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 QMESH (A, IA, MP, ML, MS, MR, MSC, MCOM, ICOM, JCOM, & CIN, RIN, IIN, KIN, IUNIT, IDUMP, N, IPOINT, COOR, IPBOUN, & ILINE, LTYPE, NINT, FACTOR, LCON, ILBOUN, ISBOUN, ISIDE, NLPS, & IFLINE, ILLIST, IBARST, JMAT, JCENT, NLPB, JFLINE, JLLIST, & IREGN, IMAT, NSPR, IFSIDE, ISLIST, IRPB, IPBF, NPPF, IFPB, & LISTPB, ILBF, NLPF, IFLB, LISTLB, ISBF, NSPF, IFSB, LISTSB, & LINKP, LINKL, LINKS, LINKB, LINKR, LINKSC, LINKPB, LINKLB, & LINKSB, RSIZE, IFHOLE, NHPR, IHLIST, IRGFLG, ISCHM, SCHEME, & DEFSCH, DEFSIZ, NPREGN, NPNBC, NPSBC, NPNODE, NPELEM, MAXKXN, & STEP, DEV1, THREE, EIGHT, NINE, LGROUP, BATCH, AMESUR, XNOLD, & YNOLD, NXKOLD, MMPOLD, LINKEG, LISTEG, BMESUR, MLINK, NPROLD, & NPNOLD, NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX, & IDIVIS, SIZMIN, EMAX, EMIN) C*********************************************************************** C QMESH: A QUADRILATERAL MESH GENERATION PROGRAM C*********************************************************************** C ORIGINALLY WRITTEN BY: C RONDALL E JONES DIV 2642 SANDIA LABORATORIES ALBUQUERQUE C REWRITTEN AND UPDATED BY: C TEDDY D. BLACKER DIV 1522 SANDIA LABORATORIES ALBUQUERQUE C DECEMBER 1985 C*********************************************************************** DIMENSION A(1), IA(1) DIMENSION IPOINT(MP), COOR(2, MP), IPBOUN(MP) DIMENSION ILINE(ML), LTYPE(ML), NINT(ML), FACTOR(ML), LCON(3, ML) DIMENSION ILBOUN(ML), ISBOUN(ML) DIMENSION ISIDE(MS), NLPS(MS), IFLINE(MS), ILLIST(MS*3) DIMENSION IBARST(MS), JMAT(MS), JCENT(MS), NLPB(MS), JFLINE(MS) DIMENSION JLLIST(MS*3) DIMENSION IREGN(MR), IMAT(MR), NSPR(MR), IFSIDE(MR), ISLIST(MR*4) DIMENSION IRPB(MR), RSIZE(MR), IFHOLE(MR), NHPR(MR), IHLIST(MR*2) DIMENSION ISCHM(MSC), SCHEME(MSC) 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 LINKP(2, MP), LINKL(2, ML), LINKS(2, MS), LINKB(2, MS) DIMENSION LINKR(2, MR), LINKSC(2, MR), LINKPB(2, MP) DIMENSION LINKLB(2, ML), LINKSB(2, ML), IRGFLG(MR) DIMENSION AMESUR(NPEOLD), XNOLD(NPNOLD), YNOLD(NPNOLD) DIMENSION NXKOLD(NNXK, NPEOLD), MMPOLD(3, NPROLD) DIMENSION LINKEG(2, MLINK), LISTEG(4 * NPEOLD), BMESUR(NPNOLD) DIMENSION N(29), CIN(MCOM), IIN(MCOM), RIN(MCOM), KIN(MCOM) DIMENSION K(30), IDUMMY(1) CHARACTER*72 SCHEME, DEFSCH, SCHSTR, CIN CHARACTER DEV1*3 LOGICAL NOROOM, EVEN, ERR, CCW, IANS, LGROUP LOGICAL RECT, REAL, STEP, TEST, REMESH LOGICAL BAR, ADDLNK, EIGHT, NINE, PENTAG, TRIANG, TRNSIT, FINAL LOGICAL HALFC, COUNT, FILL, ERRCHK, THREE, BATCH, GRAPH DATA IEXIT, IOVER, IQUIT /1, 2, 3/ C INITIALIZE IZ = 0 IPNTR = 0 IPNTR1 = 0 IPNTR2 = 0 NPREGN = 0 NPELEM = 1 NPNODE = 1 NPNBC = 1 NPSBC = 1 MAXKXN = 1 MXND = 1 MXNL = 1 MXRXG = 1 MXNPER = 1 MAXSBC = 1 MAXNBC = 1 KSBC = 1 KKSBC = 1 MAX1 = 1 MAX2 = 1 MAX3 = 1 MAX4 = 1 EVEN = .TRUE. COUNT = .TRUE. ADDLNK = .FALSE. PENTAG = .FALSE. TRIANG = .FALSE. TRNSIT = .FALSE. FILL = .FALSE. GRAPH = .FALSE. C HEADER CALL MESSAGE(' ') CALL MESSAGE('MESH PROCESSING BEGUN') CALL MESSAGE(' ') C FILL IN ANY MISSING INTERVALS ACCORDING TO SIZE AND CHECK THE C VALIDITY OF REGION DATA ERRCHK = .FALSE. DO 130 I = 1, N(9) CALL LTSORT (MR, LINKR, ABS(IRPB(I)), IPNTR1, ADDLNK) CALL LTSORT (MS, LINKB, ABS(IRPB(I)), IPNTR2, ADDLNK) IF ((IRPB(I) .GT. 0) .AND. (IRPB(I) .LE. N(22)) .AND. & (IPNTR1 .GT. 0)) THEN IF (IRGFLG(IPNTR1) .LE. -1) THEN L = IPNTR1 IF (RSIZE (L) .LE. 0.) THEN SIZE = DEFSIZ ELSE SIZE = RSIZE (L) ENDIF CALL DATAOK (MP, ML, MS, MR, L, IREGN(L), COOR, ILINE, & LTYPE, NINT, LCON, NLPS, IFLINE, ILLIST, NSPR, IFSIDE, & ISLIST, LINKP, LINKL, LINKS, SIZE, ERRCHK, ERR) IF (NHPR (L) .GT. 0) THEN DO 100 IHOLE = IFHOLE(L), IFHOLE(L) + NHPR(L) - 1 CALL LTSORT (MR, LINKR, ABS(IHLIST(IHOLE)), IPNTRH, & ADDLNK) IF (IPNTRH .GT. 0) THEN LL = IPNTRH IF (RSIZE (LL) .LE. 0.) THEN SIZE = DEFSIZ ELSE SIZE = RSIZE (LL) ENDIF CALL DATAOK (MP, ML, MS, MR, LL, IREGN(LL), & COOR, ILINE, LTYPE, NINT, LCON, NLPS, IFLINE, & ILLIST, NSPR, IFSIDE, ISLIST, LINKP, LINKL, & LINKS, SIZE, ERRCHK, ERR) ENDIF 100 CONTINUE ENDIF ELSE IF (IRGFLG(IPNTR1) .GE. 1) THEN J1 = IFSIDE(IPNTR1) J2 = J1 + NSPR(IPNTR1) - 1 IREGN(IPNTR1) = -ABS(IREGN(IPNTR1)) MXRXG = MAX(MXRXG, NSPR(IPNTR1)) DO 120 J = J1, J2 CALL LTSORT (MR, LINKR, ABS(ISLIST(J)), IPNTR1, & ADDLNK) IF (IPNTR1 .GT. 0) THEN L = IPNTR1 IF (RSIZE (L) .LE. 0.) THEN SIZE = DEFSIZ ELSE SIZE = RSIZE (L) ENDIF CALL DATAOK (MP, ML, MS, MR, L, IREGN(L), COOR, & ILINE, LTYPE, NINT, LCON, NLPS, IFLINE, ILLIST, & NSPR, IFSIDE, ISLIST, LINKP, LINKL, LINKS, & SIZE, ERRCHK, ERR) IF (NHPR (L) .GT. 0) THEN DO 110 IHOLE = IFHOLE(L), & IFHOLE(L) + NHPR(L) - 1 CALL LTSORT (MR, LINKR, ABS(IHLIST(IHOLE)), & IPNTRH, ADDLNK) IF (IPNTRH .GT. 0) THEN LL = IPNTRH IF (RSIZE (LL) .LE. 0.) THEN SIZE = DEFSIZ ELSE SIZE = RSIZE (LL) ENDIF CALL DATAOK (MP, ML, MS, MR, LL, & IREGN(LL), COOR, ILINE, LTYPE, NINT, & LCON, NLPS, IFLINE, ILLIST, NSPR, & IFSIDE, ISLIST, LINKP, LINKL, LINKS, & SIZE, ERRCHK, ERR) ENDIF 110 CONTINUE ENDIF END IF 120 CONTINUE END IF END IF 130 CONTINUE ERRCHK = .TRUE. C FIND THE MAXIMUM NUMBER OF LINES/REGION, PERIMETER POINTS/REGION, C AND HOLES/REGION DO 140 I = 1, N(2) MAX1 = MAX0(NINT(I), MAX1) 140 CONTINUE DO 150 I = 1, N(3) MAX2 = MAX0(NLPS(I), MAX2) 150 CONTINUE DO 160 I = 1, N(5) MAX2 = MAX0(NLPB(I), MAX2) 160 CONTINUE DO 170 I = 1, N(7) MAX3 = MAX0(NSPR(I), MAX3) MAX4 = MAX0(NHPR(I), MAX4) 170 CONTINUE IF (REMESH) MAX1 = MAX1 * 20 MAXNL = (MAX2 * (MAX3 + (MAX4 * MAX3))) + 1 MAXNP = (MAX1 * MAXNL) + 1 MAXPRM = 1 + MAX4 MAX3 = MAX3 + 1 C GET INITIAL SPACE IN ARRAY A FOR PERIMETER GENERATION C K(1) = X ARRAY OF THE PERIMETER C K(2) = Y ARRAY OF THE PERIMETER C K(3) = NID ARRAY OF THE PERIMETER C K(4) = LINE LIST C K(5) = NO OF NODES PER SIDE LIST C K(6) = WORK ARRAY FOR M1 GENERATION CALL MDRSRV ('X', K(1), MAXNP) CALL MDRSRV ('Y', K(2), MAXNP) CALL MDRSRV ('NID', K(3), MAXNP) CALL MDRSRV ('LISTL', K(4), MAXNL) CALL MDRSRV ('NNPS', K(5), MAX3) CALL MDRSRV ('ANGLE', K(6), MAXNP) CALL MDRSRV ('MARKED', K(26), MAXNL * 3) CALL MDSTAT (NERR, MUSED) IF (NERR .GT. 0) THEN CALL MDEROR (6) STOP ' ' END IF C LOOP THROUGH THE GROUPS/REGIONS AND BAR SETS IN THE BODY LIST C CHECK CONNECTIVITY AND CALCULATE THE DIMENSIONS NEEDED FOR MESHING C NO PERIMETER INFORMATION IS SAVED THIS TIME THROUGH REAL = .FALSE. COUNT = .TRUE. DO 210 I = 1, N(9) CALL LTSORT (MR, LINKR, ABS(IRPB(I)), IPNTR1, ADDLNK) CALL LTSORT (MS, LINKB, ABS(IRPB(I)), IPNTR2, ADDLNK) C CHECK A REGION OR GROUP IF ((IRPB(I) .GT. 0) .AND. (IRPB(I) .LE. N(22)) .AND. & (IPNTR1 .GT. 0)) THEN IF (IRGFLG(IPNTR1) .LE. -1) THEN WRITE (*, 10000) IRPB(I) L = IPNTR1 CALL CHKRGN (IA, L, MP, ML, MS, MR, MSC, N(24), IPOINT, & COOR, IPBOUN, ILINE, LTYPE, NINT, FACTOR, LCON, & ILBOUN, ISBOUN, ISIDE, NLPS, IFLINE, ILLIST, IREGN, & NSPR, IFSIDE, ISLIST, NPPF, IFPB, LISTPB, NLPF, IFLB, & LISTLB, NSPF, IFSB, LISTSB, IFHOLE, NHPR, IHLIST, & LINKP, LINKL, LINKS, LINKR, LINKSC, LINKPB, LINKLB, & LINKSB, RSIZE, SCHEME, DEFSCH, NPREGN, NPSBC, NPNODE, & MAXNP, MAXNL, MAX3, A(K(1)), A(K(2)), IA(K(3)), & IA(K(4)), IA(K(5)), A(K(6)), A(K(26)), MXND, MXNPER, & MXNL, MAXNBC, MAXSBC, AMESUR, XNOLD, YNOLD, NXKOLD, & MMPOLD, LINKEG, LISTEG, BMESUR, MLINK, NPROLD, NPNOLD, & NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX, & IDIVIS, SIZMIN, EMAX, EMIN, NOROOM, ERRCHK, ERR) ELSE IF (IRGFLG(IPNTR1) .GE. 1) THEN WRITE (*, 10010) IRPB(I) J1 = IFSIDE(IPNTR1) J2 = J1 + NSPR(IPNTR1) - 1 IREGN(IPNTR1) = -ABS(IREGN(IPNTR1)) MXRXG = MAX(MXRXG, NSPR(IPNTR1)) DO 180 J = J1, J2 CALL LTSORT (MR, LINKR, ABS(ISLIST(J)), IPNTR1, & ADDLNK) IF (IPNTR1 .GT. 0) THEN WRITE (*, 10020) ABS(ISLIST(J)) L = IPNTR1 CALL CHKRGN (IA, L, MP, ML, MS, MR, MSC, N(24), & IPOINT, COOR, IPBOUN, ILINE, LTYPE, NINT, & FACTOR, LCON, ILBOUN, ISBOUN, ISIDE, NLPS, & IFLINE, ILLIST, IREGN, NSPR, IFSIDE, ISLIST, & NPPF, IFPB, LISTPB, NLPF, IFLB, LISTLB, NSPF, & IFSB, LISTSB, IFHOLE, NHPR, IHLIST, LINKP, & LINKL, LINKS, LINKR, LINKSC, LINKPB, LINKLB, & LINKSB, RSIZE, SCHEME, DEFSCH, NPREGN, NPSBC, & NPNODE, MAXNP, MAXNL, MAX3, A(K(1)), A(K(2)), & IA(K(3)), IA(K(4)), IA(K(5)), A(K(6)), & A(K(26)), MXND, MXNPER, MXNL, MAXNBC, MAXSBC, & AMESUR, XNOLD, YNOLD, NXKOLD, MMPOLD, LINKEG, & LISTEG, BMESUR, MLINK, NPROLD, NPNOLD, NPEOLD, & NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX, & IDIVIS, SIZMIN, EMAX, EMIN, NOROOM, ERRCHK, $ ERR) END IF 180 CONTINUE END IF C WRITE AN ERROR FOR THIS REGION IN THE BODY LIST ELSE IF (IRPB(I) .GT. 0) THEN WRITE (*, 10030) IRPB(I) CALL LTSORT (MR, LINKR, ABS(IRPB(I)), IPNTR, ADDLNK) ADDLNK = .TRUE. IMINUS = -IPNTR CALL LTSORT (MR, LINKR, ABS(IRPB(I)), IMINUS, ADDLNK) ADDLNK = .FALSE. C CHECK A BAR SET ELSE IF ((IRPB(I) .LT. 0) .AND. (ABS(IRPB(I)) .LE. N(21)) & .AND. (IPNTR2 .GT. 0)) THEN L = IPNTR2 WRITE (*, 10040) ABS(IRPB(I)) REAL = .FALSE. COUNT = .TRUE. TEST = .FALSE. NPER = 1 KNBC = 1 KSBC = 1 DO 190 J = JFLINE(IPNTR2), JFLINE(IPNTR2) + NLPB(IPNTR2) - 1 CALL LTSORT (ML, LINKL, JLLIST(J), KK, ADDLNK) CALL LTSORT (MP, LINKP, LCON(1, KK), IP1, ADDLNK) CALL LTSORT (MP, LINKP, LCON(2, KK), IP2, ADDLNK) IF (LCON(3, KK) .GT. 0) THEN CALL LTSORT (MP, LINKP, LCON(3, KK), IP3, ADDLNK) ELSE IF (LCON(3, KK) .LT. 0) THEN CALL LTSORT (MP, LINKP, -LCON(3, KK), IP3, ADDLNK) IP3 = -IP3 ELSE IP3 = 0 END IF CALL PLINE (MP, ML, MAXNP, 1, 1, IPOINT, COOR, LINKP, & ILINE(KK), LTYPE(KK), NINT(KK), FACTOR(KK), IP1, IP2, & IP3, A(K(1)), A(K(2)), IA(K(3)), IPBOUN(IP1), & IPBOUN(IP2), ILBOUN(KK), ISBOUN(KK), LINKPB, NPPF, & IFPB, LISTPB, LINKLB, NLPF, IFLB, LISTLB, LINKSB, & NSPF, IFSB, LISTSB, IDUMMY, 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) THEN WRITE (*, 10050) IBARST(L) ADDLNK = .FALSE. CALL LTSORT (MS, LINKB, IRPB(I), IPNTR, ADDLNK) ADDLNK = .TRUE. IMINUS = -IPNTR CALL LTSORT (MS, LINKB, IRPB(I), IMINUS, ADDLNK) ADDLNK = .FALSE. GO TO 200 END IF NPER = NPER + NINT(KK) + 1 190 CONTINUE IBARST(L) = -IBARST(L) C WHEN CHECKING THE MAXIMUMS - ADD ENOUGH FOR ONE MORE INTERVAL C ON THE LINE AS THIS LINE MAY BE INCREMENTED BY ONE IF THE C PERIMETER IS ODD MAXNBC = MAX0(MAXNBC, KNBC + 3) MAXSBC = MAX0(MAXSBC, KSBC + 3) MXND = MAX0(MXND, NPER) MXNPER = MAX0(MXNPER, NPER + 2) C WRITE AN ERROR FOR THIS BAR SET IN THE BODY LIST ELSE WRITE (*, 10060) ABS(IRPB(I)) ADDLNK = .FALSE. CALL LTSORT (MS, LINKB, IRPB(I), IPNTR, ADDLNK) ADDLNK = .TRUE. IMINUS = -IPNTR CALL LTSORT (MS, LINKB, IRPB(I), IMINUS, ADDLNK) ADDLNK = .FALSE. END IF 200 CONTINUE 210 CONTINUE C RESET ALL USED POINTS AND LINES DO 220 I = 1, N(1) IPOINT(I) = ABS(IPOINT(I)) 220 CONTINUE DO 230 I = 1, N(2) NINT(I) = ABS(NINT(I)) 230 CONTINUE C RELEASE THE OLD ARRAYS, AND THEN C DIMENSION BASED ON THE MAXIMUMS CALCULATED CALL MDDEL ('X') CALL MDDEL ('Y') CALL MDDEL ('NID') CALL MDDEL ('LISTL') CALL MDDEL ('NNPS') CALL MDDEL ('ANGLE') CALL MDDEL ('MARKED') CALL MDSTAT (NERR, MUSED) IF (NERR .GT. 0) THEN CALL MDEROR (6) STOP ' ' END IF C K(1) = X ARRAY OF THE PERIMETER C K(2) = Y ARRAY OF THE PERIMETER C K(3) = NID ARRAY(S) OF THE PERIMETER(S) [HOLES CAUSE MULTIPLE PERIMS] C K(4) = LINE LIST C K(5) = NO OF NODES PER SIDE LIST C K(6) = WORK ARRAY FOR M1 GENERATION C K(7) = XN (GLOBAL NODAL X VALUES) C K(8) = YN (GLOBAL NODAL Y VALUES) C K(9) = NUID (GLOBAL NODE UNIQUE ID'S) C K(10) = LXK (LINES PER ELEMENT) C K(11) = KXL (ELEMENTS PER LINE) C K(12) = NXL (NODES PER LINE) C K(13) = LXN (LINES PER NODE) C K(14) = LSTNBC (LIST OF NODAL BOUNDARY FLAGS AND NODES) C K(15) = LSTSBC (LIST OF SIDE BOUNDARY FLAGS AND NODES) C K(16) = XSUB ARRAY OF THE PERIMETER OF A SUBREGION C K(17) = YSUB ARRAY OF THE PERIMETER OF A SUBREGION C K(18) = NIDSUB ARRAY OF THE PERIMETER OF A SUBREGION C K(19) = NODE NUMBERS AROUND HOLE VOID C K(20) = NUMBER OF NODES ON PERIMETERS (REGION + HOLE) C K(21) = INDEX ARRAY FOR COMBINING SUB-REGIONS AND REGIONS C K(22) = FANGLE ARRAY FOR INTERIOR ANGLE IN FILL ROUTINES C K(23) = BNSIZE ARRAY FOR SIZE DIFFERENTIAL IN FILL ROUTINES C K(24) = LNODES ARRAY FOR CONNECTIVITY OF THE INSIDE PERIMETER C NODES IN FILL ROUTINES C NOTE: LINES IN THIS CONTEXT REFERS TO CONNECTIONS OF ELEMENT NODES C MAKE ROOM IN LINE LIST FOR HOLES MXND = INT(MXND * MXRXG * 1.2) MXNL = MXNL + ( (MXRXG + MAX4) * MAX2 * MAX3) MLN = 8 MAXNB = MXNPER * MAXPRM CALL MDRSRV ('X', K(1), MXNPER) CALL MDRSRV ('Y', K(2), MXNPER) CALL MDRSRV ('NID', K(3), MXNPER * MAXPRM) CALL MDRSRV ('LISTL', K(4), MXNL) CALL MDRSRV ('NNPS', K(5), MAX3) CALL MDRSRV ('ANGLE', K(6), MXNPER) CALL MDRSRV ('XN', K(7), MXND) CALL MDRSRV ('YN', K(8), MXND) CALL MDRSRV ('NUID', K(9), MXND) CALL MDRSRV ('LXK', K(10), MXND*4) CALL MDRSRV ('KXL', K(11), MXND*6) CALL MDRSRV ('NXL', K(12), MXND*6) CALL MDRSRV ('LXN', K(13), MXND*4) CALL MDRSRV ('LSTNBC', K(14), MAXNBC) CALL MDRSRV ('LSTSBC', K(15), 2*MAXSBC) CALL MDRSRV ('XSUB', K(16), MXNPER) CALL MDRSRV ('YSUB', K(17), MXNPER) CALL MDRSRV ('NIDSUB', K(18), MXNPER) CALL MDRSRV ('NXH', K(19), MXND) CALL MDRSRV ('NPERIM', K(20), MAXPRM) CALL MDRSRV ('INDX', K(21), MXND) CALL MDRSRV ('FANGLE', K(22), MXND) CALL MDRSRV ('BNSIZE', K(23), MXND * 2) CALL MDRSRV ('LNODES', K(24), MXND * MLN) CALL MDRSRV ('PRLINK', K(25), MAXPRM * 3) CALL MDRSRV ('MARKED', K(26), MXNL * 3) CALL MDRSRV ('IPTPER', K(27), MAXPRM) CALL MDRSRV ('NUMPER', K(28), MAXPRM) CALL MDRSRV ('LPERIM', K(29), MAXNB) CALL MDRSRV ('ZN', K(30), MXND) CALL MDSTAT (NERR, MUSED) IF (NERR .GT. 0) THEN CALL MDEROR (6) STOP ' ' END IF C SET UP THE LOOP FOR PROCESSING GROUPS IF (LGROUP) THEN 240 CONTINUE IF (STEP .AND. (N(22) .GT. 0)) THEN CALL MESSAGE(' ') CALL MESSAGE('STEP PROCESS GROUPS I1 THROUGH I2') IF (ICOM .GT. JCOM) THEN CALL FREFLD (IZ, IZ, '>', MCOM, IOSTAT, JCOM, KIN, CIN, & IIN, RIN) ICOM = 1 END IF CALL GETI12 (MCOM, ICOM, JCOM, CIN, IIN, KIN, I1, I2, & IFOUND) IF (IFOUND .GT. 0) THEN CALL CHECK (I1, I2, N(22)) ELSE GO TO 320 END IF ELSE I1 = 1 I2 = N(22) END IF C BEGIN PROCESSING GROUPS REAL = .TRUE. COUNT = .FALSE. DO 310 IGRP = I1, I2 250 CONTINUE CALL LTSORT (MR, LINKR, IGRP, IGPNTR, ADDLNK) IF ((IGPNTR .GT. 0) .AND. (IRGFLG(IGPNTR) .GE. 1) & .AND. (IREGN(IGPNTR) .LT. 0)) THEN WRITE (*, 10070) IGRP J1 = IFSIDE(IGPNTR) J2 = J1 + NSPR(IGPNTR) - 1 NNN = 0 KKK = 0 LLL = 0 NNNOLD = 0 KKKOLD = 0 LLLOLD = 0 DO 270 J = J1, J2 CALL LTSORT (MR, LINKR, ABS(ISLIST(J)), IPNTR2, & ADDLNK) IF ((IPNTR2 .GT. 0) .AND. (IREGN(IPNTR2) .LT. 0)) THEN L = IPNTR2 NOROOM = .FALSE. CALL MESSAGE(' ') WRITE (*, 10080) ABS(IREGN(L)) C CALCULATE THE PERIMETER OF THE REGION 260 CONTINUE NPRM = 1 JJHOLE = 0 KNBC = 0 CALL PERIM (MP, ML, MS, NSPR(L), MXNL, MXNPER, & MAXNBC, MAXSBC, KNBC, KSBC, ABS (IREGN(L)), & IPOINT, COOR, IPBOUN, ILINE, LTYPE, NINT, & FACTOR, LCON, ILBOUN, ISBOUN, ISIDE, NLPS, & IFLINE, ILLIST, ISLIST(IFSIDE(L)), NPPF, IFPB, & LISTPB, NLPF, IFLB, LISTLB, NSPF, IFSB, LISTSB, & LINKP, LINKL, LINKS, LINKPB, LINKLB, LINKSB, & A(K(1)), A(K(2)), IA(K(3)), NPER, IA(K(4)), NL, & IA(K(14)), IA(K(26)), 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 GET THE REGION SCHEME CALL LTSORT (MR, LINKSC, ABS(IREGN(L)), IPNTR, & ADDLNK) CALL RGNSCH (MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN, & STEP, IREGN(L), IPNTR, N(24), MSC, SCHEME, & DEFSCH, SCHSTR, LENSCH, NPER, PENTAG, TRIANG, & TRNSIT, HALFC, FILL, ICODE, REMESH) IF (ICODE .EQ. IEXIT) THEN GO TO 270 ELSE IF (ICODE .EQ. IOVER) THEN GO TO 260 ELSE IF (ICODE .EQ. IQUIT) THEN GO TO 270 C GENERATE INITIAL GRID C CALCULATE A "TRANSITION" MAPPED MESH ELSE IF (TRNSIT) THEN CALL BMSCHM (NPER, KKK, LLL, NNN, ML, MS, & NSPR(L), ISLIST(IFSIDE(L)), NINT, IFLINE, & NLPS, ILLIST, LINKL, LINKS, MXNPER, MAXPRM, & MAX3, MXND, A(K(1)), A(K(2)), IA(K(3)), & IA(K(5)), A(K(6)), A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), & IA(K(13)), A(K(16)), A(K(17)), IA(K(18)), & IA(K(21)), IAVAIL, NAVAIL, CCW, HALFC, ERR) C CALCULATE A "TRIANGULAR" MAPPED MESH ELSE IF (TRIANG) THEN CALL TMSCHM (NPER, KKK, LLL, NNN, ML, MS, & NSPR(L), ISLIST(IFSIDE(L)), NINT, IFLINE, & NLPS, ILLIST, LINKL, LINKS, MXNPER, MAXPRM, & MAX3, MXND, A(K(1)), A(K(2)), IA(K(3)), & IA(K(5)), A(K(6)), A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), & IA(K(13)), A(K(16)), A(K(17)), IA(K(18)), & IA(K(21)), IAVAIL, NAVAIL, CCW, ERR) C CALCULATE A "PENTAGON" MAPPED MESH ELSE IF (PENTAG) THEN CALL UMSCHM (IA, NPER, KKK, LLL, NNN, ML, MS, & NSPR(L), ISLIST(IFSIDE(L)), NINT, IFLINE, & NLPS, ILLIST, LINKL, LINKS, MXNPER, MAXPRM, & MAX3, MXND, A(K(1)), A(K(2)), IA(K(3)), & IA(K(5)), A(K(6)), A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), & IA(K(13)), A(K(16)), A(K(17)), IA(K(18)), & IA(K(21)), IAVAIL, NAVAIL, CCW, ERR) C USE THE PAVING TECHNIQUE TO FILL THE INITIAL REGION ELSE IF (FILL) THEN CALL PMSCHM (NPER, NPRM, MXND, MLN, MP, ML, MS, & MR, NL, MXNL, MXNPER, 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, & A(K(1)), A(K(2)), IA(K(3)), IA(K(4)), & A(K(7)), A(K(8)), A(K(30)), IA(K(9)), & IA(K(10)), IA(K(11)), IA(K(12)), IA(K(13)), & IA(K(14)), IA(K(20)), A(K(22)), A(K(23)), & IA(K(24)), IA(K(25)), IA(K(26)), IA(K(27)), & IA(K(28)), IA(K(29)), KKK, NNN, LLL, IAVAIL, & NAVAIL, DEV1, ABS(IREGN(L)), L, 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) IF (NOROOM) THEN MXND = INT(MXND*1.5 + 1) MAXNBC = MAX0 (MAXNBC, KNBC) MAXSBC = MAX0 (MAXSBC, KSBC) KSBC = KKSBC CALL MDLONG ('XN', K(7), MXND) CALL MDLONG ('YN', K(8), MXND) CALL MDLONG ('ZN', K(30), MXND) CALL MDLONG ('NUID', K(9), MXND) CALL MDLONG ('LXK', K(10), MXND*4) CALL MDLONG ('KXL', K(11), MXND*6) CALL MDLONG ('NXL', K(12), MXND*6) CALL MDLONG ('LXN', K(13), MXND*4) CALL MDLONG ('LSTNBC', K(14), MAXNBC) CALL MDLONG ('LSTSBC', K(15), MAXSBC) CALL MDLONG ('NXH', K(19), MXND) CALL MDLONG ('INDX', K(21), MXND) CALL MDLONG ('FANGLE', K(22), MXND) CALL MDLONG ('BNSIZE', K(23), MXND * 2) CALL MDLONG ('LNODES', K(24), MXND * MLN) CALL MDSTAT (NERR, MUSED) IF (NERR .GT. 0) THEN CALL MDEROR (6) STOP ' ' END IF CALL MESSAGE & ('REDIMENSIONING NEEDED - PLEASE WAIT') IF (STEP) THEN CALL MESSAGE & ('CURRENT PROCESSING SCHEME IS SAVED') ELSE CALL MESSAGE & ('CURRENT SCHEME WILL BE REPEATED') END IF GO TO 260 END IF C PROCESS A "NORMAL" REGION ELSE CALL MMSCHM (NPER, KKK, LLL, NNN, ML, MS, & NSPR(L), ISLIST(IFSIDE(L)), NINT, IFLINE, & NLPS, ILLIST, LINKL, LINKS, MXNPER, MAXPRM, & MAX3, MXND, A(K(1)), A(K(2)), IA(K(3)), & IA(K(5)), A(K(6)), A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), & IA(K(13)), IAVAIL, NAVAIL, CCW, REAL, SCHSTR, & M1, ERR) END IF C FLAG THE REGION IF AN ERROR HAS OCCURRED IF (ERR) THEN CALL MESSAGE('ERROR IN INITIAL GRID GENERATION') CALL MESSAGE('** REGION PROCESSING ABORTED **') CALL PLTBEL CALL PLTFLU CALL MESSAGE(' ') IREGN(L) = ABS(IREGN(L)) IF (ISLIST(J) .EQ. IREGN(L)) THEN ADDLNK = .TRUE. IMINUS = -L CALL LTSORT (MR, LINKR, IREGN(L), IMINUS, & ADDLNK) ADDLNK = .FALSE. END IF GO TO 270 END IF C BEGIN FULL SCHEME CONTROL FOR A GROUP SUB-REGION RECT = .NOT.(PENTAG .OR. TRIANG .OR. & TRNSIT .OR. FILL) IF (STEP) CALL MINMAX_FQ (MXNPER, NPER, A(K(1)), & A(K(2)), XMIN, XMAX, YMIN, YMAX) CALL PSCHEM (MP, ML, MS, MR, N, IPOINT, COOR, & IPBOUN, ILINE, LTYPE, NINT, FACTOR, LCON, & ILBOUN, ISBOUN, ISIDE, NLPS, IFLINE, ILLIST, & IREGN, NSPR, IFSIDE, ISLIST, NPPF, IFPB, LISTPB, & NLPF, IFLB, LISTLB, NSPF, IFSB, LISTSB, LINKP, & LINKL, LINKS, LINKR, LINKSC, LINKPB, LINKLB, & LINKSB, IFHOLE, NHPR, IHLIST, MAXNBC, KNBC, & MAXSBC, KSBC, MXND, NNN, NNNOLD, KKK, KKKOLD, & LLL, A(K(1)), A(K(2)), IA(K(3)), IA(K(4)), & A(K(7)), A(K(8)), IA(K(9)), IA(K(10)), & IA(K(11)), IA(K(12)), IA(K(13)), IA(K(14)), & IA(K(19)), IA(K(20)), IA(K(26)), IAVAIL, NAVAIL, & MXNL, MXNPER, NPER, MAXPRM, NPRM, MSC, ISCHM, & SCHEME, SCHSTR, RECT, M1, INSIDE, JJHOLE, KKSBC, & DEV1, EIGHT, NINE, STEP, L, NL, MCOM, CIN, IIN, & RIN, KIN, ICOM, JCOM, XMIN, XMAX, YMIN, YMAX, & ICODE, NOROOM, ERR, AMESUR, XNOLD, YNOLD,NXKOLD, & MMPOLD, LINKEG, LISTEG, BMESUR, MLINK, NPROLD, & NPNOLD, NPEOLD, NNXK, REMESH, REXMIN, REXMAX, & REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX, EMIN) IF (NOROOM) THEN MXND = INT(MXND*1.2 + 1) MAXNBC = MAX0 (MAXNBC, KNBC) MAXSBC = MAX0 (MAXSBC, KSBC) KSBC = KKSBC CALL MDLONG ('XN', K(7), MXND) CALL MDLONG ('YN', K(8), MXND) CALL MDLONG ('ZN', K(30), MXND) CALL MDLONG ('NUID', K(9), MXND) CALL MDLONG ('LXK', K(10), MXND*4) CALL MDLONG ('KXL', K(11), MXND*6) CALL MDLONG ('NXL', K(12), MXND*6) CALL MDLONG ('LXN', K(13), MXND*4) CALL MDLONG ('LSTNBC', K(14), MAXNBC) CALL MDLONG ('LSTSBC', K(15), MAXSBC) CALL MDLONG ('NXH', K(19), MXND) CALL MDLONG ('INDX', K(21), MXND) CALL MDLONG ('FANGLE', K(22), MXND) CALL MDLONG ('BNSIZE', K(23), MXND * 2) CALL MDLONG ('LNODES', K(24), MXND * MLN) CALL MDSTAT (NERR, MUSED) IF (NERR .GT. 0) THEN CALL MDEROR (6) STOP ' ' END IF CALL MESSAGE & ('REDIMENSIONING NEEDED - PLEASE WAIT') IF (STEP) THEN CALL MESSAGE & ('CURRENT PROCESSING SCHEME IS SAVED') ELSE CALL MESSAGE & ('CURRENT SCHEME WILL BE REPEATED') END IF GO TO 260 ELSE IF (ERR) THEN IF (STEP) THEN CALL INTRUP & ('WOULD YOU LIKE TO REPROCESS REGION', & IANS, MCOM, ICOM, JCOM, CIN, IIN, RIN, & KIN) NNN = NNNOLD KKK = KKKOLD LLL = LLLOLD IF (IANS) GO TO 260 END IF CALL MESSAGE('REGION PROCESSING ABORTED') GO TO 270 ELSE IF (ICODE .EQ. IEXIT) THEN FINAL = J .EQ. J2 IF (J .GT. J1) THEN CALL FIXSUB (MXND, NNNOLD, NNN, LLLOLD, LLL, & KKKOLD, KKK, A(K(7)), A(K(8)), IA(K(9)), & IA(K(10)), IA(K(11)), IA(K(12)), & IA(K(13)), IA(K(21)), IAVAIL, NAVAIL, & FINAL) END IF NNNOLD = NNN LLLOLD = LLL KKKOLD = KKK IF (FINAL) CALL FXNUID (NSPR(IGPNTR), & ISLIST(IFSIDE(IGPNTR)), MR, MS, ML, NSPR, & ILINE, ISIDE, NLPS, IFLINE, ILLIST, LCON, & ISLIST, IFSIDE, LINKR, LINKS, LINKL, NNN, & MXNL, MXND, IA(K(4)), IA(K(9)), IA(K(12)), & IA(K(13)), IA(K(21)), NOROOM, ERR) IF (ERR) THEN CALL MESSAGE & ('GROUP SCHEME PROCESSING NOT POSSIBLE') CALL MESSAGE('GROUP PROCESSING ABORTED') GO TO 300 END IF ELSE IF (ICODE .EQ. IOVER) THEN NNN = NNNOLD KKK = KKKOLD LLL = LLLOLD GO TO 260 ELSE IF (ICODE .EQ. IQUIT) THEN NNN = NNNOLD KKK = KKKOLD LLL = LLLOLD GO TO 270 END IF END IF 270 CONTINUE C BEGIN FULL SCHEME CONTROL FOR A GROUP REGION NNNOLD = 0 KKKOLD = 0 RECT = .FALSE. CALL MESSAGE(' ') CALL MESSAGE('GROUP SCHEME PROCESSING BEGUN') CALL LTSORT (MR, LINKSC, ABS(IREGN(IGPNTR)), IPNTR, & ADDLNK) CALL RGNSCH (MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN, STEP, & IREGN(IGPNTR), IPNTR, N(24), MSC, SCHEME, DEFSCH, & SCHSTR, LENSCH, NPER, PENTAG, TRIANG, TRNSIT, HALFC, & FILL, ICODE, REMESH) IF (ICODE .EQ. IEXIT) THEN CALL CHKKXL (MXND, IA(K(10)), IA(K(11)), LLL, ERR) IF (ERR) THEN CALL MESSAGE('ERROR IN CHECK OF KXL ARRAY') IF (STEP) THEN CALL INTRUP & ('WOULD YOU LIKE TO REPROCESS GROUP', & IANS, MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN) IF (IANS) GO TO 250 END IF CALL MESSAGE('GROUP PROCESSING ABORTED') GO TO 300 END IF BAR = .FALSE. KSBC = 0 CALL GETSBC (MXND, MXNPER, NPER, NL, ML, MAXSBC, & MAXPRM, NPRM, IA(K(3)), IA(K(4)), A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), & IA(K(15)), IA(K(20)), KSBC, LCON, ISBOUN, LINKL, & NSPF, IFSB, LISTSB, LINKSB, LLL, BAR, ERR) IF (ERR) THEN CALL MESSAGE('ERROR IN SORTING SIDE BOUNDARIES') IF (STEP) THEN CALL INTRUP & ('WOULD YOU LIKE TO REPROCESS GROUP', & IANS, MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN) IF (IANS) GO TO 250 END IF CALL MESSAGE('GROUP PROCESSING ABORTED') GO TO 300 END IF CALL MKUSED (MXNL, MP, ML, IA(K(4)), IPOINT, NINT, & LINKP, LINKL, LCON, NL) CALL SAVREG (MXND, MAXNBC, MAXSBC, A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(12)), IA(K(13)), & IA(K(14)), IA(K(15)), KNBC, KSBC, NNN, KKK, IGRP, & IUNIT, BAR, M1) DO 280 J = J1, J2 CALL LTSORT (MR, LINKR, ABS(ISLIST(J)), IPNTR2, & ADDLNK) IREGN(IPNTR2) = ABS(IREGN(IPNTR2)) 280 CONTINUE NPREGN = NPREGN + 1 NPELEM = NPELEM + KKK NPNODE = NPNODE + NNN IF (EIGHT .OR. NINE) NPNODE = NPNODE + LLL IF (NINE) NPNODE = NPNODE + KKK NPNBC = NPNBC + KNBC IF (THREE .OR. EIGHT .OR. NINE) & NPNBC = NPNBC + KNBC NPSBC = NPSBC + KSBC IF (THREE .OR. EIGHT .OR. NINE) & NPSBC = NPSBC + KSBC MAXKXN = MAXKXN + LLL IREGN(IGPNTR) = ABS(IREGN(IGPNTR)) WRITE (*, 10100) IREGN(IGPNTR) GO TO 300 ELSE IF (ICODE .EQ. IOVER) THEN GO TO 250 ELSE IF (ICODE .EQ. IQUIT) THEN GO TO 300 END IF IF (STEP) CALL MINMAX_FQ (MXND, NNN, A(K(7)), A(K(8)), & XMIN, XMAX, YMIN, YMAX) CALL PSCHEM (MP, ML, MS, MR, N, IPOINT, COOR, IPBOUN, & ILINE, LTYPE, NINT, FACTOR, LCON, ILBOUN, ISBOUN, & ISIDE, NLPS, IFLINE, ILLIST, IREGN, NSPR, IFSIDE, & ISLIST, NPPF, IFPB, LISTPB, NLPF, IFLB, LISTLB, NSPF, & IFSB, LISTSB, LINKP, LINKL, LINKS, LINKR, LINKSC, & LINKPB, LINKLB, LINKSB, IFHOLE, NHPR, IHLIST, MAXNBC, & KNBC, MAXSBC, KSBC, MXND, NNN, NNNOLD, KKK, KKKOLD, & LLL, A(K(1)), A(K(2)), IA(K(3)), IA(K(4)), A(K(7)), & A(K(8)), IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), & IA(K(13)), IA(K(14)), IA(K(19)), IA(K(20)), IA(K(26)), & IAVAIL, NAVAIL, MXNL, MXNPER, NPER, MAXPRM, NPRM, MSC, & ISCHM, SCHEME, SCHSTR, RECT, M1, INSIDE, JJHOLE, & KKSBC, DEV1, EIGHT, NINE, STEP, IGPNTR, NL, MCOM, CIN, & IIN, RIN, KIN, ICOM, JCOM, XMIN, XMAX, YMIN, YMAX, & ICODE, NOROOM, ERR, AMESUR, XNOLD, YNOLD, NXKOLD, & MMPOLD, LINKEG, LISTEG, BMESUR, MLINK, NPROLD, NPNOLD, & NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX, & IDIVIS, SIZMIN, EMAX, EMIN) IF (NOROOM) THEN MXND = INT(MXND*1.2 + 1) MAXNBC = MAX0 (MAXNBC, KNBC) MAXSBC = MAX0 (MAXSBC, KSBC) KSBC = KKSBC CALL MDLONG ('XN', K(7), MXND) CALL MDLONG ('YN', K(8), MXND) CALL MDLONG ('ZN', K(30), MXND) CALL MDLONG ('NUID', K(9), MXND) CALL MDLONG ('LXK', K(10), MXND*4) CALL MDLONG ('KXL', K(11), MXND*6) CALL MDLONG ('NXL', K(12), MXND*6) CALL MDLONG ('LXN', K(13), MXND*4) CALL MDLONG ('LSTNBC', K(14), MAXNBC) CALL MDLONG ('LSTSBC', K(15), MAXSBC) CALL MDLONG ('NXH', K(19), MXND) CALL MDLONG ('INDX', K(21), MXND) CALL MDLONG ('FANGLE', K(22), MXND) CALL MDLONG ('BNSIZE', K(23), MXND * 2) CALL MDLONG ('LNODES', K(24), MXND * MLN) CALL MDSTAT (NERR, MUSED) IF (NERR .GT. 0) THEN CALL MDEROR (6) STOP ' ' END IF CALL MESSAGE & ('REDIMENSIONING NEEDED - PLEASE WAIT') IF (STEP) THEN CALL MESSAGE('CURRENT PROCESSING SCHEME IS SAVED') ELSE CALL MESSAGE('CURRENT SCHEME WILL BE REPEATED') END IF GO TO 250 ELSE IF (ERR) THEN IF (STEP) THEN CALL INTRUP ('WOULD YOU LIKE TO REPROCESS GROUP', & IANS, MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN) IF (IANS) GO TO 250 END IF CALL MESSAGE('GROUP PROCESSING ABORTED') GO TO 300 ELSE IF (ICODE .EQ. IEXIT) THEN CALL CHKKXL (MXND, IA(K(10)), IA(K(11)), LLL, ERR) IF (ERR) THEN CALL MESSAGE('ERROR IN CHECK OF KXL ARRAY') IF (STEP) THEN CALL INTRUP & ('WOULD YOU LIKE TO REPROCESS GROUP', & IANS, MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN) IF (IANS) GO TO 250 END IF CALL MESSAGE('GROUP PROCESSING ABORTED') GO TO 300 END IF BAR = .FALSE. KSBC = 0 CALL GETSBC (MXND, MXNPER, NPER, NL, ML, MAXSBC, & MAXPRM, NPRM, IA(K(3)), IA(K(4)), A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), & IA(K(15)), IA(K(20)), KSBC, LCON, ISBOUN, LINKL, & NSPF, IFSB, LISTSB, LINKSB, LLL, BAR, ERR) IF (ERR) THEN CALL MESSAGE('ERROR IN SORTING SIDE BOUNDARIES') IF (STEP) THEN CALL INTRUP & ('WOULD YOU LIKE TO REPROCESS GROUP', & IANS, MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN) IF (IANS) GO TO 250 END IF CALL MESSAGE('GROUP PROCESSING ABORTED') GO TO 300 END IF CALL MKUSED (MXNL, MP, ML, IA(K(4)), IPOINT, NINT, & LINKP, LINKL, LCON, NL) CALL SAVREG (MXND, MAXNBC, MAXSBC, A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(12)), IA(K(13)), & IA(K(14)), IA(K(15)), KNBC, KSBC, NNN, KKK, IGRP, & IUNIT, BAR, M1) DO 290 J = J1, J2 CALL LTSORT (MR, LINKR, ABS(ISLIST(J)), IPNTR2, & ADDLNK) IREGN(IPNTR2) = ABS(IREGN(IPNTR2)) 290 CONTINUE NPREGN = NPREGN + 1 NPELEM = NPELEM + KKK NPNODE = NPNODE + NNN IF (EIGHT .OR. NINE) NPNODE = NPNODE + LLL IF (NINE) NPNODE = NPNODE + KKK NPNBC = NPNBC + KNBC IF (THREE .OR. EIGHT .OR. NINE) & NPNBC = NPNBC + KNBC NPSBC = NPSBC + KSBC IF (THREE .OR. EIGHT .OR. NINE) & NPSBC = NPSBC + KSBC MAXKXN = MAXKXN + LLL IREGN(IGPNTR) = ABS(IREGN(IGPNTR)) WRITE (*, 10100) IREGN(IGPNTR) ELSE IF (ICODE .EQ. IOVER) THEN GO TO 250 ELSE IF (ICODE .EQ. IQUIT) THEN GO TO 300 END IF END IF 300 CONTINUE 310 CONTINUE C END OF THIS SET OF GROUPS C IF STEPPING THROUGH, SEE IF ANY MORE GROUPS C ARE TO BE PROCESSED IF (STEP) THEN CALL INTRUP ('PROCESS ADDITIONAL GROUPS', IANS, MCOM, & ICOM, JCOM, CIN, IIN, RIN, KIN) IF (IANS) GO TO 240 END IF END IF C SET UP THE LOOP FOR PROCESSING REGIONS 320 CONTINUE IF (STEP .AND. (N(22) .GT. 0)) THEN CALL MESSAGE(' ') CALL MESSAGE('STEP PROCESS REGIONS I1 THROUGH I2') IF (ICOM .GT. JCOM) THEN CALL FREFLD (IZ, IZ, '>', MCOM, IOSTAT, JCOM, KIN, CIN, IIN, & RIN) ICOM = 1 END IF CALL GETI12 (MCOM, ICOM, JCOM, CIN, IIN, KIN, I1, I2, IFOUND) IF (IFOUND .GT. 0) THEN CALL CHECK (I1, I2, N(22)) ELSE GO TO 370 END IF ELSE I1 = 1 I2 = N(22) END IF C BEGIN PROCESSING REGIONS REAL = .TRUE. COUNT = .FALSE. DO 350 I = I1, I2 CALL LTSORT (MR, LINKR, I, L, ADDLNK) IF (L .GT. 0) THEN IF (IREGN(L) .LT. 0) THEN NOROOM = .FALSE. CALL MESSAGE(' ') WRITE (*, 10090) ABS(IREGN(L)) C CALCULATE THE PERIMETER OF THE REGION 330 CONTINUE NNN = 0 KKK = 0 LLL = 0 NPRM = 1 JJHOLE = 0 KNBC = 0 CALL PERIM (MP, ML, MS, NSPR(L), MXNL, MXNPER, MAXNBC, & MAXSBC, KNBC, KSBC, ABS (IREGN(L)), IPOINT, COOR, IPBOUN, & ILINE, LTYPE, NINT, FACTOR, LCON, ILBOUN, ISBOUN, ISIDE, & NLPS, IFLINE, ILLIST, ISLIST(IFSIDE(L)), NPPF, IFPB, & LISTPB, NLPF, IFLB, LISTLB, NSPF, IFSB, LISTSB, LINKP, & LINKL, LINKS, LINKPB, LINKLB, LINKSB, A(K(1)), A(K(2)), & IA(K(3)), NPER, IA(K(4)), NL, IA(K(14)), IA(K(26)), 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 GET THE REGION SCHEME CALL LTSORT (MR, LINKSC, ABS(IREGN(L)), IPNTR, ADDLNK) CALL RGNSCH (MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN, STEP, & IREGN(L), IPNTR, N(24), MSC, SCHEME, DEFSCH, SCHSTR, & LENSCH, NPER, PENTAG, TRIANG, TRNSIT, HALFC, FILL, ICODE, & REMESH) IF (ICODE .EQ. IEXIT) THEN GO TO 360 ELSE IF (ICODE .EQ. IOVER) THEN GO TO 330 ELSE IF (ICODE .EQ. IQUIT) THEN GO TO 350 C GENERATE INITIAL GRID C CALCULATE A "TRANSITION" MAPPED MESH ELSE IF (TRNSIT) THEN CALL BMSCHM (NPER, KKK, LLL, NNN, ML, MS, NSPR(L), & ISLIST(IFSIDE(L)), NINT, IFLINE, NLPS, ILLIST, LINKL, & LINKS, MXNPER, MAXPRM, MAX3, MXND, A(K(1)), A(K(2)), & IA(K(3)), IA(K(5)), A(K(6)), A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), IA(K(13)), & A(K(16)), A(K(17)), IA(K(18)), IA(K(21)), IAVAIL, & NAVAIL, CCW, HALFC, ERR) C CALCULATE A "TRIANGULAR" MAPPED MESH ELSE IF (TRIANG) THEN CALL TMSCHM (NPER, KKK, LLL, NNN, ML, MS, NSPR(L), & ISLIST(IFSIDE(L)), NINT, IFLINE, NLPS, ILLIST, LINKL, & LINKS, MXNPER, MAXPRM, MAX3, MXND, A(K(1)), A(K(2)), & IA(K(3)), IA(K(5)), A(K(6)), A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), IA(K(13)), & A(K(16)), A(K(17)), IA(K(18)), IA(K(21)), IAVAIL, & NAVAIL, CCW, ERR) C CALCULATE A "PENTAGON" MAPPED MESH ELSE IF (PENTAG) THEN CALL UMSCHM (IA, NPER, KKK, LLL, NNN, ML, MS, NSPR(L), & ISLIST(IFSIDE(L)), NINT, IFLINE, NLPS, ILLIST, LINKL, & LINKS, MXNPER, MAXPRM, MAX3, MXND, A(K(1)), A(K(2)), & IA(K(3)), IA(K(5)), A(K(6)), A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), IA(K(13)), & A(K(16)), A(K(17)), IA(K(18)), IA(K(21)), IAVAIL, & NAVAIL, CCW, ERR) C USE THE PAVING TECHNIQUE TO FILL THE INITIAL REGION ELSE IF (FILL) THEN CALL PMSCHM (NPER, NPRM, MXND, MLN, MP, ML, MS, MR, NL, & MXNL, MXNPER, 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, A(K(1)), A(K(2)), IA(K(3)), & IA(K(4)), A(K(7)), A(K(8)), A(K(30)), IA(K(9)), & IA(K(10)), IA(K(11)), IA(K(12)), IA(K(13)), IA(K(14)), & IA(K(20)), A(K(22)), A(K(23)), IA(K(24)), IA(K(25)), & IA(K(26)), IA(K(27)), IA(K(28)), IA(K(29)), KKK, NNN, & LLL, IAVAIL, NAVAIL, DEV1, ABS(IREGN(L)), L, 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) IF (NOROOM) THEN MXND = INT(MXND*1.5 + 1) MAXNBC = MAX0 (MAXNBC, KNBC) MAXSBC = MAX0 (MAXSBC, KSBC) KSBC = KKSBC CALL MDLONG ('XN', K(7), MXND) CALL MDLONG ('YN', K(8), MXND) CALL MDLONG ('ZN', K(30), MXND) CALL MDLONG ('NUID', K(9), MXND) CALL MDLONG ('LXK', K(10), MXND*4) CALL MDLONG ('KXL', K(11), MXND*6) CALL MDLONG ('NXL', K(12), MXND*6) CALL MDLONG ('LXN', K(13), MXND*4) CALL MDLONG ('LSTNBC', K(14), MAXNBC) CALL MDLONG ('LSTSBC', K(15), MAXSBC) CALL MDLONG ('NXH', K(19), MXND) CALL MDLONG ('INDX', K(21), MXND) CALL MDLONG ('FANGLE', K(22), MXND) CALL MDLONG ('BNSIZE', K(23), MXND * 2) CALL MDLONG ('LNODES', K(24), MXND * MLN) CALL MDSTAT (NERR, MUSED) IF (NERR .GT. 0) THEN CALL MDEROR (6) STOP ' ' END IF CALL MESSAGE & ('REDIMENSIONING NEEDED - PLEASE WAIT') IF (STEP) THEN CALL MESSAGE & ('CURRENT PROCESSING SCHEME IS SAVED') ELSE CALL MESSAGE & ('CURRENT SCHEME WILL BE REPEATED') END IF GO TO 330 END IF C PROCESS A "NORMAL" REGION ELSE CALL MMSCHM (NPER, KKK, LLL, NNN, ML, MS, NSPR(L), & ISLIST(IFSIDE(L)), NINT, IFLINE, NLPS, ILLIST, LINKL, & LINKS, MXNPER, MAXPRM, MAX3, MXND, A(K(1)), A(K(2)), & IA(K(3)), IA(K(5)), A(K(6)), A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), IA(K(13)), & IAVAIL, NAVAIL, CCW, REAL, SCHSTR, M1, ERR) END IF C FLAG THE REGION IF AN ERROR HAS OCCURRED IF (ERR) THEN CALL MESSAGE('ERROR IN INITIAL GRID GENERATION') CALL MESSAGE('** REGION PROCESSING ABORTED **') CALL MESSAGE(' ') CALL PLTBEL CALL PLTFLU IREGN(L) = ABS(IREGN(L)) DO 340 J = 1, N(9) IF (IRPB(J) .EQ. IREGN(L)) THEN ADDLNK = .TRUE. IMINUS = -L CALL LTSORT (MR, LINKR, IREGN(L), IMINUS, & ADDLNK) ADDLNK = .FALSE. END IF 340 CONTINUE GO TO 350 END IF C BEGIN FULL SCHEME CONTROL RECT = .NOT.(PENTAG .OR. TRIANG .OR. TRNSIT .OR. FILL) IF (STEP) CALL MINMAX_FQ (MXNPER, NPER, A(K(1)), A(K(2)), * XMIN, XMAX, YMIN, YMAX) NNNOLD = 0 KKKOLD = 0 CALL PSCHEM (MP, ML, MS, MR, N, IPOINT, COOR, IPBOUN, ILINE, & LTYPE, NINT, FACTOR, LCON, ILBOUN, ISBOUN, ISIDE, NLPS, & IFLINE, ILLIST, IREGN, NSPR, IFSIDE, ISLIST, NPPF, IFPB, & LISTPB, NLPF, IFLB, LISTLB, NSPF, IFSB, LISTSB, LINKP, & LINKL, LINKS, LINKR, LINKSC, LINKPB, LINKLB, LINKSB, & IFHOLE, NHPR, IHLIST, MAXNBC, KNBC, MAXSBC, KSBC, MXND, & NNN, NNNOLD, KKK, KKKOLD, LLL, A(K(1)), A(K(2)), & IA(K(3)), IA(K(4)), A(K(7)), A(K(8)), IA(K(9)), & IA(K(10)), IA(K(11)), IA(K(12)), IA(K(13)), IA(K(14)), & IA(K(19)), IA(K(20)), IA(K(26)), IAVAIL, NAVAIL, MXNL, & MXNPER, NPER, MAXPRM, NPRM, MSC, ISCHM, SCHEME, SCHSTR, & RECT, M1, INSIDE, JJHOLE, KKSBC, DEV1, EIGHT, NINE, STEP, & L, NL, MCOM, CIN, IIN, RIN, KIN, ICOM, JCOM, XMIN, XMAX, & YMIN, YMAX, ICODE, NOROOM, ERR, AMESUR, XNOLD, YNOLD, & NXKOLD, MMPOLD, LINKEG, LISTEG, BMESUR, MLINK, NPROLD, & NPNOLD, NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, & REYMAX, IDIVIS, SIZMIN, EMAX, EMIN) IF (NOROOM) THEN MXND = INT(MXND*1.2 + 1) MAXNBC = 2*MAX0 (MAXNBC, KNBC) MAXSBC = 2*MAX0 (MAXSBC, KSBC) KSBC = KKSBC CALL MDLONG ('XN', K(7), MXND) CALL MDLONG ('YN', K(8), MXND) CALL MDLONG ('ZN', K(30), MXND) CALL MDLONG ('NUID', K(9), MXND) CALL MDLONG ('LXK', K(10), MXND*4) CALL MDLONG ('KXL', K(11), MXND*6) CALL MDLONG ('NXL', K(12), MXND*6) CALL MDLONG ('LXN', K(13), MXND*4) CALL MDLONG ('LSTNBC', K(14), MAXNBC) CALL MDLONG ('LSTSBC', K(15), MAXSBC) CALL MDLONG ('NXH', K(19), MXND) CALL MDLONG ('INDX', K(21), MXND) CALL MDLONG ('FANGLE', K(22), MXND) CALL MDLONG ('BNSIZE', K(23), MXND * 2) CALL MDLONG ('LNODES', K(24), MXND * MLN) CALL MDSTAT (NERR, MUSED) IF (NERR .GT. 0) THEN CALL MDEROR (6) STOP ' ' END IF CALL MESSAGE & ('REDIMENSIONING NEEDED - PLEASE WAIT') IF (STEP) THEN CALL MESSAGE('CURRENT PROCESSING SCHEME IS SAVED') ELSE CALL MESSAGE('CURRENT SCHEME WILL BE REPEATED') END IF GO TO 330 ELSE IF (ERR) THEN IF (STEP) THEN CALL INTRUP ('WOULD YOU LIKE TO REPROCESS REGION', & IANS, MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN) IF (IANS) GO TO 330 END IF CALL MESSAGE('REGION PROCESSING ABORTED') GO TO 350 ELSE IF (ICODE .EQ. IEXIT) THEN CALL CHKKXL (MXND, IA(K(10)), IA(K(11)), LLL, ERR) IF (ERR) THEN CALL MESSAGE('ERROR IN CHECK OF KXL ARRAY') IF (STEP) THEN CALL INTRUP ('WOULD YOU LIKE TO REPROCESS REGION', & IANS, MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN) IF (IANS) GO TO 330 END IF CALL MESSAGE('REGION PROCESSING ABORTED') GO TO 350 END IF BAR = .FALSE. KSBC = 0 CALL GETSBC (MXND, MXNPER, NPER, NL, ML, MAXSBC, MAXPRM, & NPRM, IA(K(3)), IA(K(4)), A(K(7)), A(K(8)), IA(K(9)), & IA(K(10)), IA(K(11)), IA(K(12)), IA(K(15)), IA(K(20)), & KSBC, LCON, ISBOUN, LINKL, NSPF, IFSB, LISTSB, LINKSB, & LLL, BAR, ERR) IF (ERR) THEN CALL MESSAGE('ERROR IN SORTING SIDE BOUNDARIES') IF (STEP) THEN CALL INTRUP ('WOULD YOU LIKE TO REPROCESS REGION', & IANS, MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN) IF (IANS) GO TO 330 END IF CALL MESSAGE('REGION PROCESSING ABORTED') GO TO 350 END IF CALL MKUSED (MXNL, MP, ML, IA(K(4)), IPOINT, NINT, LINKP, & LINKL, LCON, NL) CALL SAVREG (MXND, MAXNBC, MAXSBC, A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(12)), IA(K(13)), IA(K(14)), & IA(K(15)), KNBC, KSBC, NNN, KKK, ABS(IREGN(L)), IUNIT, & BAR, M1) IREGN(L) = ABS(IREGN(L)) NPREGN = NPREGN + 1 NPELEM = NPELEM + KKK NPNODE = NPNODE + NNN IF (EIGHT .OR. NINE) NPNODE = NPNODE + LLL IF (NINE) NPNODE = NPNODE + KKK NPNBC = NPNBC + KNBC IF (THREE .OR. EIGHT .OR. NINE) & NPNBC = NPNBC + KNBC NPSBC = NPSBC + KSBC IF (THREE .OR. EIGHT .OR. NINE) & NPSBC = NPSBC + KSBC MAXKXN = MAXKXN + LLL IREGN(L) = ABS(IREGN(L)) WRITE (*, 10110) IREGN(L) ELSE IF (ICODE .EQ. IOVER) THEN GO TO 330 ELSE IF (ICODE .EQ. IQUIT) THEN GO TO 350 END IF END IF END IF 350 CONTINUE C END OF THIS SET OF REGIONS C IF STEPPING THROUGH, SEE IF ANY MORE REGIONS C ARE TO BE PROCESSED 360 CONTINUE IF (STEP) THEN CALL INTRUP ('PROCESS ADDITIONAL REGIONS', IANS, MCOM, & ICOM, JCOM, CIN, IIN, RIN, KIN) IF (IANS) GO TO 320 END IF C SET UP THE LOOP FOR PROCESSING BAR SETS 370 CONTINUE 380 CONTINUE IF (STEP .AND. (N(21) .GT. 0)) THEN CALL MESSAGE('STEP PROCESS BAR SETS I1 THROUGH I2') IF (ICOM .GT. JCOM) THEN CALL FREFLD (IZ, IZ, '>', MCOM, IOSTAT, JCOM, KIN, CIN, IIN, & RIN) ICOM = 1 END IF CALL GETI12 (MCOM, ICOM, JCOM, CIN, IIN, KIN, I1, I2, IFOUND) IF (IFOUND .GT. 0) THEN CALL CHECK (I1, I2, N(21)) ELSE GO TO 450 END IF ELSE I1 = 1 I2 = N(21) END IF C BEGIN PROCESSING BAR SETS REAL = .TRUE. COUNT = .FALSE. DO 440 I = I1, I2 CALL LTSORT (MS, LINKB, I, IPNTR, ADDLNK) C SEE IF THIS BAR SET IS FOR SPRINGS IF (IPNTR .GT. 0) THEN IF ((IBARST(IPNTR) .LT. 0) .AND. (JMAT(IPNTR) .LT. 0)) THEN L = IPNTR WRITE (*, 10130) ABS(IBARST(L)) CALL SPRING (MP, ML, MS, MXNPER, MXND, MAXNBC, MAXSBC, L, & IPOINT, COOR, IPBOUN, LINKP, ILINE, LTYPE, NINT, FACTOR, & LCON, ILBOUN, ISBOUN, LINKL, NLPB, JFLINE, JLLIST, & LINKPB, NPPF, IFPB, LISTPB, LINKLB, NLPF, IFLB, LISTLB, & LINKSB, NSPF, IFSB, LISTSB, LSTNBC, A(K(1)), A(K(2)), & IA(K(3)), A(K(7)), A(K(8)), IA(K(9)), IA(K(10)), NNN, & KKK, LLL, KNBC, KSBC, ERR, ADDLNK, 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) IF (ERR) THEN CALL MESSAGE('ERROR IN 2-NODE SPRING ELEMENT '// & 'GENERATION') CALL MESSAGE('BAR SET PROCESSING ABORTED') CALL MESSAGE(' ') CALL PLTBEL CALL PLTFLU IBARST(L) = ABS(IBARST(L)) DO 390 M = 1, N(9) IF (ABS(IRPB(M)) .EQ. IBARST(L)) THEN CALL LTSORT (MS, LINKB, IRPB(M), IPNTR, ADDLNK) ADDLNK = .TRUE. IMINUS = -IPNTR CALL LTSORT (MS, LINKB, IRPB(M), IMINUS, ADDLNK) ADDLNK = .FALSE. END IF 390 CONTINUE GO TO 430 END IF C PROCESS A REGULAR BARSET ELSE IF ((IPNTR .GT. 0) .AND. (IBARST(IPNTR) .LT. 0)) THEN L = IPNTR WRITE (*, 10120) ABS(IBARST(L)) REAL = .TRUE. TEST = .FALSE. KKK = 0 NNN = 0 KNBC = 0 KSBC = 0 LLL = 1 C LOOP THROUGH ALL THE LINES IN THE BAR SETS DO 410 J = JFLINE(L), JFLINE(L) + NLPB(L) - 1 CALL LTSORT (ML, LINKL, JLLIST(J), KK, ADDLNK) CALL LTSORT (MP, LINKP, LCON(1, KK), IP1, ADDLNK) CALL LTSORT (MP, LINKP, LCON(2, KK), IP2, ADDLNK) IF (LCON(3, KK) .GT. 0) THEN CALL LTSORT (MP, LINKP, LCON(3, KK), IP3, ADDLNK) ELSE IF (LCON(3, KK) .LT. 0) THEN CALL LTSORT (MP, LINKP, ABS(LCON(3, KK)), IP3, & ADDLNK) IP3 = -IP3 ELSE IP3 = 0 END IF C CALCULATE NODES IN THE BAR SET LINE CALL PLINE (MP, ML, MXNPER, MAXNBC, MAXSBC, IPOINT, & COOR, LINKP, ILINE(KK), LTYPE(KK), NINT(KK), & FACTOR(KK), IP1, IP2, IP3, A(K(1)), A(K(2)), IA(K(3)), & IPBOUN(IP1), IPBOUN(IP2), ILBOUN(KK), ISBOUN(KK), & LINKPB, NPPF, IFPB, LISTPB, LINKLB, NLPF, IFLB, & LISTLB, LINKSB, NSPF, IFSB, LISTSB, IA(K(14)), 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) THEN CALL MESSAGE('ERROR IN 2-NODE ELEMENT GENERATION') CALL MESSAGE('BAR SET PROCESSING ABORTED') CALL MESSAGE(' ') CALL PLTBEL CALL PLTFLU IBARST(L) = ABS(IBARST(L)) DO 400 M = 1, N(9) IF (ABS(IRPB(M)) .EQ. IBARST(L)) THEN CALL LTSORT (MS, LINKB, IRPB(M), IPNTR, ADDLNK) ADDLNK = .TRUE. IMINUS = -IPNTR CALL LTSORT (MS, LINKB, IRPB(M), IMINUS, ADDLNK) ADDLNK = .FALSE. END IF 400 CONTINUE GO TO 430 END IF C ADD THESE NODES AND ELEMENTS TO THE CURRENT LIST NNN0 = NNN + 1 NNN = NNN + ABS(NINT(KK)) + 1 IF (JCENT(L) .GT. 0) THEN CALL LTSORT (MP, LINKP, JCENT(L), IP3, ADDLNK) ELSE IP3 = 0 END IF CALL MAK2EL (MP, MXNPER, MXND, NNN0, NNN, KKK, A(K(1)), & A(K(2)), IA(K(3)), A(K(7)), A(K(8)), IA(K(9)), & IA(K(10)), COOR, IP3) C MARK THESE POINTS AND THE LINE AS BEING USED NINT(KK) = -ABS(NINT(KK)) IPOINT(IP1) = -ABS(IPOINT(IP1)) IPOINT(IP2) = -ABS(IPOINT(IP2)) 410 CONTINUE ENDIF C WRITE OUT THE BAR SET ELEMENTS AND BOUNDARY CONDITIONS IF (IBARST(IPNTR) .LT. 0) THEN BAR = .TRUE. KSBC = 0 CALL GETSBC (MXND, NNN, NNN, NLPB(L), ML, MAXSBC, 1, & 1, IA(K(3)), JLLIST(JFLINE(L)), A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), IA(K(15)), & IA(K(20)), KSBC, LCON, ISBOUN, LINKL, NSPF, IFSB, & LISTSB, LINKSB, KKK, BAR, ERR) IF (ERR) THEN CALL MESSAGE('ERROR IN SORTING SIDE BOUNDARIES') CALL MESSAGE('BAR SET PROCESSING ABORTED') CALL MESSAGE(' ') IBARST(L) = ABS(IBARST(L)) DO 420 M = 1, N(9) IF (ABS(IRPB(M)) .EQ. IBARST(L)) THEN CALL LTSORT (MS, LINKB, IRPB(M), IPNTR, ADDLNK) ADDLNK = .TRUE. IMINUS = -IPNTR CALL LTSORT (MS, LINKB, IRPB(M), IMINUS, ADDLNK) ADDLNK = .FALSE. END IF 420 CONTINUE GO TO 430 END IF CALL SAVREG (MXND, MAXNBC, MAXSBC, A(K(7)), A(K(8)), & IA(K(9)), IA(K(10)), IA(K(12)), IA(K(13)), IA(K(14)), & IA(K(15)), KNBC, KSBC, NNN, KKK, ABS(IBARST(L)), IUNIT, & BAR, M1) NPREGN = NPREGN + 1 NPELEM = NPELEM + KKK NPNODE = NPNODE + NNN IF (THREE) NPNODE = NPNODE + MAX0 (NNN, KKK + 1) NPNBC = NPNBC + KNBC IF (THREE) NPNBC = NPNBC + KNBC NPSBC = NPSBC + KSBC IF (THREE) NPSBC = NPSBC + KSBC MAXKXN = MAXKXN + KKK + NLPB(L) IBARST(L) = ABS(IBARST(L)) WRITE (*, 10140) IBARST(L) END IF END IF C END OF THIS BAR SET 430 CONTINUE 440 CONTINUE C END OF THIS GROUP OF BAR SETS C IF STEPPING THROUGH, SEE IF ANY MORE BAR SETS ARE TO BE PROCESSED IF (STEP .AND. (N(21) .GT. 0)) THEN IF ((ICOM .LE. JCOM) .AND. ((CIN(ICOM)(1:1) .EQ. 'Y') .OR. & (CIN(ICOM)(1:1) .EQ. 'y'))) THEN IANS = .TRUE. ICOM = ICOM + 1 ELSE IF ((ICOM .LE. JCOM) .AND. ((CIN(ICOM)(1:1) .EQ. 'N') .OR. & (CIN(ICOM)(1:1) .EQ. 'n'))) THEN IANS = .TRUE. ICOM = ICOM + 1 ELSE IF ((ICOM .LE. JCOM) .AND. ((CIN(ICOM)(1:1) .EQ. 'Y') .OR. & (CIN(ICOM)(1:1) .EQ. 'y'))) THEN IANS = .TRUE. ICOM = ICOM + 1 ELSE IF ((ICOM .LE. JCOM) .AND. ((CIN(ICOM)(1:1) .EQ. 'N') & .OR. (CIN(ICOM)(1:1) .EQ. 'n'))) THEN IANS = .FALSE. ICOM = ICOM + 1 ELSE CALL MESSAGE(' ') CALL INTRUP ('PROCESS ADDITIONAL BAR SETS', IANS, MCOM, & ICOM, JCOM, CIN, IIN, RIN, KIN) END IF END IF IF (IANS) GO TO 380 END IF C RESTORE THE DATA BASE TO ITS INITIAL CONDITION 450 CONTINUE DO 460 I = 1, N(1) IPOINT(I) = ABS(IPOINT(I)) 460 CONTINUE DO 470 I = 1, N(2) NINT(I) = ABS(NINT(I)) 470 CONTINUE DO 480 I = 1, N(5) IBARST(I) = ABS(IBARST(I)) 480 CONTINUE DO 490 I = 1, N(7) IREGN(I) = ABS(IREGN(I)) 490 CONTINUE DO 500 I = 1, N(5) CALL LTSORT (MS, LINKB, IBARST(I), IPNTR, ADDLNK) ADDLNK = .TRUE. IPLUS = ABS(IPNTR) CALL LTSORT (MS, LINKB, IBARST(I), IPLUS, ADDLNK) ADDLNK = .FALSE. 500 CONTINUE DO 510 I = 1, N(7) CALL LTSORT (MR, LINKR, IREGN(I), IPNTR, ADDLNK) ADDLNK = .TRUE. IPLUS = ABS(IPNTR) CALL LTSORT (MR, LINKR, IREGN(I), IPLUS, ADDLNK) ADDLNK = .FALSE. 510 CONTINUE CALL MDDEL ('X') CALL MDDEL ('Y') CALL MDDEL ('NID') CALL MDDEL ('LISTL') CALL MDDEL ('NNPS') CALL MDDEL ('ANGLE') CALL MDDEL ('XN') CALL MDDEL ('YN') CALL MDDEL ('NUID') CALL MDDEL ('LXK') CALL MDDEL ('KXL') CALL MDDEL ('NXL') CALL MDDEL ('LXN') CALL MDDEL ('LSTNBC') CALL MDDEL ('LSTSBC') CALL MDDEL ('XSUB') CALL MDDEL ('YSUB') CALL MDDEL ('NIDSUB') CALL MDDEL ('NXH') CALL MDDEL ('NPERIM') CALL MDDEL ('INDX') CALL MDDEL ('FANGLE') CALL MDDEL ('BNSIZE') CALL MDDEL ('LNODES') CALL MDDEL ('PRLINK') CALL MDDEL ('MARKED') CALL MDDEL ('IPTPER') CALL MDDEL ('NUMPER') CALL MDDEL ('LPERIM') CALL MDDEL ('ZN') CALL MDSTAT (NERR, MUSED) IF (NERR .GT. 0) THEN CALL MDEROR (6) STOP ' ' END IF RETURN 10000 FORMAT (' INITIAL CHECK BEGUN FOR REGION:', I5) 10010 FORMAT (' INITIAL CHECK BEGUN FOR GROUP:', I5) 10020 FORMAT (' ...INITIAL CHECK BEGUN FOR REGION:', I5) 10030 FORMAT (' ** ERROR - REGION', I5, ' IN BODY LIST IS INVALID **') 10040 FORMAT (' INITIAL CHECK BEGUN FOR BAR SET:', I5) 10050 FORMAT (' ** ERROR - LINE GENERATION ERRORS FOR BAR SET', I5, & ' **') 10060 FORMAT (' ** ERROR - BAR SET', I5, ' IN BODY LIST IS INVALID **') 10070 FORMAT (' NOW PROCESSING GROUP: ', I5) 10080 FORMAT (' ...NOW PROCESSING REGION:', I5) 10090 FORMAT (' NOW PROCESSING REGION:', I5) 10100 FORMAT (' GROUP', I5, ' SUCCESSFULLY COMPLETED AND SAVED') 10110 FORMAT (' REGION', I5, ' SUCCESSFULLY COMPLETED AND SAVED') 10120 FORMAT (' NOW PROCESSING BAR SET:', I5) 10130 FORMAT (' NOW PROCESSING SPRING BAR SET:', I5) 10140 FORMAT (' BAR SET', I5, ' SUCCESSFULLY COMPLETED AND SAVED') END