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 C** SIDE BOUNDARY FLAG WOULD REDIMENSION FOREVER. C** THE KKSBC VARIABLE WAS CHANGED TO BE SET AT THE C** BEGINNING OF THE ROUTINE INSTEAD OF RIGHT BEFORE THE C** ZHOLE PROCESSING WAS STARTED. SUBROUTINE 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, X, Y, & NID, LISTL, XN, YN, NUID, LXK, KXL, NXL, LXN, LSTNBC, NXH, & NPERIM, MARKED, 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) C*********************************************************************** C PSCHEM - PROCESS A COMPLETE SCHEME C*********************************************************************** 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 IREGN(MR), NSPR(MR), IFSIDE(MR), ISLIST(MR*4) DIMENSION IFHOLE(MR), NHPR(MR), IHLIST(MR*2) DIMENSION ISCHM(MSC), SCHEME(MSC) DIMENSION NPPF(MP), IFPB(MP), LISTPB(2, MP) DIMENSION NLPF(ML), IFLB(ML), LISTLB(2, ML) DIMENSION NSPF(ML), IFSB(ML), LISTSB(2, ML) DIMENSION LINKP(2, MP), LINKL(2, ML), LINKS(2, MS) DIMENSION LINKR(2, MR), LINKSC(2, MR), LINKPB(2, MP) DIMENSION LINKLB(2, ML), LINKSB(2, ML) DIMENSION N(29), CIN(MCOM), IIN(MCOM), RIN(MCOM), KIN(MCOM) DIMENSION X(MXNPER), Y(MXNPER), NID(MXNPER*MAXPRM) DIMENSION LISTL(MXNL), MARKED(3, MXNL) DIMENSION XN(MXND), YN(MXND), NUID(MXND), LXK(4, MXND) DIMENSION KXL(2, 3*MXND), NXL(2, 3*MXND), LXN(4, MXND) DIMENSION LSTNBC(MAXNBC), NXH(MXND), NPERIM(MAXPRM) DIMENSION ILPC(10) DIMENSION AMESUR(NPEOLD), XNOLD(NPNOLD), YNOLD(NPNOLD) DIMENSION NXKOLD(NNXK, NPEOLD), MMPOLD(3, NPROLD) DIMENSION LINKEG(2, MLINK), LISTEG(2 * NPEOLD), BMESUR(NPNOLD) CHARACTER*72 ADDSTR, CIN, DEFSCH, SCHEME, SCHOLE, SCHSTR CHARACTER DEV1*3 LOGICAL DOLINK, EIGHT, ERR, NINE, NOROOM, STEP LOGICAL ADDLNK, ACTIVE, IANS, DONE, DOSMOO, DOTILT, LACT(10) LOGICAL RECT, REMESH DATA IEXIT, IOVER, IQUIT /1, 2, 3/ ALPHA = 0.7 ASMALL = 45.0 RO = 1. TOL = .03 WF = 0.7 ICODE = 0 ISTYPE = 1 J = 1 NACALL = 0 NEWSGN = 0 DOTILT = .TRUE. DOSMOO = .TRUE. ERR = .FALSE. NOROOM = .FALSE. KKSBC = KSBC NLEFTP = 0 NIT = 5 * NPER/2 CALL MNORM (MXND, XN, YN, NXL, LLL, STDLEN) EPS = 0.03 * STDLEN CALL STRIPB (SCHSTR, I1, LENSCH) 100 CONTINUE IISIGN = NEWSGN NEWSGN = 0 C ACT ON NEXT COMMAND C A - ALPHA CONTROL FOR APALSM IF ((SCHSTR(J:J) .EQ. 'A') .OR. (SCHSTR(J:J) .EQ. 'a')) THEN IF (IISIGN .GE. 0) THEN ALPHA = MIN(ALPHA + 0.1, 1.0) ELSE ALPHA = MAX(ALPHA - 0.1, 0.0) END IF IF (ISTYPE .LE. 2) DOSMOO = .TRUE. WRITE(*, 10010) ALPHA C B - BLACKER TRANSITION REGION TEST ELSE IF ((SCHSTR(J:J) .EQ. 'B') .OR. & (SCHSTR(J:J) .EQ. 'b')) THEN CONTINUE C C - SEMI-CIRCLE REGION TEST ELSE IF ((SCHSTR(J:J) .EQ. 'C') .OR. & (SCHSTR(J:J) .EQ. 'c')) THEN CONTINUE C D - DELETE WORST RHOMBUS ELSE IF ((SCHSTR(J:J) .EQ. 'D') .OR. & (SCHSTR(J:J) .EQ. 'd')) THEN LIMIT = 0 IF (DOTILT) THEN CALL RESTA (MXND, XN, YN, NUID, LXK, KXL, NXL, LXN, KKK, & KKKOLD, NAVAIL, IAVAIL, NNN, LIMIT, IREST, TILT, ERR, & NOROOM) IF (NOROOM) THEN GO TO 140 ELSE IF (ERR) THEN CALL MESSAGE('ERROR DURING SHAPE SORTING OF ELEMENTS') GO TO 140 END IF DOTILT = .FALSE. END IF ATILT = MIN(45.0, TILT*0.667) ATILT = (ASMALL/45.0)*ATILT CALL SQUASH (MXND, XN, YN, NUID, LXK, KXL, NXL, LXN, KKK, & KKKOLD, NNN, NAVAIL, IAVAIL, ATILT, DONE, NOROOM, ERR) IF (NOROOM) THEN GO TO 140 ELSE IF (ERR) THEN CALL MESSAGE('ERROR DURING DELETION OF ELEMENT') GO TO 140 END IF IF (DONE) THEN DOSMOO = .TRUE. RECT = .FALSE. ACTIVE = .TRUE. CALL MESSAGE('ELEMENT DELETED') ELSE CALL MESSAGE('NO ELEMENT(S) DELETED') END IF C E - EXIT SAVING SCHEME AND REGION ELSE IF ((SCHSTR(J:J) .EQ. 'E') .OR. & (SCHSTR(J:J) .EQ. 'e')) THEN C SAVE THE SCHEME USED IF STEPPING THROUGH IF (STEP) THEN DOLINK = .TRUE. NOLD10 = N(10) NOLD24 = N(24) JJ = ABS(IREGN(L)) CALL STRLNG (SCHSTR, LTRY) SCHSTR(LTRY:LTRY) = ' ' CALL INSCHM (MR, MSC, N(10), N(24), JJ, SCHSTR, ISCHM, & SCHEME, LINKSC, DEFSCH, NOROOM, DOLINK) IF (NOROOM) THEN N(10) = NOLD10 N(24) = NOLD24 WRITE(*, 10020) SCHSTR(1:LENSCH), ABS(IREGN(L)) GO TO 140 END IF END IF ICODE = IEXIT GO TO 140 C F - CONTROL UNDER- OR OVER-RELAXATION ELSE IF ((SCHSTR(J:J) .EQ. 'F') .OR. & (SCHSTR(J:J) .EQ. 'f')) THEN RODEL = .25 IF (IISIGN .GE. 0) THEN RO = RO + RODEL ELSE RO = MAX(RO - RODEL, RODEL) END IF DOSMOO = .TRUE. WRITE(*, 10030) RO C H - INDICATES A HELP MESSAGERESPONSE IF STEPPING ELSE IF ((SCHSTR(J:J) .EQ. 'H') .OR. & (SCHSTR(J:J) .EQ. 'h')) THEN IF (STEP) CALL HELP_FQ (3) C I - CHANGE MAX SMOOTHING ITERATIONS ELSE IF ((SCHSTR(J:J) .EQ. 'I') .OR. & (SCHSTR(J:J) .EQ. 'i')) THEN IF (IISIGN .GE. 0) THEN NIT = INT(DBLE(NIT)*1.500 + 0.51) ELSE NIT = INT(DBLE(NIT)*.6667 + 0.51) END IF DOSMOO = .TRUE. WRITE(*, 10050) NIT C J - CONTROL SMOOTHING TOLERANCE ELSE IF ((SCHSTR(J:J) .EQ. 'J') .OR. & (SCHSTR(J:J) .EQ. 'j')) THEN IF (IISIGN .GE. 0) THEN TOL = TOL*1.259921 EPS = EPS*1.259921 ELSE TOL = TOL/1.259921 EPS = EPS/1.259921 END IF DOSMOO = .TRUE. WRITE(*, 10060) TOL, EPS C L - INSERT ROW OF ELEMENTS AROUND A HOLE (TOO LATE NOW) ELSE IF ((SCHSTR(J:J) .EQ. 'L') .OR. & (SCHSTR(J:J) .EQ. 'l')) THEN CONTINUE C M - LOGICAL MESH SIDES CHOSEN BY QMESH (TOO LATE NOW) ELSE IF ((SCHSTR(J:J) .EQ. 'M') .OR. & (SCHSTR(J:J) .EQ. 'm')) THEN CONTINUE C N - NECKLACE ELSE IF ((SCHSTR(J:J) .EQ. 'N') .OR. & (SCHSTR(J:J) .EQ. 'n')) THEN CALL NCKLCE (MXND, XN, YN, NUID, LXK, KXL, NXL, LXN, KKK, NNN, & NNNOLD, LLL, NAVAIL, IAVAIL, EPS, NOROOM, ERR) IF (NOROOM) THEN GO TO 140 ELSE IF (ERR) THEN CALL MESSAGE('ERROR DURING NECKLACING OF REGION') GO TO 140 END IF ACTIVE = .TRUE. RECT = .FALSE. DOSMOO = .TRUE. CALL MESSAGE('NECKLACE INSTALLED') C O - ORIGINATE THE MESH AGAIN. ELSE IF ((SCHSTR(J:J) .EQ. 'O') .OR. & (SCHSTR(J:J) .EQ. 'o')) THEN CALL MESSAGE('PROCESSING RETURNED TO ORIGINAL') SCHSTR = ' ' ICODE = IOVER GO TO 140 C P - PLOT ELSE IF ((SCHSTR(J:J) .EQ. 'P') .OR. & (SCHSTR(J:J) .EQ. 'p')) THEN IF (STEP) THEN CALL PLOTL (MXND, XN, YN, NXL, ABS(IREGN(L)), XMIN, XMAX, & YMIN, YMAX, LLL, DEV1) ELSE CALL MESSAGE('PLOTTING AVAILABLE ONLY IN INTERACTIVE '// & 'STEP PROCESSING') END IF C Q - QUIT STEP PROCESSING WITHOUT SAVING MESH ELSE IF ((SCHSTR(J:J) .EQ. 'Q') .OR. & (SCHSTR(J:J) .EQ. 'q')) THEN CALL MESSAGE ('REGION PROCESSING ABORTED WITH "QUIT"') ICODE = IQUIT GO TO 140 C R - RESTRUCTURE ELSE IF ((SCHSTR(J:J) .EQ. 'R') .OR. & (SCHSTR(J:J) .EQ. 'r')) THEN LIMIT = MXND CALL RESTA (MXND, XN, YN, NUID, LXK, KXL, NXL, LXN, KKK, & KKKOLD, NAVAIL, IAVAIL, NNN, LIMIT, IREST, TILT, ERR, & NOROOM) IF (NOROOM) THEN GO TO 140 ELSE IF (ERR) THEN CALL MESSAGE('ERROR DURING RESTRUCTURE OF REGION') GO TO 140 END IF DOTILT = .FALSE. IF (IREST .GE. 1) THEN DOSMOO = .TRUE. RECT = .FALSE. ACTIVE = .TRUE. CALL MESSAGE('RESTRUCTURE COMPLETED') END IF C S - SMOOTH ELSE IF ((SCHSTR(J:J) .EQ. 'S') .OR. & (SCHSTR(J:J) .EQ. 's')) THEN IF (DOSMOO) THEN IF (ISTYPE .EQ. 1) THEN IF (RECT) THEN CALL REPSMO (MXND, XN, YN, LXN, NNN, NNNOLD, NIT, EPS, & RO, M1) CALL MESSAGE('EQUIPOTENTIAL SMOOTHING COMPLETED') ELSE IF ((NACALL/5)*5 .EQ. NACALL) THEN CALL ARELAX (MXND, XN, YN, LXK, KXL, NXL, LLL, & ARFACT) END IF CALL APALSM (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN, & NNNOLD, NIT, TOL, RO*ARFACT, ALPHA, ERR) IF (ERR) THEN CALL MESSAGE('ERROR DURING AREA PULL & '// & 'LAPLACIAN SMOOTHING') GO TO 140 END IF CALL MESSAGE('AREA PULL AND LAPLACIAN SMOOTHING '// & 'COMPLETED') NACALL = NACALL + 1 END IF ELSE IF (ISTYPE .EQ. 2) THEN IF ((NACALL/5)*5 .EQ. NACALL) THEN CALL ARELAX (MXND, XN, YN, LXK, KXL, NXL, LLL, ARFACT) END IF CALL APALSM (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN, & NNNOLD, NIT, TOL, RO*ARFACT, ALPHA, ERR) IF (ERR) THEN CALL MESSAGE & ('ERROR DURING AREA PULL & LAPLACIAN SMOOTHING') GO TO 140 END IF CALL MESSAGE & ('AREA PULL AND LAPLACIAN SMOOTHING COMPLETED') NACALL = NACALL + 1 ELSE IF (ISTYPE .EQ. 3) THEN CALL CIAPAL (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN, & NNNOLD, NIT, EPS, RO, 0.5) CALL MESSAGE('CENTROID INVERSE PUSH AND LAPLACIAN '// & 'SMOOTHING COMPLETED') ELSE IF (ISTYPE .EQ. 4) THEN CALL CASMO (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN, & NNNOLD, NIT, EPS, RO) CALL MESSAGE & ('CENTROID AREA PULL SMOOTHING COMPLETED') ELSE IF (ISTYPE .EQ. 5) THEN IF (RECT) THEN CALL REPSMO (MXND, XN, YN, LXN, NNN, NNNOLD, NIT, EPS, & RO, M1) CALL MESSAGE('EQUIPOTENTIAL SMOOTHING COMPLETED') ELSE CALL SMOGS (MXND, XN, YN, NXL, LXN, NNN, NNNOLD, NIT, & EPS, RO) CALL MESSAGE('LAPLACIAN SMOOTHING COMPLETED') END IF ELSE IF (ISTYPE .EQ. 6) THEN CALL L2SMO (MXND, XN, YN, NXL, LXN, NNN, NNNOLD, NIT, & EPS, RO) CALL MESSAGE('LENGTH WEIGHTED LAPLACIAN SMOOTHING '// & 'COMPLETED') ELSE IF (ISTYPE .EQ. 7) THEN CALL ISOLAP (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN, & NNNOLD, WF, NIT, EPS, RO) CALL MESSAGE & ('LAPLACIAN-ISOPARAMETRIC SMOOTHING COMPLETED') END IF DOSMOO = .FALSE. ACTIVE = .TRUE. ELSE CALL MESSAGE('MESH AND/OR SMOOTHING PARAMETERS HAVE') CALL MESSAGE('NOT CHANGED - NO SMOOTHING ATTEMPTED') END IF C T - TRIANGULAR REGION - QUAD MESH GENERATION ELSE IF ((SCHSTR(J:J) .EQ. 'T') .OR. & (SCHSTR(J:J) .EQ. 't')) THEN CONTINUE C U - PENTAGON REGION - QUAD MESH GENERATION ELSE IF ((SCHSTR(J:J) .EQ. 'U') .OR. & (SCHSTR(J:J) .EQ. 'u')) THEN CONTINUE C V - CHANGE ASMALL FOR SQUASH (D) ELSE IF ((SCHSTR(J:J) .EQ. 'V') .OR. & (SCHSTR(J:J) .EQ. 'v')) THEN IF (IISIGN .GE. 0) THEN ASMALL = MIN(ASMALL + 2.5, 80.0) ELSE ASMALL = MAX(ASMALL - 2.5, 10.0) END IF WRITE(*, 10070) ASMALL C W - RESTRUCTURE WORST POSSIBLE ELEMENT ONLY ELSE IF ((SCHSTR(J:J) .EQ. 'W') .OR. & (SCHSTR(J:J) .EQ. 'w')) THEN LIMIT = 1 CALL RESTA (MXND, XN, YN, NUID, LXK, KXL, NXL, LXN, KKK, & KKKOLD, NAVAIL, IAVAIL, NNN, LIMIT, IREST, TILT, ERR, & NOROOM) IF (NOROOM) THEN GO TO 140 ELSE IF (ERR) THEN CALL MESSAGE('ERROR DURING WORST ELEMENT RESTRUCTURE') GO TO 140 END IF DOTILT = .FALSE. IF (IREST .GE. 1) THEN DOSMOO = .TRUE. RECT = .FALSE. ACTIVE = .TRUE. CALL MESSAGE('WORST ELEMENT RESTRUCTURED') END IF C X - PAVING REGION - QUAD MESH GENERATION ELSE IF ((SCHSTR(J:J) .EQ. 'X') .OR. & (SCHSTR(J:J) .EQ. 'x')) THEN CONTINUE C Y - CONTROL UNDER- OR OVER-RELAXATION ELSE IF ((SCHSTR(J:J) .EQ. 'Y') .OR. & (SCHSTR(J:J) .EQ. 'y')) THEN WFDEL = .1 IF (IISIGN .GE. 0) THEN WF = WF + WFDEL ELSE WF = MAX(WF - WFDEL, WFDEL) END IF DOSMOO = .TRUE. WRITE(*, 10040) WF C Z - PROCESS REGION WITH HOLES ELSE IF ((SCHSTR(J:J) .EQ. 'Z') .OR. & (SCHSTR(J:J) .EQ. 'z')) THEN IF (NHPR(L) .EQ. 0) THEN CALL MESSAGE('NO HOLES DEFINED IN THIS REGION') GO TO 130 ELSE IF (JJHOLE .EQ. 0) THEN JJHOLE = IFHOLE(L) MXHOLE = JJHOLE + NHPR(L) - 1 ELSE JJHOLE = JJHOLE + 1 END IF IF (JJHOLE .GT. MXHOLE) THEN CALL MESSAGE('ALL HOLES PROCESSED FOR REGION') GO TO 130 END IF ADDLNK = .FALSE. CALL LTSORT (MR, LINKR, IHLIST(JJHOLE), JHOLE, ADDLNK) C JHOLE IS NEGATIVE FOR REGIONS ON BODY CARD WITH LESS THAN THREE INTERVALS JHOLE = ABS(JHOLE) CALL LTSORT (MR, LINKSC, ABS(IREGN(JHOLE)), IPNTR, & ADDLNK) IF ((ABS(IREGN(JHOLE)) .LE. N(24)) .AND. & (IPNTR .GT. 0)) THEN SCHOLE = SCHEME(IPNTR) ELSE SCHOLE = ' ' END IF IF (STEP) THEN CALL STRCUT (SCHOLE) CALL STRLNG (SCHOLE, LENHOL) WRITE(*, 10000) SCHOLE(1:LENHOL) CALL INTRUP ('USE CURRENT HOLE SCHEME', IANS, MCOM, ICOM, & JCOM, CIN, IIN, RIN, KIN) IF (.NOT.IANS) THEN 110 CONTINUE IF (ICOM .LE. JCOM) THEN SCHOLE = CIN(ICOM) ICOM = ICOM + 1 IANS = .TRUE. ELSE CALL INQSTR ('ENTER HOLE PROCESSING SCHEME: ', SCHOLE) END IF IF ((SCHOLE(1:1) .EQ. 'H') .OR. & (SCHOLE(1:1) .EQ. 'h')) THEN CALL MESSAGE(' ') CALL HELP_FQ (13) CALL MESSAGE(' ') GO TO 110 END IF END IF END IF CALL STRCUT (SCHOLE) CALL STRLNG (SCHOLE, LENHOL) INSIDE = 0 DO 120 M = 1, LENHOL IF ((SCHOLE(M:M) .EQ. 'L') .OR. & (SCHOLE(M:M) .EQ. 'l')) INSIDE = INSIDE + 1 120 CONTINUE NPRM = NPRM + 1 CALL ZHOLE (MP, ML, MS, MR, NSPR(JHOLE), MXNL, MXNPER, MAXPRM, & NPRM, MAXNBC, MAXSBC, KNBC, KSBC, IREGN(JHOLE), IPOINT, & COOR, IPBOUN, ILINE, LTYPE, NINT, FACTOR, LCON, ILBOUN, & ISBOUN, ISIDE, NLPS, IFLINE, ILLIST, ISLIST, & IFSIDE(JHOLE), NPPF, IFPB, LISTPB, NLPF, IFLB, LISTLB, NSPF, & IFSB, LISTSB, LINKP, LINKL, LINKS, LINKPB, LINKLB, LINKSB, & X, Y, NID, LISTL, MARKED, NL, LSTNBC, MXND, XN, YN, NUID, & LXK, KXL, NXL, LXN, NXH, NPERIM, NNN, NNNOLD, KKK, LLL, & IAVAIL, NAVAIL, JHOLE, INSIDE, EPS, 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 GO TO 140 ELSE IF (ERR) THEN CALL MESSAGE('HOLE PROCESSING FAILED') GO TO 140 ELSE DOSMOO = .TRUE. RECT = .FALSE. ACTIVE = .TRUE. IF (INSIDE .GT. 0) THEN NIT3 = 3 RONE = 1.0 CALL SMOGS (MXND, XN, YN, NXL, LXN, NNN, NNNOLD, NIT3, & EPS, RONE) END IF IF (IPNTR .LE. 0) THEN ADDLNK = .TRUE. CALL LTSORT (MR, LINKSC, ABS(IREGN(JHOLE)), IPNTR, & ADDLNK) ADDLNK = .FALSE. END IF if (ipntr .gt. 0) SCHEME(IPNTR) = SCHOLE CALL MESSAGE('HOLE PROCESSING COMPLETED') END IF 130 CONTINUE C ( - START LOOP ELSE IF (SCHSTR(J:J) .EQ. '(') THEN IF (NLEFTP .GE. 10) THEN CALL MESSAGE('TOO MANY NESTED LOOPS IN THE SCHEME') GO TO 140 END IF NLEFTP = NLEFTP + 1 LACT(NLEFTP) = ACTIVE ILPC(NLEFTP) = J ACTIVE = .FALSE. C ) - END OF LOOP - CHECK FOR ACTIVITY ELSE IF (SCHSTR(J:J) .EQ. ')') THEN IF (NLEFTP .LE. 0) THEN CALL MESSAGE('THERE IS NO LEFT PARENTHESIS TO') CALL MESSAGE('MATCH THE RIGHT PARENTHESIS') CALL MESSAGE('")" IS THUS IGNORED') ELSE C LOOP BACK IF (ACTIVE) THEN ACTIVE = .FALSE. J = ILPC(NLEFTP) LACT(NLEFTP) = .TRUE. C LOOP IS COMPLETED ELSE ACTIVE = LACT(NLEFTP) NLEFTP = NLEFTP - 1 END IF END IF C + SIGN ELSE IF (SCHSTR(J:J) .EQ. '+') THEN NEWSGN = +1 C - SIGN ELSE IF (SCHSTR(J:J) .EQ. '-') THEN NEWSGN = -1 C 1, 2, ..., 6 SMOOTHING TYPE DECLARATION ELSE IF (SCHSTR(J:J) .EQ. '1') THEN IF (ISTYPE .NE. 1) THEN ISTYPE = 1 DOSMOO = .TRUE. END IF CALL MESSAGE('SMOOTHING TYPE SET TO "EQUIPOTENTIAL"') ELSE IF (SCHSTR(J:J) .EQ. '2') THEN IF (ISTYPE .NE. 2) THEN ISTYPE = 2 DOSMOO = .TRUE. END IF CALL MESSAGE('SMOOTHING TYPE SET TO "AREA PULL & LAPLACIAN"') ELSE IF (SCHSTR(J:J) .EQ. '3') THEN IF (ISTYPE .NE. 3) THEN ISTYPE = 3 DOSMOO = .TRUE. END IF CALL MESSAGE('SMOOTHING TYPE SET TO "CENTROID INVERSE AREA '// & 'PUSH & LAPLACIAN"') ELSE IF (SCHSTR(J:J) .EQ. '4') THEN IF (ISTYPE .NE. 4) THEN ISTYPE = 4 DOSMOO = .TRUE. END IF CALL MESSAGE('SMOOTHING TYPE SET TO "CENTROID AREA PULL"') ELSE IF (SCHSTR(J:J) .EQ. '5') THEN IF (ISTYPE .NE. 5) THEN ISTYPE = 5 DOSMOO = .TRUE. END IF CALL MESSAGE('SMOOTHING TYPE SET TO "LAPLACIAN"') ELSE IF (SCHSTR(J:J) .EQ. '6') THEN IF (ISTYPE .NE. 6) THEN ISTYPE = 6 DOSMOO = .TRUE. END IF CALL MESSAGE('SMOOTHING TYPE SET TO "LENGTH WEIGHTED '// & 'LAPLACIAN"') ELSE IF (SCHSTR(J:J) .EQ. '7') THEN IF (ISTYPE .NE. 7) THEN ISTYPE = 7 DOSMOO = .TRUE. END IF CALL MESSAGE('SMOOTHING TYPE SET TO "LAPLACIAN-ISOPARAMETRIC"') C BLANK SCHEME FLAG ELSE IF (SCHSTR(J:J) .EQ. ' ') THEN IF (J .NE. 1) CALL MESSAGE('BLANK SCHEME COMMAND IGNORED') C ILLEGAL SCHEME FLAG ELSE WRITE(*, 10080) SCHSTR(J:J) END IF C GET NEXT SCHEME COMMAND J = J + 1 IF (J .LE. LENSCH) THEN GO TO 100 ELSE IF (STEP) THEN CALL MESSAGE('------------------------') IF (ICOM .LE. JCOM) THEN ADDSTR = CIN(ICOM) ICOM = ICOM + 1 ELSE CALL INQSTR ('FURTHER PROCESSING STEPS: ', ADDSTR) END IF CALL STRCUT (ADDSTR) CALL STRLNG (ADDSTR, LENA) IF ((LENSCH .EQ. 1) .AND. (SCHSTR(J - 1:J - 1) .EQ. ' ')) & LENSCH = LENSCH - 1 IF (LENSCH + LENA .GT. 72) THEN CALL MESSAGE('ERROR - SCHEME TOO LONG') GO TO 140 END IF SCHSTR(LENSCH + 1:LENSCH + LENA) = ADDSTR(1:LENA) CALL STRCUT (SCHSTR) J = LENSCH + 1 CALL STRLNG (SCHSTR, LENSCH) GO TO 100 END IF ICODE = IEXIT C END OF THIS REGION 140 CONTINUE RETURN 10000 FORMAT (' ', /, ' INITIAL MESH DEFINED USING THIS HOLE SCHEME:' /, & ' ', A) 10010 FORMAT (' ALPHA SMOOTHING PARAMETER FOR EQUAL AREAS SET TO:', & F6.3) 10020 FORMAT (' SCHEME: ', A, /, & ' FOR REGION:', I5, /, & ' CANNOT BE SAVED HERE DUE TO DIMENSIONING CONSTRAINTS') 10030 FORMAT (' RO SMOOTHING PARAMETER FOR RELAXATION SET TO:', F6.3) 10040 FORMAT (' WF SMOOTHING PARAMETER FOR ISOPARAMETIC SET TO:', F6.3) 10050 FORMAT (' NO OF SMOOTHING ITERATIONS SET TO:', I5) 10060 FORMAT (' SMOOTHING TOLERANCE SET TO:', G14.7, /, & ' SMOOTHING EPSILON SET TO:', G14.7) 10070 FORMAT (' SMALLEST ANGLE OF ELEMENT TO BE DELETED SET TO:', F6.3) 10080 FORMAT (' ILLEGAL SCHEME COMMAND: ', A1) END