lib
/
EXODUS
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Cloned SEACAS for EXODUS library with extra build files for internal package management.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2 Commits
1 Branch
0 Tags
19 MiB
Tag: Branch: Tree: b1e2a11951
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'b1e2a11951'
${ noResults }
EXODUS/packages/seacas/applications/fastq/qmesh.f

1662 lines
68 KiB
Raw Normal View History Unescape

Initial commit
2 years ago
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