C ALGORITHM 637 COLLECTED ALGORITHMS FROM ACM. C ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL.11, NO. 4, C DEC., 1985, P. 413-415. C////////////////////////////////////////////////////////////// C////////////////// ALGORITHM GENCOL /////////////////////// C///////////////////////////////////////////////////////////// C>>>>>>>>>>>>>>>>>> LOGICAL FILE 1 : DRIVER <<<<<<<<<<<<<<<<<< C///////////////////////////////////////////////////////////// C PROGRAM DRIVE1 C C C ---- T E S T D R I V E R F O R G E N C O L ----- C C C MODIFIABLE PARAMETERS FOR DIMENSION SETTING. C THE FOLLOWING DIMENSIONS LIMIT THE SIZE OF THE PROBLEM THAT C CAN BE SOLVED. C C NGXMAX - MAXIMUM NUMBER OF X GRID LINES C NGYMAX - MAXIMUM NUMBER OF Y GRID LINES C NTBXMX - MAXIMUM NUMBER OF X GRID LINES IN TABLED OUTPUT ON A C GRID OTHER THAN THE DISCRETIZATION GRID C NTBYMX - MAXIMUM NUMBER OF Y GRID LINES IN TABLED OUTPUT ON A C GRID OTHER THAN THE DISCRETIZATION GRID C NOUTMX - MAXIMUM NUMBER OF OUTPUT REQUESTS C NBPTMX - MAXIMUM NUMBER OF BOUNDARY POINTS (CORNERS OF DOMAIN C AND INTERSECTIONS OF DOMAIN BOUNARY WITH GRID) C NPMAX - MAXIMUM NUMBER OF PIECES OF DOMAIN BOUNDARY C NEQMAX - MAXIMUM NUMBER OF EQUATIONS (= 4*NGXMAX*NGYMAX) ) C NCOEMX - MAXIMUM NUMBER OF COEFFICIENTS C NWKMAX - MAXIMUM AMOUNT OF WORKSPACE (= 2+(12*NGYMAX + 23)*NEQMAX ) ) C C TABX NTBXMX BPTYPE NBPTMX C TABY NTBYMX BNEIGH NBPTMX C IDCOEF NEQMAX,NCOEMX BGRID NBPTMX C OUTFNC NOUTMX GRIDX NGXMAX C OUTTYP NOUTMX GRIDY NGYMAX C GTYPE NGXMAX,NGYMAX BRANGE 2,NPMAX C XBOUND NBPTMX NODELM NEQMAX C C REAL COEF(324,17),UNKVCT(324),WRKSP(42446),TABX(10),TABY(10) INTEGER IDCOEF(324,17),OUTFNC(4),OUTTYP(4),GTYPE(9,9),GIVOPT, . GIVOPZ LOGICAL DOMFLG,PLOTIT,USECRN,PLOTIZ,USECRZ C C C MODIFICATIONS TO CHANGE PROBLEM C C THE DRIVER IS SET TO RUN EXAMPLE 1 C C TO RUN EXAMPLE 2, CHANGE NOUT TO 4 AND MAKE THE MODIFICATIONS C TO BRANGE AND BY AS INDICATED BELOW C C C********************* NON-STANDARD COMMON BLOCK USE **************** C MANY LABELED COMMON BLOCKS ARE DIMENSIONED WITH LENGTH 1 * C IN THIS ALGORITHM. THE CORRECT LENGTHS MUST BE SET IN THE * C DRIVER(MAIN) PROGRAM. THIS IS NOT STANDARD FORTRAN 77 BUT * C IT WORKS ON ALL SYSTEMS FORTRAN KNOWN TO US. IT ALLOWS ONE * C TO USE THE PROGRAMS REPEATEDLY WITHOUT RECOMPILING THEM. * C EXAMPLE. * C COMMON / GRIDXZ / GRIDX(1) * C IS USED INSTEAD OF * C COMMON / GRIDXZ / GRIDX(9) * C IF YOUR COMPILER ENFORCES THE STANDARD THEN YOU MUST CHANGE * C THESE COMMON BLOCK LENGTHS AND RECOMPILE EACH TIME * C********************* NON-STANDARD COMMON BLOCK USE **************** C COMMON /PROBR/AX,BX,AY,BY COMMON /XBOUZZ/XBOUND(50) COMMON /YBOUZZ/YBOUND(50) COMMON /BPARZZ/BPARAM(50) COMMON /PIECZZ/PIECE(50) COMMON /BPTYZZ/BPTYPE(50) COMMON /BNEIZZ/BNEIGH(50) COMMON /BGRIZZ/BGRID(50) COMMON /GRIDXZ/GRIDX(9) COMMON /GRIDYZ/GRIDY(9) COMMON /BRANZZ/BRANGE(2,4) COMMON /COLOPT/BCP1Z,BCP2Z,DSCARZ,PTSIZZ,GIVOPZ,PLOTIZ,USECRZ COMMON /COLNUM/NODELM(324) C C ------- MODIFIABLE DATA STATEMENT ------- C C IGRID - INTEGER NOT 0 OR 1 C IF POSITIVE, THEN UNIFORM IGRID X IGRID C IF NEGATIVE, THEN VALUES LISTED IN SUBROUTINE SETGRD C C OTHER PARAMETERS ARE DESCRIBED IN SUBROUTINE GENCOL C DATA IGRID,BCP1,BCP2,DSCARE,GIVOPT,PLOTIT,USECRN,LEVEL/5,0.,0., . .05,1,.FALSE.,.FALSE.,1/ C CALL KILLIT(144) DOMFLG = .TRUE. PTSIZE = 7. C MXNEQ = 324 MXNCOE = 17 NBDIM = 50 MOUTPT = 6 C BCP1Z = BCP1 BCP2Z = BCP2 DSCARZ = DSCARE PTSIZZ = PTSIZE GIVOPZ = GIVOPT PLOTIZ = PLOTIT USECRZ = USECRN C C SET BOUNDARY DATA STRUCTURES C C ----THIS CODE IS FOR EXAMPLE 1, THE UNIT SQUARE C NBOUND = 4 DO 10 I = 1,4 BRANGE(1,I) = 0. BRANGE(2,I) = 1. 10 CONTINUE AX = 0. BX = 1. AY = 0. BY = 1. C -------------------------------------------------- C C FOR EXAMPLE 2'S NONRECTANGULAR DOMAIN, INCLUDE C PI = 4.*ATAN(1.) C BRANGE(2,4) = PI/2. C BY = .5 C C -------------------------------------------------- CCCC PI = 4.*ATAN(1.) CCCC BRANGE(2,4) = PI/2. CCCC BY = .5 NPDIM = NBOUND C C SET GRID C CALL SETGRD(GRIDX,GRIDY,NGRIDX,NGRIDY,AX,BX,AY,BY,IGRID) C C SET OUTPUT TYPES C SHOULD BE 2 FOR EXAMPLE 1, 4 FOR EXAMPLE 2 , 3 C NOUT = 4 C TABLE APPROXIMATE SOLUTION OUTFNC(1) = 1 OUTTYP(1) = 3 C TABLE RESIDUAL ON 10 X 10 GRID OUTFNC(2) = 3 OUTTYP(2) = 4 NTABX = 10 NTABY = 10 DO 20 I = 1,10 AIM1 = I - 1 TABX(I) = AX + (BX-AX)*AIM1/9. TABY(I) = AY + (BY-AY)*AIM1/9. 20 CONTINUE C MAXIMUM ERROR (MEANINGLESS FOR EXAMPLE 1 WHERE TRUE IS UNKNOWN) OUTFNC(3) = 2 OUTTYP(3) = 1 C MAXIMUM ERROR ON 10 X 10 GRID (MEANINGLESS FOR EXAMPLE 1) OUTFNC(4) = 2 OUTTYP(4) = 2 C CALL GENCOL(GTYPE,NGRIDX,NGRIDY,NBOUND,NBNDPT,NPDIM,NBDIM,DOMFLG, . AX,BX,AY,BY,NGRIDX,NGRIDY,COEF,IDCOEF,UNKVCT,MXNCOE, . MXNEQ,OUTFNC,OUTTYP,NOUT,TABX,TABY,NTABX,NTABY,LEVEL, . MOUTPT,WRKSP) STOP END SUBROUTINE KILLIT(N) C CDC-NOS DEPENDENT ROUTINE TO SUPPRESS EXP() UNDERFLOW MESSAGES. DIMENSION IS(6) DATA (IS(K),K=1,6)/-0,-0,-0,0,-0,-0/ CALL SYSTEMC(N,IS) RETURN END SUBROUTINE REGION(XGRID,YGRID,NGDIMX,NGDIMY,BRANGE,NPDIM,BCOORD, . SCLOCK,SARC,SLEVEL,GTYPE,XBOUND,YBOUND,PIECE, . BPTYPE,BNEIGH,BGRID,BPARAM,NBDIM,NBPTS,FAIL) C C DOMAIN PROCESSOR. WRITTEN BY JOHN R. RICE, PURDUE UNIVERSITY. C C THE PURPOSE OF THIS ALGORITHM IS TO RELATE A GENERAL 2 DIMENSIONAL C DOMAIN TO A RECTANGULAR GRID LAID OVER IT. THE DOMAIN BOUNDARY IS C GIVEN IN PARAMETRIC FORM AND THE PROGRAM PRODUCES ARRAYS WHICH C DESCRIBE THE RELATIONSHIP BETWEEN THE TWO OBJECTS. THESE ARRAYS C CONTAIN INFORMATION POINTING IN BOTH DIRECTIONS AND WHICH SHOULD C FACILITATE APPLICATIONS( E.G. NUMERICAL QUADRATURE, SURFACE C FITTING, DISCRETIZING PDE'S ) WHICH INVOLVE SUCH DOMAINS. C C C ------------------- INPUT INFORMATION FOR DOMAIN PROCESSOR -------- C C 1** OUTPUT LEVEL CONTROL ******* C SLEVEL = LEVEL = OUTPUT CONTROL SETTING C DETAILS GIVEN IN SUBROUTINE DOMAIN C C 2** GRID DEFINITION ************ C C NGDIMX,NGDIMY = NUMBER OF GRID LINES IN X AND Y COORDINATES C NGRIDX = NGDIMX, NGRIDY = NGDIMY C XGRID(IX),YGRID(JY) FOR IX = 1 TO NGRIDX, JY = 1 TO NGRIDY C = ARRAYS CONTAINING THE GRID LINE COORDINATES C C 3** BOUNDARY DEFINITION ******** C C NPDIM = NBOUND = NUMBER OF BOUNDARY PIECES C NBDIM = ARRAY DIMENSION FOR BOUNDARY POINTS C BCOORD = PARAMETERIZED DEFINITION OF THE BOUNDARY. C BCOORD(P,X,Y,IPIECE) GIVES THE X,Y VALUES OF THE C POINT ON PIECE IPIECE WITH PARAMETER VALUE = P. C SEE NOTE BELOW FOR DISCRETE BOUNDARY DEFINITION C C BRANGE(2,I) = FIRST AND LAST VALUES OF PARAMETERS DEFINING C THE I-TH BOUNDARY PIECE C SCLOCK = CLOCK = SWITCH TO SPECIFY BOUNDARY ORIENTATION C .TRUE. MEANS BOUNDARY IS CLOCKWISE C .FALSE. MEANS BOUNDARY IS COUNTER-CLOCKWISE C SARC = ARC = .TRUE. MEANS DOMAIN IS AN ARC WITH NO INTERIOR C C --------------------------------------------------------------------- C --------- OUTPUT INFORMATION OF THE DOMAIN PROCESSOR IS IN TWO PARTS C ( THERE IS ALSO A FAILURE FLAG = FAIL ) C C PART 1 ********** GRID POINT TYPES ************ C C GTYPE(IX,JY) FOR IX = 1 TO NGRIDX, JY = 1 TO NGRIDY C THE VALUES IN THIS ARRAY GIVE THE TYPE OF THE GRID POINTS AND C INFORMATION ABOUT THEIR RELATION TO THE BOUNDARY. DETAILS AND C EXAMPLES ARE GIVEN IN THE SUBROUTINE DOMAIN. C POSSIBLE VALUE ARE( ASSUMING PACKING FACTOR IPACKB = 1000) C C = INTEGER OVER 1000 C GRID POINT IS NEXT TO THE BOUNDARY AND THE GTYPE VALUE IS C GTYPE = K + 1000*J WHERE C K IS THE INDEX OF THE LOWEST NUMBERED BOUNDARY NEIGHBOR C J = FOUR BITS TO NOTE LOCATION OF BOUNDARY POINTS C 0001 - BOUNDARY NEIGHBOR TO NORTH (NOON) C 0010 - BOUNDARY NEIGHBOR TO EAST (3 O'CLOCK) C 0100 - BOUNDARY NEIGHBOR TO SOUTH (6 O'CLOCK) C 1000 - BOUNDARY NEIGHBOR TO WEST (9 O'CLOCK) C C = 999 C GRID POINT IS INTERIOR TO REGION AND NOT CLOSE TO BOUNDARY C C = INTEGER LESS THAN 999 C GRID POINT IS ALSO BOUNDARY PT., GTYPE IS ITS INDEX C C = 0 C GRID POINT IS EXTERIOR FAR FROM THE BOUNDARY C C = NEGATIVE INTEGER C GRID POINT IS EXTERIOR NEXT TO THE BOUNDARY, ITS LOCATION C RELATIVE TO THE BOUNDARY IS ENCODED AS FOR INTERIOR POINTS C NEAR THE BOUNDARY C C C PART 2 ********* BOUNDARY/GRID INTERSECTIONS ********** C C NBNDPT = NUMBER OF BOUNDARY POINTS ACTUALLY FOUND C BOUNDARY POINT INDEX RANGE = 1 TO NBNDPT+1 C THE FIRST BOUNDARY POINT IS ADDED TO THE LIST TO C MAKE IT CIRCULAR, HENCE THE +1 IN THE INDEX RANGE C XBOUND(I),YBOUND(I) = COORDINATES OF I-TH BOUNDARY POINT C BPARAM(I) = PARAMETER VALUE OF I-TH BOUNDARY POINT C PIECE(I) = INDEX OF BOUNDARY PIECE TO WHICH PT. BELONGS C SMALLEST NUMBER FOR CORNER POINTS C BPTYPE(I) = TYPE OF BOUNDARY POINT C = HORZ IF POINT IN ON A Y GRID LINE C = VERT X C = BOTH IF POINT IS ALSO A GRID POINT C = INTE IF POINT IS NOT ON A GRID LINE C HAPPENS ONLY FOR CORNERS OF THE BOUNDARY C = JUMP IF POINT PRECEEDS A HOLE C BNEIGH(I) = POINTER TO THE INTERIOR POINTS FROM THE I-TH C BOUNDARY POINT. SAME SCHEME IS USED TO ENCODE C DIRECTIONS AS FOR THE J PART OF GTYPE ABOVE C BGRID(I) = IX + IPACKB*JY WHEN PT. I IS IN GRID SQUARE IX,JY C C ********************************************************************* C ************** DOMAIN PROCESSOR ALGORITHM STRUCTURE *************** C C THERE ARE 2 BASIC PARTS TO THE ALGORITHM, PROCESSING THE BOUNDARY C AND TYPING THE GRID POINTS. AN OUTLINE FOLLOWS C C MARK ALL GRID POINTS AS EXTERIOR C C******* PART 1 *** PROCESS BOUNDARY C C LOCATE FIRST BOUNDARY POINT C C DO LOOP OVER BOUNDARY PIECES C 1 DO WHILE NOT AT END OF PIECE C 1 1 LOCATE NEXT INTERSECTION WITH GRID LINE( SUBROUTINE BWALK ) C 1 1 DETERMINE TYPE FOR INTERSECTION POINT FOUND C 1 1 CHECK FOR CHANGING BOUNDARY PIECE(SUBROUTINE CHANGE DOES IT) C 1 1 CHECK CONTINUITY OF BOUNDARY C 1 +--- C +------ C C CHECK CLOSING OF BOUNDARY C FINISH UP FIRST POINT C C******* PART 2 *** TYPE GRID POINTS AND MARK INTERIOR POINTS C C PASS OVER GRID MARKING THE GRID POINT TYPES(SUBROUTINE GVALUS ) C MARK INTERIOR POINTS( SUBROUTINE FILL ) C LOCATE FIRST INTERIOR POINT C MARK THE INTERIOR POINTS C SET POINTERS FROM BOUNDARY TO INTERIOR( SUBROUTINE NEIGH ) C C C **** NOTE. IF THE BOUNDARY IS DESCRIBED DISCRETELY BY THE SET OF C BOUNDARY-GRID INTERSECTIONS, THEN THE FOLLOWING FUNCTION PROGRAM C ALLOWS THE DOMAIN PROCESSOR TO BE APPLIED. IT ESSENTIALLY PROVIDES C LINEAR INTERPOLATION BETWEEN THE DISCRETE POINTS C C * FUNCTION BCOORD(P,X,Y,IPIECE) C * REAL XBOUND(***),YBOUND(***) C * LOGICAL STARTD C * DATA STARTD/.FALSE./ C * IF( STARTD ) GO TO 20 C * OBTAIN DATA FOR DISCRETE POINTS THROUGH A COMMON BLOCK C * OR BY READING FROM A FILE. THE READ CASE IS SHOWN. C * READ(INFILE,10) NBNDPT,(XBOUND(I),YBOUND(I),I=1,NBNDPT-1) C * 10 FORMAT( ****** ) C * XBOUND(NBNDPT) = XBOUND(1) C * YBOUND(NBNDPT) = YBOUND(1) C * C * OBTAIN COORDINATES FROM ARRAYS OF DISCRETE DATA C * 20 IP = P C * X = (P-IP)*XBOUND(IP+1) + (1.+P-IP)*XBOUND(IP) C * Y = (P-IP)*YBOUND(IP+1) + (1.+P-IP)*YBOUND(IP) C * RETURN C * END C C ***************************************************************** C ***** REGION IS AN INTERFACE SUBROUTINE FOR THE DOMAIN PROCESSING C MAIN SUBPROGRAM = DOMAIN. C REGION MUST BE THE FIRST ROUTINE CALLED FOR PROCESSING C MULTIPLE REGIONS( E.G. WITH HOLES) C THE FUNCTIONS OF THIS INTERFACE PROGRAM ARE AS FOLLOWS. C C 1. INITIALIZE OR COMPUTE VARIOUS CONSTANTS AND PLACE THEM IN C COMMON BLOCKS. THESE ARE C A. I/O CONSTANT = MOUTPT C B. NUMERICAL CONTROL CONSTANTS = EPSGRD,EPSTAN C C. 5 CHARACTER STRING CONSTANTS C D. COUNTERS = N1BND,N1BDPT = 1 C E. INTERIOR MARKER = NSIDE C F. PACKING FACTOR = IPACKB( SHOULD BE NSIDE+1 ) C C 2. CHECK THAT THE GRID IS PROPERLY DEFINED. C C 3. MOVE VARIABLES FROM SUBROUTINE ARGUMENT LIST INTO COMMON. C A. DIMENSION SPECIFICATIONS = NGDIMX,NGDIMY,NBOUND C B. CONTROL VARIABLES = LEVEL, CLOCKW, ARC C C 4. CALL DOMAIN. C C 5. SET FAILURE FLAG FAIL, FINAL NUMBER NBPTS OF BOUNDARY POINTS C C REAL XGRID(NGDIMX),YGRID(NGDIMY),BRANGE(2,NPDIM) LOGICAL SCLOCK,SARC,FAIL INTEGER SLEVEL DIMENSION GTYPE(NGDIMX,NGDIMY),XBOUND(NBDIM),YBOUND(NBDIM), . BPTYPE(NBDIM),BNEIGH(NBDIM),BGRID(NBDIM),BPARAM(NBDIM), . PIECE(NBDIM) C C ******** IF HOLE IS ALSO USED THEN THE CALLING PROGRAM ***** C ******** MUST HAVE THE FOLLOWING COMMON BLOCKS IN ORDER ***** C ******** TO CONFORM TO FORTRAN STANDARDS ***** C EXTERNAL BCOORD INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN,EPSGRQ LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /NUMCON/EPSGRQ COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C C CONSTANT CHARACTER STRINGS FOR NICE PRINT OUT CHARACTER *4 IQHORZ,IQVERT,IQBOTH,IQINTE,IQJUMP DATA IQHORZ,IQVERT,IQBOTH,IQINTE,IQJUMP/'HORZ','VERT','BOTH', . 'INTE','JUMP'/ C C INITIALIZE COMMON BLOCKS FROM SUBROUTINE ARGUMENTS NGRIDX = NGDIMX NGRIDY = NGDIMY NBOUND = NPDIM LEVEL = SLEVEL CLOCKW = SCLOCK ARC = SARC C C INITIALIZE CONSTANT CHARACTER STRINGS FROM DATA STATEMENTS HORZ = IQHORZ VERT = IQVERT BOTH = IQBOTH INTER = IQINTE JUMP = IQJUMP C SET UNIT NUMBER FOR OUTPUT MOUTPT = 6 C PRINT GREETINGS C IF (LEVEL.GT.0) WRITE (MOUTPT,9001) C C SET MARKER FOR INTERIOR POINTS OF REGION C MUST EXCEED MAX NUMBER OF BOUNDARY POINTS NSIDE = 999 IPACKB = NSIDE + 1 C SET LIMIT ON THE QUEUE LENGTH IN ROUTINE FILL C QLIMIT = 250 SHOULD ALLOW WELL OVER 10,000 C INTERIOR POINTS IN THE DOMAIN QLIMIT = 250 C MARK THAT WE ARE NOT IN HOLE OR ARC ARC = .FALSE. INHOLE = .FALSE. C INITIALIZE BOUNDARY LIST COUNTERS N1BND = 1 N1BDPT = 1 C C SET GEOMETRY TOLERANCE PARAMETER EPSGRD C **************************************************************** C ****** ****** C ****** THIS IS A MACHINE AND PROBLEM DEPENDENT CONSTANT ****** C ****** ****** C **************************************************************** C C EPSGRD SHOULD BE LARGE ENOUGH TO INSULATE THE COMPUTATIONS FROM C MACHINE ROUND-OFF. ALL POINTS AND LINES WITHIN EPSGRD OF ONE C ANOTHER ARE ASSUMED TO BE EQUAL. IT IS PROBABLY SAFE TO TAKE C EPSGRD AS 50 UNITS IN THE LAST PLACE, IT MUST BE AT LEAST 20 C UNITS IN THE LAST PLACE. THE CONVERGENCE TEST IN SECANT IS C .2*EPSGRD C C ****** THIS PARAMETER IS RELATIVE TO THE DOMAIN SIZE ****** C C EPSGRD SHOULD BE SMALL ENOUGH SO THAT THE ACCURACY IN THE PROBLEM C SOLUTION IS NOT AFFECTED BY AN UNCERTAINTY IN THE GEOMETRY OF C EPSGRD. C C EPSGRD = 1.E-8 IS APPROPRIATE FOR MOST LONG WORD LENGTH C MACHINES AND PROBLEMS C 2.E-5 IS APPROPRIATE( BUT NOT FAIL-SAFE ) FOR C 32 BIT MACHINES. XWIDTH = XGRID(NGRIDX) - XGRID(1) YWIDTH = YGRID(NGRIDY) - YGRID(1) EPSGRD = 2.E-5*AMAX1(XWIDTH,YWIDTH) C PUT EPSGRD IN COMMON /NUMCON/ FOR DOMAIN PROCESSING. EPSGRQ = EPSGRD C C CHECK THAT THE GRIDS ARE PROPERLY DEFINED IF (NGRIDX.GE.2) GO TO 20 C FATAL ERROR, GRID TOO SMALL 10 CONTINUE C IF (LEVEL.GE.0) WRITE (MOUTPT,9011) FATAL = .TRUE. RETURN 20 IF (NGRIDY.LE.1) GO TO 10 C C CHECK THAT THE GRID INCREASES IN BOTH DIRECTIONS C FIND THE MINIMUM GRID WIDTHS XGMIN = XWIDTH DO 30 I = 2,NGRIDX XGMIN = AMIN1(XGMIN,XGRID(I)-XGRID(I-1)) 30 CONTINUE YGMIN = YWIDTH DO 40 I = 2,NGRIDY YGMIN = AMIN1(YGMIN,YGRID(I)-YGRID(I-1)) 40 CONTINUE IF (AMIN1(XGMIN,YGMIN).GT.EPSGRD) GO TO 50 C C FATAL ERROR, HAVE ZERO OR NEGATIVE GRID WIDTH C IF (LEVEL.GE.0) WRITE (MOUTPT,9021) FATAL = .TRUE. RETURN C C SET PARAMETER FOR TANGENCY TEST C SEE SUBROUTINE CHKTAN FOR DETAILS 50 EPSTAN = .1E0*AMIN1(XGMIN,YGMIN,15.E0*SQRT(EPSGRD)) C C CALL DOMAIN PROCESSOR CALL DOMAIN(XGRID,YGRID,NGDIMX,NGDIMY,BRANGE,NPDIM,BCOORD,GTYPE, . XBOUND,YBOUND,PIECE,BPTYPE,BNEIGH,BGRID,BPARAM,NBDIM) C C SET FAILURE FLAG AND FINAL NUMBER OF BOUNDARY POINTS FAIL = FATAL C THESE NUMBERS WILL BE USED BY HOLE IF IT IS CALLED NBPTS = NBNDPT N1BND = NBOUND + 1 C CHECK FOR INTERIOR POINTS ON BOUNDARY OF GTYPE ARRAY C IF FOUND IT MEANS THERE IS SOMETHING WRONG DO 60 I = 1,NGDIMX IF (GTYPE(I,1).EQ.NSIDE .OR. GTYPE(I,NGDIMY).EQ. . NSIDE) GO TO 80 60 CONTINUE DO 70 J = 1,NGDIMY IF (GTYPE(1,J).EQ.NSIDE .OR. GTYPE(NGDIMX,J).EQ. . NSIDE) GO TO 80 70 CONTINUE C NO PROBLEM DETECTED RETURN C SERIOUS PROBLEM DETECTED 80 CONTINUE C IF (LEVEL.GE.0) WRITE (MOUTPT,9031) FATAL = .TRUE. RETURN 9001 FORMAT (///1H ,19 (1H-)/1H ,18H DOMAIN PROCESSOR /1H , . 19 (1H-)//5X, . 33H D O M A I N P R O C E S S O R ) 9011 FORMAT (/5 (3H **),39H FATAL ERROR, MUST HAVE AT LEAST 2 GRID, . 18H LINES IN X AND Y ) 9021 FORMAT (/5 (3H **),32H FATAL ERROR, X AND Y GRID LINES/9X, . 19H MUST BE INCREASING) 9031 FORMAT (/5 (3H **),33H FATAL ERROR, FOUND INTERIOR PTS /4X, . 43HON THE EDGE OF THE GRID. PROBABLE CAUSES / . 4X,40H BOUNDARY ORIENTATION IS WRONG / . 4X, . 47H BOUNDARY STARTS WHERE INTERIOR IS TOO THIN . /4X, . 46H BOUNDARY OSCILLATES TOO RAPIDLY SOME PLACE . ) END SUBROUTINE SETUP(COEF,IDCOEF,MXNEQ,MXNCOE,NUMBEQ,NUMCOE,ABD,LDA, . UNKNWN,NBANDU,NBANDL) C C INTERFACE TO SOLUTION MODULE C REAL COEF(MXNEQ,*),UNKNWN(*),ABD(LDA,*) INTEGER IDCOEF(MXNEQ,*) C C FIND BANDWIDTHS AND SET MATRIX SIZE C IF (NBANDU*NBANDL.EQ.0) CALL BNDWTH(IDCOEF,MXNEQ,NUMBEQ,NUMCOE, . NBANDU,NBANDL) NROW = 2*NBANDL + NBANDU + 1 NCOL = NUMBEQ KWORK = NROW*NCOL + NCOL WRITE (6,9001) NUMBEQ,NBANDL,NBANDU,KWORK C C ZERO OUT ABD C DO 20 J = 1,NCOL DO 10 I = 1,NROW ABD(I,J) = 0.0 10 CONTINUE 20 CONTINUE C C LOAD ABD AND RIGHT SIDE C M = NBANDL + NBANDU + 1 DO 40 I = 1,NUMBEQ UNKNWN(I) = COEF(I,MXNCOE) DO 30 JJ = 1,NUMCOE J = IDCOEF(I,JJ) IF (J.EQ.0) GO TO 30 K = I - J + M ABD(K,J) = COEF(I,JJ) 30 CONTINUE 40 CONTINUE C C RETURN 9001 FORMAT (/1H ,38H INTERFACE TO LINEAR EQUATION SOLVER/1H , . 22H NUMBER OF EQUATIONS,I9/1H ,18H LOWER BANDWIDTH,I13/1H , . 18H UPPER BANDWIDTH,I13/1H ,21H REQUIRED WORKSPACE,I10) END SUBROUTINE SOLVE(ABD,LDA,NUMBEQ,UNKNWN,PIVOTS,NBANDU,NBANDL) C C WAYNE R. DYKSEN, JANUARY 1982 C REAL ABD(LDA,*),UNKNWN(*),PIVOTS(*) C C FACTOR THE MATRIX C WRITE (6,9001) CALL FACTR(ABD,LDA,NUMBEQ,NBANDL,NBANDU,PIVOTS,INFO) IF (INFO.NE.0) GO TO 10 C C SOLVE THE SYSTEM C CALL BACKSU(ABD,LDA,NUMBEQ,NBANDL,NBANDU,PIVOTS,UNKNWN,0) C WRITE (6,9011) RETURN C C ERROR EXIT -- DIVISION BY ZERO IN BACKSU C 10 CONTINUE WRITE (6,9021) INFO,INFO STOP C C 9001 FORMAT (/1H ,25H BAND GAUSS ELIMINATION) 9011 FORMAT (1H ,23H EXECUTION SUCCESSFUL) 9021 FORMAT (1H ,36H THE BAND FACTOR ROUTINE EXECUTED/1H , . 35H SUCCESSFULLY, BUT THE BAND BACK/1H , . 40H SOLVE ROUTINE WILL DIVIDE BY ZERO IF/1H , . 36H CALLED. THE DIAGONAL ELEMENT IN/1H ,8H ROW ,I10, . 20H OF THE UPPER FACTOR/1H ,12H IS ZERO.) END SUBROUTINE OUTPUT(OUTFNC,OUTTYP,TABX,NTABX,TABY,NTABY,WKSPAC, . GTYPE,NGRDXD,NGRDYD,UNKNWN,RECTAN) C C C PURPOSE C C CONTROLS THE TYPE OF OUTPUT OF THE COLLOCATION APPROX. C C PARAMETERS C C OUTFNC - INDICATES WHAT FUNCTION IS TO BE OUTPUT C =1 APPROXIMATE SOLUTION C =2 ERROR (TRUE MUST BE SUPPLIED) C =3 RESIDUAL C C OUTTYP - INDICATES WHAT INFORMATION ABOUT THE C OUTPUT FUNCTION IS TO BE PRINTED C =1 PRINT MAX, L1, L2 NORMS OF FUNCTION C BASED ON DISCRETIZATION GRID C =2 PRINT MAX, L1, L2 NORMS OF FUNCTION C BASED ON GIVEN GRID (TABX,TABY) C =3 PRINT TABLE OF FUNCTION ON DISC. GRID C =4 PRINT TABLE OF FUNCTION ON GIVEN GRID C C TABX, TABY - X AND Y COORDINATES FOR OUTTYP 2 AND 4 C C NTABX, NTABY - NUMBER OF VALUES IN TABX, TABY C C ALL OTHER PARAMETERS ARE PASSED TO SUBROUTINES C C C REAL TABX(NTABX),TABY(NTABY),WKSPAC(NTABX),UNKNWN(*) INTEGER OUTFNC,OUTTYP,GTYPE(NGRDXD,NGRDYD) LOGICAL RECTAN C COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /PROBI/NGRIDX,NGRIDY C GO TO (10,20,30,40),OUTTYP C C PRINT NORMS OF THE FUNCTION ON DISCRETIZATION GRID C 10 CALL FNCMAX(OUTFNC,GRIDX,NGRIDX,GRIDY,NGRIDY,GTYPE,NGRDXD,NGRDYD, . UNKNWN,RECTAN) RETURN C C PRINT NORMS OF FUNCTION ON GIVEN GRID C 20 CALL FNCMAX(OUTFNC,TABX,NTABX,TABY,NTABY,GTYPE,NGRDXD,NGRDYD, . UNKNWN,RECTAN) RETURN C C PRINT TABLE OF FUNCTION ON DISCRETIZATION GRID C 30 CALL TABLER(OUTFNC,GRIDX,NGRIDX,GRIDY,NGRIDY,WKSPAC,GTYPE,NGRDXD, . NGRDYD,UNKNWN,RECTAN) RETURN C C PRINT TABLE OF FUNCTION ON GIVEN GRID C 40 CALL TABLER(OUTFNC,TABX,NTABX,TABY,NTABY,WKSPAC,GTYPE,NGRDXD, . NGRDYD,UNKNWN,RECTAN) RETURN END C////////////////////////////////////////////////////////////////////// C///////////////// END OF LOGICAL FILE 1 //////////////////////////////// C////////////////////////////////////////////////////////////////////// C////////////////////////////////////////////////////////////////////// C//////////////////// ALGORITHM GENCOL ////////////////////////////// C///////////////////////////////////////////////////////////////////// C>>>>>>>>>>>> LOGICAL FILE 2 : RELATED ROUTINES TO SOLVE S/R<<<<<<<<<<< C///////////////////////////////////////////////////////////////////// SUBROUTINE BNDWTH(IDCOEF,MXNEQ,NUMBEQ,NUMCOE,NBANDU,NBANDL) C C BNDWTH COMPUTES THE BANDWIDTH OF THE LINEAR SYSTEM WHOSE IDS C ARE STORED IN THE ARRAY IDCOEF C C NBANDU = NUMBER OF BANDS ABOVE DIAGONAL C NBANDL = NUMBER OF BANDS BELOW DIAGONAL C INTEGER IDCOEF(MXNEQ,*) C NBANDU = 0 NBANDL = 0 C DO 20 I = 1,NUMBEQ DO 10 JJ = 1,NUMCOE J = IDCOEF(I,JJ) IF (J.EQ.0) GO TO 10 JIDIFF = J - I NBANDU = MAX0(NBANDU,JIDIFF) NBANDL = MIN0(NBANDL,JIDIFF) 10 CONTINUE 20 CONTINUE NBANDL = IABS(NBANDL) C RETURN END SUBROUTINE BACKSU(ABD,LDA,N,ML,MU,PIVOTS,B,JOB) C C P U R P O S E C C BACKSU SOLVES THE REAL BAND SYSTEM A * X = B OR TRANS(A) * X = B C USING THE FACTORS COMPUTED BY FACTOR. C C D E S C R I P T I O N C C BACKSU IS A MODIFED VERSION OF THE LINPACK GENERAL BAND SOLVE C ROUTINE SGBSL WHICH USES AN INTEGER RATHER THAN A REAL PIVOT C VECTOR. C C R E F E R E N C E S C C J. J. DONGARRA, C. B. MOLER, J. R. BUNCH, AND G. W. STEWART, C LINPACK USERS' GUIDE. SIAM, PHILADELPHIA, 1979. C C A U T H O R C C WAYNE R. DYKSEN C DEPARTMENT OF COMPUTER SCIENCE C PURDUE UNIVERSITY C WEST LAFAYETTE, INDIANA 47097 C 317-494-6001 C C V E R S I O N C C JANUARY 1982 C C--------------------------------------------------------------------- C INTEGER LDA,N,ML,MU,JOB REAL ABD(LDA,*),B(*),PIVOTS(*) C C BACKSU SOLVES THE REAL BAND SYSTEM C A * X = B OR TRANS(A) * X = B C USING THE FACTORS COMPUTED BY FACTOR. C C ON ENTRY C C ABD REAL(LDA, N) C THE OUTPUT FROM FACTOR C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY ABD . C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C PIVOTS REAL(N) C THE PIVOT VECTOR FROM FACTOR. C C B REAL(N) C THE RIGHT HAND SIDE VECTOR. C C JOB INTEGER C = 0 TO SOLVE A*X = B , C = NONZERO TO SOLVE TRANS(A)*X = B , WHERE C TRANS(A) IS THE TRANSPOSE. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE C CALLED CORRECTLY AND IF FACTOR HAS SET INFO .EQ. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL FACTOR(ABD,LDA,N,ML,MU,PIVOTS,INFO) C IF (INFO .NE. 0) GO TO ... C DO 10 J = 1, P C CALL BACKSU(ABD,LDA,N,ML,MU,PIVOTS,C(1,J),0) C 10 CONTINUE C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SDOT C FORTRAN MIN0 C C INTERNAL VARIABLES C REAL SDOT,T INTEGER K,KB,L,LA,LB,LM,M,NM1 C M = MU + ML + 1 NM1 = N - 1 IF (JOB.NE.0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (ML.EQ.0) GO TO 30 IF (NM1.LT.1) GO TO 30 DO 20 K = 1,NM1 LM = MIN0(ML,N-K) L = PIVOTS(K) T = B(L) IF (L.EQ.K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL SAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE C C NOW SOLVE U*X = Y C DO 40 KB = 1,N K = N + 1 - KB B(K) = B(K)/ABD(M,K) LM = MIN0(K,M) - 1 LA = M - LM LB = K - LM T = -B(K) CALL SAXPY(LM,T,ABD(LA,K),1,B(LB),1) 40 CONTINUE GO TO 100 50 CONTINUE C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C DO 60 K = 1,N LM = MIN0(K,M) - 1 LA = M - LM LB = K - LM T = SDOT(LM,ABD(LA,K),1,B(LB),1) B(K) = (B(K)-T)/ABD(M,K) 60 CONTINUE C C NOW SOLVE TRANS(L)*X = Y C IF (ML.EQ.0) GO TO 90 IF (NM1.LT.1) GO TO 90 DO 80 KB = 1,NM1 K = N - KB LM = MIN0(ML,N-K) B(K) = B(K) + SDOT(LM,ABD(M+1,K),1,B(K+1),1) L = PIVOTS(K) IF (L.EQ.K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE FACTR(ABD,LDA,N,ML,MU,PIVOTS,INFO) C C P U R P O S E C C FACTOR FACTORS A REAL BAND MATRIX BY GAUSS ELIMINATION. C C D E S C R I P T I O N C C FACTOR FACTORS A REAL BAND MATRIX BY GAUSS ELIMINATION WITH C PARTIAL PIVOTING AND ROW EQUILIBRATION. FACTOR IS A MODIFIED C VERSION OF THE LINPACK GENERAL BAND FACTOR ROUTINE SGBFA WHICH C DOES NOT DO ROW EQUILIBRATION. C C R E F E R E N C E S C C J. J. DONGARRA, C. B. MOLER, J. R. BUNCH, AND G. W. STEWART, C LINPACK USERS' GUIDE. SIAM, PHILADELPHIA, 1979. C C A U T H O R C C WAYNE R. DYKSEN C DEPARTMENT OF COMPUTER SCIENCE C PURDUE UNIVERSITY C WEST LAFAYETTE, INDIANA 47097 C 317-494-6001 C C V E R S I O N C C JANUARY 1982 C C----------------------------------------------------------------------- C C INTEGER LDA,N,ML,MU,INFO REAL ABD(LDA,*),PIVOTS(*) C C ON ENTRY C C ABD REAL(LDA, N) C CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS C OF THE MATRIX ARE STORED IN THE COLUMNS OF ABD AND C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS C ML+1 THROUGH 2*ML+MU+1 OF ABD . C SEE THE COMMENTS BELOW FOR DETAILS. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY ABD . C LDA MUST BE .GE. 2*ML + MU + 1 . C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C 0 .LE. ML .LT. N . C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C 0 .LE. MU .LT. N . C MORE EFFICIENT IF ML .LE. MU . C ON RETURN C C ABD AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C PIVOTS REAL(N) C A REAL VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR C CONDITION FOR THIS SUBROUTINE, BUT IT DOES C INDICATE THAT EGBSL WILL DIVIDE BY ZERO IF C CALLED. C C BAND STORAGE C C IF A IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT C WILL SET UP THE INPUT. C C ML = (BAND WIDTH BELOW THE DIAGONAL) C MU = (BAND WIDTH ABOVE THE DIAGONAL) C M = ML + MU + 1 C DO 20 J = 1, N C I1 = MAX0(1, J-MU) C I2 = MIN0(N, J+ML) C DO 10 I = I1, I2 C K = I - J + M C ABD(K,J) = A(I,J) C 10 CONTINUE C 20 CONTINUE C C THIS USES ROWS ML+1 THROUGH 2*ML+MU+1 OF ABD . C IN ADDITION, THE FIRST ML ROWS IN ABD ARE USED FOR C ELEMENTS GENERATED DURING THE TRIANGULARIZATION. C THE TOTAL NUMBER OF ROWS NEEDED IN ABD IS 2*ML+MU+1 . C THE ML+MU BY ML+MU UPPER LEFT TRIANGLE AND THE C ML BY ML LOWER RIGHT TRIANGLE ARE NOT REFERENCED. C C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SSCAL C MODIFIED BLAS ISWMAX C FORTRAN MAX0,MIN0 C C INTERNAL VARIABLES C REAL T INTEGER I,ISAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 INTEGER KBEG,KEND,ISWMAX,IPVTK C C M = ML + MU + 1 INFO = 0 C C FIND RECIPROCAL OF LARGEST ELEMENT IN EACH ROW C FOR ROW EQUILIBRATION C DO 10 I = 1,N PIVOTS(I) = 0. 10 CONTINUE C DO 30 J = 1,N KBEG = M - MIN0(J-1,MU) KEND = M + MIN0(N-J,ML) DO 20 K = KBEG,KEND I = K + J - M PIVOTS(I) = AMAX1(PIVOTS(I),ABS(ABD(K,J))) 20 CONTINUE 30 CONTINUE C DO 40 I = 1,N IF (PIVOTS(I).NE.0.) PIVOTS(I) = 1./PIVOTS(I) 40 CONTINUE C C ZERO INITIAL FILL-IN COLUMNS C J0 = MU + 2 J1 = MIN0(N,M) - 1 IF (J1.LT.J0) GO TO 70 DO 60 JZ = J0,J1 I0 = M + 1 - JZ DO 50 I = I0,ML ABD(I,JZ) = 0.0E0 50 CONTINUE 60 CONTINUE 70 CONTINUE JZ = J1 JU = 0 C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C NM1 = N - 1 IF (NM1.LT.1) GO TO 170 DO 160 K = 1,NM1 KP1 = K + 1 C C ZERO NEXT FILL-IN COLUMN C JZ = JZ + 1 IF (JZ.GT.N) GO TO 90 IF (ML.LT.1) GO TO 90 DO 80 I = 1,ML ABD(I,JZ) = 0.0E0 80 CONTINUE 90 CONTINUE C C FIND L = PIVOT INDEX C LM = MIN0(ML,N-K) ISAMAX = ISWMAX(LM+1,ABD(M,K),PIVOTS(K),1) L = ISAMAX + M - 1 K1 = K + ISAMAX - 1 PIVOTS(K1) = PIVOTS(K) PIVOTS(K) = L + K - M C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (ABD(L,K).EQ.0.0E0) GO TO 140 C C INTERCHANGE IF NECESSARY C IF (L.EQ.M) GO TO 100 T = ABD(L,K) ABD(L,K) = ABD(M,K) ABD(M,K) = T 100 CONTINUE C C COMPUTE MULTIPLIERS C T = -1.0E0/ABD(M,K) CALL SSCAL(LM,T,ABD(M+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C IPVTK = PIVOTS(K) JU = MIN0(MAX0(JU,MU+IPVTK),N) MM = M IF (JU.LT.KP1) GO TO 130 DO 120 J = KP1,JU L = L - 1 MM = MM - 1 T = ABD(L,J) IF (L.EQ.MM) GO TO 110 ABD(L,J) = ABD(MM,J) ABD(MM,J) = T 110 CONTINUE CALL SAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1) 120 CONTINUE 130 CONTINUE GO TO 150 140 CONTINUE INFO = K 150 CONTINUE 160 CONTINUE 170 CONTINUE PIVOTS(N) = N IF (ABD(M,N).EQ.0.0E0) INFO = N RETURN END SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) C C OVERWRITE SINGLE PRECISION SY WITH SINGLE PRECISION SA*SX +SY. C REAL SX(*),SY(*),SA IF (N.LE.0 .OR. SA.EQ.0.E0) RETURN IF (INCX.EQ.INCY) IF (INCX-1) 10,30,70 10 CONTINUE C C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 DO 20 I = 1,N SY(IY) = SY(IY) + SA*SX(IX) IX = IX + INCX IY = IY + INCY 20 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. C 30 M = N - (N/4)*4 IF (M.EQ.0) GO TO 50 DO 40 I = 1,M SY(I) = SY(I) + SA*SX(I) 40 CONTINUE IF (N.LT.4) RETURN 50 MP1 = M + 1 DO 60 I = MP1,N,4 SY(I) = SY(I) + SA*SX(I) SY(I+1) = SY(I+1) + SA*SX(I+1) SY(I+2) = SY(I+2) + SA*SX(I+2) SY(I+3) = SY(I+3) + SA*SX(I+3) 60 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 70 CONTINUE NS = N*INCX DO 80 I = 1,NS,INCX SY(I) = SA*SX(I) + SY(I) 80 CONTINUE RETURN END REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) C C RETURNS THE DOT PRODUCT OF SINGLE PRECISION SX AND SY. C REAL SX(1),SY(1) SDOT = 0.0E0 IF (N.LE.0) RETURN IF (INCX.EQ.INCY) IF (INCX-1) 10,30,70 10 CONTINUE C C CODE FOR UNEQUAL INCREMENTS OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 DO 20 I = 1,N SDOT = SDOT + SX(IX)*SY(IY) IX = IX + INCX IY = IY + INCY 20 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. C 30 M = N - (N/5)*5 IF (M.EQ.0) GO TO 50 DO 40 I = 1,M SDOT = SDOT + SX(I)*SY(I) 40 CONTINUE IF (N.LT.5) RETURN 50 MP1 = M + 1 DO 60 I = MP1,N,5 SDOT = SDOT + SX(I)*SY(I) + SX(I+1)*SY(I+1) + SX(I+2)*SY(I+2) + . SX(I+3)*SY(I+3) + SX(I+4)*SY(I+4) 60 CONTINUE RETURN C C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. C 70 CONTINUE NS = N*INCX DO 80 I = 1,NS,INCX SDOT = SDOT + SX(I)*SY(I) 80 CONTINUE RETURN END SUBROUTINE SSCAL(N,SA,SX,INCX) C C SCALES A VECTOR BY A CONSTANT. C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO 1. C JACK DONGARRA, LINPACK, 3/11/78. C REAL SA,SX(*) INTEGER I,INCX,M,MP1,N,NINCX C IF (N.LE.0) RETURN IF (INCX.EQ.1) GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C NINCX = N*INCX DO 10 I = 1,NINCX,INCX SX(I) = SA*SX(I) 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,5) IF (M.EQ.0) GO TO 40 DO 30 I = 1,M SX(I) = SA*SX(I) 30 CONTINUE IF (N.LT.5) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 SX(I) = SA*SX(I) SX(I+1) = SA*SX(I+1) SX(I+2) = SA*SX(I+2) SX(I+3) = SA*SX(I+3) SX(I+4) = SA*SX(I+4) 50 CONTINUE RETURN END INTEGER FUNCTION ISWMAX(N,SX,WEIGHT,INCX) C C FINDS THE INDEX OF ELEMENT HAVING MAX. WEIGHTED ABSOLUTE VALUE. C WAYNE DYKSEN, JANUARY 1982 C REAL SX(1),WEIGHT(1),SMAX INTEGER I,INCX,IX,N C ISWMAX = 0 IF (N.LT.1) RETURN ISWMAX = 1 IF (N.EQ.1) RETURN IF (INCX.EQ.1) GO TO 30 C C CODE FOR INCREMENT NOT EQUAL TO 1 C IX = 1 SMAX = ABS(SX(1)*WEIGHT(1)) IX = IX + INCX DO 20 I = 2,N IF (ABS(SX(IX)*WEIGHT(I)).LE.SMAX) GO TO 10 ISWMAX = I SMAX = ABS(SX(IX)*WEIGHT(I)) 10 IX = IX + INCX 20 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C 30 SMAX = ABS(SX(1)*WEIGHT(1)) DO 40 I = 2,N IF (ABS(SX(I)*WEIGHT(I)).LE.SMAX) GO TO 40 ISWMAX = I SMAX = ABS(SX(I)*WEIGHT(I)) 40 CONTINUE RETURN END C/////////////////////////////////////////////////////////////////////// C//////////////////// END OF LOGICAL FILE 2 //////////////////////////// C/////////////////////////////////////////////////////////////////////// C//////////////////////////////////////////////////////////////////////// C//////////////////// ALGORITHM GENCOL //////////////////////////////// C/////////////////////////////////////////////////////////////////////// C>>>>>>>>>> LOGICAL FILE 3 : RELATED SUBPROGRAMS TO S/R OUTPUT<<<<<<<<<< C/////////////////////////////////////////////////////////////////////// SUBROUTINE SETGRD(GRIDX,GRIDY,NGRIDX,NGRIDY,AX,BX,AY,BY,IGRID) C REAL GRIDX(*),GRIDY(*) C IF (IGRID.LT.0) GO TO 20 C DX = BX - AX DY = BY - AY NGRIDX = IGRID NGRIDY = IGRID C AIGRM1 = IGRID - 1 DO 10 I = 1,IGRID AIM1 = I - 1 GRIDX(I) = AX + (AIM1)*DX/ (AIGRM1) GRIDY(I) = AY + (AIM1)*DY/ (AIGRM1) 10 CONTINUE C RETURN C 20 CONTINUE RETURN END SUBROUTINE FNDINT(X1A,Y1A,X1B,Y1B,X2A,Y2A,X2B,Y2B,X0,Y0,NOINT) C C ............................................................... C C E L L P A C K 7 8 O U T P U T M O D U L E C C SUBROUTINE FNDINT C C PURPOSE C TO FIND THE INTERSECTION POINT (X0,Y0) OF LINE L1 C DEFINED BY (X1A,Y1A) AND (X1B,Y1B) AND LINE L2 C DEFINED BY (X2A,Y2A) AND (X2B,Y2B). C C METHOD C THE SLOPE INTERCEPT FORM ( Y = M*X + B ) IS USED. C C ............................................................... C REAL X1A,Y1A,X1B,Y1B,X2A,Y2A,X2B,Y2B,X0,Y0,M1,B1,M2,B2,DX,DM, . EPSGRD COMMON /NUMCON/EPSGRD NOINT = 0 NCASE = 1 C C IS L1 A VERTICAL LINE C DX = X1B - X1A IF (ABS(DX).GT.EPSGRD) GO TO 10 NCASE = 2 GO TO 20 10 CONTINUE M1 = (Y1B-Y1A)/DX B1 = Y1A - M1*X1A 20 CONTINUE C C IS L2 A VERTICAL LINE C DX = X2B - X2A IF (ABS(DX).GT.EPSGRD) GO TO 30 NCASE = NCASE + 2 GO TO 40 30 CONTINUE M2 = (Y2B-Y2A)/DX B2 = Y2A - M2*X2A C C BRANCH ON NCASE C C NCASE = 1 - BOTH LINES ARE NOT VERTICAL C NCASE = 2 - L1 IS VERTICAL, L2 IS NOT C NCASE = 3 - L2 IS VERTICAL, L1 IS NOT C NCASE = 4 - BOTH LINES ARE VERTICAL C 40 CONTINUE GO TO (50,60,70,80),NCASE C C BOTH LINES ARE NOT VERTICAL C 50 CONTINUE DM = M2 - M1 IF (ABS(DM).LE.EPSGRD) GO TO 80 X0 = (B1-B2)/DM Y0 = M1*X0 + B1 GO TO 90 C C L1 IS VERTICAL, L2 IS NOT C 60 CONTINUE X0 = X1A Y0 = M2*X0 + B2 GO TO 90 C C L2 IS VERTICAL, L1 IS NOT C 70 CONTINUE X0 = X2A Y0 = M1*X0 + B1 GO TO 90 C C L1 AND L2 ARE PARALLEL C 80 CONTINUE NOINT = 1 C 90 CONTINUE RETURN END SUBROUTINE INSQAR(X,Y,GT,GX,GY,XBOUND,YBOUND,NBNDPT,IPNTYP,IERR) C C ............................................................... C C E L L P A C K 7 8 O U T P U T M O D U L E C C SUBROUTINE INSQAR C C PURPOSE C TO DETERMINE IF THE POINT (X,Y) IS INSIDE THE REGION, C ON THE BOUNDARY, OR OUTSIDE THE REGION WHEN (X,Y) IS C INSIDE A GRID SQUARE. C C PARAMETERS C X - THE X COORDINATE OF THE POINT C Y - THE Y COORDINATE OF THE POINT C GT - THE GTYPES OF THE FOUR CORNER POINTS OF THE C SQUARE BEGINNING WITH THE LOWER LEFT HAND C POINT AND PROCEEDING COUNTERCLOCKWISE. C GX - GX(1) IS THE X COORDINATE OF THE LEFT GRID C LINE BOUNDING THE GRID SQUARE WHILE GX(2) C IS THE X COORDINATE OF THE RIGHT BOUNDARY. C GY - GY(1) IS THE Y COORDINATE OF THE BOTTOM OF C THE GRID SQUARE WHILE GY(2) IS THE Y COORDI- C NATE OF THE TOP. C IPNTYP - 1, IF (X,Y) IS INSIDE THE REGION C 2, IF (X,Y) IS ON THE BOUNDARY C 3, IF (X,Y) IS OUTSIDE THE REGION C IERR - ERROR RETURN CODE. C C ............................................................... C REAL X,Y,GX(4),GY(4),XBOUND(NBNDPT),YBOUND(NBNDPT),XBK,YBK,XBKP1, . YBKP1,PLEN,BLEN,GXL,GYL,XINT,YINT INTEGER GT(4),IBOUND(8) COMMON /NUMCON/EPSGRD C C NINSID - THE NUMBER OF NEIGHBORING GRID POINTS C INSIDE THE DOMAIN C NOUTSD - THE NUMBER OF NEIGHBORING GRID POINTS C OUTSIDE THE DOMAIN C NINSID = 0 NOUTSD = 0 C DO 20 K = 1,4 IF (GT(K).LT.999) GO TO 10 NINSID = NINSID + 1 GO TO 20 10 CONTINUE IF (GT(K).LE.0) NOUTSD = NOUTSD + 1 20 CONTINUE C NCASE = 5*NOUTSD + NINSID + 1 C C BRANCH ON NCASE C ----------------------------------- C NOUTSD NINSID NCASE (X,Y) C ----------------------------------- C C 0 0 1 OUTSIDE C 0 1 2 INSIDE C 0 2 3 INSIDE C 0 3 4 INSIDE C 0 4 5 INSIDE C 1 0 6 OUTSIDE C 1 1 7 UNKNOWN C 1 2 8 UNKNOWN C 1 3 9 UNKNOWN C 1 4 10 IMPOSS. C 2 0 11 OUTSIDE C 2 1 12 UNKNOWN C 2 2 13 UNKNOWN C 2 3 14 IMPOSS. C 2 4 15 IMPOSS. C 3 0 16 OUTSIDE C 3 1 17 UNKNOWN C 3 2 18 IMPOSS. C 3 3 19 IMPOSS. C 3 4 20 IMPOSS. C 4 0 21 OUTSIDE C GO TO (120,100,100,100,100,120,30,30,30, . 130,120,30,30,130,130,120,30,130, . 130,130,120),NCASE C C THIS IS THE CASE WHERE AT LEAST ONE OF THE C NEIGHBORING GRID POINTS IS INSIDE AND AT C LEAST ONE IS OUTSIDE. C 30 CONTINUE KB = 0 C DO 40 K = 1,NBNDPT IF (XBOUND(K).LT.GX(1)-EPSGRD) GO TO 40 IF (YBOUND(K).LT.GY(1)-EPSGRD) GO TO 40 IF (XBOUND(K).GT.GX(3)+EPSGRD) GO TO 40 IF (YBOUND(K).GT.GY(3)+EPSGRD) GO TO 40 KB = KB + 1 IBOUND(KB) = K 40 CONTINUE C IF (KB.GE.2) GO TO 50 IERR = 3 GO TO 120 C 50 CONTINUE KSTOP = KB - 1 C DO 90 K = 1,KSTOP IBK = IBOUND(K) IBKP1 = IBOUND(K+1) IF (IBKP1-IBK.EQ.1) GO TO 60 IF (IBK.NE.1) GO TO 90 IF (IBKP1.NE.NBNDPT) GO TO 90 60 CONTINUE XBK = XBOUND(IBK) YBK = YBOUND(IBK) XBKP1 = XBOUND(IBKP1) YBKP1 = YBOUND(IBKP1) IF (ABS(XBK-XBKP1).LT.EPSGRD) GO TO 90 IF (ABS(YBK-YBKP1).LT.EPSGRD) GO TO 90 C DO 80 L = 1,4 IF ((GT(L).GT.0) .AND. (GT(L).LT.999)) GO TO 80 GXL = GX(L) GYL = GY(L) CALL FNDINT(X,Y,GXL,GYL,XBK,YBK,XBKP1,YBKP1,XINT,YINT,NOINT) IF (NOINT.NE.0) GO TO 80 IF (XINT.GT.AMAX1(XBK,XBKP1)+EPSGRD) GO TO 80 IF (XINT.LT.AMIN1(XBK,XBKP1)-EPSGRD) GO TO 80 IF (YINT.GT.AMAX1(YBK,YBKP1)+EPSGRD) GO TO 80 IF (YINT.LT.AMIN1(YBK,YBKP1)-EPSGRD) GO TO 80 C C PLEN - THE DISTANCE FROM THE GRID POINT TO (X,Y) C C BLEN - THE DISTANCE FROM THE GRID POINT TO THE C BOUNDARY INTERSECTION POINT C PLEN = (GXL-X)**2 + (GYL-Y)**2 BLEN = (GXL-XINT)**2 + (GYL-YINT)**2 C C NOW DETERMINE THE RELATIONSHIP C OF (X,Y) TO THE BOUNDARY. C IF (ABS(PLEN-BLEN).LE.EPSGRD) GO TO 110 IF (GT(L).LE.0) GO TO 70 IF (PLEN.LT.BLEN) GO TO 100 GO TO 120 70 CONTINUE IF (PLEN.GT.BLEN) GO TO 100 GO TO 120 80 CONTINUE 90 CONTINUE GO TO 120 C C (X,Y) IS INSIDE C 100 CONTINUE IPNTYP = 1 GO TO 130 C C (X,Y) IS ON THE BOUNDARY C 110 CONTINUE IPNTYP = 2 GO TO 130 C C (X,Y) IS OUTSIDE C 120 CONTINUE IPNTYP = 3 C 130 CONTINUE RETURN END SUBROUTINE OUTSID(X,Y,GTYPE,GRIDX,GRIDY,XBOUND,YBOUND,NGRDXD, . NGRDYD,NBNDPT,IPNTYP,IERR) C C ............................................................... C C E L L P A C K 7 8 O U T P U T M O D U L E C C SUBROUTINE OUTSID C C PURPOSE C TO DETERMINE IF THE POINT (X,Y) IS INSIDE THE REGION, C ON THE BOUNDARY, OR OUTSIDE THE REGION. C C PARAMETERS C X - THE X COORDINATE OF THE POINT C Y - THE Y COORDINATE OF THE POINT C IPNTYP - 1, IF (X,Y) IS INSIDE THE REGION C 2, IF (X,Y) IS ON THE BOUNDARY C 3, IF (X,Y) IS OUTSIDE THE REGION C IERR - ERROR RETURN CODE. C 1, IF NO NEIGHBORING VERTICAL GRID C LINES WERE FOUND. C 2, IF NO NEIGHBORING HORIZONTAL GRID C LINES WERE FOUND. C 3, IF AN ERROR OCCURED IN SUBROUTINE INSQAR. C 4, IF AN ERROR OCCURED IN SUBROUTINE ONLINE. C C ............................................................... C REAL X,Y,GRIDX(NGRDXD),GRIDY(NGRDYD),XBOUND(NBNDPT), . YBOUND(NBNDPT),GX(4),GY(4),EPSGRD,AX,BX,AY,BY INTEGER GTYPE(NGRDXD,NGRDYD),GT(4),IPNTYP,IPTCOM COMMON /PROBR/AX,BX,AY,BY COMMON /NUMCON/EPSGRD COMMON /PNTYPE/IPTCOM C C CHECK FOR TRIVIAL CASES C IERR = 0 IF (X.LT.AX-EPSGRD) GO TO 130 IF (Y.LT.AY-EPSGRD) GO TO 130 IF (X.GT.BX+EPSGRD) GO TO 130 IF (Y.GT.BY+EPSGRD) GO TO 130 NCASE = 1 C C FIND VERTICAL GRID LINES SUCH THAT C C GRIDX(I-1) .LT. X .LT. GRIDX(I) C C DO 20 I = 1,NGRDXD IF (ABS(GRIDX(I)-X).GT.EPSGRD) GO TO 10 NCASE = 2 GO TO 30 10 CONTINUE IF (X.LE.GRIDX(I)) GO TO 30 20 CONTINUE C IERR = 1 GO TO 130 C C FIND HORIZONTAL GRID LINES SUCH THAT C C GRIDY(J-1) .LT. Y .LT. GRIDY(J) C 30 CONTINUE C DO 50 J = 1,NGRDYD IF (ABS(GRIDY(J)-Y).GT.EPSGRD) GO TO 40 NCASE = NCASE + 2 GO TO 60 40 CONTINUE IF (Y.LE.GRIDY(J)) GO TO 60 50 CONTINUE C IERR = 2 GO TO 130 C C BRANCH ON NCASE C C NCASE = 1 - (X,Y) IS STRICTLY ON THE INTERIOR C OF A GRID SQUARE C NCASE = 2 - (X,Y) IS ON A VERTICAL GRID LINE C NCASE = 3 - (X,Y) IS ON A HORIZONTAL GRID LINE C NCASE = 4 - (X,Y) IS A GRID POINT C 60 CONTINUE GO TO (70,80,90,100),NCASE C C (X,Y) IS AN INTERIOR POINT C 70 CONTINUE GX(1) = GRIDX(I-1) GX(2) = GRIDX(I) GX(3) = GX(2) GX(4) = GX(1) GY(1) = GRIDY(J-1) GY(2) = GY(1) GY(3) = GRIDY(J) GY(4) = GY(3) GT(1) = GTYPE(I-1,J-1) GT(2) = GTYPE(I,J-1) GT(3) = GTYPE(I,J) GT(4) = GTYPE(I-1,J) CALL INSQAR(X,Y,GT,GX,GY,XBOUND,YBOUND,NBNDPT,IPNTYP,IERR) GO TO 140 C C (X,Y) IS ON A VERTICAL GRID LINE C 80 CONTINUE GY(1) = GRIDY(J-1) GY(2) = GRIDY(J) GT(1) = GTYPE(I,J-1) GT(2) = GTYPE(I,J) CALL ONLINE(X,Y,GT,GY,XBOUND,YBOUND,NBNDPT,IPNTYP,IERR) GO TO 140 C C (X,Y) IS ON A HORIZONTAL GRID LINE C 90 CONTINUE GX(1) = GRIDX(I-1) GX(2) = GRIDX(I) GT(1) = GTYPE(I-1,J) GT(2) = GTYPE(I,J) CALL ONLINE(Y,X,GT,GX,YBOUND,XBOUND,NBNDPT,IPNTYP,IERR) GO TO 140 C C (X,Y) IS A GRID POINT C 100 CONTINUE IF (GTYPE(I,J).GT.999) GO TO 110 IF (GTYPE(I,J).GT.0) GO TO 120 GO TO 130 C C (X,Y) IS INSIDE C 110 CONTINUE IPNTYP = 1 GO TO 140 C C (X,Y) IS ON THE BOUNDARY C 120 CONTINUE IPNTYP = 2 GO TO 140 C C (X,Y) IS OUTSIDE C 130 CONTINUE IPNTYP = 3 C 140 CONTINUE IPTCOM = IPNTYP RETURN END SUBROUTINE ONLINE(X,Y,GT,GY,XBOUND,YBOUND,NBNDPT,IPNTYP,IERR) C C ............................................................... C C E L L P A C K 7 8 O U T P U T M O D U L E C C SUBROUTINE ONLINE C C PURPOSE C TO DETERMINE IF THE POINT (X,Y) IS INSIDE THE REGION, C ON THE BOUNDARY, OR OUTSIDE THE REGION WHEN (X,Y) IS C ON A VERTICAL GRID LINE. C C PARAMETERS C X - THE X COORDINATE OF THE POINT C Y - THE Y COORDINATE OF THE POINT C GT - GT(1) IS THE GTYPE OF THE LOWER GRID POINT C (X,GY(1)) WHILE GT(2) IS THE GTYPE OF THE C THE UPPER GRID POINT (X,GY(2)) C GY - GY(1) IS THE Y COORDINATE OF THE LOWER GRID C POINT WHILE GY(2) IS THE Y COORDINATE OF THE C UPPER GRID POINT. C IPNTYP - 1, IF (X,Y) IS INSIDE THE REGION C 2, IF (X,Y) IS ON THE BOUNDARY C 3, IF (X,Y) IS OUTSIDE THE REGION C IERR - ERROR RETURN CODE. C C ............................................................... C REAL X,Y,GY(2),XBOUND(NBNDPT),YBOUND(NBNDPT),PLEN,BLEN INTEGER GT(2),IGT(2) COMMON /NUMCON/EPSGRD C C NINSID - THE NUMBER OF NEIGHBORING GRID POINTS C INSIDE THE DOMAIN C NOUTSD - THE NUMBER OF NEIGHBORING GRID POINTS C OUTSIDE THE DOMAIN C NINSID = 0 NOUTSD = 0 C DO 20 K = 1,2 IF (GT(K).LT.999) GO TO 10 NINSID = NINSID + 1 GO TO 20 10 CONTINUE IF (GT(K).LE.0) NOUTSD = NOUTSD + 1 20 CONTINUE C NCASE = 3*NOUTSD + NINSID + 1 C C BRANCH ON NCASE C ----------------------------------- C NOUTSD NINSID NCASE (X,Y) C ----------------------------------- C C 0 0 1 BOUNDARY C 0 1 2 INSIDE C 0 2 3 INSIDE C 1 0 4 OUTSIDE C 1 1 5 UNKNOWN C 1 2 6 IMPOSS. C 2 0 7 OUTSIDE C GO TO (100,90,90,110,30,120,110),NCASE C C THIS IS THE CASE WHERE ONE OF THE NEIGHBORING GRID C POINTS IS INSIDE WHILE THE OTHER IS OUTSIDE. C C FIRST, TRY TO USE GTYPE INFO SAVED IN GT TO FIND THE C BOUNDARY - GRID LINE INTERSECTION POINT. C 30 CONTINUE C DO 40 K = 1,2 KB = MOD(IABS(GT(K)),1000) IF (ABS(XBOUND(KB)-X).GT.EPSGRD) GO TO 40 IF (YBOUND(KB).LT.GY(1)) GO TO 40 IF (YBOUND(KB).GT.GY(2)) GO TO 40 GO TO 60 40 CONTINUE C C USING GTYPE HAS FAILED. C NOW TRY A BRUTE FORCE SEARCH. C DO 50 KB = 1,NBNDPT IF (ABS(XBOUND(KB)-X).GT.EPSGRD) GO TO 50 IF (YBOUND(KB).LT.GY(1)) GO TO 50 IF (YBOUND(KB).GT.GY(2)) GO TO 50 GO TO 60 50 CONTINUE C IERR = 4 GO TO 120 C C PLEN - THE DISTANCE FROM THE INTERIOR POINT TO (X,Y) C C BLEN - THE DISTANCE FROM THE INTERIOR POINT TO THE C BOUNDARY - GRID LINE INTERSECTION POINT C 60 CONTINUE IF (GT(2).GE.999) GO TO 70 PLEN = ABS(GY(1)-Y) BLEN = ABS(GY(1)-YBOUND(KB)) GO TO 80 70 CONTINUE PLEN = ABS(GY(2)-Y) BLEN = ABS(GY(2)-YBOUND(KB)) C C NOW DETERMINE THE RELATIONSHIP C OF (X,Y) TO THE BOUNDARY. C 80 CONTINUE IF (ABS(PLEN-BLEN).LE.EPSGRD) GO TO 100 IF (PLEN.LT.BLEN) GO TO 90 GO TO 110 C C (X,Y) IS INSIDE C 90 CONTINUE IPNTYP = 1 GO TO 120 C C (X,Y) IS ON THE BOUNDARY C 100 CONTINUE IPNTYP = 2 GO TO 120 C C (X,Y) IS OUTSIDE C 110 CONTINUE IPNTYP = 3 C 120 CONTINUE RETURN END SUBROUTINE TABLER(OUTFNC,TABX,NTABX,TABY,NTABY,TPRINT,GTYPE, . NGRDXD,NGRDYD,UNKNWN,RECTAN) C C C PURPOSE C C PRINTS THE VALUES OF THE OUTPUT FUNCTION ON THE GRID C DEFINED BY THE ARRAYS TABX AND TABY IF A PAR- C TICULAR GRID POINT IS INSIDE THE REGION. C C PARAMETERS C C OUTFNC - INDICATES WHAT FUNCTION IS TO BE OUTPUT C =1 APPROXIMATE SOLUTION C =2 ERROR (TRUE MUST BE SUPPLIED) C =3 RESIDUAL C C TABX, TABY - X AND Y COORDINATES FOR OUTTYP 2 AND 4 C C NTABX, NTABY - NUMBER OF VALUES IN TABX, TABY C C RECTAN - =TRUE - RECTANGULAR DOMAIN C =FALSE- NONRECTANGULAR DOMAIN C C TPRINT - WORKSPACE OF DIMENSION >= NTABX C C ALL OTHER PARAMETERS ARE PASSED TO SUBROUTINES C C REAL TABX(NTABX),TABY(NTABY),DERVSL(6),UNKNWN(1),TPRINT(NTABX) C INTEGER GTYPE(NGRDXD,NGRDYD),OUTFNC C LOGICAL RECTAN C COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT,NROW C C C PRINT HEADING C IF (OUTFNC.EQ.1) WRITE (MOUTPT,9001) NTABX,NTABY IF (OUTFNC.EQ.2) WRITE (MOUTPT,9011) NTABX,NTABY IF (OUTFNC.EQ.3) WRITE (MOUTPT,9021) NTABX,NTABY WRITE (MOUTPT,9031) WRITE (MOUTPT,9051) (TABX(I),I=1,NTABX) C C DO 20 JUP = 1,NTABY J = NTABY - JUP + 1 Y = TABY(J) WRITE (MOUTPT,9041) Y C DO 10 I = 1,NTABX TPRINT(I) = 0.0 X = TABX(I) IPNTYP = 0 IF ( .NOT. RECTAN) CALL OUTSID(X,Y,GTYPE,GRIDX,GRIDY,XBOUND, . YBOUND,NGRDXD,NGRDYD,NBNDPT,IPNTYP, . IERR) IF (IPNTYP.EQ.3) GO TO 10 IF (OUTFNC.NE.3) TPRINT(I) = COLAPR(X,Y,UNKNWN,DERVSL, . RECTAN) IF (OUTFNC.EQ.2) TPRINT(I) = TPRINT(I) - TRUE(X,Y) IF (OUTFNC.EQ.3) TPRINT(I) = RESID(X,Y,IPNTYP,UNKNWN,RECTAN) 10 CONTINUE C WRITE (MOUTPT,9051) (TPRINT(I),I=1,NTABX) 20 CONTINUE C RETURN 9001 FORMAT (///1H ,10X,46 (1H+)/1H ,10X,1H+,44X,1H+/1H ,10X,1H+,4X, . 9HTABLE OF ,8HSOLUTION,3H ON,I4,2H X,I4, . 6H GRID,4X,1H+) 9011 FORMAT (///1H ,10X,46 (1H+)/1H ,10X,1H+,44X,1H+/1H ,10X,1H+,4X, . 9HTABLE OF ,8HERROR ,3H ON,I4,2H X,I4, . 6H GRID,4X,1H+) 9021 FORMAT (///1H ,10X,46 (1H+)/1H ,10X,1H+,44X,1H+/1H ,10X,1H+,4X, . 9HTABLE OF ,9HRESIDUALS,3H ON,I4,2H X,I4, . 6H GRID,4X,1H+) 9031 FORMAT (1H ,10X,1H+,44X,1H+/1H ,10X,46 (1H+)///1H ,4X, . 15HX-ABSCISSAE ARE/1H ,4X,15 (1H-)) 9041 FORMAT (/1H ,7X,3HY =,E13.6/1H ,7X,16 (1H-)) 9051 FORMAT ((1H ,3X,E13.6,3X,E13.6,3X,E13.6,3X,E13.6)) END SUBROUTINE FNCMAX(OUTFNC,TABX,NTABX,TABY,NTABY,GTYPE,NGRDXD, . NGRDYD,UNKNWN,RECTAN) C C C PURPOSE C C COMPUTE AND PRINT MAX, L1 AND L2 NORMS OF THE OUTPUT C FUNCTION BASED ON THE GRID DEFINED BY TABX AND TABY C C PARAMETERS C C OUTFNC - INDICATES WHAT FUNCTION IS TO BE OUTPUT C =1 APPROXIMATE SOLUTION C =2 ERROR (TRUE MUST BE SUPPLIED) C =3 RESIDUAL C C TABX, TABY - GRID ON WHICH TO MEASURE NORMS C C NTABX, NTABY - NUMBER OF VALUES IN TABX, TABY C C RECTAN - =TRUE - RECTANGULAR DOMAIN C =FALSE- NONRECTANGULAR DOMAIN C C REAL TABX(NTABX),TABY(NTABY),DERVSL(6),UNKNWN(*) C INTEGER GTYPE(NGRDXD,NGRDYD),OUTFNC C LOGICAL RECTAN C COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT,NROW C C R1NRMI = 0.0 R1NRM1 = 0.0 R1NRM2 = 0.0 GPTS = 0 C C DO 20 I = 1,NTABX X = TABX(I) DO 10 J = 1,NTABY Y = TABY(J) IPTYPE = 0 IF ( .NOT. RECTAN) CALL OUTSID(X,Y,GTYPE,GRIDX,GRIDY,XBOUND, . YBOUND,NGRDXD,NGRDYD,NBNDPT,IPTYPE, . IERR) IF (IPTYPE.EQ.3) GO TO 10 IF (OUTFNC.NE.3) FVALUE = COLAPR(X,Y,UNKNWN,DERVSL,RECTAN) IF (OUTFNC.EQ.2) FVALUE = ABS(FVALUE-TRUE(X,Y)) IF (OUTFNC.EQ.3) FVALUE = RESID(X,Y,IPTYPE,UNKNWN,RECTAN) GPTS = GPTS + 1. R1NRMI = AMAX1(R1NRMI,FVALUE) R1NRM1 = R1NRM1 + FVALUE R1NRM2 = R1NRM2 + FVALUE**2 10 CONTINUE 20 CONTINUE R1NRM1 = R1NRM1/GPTS R1NRM2 = SQRT(R1NRM2/GPTS) IF (OUTFNC.EQ.1) WRITE (MOUTPT,9001) NTABX,NTABY,R1NRMI,NTABX, . NTABY,R1NRM1,NTABX,NTABY,R1NRM2 IF (OUTFNC.EQ.2) WRITE (MOUTPT,9011) NTABX,NTABY,R1NRMI,NTABX, . NTABY,R1NRM1,NTABX,NTABY,R1NRM2 IF (OUTFNC.EQ.3) WRITE (MOUTPT,9021) NTABX,NTABY,R1NRMI,NTABX, . NTABY,R1NRM1,NTABX,NTABY,R1NRM2 RETURN C C 9001 FORMAT (//5X,60 (1H+)/5X,1H+,58X,1H+/5X,12H+ MAX( ABS(, . 8HSOLUTION,7H) ) ON ,I3,3H X ,I3,7H GRID =, . 1PE14.7,2X,1H+/5X,1H+,58X,1H+/5X, . 12H+ L1 NORM( ,8HSOLUTION,7H) ON ,I3,3H X , . I3,7H GRID =,1PE14.7,2X,1H+/5X,1H+,58X,1H+/5X, . 12H+ L2 NORM( ,8HSOLUTION,7H) ON ,I3,3H X , . I3,7H GRID =,1PE14.7,2X,1H+/5X,1H+,58X,1H+/5X, . 60 (1H+)) 9011 FORMAT (//5X,60 (1H+)/5X,1H+,58X,1H+/5X,12H+ MAX( ABS(, . 8HERROR ,7H) ) ON ,I3,3H X ,I3,7H GRID =, . 1PE14.7,2X,1H+/5X,1H+,58X,1H+/5X, . 12H+ L1 NORM( ,8HERROR ,7H) ON ,I3,3H X , . I3,7H GRID =,1PE14.7,2X,1H+/5X,1H+,58X,1H+/5X, . 12H+ L2 NORM( ,8HERROR ,7H) ON ,I3,3H X , . I3,7H GRID =,1PE14.7,2X,1H+/5X,1H+,58X,1H+/5X, . 60 (1H+)) 9021 FORMAT (//5X,60 (1H+)/5X,1H+,58X,1H+/5X,12H+ MAX( ABS(, . 8HRESIDUAL,7H) ) ON ,I3,3H X ,I3,7H GRID =, . 1PE14.7,2X,1H+/5X,1H+,58X,1H+/5X, . 12H+ L1 NORM( ,8HRESIDUAL,7H) ON ,I3,3H X , . I3,7H GRID =,1PE14.7,2X,1H+/5X,1H+,58X,1H+/5X, . 12H+ L2 NORM( ,8HRESIDUAL,7H) ON ,I3,3H X , . I3,7H GRID =,1PE14.7,2X,1H+/5X,1H+,58X,1H+/5X, . 60 (1H+)) END REAL FUNCTION RESID(X,Y,IPTCOM,UNKNWN,RECTAN) C C C PURPOSE C TO DETERMINE THE VALUE OF THE RESIDUAL AT C THE POINT (X,Y). C C PARAMETERS C C X,Y - THE POINT AT WHICH TO COMPUTE THE RESIDUAL C IPTCOM - RESULT FROM SUBROUTINE OUTSID C =1 POINT IS INTERIOR TO DOMAIN C =2 POINT IS ON BOUNDARY OF DOMAIN C C REAL UNKNWN(*),BVALUS(4),DERVSL(6),CVALUS(7) C C LOGICAL RECTAN C COMMON /BRANZZ/BRANGE(2,1) COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /NUMCON/EPSGRD COMMON /PROBR/AX,BX,AY,BY C RESID = 0. C C CHECK TO SEE IF (X,Y) IS ON THE BOUNDARY. C IN THIS CASE THE RESIDUAL OF THE BOUNDARY C OPERATOR MUST BE COMPUTED. C C FOR RECTANGULAR DOMAINS, NEED TO SET IPTCOM C IF ( .NOT. RECTAN) GO TO 10 IPTCOM = 1 IF (X.EQ.AX .OR. X.EQ.BX .OR. Y.EQ.AY .OR. Y.EQ.BY) IPTCOM = 2 C 10 IF (IPTCOM.EQ.2) GO TO 20 C C EVALUATE THE COEFFICIENTS OF THE PDE OPERATOR. C CALL PDE(X,Y,CVALUS) GO TO 60 C C EVALUATE COEFFICIENTS OF BOUNDARY OPERATOR C 20 CONTINUE C C FIND THE BOUNDARY PIECE THE POINT IS ON C IF (RECTAN) GO TO 40 C C NONRECTANGULAR CASE C DO 30 IP = 1,NBOUND IPIECE = IP P = BRANGE(1,IP) CALL BCOORD(P,X1,Y1,IPIECE) P = BRANGE(2,IP) CALL BCOORD(P,X2,Y2,IPIECE) IF (X.LT.AMIN1(X1,X2)-EPSGRD) GO TO 30 IF (Y.LT.AMIN1(Y1,Y2)-EPSGRD) GO TO 30 IF (X.GT.AMAX1(X1,X2)+EPSGRD) GO TO 30 IF (Y.GT.AMAX1(Y1,Y2)+EPSGRD) GO TO 30 GO TO 50 30 CONTINUE GO TO 80 C C RECTANGULAR CASE C 40 IF (X.EQ.BX) IP = 1 IF (Y.EQ.AY) IP = 2 IF (X.EQ.AX) IP = 3 IF (Y.EQ.BY) IP = 4 C 50 CONTINUE C C EVALUATE BOUNDARY COEFFICIENTS C TEMP = BCOND(IP,X,Y,BVALUS) C C EVALUATE COMPUTED SOLUTION AND ITS DERIVATIVES AT (X,Y) C 60 CONTINUE TEMP = COLAPR(X,Y,UNKNWN,DERVSL,RECTAN) C C DERIVATIVES OF SOLUTION ARE NOW IN THE ARRAY DERVSL C C COMPUTE THE RESIDUAL FOR ALL CASES C IF (IPTCOM.EQ.2) GO TO 70 C C RESIDUAL OF PDE OPERATOR IS C RESID = CVALUS(1)*DERVSL(1) + CVALUS(2)*DERVSL(2) + . CVALUS(3)*DERVSL(3) + CVALUS(4)*DERVSL(4) + . CVALUS(5)*DERVSL(5) + CVALUS(6)*DERVSL(6) - PDERHS(X,Y) GO TO 80 C C THE RESIDUAL OF THE BOUNDARY OPERATOR IS C 70 CONTINUE RESID = BVALUS(1)*DERVSL(6) + BVALUS(2)*DERVSL(4) + . BVALUS(3)*DERVSL(5) - BVALUS(4) C 80 CONTINUE RETURN END C///////////////////////////////////////////////////////////////////// C///////////////////// END OF LOGICAL FILE 3 ///////////////////////// C///////////////////////////////////////////////////////////////////// C//////////////////////////////////////////////////////////////////// C///////////////// ALGORITHM GENCOL //////////////////////////////// C/////////////////////////////////////////////////////////////////// C>>>>>>>>> LOGICAL FILE 4 : RELATED SUBPROGRAMS TO S/R REGION<<<<<<<< C//////////////////////////////////////////////////////////////////// SUBROUTINE DOMAIN(XGRID,YGRID,NGDIMX,NGDIMY,BRANGE,NPDIM,BCOORD, . GTYPE,XBOUND,YBOUND,PIECE,BPTYPE,BNEIGH,BGRID, . BPARAM,NBDIM) C C ***** THIS SUBROUTINE PROCESSES THE RECTANGULAR GRID AND SPECIFIED C BOUNDARY. IT APPLIES TO ONE CLOSED LOOP OR ARC OF THE BOUNDARY AND C MAY BE CALLED SEVERAL TIMES FOR A COMPLEX DOMAIN C C ------------------- INPUT INFORMATION FOR DOMAIN ------------------ C THE INPUT INFORMATION IS IN THE COMMON BLOCKS AND ARGUMENTS C SEE THE MAIN DRIVER REGION FOR MORE DETAILS C C 1** OUTPUT LEVEL CONTROL ******* C LEVEL = CONTROL SETTING, DETAILS GIVEN BELOW C C 2** GRID DEFINITION ************ C C NGDIMX,NGDIMY = NGRIDX,NGRIDY = GRID LINES IN X AND Y COORDINATES C XGRID(IX),YGRID(JY) FOR IX = 1 TO NGRIDX, JY = 1 TO NGRIDY C C 3** BOUNDARY DEFINITION ******** C C N1BND = NUMBER OF THE FIRST BOUNDARY PIECE C WILL DIFFER FROM 1 AFTER FIRST CALL C NPDIM = ARRAY DIMENSION FOR BOUNDARY PIECES C N1BDPT = NUMBER OF THE FIRST BOUNDARY POINT C WILL DIFFER FROM 1 AFTER FIRST CALL C NBDIM = ARRAY DIMENSION FOR BOUNDARY POINTS C BCOORD = PARAMETERIZED DEFINITION OF THE BOUNDARY. C BCOORD(P,X,Y,IPIECE) GIVES THE X,Y VALUES OF THE C POINT ON PIECE IPIECE WITH PARAMETER VALUE = P. C BRANGE(2,I) = FIRST AND LAST VALUES OF PARAMETERS DEFINING C THE I-TH BOUNDARY PIECE C CLOCKW = SWITCH TO SPECIFY BOUNDARY ORIENTATION C .TRUE. MEANS BOUNDARY IS CLOCKWISE C .FALSE.MEANS BOUNDARY IS COUNTER-CLOCKWISE C ARC = .TRUE. MEANS DOMAIN IS AN ARC WITH NO INTERIOR C C ----------- THE OUTPUT OF DOMAIN IS IN TWO PARTS ------------- C C 1** GRID SPECIFICATION ********** C C GTYPE(IX,JY) FOR IX = 1 TO NGRIDX, JY = 1 TO NGRIDY C THE VALUES IN THIS ARRAY GIVE THE TYPE OF THE GRID POINTS AND C INFORMATION ABOUT THEIR RELATION TO THE BOUNDARY. C THERE IS A PACKING FACTOR IPACKB WHICH IS NORMALLY 1000. FOR C VERY LARGE PROBLEMS, IPACKB AND RELATED CONSTANT NSIDE = C IPACKB - 1 MUST BE INCREASED SO THAT NSIDE .GT. NBNDPT. C POSSIBLE VALUE ARE( ASSUMING IPACKB = 1000) C C = INTEGER OVER 1000 C GRID POINT IS NEXT TO THE BOUNDARY AND THE GTYPE VALUE IS C GTYPE = K + 1000*J WHERE C K IS THE INDEX OF THE LOWEST NUMBERED BOUNDARY NEIGHBOR C MUST DOUBLE CHECK USE WHEN K = 1 C J = FOUR BITS TO NOTE LOCATION OF BOUNDARY POINTS C 0001 - BOUNDARY NEIGHBOR TO NORTH (NOON) C 0010 - BOUNDARY NEIGHBOR TO EAST (3 O'CLOCK) C 0100 - BOUNDARY NEIGHBOR TO SOUTH (6 O'CLOCK) C 1000 - BOUNDARY NEIGHBOR TO WEST (9 O'CLOCK) C THUS J=9 (1001 IN BINARY) IMPLIES THAT THERE ARE BOUNDARY C NEIGHBORS TO THE NORTH AND WEST C EXAMPLES ( X = BNDRY PT., 0 = GRID PT ) C C X X X 0 X C C X 0 0 X X C J=9 J=3 J=14 C C ***** NOTE THAT GTYPE IS INITIALLY SET NEG. AND THEN MADE C POSITIVE WHEN THE INTERIOR IS FILLED C C = 999 C MEANS GRID POINT IS INTERIOR TO THE REGION AND NOT CLOSE C TO THE BOUNDARY, NSIDE HAS BEEN SET TO 999 SO THAT THE PACKING C C = INTEGER LESS THAN 1000 ( 1000 IS IPACKB VALUE) C GRID POINT IS ALSO BOUNDARY PT., GTYPE IS ITS INDEX C C = 0 C GRID POINT IS EXTERIOR FAR FROM THE BOUNDARY C C = NEGATIVE INTEGER C GRID POINT IS EXTERIOR NEXT TO THE BOUNDARY, ITS LOCATION C RELATIVE TO THE BOUNDARY IS ENCODED AS FOR INTERIOR POINTS C NEAR THE BOUNDARY C C 2** BOUNDARY SPECIFICATION ********** C C NBNDPT = NUMBER OF THE LAST BOUNDARY POINT ACTUALLY FOUND C ON THIS CALL TO DOMAIN C NBNDP1 = TOTAL NUMBER OF BOUNDARY POINTS SO FAR. C THIS INCLUDES FIRST POINT OF ANY CLOSED BOUNDARY C COPIED TO END OF THAT BOUNDARY - BUT NOT ARCS C XBOUND(I),YBOUND(I) = COORDINATES OF I-TH BOUNDARY POINT C BPARAM(I) = PARAMETER VALUE OF I-TH BOUNDARY POINT C PIECE(I) = INDEX OF BOUNDARY PIECE TO WHICH PT. BELONGS C SMALLEST NUMBER FOR CORNER POINTS C BPTYPE(I) = TYPE OF BOUNDARY POINT C = HORZ,VERT,BOTH,INTE OR JUMP C BNEIGH(I) = POINTER TO THE INTERIOR POINTS FROM THE I-TH C BOUNDARY POINT. SAME SCHEME IS USED TO ENCODE C DIRECTIONS AS FOR THE J PART OF GTYPE ABOVE C BGRID(I) = IX + IPACKB*JY WHEN PT. I IS IN GRID SQUARE IX,JY C C MAXIMUM NUMBER OF BOUNDARY POINTS = NBDIM C THIS IS ESTIMATED BY THE CALLING PROGRAM FOR DIMENSIONING C THE VARIOUS ARRAYS. C C *********** DOMAIN PROCESSOR SUBPROGRAMS *********************** C C REGION - MAIN DRIVER AND USER INTERFACE C HOLE - ALTERNATE DRIVER, INSERTS HOLES IN FIRST DOMAIN C REMOVH - REMOVES HOLE FROM GRID TYPES, UPDATES ALL INFO C DOMAIN - MAIN PROGRAM TO PROCESS A DOMAIN C BWALK - WALK ALONG BOUNDARY TO FIND GRID INTERSECTION C CHKTAN - CHECK FOR BOUNDARY TANGENT TO A GRID LINE C CROSS2 - CHECK FOR DOUBLE CROSSING OF A GRID LINE C DBACK - FOLLOW BOUNDARY FOR A DOUBLE CROSSING OF A GRID LINE C REGULA - MODIFIED REGULA FALSI METHOD C SECANT - SECANT METHOD C CHANGE - MAKE CHANGE OF BOUNDARY PIECE C FILL - LOCATE AND FILL INTERIOR OF THE DOMAIN C EXPAND - EXPAND INTERIOR OF DOMAIN BY 1 POINT C GVALUS - SET TYPES OF ALL GRID POINTS C ISETGT - COMPUTE GTYPE VALUE FOR A GRID POINT, SET IT C INSIDE - UTILITY: CHECKS POINT INSIDE SPECIFIED SUBGRID C LOCATE - UTILITY: LOCATE POINT IN GRID, TYPE IT C NEIGH - COMPUTE POINTERS FROM BOUNDARY TO GRID POINTS C TABLGT - TABLE THE GTYPE VALUES FOR THE GRID C C ******************************************************************** C ************* OUTPUT CONTROL ************************************* C C LEVEL = 0 ***** FATAL ERROR MESSAGES ************************** C BWALK - BOUNDARY GOES OUTSIDE DOMAIN C - UNABLE TO FIND GRID WHERE BOUNDARY GOES C - UNABLE TO FIND GRID INTERSECTION WITH BOUNDARY C CHANGE - BOUNDARY PIECES DO NOT JOIN UP C DOMAIN - BOUNDARY PARAMETER NOT INCREASING C - OVERFLOW OF STORAGE ALLOCATED FOR BOUNDARY POINTS C MUST CHANGE DECLARATIONS IN PROGRAM CALLING REGION C - ABNORMAL EXIT FROM BOUNDARY PROCESSING C PROBABLY CANNOT HAPPEN C - BOUNDARY DOES NOT CLOSE C FILL - FAILURE TO FIND INTERIOR OF DOMAIN C - OVERFLOW IN QUEUE FOR FILLING INTERIOR OF DOMAIN C MUST INCREASE QLIMIT AND RECOMPILE SUBROUTINE FILL C GVALUS - HAVE ILLEGAL POINT TYPE. THINGS ARE REALLY MESSED UP C LOCATE - ASKED TO FIND POINT OUTSIDE DOMAIN C INPUT ERROR OR PROGRAM BUG C REMOVH - HOLE IS TOO CLOSE TO BOUNDARY OF CONTAINING DOMAIN C NEED TO USE FINER GRID C REGION - GRID LINES ARE NOT INCREASING, INPUT ERROR C - LESS THAN 2 GRID LINES IN X OR Y DIRECTION, INPUT ERROR C C LEVEL = 1 ***** MINIMAL MESSAGES ******************************* C C REGION - NEW PAGE, DOMAIN PROCESSING STARTS C HOLE - NEW PAGE, HOLE PROCESSING STARTS C DOMAIN - NUMBER OF BOUNDARY/GRID INTERSECTIONS C - FATAL ERROR NOTE( IF PRESENT ) C C LEVEL = 2 ***** SUMMARY TRACE ********************************** C C CHANGE - CHANGE OF BOUNDARY PIECE C CHKTAN - POINT REPLACEMENT DUE TO TANGENCY TO GRID LINE C DOMAIN - INITIAL BOUNDARY POINT C - BOUNDARY POINT FOUND C - TABLE OF GRID POINT TYPES( FROM TABLGT ) C - SUMMARY OUTPUT OF BOUNDARY POINT ARRAYS C FILL - WARNING, FIRST TRY TO LOCATE INTERIOR FAILS C - FAILURE INFORMATION ( IF NEEDED ) C REMOVH - TABLE OF GRID POINT TYPES ( FROM TABLGT ) C C LEVEL = 3 **** SOME DETAILS OF THE PROGRAM OPERATION *********** C C BWALK - START C - WARNING, POINT FOUND IS NOT IN EXPECTED GRID C - BOUNDARY IS VERTICAL/HORIZONTAL C - FINISH C CHANGE - BOUNDARY PIECE CHANGE DATA C CHKTAN - DATA FOR THE TANGENCY TEST( WHEN IT SUCCEEDS ) C CROSS2 - SIGNS FOR DOUBLE CROSSING CHECK C - SUCCESSFUL RESULTS C DOMAIN - BOUNDARY PIECE CHANGE DATA C - HEADING FOR TYPING OF GRID POINTS C FILL - DATA ON SEARCH FOR INTERIOR POINTS C NEIGH - SUMMARY OF EXECUTION C C LEVEL = 4 **** MORE DETAILS ABOUT OPERATION ******************** C C BWALK - EXPANSION OF PARAMETER STEP C DBACK - SUMMARY OF EXECUTION C EXPAND - DETAILS OF IDENTIFICATION OF THE INTERIOR POINTS C GVALUS - DATA USED FOR TYPING GRID POINTS C LOCATE - DATA FOR POINTS LOCATED C NEIGH - DATA FOR NEIGHBORS LOCATED C REGULA - SUMMARY OF EXECUTION C SECANT - START INFORMATION C - FINISH INFORMATION C C LEVEL = 5 **** DETAILS OF MANY LOOPS ,ETC. ******************** C C BWALK - DATA ON INITIAL ROUGH GUESSES AT INTERSECTIONS C DBACK - LOOP DETAILS C FILL - DATA FOR LOOP TO FIND FIRST INTERIOR POINT C - DATA ON CLASSIFYING INTERIOR POINTS C GVALUS - DATA ON TYPING GRID POINTS C SECANT - BOUNDS USED ON VARIABLES C - DATA WHEN VARIABLE BOUNDS ARE USED C************************************************* END OF OUTPUT SPECS C EXTERNAL BCOORD CHARACTER *4 TYPEC,BPTYPE REAL XGRID(NGDIMX),YGRID(NGDIMY),BRANGE(2,NPDIM) DIMENSION GTYPE(NGDIMX,NGDIMY),XBOUND(NBDIM),YBOUND(NBDIM), . BPTYPE(NBDIM),BNEIGH(NBDIM),BGRID(NBDIM),BPARAM(NBDIM), . PIECE(NBDIM) C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C C -------------------------- PROCESS A DOMAIN ------------------------ C C CHECK THAT THE BOUNDARY PARAMETERS ARE ALWAYS INCREASING FATAL = .FALSE. DO 10 IB = N1BND,NBOUND IF (BRANGE(2,IB).GT.BRANGE(1,IB)) GO TO 10 C FATAL ERROR IN BOUNDARY PARAMETERIZATION C IF (LEVEL.GE.0) WRITE (MOUTPT,9001) IB FATAL = .TRUE. 10 CONTINUE IF (FATAL) GO TO 190 IF (LEVEL.GE.4) WRITE (MOUTPT,9011) CLOCKW,ARC,INHOLE,NGRIDX, . NGRIDY,N1BND,N1BDPT,NBOUND,IPACKB,NSIDE,MOUTPT,QLIMIT,EPSGRD, . EPSTAN C LOCATE FIRST BOUNDARY POINT IPIECE = N1BND PARAM = BRANGE(1,IPIECE) CALL BCOORD(PARAM,XB,YB,IPIECE) C CALL LOCATE(XB,YB,IX,JY,TYPE,XGRID,YGRID,NGDIMX,NGDIMY) IF (FATAL) GO TO 190 C SET INFORMATION FOR FIRST BOUNDARY POINT NBNDPT = N1BDPT XBOUND(N1BDPT) = XB YBOUND(N1BDPT) = YB PIECE(N1BDPT) = N1BND BPTYPE(N1BDPT) = TYPE BGRID(N1BDPT) = IX + IPACKB*JY BPARAM(N1BDPT) = PARAM IF ((TYPE.EQ.VERT) .OR. (TYPE.EQ.BOTH)) XBOUND(N1BDPT) = XGRID(IX) IF ((TYPE.EQ.HORZ) .OR. (TYPE.EQ.BOTH)) YBOUND(N1BDPT) = YGRID(JY) C DEBUG IF (LEVEL.GE.2) WRITE (MOUTPT,9021) IPIECE,PARAM,XB,YB,TYPE C C ----------------------- START LOOP OVER BOUNDARY PIECES ---------- C FOLLOW EACH PIECE OF THE BOUNDARY AND DETERMINE ALL GRID C LINE INTERSECTIONS AND VARIOUS INFORMATION ASSOCIATED WITH C THE INTERSECTION POINTS( = BOUNDARY POINTS) DO 50 IB = N1BND,NBOUND C C CHECK FOR HITTING END OF BOUNDARY IMMEDIATELY IF (PARAM.GT.BRANGE(2,IPIECE)-EPSGRD) GO TO 40 C C ----------- LOOP WHICH WALKS ALONG THE IB-TH BOUNDARY PIECE ---- DO 30 IDUMB = 1,NBDIM C LOCATE THE NEXT GRID LINE INTERSECTION BY WALKING FROM XB,YB C ALONG THE BOUNDARY TO GRID LINES IXNU,JYNU AND PARAM = PNEXT CALL BWALK(XB,YB,IX,JY,PNEXT,XNEXT,YNEXT,IXNU,JYNU,XGRID, . YGRID,NGDIMX,NGDIMY,BRANGE,NPDIM,BCOORD) IF (FATAL) GO TO 190 C C CHECK FOR HAVING REACHED THE END OF THE BOUNDARY C *** EXIT *** THIS IS THE NORMAL EXIT OF LOOP OVER BOUNDARY PIECE IF (IB.EQ.NBOUND .AND. PNEXT.GT.BRANGE(2,IB)- . EPSGRD) GO TO 60 C C CHECK FOR GOING PAST THE END OF THIS BOUNDARY PIECES IF (PNEXT.GE.BRANGE(2,IPIECE)-.5E0*EPSGRD) GO TO 40 C C PUT NEW POINT IN BOUNDARY POINT LIST NBNDPT = NBNDPT + 1 IF (NBNDPT.LE.NBDIM) GO TO 20 C C HAVE EXCEEDED BOUNDARY POINT LIMIT C IF (LEVEL.GE.0) WRITE (MOUTPT,9031) NBDIM FATAL = .TRUE. GO TO 190 20 CONTINUE XBOUND(NBNDPT) = XNEXT YBOUND(NBNDPT) = YNEXT PIECE(NBNDPT) = IPIECE BPTYPE(NBNDPT) = TYPE BGRID(NBNDPT) = IXNU + IPACKB*JYNU BPARAM(NBNDPT) = PNEXT IX = IXNU JY = JYNU PARAM = PNEXT IF (LEVEL.GE.2) WRITE (MOUTPT,9041) NBNDPT,XBOUND(NBNDPT), . YBOUND(NBNDPT) IF (LEVEL.GE.3) WRITE (MOUTPT,9051) IPIECE,TYPE,IX,JY C C CHECK TO SEE IF THIS IS A POINT OF TANGENCY. C IF SO, REPLACE THE PREVIOUS POINT IN THE BOUNDARY LIST C BY THIS ONE IF IT IS VERY CLOSE BY CALL CHKTAN(XBOUND,YBOUND,BPARAM,BPTYPE,BGRID,NBDIM,NPDIM, . BRANGE,XGRID,YGRID,NGDIMX,NGDIMY,TYPE,IXNU,JYNU) C TANGENT CHECK MIGHT MOVE START OF NEXT SEARCH AWAY C FROM XNEXT,YNEXT. THE VALUE OF PARAM IS ALWAYS C INCREASING AND IS USED TO FORCE SEARCH AWAY FROM THE C POINT OF TEANGENCY. CALL BCOORD(PARAM,XB,YB,IPIECE) 30 CONTINUE C C ---------------- END OF LOOP OVER POINTS ON 1 BOUNDARY PIECE --- C 40 CONTINUE C C HAVE COME TO END OF PIECE, TAKE CARE OF LAST POINT C THIS ALSO INSERTS THE END POINT IN THE BOUNDARY LIST, C LOCATES THE NEXT POINT ON THE BOUNDARY AND PUTS IT IN C THE LIST TOO. C C DO NOT TRY TO CHANGE THE LAST PIECE IF (IB.EQ.NBOUND) GO TO 60 C CALL CHANGE(BRANGE,NPDIM,XGRID,YGRID,NGDIMX,NGDIMY,NBDIM, . XBOUND,YBOUND,PIECE,BPTYPE,BGRID,BPARAM,BCOORD) IF (FATAL) GO TO 190 CALL LOCATE(XBOUND(NBNDPT),YBOUND(NBNDPT),IX,JY,TYPE,XGRID, . YGRID,NGDIMX,NGDIMY) CALL BCOORD(PARAM,XB,YB,IPIECE) 50 CONTINUE C C ABNORMAL EXIT FROM BOUNDARY PROCESSING C THIS CANNOT HAPPEN UNLESS THINGS ARE REALLY MESSED UP C IF (LEVEL.GE.0) WRITE (MOUTPT,9061) PARAM,IPIECE,NBOUND,NBNDPT, . IX,JY,NGRIDX,NGRIDY,NPDIM,NBDIM FATAL = .TRUE. GO TO 190 C 60 CONTINUE C CHECK CLOSING OF THE BOUNDARY IF (ARC) GO TO 70 CALL BCOORD(BRANGE(2,NBOUND),XLAST,YLAST,IPIECE) DIST = ABS(XLAST-XBOUND(N1BDPT)) + ABS(YLAST-YBOUND(N1BDPT)) IF (DIST.LT.3.*EPSGRD) GO TO 70 C IF (LEVEL.GE.0) WRITE (MOUTPT,9071) FATAL = .TRUE. GO TO 190 C C -------------- END LOOP OVER BOUNDARY PIECES --------------------- 70 CONTINUE C C FIX END OF BOUNDARY, DUPLICATE FIRST POINT AT END C OF LIST, CHECK FOR TANGENCY C IF NOT ON AN ARC IF (ARC) GO TO 100 C C COPY FIRST BOUNDARY POINT IN BOUNDARY LIST AS LAST POINT C ONLY IF THERE IS SPACE FOR IT IF (NBNDPT+1.LT.NBDIM) GO TO 80 C WRITE (MOUTPT,9031) NBDIM FATAL = .TRUE. RETURN C C PRINT WARNING IF LAST PIECE HAS ONLY ONE BOUNDARY POINT 80 IF (PIECE(NBNDPT).EQ.NBOUND) GO TO 90 IF (LEVEL.GE.1) WRITE (MOUTPT,9081) 90 XBOUND(NBNDPT+1) = XBOUND(N1BDPT) YBOUND(NBNDPT+1) = YBOUND(N1BDPT) PIECE(NBNDPT+1) = NBOUND BPTYPE(NBNDPT+1) = BPTYPE(N1BDPT) BGRID(NBNDPT+1) = BGRID(N1BDPT) BPARAM(NBNDPT+1) = BRANGE(2,NBOUND) NBNDP1 = NBNDPT + 1 GO TO 110 C C ON AN ARC PUT IN THE LAST BOUNDARY POINT FOUND 100 CONTINUE NBNDPT = NBNDPT + 1 XBOUND(NBNDPT) = XNEXT YBOUND(NBNDPT) = YNEXT PIECE(NBNDPT) = IPIECE BPTYPE(NBNDPT) = TYPE BGRID(NBNDPT) = IXNU + IPACKB*JYNU BPARAM(NBNDPT) = PNEXT NBNDP1 = NBNDPT C C C CHECK FOR TANGENCY AS THE BOUNDARY CLOSES C TEMPORARILY INCREASE BOUNDARY POINT COUNT 110 NBNDPT = NBNDPT + 1 CALL CHKTAN(XBOUND,YBOUND,BPARAM,BPTYPE,BGRID,NBDIM,NPDIM,BRANGE, . XGRID,YGRID,NGDIMX,NGDIMY,TYPE,IXNU,JYNU) NBNDPT = NBNDPT - 1 C NO DUPLICATE AT THE END FOR AN ARC IF (ARC) NBNDPT = NBNDP1 C IF (LEVEL.GE.3) WRITE (MOUTPT,9091) C C FIND BOUNDARY NEIGHBORS GRID POINT INFORMATION C THIS SETS VALUES OF GTYPE FOR GRID POINTS NEXT TO THE BOUNDARY C EXCEPT THAT THE SIGN( = INTERIOR/EXTERIOR FLAG ) IS NOT C SET UNTIL FILL IS CALLED LATER. C SET ALL GRID POINT TYPES = 0 DO 130 IX = 1,NGRIDX DO 120 JY = 1,NGRIDY GTYPE(IX,JY) = 0 120 CONTINUE 130 CONTINUE CALL GVALUS(XGRID,YGRID,NGDIMX,NGDIMY,GTYPE,NBDIM,XBOUND,YBOUND, . BPTYPE,BGRID) C C NOW FILL IN THE TYPES OF GRID POINTS AWAY FROM THE BOUNDARY C IN THE INTERIOR OF THE REGION. SET GTYPE POS. NEXT TO BOUNDARY C IF ( .NOT. ARC) CALL FILL(GTYPE,NGDIMX,NGDIMY,NBDIM,BGRID,BPTYPE, . PIECE,XBOUND,YBOUND) IF (FATAL) GO TO 190 C C GO ALONG THE BOUNDARY AND SET BNEIGH VALUES FOR ALL C THE BOUNDARY POINTS. CALL NEIGH(NGDIMX,NGDIMY,GTYPE,NBDIM,BNEIGH,BPTYPE,BGRID) C SET BNEIGH FOR LAST+1 POINT IF NOT ON AN ARC IF ( .NOT. ARC) BNEIGH(NBNDP1) = BNEIGH(NBNDPT) C C SUMMARY OUTPUT NBPTF = NBNDPT - N1BDPT + 1 NBDF = NBOUND - N1BND + 1 IF (LEVEL.GE.1) WRITE (MOUTPT,9101) NBPTF,NBDF,NGRIDX,NGRIDY IF (LEVEL.LT.2) GO TO 150 WRITE (MOUTPT,9111) DO 140 IB = N1BDPT,NBNDP1 TYPEC = BPTYPE(IB) WRITE (MOUTPT,9121) IB,XBOUND(IB),YBOUND(IB),BPARAM(IB), . PIECE(IB),TYPEC,BGRID(IB),BNEIGH(IB) 140 CONTINUE 150 CONTINUE C PRINT TABLE OF GTYPE VALUES IF (LEVEL.GT.1) CALL TABLGT(MOUTPT,1,NGRIDX,NGRIDY,GTYPE) C C CHECK FOR INTERIOR POINTS ON BOUNDARY OF GTYPE ARRAY C IF FOUND IT MEANS THERE IS SOMETHING WRONG DO 160 I = 1,NGDIMX IF (GTYPE(I,1).EQ.NSIDE .OR. GTYPE(I,NGDIMY).EQ. . NSIDE) GO TO 180 160 CONTINUE DO 170 J = 1,NGDIMY IF (GTYPE(1,J).EQ.NSIDE .OR. GTYPE(NGDIMX,J).EQ. . NSIDE) GO TO 180 170 CONTINUE C C ******* NORMAL RETURN ******** NO PROBLEMS DETECTED RETURN C C SERIOUS PROBLEM DETECTED 180 CONTINUE C WRITE (MOUTPT,9131) FATAL = .TRUE. C C ALL FATAL ERRORS COME TO 300 190 CONTINUE C IF (LEVEL.GE.0) WRITE (MOUTPT,9141) IF (LEVEL.GE.2 .AND. N1BDPT.LT.NBNDPT) WRITE (MOUTPT,9101) NBPTF, . NBDF,NGRIDX,NGRIDY IF (LEVEL.LT.2 .OR. N1BDPT.GE.NBNDPT) GO TO 210 DO 200 IB = N1BDPT,NBNDPT TYPEC = BPTYPE(IB) WRITE (MOUTPT,9151) IB,XBOUND(IB),YBOUND(IB),BPARAM(IB), . PIECE(IB),TYPEC,BGRID(IB) 200 CONTINUE 210 CONTINUE FATAL = .TRUE. RETURN 9001 FORMAT (/5 (3H **),' FATAL ERROR IN BOUNDARY DEFINITION',/9X, . 'PARAMETER OF PIECE ',I4,' IS DECREASING') 9011 FORMAT (/20X,'DATA AND CONSTANTS FOR THIS DOMAIN PROCESSING'/3X, . 'SWITCHES CLOCKW, ARC AND INHOLE =',3L4/3X,'NGRIDX,NGRIDY =', . 2I4,' FIRST BOUNDARY POINT, PIECE =',2I4,' WITH ',I3, . ' BOUNDARY PIECES'/3X,'CONSTANTS IPACKB,NSIDE,MOUTPT,QLIMIT = ', . 4I6/3X,'GEOMETRY TOLERANCES EPSGRD, EPSTAN =',2E15.5) 9021 FORMAT (5X,'ON PIECE',I4,' PARAM ',F10.6,', GIVES COORDS ',2F10.6, . ', TYPE ',A4) 9031 FORMAT (/5 (3H **),' FATAL ERROR IN PROCESSING DOMAIN, ', . 'ESTIMATED NUMBER',I4/9X, . 'OF BOUNDARY-GRID INTERSECTION POINTS IS TOO LOW,' . /9X,'THE REMEDY IS TO INCREASE NBDIM') 9041 FORMAT (2X,3 ('--'),' FOUND BOUNDARY POINT ',I3, . ' WITH COORDINATES ',2F10.6) 9051 FORMAT (15X,'ON PIECE ',I2,' OF TYPE ',A4,' IN GRID ',2I3) 9061 FORMAT (/5 (3H **),' ABNORMAL EXIT FROM LOOP IN BOUNDARY ', . 'PROCESSING, = FATAL ERROR'/9X, . 'HAPPENS ONLY IF BOUNDARY INFO IS REALLY MESSED UP' . /6X,' PARAM =',F12.7/6X, . 58H IPIECE,NBOUND,NBNDPT,IX,JY,NGRIDX,NGRIDY,NPDIM,NBDIM = . /6X,9I5) 9071 FORMAT (/5 (3H **),' FATAL ERROR, BOUNDARY DOES NOT CLOSE') 9081 FORMAT (/5 (3H **),' WARNING, LAST PIECE HAS ONLY 1 BOUNDARY', . ' POINT') 9091 FORMAT (//20X,'SET GTYPE FOR NEIGHBORS OF BOUNDARY POINTS') 9101 FORMAT (/5X,'BOUNDARY POINTS FOUND',I12/5X, . 'BOUNDARY PIECES FOUND',I12/5X,'GRID SIZE',I17,' BY',I4/5X, . 'EXECUTION SUCCESSFUL') 9111 FORMAT (/3X,'BOUNDARY PT XBOUND',8X,'YBOUND',8X,'BPARAM', . ' PIECE BPTYPE BGRID BNEIGH') 9121 FORMAT (I10,3F14.9,I5,4X,A4,I8,I6) 9131 FORMAT (4X,'FOUND INTERIOR POINTS ON EDGE OF GRID'/4X, . 'PROBABLE CAUSES ARE:'/8X,'BOUNDARY ORIENTATION IS WRONG'/8X, . 'BOUNDARY STARTS WHERE INTERIOR IS TOO THIN'/8X, . 'BOUNDARY OSCILLATES TOO RAPIDLY SOMEPLACE') 9141 FORMAT (/5 (3H **),' FATAL ERROR IN DOMAIN,'/9X, . 'STOPS PROCESSING RUN') 9151 FORMAT (I10,3F14.9,I5,4X,A4,I8) END SUBROUTINE BWALK(XSTART,YSTART,IX,JY,PNEW,XNEW,YNEW,INEW,JNEW, . XGRID,YGRID,NGDIMX,NGDIMY,BRANGE,NPDIM,BCOORD) C C THIS SUBROUTINE STARTS AT (XSTART,YSTART) AND WALKS ALONG THE C BOUNDARY TO THE NEXT GRID LINE INTERSECTION AT THE POINT C (XNEW,YNEW) WITH PARAMETER PNEW IN GRID SQUARE INEW,JNEW. C THE PARAMETER START IS PARAM IN COMMON C THE INTERSECTION POINT TYPE IS FOUND AND PLACED IN COMMON AS TYPE C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C EXTERNAL BCOORD LOGICAL XCASE,INSIDE,ALLIN REAL XGRID(NGDIMX),YGRID(NGDIMY),BRANGE(2,NPDIM),GESS1(4), . GESS2(4),TSIGN(4),SIGNOW(4),X(4),Y(4),P(4) INTEGER LTRY(4) CHARACTER *4 TYPEC,OUTCM(4) CHARACTER *4 WBACK,NOTRY,SUCCES,FAIL,OUTSID DATA WBACK,NOTRY,SUCCES,FAIL,OUTSID/'BACK','NOTR','SUCC','FAIL', . 'OUTS'/ C C ********** VARIABLES IN BWALK ********** C C *** INPUT * XSTART,YSTART,IX,JY C VIA COMMON = PARAM,EPSGRD,EPSTAN,IPIECE C THE POINT WHERE THE WALK STARTS IS (XSTART,YSTART) C IN GRID SQUARE (IX,JY). C C *** OUTPUT * PNEW = PARAM VALVE FOR NEXT GRID LINE INTERSECTION C INEW, JNEW = INDICES FOR NEXT X,Y GRID LINES C XNEW,YNEW = COORDINATES FOR NEXT INTERSECTION C TYPE(VIA COMMON) = TYPE OF INTERSECTION C = HORZ, VERT OR BOTH C FATAL(VIA COMMON)= SWITCH FOR FATAL ERRORS C C *** MAIN VARIABLES *** C C DELP,DELPNU = CHANGES TRIED FOR PARAM C DXGRD,DYGRD = X AND Y GRID SPACING C XTAR1,XTAR2,YTAR1,YTAR2 = TARGETS OF SECANT METHOD C = COORDINATES OF GRID SQUARE C XTEST,YTEST,PTEST = TEST POINT INSIDE TARGET GRID SQUARE C X(I), 1 TO 4 = X COORDINATES OF SECANT RESULTS C Y(I) 1 TO 4 = Y COORDINATES OF SECANT RESULTS C P(I) 1 TO 4 = PARAMETERS FOR SECANT RESULTS C OUTCM(I) = FLAGS FOR SECANT RESULTS C NOTRY - NOT TRIED C WBACK - WALKED BACK TO START C SUCCES- HIT THE TARGET C FAIL - FAILED TO HIT TARGET C OUTSID- HIT TARGET, BUT OUTSIDE GRID C PEND,XEND,YEND = VALUES OF PARAM,X,Y AT END OF BOUNDARY C PSTOP = PARAMETER VALUE KNOWN TO BE BEYOND C THE NEXT INTERSECTION WITH THE GRID C INEXT, JNEXT = INDEXES OF OTHER TWO SIDES OF SQUARE C BOUNDARY IS PASSING THROUGH C C *** OTHER VARIABLES *** C C NHORZ,NVERT = LOOP COUNTERS C LTRY = ORDER FOR TRIES TO HIT TARGETS C TESTX,TESTY = TEMP VALUES OF X,Y C TSIGN,SIGNOW = SIGNS OF ERROR FOR THE 4 TARGETS C KTAR,STEP = COUNTER AND STEP FOR INITIAL SEARCH C DGMAX,DIST = DISTANCES FROM START C ALLIN = .TRUE. IF ALL PTS MET ARE INSIDE GRID C PEND = BRANGE(2,IPIECE) CALL BCOORD(PEND,XEND,YEND,IPIECE) C SET INITIAL OUTCOME SWITCHES, VARIABLES TO INVALID VALUES DO 10 I = 1,4 X(I) = -100.E0 Y(I) = -100.E0 P(I) = PEND + 1.E0 OUTCM(I) = NOTRY 10 CONTINUE ALLIN = .TRUE. C C SET INDICES OF GRIDS THAT MUST CONTAIN NEXT POINT ISOUTH = JY IWEST = IX INORTH = MIN0(JY+1,NGRIDY) IEAST = MIN0(IX+1,NGRIDX) IF (TYPE.EQ.VERT .OR. TYPE.EQ.BOTH) IWEST = MAX0(1,IX-1) IF (TYPE.EQ.HORZ .OR. TYPE.EQ.BOTH) ISOUTH = MAX0(1,JY-1) DXGRD = XGRID(IEAST) - XGRID(IWEST) DYGRD = YGRID(INORTH) - YGRID(ISOUTH) C C FIND PARAMETER CHANGE = PTEST TO GIVE POINT IN THIS GRID FACTOR = 10.E0 PTEST = (PEND-PARAM)/FACTOR DO 30 I1 = 1,2 DO 20 I2 = 1,8 CALL BCOORD(PARAM+PTEST,XTEST,YTEST,IPIECE) IF (INSIDE(XTEST,YTEST,IWEST,ISOUTH,IEAST,INORTH,XGRID, . NGDIMX,YGRID,NGDIMY)) GO TO 50 C NOT INSIDE REQUIRED GRID AREA YET C CHECK FOR GOING OUTSIDE GRID DOMAIN IF ( .NOT. INSIDE(XTEST,YTEST,1,1,NGRIDX,NGRIDY,XGRID, . NGDIMX,YGRID,NGDIMY)) GO TO 40 ALLIN = .FALSE. PSTOP = PARAM + PTEST PTEST = PTEST/FACTOR 20 CONTINUE FACTOR = 2.E0*FACTOR 30 CONTINUE C C ****** FATAL ERROR ***** C DID NOT FIND REQUIRED POINT = INEXPLICABLE SITUATION C PARAMETER CHANGE IS NOW LESS THAN (PEND-PARAM)/1E+12 C IF (LEVEL.GE.0) WRITE (MOUTPT,9001) XSTART,YSTART FATAL = .TRUE. GO TO 520 C C ***** FATAL ERROR, BOUNDARY GOES OUTSIDE GRID ***** 40 CONTINUE C IF (LEVEL.GE.0) WRITE (MOUTPT,9011) XSTART,YSTART PTEST = PARAM + PTEST IF (LEVEL.GE.2) WRITE (MOUTPT,9021) XTEST,YTEST,PTEST FATAL = .TRUE. GO TO 520 C C NOW CHECK TO SEE IF TEST PT. IS TOO CLOSE TO START 50 DELP2 = PTEST FACTOR = 1.6E0 DO 60 I1 = 1,6 DX = ABS(XSTART-XTEST) DY = ABS(YSTART-YTEST) IF (AMIN1(DX,DY).GT.4.E0*EPSGRD) GO TO 80 C DO NOT LET DELP2 GET OUT OF RANGE IF (DELP2*FACTOR.GT.PEND-PARAM) GO TO 80 DELP2 = DELP2*FACTOR CALL BCOORD(PARAM+DELP2,XTEST,YTEST,IPIECE) IF ( .NOT. INSIDE(XTEST,YTEST,IWEST,ISOUTH,IEAST,INORTH,XGRID, . NGDIMX,YGRID,NGDIMY)) GO TO 70 60 CONTINUE C DID NOT MOVE AWAY FROM START IN BOTH COORDINATES C COULD HAVE VERT OR HORZ BOUNDARY WHICH IS DETECTED LATER GO TO 80 C MOVED TEST POINT OUTSIDE GRID AREA, RESTORE PREVIOUS DELP 70 DELP2 = DELP2/FACTOR ALLIN = .FALSE. 80 PTEST = DELP2 C LOCATE THE POINT INSIDE THE DESIRED GRID AREA CALL BCOORD(PARAM+PTEST,XTEST,YTEST,IPIECE) CALL LOCATE(XTEST,YTEST,IX,JY,TYPEC,XGRID,YGRID,NGDIMX,NGDIMY) C CHECK LOCATION FAILURE - SHOULD NEVER HAPPEN IF ( .NOT. FATAL) GO TO 90 C WRITE (MOUTPT,9031) XSTART,YSTART FATAL = .TRUE. GO TO 520 90 INEXT = MIN0(IX+1,NGRIDX) JNEXT = MIN0(JY+1,NGRIDY) C C HAVE THE GRID SQUARE LOCATED, SET TARGETS XTAR1 = XGRID(INEXT) XTAR2 = XGRID(IX) YTAR1 = YGRID(JNEXT) YTAR2 = YGRID(JY) C COMPUTE THE CORRECT GRID WIDTHS DXGRD = ABS(XGRID(IX)-XGRID(INEXT)) DYGRD = ABS(YGRID(JY)-YGRID(JNEXT)) C IF (LEVEL.GE.3) WRITE (MOUTPT,9041) XSTART,YSTART,IX,JY,PTEST, . XTEST,YTEST,PARAM,XTAR1,XTAR2,YTAR1,YTAR2 C C STEP ALONG BOUNDARY TO FIND WHERE IT GOES AND TO OBTAIN ROUGH C ESTIMATES OF INTERSECTIONS. ORDER THE TARGETS WITH MOST C LIKELY FIRST AND OBTAIN INITIAL GUESSES FOR EACH DGMAX = SQRT(DXGRD**2+DYGRD**2) C SET INITIAL SIGNS OF DIRECTION TO TARGETS TSIGN(1) = XTAR1 - XSTART TSIGN(2) = XTAR2 - XSTART TSIGN(3) = YTAR1 - YSTART TSIGN(4) = YTAR2 - YSTART PSTOP = PEND C C **************** RETURN HERE FOR POSSIBLE ADDITIONAL ATTEMPTS C **************** TO BRACKET THE TARGET COORDINATES C LOCAL RETURN FROM INSIDE DO-LOOP 22 C GLOBAL RETURN FROM EXIT OF DO-LOOP 200 100 KTAR = 0 STEP = (PSTOP-PARAM)/5.E0 C SET TARGET ORDERS TO NULL DO 110 I = 1,4 LTRY(I) = 0 110 CONTINUE C STEP ALONG THE BOUNDARY DO 160 I = 1,5 STEPI = FLOAT(I)*STEP CALL BCOORD(PARAM+STEPI,TESTX,TESTY,IPIECE) DIST = SQRT((TESTX-XSTART)**2+ (TESTY-YSTART)**2) IF (ALLIN) ALLIN = INSIDE(TESTX,TESTY,IX,JY,INEXT,JNEXT,XGRID, . NGDIMX,YGRID,NGDIMY) IF (DIST.LE.DGMAX) GO TO 120 C HAVE GONE TOO FAR, REDUCE PSTOP PSTOP = PARAM + STEPI C IF THIS IS 1ST OR 2ND POINT, REPEAT WHOLE PROCESS IF (I.LE.2) GO TO 100 C FIND SIGNS TO TARGETS FROM THIS BOUNDARY POINT 120 SIGNOW(1) = XTAR1 - TESTX SIGNOW(2) = XTAR2 - TESTX SIGNOW(3) = YTAR1 - TESTY SIGNOW(4) = YTAR2 - TESTY C C CHECK TO SEE IF ANY SIGN CHANGES HAVE OCCURRED C IF SO, SET ORDER AND SAVE GUESSES DO 150 L = 1,4 C SKIP THOSE TARGETS ALREADY IN ORDER IF (KTAR.EQ.0) GO TO 140 DO 130 K = 1,KTAR IF (LTRY(K).EQ.L) GO TO 150 130 CONTINUE 140 IF (SIGNOW(L)*TSIGN(L).GE.0.0) GO TO 150 KTAR = KTAR + 1 LTRY(KTAR) = L GESS1(KTAR) = STEPI - STEP GESS2(KTAR) = STEPI 150 CONTINUE 160 CONTINUE C C CHECK IF THE CURRENT BOUNDARY PIECE ENDS INSIDE THE GRID SQUARE C AND NO POINT EXAMINED HAS BEEN OUTSIDE THE GRID SQUARE. IF (INSIDE(XEND,YEND,IX,JY,INEXT,JNEXT,XGRID,NGDIMX,YGRID, . NGDIMY) .AND. ALLIN) GO TO 500 C C SET GUESSES AND ORDER FOR TARGETS NOT CROSSED DO 190 L = 1,4 C SKIP THOSE TARGETS ALREADY IN ORDER IF (KTAR.EQ.0) GO TO 180 DO 170 K = 1,KTAR IF (LTRY(K).EQ.L) GO TO 190 170 CONTINUE 180 KTAR = KTAR + 1 LTRY(KTAR) = L GESS1(KTAR) = 0. GESS2(KTAR) = STEP 190 CONTINUE IF (LEVEL.GE.5) WRITE (MOUTPT,9051) (I,LTRY(I),GESS1(I),GESS2(I), . I=1,4) C ----------- CASE STATEMENT TO SEARCH FOR 4 TARGETS ------------ DO 460 I = 1,4 KTAR = LTRY(I) GO TO (200,200,330,330),KTAR C C X TARGETS - CHECK FOR VERTICAL BOUNDARY BEFORE SEARCH 200 CONTINUE XCASE = .TRUE. C TEST FOR NEARLY VERTICAL BOUNDARY C C LOOP TO INCREASE DELP AND SEE IF BOUNDARY STAYS C ALONG THE GRID LINE UNTIL DXGRD STEP PASSED DELP = (PSTOP-PARAM)/8.E0 DO 210 NVERT = 1,8 CALL BCOORD(PARAM+DELP*FLOAT(NVERT),TESTX,TESTY,IPIECE) DX = ABS(TESTX-XSTART) IF (DX.GT.10.E0*DXGRD*EPSGRD) GO TO 230 IF (DX.GE.DXGRD) GO TO 220 210 CONTINUE C C BOUNDARY IS VERTICAL, SKIP THE X SEARCHES 220 IF (LEVEL.GE.3) WRITE (MOUTPT,9061) XSTART,YSTART OUTCM(1) = VERT OUTCM(2) = VERT GO TO 460 C SELECT PROPER X TARGET 230 IF (KTAR.EQ.2) GO TO 270 IF (INEXT.LE.NGRIDX) GO TO 240 C WALKING OUTSIDE GRID DOMAIN IF (LEVEL.GE.1) WRITE (MOUTPT,9071) XSTART,YSTART OUTCM(1) = OUTSID OUTCM(2) = OUTSID GO TO 460 240 CONTINUE C CASE 1 -------------------- TRY THE FIRST X-TARGET C SKIP THIS TARGET IF = XSTART, LOOK FOR DOUBLE BACK IF (ABS(XSTART-XTAR1).LE.EPSGRD) GO TO 320 C CHECK FOR TRYING TO WALK OUTSIDE IN X-DIRECTION IF (OUTCM(1).EQ.OUTSID) GO TO 460 C USE SPECIAL REGULA FALSI TO IMPROVE THE INITIAL GUESS CALL REGULA(XTAR1,XCASE,GESS1(I),GESS2(I),PSTOP,EPSTAN,BCOORD) C NOW USE THE SECANT METHOD TO HIT TARGET ACCURATELY CALL SECANT(PARAM+GESS1(I),PARAM+GESS2(I),XTAR1,XCASE,P(1), . X(1),Y(1),OUTCM(1),PSTOP,DXGRD,BCOORD) IF (OUTCM(1).EQ.FAIL) GO TO 460 C CHECK FOR HAVING WALKED BACKWARD IF (ABS(XSTART-X(1)).LE.EPSGRD) OUTCM(1) = WBACK C TEST FOR GETTING A RESULT IN THE RIGHT GRID SQUARE IF (INSIDE(X(1),Y(1),IX,JY,INEXT,JNEXT,XGRID,NGDIMX,YGRID, . NGDIMY)) GO TO 250 C POINT FOUND IS OUTSIDE GRID SQUARE, CHECK C FOR HAVING CROSSED THE TARGET TWICE. OUTCM(1) = OUTSID CALL CROSS2(XSTART,XTAR1,XCASE,P(1),X(1),Y(1),OUTCM(1),BCOORD) C CHECK TO SEE IF THE POINT IS STILL OUTSIDE IF ( .NOT. INSIDE(X(1),Y(1),IX,JY,INEXT,JNEXT,XGRID,NGDIMX, . YGRID,NGDIMY)) OUTCM(1) = OUTSID 250 IF (OUTCM(1).NE.SUCCES) GO TO 460 C C FOUND CROSSING AT THE NEXT X-GRID LINE 260 PNEW = P(1) XNEW = XTAR1 YNEW = Y(1) JNEW = JY INEW = INEXT C FINISH UP AS IN THE SECOND GRID TARGET GO TO 300 C CASE 2 ---------------- TRY THE SECOND X-TARGET 270 CONTINUE C SKIP THIS TARGET IF = XSTART, LOOK FOR DOUBLE BACK IF (ABS(XSTART-XTAR2).LE.EPSGRD) GO TO 320 C USE SPECIAL REGULA FALSI TO IMPROVE THE INITIAL GUESS CALL REGULA(XTAR2,XCASE,GESS1(I),GESS2(I),PSTOP,EPSTAN,BCOORD) C NOW USE THE SECANT METHOD TO HIT TARGET ACCURATELY CALL SECANT(PARAM+GESS1(I),PARAM+GESS2(I),XTAR2,XCASE,P(2), . X(2),Y(2),OUTCM(2),PSTOP,DXGRD,BCOORD) IF (OUTCM(2).EQ.FAIL) GO TO 460 C CHECK FOR HAVING WALKED BACKWARD IF (ABS(XSTART-X(2)).LE.EPSGRD) OUTCM(2) = WBACK C TEST FOR GETTING A RESULT IN THE RIGHT GRID SQUARE IF (INSIDE(X(2),Y(2),IX,JY,INEXT,JNEXT,XGRID,NGDIMX,YGRID, . NGDIMY)) GO TO 280 C POINT FOUND IS OUTSIDE GRID SQUARE, CHECK C FOR HAVING CROSSED THE TARGET TWICE. OUTCM(2) = OUTSID CALL CROSS2(XSTART,XTAR2,XCASE,P(2),X(2),Y(2),OUTCM(2),BCOORD) C CHECK TO SEE IF THE POINT IS STILL OUTSIDE IF ( .NOT. INSIDE(X(2),Y(2),IX,JY,INEXT,JNEXT,XGRID,NGDIMX, . YGRID,NGDIMY)) OUTCM(2) = OUTSID 280 IF (OUTCM(2).NE.SUCCES) GO TO 460 C C FOUND CROSSING POINT AT THIS X-GRID LINE 290 CONTINUE JNEW = JY INEW = IX PNEW = P(2) XNEW = XTAR2 YNEW = Y(2) 300 TYPE = VERT C CHECK POSSIBILITY OF TYPE BOTH IF (ABS(YNEW-YTAR1).GT.EPSGRD) GO TO 310 TYPE = BOTH JNEW = JNEXT YNEW = YTAR1 GO TO 510 310 IF (ABS(YNEW-YTAR2).GT.EPSGRD) GO TO 510 TYPE = BOTH JNEW = JY YNEW = YTAR2 GO TO 510 C C SPECIAL CALCULATION FOR DOUBLING BACK ON TARGET 320 CONTINUE CALL DBACK(XSTART,XTEST,PTEST,XCASE,DXGRD,OUTCM(KTAR),P(KTAR), . X(KTAR),Y(KTAR),BCOORD,PSTOP) IF (OUTCM(KTAR).EQ.FAIL) GO TO 460 C CHECK FOR HAVING WALKED BACKWARD TO STARTING POINT IF (ABS(YSTART-Y(KTAR)).LE.EPSGRD) OUTCM(KTAR) = WBACK C TEST FOR GETTING A RESULT IN THE RIGHT GRID SQUARE IF ( .NOT. INSIDE(X(KTAR),Y(KTAR),IX,JY,INEXT,JNEXT,XGRID, . NGDIMX,YGRID,NGDIMY)) OUTCM(KTAR) = OUTSID IF (OUTCM(KTAR).EQ.SUCCES .AND. KTAR.EQ.1) GO TO 260 IF (OUTCM(KTAR).EQ.SUCCES .AND. KTAR.EQ.2) GO TO 290 GO TO 460 C C Y TARGETS - CHECK FOR HORIZONTAL BOUNDARY FIRST 330 CONTINUE XCASE = .FALSE. C C ---------- CHECK FOR NEARLY HORIZONTAL BOUNDARY C LOOP TO INCREASE DELP AND SEE IF BOUNDARY STAYS C ALONG THE GRID LINE UNTIL DYGRD IS PASSED DELP = (PSTOP-PARAM)/8. DO 340 NHORZ = 1,8 CALL BCOORD(PARAM+FLOAT(NHORZ)*DELP,TESTX,TESTY,IPIECE) DY = ABS(TESTY-YSTART) IF (DY.GT.10.E0*DYGRD*EPSGRD) GO TO 360 IF (DY.GT.DYGRD) GO TO 350 340 CONTINUE C C BOUNDARY HORIZONTAL 350 IF (LEVEL.GE.3) WRITE (MOUTPT,9081) XSTART,YSTART OUTCM(3) = HORZ OUTCM(4) = HORZ GO TO 460 C SELECT THE PROPER Y TARGET 360 IF (KTAR.EQ.4) GO TO 400 IF (JNEXT.LE.NGRIDY) GO TO 370 C WALKING OUTSIDE GRID DOMAIN OUTCM(3) = OUTSID OUTCM(4) = OUTSID IF (LEVEL.GE.1) WRITE (MOUTPT,9071) XSTART,YSTART GO TO 460 370 CONTINUE C CASE 3 ------------------ TRY THE FIRST Y-TARGET C SKIP THIS TARGET IF = YSTART, LOOK FOR DOUBLE BACK IF (ABS(YSTART-YTAR1).LE.EPSGRD) GO TO 450 C CHECK FOR TRYING TO WALK OUTSIDE IN Y-DIRECTION IF (OUTCM(3).EQ.OUTSID) GO TO 460 C USE SPECIAL REGULA FALSI TO IMPROVE THE INITIAL GUESS CALL REGULA(YTAR1,XCASE,GESS1(I),GESS2(I),PSTOP,EPSTAN,BCOORD) C NOW USE THE SECANT METHOD TO HIT TARGET ACCURATELY CALL SECANT(PARAM+GESS1(I),PARAM+GESS2(I),YTAR1,XCASE,P(3), . X(3),Y(3),OUTCM(3),PSTOP,DYGRD,BCOORD) IF (OUTCM(3).EQ.FAIL) GO TO 460 C CHECK FOR HAVING WALKED BACKWARD IF (ABS(YSTART-Y(3)).LE.EPSGRD) OUTCM(3) = WBACK C TEST FOR GETTING A RESULT IN THE RIGHT GRID SQUARE IF (INSIDE(X(3),Y(3),IX,JY,INEXT,JNEXT,XGRID,NGDIMX,YGRID, . NGDIMY)) GO TO 380 C POINT FOUND IS OUTSIDE GRID SQUARE, CHECK C FOR HAVING CROSSED THE TARGET TWICE. OUTCM(3) = OUTSID CALL CROSS2(YSTART,YTAR1,XCASE,P(3),X(3),Y(3),OUTCM(3),BCOORD) C CHECK TO SEE IF THE POINT IS STILL OUTSIDE IF ( .NOT. INSIDE(X(3),Y(3),IX,JY,INEXT,JNEXT,XGRID,NGDIMX, . YGRID,NGDIMY)) OUTCM(3) = OUTSID 380 IF (OUTCM(3).NE.SUCCES) GO TO 460 C C FOUND CROSSING POINT AT THE NEXT Y-GRID LINE 390 CONTINUE JNEW = JNEXT INEW = IX PNEW = P(3) XNEW = X(3) YNEW = YTAR1 C FINISH UP AS AT THE FOURTH TARGET GO TO 430 C CASE 4 ------------ TRY THE SECOND Y-TARGET 400 CONTINUE C SKIP THIS TARGET IF = YSTART, LOOK FOR DOUBLE BACK IF (ABS(YSTART-YTAR2).LE.EPSGRD) GO TO 450 C USE SPECIAL REGULA FALSI TO IMPROVE THE INITIAL GUESS CALL REGULA(YTAR2,XCASE,GESS1(I),GESS2(I),PSTOP,EPSTAN,BCOORD) C NOW USE THE SECANT METHOD TO HIT TARGET ACCURATELY CALL SECANT(PARAM+GESS1(I),PARAM+GESS2(I),YTAR2,XCASE,P(4), . X(4),Y(4),OUTCM(4),PSTOP,DYGRD,BCOORD) IF (OUTCM(4).EQ.FAIL) GO TO 460 C CHECK FOR HAVING WALKED BACKWARD IF (ABS(YSTART-Y(4)).LE.EPSGRD) OUTCM(4) = WBACK C TEST FOR GETTING A RESULT IN THE RIGHT GRID SQUARE IF (INSIDE(X(4),Y(4),IX,JY,INEXT,JNEXT,XGRID,NGDIMX,YGRID, . NGDIMY)) GO TO 410 C POINT FOUND IS OUTSIDE GRID SQUARE, CHECK C FOR HAVING CROSSED THE TARGET TWICE. OUTCM(4) = OUTSID CALL CROSS2(YSTART,YTAR2,XCASE,P(4),X(4),Y(4),OUTCM(4),BCOORD) C CHECK TO SEE IF THE POINT IS STILL OUTSIDE IF ( .NOT. INSIDE(X(4),Y(4),IX,JY,INEXT,JNEXT,XGRID,NGDIMX, . YGRID,NGDIMY)) OUTCM(4) = OUTSID 410 IF (OUTCM(4).NE.SUCCES) GO TO 460 C C FOUND CROSSING POINT AT THIS Y-GRID LINE 420 CONTINUE PNEW = P(4) XNEW = X(4) YNEW = YTAR2 INEW = IX JNEW = JY 430 TYPE = HORZ C CHECK POSSIBILITY OF TYPE BOTH C WE GET HERE ONLY IN UNUSUAL CASES IF (ABS(XNEW-XTAR1).GT.EPSGRD) GO TO 440 TYPE = BOTH INEW = INEXT XNEW = XTAR1 GO TO 510 440 IF (ABS(XNEW-XTAR2).GT.EPSGRD) GO TO 510 TYPE = BOTH INEW = IX XNEW = XTAR2 GO TO 510 C C SPECIAL CALCULATION FOR DOUBLING BACK ON TARGET 450 CONTINUE CALL DBACK(YSTART,YTEST,PTEST,XCASE,DYGRD,OUTCM(KTAR),P(KTAR), . X(KTAR),Y(KTAR),BCOORD,PSTOP) IF (OUTCM(KTAR).EQ.FAIL) GO TO 460 C CHECK FOR HAVING WALKED BACKWARD TO STARTING POINT IF (ABS(XSTART-X(KTAR)).LE.EPSGRD) OUTCM(KTAR) = WBACK C TEST FOR GETTING A RESULT IN THE RIGHT GRID SQUARE IF ( .NOT. INSIDE(X(KTAR),Y(KTAR),IX,JY,INEXT,JNEXT,XGRID, . NGDIMX,YGRID,NGDIMY)) OUTCM(KTAR) = OUTSID IF (OUTCM(KTAR).EQ.SUCCES .AND. KTAR.EQ.3) GO TO 390 IF (OUTCM(KTAR).EQ.SUCCES .AND. KTAR.EQ.4) GO TO 420 C 460 CONTINUE C C HAVE CHECKED ALL POSSIBLE GRID INTERSECTIONS - NOTHING FOUND C CHECK THE OUTSIDE POINTS FOR ACCEPTABILITY C OR FOR REDUCING PSTOP AND MAKING THE WHOLE SEARCH OVER C AGAIN - GOING BACK UP TO 12 POUT = PSTOP DO 470 I1 = 1,4 IF (OUTCM(I1).NE.OUTSID) GO TO 470 POUT = AMIN1(P(I1),POUT) IF ( .NOT. INSIDE(X(I1),Y(I1),IWEST,ISOUTH,IEAST,INORTH,XGRID, . NGDIMX,YGRID,NGDIMY)) GO TO 470 C HAVE ACCEPTABLE POINT, TAKE IT IF (LEVEL.GE.3) WRITE (MOUTPT,9091) X(I1),Y(I1) C LOCATE NEW POINT,SET COORDINATES AND EXIT BWALK CALL LOCATE(X(I1),Y(I1),INEW,JNEW,TYPE,XGRID,YGRID,NGDIMX, . NGDIMY) C CHECK LOCATION FAILURE - SHOULD NEVER HAPPEN IF (FATAL) GO TO 470 XNEW = X(I1) YNEW = Y(I1) PNEW = P(I1) GO TO 510 470 CONTINUE C C CHECK TO SEE IF PSTOP HAS BEEN REDUCED. IF SO REDO THE C WHOLE SEARCH - GOING BACK UP TO 12 TO RESTART IF (POUT.GE.PSTOP) GO TO 490 PSTOP = POUT IF (LEVEL.GE.3) WRITE (MOUTPT,9101) PSTOP,OUTCM(1),XTAR1,X(1), . Y(1),P(1),OUTCM(2),XTAR2,X(2),Y(2),P(2),OUTCM(3),YTAR1,X(3), . Y(3),P(3),OUTCM(4),YTAR2,X(4),Y(4),P(4) DO 480 I = 1,4 X(I) = -100.E0 Y(I) = -100.E0 P(I) = PEND + 1.E0 OUTCM(I) = NOTRY 480 CONTINUE ALLIN = .TRUE. GO TO 100 C STILL NO POINT FOUND C ************************************* C *********** FATAL ERROR *********** C ************************************* 490 CONTINUE C IF (LEVEL.GE.0) WRITE (MOUTPT,9111) IPIECE,XSTART,YSTART,IX,JY, . OUTCM(1),XTAR1,X(1),Y(1),P(1),OUTCM(2),XTAR2,X(2),Y(2),P(2), . OUTCM(3),YTAR1,X(3),Y(3),P(3),OUTCM(4),YTAR2,X(4),Y(4),P(4) C FATAL = .TRUE. GO TO 520 C C CURRENT PIECE STOPS IN THE GRID SQUARE 500 CONTINUE TYPE = INTER IF (LEVEL.GE.2) WRITE (MOUTPT,9121) IPIECE,XEND,YEND,IX,JY XNEW = XEND YNEW = YEND PNEW = PEND + .1E0*EPSGRD C C NORMAL SUBPROGRAM EXIT 510 CONTINUE C PRINT POSSIBLE BEFORE RETURN IF (LEVEL.GE.3) WRITE (MOUTPT,9131) PNEW,XNEW,YNEW,TYPE,INEW, . JNEW, (OUTCM(I),X(I),Y(I),I=1,4) RETURN C EXIT FOR FATAL ERROR DETECTED AT 200 ABOVE 520 FATAL = .TRUE. RETURN 9001 FORMAT (/5 (3H **),' FATAL ERROR, DID NOT FIND BOUNDARY'/9X, . 'POINT CLOSE TO',2F15.9/9X, . 'INEXPLICABLE, IT OCCURS IN FINDING INITIAL GRID SQUARE' . ) 9011 FORMAT (/5 (3H **),' FATAL ERROR, BOUNDARY GOES'/9X, . 'OUTSIDE GRID DOMAIN AT',2F12.6) 9021 FORMAT (9X,'TO POINT ',2F12.6,' WITH PARAMETER ',F12.8) 9031 FORMAT (/5 (3H **),' UNABLE TO START SEARCH FOR GRID', . ' INTERSECTION AT ',2F12.6) 9041 FORMAT (5X,'BOUNDARY WALK START WITH XSTART,YSTART,IX,JY,PTEST', . ',XTEST,YTEST = ',2F11.6,2I4,3F11.6/9X,'PARAM = ',F10.6, . ', X AND Y TARGETS ARE ',4F10.6) 9051 FORMAT (9X,'TARGET ORDERS,GUESSES =',4 (I3,I2,2F9.5)) 9061 FORMAT (9X,'BOUNDARY IS VERTICAL AT ',2F10.6) 9071 FORMAT (5 (' **'),'POSSIBLE FATAL ERROR, BOUNDARY GOES', . ' OUTSIDE GRID DOMAIN AT ',2F11.6) 9081 FORMAT (9X,'BOUNDARY IS HORIZONTAL AT ',2F10.6) 9091 FORMAT (1X,8 ('+'),'THE POINT ',2F10.6, . ' TAKEN EVEN THOUGH OUTSIDE',' EXPECTED GRID') 9101 FORMAT (9X,'ALL POINTS FOUND ARE TOO FAR AWAY. RESTART', . ' SEARCH WITH SMALLER PARAMETER LIMIT',F11.6/3X, . 'THE RESULTS OF 4 TRIES TO FOLLOW BOUNDARY'/ . 2 (2X,A4,' X=',F10.6,2F14.8,F12.6)/ . 2 (2X,A4,' Y=',F10.6,2F14.8,F12.6)) 9111 FORMAT (/5 (3H **),' FATAL ERROR IN BOUNDARY '/3X, . 'OR GRID DEFINITION FOR PIECE ',I3,' AT POINT ', . 2F10.6/2X,' IN GRID ',2I3,3X, . 'THE RESULTS OF 4 TRIES TO FOLLOW', . ' BOUNDARY'/2X, . 'NOTR - TARGET NOT TRIED OUTS - TARGET OUTSIDE GRID ' . /2X, . 'FAIL - TARGET NOT ACHIEVED BACK - FOUND PREVIOUS PT. ' . /2X,'OUTCOME',4X,'TARGET',12X,'X,Y-COORDS',10X, . 'PARAMETER'/2 (2X,A4,' X=',F10.6,2F14.8,F12.6/), . 2 (2X,A4,' Y=',F10.6,2F14.8,F12.6/)) 9121 FORMAT (2X,3 ('--'),' PIECE',I3,' ENDS AT POINT',2F10.6, . ' NEAR GRID ',2I4) 9131 FORMAT (5X,'--- END OF BOUNDARY WALK, PNEW =',F12.7/5X, . 'GIVES POINT ',2F10.6,' OF TYPE ',A4,' IN GRID ',2I3, . ' OUTCOMES,PTS FOR 4 CASES ='/3X,4 (2X,A4,2F12.6)) END SUBROUTINE CHANGE(BRANGE,NPDIM,XGRID,YGRID,NGDIMX,NGDIMY,NBDIM, . XBOUND,YBOUND,PIECE,BPTYPE,BGRID,BPARAM,BCOORD) C C *** THIS PROGRAM CHANGES BOUNDARY PIECES AND CHECKS FOR CONTINUTIY C IT ALSO PUTS THE END OF THE BOUNDARY PLUS THE NEXT POINT IN THE C BOUNDARY LIST. C C INPUT = BRANGE, (VIA COMMON) IPIECE,PARAM C PLUS DIMENSION VARIABLES = NPDIM,NGDIMX,NGDIMY,NBDIM C OUTPUT= (VIA COMMON) TYPE,PARAM,IPIECE,NBNDPT C XBOUND(NBNDPT) PIECE(NBNDPT) BPTYPE(NBNDPT) C YBOUND(NBNDPT) BGRID(NBNDPT) BPARAM(NBNDPT) C C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C EXTERNAL BCOORD CHARACTER *4 TYPEC REAL XGRID(NGDIMX),YGRID(NGDIMY),BRANGE(2,NPDIM) DIMENSION XBOUND(NBDIM),YBOUND(NBDIM),PIECE(NBDIM),BPTYPE(NBDIM), . BGRID(NBDIM),BPARAM(NBDIM) C COORDINATES OF END OF CURRENT PIECE CALL BCOORD(BRANGE(2,IPIECE),XOLD,YOLD,IPIECE) C C INCREMENT COUNTER IPIECE OF BOUNDARY PIECES C FIND COORDINATES (XCOR,YCOR) THAT START THE NEW PIECE IPIECE = IPIECE + 1 PARAM = BRANGE(1,IPIECE) CALL BCOORD(PARAM,XCOR,YCOR,IPIECE) C C CHECK THAT THE NEXT PIECE JOINS UP WITH CURRENT PIECE DIST = SQRT((XOLD-XCOR)**2+ (YOLD-YCOR)**2) IF (DIST.LE.4.E0*EPSGRD) GO TO 10 C IF (LEVEL.GE.0) WRITE (MOUTPT,9001) IPIECE,XCOR,YCOR,DIST FATAL = .TRUE. RETURN C 10 CONTINUE C C LOCATE AND TYPE CORNER POINT CALL LOCATE(XCOR,YCOR,IXCOR,JYCOR,TYPEC,XGRID,YGRID,NGDIMX,NGDIMY) C C DEBUG IF (LEVEL.GE.3) WRITE (MOUTPT,9011) IPIECE,NBNDPT,PARAM,XCOR, . YCOR,TYPEC,IXCOR,JYCOR C C CHECK TO SEE IF THE END POINT IS ALREADY IN BOUNDARY LIST C IF SO, GO ON TO THE NEXT POINT IF (ABS(BRANGE(2,IPIECE-1)-BPARAM(NBNDPT)).LE.EPSGRD) GO TO 20 C C HAVE NEW POINT (XCOR,YCOR) TO INSERT IN BOUNDARY LIST NBNDPT = NBNDPT + 1 XBOUND(NBNDPT) = XCOR YBOUND(NBNDPT) = YCOR BPTYPE(NBNDPT) = TYPEC BGRID(NBNDPT) = IXCOR + IPACKB*JYCOR BPARAM(NBNDPT) = BRANGE(2,IPIECE-1) PIECE(NBNDPT) = IPIECE - 1 C CHECK FOR TANGENCY AT CORNER POINT AS CHANGE IS MADE CALL CHKTAN(XBOUND,YBOUND,BPARAM,BPTYPE,BGRID,NBDIM,NPDIM,BRANGE, . XGRID,YGRID,NGDIMX,NGDIMY,TYPEC,IXCOR,JYCOR) C C ******* SUBPROGRAM EXIT AND DEBUG OUTPUT ******* 20 CONTINUE IF (LEVEL.LE.1) RETURN TYPEC = BPTYPE(NBNDPT) WRITE (MOUTPT,9021) IPIECE,XCOR,YCOR,TYPEC WRITE (MOUTPT,9031) NBNDPT,XBOUND(NBNDPT),YBOUND(NBNDPT) IF (LEVEL.EQ.2) RETURN WRITE (MOUTPT,9041) IXCOR,JYCOR,TYPEC,BPARAM(NBNDPT),DIST RETURN 9001 FORMAT (/5 (3H **),' FATAL ERROR, PIECE ',I3,' STARTS AT', . 2F15.7/9X,'PIECES DO NOT JOIN UP, BREAK IS ', . 1PE15.6) 9011 FORMAT (1X,'---CHANGE TO PIECE',I3,' AT BOUNDARY POINT',I3, . ' WITH PARAM = ',F10.6,', CORNER POINT IS ',2F10.6,', OF TYPE ', . A4/4X,'IT IS IN GRID ',2I3) 9021 FORMAT (/9X,'CHANGE TO BOUNDARY PIECE ',I3,' AT ',2F10.6, . ' WITH TYPE = ',A4) 9031 FORMAT (2X,3 ('--'),' IT IS BOUNDARY POINT ',I3, . ' WITH COORDINATES ',2F10.6) 9041 FORMAT (5X,'CORNER POINT DATA IX,JY,TYPE,PARAM,DISTANCE',2I4,1X, . A4,F10.6,1PE10.2) END SUBROUTINE CHKTAN(XBOUND,YBOUND,BPARAM,BPTYPE,BGRID,NBDIM,NPDIM, . BRANGE,XGRID,YGRID,NGDIMX,NGDIMY,TYPEPT,IXNU, . JYNU) C C ***** THIS PROGRAM CHECKS FOR THE BOUNDARY BEING TANGENT TO A GRID C LINE. IF TWO BOUNDARY POINTS ARE VERY CLOSE, THAT IS ABOUT C SQRT(EPSGRD) APART. THEN THEY ARE ASSUMED TO BE THE SAME POINT C AND THEY ARE MERGED INTO ONE POINT. NORMALLY THE SECOND POINT C FOUND( HAS INDEX = NBNDPT ) IS TAKEN, BUT WHEN THE TANGENT C IS THE FIRST POINT ON A BOUNDARY PIECE WE TAKE IT INSTEAD. C REAL XBOUND(NBDIM),YBOUND(NBDIM),BPARAM(NBDIM),XGRID(NGDIMX), . YGRID(NGDIMY),BRANGE(2,NPDIM) CHARACTER *4 BPTYPE,TYPEC,TYPEPT DIMENSION BPTYPE(NBDIM),BGRID(NBDIM) INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C DELX = ABS(XBOUND(NBNDPT)-XBOUND(NBNDPT-1)) DELY = ABS(YBOUND(NBNDPT)-YBOUND(NBNDPT-1)) C CHECK FOR TANGENCY TO HORIZONTAL GRID LINE C IF POINT IS ON HORIZONTAL GRID LINE IF ( .NOT. (TYPEPT.EQ.HORZ.OR.TYPEPT.EQ.BOTH)) GO TO 10 IF ( .NOT. (DELX.LE.EPSTAN.AND.DELY.LE.EPSGRD)) GO TO 10 DELGY2 = AMIN1(ABS(YBOUND(NBNDPT)-YGRID(JYNU)), . ABS(YBOUND(NBNDPT)-YGRID(JYNU+1))) DELGY1 = AMIN1(ABS(YBOUND(NBNDPT-1)-YGRID(JYNU)), . ABS(YBOUND(NBNDPT-1)-YGRID(JYNU+1))) GO TO 20 C C CHECK FOR TANGENCY TO VERTICAL GRID LINE C IF POINT IS ON VERTICAL GRID LINE 10 IF ( .NOT. (TYPEPT.EQ.VERT.OR.TYPEPT.EQ.BOTH)) GO TO 50 IF ( .NOT. (DELY.LE.EPSTAN.AND.DELX.LE.EPSGRD)) GO TO 50 DELGX2 = AMIN1(ABS(XBOUND(NBNDPT)-XGRID(IXNU)), . ABS(XBOUND(NBNDPT)-XGRID(IXNU+1))) DELGX1 = AMIN1(ABS(XBOUND(NBNDPT-1)-XGRID(IXNU)), . ABS(XBOUND(NBNDPT-1)-XGRID(IXNU+1))) C C HAVE FOUND TANGENCY, MERGE THE 2 POINTS C CHOOSE THE SECOND POINT UNLESS THE FIRST IS CLOSER TO THE C GRID LINES OR THE START OF A PIECE. C FURTHER CHECK TO SEE IF TWO INTERSECTIONS ARE SO CLOSE TO A C CORNER THAT THEY LOOK LIKE TANGENCY 20 CONTINUE IF (DELGX2.LE.EPSGRD .AND. DELGY1.LE.EPSGRD) GO TO 50 IF (DELGX1.LE.EPSGRD .AND. DELGY2.LE.EPSGRD) GO TO 50 C DONT HAVE FALSE TANGENCY NEAR A CORNER DELGRD = AMIN1(DELGX2,DELGY2) DELOLD = AMIN1(DELGX1,DELGY1) IF (ABS(BRANGE(1,IPIECE)-BPARAM(I1NBPT-1)).LE.EPSGRD) GO TO 30 IF (DELGRD.GT.DELOLD) GO TO 30 C USE THE SECOND POINT C ITEMS NOT CHANGED HERE ARE THE SAME FOR BOTH POINTS XBOUND(NBNDPT-1) = XBOUND(NBNDPT) YBOUND(NBNDPT-1) = YBOUND(NBNDPT) BPTYPE(NBNDPT-1) = BPTYPE(NBNDPT) BPARAM(NBNDPT-1) = BPARAM(NBNDPT) BGRID(NBNDPT-1) = BGRID(NBNDPT) NBNDPT = NBNDPT - 1 TYPEC = BPTYPE(NBNDPT) IF (LEVEL.GE.2) WRITE (MOUTPT,9001) NBNDPT,XBOUND(NBNDPT), . YBOUND(NBNDPT),TYPEC GO TO 40 C C USE THE FIRST POINT - BUT INCREASE PARAM 30 NBNDPT = NBNDPT - 1 PARAM = PARAM + EPSGRD TYPEC = BPTYPE(NBNDPT) IF (LEVEL.GE.2) WRITE (MOUTPT,9011) NBNDPT,XBOUND(NBNDPT), . YBOUND(NBNDPT),TYPEC 40 IF (LEVEL.GE.3) WRITE (MOUTPT,9021) DELX,DELY 50 RETURN 9001 FORMAT (2X,4 ('+++'),' FOUND BOUNDARY TANGENT TO GRID AT POINT', . I4/9X,'= ',2F10.6,' OF TYPE ',A4, . ' REPLACES PREVIOUS POINT') 9011 FORMAT (2X,4 ('+++'),' FOUND BOUNDARY TANGENT TO GRID AT POINT', . I4/9X,'= ',2F10.6,' OF TYPE ',A4, . ', MOVED PAST IT') 9021 FORMAT (8X,' TEST VARIABLES DELX,DELY =',4E12.3) END SUBROUTINE CROSS2(START,TARGET,XCASE,PEND,XEND,YEND,OUTCOM,BCOORD) C C **** THIS ROUTINE IS TO CHECK FOR THE POSSIBILITY THAT THE BOUNDARY C CROSSED THE TARGET GRID LINE MORE THAT ONCE AND THAT THE C FIRST CROSSING WAS NOT LOCATED. THE IDEA IS TO CHECK TO SEE C IF THE BOUNDARY IS MOVING TOWARD OR AWAY FROM THE START. IF C A DOUBLE( OR MORE ) CROSSING IS DETECTED THEN REGULA ( THE C MODIFIED REGULA FALSI METHOD) IS USED TO LOCATE A CROSSING C CLOSER TO THE START. NOTE THIS LOGIC WILL NOT NOT DETECT A C TRIPLE CROSSING. C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP CHARACTER *4 OUTCOM,SUCCES EXTERNAL BCOORD LOGICAL XCASE DATA SUCCES/'SUCC'/ C C FIRST CHECK FOR A DOUBLE CROSSING PCHECK = PEND - EPSTAN CALL BCOORD(PCHECK,XCHECK,YCHECK,IPIECE) CHECK = YCHECK IF (XCASE) CHECK = XCHECK SIGN = TARGET - START CSIGN = TARGET - CHECK IF (LEVEL.GE.3) WRITE (MOUTPT,9001) PEND,SIGN,CSIGN IF (SIGN*CSIGN.GT.0.) RETURN C FOUND A SIGN CHANGE = THERE IS CLOSER CROSSING C USE REGULA TO FIND IT ACCURATELY PLEFT = 0. PRIGHT = PCHECK - PARAM CALL REGULA(TARGET,XCASE,PLEFT,PRIGHT,PCHECK-PARAM,EPSGRD,BCOORD) C REGULA SHOULD ALWAYS CONVERGE SINCE THE TARGET IS BRACKETED C CHECK CONVERGENCE CALL BCOORD(PARAM+PRIGHT,X,Y,IPIECE) V = Y IF (XCASE) V = X IF (ABS(TARGET-V).GT.EPSGRD) RETURN C C HAVE CONVERGENCE, SET VALUES AND OUTCOM OUTCOM = SUCCES IF (LEVEL.GE.3) WRITE (MOUTPT,9011) XEND,YEND,X,Y PEND = PRIGHT XEND = X YEND = Y RETURN 9001 FORMAT (9X,'***** ','DOUBLE CROSSING CHECK AT',F12.6,' HAS SIGNS', . 2E13.3) 9011 FORMAT (9X,'***** ','DOUBLE CROSSING CHECK FOUND CLOSER POINT'/ . 15X,'ORIG OUTSIDE PT =',2F12.6,' NEW PT =',2F12.6) END SUBROUTINE DBACK(TARGET,VTEST,DELPST,XCASE,DVGRD,OUTCOM,P,X,Y, . BCOORD,PSTOP) C C ***** THIS PROGRAM ATTEMPTS TO FIND A CROSSING DUE TO THE C BOUNDARY DOUBLING BACK OVER A GRID LINE WITHIN THE GRID C SQUARE. THE BOUNDARY IS FOLLOWED FROM (XTEST,YTEST) UNTIL C IT CROSSES THE TARGET AGAIN. THIS GIVES PARAMETERS P1,P2 C WHICH ARE USED TO START SECANT SEARCH FOR THE RESULTS C P,X,Y = SOLUTION. C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C EXTERNAL BCOORD CHARACTER *4 OUTCOM,FAIL LOGICAL XCASE DATA FAIL/'FAIL'/ C ALWAYS LIMIT PARAMETER TO CURRENT PIECE DELPMX = PSTOP - PARAM FACTOR = 1.5E0 C DEVST = SIZE OF POINT-TARGET AT START C DEVNU = SIZE OF POINT-TARGET AT NEXT STEP DEVST = VTEST - TARGET DELP = DELPST KEXPND = 0 IF (LEVEL.GE.5) WRITE (MOUTPT,9001) KEXPND,DELP,DEVST,VTEST C C EXPAND PARAMETER STEP UNTIL BOUNDARY C CROSSES THE TARGET GRID LINE DO 10 KEXPND = 1,20 C STEP AWAY FROM PREVIOUS POINT TO CROSS THE TARGET DELPNU = AMIN1(FACTOR*DELP,DELPMX) CALL BCOORD(PARAM+DELPNU,XNU,YNU,IPIECE) VNU = YNU IF (XCASE) VNU = XNU DEVNU = VNU - TARGET C TEST FOR FINDING A SIGN CHANGE IN POINT-TARGET DIFFERENCE C THIS MEANS THAT WE HAVE CROSSED THE TARGET GRID LINE C SO WE START TO USE SECANT METHOD IF (DEVST*DEVNU.LT.0.E0) GO TO 30 DELP = DELPNU C INCREASE FACTOR OCCAISIONALLY IF (MOD(KEXPND,4).EQ.0) FACTOR = FACTOR*1.2E0 C CHECK FOR GETTING TOO FAR AWAY = FAILURE IF (ABS(DEVNU).GE.DVGRD .OR. DELPNU.GE.DELPMX) GO TO 20 IF (LEVEL.GE.5) WRITE (MOUTPT,9001) KEXPND,DELPNU,DEVNU,XNU, . YNU 10 CONTINUE C C FAILED TO FIND A DOUBLE CROSSING = FAILURE EXIT 20 OUTCOM = FAIL IF (LEVEL.GE.4) WRITE (MOUTPT,9011) TARGET,VTEST,XNU,YNU RETURN C C FOUND CROSSING, SET PARAMETER GUESSES P1 AND P2 C CALL SECANT TO FINISH FINDING CROSSING 30 CONTINUE P1 = PARAM + DELPNU P2 = PARAM + DELP IF (LEVEL.GE.5) WRITE (MOUTPT,9021) P1,P2 C USE SPECIAL REGULA FALSI TO IMPROVE THE INITIAL GUESS CALL REGULA(TARGET,XCASE,DELPNU,DELP,PSTOP,EPSTAN,BCOORD) C USE SECANT TO GET THE FINAL RESULTS CALL SECANT(PARAM+DELPNU,PARAM+DELP,TARGET,XCASE,P,X,Y,OUTCOM, . PSTOP,DVGRD,BCOORD) IF (OUTCOM.EQ.FAIL .AND. LEVEL.GE.4) WRITE (MOUTPT,9011) TARGET, . VTEST,XNU,YNU RETURN 9001 FORMAT (9X,'DBACK LOOP',I3,' GIVES DELPNU,DEVNU,X,Y =',4F11.6) 9011 FORMAT (9X,'DBACK ROUTINE FAILS FOR TARGET ',F10.6,', START AT ', . F11.7,', END AT ',2F11.7) 9021 FORMAT (9X,'DBACK SUCCEEDED TO BRACKET TARGET', . ' WITH PARAMETER = ',2F10.6) END SUBROUTINE EXPAND(ICENT,JCENT,NUPTS,INEW,JNEW,GTYPE,NGDIMX,NGDIMY) C C ***** THIS PROGRAM IS GIVEN THE POINT ICENT,JCENT AS AN INTERIOR C POINT. IT THEN DETERMINES IF ITS 4 NEIGHBORS ARE INTERIOR C POINTS AND, IF SO, MARKS THEM BY C GTYPE = NSIDE FOR PTS AWAY FROM THE BOUNDARY C GTYPE = -GTYPE FOR PTS NEXT TO THE BOUNDARY C C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C DIMENSION GTYPE(NGDIMX,NGDIMY) C INTEGER INEW(4),JNEW(4),PTYPE,IXN(4),JYN(4),CENTER LOGICAL PTNAY,BCROSS DATA IXN(1),IXN(2),IXN(3),IXN(4)/0,-1,0,1/ DATA JYN(1),JYN(2),JYN(3),JYN(4)/-1,0,1,0/ C C ARITHMETIC STATEMENT FUNCTIONS C PTNAY IS TRUE FOR BOUNDARY POINT LOCATED C ABOVE J=1 C RIGHT J=2 C BELOW J=3 C LEFT J=4 PTNAY(K,J) = MOD(K/ (IPACKB*2** (MOD(J-1,4))),2) .EQ. 1 C C BCROSS IS TRUE IF THE LINE FROM THE J-TH POINT TO THE C CENTER POINT CROSSES THE BOUNDARY BCROSS(J) = PTNAY(PTYPE,J) .AND. PTNAY(CENTER,J+2) C CENTER = GTYPE(ICENT,JCENT) NUPTS = 0 DO 10 JNAY = 1,4 IX = ICENT + IXN(JNAY) JY = JCENT + JYN(JNAY) PTYPE = -GTYPE(IX,JY) C PTYPE IS NEGATIVE FOR BOUNDARY POINTS IF (PTYPE.LT.0) GO TO 10 IF (BCROSS(JNAY)) GO TO 10 C HAVE AN INTERIOR POINT C CHECK FOR LEGALITY OF INDEXES IF (IX.LT.1 .OR. IX.GT.NGRIDX) GO TO 10 IF (JY.LT.1 .OR. JY.GT.NGRIDY) GO TO 10 NUPTS = NUPTS + 1 INEW(NUPTS) = IX JNEW(NUPTS) = JY IF (PTYPE.EQ.0) PTYPE = NSIDE GTYPE(IX,JY) = PTYPE 10 CONTINUE IF (LEVEL.GE.4) WRITE (MOUTPT,9001) ICENT,JCENT,PTYPE IF (LEVEL.GE.5 .AND. NUPTS.GT.0) WRITE (MOUTPT,9011) (I,INEW(I), . JNEW(I),I=1,NUPTS) RETURN 9001 FORMAT (5X,'EXPAND INTERIOR AT ',2I3,' FINAL TYPE =',I7) 9011 FORMAT (9X,'NEW POINTS = ',4 (I7,' = ',2I3)) END SUBROUTINE FILL(GTYPE,NGDIMX,NGDIMY,NBDIM,BGRID,BPTYPE,PIECE, . XBOUND,YBOUND) C C ***** THIS PROGRAM LOCATES AN INTERIOR POINT NEAR THE START OF THE C BOUNDARY AND THEN EXPANDS THE INTERIOR, MARKING ALL INTERIOR C POINTS BY CHANGING GTYPE TO PLUS OR SETTING GTYPE = INTER. C THE METHOD USES A QUEUE OF POINTS ON THE FRINGE OF THE CURRENTLY C KNOWN INTERIOR AND THIS QUEUE IS PROCESSED VIA EXPAND WHICH C LOCATES NEW INTERIOR POINTS ADJACENT TO ANY GIVEN ONE. C C INPUT. XBOUND,YBOUND = BOUNDARY POINT COORDINATES C BGRID = - - GRID LOCATIONS C BPTYPE = - - TYPES C PIECE = - - PIECE C GTYPE = GRID POINT MARKERS C OUTPUT. GTYPE MODIFIED C DIMENSION GTYPE(NGDIMX,NGDIMY) DIMENSION BGRID(NBDIM),BPTYPE(NBDIM),XBOUND(NBDIM),YBOUND(NBDIM), . PIECE(NBDIM) C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C INTEGER INEW(4),JNEW(4) CHARACTER *4 TYPE1,TYPE2,TYPE3,CORNER LOGICAL FIRST DATA CORNER/'CORN'/ C C SET ORIENT = +- 1 ( A SIGN ) DEPENDING ON ORIENTATION ORIENT = -1. IF (CLOCKW) ORIENT = 1. C CHANGE ORIENTATION IF CALLED FROM HOLE IF (INHOLE) ORIENT = -ORIENT C C FIND AN INITIAL INTERIOR POINT FROM THE BPTYPE ARRAY IB = N1BDPT FIRST = .TRUE. C C RETURN HERE FOR RESTART OF SEARCH IF THINGS LOOK C BAD. SKIP TO END OF LOOP IF IB=NBNDPT. 10 CONTINUE ISTART = IB + 1 IF (ISTART.LT.NBNDPT) GO TO 30 C IF THIS IS THE SECOND PASS OVER THE BOUNDARY, QUIT IF ( .NOT. FIRST) GO TO 60 C HAVE FAILED TO FIND INTERIOR POINT. MAKE ANOTHER PASS C AROUND BOUNDARY NOW ALLOWING CORNER POINTS TO BE USED C NEXT TO THE BOUNDARY POINT BEING TESTED. 20 IF (LEVEL.GE.2) WRITE (MOUTPT,9001) FIRST = .FALSE. ISTART = N1BDPT + 1 30 CONTINUE C DEBUG FOR LOOP RESTART IF (LEVEL.GE.4 .AND. ISTART.GT.N1BDPT+1) WRITE (MOUTPT, . 9011) IADDX,TESTX,JADDY,TESTY,IDIFF C C USE TYPES FOR 3 POINTS IN A ROW, INITIALIZE 2 HERE C SET TYPE FOR CORNER POINTS = CORNER TYPE2 = BPTYPE(IB) TYPE3 = BPTYPE(ISTART) IF (PIECE(IB).NE.PIECE(IB+1)) TYPE2 = CORNER IF (PIECE(ISTART).NE.PIECE(ISTART+1)) TYPE3 = CORNER DO 50 IB = ISTART,NBNDPT C UPDATE TYPES OF 3 POINTS ABOUT IB POINT TYPE1 = TYPE2 TYPE2 = TYPE3 TYPE3 = BPTYPE(IB+1) IF (PIECE(IB+1).NE.PIECE(IB+2)) TYPE3 = CORNER C DO NOT LOOK FOR INTERIOR POINT NEXT TO BOUNDARY POINT C WHOSE SUCCESSOR OR PREDECESSOR IS A CORNER C I. E. WHOSE TYPE IS CORNER OR INTER. IF (TYPE2.EQ.CORNER .OR. TYPE2.EQ.INTER) GO TO 40 IF (FIRST .AND. (TYPE3.EQ.CORNER.OR.TYPE1.EQ. . CORNER)) GO TO 40 IF (TYPE3.EQ.INTER .OR. TYPE1.EQ.INTER) GO TO 40 IF (IB.EQ.NBNDPT) GO TO 40 C DO NOT LOOK FOR INTERIOR POINT IF THE SUCCESSOR OR C PREDESSOR OF THE BOUNDARY POINT IS ON THE SAME GRID C LINE UNLESS THIS IS A GRID POINT( TYPE = BOTH ) TESTXM = XBOUND(IB) - XBOUND(IB-1) TESTYM = YBOUND(IB) - YBOUND(IB-1) TESTX = XBOUND(IB+1) - XBOUND(IB) TESTY = YBOUND(IB+1) - YBOUND(IB) IF (AMIN1(ABS(TESTX),ABS(TESTXM)).LE.EPSGRD .AND. TYPE2.EQ. . VERT) GO TO 40 IF (AMIN1(ABS(TESTYM),ABS(TESTY)).LE.EPSGRD .AND. TYPE2.EQ. . HORZ) GO TO 40 C DO NOT LOOK FOR INTERIOR POINT IF BOUNDARY IS TANGENT C TO HORIZONTAL OR VERTICAL GRID LINE IF (SIGN(1.,TESTX*TESTXM).LT.0.0 .AND. TYPE2.NE. . VERT) GO TO 40 IF (SIGN(1.,TESTY*TESTYM).LT.0.0 .AND. TYPE2.NE. . HORZ) GO TO 40 C HAVE FOUND A POINT WHOSE NEIGHBOR SHOULD BE C AN INTERIOR POINT, EXIT LOOP GO TO 70 C UPDATE TYPES FOR NEXT POINT 40 CONTINUE IF (LEVEL.GE.5) WRITE (MOUTPT,9021) IB,TYPE1,TYPE2,TYPE3 50 CONTINUE C C DO NOT GIVE UP UNTIL A SECOND PASS IS MADE IF (FIRST) GO TO 20 C *********************** FATAL ERROR ********************* C IF THE LOOP IS ENDED NORMALLY 60 CONTINUE C IF (LEVEL.GE.0) WRITE (MOUTPT,9031) FATAL = .TRUE. RETURN C C ---------- NEIGHBOR OF IB POINT SHOULD BE AN INTERIOR POINT --------- C 70 CONTINUE IX = MOD(BGRID(IB),IPACKB) JY = BGRID(IB)/IPACKB C DEBUG OUTPUT FOR LEVELS 3 AND 5 IF (LEVEL.GE.5) WRITE (MOUTPT,9021) IB,TYPE1,TYPE2,TYPE3 IF (LEVEL.GE.3) WRITE (MOUTPT,9041) IB,IX,JY,GTYPE(IX,JY) C C TO LOCATE INTERIOR POINT FROM BOUNDARY WE COMPUTE INCREMENTS C IADDX, JADDY FOR (IX,JY) = THE CORNER OF THE GRID SQUARE C CONTAINING THE IB POINT. THESE INCREMENTS ARE DETERMINED C BY THE FOLLOWING( THE SING ORIENT IS USED TO COMBINE THE TWO C ORIENTATIONS) C C CLOCKWISE COUNTERCLOCKWISE C TESTX TESTY TYPE2 IADDX JADDY IADDX JADDY C + HORZ 1 0 C - HORZ 0 1 C + BOTH 1 -1 C - BOTH -1 1 C + BOTH -1 1 C - BOTH 1 -1 C + VERT 1 0 C - VERT 0 1 C C SELECT CASE OF TYPE2 = BOUNDARY POINT TYPE IF (TYPE2.EQ.HORZ) GO TO 90 IF (TYPE2.EQ.VERT) GO TO 100 C HAVE BOUNDARY POINT OF TYPE BOTH, TREAT AS HORZ OR VERT C IF BOUNDARY IS MOVING STEADILY IN X OR Y DIRECTION C CHOOSE THE DIRECTION WITH THE MOST MOVEMENT XMOVE = ABS(TESTX) + ABS(TESTXM) YMOVE = ABS(TESTY) + ABS(TESTYM) XRATIO = AMIN1(ABS(TESTX),ABS(TESTXM))/ (XMOVE+EPSGRD) YRATIO = AMIN1(ABS(TESTY),ABS(TESTYM))/ (YMOVE+EPSGRD) C DO NOT CHOOSE DIRECTION WHERE MOVEMENT CHANGES SIGN IF (ABS(TESTX+TESTXM).LT.XMOVE-EPSGRD) XRATIO = -1. IF (ABS(TESTY+TESTYM).LT.YMOVE-EPSGRD) YRATIO = -1. RATIO = AMAX1(XRATIO,YRATIO) IF (LEVEL.GE.5) WRITE (MOUTPT,9051) XMOVE,XRATIO,YMOVE,YRATIO IF (RATIO.GT..01) GO TO 80 C SOMETHING MIGHT BE WRONG, GO BACK TO INITIAL SEARCH GO TO 10 80 IF (RATIO.LE.XRATIO-EPSGRD) GO TO 100 C C IB BOUNDARY POINT IS ON HORIZONTAL LINE 90 IADDX = 0 IF (TESTY*ORIENT.GT.0.0) IADDX = 1 C ADJUST IADDX FOR A POINT OF TYPE BOTH IF (TYPE2.EQ.BOTH .AND. IADDX.EQ.0) IADDX = -1 IX = IX + IADDX C C CHECK THAT TENTATIVE INTERIOR POINT HAS GTYPE THAT POINTS C TO THE IB BOUNDARY POINT IABSG = IABS(GTYPE(IX,JY))/IPACKB IF (LEVEL.GE.5) WRITE (MOUTPT,9061) TYPE2,IADDX,TESTY,ORIENT,IX, . IABSG C CHECK FOR BOUNDARY TO THE LEFT IF (IADDX.LE.1) IDIFF = MOD(IABSG/8,2) - 1 C CHECK FOR BOUNDARY TO THE RIGHT IF (IADDX.EQ.0) IDIFF = MOD(IABSG/2,2) - 1 IF (IDIFF.EQ.0) GO TO 110 C SOMETHING IS WRONG, GO BACK TO INITIAL SEARCH GO TO 10 C C IB POINT IS ON VERTICAL GRID LINE 100 JADDY = 0 IF (TESTX*ORIENT.LT.0.0) JADDY = 1 IF (TYPE2.EQ.BOTH .AND. JADDY.EQ.0) JADDY = -1 JY = JY + JADDY C C CHECK THAT TENTATIVE INTERIOR POINT HAS GTYPE THAT POINTS C TO THE IB BOUNDARY POINT IABSG = IABS(GTYPE(IX,JY))/IPACKB IF (LEVEL.GE.5) WRITE (MOUTPT,9061) TYPE2,JADDY,TESTX,ORIENT,JY, . IABSG C CHECK FOR BOUNDARY TO THE BELOW IF (JADDY.EQ.1) IDIFF = MOD(IABSG/4,2) - 1 C CHECK FOR BOUNDARY TO THE ABOVE IF (JADDY.LE.0) IDIFF = MOD(IABSG,2) - 1 IF (IDIFF.EQ.0) GO TO 110 C SOMETHING IS WRONG, GO BACK TO INITIAL SEARCH GO TO 10 C C GOT AN INTERIOR POINT 110 CONTINUE IF (LEVEL.GE.3) WRITE (MOUTPT,9071) IX,JY IF (LEVEL.GE.4) WRITE (MOUTPT,9081) IADDX,TESTX,JADDY,TESTY QX(1) = IX QY(1) = JY GTYPE(IX,JY) = -GTYPE(IX,JY) LENGTH = 1 C ISTART = 1 ISTOP = 1 C PROCESS THE QUEUE BY EXPANDING THE INTERIOR UNTIL NO C POINTS ARE LEFT ON ITS EDGE 120 CONTINUE CALL EXPAND(QX(ISTART),QY(ISTART),NUPTS,INEW,JNEW,GTYPE,NGDIMX, . NGDIMY) C C REMOVE THIS POINT FROM THE QUEUE LENGTH = LENGTH - 1 ISTART = ISTART + 1 IF (ISTART.GT.QLIMIT) ISTART = 1 IF (NUPTS.GT.0) GO TO 130 C C TEST FOR EMPTY QUEUE AND TERMINATION IF (LENGTH.GT.0) GO TO 120 C C *********** SUBPROGRAM EXIT ********** RETURN C 130 DO 140 K = 1,NUPTS ISTOP = ISTOP + 1 IF (ISTOP.GT.QLIMIT) ISTOP = 1 LENGTH = LENGTH + 1 C C **** TEST FOR QUEUE OVERFLOW **** IF (LENGTH.GT.QLIMIT) GO TO 150 QX(ISTOP) = INEW(K) QY(ISTOP) = JNEW(K) 140 CONTINUE GO TO 120 C C *********** FATAL ERROR EXIT ****** 150 CONTINUE C IF (LEVEL.GE.0) WRITE (MOUTPT,9091) QLIMIT IF (LEVEL.GE.2) WRITE (MOUTPT,9101) IF (LEVEL.GE.2) WRITE (MOUTPT,9111) (K,QX(K),QY(K),K=1,QLIMIT), . ISTOP FATAL = .TRUE. RETURN 9001 FORMAT (2X,7 ('++ '),'FIRST ATTEMPT TO FIND INTERIOR POINT', . ' FAILED') 9011 FORMAT (4X,'-RESTART SEARCH WITH IADDX,TESTX,JADDY,TESTY', . ',IDIFF =',2 (I3,E14.3),I4) 9021 FORMAT (5X,'TEST POINT',I3,' FOR INTERIOR, TYPES =',3 (2X,A4)) 9031 FORMAT (/5 (3H **),' FATAL ERROR, NO INITIAL INTERIOR POINT',/9X, . 'LOCATED NEXT TO BOUNDARY POINTS') 9041 FORMAT (9X,'CHECK NEIGHBOR OF BOUNDARY POINT ',I3, . ' AS INTERIOR POINT. IT IS ',2I4,' WITH GTYPE ',I7) 9051 FORMAT (9X,'VARIABLES TO CLASSIFY BOTH POINT. XMOVE,XRATIO', . ',YMOVE,YRATIO ='/15X,4F12.6) 9061 FORMAT (9X,A4,I4,2F12.6,2I5) 9071 FORMAT (9X,'-----POINT',2I4,' PASSES CHECK TO BE INTERIOR PT.') 9081 FORMAT (9X,'WITH IADDX,TESTX,JADDY,TESTY =',2 (I3,F12.4)) 9091 FORMAT (/5 (3H **),' FATAL ERROR IN TAGGING ALL INTERIOR POINTS'/ . 9X,' QUEUE OVERFLOWED IN SUBROUTINE', . ' FILL OF DOMAIN '/9X, . ' DOMAIN PROCESSOR MUST BE RECOMPILED ', . 'WITH QLIMIT',I5,' INCREASED') 9101 FORMAT (25X,'FINAL QUEUE, THEN ISTOP') 9111 FORMAT (6 (4X,3I3)) END SUBROUTINE HOLE(XGRID,YGRID,NGDIMX,NGDIMY,BRANGE,NPDIM,BCOORD, . SCLOCK,SARC,SLEVEL,GTYPE,XBOUND,YBOUND,PIECE, . BPTYPE,BNEIGH,BGRID,BPARAM,NBDIM,NBPTS,FAIL, . GTYPE2) C C ***** THIS ROUTINE IS AN ALTERNATE TO REGION AS A DRIVER FOR THE C DOMAIN PROCESSOR THAT IS USED TO REMOVE HOLES FROM THE DOMAIN. C THE HOLE IS PROCESSED LIKE AN ORIGINAL DOMAIN AND THEN THE C RESULTING INFORMATION USED BY REMOVH TO REMOVE THE HOLE. C THE INPUT/OUTPUT IS THE SAME AS REGION - SEE COMMENTS THERE - C EXCEPT THAT A SECOND ARRAY( = GTYPE2 ) IS PASSED AS C WORKSPACE FOR THE NEW GRID POINT TYPES C ***** REGION MUST BE CALLED BEFORE HOLE ***** C REAL XGRID(NGDIMX),YGRID(NGDIMY),BRANGE(2,NPDIM) LOGICAL SCLOCK,SARC,OLDARC,FAIL INTEGER SLEVEL,GTYPE2(NGDIMX,NGDIMY) DIMENSION GTYPE(NGDIMX,NGDIMY),XBOUND(NBDIM),YBOUND(NBDIM), . BPTYPE(NBDIM),BNEIGH(NBDIM),BGRID(NBDIM),BPARAM(NBDIM), . PIECE(NBDIM) EXTERNAL BCOORD INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP DATA OLDARC/.FALSE./ C IF (LEVEL.GT.0) WRITE (MOUTPT,9001) C C RESET COMMON BLOCK VARIABLES THAT MAY HAVE BEEN CHANGED C FROM THE PRECEEDING CALL TO REGION OR HOLE C NBOUND = NPDIM LEVEL = SLEVEL CLOCKW = SCLOCK ARC = SARC C C INITIALIZE JUMP TO HOLE, BOUNDARY POINT COUNT N1BDPT = NBNDPT + 2 C REDUCE STARTING INDEX AFTER AN ARC IF (OLDARC) N1BDPT = N1BDPT - 1 OLDARC = ARC BPTYPE(N1BDPT-1) = JUMP C MARK THAT WE ARE IN HOLE INHOLE = .TRUE. C CALL DOMAIN(XGRID,YGRID,NGDIMX,NGDIMY,BRANGE,NPDIM,BCOORD,GTYPE2, . XBOUND,YBOUND,PIECE,BPTYPE,BNEIGH,BGRID,BPARAM,NBDIM) C FAIL = FATAL IF (FATAL) RETURN C C USE GTYPE2 TO REMOVE HOLE FROM DOMAIN CALL REMOVH(GTYPE,GTYPE2,NGDIMX,NGDIMY) FAIL = FATAL N1BND = NBOUND + 1 C RETURN 9001 FORMAT (///' ',19 ('-')/' ',' DOMAIN PROCESSOR'/' ',19 ('-')//5X, . ' H O L E P R O C E S S O R ') END LOGICAL FUNCTION INSIDE(X,Y,IX,JY,INEXT,JNEXT,XGRID,NGDIMX,YGRID, . NGDIMY) C C **** THIS FUNCTION TESTS WHETHER THE POINT (X,Y) IS INSIDE THE GRID C WITH SIDES IX AND INEXT, JY AND JNEXT C THIS HAS BEEN MADE INTO A FUNCTION SUBPROGRAM BECAUSE TOO C MANY COMPILERS FAILED ON IT AS AN ARITHMETIC STATEMENT C FUNCTION. C REAL X,Y,XGRID(NGDIMX),YGRID(NGDIMY) INTEGER IX,JY,INEXT,JNEXT C C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C INSIDE = X .GE. (XGRID(IX)-EPSGRD) .AND. X .LE. . (XGRID(INEXT)+EPSGRD) .AND. Y .GE. . (YGRID(JY)-EPSGRD) .AND. Y .LE. (YGRID(JNEXT)+EPSGRD) RETURN END INTEGER FUNCTION ISETGT(GTYPE,IPOINT,NB) C C **** THIS FUNCTION SETS THE GTYPE VALUE OF A GRID POINT. C 1. SETS IT = INSIDE FOR INTERIOR POINTS C 2. UPDATES IT IF GTYPE HAS BEEN SET BY SOME OTHER BOUNDARY PT C 3. DOES NOTHING IF GRID POINT IS A BOUNDARY POINT C 4. SETS ITS FIRST VALUE IF IT HAS NOT BEEN SET BEFORE C LOGICAL PTNAY INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C C PTNAY IS TRUE FOR BOUNDARY POINT LOCATED C ABOVE J=1 C RIGHT J=2 C BELOW J=3 C LEFT J=4 PTNAY(K,J) = MOD(K/ (IPACKB*2** (MOD(J-1,4))),2) .EQ. 1 C C ISETGT = GTYPE C DO NOT CHANGE GTYPE AT BOUNDARY POINTS OR AT DOUBLE CROSSINGS IF ((ISETGT.LT.NSIDE.AND.ISETGT.GT.0) .OR. . PTNAY(IABS(ISETGT),IPOINT)) RETURN ISETGT = IABS(GTYPE) IF (ISETGT.EQ.0) ISETGT = NSIDE ISETGT = -MIN0(NB,MOD(ISETGT,IPACKB)) - . IPACKB* (ISETGT/IPACKB+2** (IPOINT-1)) RETURN END SUBROUTINE LOCATE(XB,YB,IX,JY,TYPEC,XGRID,YGRID,NGDIMX,NGDIMY) C C *** THIS PROGRAM LOCATES AND TYPES A GIVEN BOUNDARY POINT XB,YB C IT FINDS THE GRID SQUARE BOUNDED BY X-GRID LINES IX,IX+1 AND C Y-GRID LINES JY,JY+1 WHICH CONTAIN TH XB,YB POOINT. C INPUT = XB,YB = POINT COORDINATES C XGRID,YGRID = GRID DEFINITION C OUTPUT= IX,JY = GRID CONTAINING XB,YB C TYPEC = TYPE, BUT NOT RETURNED THRU COMMON C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C CHARACTER *4 TYPEC,TYPE1,TYPE2 REAL XGRID(NGDIMX),YGRID(NGDIMY) C C FIND X-GRID LINE TO LEFT OF XB IX = 0 DO 10 IXX = 1,NGRIDX IX = IX + 1 IF (XB.LE.XGRID(IX)-EPSGRD) GO TO 20 10 CONTINUE IF (XB.LE.XGRID(NGRIDX)+EPSGRD) GO TO 20 C IF (LEVEL.GE.0) WRITE (MOUTPT,9001) XB,XGRID(NGRIDX) FATAL = .TRUE. RETURN 20 IX = IX - 1 IF (XB.GT.XGRID(1)-EPSGRD) GO TO 30 C WRITE (MOUTPT,9011) XB,XGRID(1) FATAL = .TRUE. RETURN C C C FIND Y-GRID LINE BELOW YB 30 CONTINUE JY = 0 DO 40 JYY = 1,NGRIDY JY = JY + 1 IF (YB.LE.YGRID(JY)-EPSGRD) GO TO 50 40 CONTINUE IF (YB.LE.YGRID(NGRIDY)+EPSGRD) GO TO 50 C WRITE (MOUTPT,9021) YB,YGRID(NGRIDY) FATAL = .TRUE. RETURN 50 JY = JY - 1 IF (YB.GT.YGRID(1)-EPSGRD) GO TO 60 C WRITE (MOUTPT,9031) YB,YGRID(1) FATAL = .TRUE. RETURN C C DETERMINE IF FIRST POINT IS ON GRID LINES 60 TYPE1 = INTER C CHECK X-GRID LINES IF (ABS(XB-XGRID(IX)).LE.EPSGRD) TYPE1 = VERT C CHECK NEXT X-GRID LINE IF (ABS(XB-XGRID(IX+1)).GT.EPSGRD) GO TO 70 TYPE1 = VERT IX = IX + 1 C CHECK Y-GRID LINES 70 TYPE2 = INTER IF (ABS(YB-YGRID(JY)).LE.EPSGRD) TYPE2 = HORZ C CHECK NEXT Y-GRID LINE IF (ABS(YB-YGRID(JY+1)).GT.EPSGRD) GO TO 80 TYPE2 = HORZ JY = JY + 1 C CHECK FOR BOTH 80 CONTINUE TYPEC = INTER IF (TYPE1.EQ.INTER .AND. TYPE2.EQ.HORZ) TYPEC = HORZ IF (TYPE1.EQ.VERT .AND. TYPE2.EQ.INTER) TYPEC = VERT IF (TYPE1.EQ.VERT .AND. TYPE2.EQ.HORZ) TYPEC = BOTH C DEBUG IF (LEVEL.GE.4) WRITE (MOUTPT,9041) XB,YB,IX,JY,TYPEC,TYPE1,TYPE2 RETURN 9001 FORMAT (/5 (3H **),' FATAL ERROR, BOUNDARY POINT X-COORDINATE'/9X, . F10.6,' BIGGER THAN X-GRID ',F10.6) 9011 FORMAT (/5 (3H **),' FATAL ERROR, BOUNDARY POINT X-COORDINATE'/9X, . F10.6,' LESS THAN X-GRID ',F10.6) 9021 FORMAT (/5 (3H **),' FATAL ERROR, BOUNDARY POINT Y-COORDINATE'/9X, . F10.6,' BIGGER THAN Y-GRID ',F10.6) 9031 FORMAT (/5 (3H **),' FATAL ERROR, BOUNDARY POINT Y-COORDINATE'/9X, . F10.6,' LESS THAN Y-GRID ',F10.6) 9041 FORMAT (5X,'LOCATED POINT ',2F10.6,' IN GRID ',2I3,' OF TYPE ',A4, . ' AUX. VARS. = ',A4,1X,A4) END SUBROUTINE NEIGH(NGDIMX,NGDIMY,GTYPE,NBDIM,BNEIGH,BPTYPE,BGRID) C C ***** THIS ROUTINE COMPUTES POINTERS FROM THE BOUNDARY POINTS TO C THE INTERIOR GRID POINTS. THE VALUE IS ENCODED INTO BNEIGH C THE SAME WAY POINTERS ARE ENCODED INTO GTYPE( SEE COMMENTS IN C DOMAIN ) C C INPUT. BPTYPE = BOUNDARY POINT TYPES C BGRID = - - GRID LOCATIONS C GTYPE = GRID POINT MARKERS C OUTPUT. BNEIGH = POINTERS FROM BOUNDARY TO GRID C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C DIMENSION GTYPE(NGDIMX,NGDIMY) DIMENSION BPTYPE(NBDIM),BGRID(NBDIM),BNEIGH(NBDIM) C IF CALLED FROM HOLE WE ANTICIPATE THE CHANGE IN SIGN C OF GTYPE THAT IS COMING LATER BY SETTING IS = -1 IS = 1 IF (INHOLE) IS = -1 C INITIALIZE POINTER TO PREVIOUS JUMP POINT LASTJ = N1BDPT - 1 C C LOOP OVER BOUNDARY SETTING BNEIGH VALUES DO 90 IB = N1BDPT,NBNDPT C FIND GRID CONTAINING BOUNDARY POINT IB IX = MOD(BGRID(IB),IPACKB) JY = BGRID(IB)/IPACKB C C SELECT CASE DEPENDING ON TYPE OF POINT TYPE = BPTYPE(IB) BNEIGH(IB) = 0 IF (TYPE.EQ.HORZ) GO TO 10 IF (TYPE.EQ.VERT) GO TO 20 IF (TYPE.EQ.BOTH) GO TO 30 IF (TYPE.EQ.JUMP) GO TO 70 C EVERYTHING ELSE HAS BNEIGH = 0 GO TO 80 C C HORIZONTAL GRID POINT 10 CONTINUE IF (IS*GTYPE(IX,JY).GE.NSIDE) BNEIGH(IB) = BNEIGH(IB) + 8 IF (IX.EQ.NGRIDX) GO TO 80 IF (IS*GTYPE(IX+1,JY).GE.NSIDE) BNEIGH(IB) = BNEIGH(IB) + 2 GO TO 80 C C VERTICAL GRID POINT 20 CONTINUE IF (IS*GTYPE(IX,JY).GE.NSIDE) BNEIGH(IB) = BNEIGH(IB) + 4 IF (JY.EQ.NGRIDY) GO TO 80 IF (IS*GTYPE(IX,JY+1).GE.NSIDE) BNEIGH(IB) = BNEIGH(IB) + 1 GO TO 80 C C BOTH GRID POINT 30 CONTINUE IF (JY.EQ.NGRIDY) GO TO 40 IF (IS*GTYPE(IX,JY+1).GE.NSIDE) BNEIGH(IB) = BNEIGH(IB) + 1 40 IF (IX.EQ.NGRIDX) GO TO 50 IF (IS*GTYPE(IX+1,JY).GE.NSIDE) BNEIGH(IB) = BNEIGH(IB) + 2 50 IF (JY.EQ.1) GO TO 60 IF (IS*GTYPE(IX,JY-1).GE.NSIDE) BNEIGH(IB) = BNEIGH(IB) + 4 60 IF (IX.EQ.1) GO TO 80 IF (IS*GTYPE(IX-1,JY).GE.NSIDE) BNEIGH(IB) = BNEIGH(IB) + 8 GO TO 80 C JUMP POINT, COPY I1BNGH AND RESET LASTJ 70 BNEIGH(IB) = BNEIGH(LASTJ+1) LASTJ = IB C C TERMINAL MESSAGE 80 IF (LEVEL.GE.4) WRITE (MOUTPT,9001) IB,IX,JY,TYPE,BNEIGH(IB) 90 CONTINUE C C PROGRAM EXIT IF (LEVEL.GE.3) WRITE (MOUTPT,9011) RETURN 9001 FORMAT (5X,'NEIGHBORS OF ',I3,' IN SQUARE ',2I3,' OF TYPE ',A4, . ' FOUND, BNEIGH =',I7) 9011 FORMAT (9X,'HAVE SET BNEIGH FOR THE BOUNDARY') END SUBROUTINE REGULA(TARGET,XCASE,GESSL,GESSR,PSTOP,EPSILN,BCOORD) C C ***** THIS IS A SIMPLE MODIFIED REGULA FALSI METHOD TO IMPROVE THE C GUESSES FOR SECANT. THIS SPECIAL REGULA FALSI USES THE USUAL C FORMULA IS THE NEXT POINT IS BETWEEN THE PREVIOUS PAIR AND C USES A PROPORTIONAL RULE OTHERWISE WHICH KEEPS GESSL FIXED C IT IS NOT RUN TO COMPLETE CONVERGENCE IN NORMAL USE, THE SECANT C METHOD IS USED FOR THAT. C EPSILN = CONVERGENCE TOLERANCE TIMES 10. C CONVERG = EPSILN*.1 C ITERATIONS LIMITED TO 6 WHEN TARGET NOT BRACKETED C LIMITED TO 20 OTHERWISE C GESSL = FIRST GUESS OF INCREMENT TO TARGET C START = CORRESPONDING VARIABLE VALUE - NEVER CHANGED C VLEFT = CORRESPONDING VARIABLE VALUE C ELEFT = CORRESPONDING ERROR C GESSR = SECOND GUESS OF INCREMENT TO TARGET C VRIGHT= CORRESPONDING VARIABLE VALUE C ERIGHT= CORRESPONDING ERROR C GESNEW = NEW VALUE OF GESSL FROM REGULA FALSI FORMULA C VNEW = CORRESPONDING VARIABLE VALUE C ENEW = CORRESPONDING ERROR C DELJIG = SMALL VALUE TO JIGGLE RESULTS TO AVOID DUPLICATES C PSTOP = LIMIT ON THE PARAMETER VALUE C DELPMX = LIMIT ON THE CHANGE FROM PARAM = PSTOP-PARAM C GTOP = TOP LIMIT ON PARAMETER CHANGE C GBOT = BOTTOM LIMIT ON PARAMETER CHANGE C XCASE = .TRUE. WHEN TARGET IS X-VALUE C .FALSE. WHEN TARGET IS Y-VALUE C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C EXTERNAL BCOORD LOGICAL XCASE C FIND COORDINATES, ERRORS FOR INITIAL GUESSES CALL BCOORD(PARAM+GESSL,XLEFT,YLEFT,IPIECE) START = YLEFT IF (XCASE) START = XLEFT VLEFT = START ELEFT = TARGET - VLEFT CALL BCOORD(PARAM+GESSR,XRIGHT,YRIGHT,IPIECE) VRIGHT = YRIGHT IF (XCASE) VRIGHT = XRIGHT ERIGHT = TARGET - VRIGHT ENEW = 0.0E0 C SET LIMIT FOR PARAMETER DURING THE SEARCH DELPMX = PSTOP - PARAM C SIGN CHANGE BETWEEN GUESSES, RESET DELPMX IF (ELEFT*ERIGHT.LT.0.) DELPMX = GESSR CONVRG = .1E0*EPSILN GBOT = GESSL GTOP = DELPMX C C START MODIFIED REGULA FALSI ITERATION LOOP KREG = 0 10 KREG = KREG + 1 C PROTECTION FROM DIVISION BY ZERO DENOM = VLEFT - VRIGHT IF (ABS(DENOM).LE.EPSGRD) GO TO 40 C REGULA FALSI FORMULA GESNEW = GESSR - ERIGHT* (GESSR-GESSL)/DENOM C CHECK BRACKETEING OF NEW POINT IF (ABS(GESSR-GESSL).LT.ABS(GESSR-GESNEW)+ . ABS(GESSL-GESNEW)) GO TO 50 C HAVE GESNEW BRACKETED, PROCEED WITH MODIFIED REGULA FALSI CALL BCOORD(PARAM+GESNEW,XNEW,YNEW,IPIECE) VNEW = YNEW IF (XCASE) VNEW = XNEW EOLD = ENEW ENEW = TARGET - VNEW IF (ENEW*ERIGHT.GT.0.0) GO TO 20 C REPLACE VLEFT WITH NEW POINT VLEFT = VNEW ELEFT = ENEW GESSL = GESNEW IF (ENEW*EOLD.GT.0.) ERIGHT = ERIGHT/2.E0 GO TO 30 C REPLACE VRIGHT POINT WITH NEW POINT 20 VRIGHT = VNEW ERIGHT = ENEW GESSR = GESNEW IF (ENEW*EOLD.GT.0.) ELEFT = ELEFT/2.E0 30 CONTINUE IF (KREG.GE.20 .OR. ABS(ENEW).LE.CONVRG) GO TO 60 GO TO 10 C C ABOUT TO DIVIDE BY ZERO, CONJURE UP NEW DENOM 40 DENOM = TARGET - VLEFT + FLOAT(KREG)*EPSGRD*5. C DO NOT HAVE SOLUTION BRACKETED, DO NOT MOVE C STARTING POINT( GESSL ), ADJUST GESSR 50 GESSR = (GESSL*ELEFT-ERIGHT*GESSR)/DENOM C JIGGLE SOME TO AVOID GETTING DUPLICATE POINTS DELJIG = DELPMX*.01E0/FLOAT(KREG) GESSR = AMIN1(GTOP-DELJIG,AMAX1(GBOT,DELJIG)) CALL BCOORD(PARAM+GESSR,XRIGHT,YRIGHT,IPIECE) VRIGHT = YRIGHT IF (XCASE) VRIGHT = XRIGHT ERIGHT = TARGET - VRIGHT IF (KREG.LT.6) GO TO 10 C C ERROR EXIT - DID NOT GET A SATISFACTORY IMPROVEMENT C SET GESSR = PROPORTIONAL DISTANCE TO PSTOP CALL BCOORD(PSTOP,XRIGHT,YRIGHT,IPIECE) VRIGHT = YRIGHT IF (XCASE) VRIGHT = XRIGHT GESSR = GESSL - (TARGET-VRIGHT)* (VRIGHT-VLEFT)/ (DELPMX-GESSL) DELJIG = (PSTOP-START)*.001 GESSR = AMIN1(GTOP-DELJIG,AMAX1(GESSR,DELJIG)) IF (LEVEL.GE.4) WRITE (MOUTPT,9001) PARAM,TARGET,GESSL,GESSR, . VRIGHT RETURN C C NORMAL EXIT 60 CONTINUE IF (LEVEL.GE.4) WRITE (MOUTPT,9011) START,KREG,GESSL,GESSR, . VRIGHT,VLEFT RETURN 9001 FORMAT (3 (' ++'),'REGULA DID NOT CONVERGE NORMALLY', . ', STARTED WITH PARAM =',F10.6/9X,'FOR TARGET = ', . F10.6,' ENDED WITH GESSL, GESSR AND VALUE = ', . 3F11.6) 9011 FORMAT (9X,'REGULA-FALSI START,KREG,GESSL,GESSR,VALUES = ',F10.6, . I3,4F10.6) END SUBROUTINE REMOVH(GTYPE1,GTYPE2,NDX,NDY) C INTEGER GTYPE1(NDX,NDY),GTYPE2(NDX,NDY) LOGICAL FATALE C C C *** REMOVH REMOVES A HOLE FROM A DOMAIN. GTYPE1 REPRESENTS THE C DOMAIN AND GTYPE2 THE HOLE. ON EXIT, GTYPE1 HAS THE HOLE C REMOVED FROM IT. C C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C FATALE = .FALSE. DO 20 I = 1,NDX DO 10 J = 1,NDY IF (GTYPE2(I,J).EQ.0) GO TO 10 IF (GTYPE1(I,J).NE.NSIDE) FATALE = .TRUE. GTYPE1(I,J) = -GTYPE2(I,J) IF (IABS(GTYPE1(I,J)).LT.NSIDE) GTYPE1(I, . J) = IABS(GTYPE1(I,J)) IF (GTYPE1(I,J).EQ.-NSIDE) GTYPE1(I,J) = 0 10 CONTINUE 20 CONTINUE C IF ( .NOT. FATALE) GO TO 30 C C IF (LEVEL.GE.0) WRITE (MOUTPT,9001) FATAL = .TRUE. C 30 CONTINUE IF (LEVEL.GT.1) CALL TABLGT(MOUTPT,1,NDX,NDY,GTYPE1) C RETURN 9001 FORMAT (/5 (3H **),' FATAL ERROR IN ROUTINE REMOVH,'/9X, . 'HOLE TOO NEAR BOUNDARY OR OTHER HOLE'/9X, . 'MUST ADJUST GRID OR MAKE IT FINER') END SUBROUTINE SECANT(PFIRST,PSECND,TARGET,XCASE,PANS,X2,Y2,OUTCOM, . PSTOP,VGRID,BCOORD) C C ******* THIS IS A GENERAL PURPOSE SECANT ROUTINE FOR BOUNDARY C INTERSECTIONS. XCASE TELLS WHETHER AN X OR Y INTERSECTION C IS SOUGHT. CONVERGENCE TEST IS .2*EPSGRD BUT POINT ACCEPTED C AT END EVEN WITHIN ONLY EPSGRD OF TARGET. C OUTCOM CAN BE = SUCCES OR FAIL C C INPUT. PFIRST,PSECOND = GUESSES FOR PARAMETER C PSTOP = LIMIT ON PARAMETER C TARGET,XCASE = DESIRED COORDINATE VALUE( XCASE = .TRUE. C FOR X-VALUE, .FALSE. FOR Y-VALUE ) C VGRID = GRID SIZE FOR THE UNKNOWN VARIABLE C BCOORD = FUNCTION THAT DEFINES BOUNDARY C OUTPUT. PANS,X2,Y2 = ANSWERS( PARAMETER AND X,Y VALUES) C OUTCOM = OUTCOME FLAG ( = SUCCES OR FAIL ) C C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C EXTERNAL BCOORD LOGICAL XCASE,LAST CHARACTER *4 OUTCOM,SUCCES,FAIL DATA SUCCES,FAIL/'SUCC','FAIL'/ C OUTCOM = SUCCES C C SIMPLE PROTECTION AGAINST BAD INITIAL GUESSES P1 = PFIRST P2 = PSECND DELV = P2 - P1 IF (ABS(DELV).GE.EPSGRD) GO TO 10 IF (DELV.EQ.0.0E0) DELV = .0001E0* (PSTOP-PARAM) P1 = P1 - 2.E0*DELV P2 = P2 + 2.E0*DELV 10 CONTINUE P1 = AMAX1(PARAM,AMIN1(P1,PSTOP)) P2 = AMAX1(PARAM,AMIN1(P2,PSTOP)) CALL BCOORD(P1,X1,Y1,IPIECE) CALL BCOORD(P2,X2,Y2,IPIECE) C C INTRODUCE VARIABLES V1,V2 AS UNKNOWNS FOR THE SECANT IF (XCASE) GO TO 20 V1 = Y1 V2 = Y2 GO TO 30 20 V1 = X1 V2 = X2 30 CONTINUE C C SET BOUNDS ON RANGE OF UNKNOWN DELV = TARGET + SIGN(1.,TARGET-V1)*VGRID VLOW = AMIN1(V1,DELV) - EPSGRD VHIGH = AMAX1(V1,DELV) + EPSGRD IF (LEVEL.GE.5) WRITE (MOUTPT,9001) VLOW,VHIGH IF (LEVEL.GE.5) WRITE (MOUTPT,9011) P1,V1,P2,V2,TARGET,XCASE C C SET CONVERGENCE TOLERANCE LESS THAN EPSGRD C THE FACTOR 0.2 MAY BE CHANGED TO TUNE THE CONVERGENCE CONVRG = 0.2E0*EPSGRD ERPASS = EPSGRD EPS01 = EPSGRD*.01E0 C LIMIT THE SECANT METHOD TO 12 ITERATIONS C THERE IS A SPECIAL LAST ITERATION LAST = .FALSE. DO 70 KNTSEC = 1,12 C PROTECT AGAINST DIVISION BY ZERO IN SECANT FORMULA IF (ABS(V2-V1).GT.EPS01) PANS = P2 - . (V2-TARGET)* (P1-P2)/ (V1-V2) IF (ABS(V2-V1).LE.EPS01) PANS = P2 - . (V2-TARGET)* (P1-P2)/ (EPSGRD*SIGN(1.E0,V1-V2)) C RESTRICT PARAMETER TO VALID RANGE C INTRODUCE TEMPORARY PARAMETER VALUE PTEMP PTEMP = AMIN1(PSTOP,AMAX1(PANS,PARAM)) CALL BCOORD(PTEMP,XNU,YNU,IPIECE) VNU = YNU IF (XCASE) VNU = XNU C C CHECK THAT THE SECANT METHOD IS STAYING WITHIN RANGE IF (VNU.LE.VHIGH .AND. VNU.GE.VLOW) GO TO 40 C CHANGE PANS TO KEEP IT NEAR THE LIMIT POINT DELV = VNU - V2 VF = VHIGH - V2 IF (VNU.LT.VLOW) VF = VLOW - V2 RATIO = .4 + .4/FLOAT(KNTSEC) IF (ABS(DELV).GT.EPS01) RATIO = VF/ (DELV) PANS = RATIO* (PANS-P2) + P2 IF (LEVEL.GE.5) WRITE (MOUTPT,9021) KNTSEC,P1,P2,PANS,V1,V2, . VNU C RESTRICT PANS TO VALID RANGE C JIGGLED BY .02/KNTSEC TO PREVENT GETTING C DUPLICATE POINTS VF = 1. - .02E0/FLOAT(KNTSEC) PANS = AMIN1(PSTOP*VF,AMAX1(PANS,PARAM)/VF) CALL BCOORD(PANS,XNU,YNU,IPIECE) VNU = YNU IF (XCASE) VNU = XNU GO TO 50 C OK TO USE PTEMP AS PANS 40 PANS = PTEMP C C GET CONVERGENCE CLOSER THAN EPSGRD 50 ERROR = ABS(VNU-TARGET) IF (ERROR.GE.ERPASS) GO TO 60 C SAVE BEST POINT CLOSER THAN EPSGRD ERPASS = ERROR XPASS = XNU YPASS = YNU IF (ERROR.GT.CONVRG) GO TO 60 C HAVE PASSED THE CONVERGENCE TEST C CHECK FOR THE LAST ITERATION IF (LAST) GO TO 90 LAST = .TRUE. C C AFTER NORMAL CONVERGENCE DO 1 MORE ITERATION BEFORE QUITTING C WILL PICK THE BEST OF THE TWO RESULTS CONVRG = 1.E10*CONVRG ERPASS = CONVRG ERROLD = ERROR XOLD = XNU YOLD = YNU C RESET FOR NEXT ITERATION 60 P1 = P2 V1 = V2 P2 = PANS V2 = VNU 70 CONTINUE C C CHECK TO SEE IF WE HAVE COME WITHIN EPSGRD OF C TARGET, IF SO ACCEPT THAT POINT IF (ERPASS.GE.EPSGRD) GO TO 80 ERROR = ERPASS XNU = XPASS YNU = YPASS GO TO 100 C SECANT METHOD DID NOT CONVERGE NORMALLY 80 OUTCOM = FAIL X2 = XNU Y2 = YNU IF (LEVEL.GE.4) WRITE (MOUTPT,9031) X2,Y2,ERROR RETURN C C NORMAL CONVERGENCE EXIT 90 CONTINUE C C TAKE THE BEST OF THE LAST TWO ITERATES AS THE SECANT ANSWER IF (ERROR.LE.ERROLD) GO TO 100 XNU = XOLD YNU = YOLD ERROR = ERROLD 100 CONTINUE X2 = XNU Y2 = YNU IF (LEVEL.GE.4) WRITE (MOUTPT,9041) X2,Y2,KNTSEC,PANS,ERROR RETURN 9001 FORMAT (9X,'BOUNDS ON VARIABLE RANGE =',F12.5,' TO ',F12.5) 9011 FORMAT (9X,'START SECANT AT ',2 (F14.7,F12.7),' FOR TARGET ', . F11.6,' WITH XCASE = ',L3) 9021 FORMAT (15X,'RANGE LIMIT INFO P1,P2,PANS,V1,V2,VNU =',I3,6F12.7) 9031 FORMAT (15X,'SECANT FAILED TO CONVERGE, FOUND POINT',2F14.9, . ', WITH ERROR =',1PE11.2) 9041 FORMAT (15X,'SECANT CONVERGED TO (X,Y) =',2F14.9,' IN ',I3, . ' ITERATIONS. PARAM,ERROR =',F11.7,1PE11.2) END SUBROUTINE TABLGT(MOUTPT,IPAGE,NGRIDX,NGRIDY,GTYPE) C C *** THIS PROGRAM PRINTS THE ARRAY GTYPE GTYPE(NGRIDX,NGRIDY), C ON OUTPUT UNIT MOUTPT. IF IPAGE = 1 THEN A NEW PAGE IS C STARTED. C INTEGER GTYPE(NGRIDX,NGRIDY) C IF (IPAGE.EQ.1) WRITE (MOUTPT,9001) WRITE (MOUTPT,9011) NGRIDX,NGRIDY C DO 10 NY = 1,NGRIDY J = NGRIDY - NY + 1 WRITE (MOUTPT,9021) J, (GTYPE(I,J),I=1,NGRIDX) 10 CONTINUE C WRITE (MOUTPT,9031) (I,I=1,NGRIDX) C RETURN 9001 FORMAT ('1',40 ('-')/' ',' DOMAIN PROCESSOR OUTPUT OF GTYPE ARRAY' . /' ',40 ('-')) 9011 FORMAT (' '//' ',4X,58 ('+')/' ',4X,'+',56X,'+'/' ',4X,'+',4X, . 'TABLE OF THE POINT TYPES ON',I4, . ' X',I4,' GRID',4X,'+'/' ',4X,'+',56X, . '+'/' ',4X,58 ('+')///' ',9X, . 'THE POINT XGRID(1), YGRID(1)', . ' IS AT THE LOWER LEFT.'/' ',9X, . 50 ('-')/) 9021 FORMAT (' ',I3,' * ',18I7/ (' ',6X,18I7)) 9031 FORMAT (' ',4X,'*'/' ',4X,'*******',I2,17I7/ (' ',6X,18I7)) END SUBROUTINE GVALUS(XGRID,YGRID,NGDIMX,NGDIMY,GTYPE,NBDIM,XBOUND, . YBOUND,BPTYPE,BGRID) C C *** THIS PROGRAM LOCATES THE NEIGHBORING GRID POINTS WITH RESPECT C TO THE BOUNDARY. THE INFO IS ENCODED INTO GTYPE. C GTYPE IS INITIALLY NEGATIVE BUT IT IS SET POSITIVE AT C INTERIOR POINTS BY THE SUBROUTINE FILL CALLED LATER. C C INPUT. XBOUND,YBOUND = BOUNDARY POINT COORDINATES C BGRID = - - GRID LOCATIONS C BPTYPE = - - TYPES C XGRID,YGRID = GRID DEFINITION C GTYPE = GRID MARKERS INITIALIZED TO ZERO C OUTPUT. GTYPE MODIFIED C INTEGER N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY,LEVEL, . QLIMIT,QX(250),QY(250),GTYPE,PIECE,BGRID,BNEIGH REAL PARAM,EPSGRD,EPSTAN LOGICAL CLOCKW,ARC,FATAL,INHOLE CHARACTER *4 TYPE,BPTYPE,HORZ,VERT,BOTH,INTER,JUMP COMMON /DMCINT/N1BND,N1BDPT,NSIDE,IPACKB,MOUTPT,NGRIDX,NGRIDY, . LEVEL,QLIMIT,QX,QY COMMON /DMCREL/PARAM,EPSGRD,EPSTAN COMMON /BNDRYI/IPIECE,NBOUND,NBNDPT COMMON /BNDRYL/CLOCKW,ARC,FATAL,INHOLE COMMON /DMCHAR/TYPE,HORZ,VERT,BOTH,INTER,JUMP C REAL XGRID(NGDIMX),YGRID(NGDIMY) DIMENSION GTYPE(NGDIMX,NGDIMY) DIMENSION XBOUND(NBDIM),YBOUND(NBDIM),BPTYPE(NBDIM),BGRID(NBDIM) C C LOOP OVER BOUNDARY POINTS DO 120 NB = N1BDPT,NBNDPT IX = MOD(BGRID(NB),IPACKB) JY = BGRID(NB)/IPACKB C NBPTDL = NBNDPT - N1BDPT + 1 NBACK = MOD(NB-N1BDPT+1+NBPTDL-2,NBPTDL) + N1BDPT C ELIMINATE ANY INTERIOR POINT BEHIND THE NB POINT IF (BPTYPE(NBACK).EQ.INTER) NBACK = MOD(NB-N1BDPT+1+NBPTDL-3, . NBPTDL) + N1BDPT C VARIABLES FOR TESTING THE DIRECTION OF THE BOUNDARY TESTX = XBOUND(NB) - XBOUND(NBACK) TESTY = YBOUND(NB) - YBOUND(NBACK) TYPE = BPTYPE(NB) C C THERE ARE SEVERAL CASES = VERT, HORZ AND BOTH,INTER IF (TYPE.EQ.VERT) GO TO 10 IF (TYPE.EQ.HORZ) GO TO 30 IF (TYPE.EQ.BOTH) GO TO 50 IF (TYPE.EQ.INTER) GO TO 100 C C HAVE ERROR IN ILLEGAL TYPE C IF (LEVEL.GE.0) WRITE (MOUTPT,9001) NB,IX,JY,TYPE FATAL = .TRUE. GTYPE(IX,JY) = NB GO TO 110 C C ****** BOUNDARY POINT IS ON VERTICAL GRID LINE ************** 10 CONTINUE C CHECK FOR A DOUBLE CROSSING ON THIS GRID IF (ABS(TESTX).LE.EPSGRD .AND. YBOUND(NBACK).LT.YGRID(JY+1)+ . EPSGRD .AND. YBOUND(NBACK).GT.YGRID(JY)-EPSGRD) GO TO 20 C C SET GTYPE FOR POINTS ABOVE AND BELOW GTYPE(IX,JY) = ISETGT(GTYPE(IX,JY),1,NB) GTYPE(IX,JY+1) = ISETGT(GTYPE(IX,JY+1),3,NB) GO TO 110 C C HAVE A DOUBLE CROSSING C GTYPE HAS ALREADY BEEN SET CORRECTLY BY THE NBACK POINT C EXCEPT AT THE START OF THE BOUNDARY 20 IF (NB.GT.2) GO TO 110 C C IDIREC = +1 FOR BOUNDARY GOING UP, = 0 GOING DOWN IDIREC = +1 IF (TESTY.LT.0.0) IDIREC = 0 JY1ID = JY + 1 - IDIREC GTYPE(IX,JY1ID) = -NBACK - IPACKB* (4-3*IDIREC) GO TO 110 C C ******* BOUNDARY POINT IS ON HORIZONTAL GRID LINE *********** 30 CONTINUE C CHECK FOR A DOUBLE CROSSING ON THIS GRID IF (ABS(TESTY).LE.EPSGRD .AND. XBOUND(NBACK).LT.XGRID(IX+1)+ . EPSGRD .AND. XBOUND(NBACK).GT.XGRID(IX)-EPSGRD) GO TO 40 C C SET GTYPE FOR POINTS LEFT AND RIGHT GTYPE(IX,JY) = ISETGT(GTYPE(IX,JY),2,NB) GTYPE(IX+1,JY) = ISETGT(GTYPE(IX+1,JY),4,NB) GO TO 110 C C HAVE A DOUBLE CROSSING C GTYPE HAS ALREADY BEEN SET CORRECTLY BY THE NBACK POINT C EXCEPT AT THE START OF THE BOUNDARY 40 IF (NB.GT.2) GO TO 110 C C IDIREC = +1 FOR BOUNDARY GOING RIGHT, = 0 GOING LEFT IDIREC = +1 IF (TESTX.LT.0.0) IDIREC = 0 IX1ID = IX + 1 - IDIREC GTYPE(IX1ID,JY) = -NBACK - IPACKB* (2+6*IDIREC) GO TO 110 C C ******* BOUNDARY POINT IS AT GRID POINT IX,JY ***************** 50 CONTINUE C C TYPE THIS GRID POINT AS A BOUNDARY POINT GTYPE(IX,JY) = NB C SET ALL 4 NEIGHBORS THAT ARE NOT ALSO BOUNDARY POINTS OF C THE GRID. SKIP THOSE BOUNDARY PTS THAT ARE GRID PTS OR C HAVE BOUNDARY PTS ALREADY INDICATED ON THIS SEGMENT IF (IX.EQ.NGRIDX) GO TO 60 C POINT TO THE RIGHT GTYPE(IX+1,JY) = ISETGT(GTYPE(IX+1,JY),4,NB) 60 IF (JY.EQ.NGRIDY) GO TO 70 C POINT ABOVE GTYPE(IX,JY+1) = ISETGT(GTYPE(IX,JY+1),3,NB) 70 IF (JY.EQ.1) GO TO 80 C POINT BELOW GTYPE(IX,JY-1) = ISETGT(GTYPE(IX,JY-1),1,NB) 80 IF (IX.EQ.1) GO TO 90 C POINT TO THE LEFT GTYPE(IX-1,JY) = ISETGT(GTYPE(IX-1,JY),2,NB) 90 CONTINUE GO TO 110 C C BOUNDARY POINT IS INTERIOR, NO GTYPES TO SET 100 CONTINUE C C ALL CASES COME HERE, POSSIBLE PRINT FOR DEBUG 110 CONTINUE C C LEVEL 4 DEBUG OUTPUT C NOTE: GTYPE VALUES MAY BE PRINTED FOR ILLEGAL INDICES C 0, NGRIDX + 1, NGRIDY + 1 IF (LEVEL.GE.4) WRITE (MOUTPT,9011) NB,TYPE,GTYPE(IX,JY), . GTYPE(IX+1,JY),GTYPE(IX-1,JY),GTYPE(IX,JY+1),GTYPE(IX,JY-1) IF (LEVEL.GE.5) WRITE (MOUTPT,9021) TESTX,TESTY,NBPTDL,NBACK 120 CONTINUE C END OF LOOP OVER BOUNDARY C IF (LEVEL.LT.2) RETURN WRITE (MOUTPT,9031) RETURN 9001 FORMAT (/5 (3H **),' FATAL ERROR IN DETERMINING NEIGHBORS OF',/9X, . 'BOUNDARY POINT ',I3,' IN GRID SQUARE ',2I3,/9X, . ' WITH UNKNOWN TYPE = ',A4) 9011 FORMAT (5X,'POINT',I4,' OF TYPE ',A4,' AND GTYPE = ',5I7) 9021 FORMAT (14X,'TESTX,TESTY,NBDPDL,NBACK = ',2F12.7,I4,I7) 9031 FORMAT (9X,'----HAVE SET GTYPE FOR ALL POINTS') END C/////////////////////////////////////////////////////////////////// C///////////////// END OF LOGICAL FILE 4 /////////////////////////// C//////////////////////////////////////////////////////////////////// C////////////////////////////////////////////////////////////////// C/////////////////// ALGORITHM GENCOL //////////////////////////// C///////////////////////////////////////////////////////////////// C>>>>>>>>>>>>>>>>> LOGICAL FILE 5 : ALGORITHM GENCOL <<<<<<<<<<< C//////////////////////////////////////////////////////////////// SUBROUTINE GENCOL(GTYPE,NGRDXD,NGRDYD,NBOUND,NBNDPT,NPDIM,NBDIM, . DOMFLG,AX,BX,AY,BY,NGRIDX,NGRIDY,COEF,IDCOEF, . UNKVCT,MXNCOE,MXNEQ,OUTFNC,OUTTYP,NOUT,TABX, . TABY,NTABX,NTABY,LEVEL,MOUTPT,WRKSP) C C C PURPOSE C C USES THE COLLOCATION METHOD TO FIND A BICUBIC HERMITE C APPROXIMANT TO THE SOLUTION OF C C C1*UXX + C2*UXY + C3*UYY + C4*UX + C5*UY + C6*U = F IN OMEGA C B1*U + B2*UX + B3*UY = G ON BOUNDARY OMEGA C C WHERE C C1,C2,C3,C4,C5,C6,F,B1,B2,B3, AND G ARE FUNCTIONS OF X AND Y C AND OMEGA IS A CONNECTED, BOUNDED REGION IN R X R C C AND PRINTS TABLES OR NORMS OF THE APPROXIMATE SOLUTION, C ERROR, OR RESIDUAL C C C INPUTS C C C 1) DOMAIN SPECIFICATION C C - BOUNDARY DEFINITION - C C NPDIM ARRAY DIMENSION FOR BOUNDARY PIECES C C NBDIM ARRAY DIMENSION FOR BOUNDARY POINTS C C NBOUND NUMBER OF BOUNDARY PIECES C C BCOORD PARAMETERIZED DEFINITION OF THE BOUNDARY. C BCOORD(P,X,Y,IPIECE) GIVES THE X,Y VALUES OF THE C POINT ON PIECE IPIECE WITH PARAMETER VALUE = P. C C EXAMPLE OF BCOORD C C SUBROUTINE BCOORD(P,X,Y,IPIECE) C C GO TO (101,102,. . .),IPIECE C C DEFINE FIRST PIECE OF BOUNDARY C C 101 X = (X COORDINATE OF BOUNDARY AS FUNCTION OF P) C Y = (Y COORDINATE OF BOUNDARY AS FUNCTION OF P) C RETURN C C DEFINE SECOND PIECE OF BOUNDARY C C 102 X = . . . C Y = . . . C RETURN C C . C . C . C END C C BRANGE(2,I) = FIRST AND LAST VALUES OF PARAMETERS DEFINING C THE I-TH BOUNDARY PIECE C C DOMFLG = TRUE - USE DOMAIN PROCESSOR C FALSE - THE REMAINING DOMAIN INFORMATION WILL C BE SUPPLIED BY THE USER C C **** IMPORTANT NOTE - THE DOMAIN MUST BE SPECIFIED CLOCKWISE **** C C C ---- THE REMAINING DOMAIN INFORMATION IS SUPPLIED BY THE USER C (IF DOMFLG=.FALSE.) OR BY THE DOMAIN PROCESSOR (IF DOMFLG=TRUE) C C REFERENCES FOR THE DOMAIN PROCESSOR: C C JOHN R. RICE, NUMERICAL COMPUTATION WITH GENERAL TWO C DIMENSIONAL DOMAINS, CSD-TR 416, COMPUTER SCIENCE DEPT, C PURDUE UNIVERSITY, OCTOBER 1982. C C JOHN R. RICE, ALGORITHM: A TWO DIMENSIONAL DOMAIN PROCESSOR, C CSD-TR 417, COMPUTER SCIENCE DEPT, PURDUE UNIVERSITY, C OCTOBER 1982. C C - GRID SPECIFICATION - C C GTYPE(IX,JY) FOR IX = 1 TO NGRIDX, JY = 1 TO NGRIDY C THE VALUES IN THIS ARRAY GIVE THE TYPE OF THE GRID POINTS AND C INFORMATION ABOUT THEIR RELATION TO THE BOUNDARY. C THERE IS A PACKING FACTOR IPACKB WHICH IS NORMALLY 1000. FOR C VERY LARGE PROBLEMS, IPACKB AND RELATED CONSTANT NSIDE = C IPACKB - 1 MUST BE INCREASED SO THAT NSIDE .GT. NBNDPT. C POSSIBLE VALUE ARE( ASSUMING IPACKB = 1000) C C = INTEGER OVER 1000 C GRID POINT IS NEXT TO THE BOUNDARY AND THE GTYPE VALUE IS C GTYPE = K + 1000*J WHERE C K IS THE INDEX OF THE LOWEST NUMBERED BOUNDARY NEIGHBOR C MUST DOUBLE CHECK USE WHEN K = 1 C J = FOUR BITS TO NOTE LOCATION OF BOUNDARY POINTS C 0001 - BOUNDARY NEIGHBOR TO NORTH (NOON) C 0010 - BOUNDARY NEIGHBOR TO EAST (3 O'CLOCK) C 0100 - BOUNDARY NEIGHBOR TO SOUTH (6 O'CLOCK) C 1000 - BOUNDARY NEIGHBOR TO WEST (9 O'CLOCK) C THUS J=9 (1001 IN BINARY) IMPLIES THAT THERE ARE BOUNDARY C NEIGHBORS TO THE NORTH AND WEST C EXAMPLES ( X = BNDRY PT., 0 = GRID PT ) C C X X X 0 X C C X 0 0 X X C J=9 J=3 J=14 C C ***** NOTE THAT GTYPE IS INITIALLY SET NEG. AND THEN MADE C POSITIVE WHEN THE INTERIOR IS FILLED C C = 999 C MEANS GRID POINT IS INTERIOR TO THE REGION AND NOT CLOSE C TO THE BOUNDARY, NSIDE HAS BEEN SET TO 999 SO THAT THE PACKING C C = INTEGER LESS THAN 1000 ( 1000 IS IPACKB VALUE) C GRID POINT IS ALSO BOUNDARY PT., GTYPE IS ITS INDEX C C = 0 C GRID POINT IS EXTERIOR FAR FROM THE BOUNDARY C C = NEGATIVE INTEGER C GRID POINT IS EXTERIOR NEXT TO THE BOUNDARY, ITS LOCATION C RELATIVE TO THE BOUNDARY IS ENCODED AS FOR INTERIOR POINTS C NEAR THE BOUNDARY C C - BOUNDARY SPECIFICATION - C C NBNDPT = NUMBER OF BOUNDARY POINTS ACTUALLY FOUND C XBOUND(I),YBOUND(I) = COORDINATES OF I-TH BOUNDARY POINT C BPARAM(I) = PARAMETER VALUE OF I-TH BOUNDARY POINT C PIECE(I) = INDEX OF BOUNDARY PIECE TO WHICH PT. BELONGS C SMALLEST NUMBER FOR CORNER POINTS C BPTYPE(I) = TYPE OF BOUNDARY POINT C = HORZ,VERT,BOTH,INTE,CORN OR JUMP C BNEIGH(I) = POINTER TO THE INTERIOR POINTS FROM THE I-TH C BOUNDARY POINT. SAME SCHEME IS USED TO ENCODE C DIRECTIONS AS FOR THE J PART OF GTYPE ABOVE C BGRID(I) = IX + IPACKB*JY WHEN PT. I IS IN GRID SQUARE IX,JY C C NBDIM = ACTUAL DIMENSION OF ABOVE ARRAYS C C EPSGRD = ACCURACY OF BOUNDARY POINTS C C C 2) PROBLEM SPECIFICATION C C USER SUPPLIED FORTRAN FUNCTIONS C C REAL FUNCTION PDERHS(X,Y) C C PDERHS = RIGHT SIDE OF DIFFERENTIAL EQUATION C C RETURN C END C C REAL FUNCTION BCOND(I,X,Y,BVALUS) C C VALUES OF BOUNDARY CONDITION COEFFICIENTS AND C RIGHT SIDE ON PIECE I AT (X,Y) C C REAL BVALUS(4) C GO TO(101,102,. . .) , I C 101 BVALUS(1) = COEFFICIENT OF U C BVALUS(2) = COEFFICIENT OF UX C BVALUS(3) = COEFFICIENT OF UY C BVALUS(4) = RIGHT SIDE C BCOND = BVALUS(4) C RETURN C 102 BVALUS(1) = COEFFICIENT OF U C BVALUS(2) = COEFFICIENT OF UX C BVALUS(3) = COEFFICIENT OF UY C BVALUS(4) = RIGHT SIDE C BCOND = BVALUS(4) C RETURN C . C . C . C END C C SUBROUTINE PDE(X,Y,CVALUS) C C P.D.E. COEFFICIENTS AT (X,Y) C C REAL CVALUS(6) C CVALUS(1) = COEFFICIENT OF UXX C CVALUS(2) = COEFFICIENT OF UXY C CVALUS(3) = COEFFICIENT OF UYY C CVALUS(4) = COEFFICIENT OF UX C CVALUS(5) = COEFFICIENT OF UY C CVALUS(6) = COEFFICIENT OF U C RETURN C END C C C 3) GRID SPECIFICATION C C AX,BX LEFT AND RIGHT ENDPOINTS OF X-INTERVAL C C AY,BY BOTTOM AND TOP ENDPOINTS OF Y-INTERVAL C C NGRIDX,NGRIDY NUMBER OF X AND Y GRID LINES C C GRIDX, GRIDY VECTORS CONTAINING VALUES FOR C X AND Y GRID LINES C C NGRDXD,NGRDYD ACTUAL DIMENSIONS OF GRIDX, GRIDY AND GTYPE C NGRDXD >= NGRIDX C NGRDYD >= NGRIDY C C 4) CONTROL OPTIONS C C LEVEL OUTPUT LEVEL C C 0 FATAL ERROR MESSAGES C C 1 0 PLUS GREETINGS AND INPUT VALUES C C 2 SAME AS 1 C C 3 2 PLUS INFORMATION ON WHICH BOUNDARY POINTS C ARE THE ENTRY AND EXIT OF EACH ELEMENT C AND THE COORDINATES OF COLLOCATION POINTS C C 4 3 PLUS THE GENERATED EQUATIONS C C BCP1,BCP2 PLACEMENT OF 2 BOUNDARY COLLOCATION POINTS C IN THE INTERVAL (0,1) C 0<= BCP1 < BCP2 <1 C BCP1=0 AND BCP2=0 GIVES GAUSS POINTS C C DSCARE FRACTION OF AREA OF AN ELEMENT PARTIALLY C INTERIOR TO DOMAIN TO KEEP IT C 0 <= DSCARE < 1 C IF (AREA OF ELEMENT INSIDE DOMAIN)/(AREA OF C ELEMENT) <= DSCARE THEN ELEMENT IS C DISCARDED C C PLOTIT TRUE - MAKE A PLOT OF THE DOMAIN, GRID, C AND COLLOCATION POINTS C IF LEVEL >=3 ALSO PLOT THE IMAGE OF A C 10 X 10 GRID UNDER THE MAPPING USED C FOR INTERIOR COLLOCATION POINTS C FALSE - DONT MAKE A PLOT C C **** NOTE - PLOTTING REQUIRES CALCOMP OR CALCOMP-LIKE SUBROUTINES C SEE SUBROUTINE COLPLT FOR DETAILS. C C C PTSIZE SIZE OF PLOT IN INCHES C C GIVOPT 1 - GIVE BOUNDARY OF DISCARDED ELEMENTS C TO NEIGHBORING ELEMENTS C 2 - DONT USE BOUNDARY OF DISCARDED ELEMENTS C C USECRN TRUE - FORCE BOUNDARY COLLOCATION POINTS AT C CORNERS OF DOMAIN BY SHIFTING THE C LAST POINT BEFORE THE CORNER TO THE C CORNER C FALSE - DONT C C 5) OUTPUT CONTROL C C NOUT NUMBER OF OUTPUTS TO PERFORM C C OUTFNC(I) WHAT FUNCTION TO USE FOR THE ITH OUTPUT C =1 APPROXIMATE SOLUTION C =2 ERROR = U - TRUE (TRUE MUST BE SUPPLIED) C =3 RESIDUAL = LU - F C C OUTTYP(I) WHAT INFORMATION IS TO BE PRINTED C IN THE OUTPUT C =1 MAX, L1, L2 NORMS BASED ON C DISCRETIZATION GRID C =2 MAX, L1, L2 NORMS BASED ON C USER SUPPLIED GRID (TABX,TABY) C =3 TABLE OF FUNCTION ON DISC. GRID C =4 TABLE OF FUNCTION ON USER SUPPLIED GRID C C TABX,TABY X AND Y COORDINATES OF GRID FOR OUTTYP 2 AND 4 C C NTABX,NTABY NUMBER OF VALUES IN TABX,TABY C C C 6) MISC INPUTS C C COEF ARRAY TO CONTAIN COEFFICENTS AND RIGHT C SIDES OF COLLOCATION EQUATIONS C C IDCOEF ARRAY TO CONTAIN THE COLUMN INDICES C FOR COEF C C MXNEQ,MXNCOE ACTUAL DIMENSIONS OF COEF AND IDCOEF C MXNCOE >= 17 C MXNEQ >= NUMBER OF EQUATIONS C C THE NUMBER OF EQUATIONS DEPENDS OF THE GRID C AND THE SHAPE OF THE DOMAIN C IT WILL BE PRINTED, SO ARRAY SIZES CAN BE C REDUCED ON SUBSEQUENT USES OF THE SAME C DOMAIN AND GRID C C NUMB. OF EQ. <= 4*(NGRIDX-1)*(NGRIDY-1) C C WRKSP WORKSPACE OF DIMENSION >= MAXIMUM OF C A) (NGRIDX-1)X(NGRIDY-1) C B) NTABX C C) 2+(12*NGRIDY + 23)*(NUMBER OF EQUATIONS) C C MOUTPT UNIT NUMBER FOR PRINTED OUTPUT C C NODELM USED FOR RELATING NODE NUMBERS TO ELEMENTS. C DIMENSION MXNEQ. NEED NOT BE ASSIGNED C VALUES BY THE USER. C C --- COMMON BLOCKS FOR INPUT C C COMMON / XBOUZZ / XBOUND(NBDIM) C COMMON / YBOUZZ / YBOUND(NBDIM) C COMMON / BPARZZ / BPARAM(NBDIM) C COMMON / PIECZZ / PIECE (NBDIM) C COMMON / BPTYZZ / BPTYPE(NBDIM) C COMMON / BNEIZZ / BNEIGH(NBDIM) C COMMON / BGRIZZ / BGRID (NBDIM) C COMMON / GRIDXZ / GRIDX (NGRDXD) C COMMON / GRIDYZ / GRIDY (NGRDYD) C COMMON / BRANZZ / BRANGE(2,NPDIM) C COMMON / COLOPT / BCP1 , BCP2 , DSCARE , PTSIZE , C A GIVOPT , PLOTIT , USECRN C COMMON / COLNUM / NODELM(MXNEQ) C C --- DIMENSION OF ARRAYS INPUT AS PARAMETERS C C INTEGER GTYPE (NGRDXD,NGRDYD) C REAL COEF (MXNEQ,MXNCOE) C INTEGER IDCOEF(MXNEQ,MXNCOE) C REAL UNKVCT(MXNEQ) C REAL WRKSP ( SEE ABOVE ) C INTEGER OUTFNC(NOUT) C INTEGER OUTTYP(NOUT) C REAL TABX (NTABX) C REAL TABY (NTABY) C C C C C DECLARATIONS C REAL COEF(MXNEQ,MXNCOE),UNKVCT(MXNEQ),WRKSP(*),TABX(NTABX), . TABY(NTABY) C INTEGER GTYPE(NGRDXD,NGRDYD),IDCOEF(MXNEQ,MXNCOE),OUTFNC(NOUT), . OUTTYP(NOUT),PIECE,BPTYPE,BNEIGH,BGRID,GIVOPT C LOGICAL USECRN,DOMFLG,RECTAN,SCLOCK,SARC,FAIL,FATAL C EXTERNAL BCOORD C COMMON /COLOPT/BCP1,BCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /PROBR/AXQ,BXQ,AYQ,BYQ COMMON /PROBI/NGRIQX,NGRIQY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVELQ,MOUTPQ COMMON /BNDRY/IPIECE,NBOUNQ,NBNDPQ COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRQ COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) C CHARACTER *4 IHORZ,IVERT,IBOTH,IINTE,IJUMP,ICORN,HORZ,VERT,BOTH, . INTER,JUMP DATA IHORZ,IVERT,IBOTH,IINTE,IJUMP/'HORZ','VERT','BOTH','INTE', . 'JUMP'/ C C COPY PARAMETERS TO COMMONS C HORZ = IHORZ VERT = IVERT BOTH = IBOTH INTER = IINTE JUMP = IJUMP NBOUNQ = NBOUND NBNDPQ = NBNDPT AXQ = AX BXQ = BX AYQ = AY BYQ = BY NGRIQX = NGRIDX NGRIQY = NGRIDY LEVELQ = LEVEL MOUTPQ = MOUTPT SCLOCK = .TRUE. SARC = .FALSE. FATAL =.FALSE. C C CALL THE DOMAIN PROCESSOR, IF DESIRED C IF ( .NOT. DOMFLG) GO TO 10 CALL REGION(GRIDX,GRIDY,NGRIDX,NGRIDY,BRANGE,NPDIM,BCOORD,SCLOCK, . SARC,LEVEL,GTYPE,XBOUND,YBOUND,PIECE,BPTYPE,BNEIGH, . BGRID,BPARAM,NBDIM,NBPTS,FAIL) NBNDPT = NBPTS NBNDPQ = NBPTS 10 CONTINUE C C CALL THE DISCRETIZATION MODULE C TO SET THE COLLOCATION EQUATIONS C NGDXM1 = NGRIDX - 1 NGDYM1 = NGRIDY - 1 C CALL P3C1CG(COEF,IDCOEF,MXNEQ,MXNCOE,GTYPE,NGRDXD,NGRDYD,WRKSP, . NGDXM1,NGDYM1,NBDIM,FATAL) C C C REFORMAT LINEAR SYSTEM FOR LINEAR EQUATION SOLVERS OF C BAND MATRIX FORM WITH BANDWIDTH 2*NGRIDY+4 C LDA = 12*NGRIDY + 22 C C C NBANDU = 0 NBANDL = 0 CALL SETUP(COEF,IDCOEF,MXNEQ,MXNCOE,NUMBEQ,NUMCOE,WRKSP,LDA, . UNKVCT,NBANDU,NBANDL) C C C SOLVE LINEAR SYSTEM OF COLLOCATION EQUATIONS BY C GAUSS ELIMINATION WITH SCALLING C IBLOK2 = 2 + LDA*NUMBEQ C CALL SOLVE(WRKSP,LDA,NUMBEQ,UNKVCT,WRKSP(IBLOK2),NBANDU,NBANDL) IF (LEVEL.LT.3) GO TO 20 WRITE (MOUTPT,9001) WRITE (MOUTPT,9011) (UNKVCT(I),I=1,NUMBEQ) C C GENERATE OUTPUT C 20 RECTAN = .FALSE. C DO 30 I = 1,NOUT C CALL OUTPUT(OUTFNC(I),OUTTYP(I),TABX,NTABX,TABY,NTABY,WRKSP, . GTYPE,NGRDXD,NGRDYD,UNKVCT,RECTAN) C 30 CONTINUE C RETURN 9001 FORMAT (/16H SOLUTION VECTOR/) 9011 FORMAT (1X,4E15.6) END SUBROUTINE BASE(B1,B2,B3,B4,Z,H) C C C PURPOSE C C DEFINE THE CUBIC HERMITE POLYNOMIALS C C PARAMETERS C C INPUT C Z - DIFFERENCE BETWEEN THE POINT WHERE THE POLYNOMIALS C ARE TO BE EVALUATED AND THE LOWER ENDPOINT OF THE C INTERVAL THE POINT IS CONTAINED IN C H - LENGTH OF INTERVAL C C OUTPUT C B1,B2,B3,B4 - VALUES OF THE FOUR POLYNOMIALS C C S = Z/H T = 1. - S B1 = S*S* (2.*S-3.) + 1. B2 = 1. - B1 B3 = S*T* (H-Z) B4 = -S*T*Z RETURN END SUBROUTINE BCP(NBCP,X,Y,IX,JY,ICODE,ELTYPE,NGDXM1,NGDYM1,T,IPIEC, . SCAL,FATAL) C C C PURPOSE C C ASSIGN BOUNDARY COLLOCATION POINTS (BCP) TO ELEMENT (IX,JY) C C PARAMETERS C C INPUT C IX,JY - ELEMENT INDICIES C IENT,IEXT - INDICIES OF POINTS WHERE BOUNDARY ENTERS C AND EXITS THIS ELEMENT C ICODE = 0 - GENERATE BCP FOR ELEMENT IX,JY C = 1 - FIND MIDPOINT OF BOUNDARY SEGMENT C C OUTPUT C NBCP - NUMBER OF BOUNDARY COLLOCATION POINTS C X,Y - COORDINATES OF BCPS C IPIEC - PIECES BCPS ARE ON C T - PARAMETER OF LAST BCP C ICODE - IF ICODE=0 ON INPUT THEN ICODE IS C SET TO INDICATE WHICH SIDES OF THE C ELEMENT ARE BOUNDARY C C METHOD C C STEP 1 - C PLACE COLLOCATION POINTS ON THE BOUNDARY SIDES OF THE C RECTANGULAR ELEMENT. BOUNDARY SIDES ARE THE SIDES WHICH C ARE NOT SHARED WITH ANOTHER ELEMENT. C PLACE TWO BCP ON EACH BOUNDARY SIDE OF THE ELEMENT AND ONE C BCP AT EACH CORNER BETWEEN BOUNDARY SIDES. IF THE CORNER C AFTER THE LAST BOUNDARY SIDE IS CONCAVE, REMOVE THE LAST C BCP AND SHIFT THE NEXT TO THE LAST BCP TO MIDWAY BETWEEN C THE LAST TWO BCPS. IF THE CORNER BEFORE THE FIRST BOUNDARY C SIDE IS CONCAVE, SHIFT TE FIRST BCP TO THE CORNER AND THE C SECOND BCP TO MIDWAY BETWEEN THE FIRST AND SECOND BCPS. C C THIS PLACEMENT IS REPRESENTED BY VALUES FROM (0,1) WITH C 0 AND 1 CORRESPONDING TO THE CORNERS BEFORE THE FIRST C BOUNDARY SIDE AND AFTER THE LAST BOUNDARY SIDE, RESPECTIVELY. C C PLACEMENT OF THE TWO POINTS ON A SIDE IS CONTROLLED BY C THE PARAMETERS WTBCP1 AND WTBCP2. THEY ARE PLACED ON THE C SIDE AS WTBCP1 AND WTBCP2 ARE PLACED IN (0,1) C C STEP 2 - C MAP THE BOUNDARY OF THE ELEMENT TO THE BOUNDARY C OF THE DOMAIN AS FOLLOWS: C C IF THE DOMAIN BOUNDARY IN THIS ELEMENT IS ALL IN ONE PIECE, C THEN MININUM AND MAXIMUM PARAMETERS FOR THE PART OF THAT PIECE C ARE DETERMINED AND THE BCP ARE DISTRIBUTED BETWEEN THOSE C PARAMETERS. C C IF THE DOMAIN BOUNDARY IN THIS ELEMENT USES TWO PIECES, THE C MINIMUM PARAMETER FOR THE FIRST PIECE IS DETERMINED AND THE C MAXIMUM PARAMETER FOR THE SECOND PIECE IS DETERMINED. THEN C BCPARMS IN (0,.5) ARE MAPPED TO THE FIRST PIECE, AND BCPARMS C IN (.5,1) ARE MAPPED TO THE SECOND PIECE C C IF THE BOUNDARY IN THIS ELEMENT USES MORE THAN TWO PIECES, C IT IS AN ERROR C C BCPS THAT ARE AT THE CONNECTION OF TWO PIECES ARE CONSIDERED C TO BE ON THE PIECE WITH DIRICHLET CONDITIONS, IF ONE EXISTS C C REAL X(8),Y(8),MIN1,MAX1,MIN2,MAX2,BVALS(4),BCPPAR(8) C INTEGER JPTS(10),PIECE1,PIECE2,IPIEC(8),PIECEN, . ELTYPE(NGDXM1,NGDYM1),PTCNT C LOGICAL CLOCKW,FATAL,TWOPEC C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BPTYPE,BNEIGH,BGRID,PIECE REAL LO,LOA LOGICAL PLOTIT,USECRN CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C IF ICODE=1, THEN JUST COMPUTE THE MIDPOINT OF THE DOMAIN C BOUNDARY WITHIN THIS ELEMENT C IF (ICODE.NE.1) GO TO 10 NBCP = 1 BCPPAR(1) = .5 GO TO 250 C C C --- DETERMINE WHICH SIDES OF THIS ELEMENT ARE BOUNDARY --- C C INCLUDE ALL SIDES WHICH ARE NOT SHARED BY ANOTHER ELEMENT. C THE ITH BIT OF ICODE IS SET TO 1 IFF THE ITH SIDE IS A C BOUNDARY SIDE, WHERE THE SIDES ARE NUMBERED C 1-BOTTOM, 2-RIGHT, 3-TOP, 4-LEFT C C CHECK BOTTOM SIDE C 10 IF (JY.EQ.1) GO TO 20 IF (ELTYPE(IX,JY-1).GE.0) GO TO 30 20 ICODE = ICODE + 1 C C CHECK RIGHT SIDE C 30 IF (IX.EQ.NGDXM1) GO TO 40 IF (ELTYPE(IX+1,JY).GE.0) GO TO 50 40 ICODE = ICODE + 2 C C CHECK TOP SIDE C 50 IF (JY.EQ.NGDYM1) GO TO 60 IF (ELTYPE(IX,JY+1).GE.0) GO TO 70 60 ICODE = ICODE + 4 C C CHECK LEFT SIDE C 70 IF (IX.EQ.1) GO TO 80 IF (ELTYPE(IX-1,JY).GE.0) GO TO 90 80 ICODE = ICODE + 8 C C C IF ICODE=0 THIS ELEMENT IS INTERIOR C C 90 NBCP = 0 IF (ICODE.EQ.0) RETURN C C C --- DETERMINE PLACEMENT OF BCP ON SIDES OF ELEMENT --- C C C PLACE TWO BCP ON EACH BOUNDARY SIDE C AND ONE AT EACH CORNER BETWEEN BOUNDARY SIDES C GO TO (100,100,110,100,420,110,120,100,110, . 420,120,110,120,120,420),ICODE C C ONE BOUNDARY SIDE C 100 NBCP = 2 BCPPAR(1) = WTBCP1 BCPPAR(2) = WTBCP2 GO TO 130 C C TWO BOUNDARY SIDES C 110 NBCP = 5 B1 = WTBCP1/2. B2 = WTBCP2/2. BCPPAR(1) = B1 BCPPAR(2) = B2 BCPPAR(3) = .5 BCPPAR(4) = .5 + B1 BCPPAR(5) = .5 + B2 IF (B1.NE.0. .OR. B2.NE..25) GO TO 130 BCPPAR(4) = .5 + THIRD/2. BCPPAR(5) = .5 + THIRD GO TO 130 C C THREE BOUNDARY SIDES C 120 NBCP = 8 B1 = WTBCP1/3. B2 = WTBCP2/3. BCPPAR(1) = B1 BCPPAR(2) = B2 BCPPAR(3) = THIRD BCPPAR(4) = THIRD + B1 BCPPAR(5) = THIRD + B2 BCPPAR(6) = TWOTHR BCPPAR(7) = TWOTHR + B1 BCPPAR(8) = TWOTHR + B2 IF (B1.NE.0. .OR. B2.NE.THIRD/2.) GO TO 130 BCPPAR(2) = THIRD*THIRD BCPPAR(3) = TWOTHR*THIRD BCPPAR(7) = TWOTHR + THIRD*THIRD BCPPAR(8) = TWOTHR + TWOTHR*THIRD C C END OF CASES FOR ASSIGNING DEFAULT PARAMETERS C 130 ITEMP = 0 C C CHECH TO SEE IF THE LAST CORNER IS CONCAVE C GO TO (150,140,150,170,420,140,150,160,160, . 420,160,170,170,140,420),ICODE 140 IF (IX.NE.NGRIDX-1 .AND. JY.NE.1) ITEMP = ELTYPE(IX+1,JY-1) GO TO 180 150 IF (IX.NE.1 .AND. JY.NE.1) ITEMP = ELTYPE(IX-1,JY-1) GO TO 180 160 IF (IX.NE.1 .AND. JY.NE.NGRIDY-1) ITEMP = ELTYPE(IX-1,JY+1) GO TO 180 170 IF (IX.NE.NGRIDX-1 .AND. JY.NE.NGRIDY-1) ITEMP = ELTYPE(IX+1,JY+1) C C END OF CASES FOR CHECKING CONCAVITY C C IF ITEMP IS NONNEGATIVE, THEN THE CORNER IS CONCAVE C 180 IF (ITEMP.LE.0) GO TO 190 C C REMOVE LAST BCP AND SHIFT NEXT TO LAST BCP C NBCP = NBCP - 1 IF (WTBCP1.EQ.0. .AND. WTBCP2.EQ..5 .AND. NBCP.EQ.1) GO TO 250 BCPPAR(NBCP) = (BCPPAR(NBCP)+BCPPAR(NBCP+1))/2. 190 IF (WTBCP1.EQ.0. .AND. WTBCP2.EQ..5) GO TO 250 ITEMP = 0 C C CHECK TO SEE IF THE FIRST CORNER IS CONCAVE C GO TO (200,230,230,220,420,220,220,210,200, . 420,230,210,200,210,420),ICODE 200 IF (IX.NE.NGRIDX-1 .AND. JY.NE.1) ITEMP = ELTYPE(IX+1,JY-1) GO TO 240 210 IF (IX.NE.1 .AND. JY.NE.1) ITEMP = ELTYPE(IX-1,JY-1) GO TO 240 220 IF (IX.NE.1 .AND. JY.NE.NGRIDY-1) ITEMP = ELTYPE(IX-1,JY+1) GO TO 240 230 IF (IX.NE.NGRIDX-1 .AND. JY.NE.NGRIDY-1) ITEMP = ELTYPE(IX+1,JY+1) C C END OF CASES FOR CHECKING CONCAVITY C C C IF ITEMP IS NONNEGATIVE, THEN THE CORNER IS CONCAVE C 240 IF (ITEMP.LE.0) GO TO 250 C C SHIFT FIRST TWO BCPS C BCPPAR(2) = (BCPPAR(1)+BCPPAR(2))/2. BCPPAR(1) = 0. C C C --- MAP BOUNDARY OF ELEMENT TO BOUNDARY OF DOMAIN --- C C 250 NPTS = 0 C C FIND INDICES OF ENTRY AND EXIT POINTS C IEXT = ELTYPE(IX,JY)/1000 IENT = ELTYPE(IX,JY) - 1000*IEXT IPTS = IENT JEXT = IEXT C C IF THE ENTRY POINT IS ONE THAT WAS ADDED WHILE GIVING AWAY BOUNDARY C FROM A DISCARDED ELEMENT, FIND THE REAL ENTRY POINT C IF (IENT.LE.NBNDPT) GO TO 260 JPTS(1) = IENT NPTS = 1 IXX = BGRID(IENT) JYY = BNEIGH(IENT) IPTS = -ELTYPE(IXX,JYY)/1000 C C IF THE EXIT POINT IS ONE THAT WAS ADDED WHILE GIVING AWAY BOUNDARY C FROM A DISCARDED ELEMENT, FIND THE REAL EXIT POINT C 260 IF (IEXT.LE.NBNDPT) GO TO 270 IXX = BGRID(IEXT) JYY = BNEIGH(IEXT) JEXT = -ELTYPE(IXX,JYY) + 1000* (ELTYPE(IXX,JYY)/1000) C C PUT A LIST OF ALL BOUNDARY POINTS BETWEEN IENT AND IEXT INTO THE C VECTOR JPTS C 270 IF (JEXT.EQ.1) JEXT = NBNDPT + 1 NPTS = NPTS + 1 JPTS(NPTS) = IPTS IPTS = IPTS + 1 IF (IPTS.GT.NBNDPT+1) IPTS = 1 IF (IPTS.NE.JEXT) GO TO 270 NPTS = NPTS + 1 JPTS(NPTS) = JEXT IF (JEXT.EQ.IEXT .OR. (JEXT.EQ.NBNDPT+1.AND.IEXT.EQ. . 1)) GO TO 280 NPTS = NPTS + 1 JPTS(NPTS) = IEXT C C INDICATE THAT THERE IS ONLY ONE BOUNDARY PIECE, FIND THE BOUNDARY C PIECE, AND THE MINIMUM PARAMETER IN THIS ELEMENT FOR THAT PIECE C 280 TWOPEC = .FALSE. ISUB = JPTS(1) PIECE1 = PIECE(ISUB) MIN1 = BPARAM(ISUB) PTCNT = 2 C C IF THE FIRST POINT IS AT THE JOINING OF TWO PIECES, CONSIDER IT C TO BE ON THE SECOND C ISUB = JPTS(1) JSUB = JPTS(2) IF (PIECE(ISUB).EQ.PIECE(JSUB) .OR. ABS(MIN1-BRANGE(2,PIECE1)).GT. . EPSGRD) GO TO 290 PIECE1 = PIECE1 + 1 IF (PIECE1.GT.NBOUND) PIECE1 = 1 MIN1 = BRANGE(1,PIECE1) C C PASS THROUGH THE POINTS LOOKING FOR A CHANGE IN PIECE. C THE SECOND CONDITION CHECKS FOR PASSING OVER THE JOIN WHEN C THERE IS ONLY ONE BOUNDARY PIECE C 290 ISUB = JPTS(PTCNT) IF ((PIECE(ISUB).NE.PIECE1) .OR. . (NBOUND.EQ.1.AND.BPARAM(ISUB).LT.MIN1)) GO TO 300 PTCNT = PTCNT + 1 IF (PTCNT.LE.NPTS) GO TO 290 C C THERE WAS ONLY ONE PIECE C SET THE MAXIMUM PARAMETER AND GO FIND THE BCPS C ISUB = JPTS(NPTS) MAX1 = BPARAM(ISUB) GO TO 310 C C FOUND A SECOND PIECE C SET THE MAXIMUM PARAMETER FOR THE FIRST PIECE C 300 MAX1 = BRANGE(2,PIECE1) TWOPEC = .TRUE. C C FIND THE SECOND PIECE AND ITS MINIMUM PARAMETER C ISUB = JPTS(PTCNT) PIECE2 = PIECE(ISUB) MIN2 = BRANGE(1,PIECE2) ISUB = JPTS(NPTS) PIECEN = PIECE(ISUB) C C SEE IF THE LAST POINT IS ON THE SECOND PIECE. C IT IS IF THE PIECE NUMBERS ARE THE SAME, OR ITS ON THE NEXT PIECE AND C ITS PARAMETER IS THE MINIMUM PARAMETER FOR THAT PIECE C IF ITS NOT ON THE SECOND PIECE, ITS AN ERROR C ISUB = JPTS(NPTS) IF ((PIECEN.NE.PIECE2) .AND. (((PIECEN.NE.PIECE2+1).AND. . (PIECEN.NE.1.OR.PIECE2.NE.NBOUND)).OR. (BPARAM(ISUB).NE. . BRANGE(2,PIECEN)))) GO TO 410 C C FIND MAXIMUM PARAMETER FOR SECOND PIECE C MAX2 = BPARAM(ISUB) IF (PIECEN.NE.PIECE2) MAX2 = BRANGE(2,PIECE2) C C C --- COMPUTE BOUNDARY COLLOCATION POINTS --- C C 310 IF (TWOPEC) GO TO 330 C C -ONE PIECE CASE- C IPIECE = PIECE1 DIFF1 = MAX1 - MIN1 DO 320 I = 1,NBCP T = MIN1 + BCPPAR(I)*DIFF1 CALL BCOORD(T,X(I),Y(I),IPIECE) IPIEC(I) = PIECE1 320 CONTINUE GO TO 370 C C -TWO PIECE CASE- C 330 TCUT = .5 IF (ICODE.NE.7 .AND. ICODE.NE.11 .AND. ICODE.NE.13 .AND. ICODE.NE. . 14) GO TO 340 C C IF THE ELEMENT HAS THREE BOUNDARY SIDES, DETERMINE IF C PARAMETER .5 SHOULD BE MAPPED TO THE FIRST CORNER (TCUT=1/3) C OR TO THE SECOND CORNER (TCUT=2/3) C IPIECE = PIECE1 CALL BCOORD(MIN1,X1,Y1,IPIECE) CALL BCOORD(MAX1,X2,Y2,IPIECE) IPIECE = PIECE2 CALL BCOORD(MAX2,X3,Y3,IPIECE) XD1 = X2 - X1 XD2 = X3 - X2 YD1 = Y2 - Y1 YD2 = Y3 - Y2 TCUT = THIRD IF (SQRT(XD1*XD1+YD1*YD1).GT.SQRT(XD2*XD2+YD2*YD2)) TCUT = TWOTHR 340 DIFF1 = MAX1 - MIN1 DIFF2 = MAX2 - MIN2 C C COMPUTE BCPS C LAST = 0 DO 360 I = 1,NBCP T = BCPPAR(I) IF (T.GE.TCUT) GO TO 350 IPIECE = PIECE1 T = MIN1 + T*DIFF1/TCUT CALL BCOORD(T,X(I),Y(I),IPIECE) IPIEC(I) = PIECE1 LAST = I GO TO 360 350 IPIECE = PIECE2 T = MIN2 + (T-TCUT)*DIFF2/ (1.-TCUT) CALL BCOORD(T,X(I),Y(I),IPIECE) IPIEC(I) = PIECE2 IF (T.NE.MIN2) GO TO 360 C C IF THIS BCP IS AT THE JOIN OF THE TWO PIECES, C TRY TO FIND ONE WITH DIRICHLET CONDITIONS C BVALS(4) = BCOND(PIECE2,X(I),Y(I),BVALS) IF (BVALS(2).NE.0. .OR. BVALS(3).NE.0.) IPIEC(I) = PIECE1 C 360 CONTINUE C C IF USE CORNER OPTION IS ON (USECRN=.TRUE.) THEN PUT THE C LAST POINT FROM THE FIRST PIECE AT THE JOIN C IF ((.NOT.USECRN) .OR. BCPPAR(LAST+1).EQ..5 .OR. LAST.EQ. . 0) GO TO 370 T = BRANGE(2,PIECE1) IPIECE = PIECE1 CALL BCOORD(T,X(LAST),Y(LAST),IPIECE) BVALS(4) = BCOND(PIECE1,X(LAST),Y(LAST),BVALS) IF (BVALS(2).NE.0. .OR. BVALS(3).NE.0.) IPIEC(LAST) = PIECE2 C C C CHECK THE FIRST AND LAST POINTS FOR DIRICHLET CONDITIONS C C 370 IF (MIN1.NE.BRANGE(1,PIECE1) .OR. BCPPAR(1).NE.0.) GO TO 380 C C FIRST POINT IS AT A JOIN C BVALS(4) = BCOND(PIECE1,X(1),Y(1),BVALS) IF (BVALS(2).NE.0. .OR. BVALS(3).NE.0.) IPIEC(1) = IPIEC(1) - 1 IF (IPIEC(1).LE.0) IPIEC(1) = NBOUND C CHECK LAST POINT 380 IF (TWOPEC) GO TO 390 C ONE PIECE CASE IF (MAX1.NE.BRANGE(2,PIECE1) .OR. BCPPAR(NBCP).NE.1.) GO TO 400 C C LAST POINT IS AT A JOIN C BVALS(4) = BCOND(PIECE1,X(NBCP),Y(NBCP),BVALS) IF (BVALS(2).NE.0. .OR. BVALS(3).NE. . 0.) IPIEC(NBCP) = IPIEC(NBCP) + 1 IF (IPIEC(NBCP).GT.NBOUND) IPIEC(NBCP) = 1 GO TO 400 C TWO PIECE CASE 390 IF (MAX2.NE.BRANGE(2,PIECE2) .OR. BCPPAR(NBCP).NE.1.) GO TO 400 C C LAST POINT IS AT A JOIN C BVALS(4) = BCOND(PIECE2,X(NBCP),Y(NBCP),BVALS) IF (BVALS(2).NE.0. .OR. BVALS(3).NE. . 0.) IPIEC(NBCP) = IPIEC(NBCP) + 1 IF (IPIEC(NBCP).GT.NBOUND) IPIEC(NBCP) = 1 C C C IF PLOTTING OPTION IS ON, PLOT BOUNDARY COLLOCATION POINTS C 400 IF (NBCP.EQ.1) RETURN IF (PLOTIT) CALL COLPLT(SCAL,X,Y,NBCP,2) C C IF OUTPUT LEVEL IS HIGH ENOUGH, PRINT BOUNDARY COLLOCATION POINTS C IF (LEVEL.LT.3) RETURN WRITE (MOUTPT,9001) IX,JY WRITE (MOUTPT,9011) (X(I),Y(I),I=1,NBCP) RETURN C C ---ERROR--- TOO MANY PIECES OF THE BOUNDARY INVOLVED C WITH THIS ELEMENT C 410 WRITE (MOUTPT,9021) IX,JY FATAL = .TRUE. RETURN C C ---ERROR--- BAD COMBINATION OF BOUNDARY SIDES C 420 WRITE (MOUTPT,9031) IX,JY FATAL = .TRUE. RETURN 9001 FORMAT (40H0BOUNDARY COLLOCATION POINTS FOR ELEMENT,2I4) 9011 FORMAT (10X,2F10.4) 9021 FORMAT (/24H ***** FATAL ERROR *****/ . 42H TOO MANY PIECES OF BOUNDARY IN ELEMENT, . 2I5/49H DISCOVERED WHILE PLACING BCPS IN THAT ELEMENT) 9031 FORMAT (/24H ***** FATAL ERROR *****/11H ELEMENT,2I5, . 26H HAS ALL SIDES BOUNDARY OR/ . 34H TWO NONADJACENT SIDES BOUNDARY/ . 49H DISCOVERED WHILE PLACING BCPS IN THAT ELEMENT) END SUBROUTINE BNDEQ(NROW,X,Y,HX,HY,IX,JY,NBCP,IPIEC,COEF,MXNEQ, . MXNCOE) C C C PURPOSE C C COMPUTE BOUNDARY COLLOCATION EQUATIONS FOR ELEMENT IX,JY C C PARAMETERS C C IX,JY - INDICIES OF ELEMENT C HX,HY - SIZE OF ELEMENT C NROW - LAST ROW ADDED TO MATRIX C X,Y - BOUNDARY COLLOCATION POINTS C NBCP - NUMBER OF BOUNDARY COLLOCATION POINTS C IPIEC - BOUNDARY PIECE EACH BCP IS ON C COEF - COEFFICIENT MATRIX C MXNEQ,MXNCOE - DIMENSIONS OF COEF C C REAL X(8),Y(8),COEF(MXNEQ,MXNCOE),BVALUS(4) INTEGER IPIEC(8) C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BPTYPE,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C C C COMPUTE SCALING FACTOR FOR THIS ELEMENT SO THAT BOUNDARY C EQUATIONS HAVE THE SAME ORDER OF MAGNITUDE AS THE C INTERIOR EQUATIONS C RHXHY = (1.+HY)* (1.+1./HX)/HX + (1.+HX)* (1.+1./HY)/HY C C LOOP THROUGH BCPS AND COMPUTE EQUATIONS C DO 10 I = 1,NBCP NROW = NROW + 1 C C COMPUTE VALUES OF BASIS FUNCTIONS AT THE ITH BCP C T = X(I) - GRIDX(IX) S = Y(I) - GRIDY(JY) CALL BASE(BX1,BX2,BX3,BX4,T,HX) CALL BASE(BY1,BY2,BY3,BY4,S,HY) CALL DBASE(DBX1,DBX2,DBX3,DBX4,T,HX) CALL DBASE(DBY1,DBY2,DBY3,DBY4,S,HY) C C GET COEFFICIENTS AND RIGHT SIDE OF BOUNDARY CONDITION C BVALUS(4) = BCOND(IPIEC(I),X(I),Y(I),BVALUS) C C CORRECT SCALING FACTOR IN CASE OF NON-DIRICHLET CONDITIONS C SCALE = RHXHY IF (BVALUS(2).NE.0.) SCALE = SCALE*HX IF (BVALUS(3).NE.0.) SCALE = SCALE*HY C C TEMPORARY VARIABLES C BCOEF1 = BVALUS(1)*SCALE BCOEF2 = BVALUS(2)*SCALE BCOEF3 = BVALUS(3)*SCALE BDUMY1 = BCOEF1*BY1 + BCOEF3*DBY1 BDUMY2 = BCOEF1*BY2 + BCOEF3*DBY2 BDUMY3 = BCOEF1*BY3 + BCOEF3*DBY3 BDUMY4 = BCOEF1*BY4 + BCOEF3*DBY4 C C COMPUTE NONZERO COEFFICIENTS C COEF(NROW,1) = BX1*BDUMY1 + BCOEF2*DBX1*BY1 COEF(NROW,2) = BX1*BDUMY3 + BCOEF2*DBX1*BY3 COEF(NROW,3) = BX3*BDUMY1 + BCOEF2*DBX3*BY1 COEF(NROW,4) = BX3*BDUMY3 + BCOEF2*DBX3*BY3 COEF(NROW,5) = BX2*BDUMY1 + BCOEF2*DBX2*BY1 COEF(NROW,6) = BX2*BDUMY3 + BCOEF2*DBX2*BY3 COEF(NROW,7) = BX4*BDUMY1 + BCOEF2*DBX4*BY1 COEF(NROW,8) = BX4*BDUMY3 + BCOEF2*DBX4*BY3 COEF(NROW,9) = BX2*BDUMY2 + BCOEF2*DBX2*BY2 COEF(NROW,10) = BX2*BDUMY4 + BCOEF2*DBX2*BY4 COEF(NROW,11) = BX4*BDUMY2 + BCOEF2*DBX4*BY2 COEF(NROW,12) = BX4*BDUMY4 + BCOEF2*DBX4*BY4 COEF(NROW,13) = BX1*BDUMY2 + BCOEF2*DBX1*BY2 COEF(NROW,14) = BX1*BDUMY4 + BCOEF2*DBX1*BY4 COEF(NROW,15) = BX3*BDUMY2 + BCOEF2*DBX3*BY2 COEF(NROW,16) = BX3*BDUMY4 + BCOEF2*DBX3*BY4 C C RIGHT SIDE C COEF(NROW,MXNCOE) = BVALUS(4)*SCALE 10 CONTINUE RETURN END FUNCTION COLAPR(X,Y,UNKVCT,DERVSL,RECTAN) C C PURPOSE C C EVALUATE THE APPROXIMATE SOLUTION C AND ITS DERIVATIVES AT (X,Y) C C PARAMETERS C C X,Y - POINT AT WHICH TO EVALUATE SOLUTION C UNKVCT - SOLUTION VECTOR. CONTAINS APPROXIMATION OF C U,UX,UY AND UXY AT THE NODES C DERVSL - RETURN DERIVATIVES AND SOLUTION C DERVSL(1)=UXX C DERVSL(2)=UXY C DERVSL(3)=UYY C DERVSL(4)=UX C DERVSL(5)=UY C DERVSL(6)=U C COLAPR =U C C COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /PROBI/NGRIDX,NGRIDY COMMON /COLNUM/NODELM(4,1) C REAL UNKVCT(4,*),DERVSL(6),Q(16) INTEGER UR,UL LOGICAL RECTAN C C ZERO OUT VECTOR OF COEFFICIENT VALUES C DO 10 I = 1,16 Q(I) = 0. 10 CONTINUE C C C FIND THE ELEMENT TO WHICH (X,Y) BELONGS C I = 1 20 CONTINUE I = I + 1 IF (GRIDX(I).LT.X) GO TO 20 I = I - 1 C J = 1 30 CONTINUE J = J + 1 IF (GRIDY(J).LT.Y) GO TO 30 J = J - 1 C C COMPUTE SIZES OF ELEMENT (I,J) C DX = GRIDX(I+1) - GRIDX(I) DY = GRIDY(J+1) - GRIDY(J) C C COMPUTE ELEMENT INDICES C C C TWO CASES - RECTANGULAR AND NONRECTANGULAR C IF (RECTAN) GO TO 40 C C NONRECTANGULAR CASE C C C PULL VALUES FROM ARRAY NODELM WHICH RELATES C NODE NUMBERS TO ELEMENTS C C NOTE THAT IF THE NODE WAS NOT KEPT, USE 0 AS THE COEFFICIENT C OF THE BASIS FUNCTIONS CENTERED AT THAT NODE C II = (I-1)* (NGRIDY-1) + J LL = NODELM(1,II) LR = NODELM(2,II) UR = NODELM(3,II) UL = NODELM(4,II) GO TO 50 C C RECTANGULAR CASE C C 40 LL = J + (I-1)*NGRIDY LR = LL + NGRIDY UR = LR + 1 UL = LL + 1 C C LOCATE DEGREES OF FREEDOM ASSOCIATED WITH ELEMENT (I,J) C 50 DO 60 NDF = 1,4 IF (LL.NE.0) Q(NDF) = UNKVCT(NDF,LL) NDF1 = NDF + 4 IF (LR.NE.0) Q(NDF1) = UNKVCT(NDF,LR) NDF2 = NDF1 + 4 IF (UR.NE.0) Q(NDF2) = UNKVCT(NDF,UR) NDF3 = NDF2 + 4 IF (UL.NE.0) Q(NDF3) = UNKVCT(NDF,UL) 60 CONTINUE C C COMPUTE BASIS FUNCTIONS AT (X,Y) C XP = X - GRIDX(I) YP = Y - GRIDY(J) C CALL BASE(BX1,BX2,BX3,BX4,XP,DX) CALL BASE(BY1,BY2,BY3,BY4,YP,DY) CALL DBASE(DBX1,DBX2,DBX3,DBX4,XP,DX) CALL DBASE(DBY1,DBY2,DBY3,DBY4,YP,DY) CALL DDBASE(DDBX1,DDBX2,DDBX3,DDBX4,XP,DX) CALL DDBASE(DDBY1,DDBY2,DDBY3,DDBY4,YP,DY) C C TEMP1 = Q(1)*BX1*BY1 + Q(2)*BX1*BY3 + Q(3)*BX3*BY1 + Q(4)*BX3*BY3 TEMP2 = Q(5)*BX2*BY1 + Q(6)*BX2*BY3 + Q(7)*BX4*BY1 + Q(8)*BX4*BY3 TEMP3 = Q(9)*BX2*BY2 + Q(10)*BX2*BY4 + Q(11)*BX4*BY2 + . Q(12)*BX4*BY4 TEMP4 = Q(13)*BX1*BY2 + Q(14)*BX1*BY4 + Q(15)*BX3*BY2 + . Q(16)*BX3*BY4 C COLAPR = TEMP1 + TEMP2 + TEMP3 + TEMP4 DERVSL(6) = COLAPR C C CALCULATE THE DY - DERIVATIVE OF THE COLLOCATION APPROXIMATION C C C TEMP1 = Q(1)*BX1*DBY1 + Q(2)*BX1*DBY3 + Q(3)*BX3*DBY1 + . Q(4)*BX3*DBY3 TEMP2 = Q(5)*BX2*DBY1 + Q(6)*BX2*DBY3 + Q(7)*BX4*DBY1 + . Q(8)*BX4*DBY3 TEMP3 = Q(9)*BX2*DBY2 + Q(10)*BX2*DBY4 + Q(11)*BX4*DBY2 + . Q(12)*BX4*DBY4 TEMP4 = Q(13)*BX1*DBY2 + Q(14)*BX1*DBY4 + Q(15)*BX3*DBY2 + . Q(16)*BX3*DBY4 C DERVSL(5) = TEMP1 + TEMP2 + TEMP3 + TEMP4 C C CALCULTE THE DX - DERIVATIVE OF THE APPROXIMATION C C C TEMP1 = Q(1)*DBX1*BY1 + Q(2)*DBX1*BY3 + Q(3)*DBX3*BY1 + . Q(4)*DBX3*BY3 TEMP2 = Q(5)*DBX2*BY1 + Q(6)*DBX2*BY3 + Q(7)*DBX4*BY1 + . Q(8)*DBX4*BY3 TEMP3 = Q(9)*DBX2*BY2 + Q(10)*DBX2*BY4 + Q(11)*DBX4*BY2 + . Q(12)*DBX4*BY4 TEMP4 = Q(13)*DBX1*BY2 + Q(14)*DBX1*BY4 + Q(15)*DBX3*BY2 + . Q(16)*DBX3*BY4 C DERVSL(4) = TEMP1 + TEMP2 + TEMP3 + TEMP4 C C CALCULATE THE DYY - DERIVATIVE OF THE APPROXIMATION C C C TEMP1 = Q(1)*BX1*DDBY1 + Q(2)*BX1*DDBY3 + Q(3)*BX3*DDBY1 + . Q(4)*BX3*DDBY3 TEMP2 = Q(5)*BX2*DDBY1 + Q(6)*BX2*DDBY3 + Q(7)*BX4*DDBY1 + . Q(8)*BX4*DDBY3 TEMP3 = Q(9)*BX2*DDBY2 + Q(10)*BX2*DDBY4 + Q(11)*BX4*DDBY2 + . Q(12)*BX4*DDBY4 TEMP4 = Q(13)*BX1*DDBY2 + Q(14)*BX1*DDBY4 + Q(15)*BX3*DDBY2 + . Q(16)*BX3*DDBY4 C DERVSL(3) = TEMP1 + TEMP2 + TEMP3 + TEMP4 C C CALCULATE THE DXY - DERIVATIVE OF THE APPROXIMATION C C C TEMP1 = Q(1)*DBX1*DBY1 + Q(2)*DBX1*DBY3 + Q(3)*DBX3*DBY1 + . Q(4)*DBX3*DBY3 TEMP2 = Q(5)*DBX2*DBY1 + Q(6)*DBX2*DBY3 + Q(7)*DBX4*DBY1 + . Q(8)*DBX4*DBY3 TEMP3 = Q(9)*DBX2*DBY2 + Q(10)*DBX2*DBY4 + Q(11)*DBX4*DBY2 + . Q(12)*DBX4*DBY4 TEMP4 = Q(13)*DBX1*DBY2 + Q(14)*DBX1*DBY4 + Q(15)*DBX3*DBY2 + . Q(16)*DBX3*DBY4 C DERVSL(2) = TEMP1 + TEMP2 + TEMP3 + TEMP4 C C CALCULATE THE DXX - DERIVATIVE OF THE APPROXIMATION C C C TEMP1 = Q(1)*DDBX1*BY1 + Q(2)*DDBX1*BY3 + Q(3)*DDBX3*BY1 + . Q(4)*DDBX3*BY3 TEMP2 = Q(5)*DDBX2*BY1 + Q(6)*DDBX2*BY3 + Q(7)*DDBX4*BY1 + . Q(8)*DDBX4*BY3 TEMP3 = Q(9)*DDBX2*BY2 + Q(10)*DDBX2*BY4 + Q(11)*DDBX4*BY2 + . Q(12)*DDBX4*BY4 TEMP4 = Q(13)*DDBX1*BY2 + Q(14)*DDBX1*BY4 + Q(15)*DDBX3*BY2 + . Q(16)*DDBX3*BY4 C DERVSL(1) = TEMP1 + TEMP2 + TEMP3 + TEMP4 RETURN END SUBROUTINE COLIND(IX,JY,NBCP,NOD,IROW,NROW,IDCOEF,MXNEQ,MXNCOE, . ELTYPE,NGDXM1,NGDYM1) C C C PURPOSE C C COMPUTE COLUMN INDICIES FOR EQUATIONS WITH BASIS C FUNCTIONS CENTERED AT THE NODES ON THE LEFT SIDE C OF ELEMENT IX,JY C C PARAMETERS C C IX,JY - ELEMENT INDICIES C NOD - NUMBER OF THE NODE AT THE LOW LEFT CORNER C OF THIS ELEMENT C IROW - NUMBER OF THE FIRST EQUATION ASSOCIATED C WITH THIS ELEMENT C NROW - NUMBER OF THE LAST EQUATION ASSOCIATED C WITH THIS ELEMENT C NBCP - NUMBER OF BOUNDARY COLLOCATION POINTS FOR C THIS ELEMENT C IDCOEF - COLUMN INDICIES FOR COEF C ELTYPE - ON INPUT, ELTYPE(IX,JY) GIVES ENTRY AND EXIT POINTS C OF DOMAIN BOUNDARY IN ELEMENT IX,JY C ON OUTPUT, ELTYPE(IX,JY) GIVES FIRST ROW AND NUMBER C OF ROWS OF MATRIX ASSOCIATED WITH ELEMENT IX,JY C C INTEGER ELTYPE(NGDXM1,NGDYM1),IDCOEF(MXNEQ,MXNCOE) C C C IROW=0 INDICATES THIS ELEMENT WAS DISCARDED, C NEED TO DO ONLY INDICIES FOR ELEMENT TO THE LEFT C IF (IROW.EQ.0) GO TO 30 C C PLACE FIRST ROW ASSOCIATED WITH THIS ELEMENT AND THE NUMBER OF C ROWS INTO ELTYPE FOR LATER REFERENCE C ELTYPE(IX,JY) = IROW + 10000* (4+NBCP) C C COMPUTE COLUMN INDICIES FOR THE LEFT NODES C I1 = 4*NOD - 4 DO 20 I = 1,4 DO 10 JROW = IROW,NROW IDCOEF(JROW,I) = I1 + I IDCOEF(JROW,I+12) = I1 + I + 4 10 CONTINUE 20 CONTINUE C C IF THERE IS NO ELEMENT TO THE LEFT, GO TO NEXT ELEMENT C 30 IF (IX.EQ.1) RETURN IF (ELTYPE(IX-1,JY).LE.0) RETURN C C IF THERE IS AN ELEMENT DIRECTLY TO THE LEFT OF THIS ELEMENT, C THE COLUMNS FOR ITS RIGHT NODES ARE THE SAME AS THE LEFT NODES HERE C C FIND FIRST ROW (IROW) AND NUMBER OF ROWS (KROW) ASSOCIATED C WITH THE ELEMENT TO THE LEFT C KROW = ELTYPE(IX-1,JY)/10000 IROW = ELTYPE(IX-1,JY) - KROW*10000 KROW = KROW + IROW - 1 I1 = 4*NOD - 8 DO 50 I = 5,12 DO 40 JROW = IROW,KROW IDCOEF(JROW,I) = I1 + I 40 CONTINUE 50 CONTINUE RETURN END SUBROUTINE COLPLT(SCAL,X,Y,NPTS,IJOB) C C PURPOSE C C PERFORMS ALL PLOTTING OPERATIONS FOR THE DOMAIN, C GRID, AND COLLOCATION POINTS C C PARAMETERS C C SCAL - SCALING FACTOR FOR SIZE OF PLOT C X,Y - COLLOCATION POINTS TO BE PLOTTED C NPTS - NUMBER OF COLLOCATION POINTS TO BE PLOTTED C IJOB - SWITCH FOR WHAT TO PLOT C =1 PLOT DOMAIN AND GRID C =2 PLOT FIRST NPTS FROM (X,Y) C =3 END PLOT C =4 PLOT MAPPING USED FOR INTERIOR COLLOC POINTS C C C * * * * * S Y S T E M D E P E N D E N C I E S * * * * * * C C THIS ROUTINE USES STANDARD CALCOMP ROUTINES PLOT AND SYMBOL. C IF CALCOMP ROUTINES ARE NOT AVAILABLE, THE CALLS SHOULD BE C REPLACED BY CALLS TO SIMILAR ROUTINES. IF PLOTTING FACILITIES C ARE NOT AVAILABLE, THIS ROUTINE CAN BE REPLACED BY A DUMMY C ROUTINE IF PLOTIT=.TRUE. IS NEVER SPECIFIED AS A PARAMETER FOR C COLLOCATION C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BPTYPE,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C REAL X(NPTS),Y(NPTS) C GO TO (10,110,130,60),IJOB C C IJOB = 1 C PRELIMINARY PLOTTING -- DOMAIN AND GRID C C OPEN PLOTTER C 10 CALL PLOTS C C SET SCALING FACTOR C XDIF = GRIDX(NGRIDX) - GRIDX(1) SCAL = PTSIZE/XDIF C C PLOT DOMAIN BOUNDARY C C C FIND BEGINING OF FIRST PIECE C TVAL = BRANGE(1,1) IPIECE = 1 CALL BCOORD(TVAL,XVAL,YVAL,IPIECE) CALL PLOT(XVAL*SCAL,YVAL*SCAL,3) C C LOOP THROUGH EACH PIECE OF BOUNDARY C DO 30 II = 1,NBOUND C C FIND BEGINING OF II'TH PIECE C IPIECE = II STARTT = BRANGE(1,IPIECE) DELTAT = (BRANGE(2,IPIECE)-STARTT)/25. C C PLOT 25 POINTS OF THE II'TH PIECE C DO 20 JJ = 1,26 TVAL = STARTT + FLOAT(JJ-1)*DELTAT CALL BCOORD(TVAL,XVAL,YVAL,IPIECE) CALL PLOT(XVAL*SCAL,YVAL*SCAL,2) 20 CONTINUE 30 CONTINUE C C PLOT GRID LINES C C C HORIZONTAL LINES C DO 40 II = 1,NGRIDY CALL PLOT(GRIDX(1)*SCAL,GRIDY(II)*SCAL,3) CALL PLOT(GRIDX(NGRIDX)*SCAL,GRIDY(II)*SCAL,2) 40 CONTINUE C C VERTICAL LINES C DO 50 II = 1,NGRIDX CALL PLOT(GRIDX(II)*SCAL,GRIDY(1)*SCAL,3) CALL PLOT(GRIDX(II)*SCAL,GRIDY(NGRIDY)*SCAL,2) 50 CONTINUE RETURN C C IJOB = 4 C PLOT 10X10 GRID SHOWING MAPPING USED FOR INTERIOR COLLOC PTS C C C SET CONSTANTS FOR MAPPING C 60 CALL CONST C C PLOT MAPPING OF 11 VERTICAL LINES C DO 80 I = 1,11 XX = FLOAT(I-1)/10. IPEN = 3 DO 70 J = 1,51 YY = FLOAT(J-1)/50. CALL MAPIT(XX,YY,XM,YM) CALL PLOT(SCAL*XM,SCAL*YM,IPEN) IPEN = 2 70 CONTINUE 80 CONTINUE C C PLOT MAPPING OF 11 HORIZONTAL LINES C DO 100 J = 1,11 YY = FLOAT(J-1)/10. IPEN = 3 DO 90 I = 1,51 XX = FLOAT(I-1)/50. CALL MAPIT(XX,YY,XM,YM) CALL PLOT(SCAL*XM,SCAL*YM,IPEN) IPEN = 2 90 CONTINUE 100 CONTINUE RETURN C C IJOB = 2 C PLOT COLLOCATION POINTS IN X AND Y C C SCALE COLLOCATION POINTS AND SHIFT SLIGHTLY TO C APPROXIMATLY CENTER THE PLOTTED CHARACTER X C 110 DO 120 II = 1,NPTS CALL SYMBOL(X(II)*SCAL-.04,Y(II)*SCAL-.05,.14,'X',0.0,1) 120 CONTINUE RETURN C C MOVE PEN PAST END OF PLOT C 130 CALL PLOT(PTSIZE+5.,GRIDY(1)*SCAL,-3) C C CLOSE PLOTTER C CALL PLOT(0.,0.,999) RETURN END SUBROUTINE CONST C C C PURPOSE C C FINDS THE IMAGE OF THE FOUR CORNERS OF THE UNIT SQUARE C UNDER THE MAPPING DEFINED BY MAPSQ. THESE ARE USED IN C THE BLENDING FUNCTION FOR MAPPING AN ARBITRAY POINT IN C THE UNIT SQUARE TO AND ODD SHAPED ELEMENT C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BPTYPE,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C C USE FUNCTION XBD AND YBD TO MAP THE CORNERS C X20 = XBD(0.,2) X21 = XBD(1.,2) X40 = XBD(0.,4) X41 = XBD(1.,4) Y10 = YBD(0.,1) Y11 = YBD(1.,1) Y30 = YBD(0.,3) Y31 = YBD(1.,3) RETURN END SUBROUTINE DBASE(DB1,DB2,DB3,DB4,Z,H) C C C PURPOSE C C DEFINE THE FIRST DERIVATIVE OF THE C CUBIC HERMITE POLYNOMIALS C C PARAMETERS C C INPUT C Z - DIFFERENCE BETWEEN THE POINT WHERE THE POLYNOMIALS C ARE TO BE EVALUATED AND THE LOWER ENDPOINT OF THE C INTERVAL THE POINT IS CONTAINED IN C H - LENGTH OF INTERVAL C C OUTPUT C DB1,DB2,DB3,DB4 - VALUES OF THE FIRST DERIVATIVES OF C THE FOUR POLYNOMIALS C C RH = 1./H S = Z*RH T = 1. - S DB1 = 6.* (S-1.)*S*RH DB2 = -DB1 DB3 = T* (T-2.*S) DB4 = S* (S-2.*T) RETURN END SUBROUTINE DDBASE(DDB1,DDB2,DDB3,DDB4,Z,H) C C C PURPOSE C C DEFINE THE SECOND DERIVATIVES OF THE C CUBIC HERMITE POLYNOMIALS C C PARAMETERS C C INPUT C Z - DIFFERENCE BETWEEN THE POINT WHERE THE POLYNOMIALS C ARE TO BE EVALUATED AND THE LOWER ENDPOINT OF THE C INTERVAL THE POINT IS CONTAINED IN C H - LENGTH OF INTERVAL C C OUTPUT C DDB1,DDB2,DDB3,DDB4 - VALUES OF THE SECOND DERIVATIVES C OF THE FOUR POLYNOMIALS C C RH = 1./H S = Z*RH T = 1. - S DDB1 = 6.* (2.*S-1.)*RH*RH DDB2 = -DDB1 DDB3 = 2.* (S-2.*T)*RH DDB4 = 6.* (S-T)*RH - DDB3 RETURN END SUBROUTINE DISCRD(ELTYPE,GTYPE,NGDXM1,NGDYM1,NGRDXD,NGRDYD,MBNDPT, . IX,JY,NBDIM,SCAL,FATAL) C C C PURPOSE C C DETERMINES WHAT TO DO WITH THE DOMAIN BOUNDARY C INSIDE A DISCARDED ELEMENT C C PARAMETERS C C IX,JY - INDICIES OF DISCARDED ELEMENT C GIVOPT - CONTROL PARAMETER DEFINED BY USER C =1 GIVE BOUNDARY TO NEIGHBORS IF POSSIBLE C =2 GIVE BOUNDARY TO NEIGHBORS IF NECESSARY C C METHOD C C FIRST CHECKS THE FOUR NEIGHBORING ELEMENTS TO SEE IF ANY C OF THEM ARE TO BE KEPT AND HAVE NO BOUNDARY OF THEIR OWN. C IF ONE OR TWO ARE LIKE THAT, THEY GET THE BOUNDARY. C IF MORE THAN TWO ARE LIKE THAT, IT IS A FATAL ERROR. C C IF NONE ARE LIKE THAT, THEN IT LOOKS FOR THE ELEMENTS WHOSE C BOUNDARY CONNECT TO THE BOUNDARY FOR THIS ELEMENT, C AND GIVES IT TO THEM. C INTEGER GTYPE(NGRDXD,NGRDYD),ELTYPE(NGDXM1,NGDYM1),IPIEC(8),ENT, . EXT,ENTL,EXTL,ENTU,EXTU,EXTD,ENTD,EXTR,ENTR C REAL X(1),Y(1) C LOGICAL FATAL,KEEPIT C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP CHARACTER *4 NTP,XTP,BPTYPE REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C IF (LEVEL.LE.2) GO TO 10 WRITE (MOUTPT,9001) IX,JY C C FIND ENTRY AND EXIT POINTS OF DISCARDED ELEMENT C 10 EXT = ELTYPE(IX,JY)/1000 ENT = ELTYPE(IX,JY) - 1000*EXT C C FIND ENTRY AND EXIT POINTS OF FOUR NEIGHBORING ELEMENTS. WHEN DONE, C ENT* AND EXT* INDICATE < 0 IF DELETED OR DOESNT EXIST C = 0 IF KEPT AND HAS NO BOUNDARY C > 0 IF KEPT AND ENT* AND EXT* ARE ENTRY AND E C C LEFT ELEMENT C IF (IX.NE.1) GO TO 20 ENTL = -1 EXTL = -1 GO TO 30 C 20 EXTL = ELTYPE(IX-1,JY)/1000 ENTL = ELTYPE(IX-1,JY) - 1000*EXTL IF (EXTL.LT.0) ENTL = -1 IF (ENTL.LT.0) EXTL = -1 C C DOWN ELEMENT C 30 IF (JY.NE.1) GO TO 40 ENTD = -1 EXTD = -1 GO TO 50 C 40 EXTD = ELTYPE(IX,JY-1)/1000 ENTD = ELTYPE(IX,JY-1) - 1000*EXTD IF (EXTD.LT.0) ENTD = -1 IF (ENTD.LT.0) EXTD = -1 C C UP ELEMENT C 50 IF (JY.NE.NGDYM1) GO TO 60 ENTU = -1 EXTU = -1 GO TO 70 C 60 EXTU = ELTYPE(IX,JY+1)/1000 ENTU = ELTYPE(IX,JY+1) - 1000*EXTU IF (ENTU.EQ.0 .AND. EXTU.EQ.0 .AND. . (GTYPE(IX,JY+1).LE.0.OR.GTYPE(IX+1,JY+1).LE.0.OR.GTYPE(IX, . JY+2).LE.0.OR.GTYPE(IX+1,JY+2).LE.0)) ENTU = -1 IF (EXTU.LT.0) ENTU = -1 IF (ENTU.LT.0) EXTU = -1 IF (EXTU.LE.0) GO TO 70 IF (KEEPIT(IX,JY+1,ENTU,EXTU,GRIDX(IX),GRIDX(IX+1),GRIDY(JY+1), . GRIDY(JY+2),NGRDXD,NGRDYD,GTYPE,ELTYPE,NGDXM1, . NGDYM1)) GO TO 70 ENTU = -1 EXTU = -1 C C RIGHT ELEMENT C 70 IF (IX.NE.NGDXM1) GO TO 80 ENTR = -1 EXTR = -1 GO TO 90 C 80 EXTR = ELTYPE(IX+1,JY)/1000 ENTR = ELTYPE(IX+1,JY) - 1000*EXTR IF (ENTR.EQ.0 .AND. EXTR.EQ.0 .AND. . (GTYPE(IX+1,JY).LE.0.OR.GTYPE(IX+1,JY+1).LE.0.OR.GTYPE(IX+2, . JY).LE.0.OR.GTYPE(IX+2,JY+1).LE.0)) ENTR = -1 IF (EXTR.LT.0) ENTR = -1 IF (ENTR.LT.0) EXTR = -1 IF (EXTR.LE.0) GO TO 90 IF (KEEPIT(IX+1,JY,ENTR,EXTR,GRIDX(IX+1),GRIDX(IX+2),GRIDY(JY), . GRIDY(JY+1),NGRDXD,NGRDYD,GTYPE,ELTYPE,NGDXM1, . NGDYM1)) GO TO 90 ENTR = -1 EXTR = -1 C C NEIGHBORING ELEMENTS WHICH ARE KEPT AND HAVE NO BOUNDARY (ENT*=0) C MUST GET SOME BOUNDARY. SET (IX1,JY1) AND (IX2,JY2) TO BE THE C INDICES OF SUCH ELEMENTS C 90 IX1 = 0 IX2 = 0 IF (ENTL.NE.0) GO TO 100 IX1 = IX - 1 JY1 = JY C 100 IF (ENTD.NE.0) GO TO 120 IF (IX1.NE.0) GO TO 110 IX1 = IX JY1 = JY - 1 GO TO 120 110 IX2 = IX JY2 = JY - 1 C 120 IF (ENTU.NE.0) GO TO 140 IF (IX1.NE.0) GO TO 130 IX1 = IX JY1 = JY + 1 GO TO 140 130 IF (IX2.NE.0) GO TO 460 IX2 = IX JY2 = JY + 1 C 140 IF (ENTR.NE.0) GO TO 160 IF (IX1.NE.0) GO TO 150 IX1 = IX + 1 JY1 = JY GO TO 160 150 IF (IX2.NE.0) GO TO 460 IX2 = IX + 1 JY2 = JY C C IF FOUND TWO ELEMENTS THAT NEED SOME BOUNDARY, DETERMINE C WHICH IS FIRST AND GO SPLIT THE BOUNDARY BETWEEN THOSE TWO C 160 IF (IX2.EQ.0) GO TO 170 IF ((IX1.EQ.IX-1.AND.JY2.EQ.JY-1) .OR. JY1.EQ.JY-1) GO TO 410 IT = IX1 IX1 = IX2 IX2 = IT IT = JY1 JY1 = JY2 JY2 = IT GO TO 410 C C IF FOUND EXACTLY ONE THAT NEEDS SOME BOUNDARY, GIVE C ALL THE BOUNDARY OF THE DISCARDED ELEMENT TO THAT ELEMENT C 170 IF (IX1.NE.0) GO TO 390 C C IF NO ELEMENTS NEED IT, AND GIVOPT IS 2, DONE. C IF (GIVOPT.NE.2) GO TO 180 IF (LEVEL.LE.2) RETURN WRITE (MOUTPT,9011) RETURN C C OTHERWISE, GIVE THE BOUNDARY TO THE ELEMENTS WHOSE BOUNDARY C CONNECT TO THE BOUNDARY OF THE DISCARDED ELEMENT C C LOOK FOR ONE WHOSE EXIT POINT IS THE ENTRY POINT OF THIS ELEMENT C 180 IF (EXTL.NE.ENT) GO TO 190 IX1 = IX - 1 JY1 = JY GO TO 220 C 190 IF (EXTD.NE.ENT) GO TO 200 IX1 = IX JY1 = JY - 1 GO TO 220 C 200 IF (EXTU.NE.ENT) GO TO 210 IX1 = IX JY1 = JY + 1 GO TO 220 C 210 IF (EXTR.NE.ENT) GO TO 220 IX1 = IX + 1 JY1 = JY C C LOOK FOR ONE WHOSE ENTRY POINT IS THE EXIT POINT OF THIS ELEMENT C 220 IF (ENTL.NE.EXT) GO TO 230 IX2 = IX - 1 JY2 = JY GO TO 260 C 230 IF (ENTD.NE.EXT) GO TO 240 IX2 = IX JY2 = JY - 1 GO TO 260 C 240 IF (ENTU.NE.EXT) GO TO 250 IX2 = IX JY2 = JY + 1 GO TO 260 C 250 IF (ENTR.NE.EXT) GO TO 260 IX2 = IX + 1 JY2 = JY C C IF BOTH THE ENTRY AND EXIT POINTS WERE MATCHED, GO SPLIT C THE BOUNDARY BETWEEN THE ELEMENTS THAT MATCHED THE ENDPOINTS C 260 IF (IX1.NE.0 .AND. IX2.NE.0) GO TO 410 C C OTHERWISE, CHECK THE ELEMENTS OFF THE CORNERS FOR A MATCH. C THIS NEED ONLY BE DONE IF THE POINT NOT MATCHED HAS TYPE BOTH C NTP = BPTYPE(ENT) XTP = BPTYPE(EXT) IF ((IX1.NE.0.OR.NTP.NE.BOTH) .AND. . (IX2.NE.0.OR.XTP.NE.BOTH)) GO TO 370 C C FIND ENTRY AND EXIT POINTS OF ELEMENTS OFF THE CORNERS. C RECHECK CONDITION AFTER EACH. C C DOWNLEFT C IF (IX.EQ.1 .OR. JY.EQ.1) GO TO 290 EXTL = ELTYPE(IX-1,JY-1)/1000 IF (EXTL.LT.0) GO TO 290 IF (EXT.NE.ENT) GO TO 270 IX1 = IX - 1 JY1 = JY - 1 GO TO 280 270 ENTL = ELTYPE(IX-1,JY-1) - 1000*EXTL IF (ENTL.NE.EXT) GO TO 290 IX2 = IX - 1 JY2 = JY - 1 280 IF ((IX1.NE.0.OR.NTP.NE.BOTH) .AND. . (IX2.NE.0.OR.XTP.NE.BOTH)) GO TO 370 C C UPLEFT C 290 IF (IX.EQ.1 .OR. JY.EQ.NGDYM1) GO TO 320 EXTL = ELTYPE(IX-1,JY+1)/1000 IF (EXTL.LT.0) GO TO 320 IF (EXTL.NE.ENT) GO TO 300 IX1 = IX - 1 JY1 = JY + 1 GO TO 310 300 ENTL = ELTYPE(IX-1,JY+1) - 1000*EXTL IF (ENTL.NE.EXT) GO TO 320 IX2 = IX - 1 JY2 = JY + 1 310 IF ((IX1.NE.0.OR.NTP.NE.BOTH) .AND. . (IX2.NE.0.OR.XTP.NE.BOTH)) GO TO 370 C C DOWNRIGHT C 320 IF (IX.EQ.NGDXM1 .OR. JY.EQ.1) GO TO 350 EXTL = ELTYPE(IX+1,JY-1)/1000 IF (EXTL.LE.0) GO TO 350 ENTL = ELTYPE(IX+1,JY-1) - 1000*EXTL IF (ENTL.LE.0) GO TO 350 IF ( .NOT. KEEPIT(IX+1,JY-1,ENTL,EXTL,GRIDX(IX+1),GRIDX(IX+2), . GRIDY(JY-1),GRIDY(JY),NGRDXD,NGRDYD,GTYPE,ELTYPE,NGDXM1, . NGDYM1)) GO TO 350 IF (EXTL.NE.ENT) GO TO 330 IX1 = IX + 1 JY1 = JY - 1 GO TO 340 330 IF (ENTL.NE.EXT) GO TO 350 IX2 = IX + 1 JY2 = JY - 1 340 IF ((IX1.NE.0.OR.NTP.NE.BOTH) .AND. . (IX2.NE.0.OR.XTP.NE.BOTH)) GO TO 370 C C UPRIGHT C 350 IF (IX.EQ.NGDXM1 .OR. JY.EQ.NGDYM1) GO TO 370 EXTL = ELTYPE(IX+1,JY+1)/1000 IF (EXTL.LE.0) GO TO 370 ENTL = ELTYPE(IX+1,JY+1) - 1000*EXTL IF (ENTL.LE.0) GO TO 370 IF ( .NOT. KEEPIT(IX+1,JY+1,ENTL,EXTL,GRIDX(IX+1),GRIDX(IX+2), . GRIDY(JY+1),GRIDY(JY+2),NGRDXD,NGRDYD,GTYPE,ELTYPE,NGDXM1, . NGDYM1)) GO TO 370 IF (EXTL.NE.ENT) GO TO 360 IX1 = IX + 1 JY1 = JY + 1 GO TO 370 360 IF (ENTL.NE.EXT) GO TO 370 IX2 = IX + 1 JY2 = JY + 1 C C IF BOTH THE ENTRY AND EXIT POINTS WERE MATCHED, GO SPLIT C THE BOUNDARY BETWEEN THE ELEMENTS THAT MATCHED THE ENDPOINTS C 370 IF (IX1.NE.0 .AND. IX2.NE.0) GO TO 410 C C IF MATCHED ENTRY AND NOT EXIT, GIVE ALL THE BOUNDARY C FROM THE DISCARDED ELEMENT TO THE ENTRY C IF (IX1.NE.0) GO TO 390 C C IF DIDNT MATCH THE ENTRY OR THE EXIT, CANNOT DO ANYTHING WITH IT C IF (IX2.NE.0) GO TO 380 IF (LEVEL.LE.2) RETURN WRITE (MOUTPT,9021) RETURN C C IF DID MATCH THE EXIT, MOVE THE INDICIES OF THE ELEMENT THAT C MATCHED THE EXIT TO (IX1,JY1) SO THAT THAT ELEMENT WILL GET C THE BOUNDARY OF THE DISCARDED ELEMENT C 380 IX1 = IX2 JY1 = JY2 C C C GIVE THE WHOLE BOUNDARY SEGMENT TO ONE ELEMENT C C 390 IF (ELTYPE(IX1,JY1).NE.0) GO TO 400 C C HAD NO BOUNDARY BEFORE C ELTYPE(IX1,JY1) = ELTYPE(IX,JY) RETURN C C HAD BOUNDARY BEFORE. FIND WHETHER IT MATCHES THE ENTRY OR EXIT, C AND REASSIGN THE EXIT OR ENTRY C 400 EXTL = ELTYPE(IX1,JY1)/1000 ENTL = ELTYPE(IX1,JY1) - 1000*EXTL IF (ENTL.EQ.EXT) ELTYPE(IX1,JY1) = 1000*EXTL + ENT IF (EXTL.EQ.ENT) ELTYPE(IX1,JY1) = 1000*EXT + ENTL IF (LEVEL.LE.2) RETURN WRITE (MOUTPT,9031) IX1,JY1,ELTYPE(IX1,JY1) RETURN C C C SPLIT BOUNDARY BETWEEN TWO ELEMENTS C C C DEFINE A NEW BOUNDARY POINT TO BE THE MIDPOINT OF C THE BOUNDARY WITHIN THE DISCARDED ELEMENT C 410 MBNDPT = MBNDPT + 1 C C CHECK FOR ARRAY LENGTH OVERFLOW C IF (MBNDPT.GT.NBDIM) GO TO 470 C C FIND MIDPOINT C ICODE = 1 CALL BCP(NBCP,X,Y,IX,JY,ICODE,ELTYPE,NGDXM1,NGDYM1,T,IPIEC,SCAL, . FATAL) IF (FATAL) GO TO 480 C C SAVE COORDINATES, PARAMETER, AND PIECE OF NEW POINT C XBOUND(MBNDPT) = X(1) YBOUND(MBNDPT) = Y(1) BPARAM(MBNDPT) = T PIECE(MBNDPT) = IPIEC(1) C C SAVE INDICIES OF ELEMENT THAT THE NEW POINT IS WITHIN C BGRID(MBNDPT) = IX BNEIGH(MBNDPT) = JY C IF (LEVEL.LE.2) GO TO 420 WRITE (MOUTPT,9041) IX1,JY1,IX2,JY2,MBNDPT,X(1),Y(1),T,IPIEC(1) C C ASSIGN ENTRY SEGMENT C 420 IF (ELTYPE(IX1,JY1).NE.0) GO TO 430 ELTYPE(IX1,JY1) = 1000*MBNDPT + ENT GO TO 440 430 EXTL = ELTYPE(IX1,JY1)/1000 ENTL = ELTYPE(IX1,JY1) - 1000*EXTL ELTYPE(IX1,JY1) = 1000*MBNDPT + ENTL C C ASSIGN EXIT SEGMENT C 440 IF (ELTYPE(IX2,JY2).NE.0) GO TO 450 ELTYPE(IX2,JY2) = 1000*EXT + MBNDPT RETURN 450 EXTL = ELTYPE(IX2,JY2)/1000 ELTYPE(IX2,JY2) = 1000*EXTL + MBNDPT IF (LEVEL.LE.2) RETURN WRITE (MOUTPT,9051) ELTYPE(IX1,JY1),ELTYPE(IX2,JY2) RETURN C C C ERROR CONDITIONS C C C MORE THAN TWO NEIGHBORS HAD NO PREVIOUS BOUNDARY C 460 WRITE (MOUTPT,9091) WRITE (MOUTPT,9061) IX,JY FATAL = .TRUE. RETURN C C RAN OUT OF ROOM IN BOUNDARY ARRAYS C 470 WRITE (MOUTPT,9091) WRITE (MOUTPT,9071) IX,JY,NBDIM FATAL = .TRUE. RETURN C C FATAL ERROR OCCURED IN BCP C 480 WRITE (MOUTPT,9081) RETURN 9001 FORMAT (19H DISCARDING ELEMENT,2I5) 9011 FORMAT (18H BOUNDARY NOT KEPT) 9021 FORMAT (18H BOUNDARY NOT KEPT) 9031 FORMAT (26H BOUNDARY GIVEN TO ELEMENT,2I5/20H NEW ELEMENT TYPE IS, . I7) 9041 FORMAT (32H BOUNDARY SPLIT BETWEEN ELEMENTS,2I5,4H AND, . 2I5/25H DIVISION POINT HAS INDEX,I4/20X,11HCOORDINATES, . 2F10.4/20X,9HPARAMETER,F10.4,9H ON PIECE,I4) 9051 FORMAT (22H NEW ELEMENT TYPES ARE,2I7) 9061 FORMAT (10X,49HWHILE DIVIDING UP BOUNDARY FROM DISCARDED ELEMENT, . 2I5/10X, . 57HFOUND MORE THAN TWO NEIGHBORING ELEMENTS WITH NO BOUNDARY/ . 10X,28H-- USE A DIFFERENT GRID --) 9071 FORMAT (10X,50HRAN OUT OF ROOM IN BOUNDARY ARRAYS WHILE SPLITTING/ . 10X,29HBOUNDARY IN DISCARDED ELEMENT,2I5/10X, . 53H-- INCREASE DIMENSION OF XBOUND,YBOUND,BPARAM,PIECE,/14X, . 39HBGRID AND BNEIGH TO A VALUE LARGER THAN,I8) 9081 FORMAT (10X,42HERROR OCCURED WHILE DIVIDING BOUNDARY FROM, . 18H DISCARDED ELEMENT) 9091 FORMAT (29H0 * * * FATAL ERROR * * *//) END SUBROUTINE ICP(IX,JY,HX,HY,X,Y,GTYPE,NGRDXD,NGRDYD,ELTYPE,NGDXM1, . NGDYM1,SCAL) C C C PURPOSE C C TO FIND FOUR INTERIOR COLLOCATION POINTS FOR ELEMENT IX,JY C C PARAMETERS C C IX,JY - ELEMENT INDICIES C HX,HY - SIZE OF ELEMENT C X,Y - OUTPUT, THE FOUR COLLOCATION POINTS C C METHOD C C IF THE ELEMENT IS RECTANGULAR, THE ICP ARE THE USUAL C GAUSS QUADRATURE POINTS C IF NOT, DEFINE A MAPPING FROM THE ELEMENT TO THE C INTERSECTION OF THE ELEMENT WITH THE DOMAIN AND MAP C THE USUAL FOUR GAUSS POINTS C C INTEGER ELTYPE(NGDXM1,NGDYM1),GTYPE(NGRDXD,NGRDYD) C REAL X(4),Y(4),XP(4,3),YP(4,3),T(3),DUM2(8),DUM3(8) C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BPTYPE,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C C SEE IF ALL FOUR CORNERS ARE INTERIOR C IF (GTYPE(IX,JY).LE.0 .OR. GTYPE(IX+1,JY).LE.0 .OR. . GTYPE(IX,JY+1).LE.0 .OR. GTYPE(IX+1,JY+1).LE.0) GO TO 10 C C IF THEY ARE, THE COLLOCATION POINTS ARE THE GAUSS POINTS C X(1) = GRIDX(IX) + GP1*HX X(2) = GRIDX(IX) + GP2*HX X(3) = X(2) X(4) = X(1) Y(1) = GRIDY(JY) + GP1*HY Y(2) = Y(1) Y(3) = GRIDY(JY) + GP2*HY Y(4) = Y(3) GO TO 100 C C IF NOT, MAP THE GAUSS POINTS FROM THE UNIT SQUARE TO THE ELEMENT C 10 IEXT = ELTYPE(IX,JY)/1000 IENT = ELTYPE(IX,JY) - 1000*IEXT C C DEFINE A MAPPING FROM THE ELEMENT TO THE INTERSECTION OF C THE ELEMENT AND THE DOMAIN C CALL MAPSQ(IENT,IEXT,GRIDX(IX),GRIDX(IX+1),GRIDY(JY),GRIDY(JY+1), . ELTYPE,NGDXM1,NGDYM1) C C IF OUTPUT LEVEL IS HIGH ENOUGH, PRINT C THE MAPPING USED C IF (LEVEL.LT.3) GO TO 40 WRITE (MOUTPT,9001) IX,JY DO 30 I = 1,4 WRITE (MOUTPT,9011) I J = 0 20 J = J + 1 WRITE (MOUTPT,9021) TT(J,I),IP(J,I),UP(J,I),LO(J,I),UPA(J,I), . LOA(J,I) IF (TT(J,I).LT.1.) GO TO 20 X(I) = 0. Y(I) = 0. 30 CONTINUE C C IF OUTPUT LEVEL IS HIGH ENOUGH, AND THE PLOTTING OPTION IS ON, C PLOT THE MAPPING OF A 10X10 GRID C IF (PLOTIT) CALL COLPLT(SCAL,DUM2,DUM3,1,4) C C MAP THE CORNERS AND THE GAUSS QUADRATURE POINTS FROM EACH C SIDE USING THE BOUNDARY MAPPING DEFINED IN MAPSQ C 40 T(1) = 0. T(2) = GP1 T(3) = GP2 DO 90 ISIDE = 1,4 ISEG = 1 DO 80 IPT = 1,3 50 ISEG = ISEG + 1 IF (TT(ISEG,ISIDE).LT.T(IPT)) GO TO 50 IF (IP(ISEG,ISIDE).EQ.-1) GO TO 60 PARAM = ((TT(ISEG,ISIDE)-T(IPT))*LO(ISEG,ISIDE)+ . (T(IPT)-TT(ISEG-1,ISIDE))*UP(ISEG,ISIDE))/ . (TT(ISEG,ISIDE)-TT(ISEG-1,ISIDE)) IPIECE = IP(ISEG,ISIDE) CALL BCOORD(PARAM,XP(ISIDE,IPT),YP(ISIDE,IPT),IPIECE) GO TO 70 60 XP(ISIDE,IPT) = UP(ISEG,ISIDE)*T(IPT) + LO(ISEG,ISIDE) YP(ISIDE,IPT) = UPA(ISEG,ISIDE)*T(IPT) + LOA(ISEG,ISIDE) 70 ISEG = ISEG - 1 80 CONTINUE 90 CONTINUE C C MAP THE USUAL FOUR COLLOCATION POINTS FROM THE UNIT SQUARE C TO THE ODD SHAPED ELEMENT BY BLENDING THE RESULTS OF C MAPPING THE SIDES C XDUM1 = GP2*XP(2,1) + GP1*XP(1,1) XDUM2 = GP2*XP(3,1) + GP1*XP(4,1) XDUM3 = GP1*XP(2,1) + GP2*XP(1,1) XDUM4 = GP1*XP(3,1) + GP2*XP(4,1) YDUM1 = GP2*YP(2,1) + GP1*YP(3,1) YDUM2 = GP2*YP(1,1) + GP1*YP(4,1) YDUM3 = GP1*YP(2,1) + GP2*YP(3,1) YDUM4 = GP1*YP(1,1) + GP2*YP(4,1) C X(1) = GP2* (XP(2,2)+XP(1,3)-XDUM1) + GP1* (XP(4,3)+XP(3,2)-XDUM2) Y(1) = GP2* (YP(2,2)+YP(1,3)-YDUM1) + GP1* (YP(4,3)+YP(3,2)-YDUM2) C X(2) = GP2* (XP(4,3)+XP(1,2)-XDUM3) + GP1* (XP(2,2)+XP(3,3)-XDUM4) Y(2) = GP1* (YP(3,3)+YP(2,2)-YDUM1) + GP2* (YP(1,2)+YP(4,3)-YDUM2) C X(3) = GP1* (XP(2,3)+XP(1,2)-XDUM3) + GP2* (XP(4,2)+XP(3,3)-XDUM4) Y(3) = GP1* (YP(1,2)+YP(2,3)-YDUM3) + GP2* (YP(3,3)+YP(4,2)-YDUM4) C X(4) = GP1* (XP(4,2)+XP(1,3)-XDUM1) + GP2* (XP(2,3)+XP(3,2)-XDUM2) Y(4) = GP2* (YP(3,2)+YP(2,3)-YDUM3) + GP1* (YP(1,3)+YP(4,2)-YDUM4) C C IF PLOTTING OPTION IS ON, PLOT INTERIOR COLLOCATION POINTS C 100 IF (PLOTIT) CALL COLPLT(SCAL,X,Y,4,2) C C IF OUTPUT LEVEL IS HIGH ENOUGH, PRINT INTERIOR COLLOCATION POINTS C IF (LEVEL.LT.3) RETURN WRITE (MOUTPT,9031) IX,JY WRITE (MOUTPT,9041) (X(I),Y(I),I=1,4) RETURN 9001 FORMAT (/40H MAPPING FOR INTERIOR COLLOCATION POINTS, . 12H FOR ELEMENT,2I4) 9011 FORMAT (/17H MAPPING FOR SIDE,I2) 9021 FORMAT (1X,F10.5,I3,4F10.5) 9031 FORMAT (/40H INTERIOR COLLOCATION POINTS FOR ELEMENT,2I4) 9041 FORMAT (10X,2F10.4) END SUBROUTINE INTEQ(IX,JY,HX,HY,NROW,X,Y,COEF,MXNEQ,MXNCOE) C C C PURPOSE C C COMPUTE THE INTERIOR COLLOCATION EQUATIONS C FOR ELEMENT IX,JY C C PARAMETERS C C IX,JY - ELEMENT INDICES C HX,HY - SIZE OF ELEMENT C NROW - LAST ROW ADDED TO MATRIX C COEF - COEFFICIENT MATRIX C C REAL COEF(MXNEQ,MXNCOE),CVALUS(7),X(8),Y(8) C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BPTYPE,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C DO 10 I = 1,4 NROW = NROW + 1 C C CALCULATE THE VALUES OF THE BASIS FUNCTIONS C T = X(I) - GRIDX(IX) S = Y(I) - GRIDY(JY) C CALL BASE(BX1,BX2,BX3,BX4,T,HX) CALL BASE(BY1,BY2,BY3,BY4,S,HY) CALL DBASE(DBX1,DBX2,DBX3,DBX4,T,HX) CALL DBASE(DBY1,DBY2,DBY3,DBY4,S,HY) CALL DDBASE(DDBX1,DDBX2,DDBX3,DDBX4,T,HX) CALL DDBASE(DDBY1,DDBY2,DDBY3,DDBY4,S,HY) C C CALCULATE THE COEFFICIENTS OF THE DIFFERENTIAL OPERATOR C CALL PDE(X(I),Y(I),CVALUS) C COEF1 = CVALUS(1) COEF2 = CVALUS(2) COEF3 = CVALUS(3) COEF4 = CVALUS(4) COEF5 = CVALUS(5) COEF6 = CVALUS(6) C C COMPUTE THE COEFFICIENTS OF THE UNKOWNS IN EQUATION NROW C C TEMPORARY VARIABLES C DUMMY1 = COEF1*DDBX1 + COEF4*DBX1 + COEF6*BX1 DUMMY2 = COEF1*DDBX2 + COEF4*DBX2 + COEF6*BX2 DUMMY3 = COEF1*DDBX3 + COEF4*DBX3 + COEF6*BX3 DUMMY4 = COEF1*DDBX4 + COEF4*DBX4 + COEF6*BX4 DUMY1 = COEF3*DDBY1 + COEF5*DBY1 DUMY2 = COEF3*DDBY2 + COEF5*DBY2 DUMY3 = COEF3*DDBY3 + COEF5*DBY3 DUMY4 = COEF3*DDBY4 + COEF5*DBY4 C2DBX1 = COEF2*DBX1 C2DBX2 = COEF2*DBX2 C2DBX3 = COEF2*DBX3 C2DBX4 = COEF2*DBX4 C C COMPUTE NONZERO COEFFICIENTS C COEF(NROW,1) = BY1*DUMMY1 + BX1*DUMY1 + C2DBX1*DBY1 COEF(NROW,2) = BY3*DUMMY1 + BX1*DUMY3 + C2DBX1*DBY3 COEF(NROW,3) = BY1*DUMMY3 + BX3*DUMY1 + C2DBX3*DBY1 COEF(NROW,4) = BY3*DUMMY3 + BX3*DUMY3 + C2DBX3*DBY3 COEF(NROW,5) = BY1*DUMMY2 + BX2*DUMY1 + C2DBX2*DBY1 COEF(NROW,6) = BY3*DUMMY2 + BX2*DUMY3 + C2DBX2*DBY3 COEF(NROW,7) = BY1*DUMMY4 + BX4*DUMY1 + C2DBX4*DBY1 COEF(NROW,8) = BY3*DUMMY4 + BX4*DUMY3 + C2DBX4*DBY3 COEF(NROW,9) = BY2*DUMMY2 + BX2*DUMY2 + C2DBX2*DBY2 COEF(NROW,10) = BY4*DUMMY2 + BX2*DUMY4 + C2DBX2*DBY4 COEF(NROW,11) = BY2*DUMMY4 + BX4*DUMY2 + C2DBX4*DBY2 COEF(NROW,12) = BY4*DUMMY4 + BX4*DUMY4 + C2DBX4*DBY4 COEF(NROW,13) = BY2*DUMMY1 + BX1*DUMY2 + C2DBX1*DBY2 COEF(NROW,14) = BY4*DUMMY1 + BX1*DUMY4 + C2DBX1*DBY4 COEF(NROW,15) = BY2*DUMMY3 + BX3*DUMY2 + C2DBX3*DBY2 COEF(NROW,16) = BY4*DUMMY3 + BX3*DUMY4 + C2DBX3*DBY4 C C COMPUTE RIGHT SIDE C COEF(NROW,MXNCOE) = PDERHS(X(I),Y(I)) 10 CONTINUE C RETURN END LOGICAL FUNCTION KEEPIT(IX,JY,IENT,IEXT,XLEFT,XRIGHT,YDOWN,YUP, . NGRDXD,NGRDYD,GTYPE,ELTYPE,NGDXM1,NGDYM1) C C C PURPOSE C C DETERMINES WHETHER OR NOT TO KEEP AN ELEMENT C THAT IS PARTIALLY EXTERIOR. C C PARAMETERS C C IX,JY - ELEMENT INDICIES C IENT,IEXT - INDICIES OF POINTS WHERE THE BOUNDARY ENTERS C AND EXITS THE ELEMENT C XLEFT,XRIGHT - X-COORDINATES OF LEFT AND RIGHT SIDES C OF ELEMENT C YDOWN,YUP - Y-COORDINATES OF BOTTOM AND TOP SIDES C OF ELEMENT C C METHOD C C DISCARD THE ELEMENT (KORDEL=.FALSE.) IF THE FRACTION C OF ITS AREA INSIDE THE DOMAIN IS LESS THAN DSCARE C C THE AREA OF THE ELEMENT INSIDE THE DOMAIN IS C COMPUTED AS FOLLOWS: C C APPROXIMATE THE BOUNDARY OF THE DOMAIN INSIDE THE ELEMENT C BY STRAIGHT LINES BETWEEN THE BOUNDARY POINTS. COMPUTE C THE AREA OF EACH TRAPEZOID (DEFINED BY THESE LINE SEGMENTS C AND THE ELEMENT BOUNDARY) WHICH IS INTERIOR TO THE DOMAIN. C SUM THE AREAS OF THE TRAPEZOIDS. C C INTEGER GTYPE(NGRDXD,NGRDYD),ELTYPE(NGDXM1,NGDYM1) C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BPTYPE,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C IF THE ENTRY AND/OR EXIT POINTS ARE EXTRAS PREVIOUSLY ADDED, C FIND THE REAL ENTRY AND EXIT POINTS C IENTRY = IENT IEXIT = IEXT IF (IENT.LE.NBNDPT) GO TO 10 IXX = BGRID(IENT) JYY = BNEIGH(IENT) IENTRY = -ELTYPE(IXX,JYY)/1000 C 10 IF (IEXT.LE.NBNDPT) GO TO 20 IXX = BGRID(IEXT) JYY = BNEIGH(IEXT) IEXIT = -ELTYPE(IXX,JYY) - 1000* ((-ELTYPE(IXX,JYY))/1000) 20 CONTINUE C C C COMPUTE THE AREA OF THE ELEMENT C C AREAEL = (XRIGHT-XLEFT)* (YUP-YDOWN) AREA = 0. LIM1 = IENTRY + 1 C C FIND THE COORDINATES OF THE POINTS WHERE THE BOUNDARY ENTERS C AND LEAVES THE ELEMENT C XENTRY = XBOUND(IENTRY) XEXIT = XBOUND(IEXIT) YENTRY = YBOUND(IENTRY) YEXIT = YBOUND(IEXIT) C C DIFFERENT CASES FOR ENTERING ON DIFFERENT SIDES C IF (ABS(XENTRY-XLEFT).LE.EPSGRD) GO TO 30 IF (ABS(XENTRY-XRIGHT).LE.EPSGRD) GO TO 80 IF (ABS(YENTRY-YDOWN).LE.EPSGRD) GO TO 130 IF (ABS(YENTRY-YUP).LE.EPSGRD) GO TO 180 C C COULDN'T FIND WHICH SIDE THE BOUNDARY ENTERS ON. C PRINT WARNING AND DISCARD ELEMENT. C WRITE (MOUTPT,9001) IX,JY KEEPIT = .FALSE. RETURN C C CASE I - BOUNDARY ENTERS ON LEFT SIDE C 30 I = LIM1 40 IF (I.GT.NBNDPT) I = 1 IF (I.NE.1) GO TO 50 DY = (YBOUND(NBNDPT)+YBOUND(1))/2. - YDOWN DX = XBOUND(1) - XBOUND(NBNDPT) GO TO 60 50 DY = (YBOUND(I-1)+YBOUND(I))/2. - YDOWN DX = XBOUND(I) - XBOUND(I-1) 60 AREA = AREA + DY*DX IF (I.EQ.IEXIT) GO TO 70 I = I + 1 GO TO 40 70 IF (ABS(YEXIT-YUP).LE.EPSGRD) AREA = AREA + . (XRIGHT-XEXIT)* (YUP-YDOWN) GO TO 230 C C CASE II - BOUNDARY ENTERS ON RIGHT SIDE C 80 I = LIM1 90 IF (I.GT.NBNDPT) I = 1 IF (I.NE.1) GO TO 100 DY = YUP - (YBOUND(NBNDPT)+YBOUND(1))/2. DX = XBOUND(NBNDPT) - XBOUND(1) GO TO 110 100 DY = YUP - (YBOUND(I-1)+YBOUND(I))/2. DX = XBOUND(I-1) - XBOUND(I) 110 AREA = AREA + DY*DX IF (I.EQ.IEXIT) GO TO 120 I = I + 1 GO TO 90 120 IF (ABS(YEXIT-YDOWN).LE.EPSGRD) AREA = AREA + . (XEXIT-XLEFT)* (YUP-YDOWN) GO TO 230 C C CASE III - BOUNDARY ENTERS FROM THE BOTTOM C 130 I = LIM1 140 IF (I.GT.NBNDPT) I = 1 IF (I.NE.1) GO TO 150 DX = XRIGHT - (XBOUND(NBNDPT)+XBOUND(1))/2. DY = YBOUND(1) - YBOUND(NBNDPT) GO TO 160 150 DX = XRIGHT - (XBOUND(I-1)+XBOUND(I))/2. DY = YBOUND(I) - YBOUND(I-1) 160 AREA = AREA + DY*DX IF (I.EQ.IEXIT) GO TO 170 I = I + 1 GO TO 140 170 IF (ABS(XEXIT-XLEFT).LE.EPSGRD) AREA = AREA + . (XRIGHT-XLEFT)* (YUP-YEXIT) GO TO 230 C C CASE IV - BOUNDARY ENTERS FROM THE TOP C 180 I = LIM1 190 IF (I.GT.NBNDPT) I = 1 IF (I.NE.1) GO TO 200 DX = (XBOUND(NBNDPT)+XBOUND(1))/2. - XLEFT DY = YBOUND(NBNDPT) - YBOUND(1) GO TO 210 200 DX = (XBOUND(I-1)+XBOUND(I))/2. - XLEFT DY = YBOUND(I-1) - YBOUND(I) 210 AREA = AREA + DY*DX IF (I.EQ.IEXIT) GO TO 220 I = I + 1 GO TO 190 220 IF (ABS(XEXIT-XRIGHT).LE.EPSGRD) AREA = AREA + . (YEXIT-YDOWN)* (XRIGHT-XLEFT) C C C IF AREA IS LESS THAN OR EQUAL TO DSCARE*(AREA OF THE ELEMENT), C THEN DISCARD THE ELEMENT C C 230 KEEPIT = .TRUE. IF (AREA.LE.DSCARE*AREAEL) KEEPIT = .FALSE. RETURN 9001 FORMAT (/43H *** WARNING--FAILED TO FIND THE ENTRY SIDE, . 28H OF THE BOUNDARY FOR ELEMENT, . 2I4/39H WHILE DECIDING WHETHER OR, . 16H NOT TO KEEP IT./40H ELEMENT DELETED AND EXECUTION CONTINUES) END SUBROUTINE LSTCOL(LAST,NOD,ELTYPE,NGDXM1,NGDYM1,IDCOEF,MXNEQ, . MXNCOE) C C C PURPOSE C C COMPUTE MATRIX COLUMN INDICIES FOR MATRIX COEFFICIENTS C CORRESPONDING TO THE NODES ON THE RIGHT EDGE OF THE C RECTANGULAR GRID (THE LINE X=BX) C C C PARAMETERS C C LAST - Y INDEX OF THE TOP ELEMENT IN THE LAST COLUMN C NOD - NODE COUNT C C INTEGER ELTYPE(NGDXM1,NGDYM1),IDCOEF(MXNEQ,MXNCOE) C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP,BPTYPE REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C IF THE TOP ELEMENT IN ONE OF THE LAST TWO COLUMNS OF ELEMENTS C WAS KEPT, AN EXTRA NODE MUST BE ADDED FOR THE TOP NODE. C IF (LAST.NE.NGDYM1 .AND. ELTYPE(NGRIDX-2,NGDYM1).LT.0) GO TO 10 C NOD = NOD + 1 ISUB = (NGRIDX-2)*NGDYM1 NODELM(3,ISUB) = NOD ISUB = NGDXM1*NGDYM1 NODELM(4,ISUB) = NOD C C IF NO ELEMENTS WERE SAVED IN THE RIGHTMOST COLUMN OF ELEMENTS, C THEN DONE C 10 IF (LAST.EQ.0) RETURN LAST = 0 DO 50 JY = 1,NGDYM1 IF (ELTYPE(NGDXM1,JY).GT.0) GO TO 20 C C THIS ELEMENT WAS DISCARDED. IF THE ELEMENT BELOW IT WAS NOT C DISCARDED, INCREMENT THE NODE COUNT. C IF (LAST.NE.JY-1 .OR. LAST.EQ.0) GO TO 50 NOD = NOD + 1 ISUB = (NGRIDX-2)*NGDYM1 + JY - 1 IF (JY.NE.1) NODELM(3,ISUB) = NOD ISUB = ISUB + 1 NODELM(2,ISUB) = NOD GO TO 50 C C THIS ELEMENT WAS KEPT, COMPUTE ITS COLUMN INDICIES C FOR THE NODES ON X=BX C 20 NOD = NOD + 1 ISUB = (NGRIDX-2)*NGDYM1 + JY - 1 IF (JY.NE.1) NODELM(3,ISUB) = NOD ISUB = ISUB + 1 NODELM(2,ISUB) = NOD LAST = JY KROW = ELTYPE(NGDXM1,JY)/10000 IROW = ELTYPE(NGDXM1,JY) - KROW*10000 KROW = KROW + IROW - 1 I1 = 4*NOD - 8 DO 40 I = 5,12 DO 30 JROW = IROW,KROW IDCOEF(JROW,I) = I1 + I 30 CONTINUE 40 CONTINUE 50 CONTINUE C C IF THE TOP ELEMENT WAS KEPT, INCREMENT NODE COUNT FOR THE TOP NODE. C IF (LAST.NE.NGDYM1) RETURN NOD = NOD + 1 ISUB = NGDXM1*NGDYM1 NODELM(3,ISUB) = NOD RETURN END SUBROUTINE MAP1(ISIDE,X1,X2,Y1,Y2,XENT,XCENT,YENT,YCENT,XEXT, . XCEXT,YEXT,YCEXT,IENTPT) C C C PURPOSE C C THIS ROUTINE DEFINES THE MAP FOR MAPSQ WHEN THE EXIT SIDE C IS THE FIRST SIDE CLOCKWISE TO THE ENTRY SIDE. THE OTHER C TWO SIDES ARE INTERIOR TO THE DOMAIN. C C PARAMETERS C C ISIDE - TELLS WHICH SIDE OF THE ELEMENT THE BOUNDARY C ENTERS ON C =1 BOTTOM C =2 LEFT C =3 TOP C =4 RIGHT C X1,X2 - X-COORDINATES OF LEFT AND RIGHT SIDES C Y1,Y2 - Y-COORDINATES OF TOP AND BOTTOM C XENT,YENT - COORDINATES OF POINT WHERE BOUNDARY C ENTERS ELEMENT C XCENT,YCENT - COORDINATES OF CORNER OF ELEMENT NEXT TO C POINT WHERE BOUNDARY ENTERS ELEMENT AND C INTERIOR TO DOMAIN C XEXT,YEXT - COORDINATES OF POINT WHERE BOUNDARY C EXITS ELEMENT C XCEXT,YCEXT - COORDINATES OF CORNER OF ELEMENT NEXT TO C POINT WHERE BOUNDARY EXITS ELEMENT AND C INTERIOR TO DOMAIN C IENTPT - INDEX OF POINT WHERE BOUNDARY ENTERS ELEMENT C C METHOD C C THE TWO INTERIOR SIDES ARE MAPPED TO THEMSELVES. C FOR THE ENTRY AND EXIT SIDES, THE ONE WITH THE LARGEST PORTION C OF ITSELF INTERIOR TO THE DOMAIN GETS MAPPED TO ITS INTERIOR C PORTION. FOR THE OTHER SIDE, THE INTERIOR PORTION IS MAPPED C TO ITSELF, AND THE EXTERIOR PORTION IS MAPPED TO THE BOUNDARY. C C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP,BPTYPE REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C COMPUTE SIDE DEPENDENT VALUES. THIS INCLUDES SOME SIDE LENGTHS, C PARTIAL MAPPINGS FOR ENTRY AND EXIT SIDES, AND THE MAPPING C FOR THE TWO INTERIOR SIDES C GO TO (10,40,70,100),ISIDE C C C THE ENTRY SIDE IS THE BOTTOM C C C FIND THE LENGTHS OF THE ENTRY AND EXIT SIDES C 10 ENTLEN = X2 - X1 EXTLEN = Y2 - Y1 C C FIND THE LENGTHS OF THE PARTS OF THE ENTRY AND C EXIT SIDES INSIDE THE DOMAIN C START = XCENT - XENT END = YCEXT - YEXT C C FIND THE RELATIVE LENGTHS OF THE PARTS INSIDE C RSTART = START/ENTLEN REND = END/ENTLEN C C DETERMINE THE SIDE THAT GETS THE BOUNDARY C MAPBND = ISIDE IF (RSTART.GT.REND) MAPBND = ISIDE + 1 IF (MAPBND.EQ.5) MAPBND = 1 C IF (MAPBND.NE.ISIDE) GO TO 20 C C THE ENTRY SIDE GETS THE BOUNDARY C MAP THE EXIT SIDE TO ITSELF C TT(2,2) = 1. IP(2,2) = -1 UP(2,2) = 0. LO(2,2) = XCEXT UPA(2,2) = END LOA(2,2) = YCEXT - END C C MAP THE INTERIOR PART OF THE ENTRY SIDE TO ITSELF C TT(2,1) = START/ENTLEN IP(2,1) = -1 UP(2,1) = -ENTLEN LO(2,1) = XCENT UPA(2,1) = 0. LOA(2,1) = YCENT C C SET SOME CONSTANTS C B1LEN = BLEN/ (1.-TT(2,1)) I = 3 GO TO 30 C C THE EXIT SIDE GETS THE BOUNDARY C MAP THE ENTRY SIDE TO ITSELF C 20 TT(2,1) = 1. IP(2,1) = -1 UP(2,1) = -START LO(2,1) = XCENT UPA(2,1) = 0. LOA(2,1) = YCENT C C MAP THE INTERIOR PART OF THE EXIT SIDE TO ITSELF C SAVE IN TEMPORARY VARIABLES C TEMPUP = 0. TEMPLO = XCEXT TEMUPA = EXTLEN TEMLOA = YCEXT - TEMUPA C C SET SOME CONSTANTS C B1LEN = BLEN/ (1.- (END/EXTLEN)) I = 2 C C MAP THE TWO INTERIOR SIDES TO THEMSELVES C 30 TT(2,3) = 1. IP(2,3) = -1 UP(2,3) = ENTLEN LO(2,3) = XCEXT UPA(2,3) = 0. LOA(2,3) = YCEXT TT(2,4) = 1. IP(2,4) = -1 UP(2,4) = 0. LO(2,4) = XCENT UPA(2,4) = -EXTLEN LOA(2,4) = YCEXT GO TO 130 C C C THE ENTRY SIDE IS THE LEFT C C C FIND THE LENGTHS OF THE ENTRY AND EXIT SIDES C 40 ENTLEN = Y2 - Y1 EXTLEN = X2 - X1 C C FIND THE LENGTHS OF THE PARTS OF THE ENTRY AND EXIT SIDES C INSIDE THE DOMAIN C START = YENT - YCENT END = XCEXT - XEXT C C FIND THE RELATIVE LENGTHS OF THE PARTS INSIDE C RSTART = START/ENTLEN REND = END/ENTLEN C C DETERMINE THE SIDE THAT GETS THE BOUNDARY C MAPBND = ISIDE IF (RSTART.GT.REND) MAPBND = ISIDE + 1 IF (MAPBND.EQ.5) MAPBND = 1 C IF (MAPBND.NE.ISIDE) GO TO 50 C C THE ENTRY SIDE GETS THE BOUNDARY C MAP THE EXIT SIDE TO ITSELF C TT(2,3) = 1. IP(2,3) = -1 UP(2,3) = END LO(2,3) = XEXT UPA(2,3) = 0. LOA(2,3) = YCEXT C C MAP THE INTERIOR PART OF THE ENTRY SIDE TO ITSELF C TT(2,2) = START/ENTLEN IP(2,2) = -1 UP(2,2) = 0. LO(2,2) = XCENT UPA(2,2) = ENTLEN LOA(2,2) = YCENT C C SET SOME CONSTANTS C B1LEN = BLEN/ (1.-TT(2,2)) I = 3 GO TO 60 C C THE EXIT SIDE GETS THE BOUNDARY C MAP THE ENTRY SIDE TO ITSELF C 50 TT(2,2) = 1. IP(2,2) = -1 UP(2,2) = 0. LO(2,2) = XCENT UPA(2,2) = START LOA(2,2) = YCENT C C MAP THE INTERIOR PART OF THE EXIT SIDE TO ITSELF C SAVE IN TEMPORARY VARIABLES C TEMPUP = EXTLEN TEMPLO = XCEXT - TEMPUP TEMUPA = 0. TEMLOA = YCEXT C C SET SOME CONSTANTS C B1LEN = BLEN/ (1.- (END/EXTLEN)) I = 2 C C MAP THE TWO INTERIOR SIDES TO THEMSELVES C 60 TT(2,4) = 1. IP(2,4) = -1 UP(2,4) = 0. LO(2,4) = XCEXT UPA(2,4) = -ENTLEN LOA(2,4) = YCEXT TT(2,1) = 1. IP(2,1) = -1 UP(2,1) = -EXTLEN LO(2,1) = XCEXT UPA(2,1) = 0. LOA(2,1) = YCENT GO TO 130 C C C THE ENTRY SIDE IS THE TOP C C C FIND THE LENGTHS OF THE ENTRY AND EXIT SIDES C 70 ENTLEN = X2 - X1 EXTLEN = Y2 - Y1 C C FIND THE LENGTHS OF THE PARTS OF THE ENTRY AND EXIT SIDES C INSIDE THE DOMAIN C START = XENT - XCENT END = YEXT - YCEXT C C FIND THE RELATIVE LENGTHS OF THE PARTS INSIDE C RSTART = START/ENTLEN REND = END/ENTLEN C C DETERMINE THE SIDE THAT GETS THE BOUNDARY C MAPBND = ISIDE IF (RSTART.GT.REND) MAPBND = ISIDE + 1 IF (MAPBND.EQ.5) MAPBND = 1 C IF (MAPBND.NE.ISIDE) GO TO 80 C C THE ENTRY SIDE GETS THE BOUNDARY C MAP THE EXIT SIDE TO ITSELF C TT(2,4) = 1. IP(2,4) = -1 UP(2,4) = 0. LO(2,4) = XCEXT UPA(2,4) = -END LOA(2,4) = YCEXT + END C C MAP THE INTERIOR PART OF THE ENTRY SIDE TO ITSELF C TT(2,3) = START/ENTLEN IP(2,3) = -1 UP(2,3) = ENTLEN LO(2,3) = XCENT UPA(2,3) = 0. LOA(2,3) = YCENT C C SET SOME CONSTANTS C B1LEN = BLEN/ (1.-TT(2,3)) I = 3 GO TO 90 C C THE EXIT SIDE GETS THE BOUNDARY C MAP THE ENTRY SIDE TO ITSELF C 80 TT(2,3) = 1. IP(2,3) = -1 UP(2,3) = START LO(2,3) = XCENT UPA(2,3) = 0. LOA(2,3) = YCENT C C MAP THE INTERIOR PART OF THE EXIT SIDE TO ITSELF C SAVE IN TEMPORARY VARIABLES C TEMPUP = 0. TEMPLO = XCEXT TEMUPA = -EXTLEN TEMLOA = YCEXT - TEMUPA C C SET SOME CONSTANTS C B1LEN = BLEN/ (1.- (END/EXTLEN)) I = 2 C C MAP THE TWO INTERIOR SIDES TO THEMSELVES C 90 TT(2,1) = 1. IP(2,1) = -1 UP(2,1) = -ENTLEN LO(2,1) = XCEXT UPA(2,1) = 0. LOA(2,1) = YCEXT TT(2,2) = 1. IP(2,2) = -1 UP(2,2) = 0. LO(2,2) = XCENT UPA(2,2) = EXTLEN LOA(2,2) = YCEXT GO TO 130 C C C THE ENTRY SIDE IS THE RIGHT C C C FIND THE LENGTHS OF THE ENTRY AND EXIT SIDES C 100 ENTLEN = Y2 - Y1 EXTLEN = X2 - X1 C C FIND THE LENGTHS OF THE PARTS OF THE ENTRY AND EXIT SIDES C INSIDE THE DOMAIN C START = YCENT - YENT END = XEXT - XCEXT C C FIND THE RELATIVE LENGTHS OF THE PARTS INSIDE C RSTART = START/ENTLEN REND = END/ENTLEN C C DETERMINE THE SIDE THAT GETS THE BOUNDARY C MAPBND = ISIDE IF (RSTART.GT.REND) MAPBND = ISIDE + 1 IF (MAPBND.EQ.5) MAPBND = 1 C IF (MAPBND.NE.ISIDE) GO TO 110 C C THE ENTRY SIDE GETS THE BOUNDARY C MAP THE EXIT SIDE TO ITSELF C TT(2,1) = 1. IP(2,1) = -1 UP(2,1) = -END LO(2,1) = XEXT UPA(2,1) = 0. LOA(2,1) = YCEXT C C MAP THE INTERIOR PART OF THE ENTRY SIDE TO ITSELF C TT(2,4) = START/ENTLEN IP(2,4) = -1 UP(2,4) = 0. LO(2,4) = XCENT UPA(2,4) = -ENTLEN LOA(2,4) = YCENT C C SET SOME CONSTANTS C B1LEN = BLEN/ (1.-TT(2,4)) I = 3 GO TO 120 C C THE EXIT SIDE GETS THE BOUNDARY C MAP THE ENTRY SIDE TO ITSELF C 110 TT(2,4) = 1. IP(2,4) = -1 UP(2,4) = 0. LO(2,4) = XCENT UPA(2,4) = -START LOA(2,4) = YCENT C C MAP THE INTERIOR PART OF THE EXIT SIDE TO ITSELF C SAVE IN TEMPORARY VARIABLES C TEMPUP = -EXTLEN TEMPLO = XCEXT - TEMPUP TEMUPA = 0. TEMLOA = YCEXT C C SET SOME CONSTANTS C B1LEN = BLEN/ (1.- (END/EXTLEN)) I = 2 C C MAP THE TWO INTERIOR SIDES TO THEMSELVES C 120 TT(2,2) = 1. IP(2,2) = -1 UP(2,2) = 0. LO(2,2) = XCEXT UPA(2,2) = ENTLEN LOA(2,2) = YCEXT TT(2,3) = 1. IP(2,3) = -1 UP(2,3) = EXTLEN LO(2,3) = XCEXT UPA(2,3) = 0. LOA(2,3) = YCENT C C -DONE WITH SIDE DEPENDENT VALUES- C MAP THE APPROPRIATE SIDE TO THE BOUNDARY C 130 IPT = IENTPT DO 150 ISEG = 1,NSEG IF (IPT.GT.NBNDPT) IPT = 1 TT(I,MAPBND) = TT(I-1,MAPBND) + SEGLEN(ISEG)/B1LEN IP(I,MAPBND) = PIECE(IPT) LO(I,MAPBND) = BPARAM(IPT) IPT = IPT + 1 UP(I,MAPBND) = BPARAM(IPT) ISUB = PIECE(IPT) IF (ISUB.EQ.IP(I,MAPBND)) GO TO 140 IP(I,MAPBND) = ISUB LO(I,MAPBND) = BRANGE(1,ISUB) 140 I = I + 1 150 CONTINUE C C SET THE LAST TT TO 1. TO AVOID ROUNDOFF C IF (MAPBND.EQ.ISIDE) TT(I-1,MAPBND) = 1. C C IF THE EXIT SIDE GOT THE BOUNDARY, C MAP THE INTERIOR PART OF THE EXIT SIDE TO ITSELF C IF (MAPBND.EQ.ISIDE) RETURN TT(I,MAPBND) = 1. IP(I,MAPBND) = -1 UP(I,MAPBND) = TEMPUP LO(I,MAPBND) = TEMPLO UPA(I,MAPBND) = TEMUPA LOA(I,MAPBND) = TEMLOA RETURN END SUBROUTINE MAP2(XENT,XCENT,YENT,YCENT,XEXT,XCEXT,YEXT,YCEXT,ISIDE, . IENTPT,IEXTPT) C C C PURPOSE C THIS ROUTINE DEFINES THE MAPPING FOR MAPSQ IF THE BOUNDARY C EXITS ON THE SIDE OPPOSITE THE SIDE IT ENTERED ON. C C PARAMETERS C C ISIDE - TELLS WHICH SIDE OF THE ELEMENT THE BOUNDARY C ENTERS ON C =1 BOTTOM C =2 LEFT C =3 TOP C =4 RIGHT C XENT,YENT - COORDINATES OF POINT WHERE BOUNDARY C ENTERS ELEMENT C XCENT,YCENT - COORDINATES OF CORNER OF ELEMENT NEXT TO C POINT WHERE BOUNDARY ENTERS ELEMENT AND C INTERIOR TO DOMAIN C XEXT,YEXT - COORDINATES OF POINT WHERE BOUNDARY C EXITS ELEMENT C XCEXT,YCEXT - COORDINATES OF CORNER OF ELEMENT NEXT TO C POINT WHERE BOUNDARY EXITS ELEMENT AND C INTERIOR TO DOMAIN C IENTPT - INDEX OF POINT WHERE BOUNDARY ENTERS ELEMENT C IEXTPT - INDEX OF POINT WHERE BOUNDARY EXITS ELEMENT C C METHOD C C MAPS ENTRY AND EXIT SIDES ONTO THEIR PORTION WHICH IS C INTERIOR TO THE DOMAIN, THE SIDE WHICH IS EXTERIOR C (FIRST SIDE CLOCKWISE TO ENTRY SIDE) TO THE DOMAIN BOUNDARY, C AND THE SIDE THAT IS INTERIOR TO ITSELF C INTEGER JROT(4,4) C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP,BPTYPE REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C DATA JROT(1,1),JROT(2,1),JROT(3,1),JROT(4,1),JROT(1,2),JROT(2,2), . JROT(3,2),JROT(4,2),JROT(1,3),JROT(2,3),JROT(3,3),JROT(4,3), . JROT(1,4),JROT(2,4),JROT(3,4),JROT(4,4)/2,3,4,1,3,4,1,2,4,1, . 2,3,1,2,3,4/ C C C MAP THE EXTERIOR SIDE TO THE BOUNDARY OF THE DOMAIN C JSUB = IENTPT IS = JROT(1,ISIDE) TT(1,IS) = 0. DO 10 ISEG = 1,NSEG ISUB = JSUB IF (ISUB.GT.NBNDPT) ISUB = 1 JSUB = JSUB + 1 IF (JSUB.GT.NBNDPT+1) JSUB = 2 TT(ISEG+1,IS) = SEGLEN(ISEG)/BLEN + TT(ISEG,IS) IP(ISEG+1,IS) = PIECE(ISUB) LO(ISEG+1,IS) = BPARAM(ISUB) UP(ISEG+1,IS) = BPARAM(JSUB) KSUB = PIECE(JSUB) IF (KSUB.EQ.IP(ISEG+1,IS)) GO TO 10 IP(ISEG+1,IS) = KSUB LO(ISEG+1,IS) = BRANGE(1,KSUB) 10 CONTINUE C C C SET THE LAST TT TO 1. TO AVOID ROUNDOFF ERRORS C TT(NSEG+1,IS) = 1. C C MAP THE TWO PARTIALLY INTERIOR SIDES TO THEIR INTERIOR PORTIONS C AND THE INTERIOR SIDE TO ITSELF C DO 20 I = 2,4 KSUB = JROT(I,ISIDE) TT(1,KSUB) = 0. TT(2,KSUB) = 1. IP(2,KSUB) = -1 20 CONTINUE C KSUB = JROT(2,ISIDE) UP(2,KSUB) = XCEXT - XEXT LO(2,KSUB) = XEXT UPA(2,KSUB) = YCEXT - YEXT LOA(2,KSUB) = YEXT KSUB = JROT(3,ISIDE) UP(2,KSUB) = XCENT - XCEXT LO(2,KSUB) = XCEXT UPA(2,KSUB) = YCENT - YCEXT LOA(2,KSUB) = YCEXT KSUB = JROT(4,ISIDE) UP(2,KSUB) = XENT - XCENT LO(2,KSUB) = XCENT UPA(2,KSUB) = YENT - YCENT LOA(2,KSUB) = YCENT RETURN END SUBROUTINE MAP3(IENTSD,IENTPT,XENT,YENT,XEXT,YEXT,XC,YC,XO,YO) C C C PURPOSE C C THIS ROUTINE DEFINES THE MAPPING FOR MAPSQ WHEN THE C EXIT SIDE IS THE FIRST SIDE COUNTERCLOCKWISE TO THE C ENTRY SIDE C C PARAMETERS C C IENTSD - TELLS WHICH SIDE OF THE ELEMENT THE BOUNDARY C ENTERS ON C =1 BOTTOM C =2 LEFT C =3 TOP C =4 RIGHT C XENT,YENT - COORDINATES OF POINT WHERE BOUNDARY C ENTERS ELEMENT C XC,YC - COORDINATES OF CORNER OF ELEMENT NEXT TO C POINT WHERE BOUNDARY ENTERS ELEMENT AND C INTERIOR TO DOMAIN C XEXT,YEXT - COORDINATES OF POINT WHERE BOUNDARY C EXITS ELEMENT C XO,YO - COORDINATES OF CORNER OF ELEMENT NEXT TO C POINT WHERE BOUNDARY EXITS ELEMENT AND C EXTERIOR TO DOMAIN C IENTPT - INDEX OF POINT WHERE BOUNDARY ENTERS ELEMENT C C METHOD C C IT MAPS THE ENTRY AND EXIT SIDES TO THEIR INTERIOR PORTIONS, C AND THE OTHER TWO SIDES TO THE DOMAIN BOUNDARY. C IF THERE IS A DOMAIN BOUNDARY CORNER IN THE ELEMENT, THEN C THE CORNER GETS MAPPED TO THAT. OTHERWISE, THE CORNER IS C MAPPED TO THE POINT WHICH CUTS THE BOUNDARY SUCH THAT THE C RATIO OF THE LENGTH OF THE TWO MAPPED SEGMENTS IS THE SAME C AS THE RATIO OF THE LENGTH OF THE TWO ELEMENT SIDES. C C INTEGER CUTSEG REAL NXTPAR C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP,BPTYPE REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C C MAP ENTRY SIDE TO ITS INTERIOR PORTION C TT(2,IENTSD) = 1. IP(2,IENTSD) = -1 UP(2,IENTSD) = XENT - XC LO(2,IENTSD) = XC UPA(2,IENTSD) = YENT - YC LOA(2,IENTSD) = YC C C MAP EXIT SIDE TO ITS INTERIOR PORTION C ISIDE = IENTSD - 1 IF (ISIDE.EQ.0) ISIDE = 4 TT(2,ISIDE) = 1. IP(2,ISIDE) = -1 UP(2,ISIDE) = XC - XEXT LO(2,ISIDE) = XEXT UPA(2,ISIDE) = YC - YEXT LOA(2,ISIDE) = YEXT C C MAP THE OTHER TWO SIDES TO THE DOMAIN BOUNDARY C C IF THERE ARE EXACTLY TWO BOUNDARY SEGMENTS, DIVIDE C THE BOUNDARY AT THE POINT BETWEEN THE SEGMENTS C IF (NSEG.EQ.2) GO TO 100 C C OTHERWISE, DIVIDE IT SO THAT THE RATIO OF THE LENGTHS OF C THE TWO BOUNDARY PARTS IS THE SAME AS THE RATIO OF C THE LENGTHS OF THE TWO ELEMENT SIDES C C FIND WHERE TO CUT THE DOMAIN BOUNDARY C XDIF = ABS(XO-XC) YDIF = ABS(YO-YC) DENOM = XDIF + YDIF IF (IENTSD.EQ.1 .OR. IENTSD.EQ.3) XDIF = YDIF BCUT = XDIF/DENOM C C FIND THE LENGTHS OF THE CURVES THE TWO SIDES WILL BE MAPPED TO C B1LEN = BCUT*BLEN B2LEN = BLEN - B1LEN C C FIND THE BOUNDARY SEGMENT THAT CONTAINS THE CUT POINT C SOFAR = 0. CUTSEG = 0 10 CUTSEG = CUTSEG + 1 SOFAR = SOFAR + SEGLEN(CUTSEG) IF (SOFAR.LT.B1LEN) GO TO 10 C C MAP THE FIRST SIDE CLOCKWISE TO THE ENTRY SIDE TO THE C FIRST PART OF THE DOMAIN BOUNDARY C ISIDE = IENTSD + 1 IF (ISIDE.EQ.5) ISIDE = 1 IPT = IENTPT LIM = CUTSEG - 1 I = 2 C C MAP TO THE SEGMENTS BEFORE THE CUT SEGMENT C IF (LIM.EQ.0) GO TO 40 DO 30 ISEG = 1,LIM IF (IPT.GT.NBNDPT) IPT = 1 TT(I,ISIDE) = TT(I-1,ISIDE) + SEGLEN(ISEG)/B1LEN IP(I,ISIDE) = PIECE(IPT) LO(I,ISIDE) = BPARAM(IPT) IPT = IPT + 1 UP(I,ISIDE) = BPARAM(IPT) ISUB = PIECE(IPT) IF (ISUB.EQ.IP(I,ISIDE)) GO TO 20 IP(I,ISIDE) = ISUB LO(I,ISIDE) = BRANGE(1,ISUB) 20 I = I + 1 30 CONTINUE C C MAP TO THE PART OF THE CUT SEGMENT THAT THE FIRST SIDE GOES TO C 40 TT(I,ISIDE) = 1. IF (IPT.GT.NBNDPT) IPT = 1 IP(I,ISIDE) = PIECE(IPT) LO(I,ISIDE) = BPARAM(IPT) IPT = IPT + 1 NXTPAR = BPARAM(IPT) ISUB = PIECE(IPT) IF (ISUB.EQ.IP(I,ISIDE)) GO TO 50 IP(I,ISIDE) = ISUB LO(I,ISIDE) = BRANGE(1,ISUB) 50 UP(I,ISIDE) = LO(I,ISIDE) + (NXTPAR-LO(I,ISIDE))* . (1.-TT(I-1,ISIDE))*B1LEN/SEGLEN(CUTSEG) C C MAP THE REST OF THE CUT SEGMENT TO THE OTHER SIDE C JSIDE = ISIDE + 1 IF (JSIDE.EQ.5) JSIDE = 1 C C DONT KNOW WHAT TT IS NOW. ADJUST LATER C TT(2,JSIDE) = 0. IP(2,JSIDE) = IP(I,ISIDE) UP(2,JSIDE) = NXTPAR LO(2,JSIDE) = UP(I,ISIDE) C C MAP THE REST OF THE OTHER SIDE TO THE REST OF THE DOMAIN BOUNDARY C LIM = CUTSEG + 1 I = 3 IF (LIM.GT.NSEG) GO TO 80 DO 70 ISEG = LIM,NSEG IF (IPT.GT.NBNDPT) IPT = 1 TT(I,JSIDE) = TT(I-1,JSIDE) + SEGLEN(ISEG)/B2LEN IP(I,JSIDE) = PIECE(IPT) LO(I,JSIDE) = BPARAM(IPT) IPT = IPT + 1 UP(I,JSIDE) = BPARAM(IPT) ISUB = PIECE(IPT) IF (ISUB.EQ.IP(I,JSIDE)) GO TO 60 IP(I,JSIDE) = ISUB LO(I,JSIDE) = BRANGE(1,ISUB) 60 I = I + 1 70 CONTINUE C C ADJUST THE TTS C 80 LIM = I - 1 ADJUST = 1. - TT(LIM,JSIDE) DO 90 I = 2,LIM TT(I,JSIDE) = TT(I,JSIDE) + ADJUST 90 CONTINUE C C SET THE LAST TT TO 1. TO AVOID ROUNDOFF ERRORS C TT(LIM,JSIDE) = 1. RETURN C C C SPECIAL CASE. TWO BOUNDARY SEGMENTS C C C MAP THE FIRST SIDE CLOCKWISE TO THE ENTRY SIDE C TO THE FIRST BOUNDARY SEGMENT C 100 ISIDE = IENTSD + 1 IF (ISIDE.EQ.5) ISIDE = 1 TT(2,ISIDE) = 1. IPT = IENTPT + 1 IP(2,ISIDE) = PIECE(IPT) UP(2,ISIDE) = BPARAM(IPT) LO(2,ISIDE) = BPARAM(IENTPT) ISUB = IP(2,ISIDE) IF (PIECE(IENTPT).NE.ISUB) LO(2,ISIDE) = BRANGE(1,ISUB) C C MAP THE NEXT SIDE TO THE SECOND BOUNDARY SEGMENT C ISIDE = ISIDE + 1 IF (ISIDE.EQ.5) ISIDE = 1 TT(2,ISIDE) = 1. IPT = IPT + 1 IF (IPT.GT.NBNDPT+1) IPT = 2 JPT = IPT - 1 IP(2,ISIDE) = PIECE(IPT) UP(2,ISIDE) = BPARAM(IPT) LO(2,ISIDE) = BPARAM(JPT) ISUB = IP(2,ISIDE) IF (PIECE(JPT).NE.ISUB) LO(2,ISIDE) = BRANGE(1,ISUB) RETURN END SUBROUTINE MAP4(ISIDE,XENT,XEXT,YENT,YEXT,H1,H2,IENTPT) C C C PURPOSE C C THIS ROUTINE DEFINES THE MAPPING FOR MAPSQ IF THE BOUNDARY C EXITS ON THE SAME SIDE IT ENTERS ON. IN THIS CASE, THE C OTHER THREE SIDES ARE ALL EXTERIOR TO THE DOMAIN. C C PARAMETERS C C ISIDE - TELLS WHICH SIDE OF THE ELEMENT THE BOUNDARY C ENTERS ON C =1 BOTTOM C =2 LEFT C =3 TOP C =4 RIGHT C XENT,YENT - COORDINATES OF POINT WHERE BOUNDARY C ENTERS ELEMENT C XEXT,YEXT - COORDINATES OF POINT WHERE BOUNDARY C EXITS ELEMENT C IENTPT - INDEX OF POINT WHERE BOUNDARY ENTERS ELEMENT C H1,H2 - LENGTH OF X AND Y SIDES OF ELEMENT C C METHOD C C IT MAPS THE ENTRY/EXIT SIDE TO ITS INTERIOR PORTION. C THE OTHER THREE SIDES ARE MAPPED TO THE DOMAIN BOUNDARY. C IN GENERAL, THE BOUNDARY IS SPLIT ACCORDING TO THE RELATIVE C LENGTHS OF THE ELEMENT SIDE. IF THEIR ARE TWO BOUNDARY C SEGMENTS, EITHER THE FIRST OR THIRD SIDE IS MAPPED TO ONE C SEGMENT (DEPENDING ON WHICH SEGMENT IS SHORTER) AND THE OTHER C TWO SIDES ARE MAPPED TO THE OTHER SEGMENT. IF THERE ARE THREE C BOUNDARY SEGMENTS, EACH SIDE GETS MAPPED TO ONE SEGMENT. C INTEGER CUTSEG,CUTSG2 REAL NXTPAR C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP,BPTYPE REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C C C MAP THE PARTIALLY INTERIOR SIDE TO ITS INTERIOR PORTION C TT(2,ISIDE) = 1. IP(2,ISIDE) = -1 UP(2,ISIDE) = XENT - XEXT LO(2,ISIDE) = XEXT UPA(2,ISIDE) = YENT - YEXT LOA(2,ISIDE) = YEXT C C MAP THE OTHER SIDES TO THE DOMAIN BOUNDARY C C IF THERE ARE EXACTLY TWO SEGMENTS MAP ONE SIDE TO ONE SEGMENT C AND THE OTHER TWO SIDES TO THE OTHER SEGMENT C IF (NSEG.EQ.2) GO TO 170 C C IF THERE ARE EXACTLY THREE SEGMENTS MAP EACH SIDE TO A SEGMENT C IF (NSEG.EQ.3) GO TO 220 C C OTHERWISE, DIVIDE THE BOUNDARY AMONG THE THREE SIDES SUCH THAT C THE LENGTHS OF THE BOUNDARY PARTS ARE SIMILAR TO THE LENGTHS C OF THE ELEMENT SIDES C C FIND WHERE TO CUT THE DOMAIN BOUNDARY C BCUT = H1/ (2.*H1+H2) C C FIND THE LENGTHS OF THE CURVES THE THREE SIDES WILL BE MAPPED TO C B1LEN = BCUT*BLEN B2LEN = BLEN - 2.*B1LEN C C FIND THE BOUNDARY SEGMENT THAT CONTAINS THE FIRST CUT POINT C SOFAR = 0. CUTSEG = 0 10 CUTSEG = CUTSEG + 1 SOFAR = SOFAR + SEGLEN(CUTSEG) IF (SOFAR.LT.B1LEN) GO TO 10 C C MAP THE FIRST SIDE CLOCKWISE TO THE PARTIALLY INTERIOR SIDE C TO THE FIRST PART OF THE DOMAIN BOUNDARY C JSIDE = ISIDE + 1 IF (JSIDE.EQ.5) JSIDE = 1 IPT = IENTPT LIM = CUTSEG - 1 I = 2 C C MAP THE SEGMENTS BEFORE THE CUT SEGMENT C IF (LIM.EQ.0) GO TO 40 DO 30 ISEG = 1,LIM IF (IPT.GT.NBNDPT) IPT = 1 TT(I,JSIDE) = TT(I-1,JSIDE) + SEGLEN(ISEG)/B1LEN IP(I,JSIDE) = PIECE(IPT) LO(I,JSIDE) = BPARAM(IPT) IPT = IPT + 1 UP(I,JSIDE) = BPARAM(IPT) ISUB = PIECE(IPT) IF (ISUB.EQ.IP(I,JSIDE)) GO TO 20 IP(I,JSIDE) = ISUB LO(I,JSIDE) = BRANGE(1,ISUB) 20 I = I + 1 30 CONTINUE C C MAP TO THE PART OF THE CUT SEGMENT THAT THE FIRST SIDE GOES TO C 40 TT(I,JSIDE) = 1. IF (IPT.GT.NBNDPT) IPT = 1 IP(I,JSIDE) = PIECE(IPT) LO(I,JSIDE) = BPARAM(IPT) IPT = IPT + 1 NXTPAR = BPARAM(IPT) ISUB = PIECE(IPT) IF (ISUB.EQ.IP(I,JSIDE)) GO TO 50 IP(I,JSIDE) = ISUB LO(I,JSIDE) = BRANGE(1,ISUB) 50 UP(I,JSIDE) = LO(I,JSIDE) + (NXTPAR-LO(I,JSIDE))* . (1.-TT(I-1,JSIDE))*B1LEN/SEGLEN(CUTSEG) C C MAP THE SECOND SIDE C TEMP = UP(I,JSIDE) IPIECE = IP(I,JSIDE) JSIDE = JSIDE + 1 IF (JSIDE.EQ.5) JSIDE = 1 C C FIND THE BOUNDARY SEGMENT THAT CONTAINS THE SECOND CUT POINT C CUTSG2 = CUTSEG TARGET = B1LEN + B2LEN IF (SOFAR.GE.TARGET) GO TO 110 60 CUTSG2 = CUTSG2 + 1 SOFAR = SOFAR + SEGLEN(CUTSG2) IF (SOFAR.LT.TARGET) GO TO 60 C C MAP THE BEGINNING OF THE SECOND SIDE TO THE REST OF THE FIRST CUT SEGM C CALL BCOORD(TEMP,X,Y,IPIECE) XDIF = XBOUND(IPT) - X YDIF = YBOUND(IPT) - Y DIST = SQRT(XDIF*XDIF+YDIF*YDIF) TT(2,JSIDE) = DIST/B2LEN IP(2,JSIDE) = PIECE(IPT) UP(2,JSIDE) = NXTPAR LO(2,JSIDE) = TEMP C C MAP TO THE SEGMENTS BETWEEN THE CUT SEGMENTS C I = 3 LOLIM = CUTSEG + 1 LIM = CUTSG2 - 1 IF (LIM.LT.LOLIM) GO TO 90 DO 80 ISEG = LOLIM,LIM IF (IPT.GT.NBNDPT) IPT = 1 TT(I,JSIDE) = TT(I-1,JSIDE) + SEGLEN(ISEG)/B2LEN IP(I,JSIDE) = PIECE(IPT) LO(I,JSIDE) = BPARAM(IPT) IPT = IPT + 1 UP(I,JSIDE) = BPARAM(IPT) ISUB = PIECE(IPT) IF (ISUB.EQ.IP(I,JSIDE)) GO TO 70 IP(I,JSIDE) = ISUB LO(I,JSIDE) = BRANGE(1,ISUB) 70 I = I + 1 80 CONTINUE C C MAP TO THE PART OF THE SECOND CUT SEGMENT THAT THE SECOND SIDE GOES TO C 90 TT(I,JSIDE) = 1. IF (IPT.GT.NBNDPT) IPT = 1 IP(I,ISIDE) = PIECE(IPT) LO(I,ISIDE) = BPARAM(IPT) IPT = IPT + 1 NXTPAR = BPARAM(IPT) ISUB = PIECE(IPT) IF (ISUB.EQ.IP(I,JSIDE)) GO TO 100 IP(I,JSIDE) = ISUB LO(I,JSIDE) = BRANGE(1,ISUB) 100 UP(I,JSIDE) = LO(I,JSIDE) + (NXTPAR-LO(I,JSIDE))* . (1.-TT(I-1,JSIDE))*B2LEN/SEGLEN(CUTSG2) GO TO 120 C C SPECIAL CASE FOR MAPPING SECOND SIDE IF CUTSEG=CUTSG2 C 110 TT(2,JSIDE) = 1. IP(2,JSIDE) = PIECE(IPT) LO(2,JSIDE) = TEMP IPIECE = PIECE(IPT) CALL BCOORD(TEMP,X,Y,IPIECE) XDIF = XBOUND(IPT) - X YDIF = YBOUND(IPT) - Y DENOM = SQRT(XDIF*XDIF+YDIF*YDIF) UP(2,JSIDE) = LO(2,JSIDE) + (NXTPAR-LO(2,JSIDE))*B2LEN/DENOM I = 2 C C MAP THE THIRD SIDE C 120 TEMP = UP(I,JSIDE) JSIDE = JSIDE + 1 IF (JSIDE.EQ.5) JSIDE = 1 C C MAP THE REST OF THE CUTSEGMENT TO THE THIRD SIDE C ADJUST THE TTS LATER C TT(2,JSIDE) = 0. IP(2,JSIDE) = PIECE(IPT) UP(2,JSIDE) = NXTPAR LO(2,JSIDE) = TEMP C C MAP THE REST OF THE THIRD SIDE TO THE REST OF THE BOUNDARY C LIM = CUTSG2 + 1 I = 3 IF (LIM.GT.NSEG) GO TO 150 DO 140 ISEG = LIM,NSEG IF (IPT.GT.NBNDPT) IPT = 1 TT(I,JSIDE) = TT(I-1,JSIDE) + SEGLEN(ISEG)/B1LEN IP(I,JSIDE) = PIECE(IPT) LO(I,JSIDE) = BPARAM(IPT) IPT = IPT + 1 UP(I,JSIDE) = BPARAM(IPT) ISUB = PIECE(IPT) IF (ISUB.EQ.IP(I,JSIDE)) GO TO 130 IP(I,JSIDE) = ISUB LO(I,JSIDE) = BRANGE(1,ISUB) 130 I = I + 1 140 CONTINUE C C ADJSUT THE TTS C 150 LIM = I - 1 ADJUST = 1. - TT(LIM,JSIDE) DO 160 I = 2,LIM TT(I,JSIDE) = TT(I,JSIDE) + ADJUST 160 CONTINUE TT(LIM,JSIDE) = 1. RETURN C C C SPECIAL CASE - TWO BOUNDARY SEGMENTS C C C IF THE FIRST SEGMENT IS SHORTER, MAP THE FIRST SIDE TO THE FIRST C SEGMENT AND THE OTHER TWO SIDES TO THE SECOND SEGMENT C IF THE SECOND SEGMENT IS SHROTER, MAP THE FIRST AND SECOND SIDES TO C THE FIRST SEGMENT AND THE THIRD SIDE TO THE SECIND SEGMENT C 170 IF (SEGLEN(2).LT.SEGLEN(1)) GO TO 180 C C FIRST CASE C LONESD = ISIDE + 1 IF (LONESD.EQ.5) LONESD = 1 JSIDE = LONESD + 1 IF (JSIDE.EQ.5) JSIDE = 1 LONEPT = IENTPT IPT = IENTPT + 1 IF (IPT.GT.NBNDPT) IPT = 1 HOWFAR = H2/ (H1+H2) GO TO 190 C C SECOND CASE C 180 LONESD = ISIDE - 1 IF (LONESD.EQ.0) LONESD = 4 JSIDE = ISIDE + 1 IF (JSIDE.EQ.5) JSIDE = 1 LONEPT = IENTPT + 1 IF (LONEPT.GT.NBNDPT) LONEPT = 1 IPT = IENTPT HOWFAR = H1/ (H1+H2) C C MAP THE LONE SIDE C 190 TT(2,LONESD) = 1. IP(2,LONESD) = PIECE(LONEPT) LO(2,LONESD) = BPARAM(LONEPT) LONEPT = LONEPT + 1 ISUB = PIECE(LONEPT) IF (ISUB.EQ.IP(2,LONESD)) GO TO 200 IP(2,LONESD) = ISUB LO(2,LONESD) = BRANGE(1,ISUB) 200 UP(2,LONESD) = BPARAM(LONEPT) C C MAP THE OTHER TWO SIDES C C FIRST SIDE C TT(2,JSIDE) = 1. IP(2,JSIDE) = PIECE(IPT) LO(2,JSIDE) = BPARAM(IPT) IPT = IPT + 1 ISUB = PIECE(IPT) IF (ISUB.EQ.IP(2,JSIDE)) GO TO 210 IP(2,JSIDE) = ISUB LO(2,JSIDE) = BRANGE(1,ISUB) 210 UP(2,JSIDE) = (BPARAM(IPT)-LO(2,JSIDE))*HOWFAR + LO(2,JSIDE) C C SECOND SIDE C KSIDE = JSIDE + 1 IF (KSIDE.EQ.5) KSIDE = 1 TT(2,KSIDE) = 1. IP(2,KSIDE) = IP(2,JSIDE) LO(2,KSIDE) = UP(2,JSIDE) UP(2,KSIDE) = BPARAM(IPT) RETURN C C C SPECIAL CASE - THREE BOUNDARY SEGMENTS C C C MAP EACH EXTERIOR SIDE TO ONE OF THE SEGMENTS C C FIRST SIDE C 220 JSIDE = ISIDE + 1 IF (JSIDE.EQ.5) JSIDE = 1 TT(2,JSIDE) = 1. IP(2,JSIDE) = PIECE(IENTPT) LO(2,JSIDE) = BPARAM(IENTPT) IPT = IENTPT + 1 UP(2,JSIDE) = BPARAM(IPT) ISUB = PIECE(IPT) IF (ISUB.EQ.IP(2,JSIDE)) GO TO 230 IP(2,JSIDE) = ISUB LO(2,JSIDE) = BRANGE(1,ISUB) C C SECOND SIDE C 230 JSIDE = JSIDE + 1 IF (JSIDE.EQ.5) JSIDE = 1 IPT = IPT + 1 IF (IPT.GT.NBNDPT) IPT = 2 IPC = PIECE(IPT) TT(2,JSIDE) = 1. IP(2,JSIDE) = IPC LO(2,JSIDE) = BRANGE(1,IPC) UP(2,JSIDE) = BRANGE(2,IPC) C C THIRD SIDE C JSIDE = JSIDE + 1 IF (JSIDE.EQ.5) JSIDE = 1 IPT = IPT + 1 IF (IPT.GT.NBNDPT) IPT = 2 IPC = PIECE(IPT) TT(2,JSIDE) = 1. IP(2,JSIDE) = IPC LO(2,JSIDE) = BRANGE(1,IPC) UP(2,JSIDE) = BPARAM(IPT) RETURN END SUBROUTINE MAPIT(X,Y,XM,YM) C C C PURPOSE C C MAPS THE POINT (X,Y) FROM THE UNIT SQUARE C TO THE INTERSECTION OF AN ELEMENT WITH THE DOMAIN C C PARAMETERS C C X,Y - POINT TO MAP C XM,YM - OUTPUT, IMAGE OF X,Y UNDER THE MAPPING C C METHOD C C USE THE MAPPING DEFINED BY MAPSQ TO MAP THE PROJECTION C OF X,Y ON EACH BOUNDARY SIDE, AND THEN USE BLENDING C TO MAP THE POINT X,Y C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP,BPTYPE REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C XX = 1. - X YY = 1. - Y C C FIND THE IMAGE OF THE PROJECTION OF (X,Y) ONTO EACH C OF THE FOUR SIDES OF THE UNIT SQUARE C X2Y = XBD(Y,2) X4YY = XBD(YY,4) X1XX = XBD(XX,1) X3X = XBD(X,3) Y1XX = YBD(XX,1) Y3X = YBD(X,3) Y2Y = YBD(Y,2) Y4YY = YBD(YY,4) C C USE BLENDING TO FIND THE IMAGE OF (X,Y) C XM = XX*X2Y + X*X4YY + YY* (X1XX-XX*X20-X*X41) + . Y* (X3X-XX*X21-X*X40) YM = YY*Y1XX + Y*Y3X + XX* (Y2Y-YY*Y11-Y*Y30) + . X* (Y4YY-YY*Y10-Y*Y31) RETURN END SUBROUTINE MAPSQ(IENT,IEXT,X1,X2,Y1,Y2,ELTYPE,NGDXM1,NGDYM1) C C C PURPOSE C C DEFINE A MAPPING FROM THE CLOSED UNIT SQUARE TO THE C INTERSECTION OF AN ELEMENT WITH THE DOMAIN C C PARAMETERS C C IENT,IEXT - INDICIES OF POINTS WHERE BOUNDARY ENTERS C AND EXITS THE ELEMENT C X1,X2,Y1,Y2 - COORDINATES OF LEFT, RIGHT, BOTTOM AND TOP C OF ELEMENT C TT,UP,LO,UPA, - OUTPUT, REPRESENT THE MAPPING FOR THE C LOA,IP BOUNDARY OF THE UNIT SQUARE(SEE BELOW). C INTERIOR IS MAPPED BY BLENDING. C C METHOD C C THE MAPPING OF THE BOUNDARY OF THE UNIT SQUARE TO THE C BOUNDARY OF THE RANGE OF THE MAPPING IS HANDLED BY MAP1, C MAP2, MAP3, OR MAP4. USE MAPI IF I CORNERS ARE EXITERIOR C TO THE DOMAIN. THE MAPPING IS RETURNED IN COMMON / COLICP /. C C TO MAP A POINT (X,Y) IN THE CLOSED UNIT SQUARE TO A POINT C (XI,ETA) IN THE INTERSECTION OF THE ELEMENT AND DOMAIN, LET C C XI = (1-X) * FX2(Y) + X * FX4(1-Y) C +(1-Y) * (FX1(1-X) - (1-X) * FX2(0) - X * FX1(0)) C + Y * (FX3(X) - (1-X) * FX3(0) - X * FX4(0)) C C ETA= (1-Y) * FY1(1-X) + Y * FY3(X) C +(1-X) * (FY2(Y) - (1-Y) * FY2(0) - Y * FY3(0)) C + X * (FY4(1-Y) - (1-Y) * FY1(0) - Y * FY4(0)) C C WHERE FXI AND FYI,I=1..4, REPRESENT THE X AND Y COORDINATES OF C THE FUNCTION FI,I=1..4, RESPECTIVELY. FI(T),I=1..4, IS C COMPUTED BY C C 1) FIND THE FIRST K>=2 SUCH THAT TT(K,I) >= T C C 2) IF IP(K,I) = -1 THEN C FXI(T) = UP(K,I)*T + LO(K,I) C FYI(T) = UPA(K,I)*T + LOA(K,I) C C 3) OTHERWISE C P = ((TT(K,I)-T)*LO(K,I) + (T-TT(K-1,I))*UP(K,I)) / C (TT(K,I)-TT(K-1,I)) C C CALL BCOORD(P,FXI,FYI,IP(K,I)) C C INTEGER ELTYPE(NGDXM1,NGDYM1),IENTMP(8),IEXTMP(8) C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP,BPTYPE REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPS COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C DATA IEXTMP(1),IEXTMP(2),IEXTMP(3),IEXTMP(4),IEXTMP(5),IEXTMP(6), . IEXTMP(7),IEXTMP(8)/1,3,2,2,3,4,1,4/ DATA IENTMP(1),IENTMP(2),IENTMP(3),IENTMP(4),IENTMP(5),IENTMP(6), . IENTMP(7),IENTMP(8)/1,3,2,1,2,4,4,3/ C C C IF ENTRY AND/OR EXIT POINTS ARE EXTRA POINTS, FIND THE C REAL ENTRY AND/OR EXIT POINT C C CHECK ENTRY C IENTPT = IENT IF (IENTPT.LE.NBNDPT) GO TO 10 C C IT IS EXTRA, FIND THE REAL POINT C IXX = BGRID(IENT) JYY = BNEIGH(IENT) IENTPT = -ELTYPE(IXX,JYY)/1000 C C CHECK EXIT C 10 IEXTPT = IEXT IF (IEXTPT.LE.NBNDPT) GO TO 20 IXX = BGRID(IEXT) JYY = BNEIGH(IEXT) IEXTPT = 1000* (ELTYPE(IXX,JYY)/1000) - ELTYPE(IXX,JYY) 20 XENT = XBOUND(IENTPT) YENT = YBOUND(IENTPT) XEXT = XBOUND(IEXTPT) YEXT = YBOUND(IEXTPT) C C COMPUTE THE NUMBER OF SEGMENTS OF THE BOUNDARY INTERSECTING C THIS ELEMENT C NSEG = IEXTPT - IENTPT IF (NSEG.LT.0) NSEG = NSEG + NBNDPT C C COMPUTE (A LINEAR APPROXIMATION TO) THE LENGTHS OF THE C BOUNDARY SEGMENTS, AND THE TOTAL LENGTH, BLEN C JSUB = IENTPT BLEN = 0. DO 30 ISEG = 1,NSEG ISUB = JSUB JSUB = JSUB + 1 IF (JSUB.GT.NBNDPT) JSUB = 1 XDIF = XBOUND(JSUB) - XBOUND(ISUB) YDIF = YBOUND(JSUB) - YBOUND(ISUB) SEGLEN(ISEG) = SQRT(XDIF*XDIF+YDIF*YDIF) BLEN = BLEN + SEGLEN(ISEG) 30 CONTINUE C C DETERMINE WHICH SIDES OF THE ELEMENT THE BOUNDARY ENTERS C ON AND EXITS ON. C IENTSD,IEXTSD = 1 - BOTTOM C 2 - LEFT C 3 - TOP C 4 - RIGHT C C ENTRY C IF (BPTYPE(IENTPT).NE.VERT) GO TO 40 IENTSD = 4 IF (ABS(XENT-X1).LE.EPS) IENTSD = 2 GO TO 60 40 IF (BPTYPE(IENTPT).NE.HORZ) GO TO 50 IENTSD = 3 IF (ABS(YENT-Y1).LE.EPS) IENTSD = 1 GO TO 60 C C ENTRY IS A GRID POINT OR BOUNDARY CORNER. FIND WHICH C GRID LINES IT INTERSECTS C 50 IVERT = 0 IHORZ = 0 IF (ABS(XENT-X1).LE.EPS) IVERT = 1 IF (ABS(XENT-X2).LE.EPS) IVERT = 2 IF (ABS(YENT-Y1).LE.EPS) IHORZ = 1 IF (ABS(YENT-Y2).LE.EPS) IHORZ = 2 C C USE IENTMP TO PICK AN ENTRY SIDE BASED ON THE GRID INTERSECTIONS C ISB = IHORZ + 3*IVERT IENTSD = IENTMP(ISB) C C EXIT C 60 IF (BPTYPE(IEXTPT).NE.VERT) GO TO 70 IEXTSD = 4 IF (ABS(XEXT-X1).LE.EPS) IEXTSD = 2 GO TO 90 70 IF (BPTYPE(IEXTPT).NE.HORZ) GO TO 80 IEXTSD = 3 IF (ABS(YEXT-Y1).LE.EPS) IEXTSD = 1 GO TO 90 80 IVERT = 0 IHORZ = 0 IF (ABS(XEXT-X1).LE.EPS) IVERT = 1 IF (ABS(XEXT-X2).LE.EPS) IVERT = 2 IF (ABS(YEXT-Y1).LE.EPS) IHORZ = 1 IF (ABS(YEXT-Y2).LE.EPS) IHORZ = 2 ISB = IHORZ + 3*IVERT IEXTSD = IEXTMP(ISB) C C C DETERMINE WHICH MAP IS APPROPRIATE BASED ON THE NUMBER C OF CORNERS EXTERIOR TO THE DOMAIN C C TT(1,I),I=1..4, IS ALWAYS 0. C 90 DO 100 I = 1,4 TT(1,I) = 0. 100 CONTINUE GO TO (110,160,210,260),IENTSD C C C ENTERS ON THE BOTTOM C C 110 GO TO (150,120,130,140),IEXTSD C C ONE CORNER IS EXTERIOR C 120 CALL MAP1(1,X1,X2,Y1,Y2,XENT,X2,YENT,Y1,XEXT,X1,YEXT,Y2,IENTPT) RETURN C C TWO CORNERS ARE EXTERIOR C 130 CALL MAP2(XENT,X2,YENT,Y1,XEXT,X2,YEXT,Y2,1,IENTPT,IEXTPT) RETURN C C THREE CORNERS ARE EXTERIOR C 140 CALL MAP3(1,IENTPT,XENT,YENT,XEXT,YEXT,X2,Y1,X1,Y2) RETURN C C FOUR CORNERS ARE EXTERIOR C 150 CALL MAP4(1,XENT,XEXT,YENT,YEXT,Y2-Y1,X2-X1,IENTPT) RETURN C C C ENTERS ON LEFT C C 160 GO TO (190,200,170,180),IEXTSD C C ONE CORNER IS EXTERIOR C 170 CALL MAP1(2,X1,X2,Y1,Y2,XENT,X1,YENT,Y1,XEXT,X2,YEXT,Y2,IENTPT) RETURN C C TWO CORNERS ARE EXTERIOR C 180 CALL MAP2(XENT,X1,YENT,Y1,XEXT,X2,YEXT,Y1,2,IENTPT,IEXTPT) RETURN C C THREE CORNERS ARE EXTERIOR C 190 CALL MAP3(2,IENTPT,XENT,YENT,XEXT,YEXT,X1,Y1,X2,Y2) RETURN C C FOUR CORNERS ARE EXTERIOR C 200 CALL MAP4(2,XENT,XEXT,YENT,YEXT,X2-X1,Y2-Y1,IENTPT) RETURN C C C ENTERS ON THE TOP C C 210 GO TO (230,240,250,220),IEXTSD C C ONE CORNER IS EXTERIOR C 220 CALL MAP1(3,X1,X2,Y1,Y2,XENT,X1,YENT,Y2,XEXT,X2,YEXT,Y1,IENTPT) RETURN C C TWO CORNERS ARE EXTERIOR C 230 CALL MAP2(XENT,X1,YENT,Y2,XEXT,X1,YEXT,Y1,3,IENTPT,IEXTPT) RETURN C C THREE CORNERS ARE EXTERIOR C 240 CALL MAP3(3,IENTPT,XENT,YENT,XEXT,YEXT,X1,Y2,X2,Y1) RETURN C C FOUR CORNERS ARE EXTERIOR C 250 CALL MAP4(3,XENT,XEXT,YENT,YEXT,Y2-Y1,X2-X1,IENTPT) RETURN C C C ENTERS ON RIGHT C C 260 GO TO (270,280,290,300),IEXTSD C C ONE CORNER IS EXTERIOR C 270 CALL MAP1(4,X1,X2,Y1,Y2,XENT,X2,YENT,Y2,XEXT,X1,YEXT,Y1,IENTPT) RETURN C C TWO CORNERS ARE EXTERIOR C 280 CALL MAP2(XENT,X2,YENT,Y2,XEXT,X1,YEXT,Y2,4,IENTPT,IEXTPT) RETURN C C THREE CORNERS ARE EXTERIOR C 290 CALL MAP3(4,IENTPT,XENT,YENT,XEXT,YEXT,X2,Y2,X1,Y1) RETURN C C FOUR CORNERS ARE EXTERIOR C 300 CALL MAP4(4,XENT,XEXT,YENT,YEXT,X2-X1,Y2-Y1,IENTPT) RETURN END SUBROUTINE P3C1CG(COEF,IDCOEF,MXNEQ,MXNCOE,GTYPE,NGRDXD,NGRDYD, . ELTYPE,NGDXM1,NGDYM1,NBDIM,FATAL) C C C DRIVER TO SET UP COLLOCATION EQUATIONS FOR NONRECTANGULAR DOMAINS C C C PURPOSE C C SETS UP LINEAR SYSTEM OF EQUATIONS FOR THE COLLOCATION C APPROXIMATION TO THE SOLUTION OF C C C1*UXX + C2*UXY + C3*UYY + C4*UX + C5*UY + C6*U = F IN OMEGA C B1*U + B2*UX + B3*UY = G ON BOUNDARY OMEGA C C WHERE C C1,C2,C3,C4,C5,C6,F,B1,B2,B3, AND G ARE FUNCTIONS OF X AND Y C AND OMEGA IS A CONNECTED, BOUNDED REGION IN R X R C C C INPUTS C C C 1) DOMAIN SPECIFICATION C C - BOUNDARY DEFINITION - C C NPDIM ARRAY DIMENSION FOR BOUNDARY PIECES C C NBDIM ARRAY DIMENSION FOR BOUNDARY POINTS C C NBOUND NUMBER OF BOUNDARY PIECES C C BCOORD PARAMETERIZED DEFINITION OF THE BOUNDARY. C BCOORD(P,X,Y,IPIECE) GIVES THE X,Y VALUES OF THE C POINT ON PIECE IPIECE WITH PARAMETER VALUE = P. C C EXAMPLE OF BCOORD C C SUBROUTINE BCOORD(P,X,Y,IPIECE) C C GO TO (101,102,. . .),IPIECE C C DEFINE FIRST PIECE OF BOUNDARY C C 101 X = (X COORDINATE OF BOUNDARY AS FUNCTION OF P) C Y = (Y COORDINATE OF BOUNDARY AS FUNCTION OF P) C RETURN C C DEFINE SECOND PIECE OF BOUNDARY C C 102 X = . . . C Y = . . . C RETURN C C . C . C . C END C C BRANGE(2,I) = FIRST AND LAST VALUES OF PARAMETERS DEFINING C THE I-TH BOUNDARY PIECE C C DOMFLG = TRUE - USE DOMAIN PROCESSOR C FALSE - THE REMAINING DOMAIN INFORMATION WILL C BE SUPPLIED BY THE USER C C ---- THE REMAINING DOMAIN INFORMATION IS SUPPLIED BY THE USER C (IF DOMFLG=.FALSE.) OR BY THE DOMAIN PROCESSOR (IF DOMFLG=TRUE) C C REFERENCES FOR THE DOMAIN PROCESSOR: C C NUMERICAL COMPUTATION WITH GENERAL TWO DIMENSTIONAL DOMAINS C CSD-TR 416, OCTOBER 1982. C C ALGORITHM: A TWO DIMENSIONAL DOMAIN PROCESSOR C CSD-TR 417, OCTOBER 1982. C C - GRID SPECIFICATION - C C GTYPE(IX,JY) FOR IX = 1 TO NGRIDX, JY = 1 TO NGRIDY C THE VALUES IN THIS ARRAY GIVE THE TYPE OF THE GRID POINTS AND C INFORMATION ABOUT THEIR RELATION TO THE BOUNDARY. C THERE IS A PACKING FACTOR IPACKB WHICH IS NORMALLY 1000. FOR C VERY LARGE PROBLEMS, IPACKB AND RELATED CONSTANT NSIDE = C IPACKB - 1 MUST BE INCREASED SO THAT NSIDE .GT. NBNDPT. C POSSIBLE VALUE ARE( ASSUMING IPACKB = 1000) C C = INTEGER OVER 1000 C GRID POINT IS NEXT TO THE BOUNDARY AND THE GTYPE VALUE IS C GTYPE = K + 1000*J WHERE C K IS THE INDEX OF THE LOWEST NUMBERED BOUNDARY NEIGHBOR C MUST DOUBLE CHECK USE WHEN K = 1 C J = FOUR BITS TO NOTE LOCATION OF BOUNDARY POINTS C 0001 - BOUNDARY NEIGHBOR TO NORTH (NOON) C 0010 - BOUNDARY NEIGHBOR TO EAST (3 O'CLOCK) C 0100 - BOUNDARY NEIGHBOR TO SOUTH (6 O'CLOCK) C 1000 - BOUNDARY NEIGHBOR TO WEST (9 O7CLOCK) C THUS J=9 (1001 IN BINARY) IMPLIES THAT THERE ARE BOUNDARY C NEIGHBORS TO THE NORTH AND WEST C EXAMPLES ( X = BNDRY PT., 0 = GRID PT ) C C X X X 0 X C C X 0 0 X X C J=9 J=3 J=14 C C ***** NOTE THAT GTYPE IS INITIALLY SET NEG. AND THEN MADE C POSITIVE WHEN THE INTERIOR IS FILLED C C = 999 C MEANS GRID POINT IS INTERIOR TO THE REGION AND NOT CLOSE C TO THE BOUNDARY, NSIDE HAS BEEN SET TO 999 SO THAT THE PACKING C C = INTEGER LESS THAN 1000 ( 1000 IS IPACKB VALUE) C GRID POINT IS ALSO BOUNDARY PT., GTYPE IS ITS INDEX C C = 0 C GRID POINT IS EXTERIOR FAR FROM THE BOUNDARY C C = NEGATIVE INTEGER C GRID POINT IS EXTERIOR NEXT TO THE BOUNDARY, ITS LOCATION C RELATIVE TO THE BOUNDARY IS ENCODED AS FOR INTERIOR POINTS C NEAR THE BOUNDARY C C - BOUNDARY SPECIFICATION - C C NBNDPT = NUMBER OF BOUNDARY POINTS ACTUALLY FOUND C XBOUND(I),YBOUND(I) = COORDINATES OF I-TH BOUNDARY POINT C BPARAM(I) = PARAMETER VALUE OF I-TH BOUNDARY POINT C PIECE(I) = INDEX OF BOUNDARY PIECE TO WHICH PT. BELONGS C SMALLEST NUMBER FOR CORNER POINTS C BPTYPE(I) = TYPE OF BOUNDARY POINT C = HORZ,VERT,BOTH,INTE,CORN OR JUMP C BNEIGH(I) = POINTER TO THE INTERIOR POINTS FROM THE I-TH C BOUNDARY POINT. SAME SCHEME IS USED TO ENCODE C DIRECTIONS AS FOR THE J PART OF GTYPE ABOVE C BGRID(I) = IX + IPACKB*JY WHEN PT. I IS IN GRID SQUARE IX,JY C C MAXIMUM NUMBER OF BOUNDARY POINTS = NBDIM C THIS IS ESTIMATED BY THE CALLING PROGRAM FOR DIMENSIONING C THE VARIOUS ARRAYS. C C C 2) PROBLEM SPECIFICATION C C USER SUPPLIED FORTRAN FUNCTIONS C C REAL FUNCTION PDERHS(X,Y) C C PDERHS = RIGHT SIDE OF DIFFERENTIAL EQUATION C C RETURN C END C C REAL FUNCTION BCOND(I,X,Y,BVALUS) C C VALUES OF BOUNDARY CONDITION COEFFICIENTS AND C RIGHT SIDE ON PIECE I AT (X,Y) C C REAL BVALUS(4) C GO TO(101,102,. . .) , I C 101 BVALUS(1) = CU C BVALUS(2) = CUX C BVALUS(3) = CUY C BVALUS(4) = RIGHT SIDE C BCOND = BVALUS(4) C RETURN C 102 BVALUS(1) = CU C BVALUS(2) = CUX C BVALUS(3) = CUY C BVALUS(4) = RIGHT SIDE C BCOND = BVALUS(4) C RETURN C . C . C . C END C C SUBROUTINE PDE(X,Y,CVALUS) C C P.D.E. COEFFICIENTS AT (X,Y) C C REAL CVALUS(7) C CVALUS(1) = CUXX C CVALUS(2) = CUXY C CVALUS(3) = CUYY C CVALUS(4) = CUX C CVALUS(5) = CUY C CVALUS(6) = CU C RETURN C END C C C 3) GRID SPECIFICATION C C AX,BX LEFT AND RIGHT ENDPOINTS OF X-INTERVAL C C AY,BY BOTTOM AND TOP ENDPOINTS OF Y-INTERVAL C C NGRIDX,NGRIDY NUMBER OF X AND Y GRID LINES C C GRIDX, GRIDY VECTORS OF LENGTH >= NGRIDX,NGRIDY C CONTAINING VALUES FOR X AND Y GRID LINES C C NGRDXD,NGRDYD ACTUAL DIMENSIONS OF GRIDX, GRIDY AND GTYPE C C 4) CONTROL OPTIONS C C LEVEL OUTPUT LEVEL C C 0 FATAL ERROR MESSAGES C C 1 0 PLUS GREETINGS AND INPUT VALUES C C 2 SAME AS 1 C C 3 2 PLUS INFORMATION ON WHICH BOUNDARY POINTS C ARE THE ENTRY AND EXIT OF EACH ELEMENT C AND THE COORDINATES OF COLLOCATION POINTS C C 4 3 PLUS THE GENERATED EQUATIONS C C BCP1,BCP2 PLACEMENT OF 2 BOUNDARY COLLOCATION POINTS C IN THE INTERVAL (0,1) C 0<= BCP1 < BCP2 <1 C BCP1=0 AND BCP2=0 GIVES GAUSS POINTS C C DSCARE FRACTION OF AREA OF AN ELEMENT PARTIALLY C INTERIOR TO DOMAIN TO KEEP IT C 0 <= DSCARE < 1 C IF (AREA OF ELEMENT INSIDE DOMAIN)/(AREA OF C ELEMENT) <= DSCARE THEN ELEMENT IS C DISCARDED C C PLOTIT TRUE - MAKE A PLOT OF THE DOMAIN, GRID, C AND COLLOCATION POINTS C IF LEVEL >=3 ALSO PLOT THE IMAGE OF A C 10 X 10 GRID UNDER THE MAPPING USED C FOR INTERIOR COLLOCATION POINTS C FALSE - DONT MAKE A PLOT C C PTSIZE SIZE OF PLOT IN INCHES C C GIVOPT 1 - GIVE BOUNDARY OF DISCARDED ELEMENTS C TO NEIGHBORING ELEMENTS C 2 - DONT USE BOUNDARY OF DISCARDED ELEMENTS C C USECRN TRUE - FORCE BOUNDARY COLLOCATION POINTS AT C CORNERS OF DOMAIN BY SHIFTING THE C LAST POINT BEFORE THE CORNER TO THE C CORNER C FALSE - DONT C C 5) MISC INPUTS C C MXNEQ,MXNCOE ACTUAL DIMENSIONS OF COEF AND IDCOEF C C WKSPAC WORKSPACE OF DIMENSION C (NGRIDX-1)X(NGRIDY-1) C C MOUTPT UNIT NUMBER FOR PRINTED OUTPUT C C EPSGRD ACCURACY OF BOUNDARY POINTS C C OUTPUTS C C COEF COEFFICENTS AND RIGHT SIDE OF EQUATIONS C EACH ROW OF COEF IS A ROW OF THE MATRIX C THE COEFFICENTS ARE IN THE FIRST 16 COLUMNS C AND THE RIGHT SIDE IS IN THE LAST COLUMN C C IDCOEF COLUMN INDICIES C IDCOEF(I,J) IS THE COLUMN INDEX FOR C THE COEFFICENT COEF(I,J) C THE LAST COLUMN IS USED FOR INFORMATION C RELATING ELEMENTS TO COLUMNS C C NUMBEQ NUMBER OF GENERATED EQUATIONS C C C C --- ALGORITHM FOR GENERAL DOMAIN COLLOCATION --- C C 1) FIND THE POINT WHERE THE BOUNDARY C ENTERS AND LEAVES EACH ELEMENT C C FOR EACH BOUNDARY POINT OF THE BOUNDARY DATA STRUCTURES C IF THE BOUNDARY LEAVES AN ELEMENT AND ENTERS A NEW C ELEMENT AT THIS POINT C THEN C SAVE THE BOUNDARY POINT INDEX FOR THOSE ELEMNTS C ENDIF C NEXT BOUNDARY POINT C C 2) DETERMINE WHICH ELEMENTS ARE TO BE IN THE DISCRETIZED DOMAIN C C FOR EACH ELEMENT C IF THE ELEMENT IS EXTERIOR TO THE DOMAIN C THEN C DON'T USE THE ELEMENT C ELSEIF THE ELEMENT IS INTERIOR TO THE DOMAIN C THEN C USE THE ELEMENT C ELSE C COMPUTE (AREA OF ELEMENT INTERSECT DOMAIN)/(AREA OF ELEMENT) C IF THIS NUMBER IS SUFFICIENTLY LARGE C THEN C USE THE ELEMENT C ELSE C DON'T USE THE ELEMENT C ENDIF C ENDIF C NEXT ELEMENT C C 3) GENERATE EQUATIONS C C FOR EACH ELEMENT IN THE DISCRETIZED DOMAIN C IF THE ELEMENT IS ENTIRELY WITHIN THE DOMAIN C THEN C SET THE COLLOCATION POINTS TO BE THE C FOUR GAUSS QUADRATURE POINTS C ELSE C SET THE COLLOCATION POINTS BY MAPPING THE FOUR GAUSS C QUADRATURE POINTS TO THE INTERSECTION OF THE C DOMAIN AND ELEMENT C ENDIF C FOR EACH COLLOCATION POINT C SET THE COLLOCATION EQUATION AT THIS POINT AS C L(APPROX(COLLOC PT)) = F(APPROX(COLLOC PT)) C WHERE L IS THE DIFFERENTIAL OPERATOR C F IS THE RIGHT SIDE OF THE PDE C APPROX IS THE APPROXIMATE SOLUTION OF THE FORM C APPROX(PT)=(SUM OVER BASES)(COEF(BASIS)*BASIS(PT)) C HERE COEF IS THE UNKNOWNS OF THE MATRIX EQUATION C NEXT COLLOCATION POINT C IF THE ELEMENT IS ON THE BOUNDARY OF THE DISCRETIZED DOMAIN C THEN C SET THE BOUNDARY COLLOCATION POINTS (SEE SUBROUTINE BCP) C FOR EACH BOUNDARY COLLOCATION POINT C SET THE BOUNDARY COLLOCATION EQUATION AT THIS POINT AS C B(APPROX(COLLOC PT)) = G(APPROX(COLLOC PT)) C WHERE B IS THE BOUNDARY CONDITION OPERATOR C G IS THE RIGHT SIDE OF THE BOUNDARY CONDITION C APPROX IS AS ABOVE C NEXT BOUNDARY COLLOCATION POINT C ENDIF C SET THE COLUMN INDICIES FOR ALL EQUATIONS WHICH USE A BASIS C FUNCTION CENTERED AT A NODE ON THE LEFT SIDE OF THIS ELEMENT C NEXT ELEMENT C SET COLUMN INDICIES FOR EQUATIONS WHICH USE A BASIS FUNCTION C CENTERED AT A NODE ON THE RIGHT MOST GRID LINE C C C ---- END OF ALGORITHM FOR GENERAL DOMAIN COLLOCATION ---- C C C --- COMMON BLOCKS FOR INPUT C C COMMON / XBOUZZ / XBOUND(NBDIM) C COMMON / YBOUZZ / YBOUND(NBDIM) C COMMON / BPARZZ / BPARAM(NBDIM) C COMMON / PIECZZ / PIECE(NBDIM) C COMMON / BPTYZZ / BPTYPE(NBDIM) C COMMON / BNEIZZ / BNEIGH(NBDIM) C COMMON / BGRIZZ / BGRID(NBDIM) C COMMON / GRIDXZ / GRIDX(NGRDXD) C COMMON / GRIDYZ / GRIDY(NGRDYD) C C C DECLARATIONS C REAL COEF(MXNEQ,MXNCOE),X(8),Y(8) C INTEGER IDCOEF(MXNEQ,MXNCOE),GTYPE(NGRDXD,NGRDYD), . ELTYPE(NGDXM1,NGDYM1),IPIEC(8),UL,UR C LOGICAL FATAL C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP,BPTYPE REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C DATA LL,LR,UR,UL/1,2,3,4/ C C C CONSTANTS C SQRT3 = SQRT(3.) GP1 = 1./ (3.+SQRT3) GP2 = 1. - GP1 THIRD = 1./3. TWOTHR = 2./3. C C FIND MAXIMUM HX AND HY FOR HEADER OUTPUT C HX = 0. HY = 0. DO 10 I = 2,NGRIDX THX = GRIDX(I) - GRIDX(I-1) IF (THX.GT.HX) HX = THX 10 CONTINUE DO 20 I = 2,NGRIDY THY = GRIDY(I) - GRIDY(I-1) IF (THY.GT.HY) HY = THY 20 CONTINUE C C INITIALIZATIONS C DO 50 J = 1,NGDYM1 DO 40 I = 1,NGDXM1 ELTYPE(I,J) = 0 KK = (I-1)*NGDYM1 + J DO 30 K = 1,4 NODELM(K,KK) = 0 30 CONTINUE 40 CONTINUE 50 CONTINUE NUMEL = 0 NROW = 0 NOD = 0 MBNDPT = NBNDPT + 1 NBCPT = 0 LAST = 0 IF (WTBCP1.NE.0. .OR. WTBCP2.NE.0.) GO TO 60 C C DEFAULT BOUNDARY COLLOCATION POINT PARAMETERS C WTBCP1 = GP1 WTBCP2 = GP2 C C PRINT GREETINGS C 60 IF (LEVEL.LE.0) GO TO 70 WRITE (MOUTPT,9001) GRIDX(1),GRIDX(NGRIDX),GRIDY(1), . GRIDY(NGRIDY),NGRIDX,NGRIDY,HX,HY,LEVEL,DSCARE,GIVOPT,USECRN, . WTBCP1,WTBCP2 C C IF PLOTTING OPTION IS ON, PLOT DOMAIN AND GRID C 70 IF (PLOTIT) CALL COLPLT(SCAL,X,Y,0,1) C C ----- TYPE THE ELEMENTS ----- C C IN ELTYPE(I,J), INDICATE IF ELEMENT I,J IS TO BE KEPT OR C DELETED, AND, IF THE BOUNDARY PASSES THROUGH IT, INDICATE C THE INDEX OF THE ENTRY AND EXIT BOUNDARY POINTS C CALL TYPELM(ELTYPE,NGDXM1,NGDYM1,GTYPE,NGRDXD,NGRDYD,MBNDPT,NBDIM, . FATAL,SCAL) IF (FATAL) RETURN C C -- PASS THROUGH THE ELEMENTS GENERATING THE EQUATIONS ---- C DO 170 IX = 1,NGDXM1 C C IF ONE OF THE TWO PREVIOUS COLUMNS OF ELEMENTS KEPT THE TOP C ELEMENT, AN EXTRA NOD MUST BE ADDED FOR THE TOP NODE C C SPECIAL CASE FOR FIRST TWO COLUMNS C IF (IX.EQ.2 .AND. LAST.EQ.NGDYM1) GO TO 80 IF (IX.LE.2) GO TO 90 C C GENERAL CASE C IF (LAST.NE.NGDYM1 .AND. ELTYPE(IX-2,NGDYM1).LT.0) GO TO 90 C 80 NOD = NOD + 1 C C RECORD NODE NUMBERS FOR TOP ELEMENT OF PREVIOUS COLUMN C ISUB = (IX-2)*NGDYM1 IF (IX.NE.2) NODELM(UR,ISUB) = NOD ISUB = ISUB + NGDYM1 NODELM(UL,ISUB) = NOD 90 LAST = 0 C C COMPUTE ELEMENT WIDTH FOR THIS COLUMN C HX = GRIDX(IX+1) - GRIDX(IX) DO 160 JY = 1,NGDYM1 C C SEE IF THIS ELEMENT WAS DISCARDED C IROW = 0 IF (ELTYPE(IX,JY).GE.0) GO TO 140 C C THIS ELEMENT WAS DISCARDED. C C IF THE ELEMENT BELOW, TO THE LEFT, OR LEFT OF THE ONE BELOW C WAS KEPT, INCREMENT THE NODE COUNT. C IF (IX.EQ.1) GO TO 100 IF (JY.EQ.1) GO TO 110 C C GENERAL CASE, CHECK ALL THREE C IF ((LAST.EQ.0.OR.LAST.NE.JY-1) .AND. ELTYPE(IX-1,JY).LT. . 0 .AND. ELTYPE(IX-1,JY-1).LT.0) GO TO 130 GO TO 120 C C LEFT MOST COLUMN, CHECK BELOW ONLY C 100 IF (LAST.EQ.0 .OR. LAST.NE.JY-1) GO TO 130 GO TO 120 C C BOTTOM ROW, CHECK TO THE LEFT ONLY C 110 IF (ELTYPE(IX-1,JY).LT.0) GO TO 130 C C INCREMENT NODE COUNT C 120 NOD = NOD + 1 C C RECORD RELATIONSHIP BETWEEN NODE NUMBER AND ELEMENTS C ISUB = (IX-2)*NGDYM1 + JY - 1 IF (IX.NE.1 .AND. JY.NE.1) NODELM(UR,ISUB) = NOD ISUB = ISUB + NGDYM1 IF (JY.NE.1) NODELM(UL,ISUB) = NOD ISUB = ISUB - NGDYM1 + 1 IF (IX.NE.1) NODELM(LR,ISUB) = NOD ISUB = ISUB + NGDYM1 NODELM(LL,ISUB) = NOD C C IF THE ELEMENT TO THE LEFT WAS KEPT, GO SET ITS RIGHT NODE C COLUMN INDICIES. ELSE GO TO NEXT ELEMENT. C C SPECIAL CASE, LEFT MOST COLUMN, NO ELEMENT TO THE LEFT C 130 IF (IX.EQ.1) GO TO 160 C C GENERAL CASE, SEE IF ELEMENT TO THE LEFT WAS DISCARDED C IF (ELTYPE(IX-1,JY).LT.0) GO TO 160 GO TO 150 C C THIS ELEMENT WAS NOT DISCARDED.COMPUTE THE ELEMENT HEIGHT, C INCREMENT NUMBER OF NODES AND ELEMENTS, RECORD RELATIONSHIP C BETWEEN NODES AND ELEMENTS, AND SET LAST TO INDICATE C THE Y-INDEX OF THE LAST ELEMENT KEPT C 140 HY = GRIDY(JY+1) - GRIDY(JY) NOD = NOD + 1 ISUB = (IX-2)*NGDYM1 + JY - 1 IF (IX.NE.1 .AND. JY.NE.1) NODELM(UR,ISUB) = NOD ISUB = ISUB + NGDYM1 IF (JY.NE.1) NODELM(UL,ISUB) = NOD ISUB = ISUB - NGDYM1 + 1 IF (IX.NE.1) NODELM(LR,ISUB) = NOD ISUB = ISUB + NGDYM1 NODELM(LL,ISUB) = NOD NUMEL = NUMEL + 1 LAST = JY C C SAVE THE INDEX OF THE FIRST ROW OF C THE MATRIX ASSOCIATED WITH THIS ELEMENT C IROW = NROW + 1 C C C --------- INTERIOR COLLOCATION EQUATIONS --------- C C C COMPUTE THE INTERIOR COLLOCATION POINTS C CALL ICP(IX,JY,HX,HY,X,Y,GTYPE,NGRDXD,NGRDYD,ELTYPE,NGDXM1, . NGDYM1,SCAL) C C GENERATE EQUATIONS FOR INTERIOR COLLOCATION POINTS C CALL INTEQ(IX,JY,HX,HY,NROW,X,Y,COEF,MXNEQ,MXNCOE) C C IF THIS ELEMENT HAS NO BOUNDARY, C SKIP BOUNDARY EQUTATIONS SEGMENT C IF (ELTYPE(IX,JY).EQ.0) GO TO 150 C C C ---------- BOUNDARY COLLOCATION EQUATIONS -------- C C C COMPUTE BOUNDARY COLLOCATION POINTS C ICODE = 0 CALL BCP(NBCP,X,Y,IX,JY,ICODE,ELTYPE,NGDXM1,NGDYM1,TVAL, . IPIEC,SCAL,FATAL) IF (FATAL) RETURN IF (NBCP.EQ.0) GO TO 150 C C GENERATE EQUATIONS FOR BOUNDARY COLLOCATION POINTS C CALL BNDEQ(NROW,X,Y,HX,HY,IX,JY,NBCP,IPIEC,COEF,MXNEQ, . MXNCOE) NBCPT = NBCPT + NBCP C C C -------- COLUMN INDICIES ----------- C C C GENERATE COLUMN INDICES FOR THE NODES ON C THE LEFT SIDE OF THIS ELEMENT C 150 CALL COLIND(IX,JY,NBCP,NOD,IROW,NROW,IDCOEF,MXNEQ,MXNCOE, . ELTYPE,NGDXM1,NGDYM1) C 160 CONTINUE 170 CONTINUE C C END OF MAJOR LOOP THROUGH ELEMENTS C C C FINISH COLLOCATION EQUATIONS BY COMPUTING MATRIX COLUMN C INDICIES FOR THE MATRIX COEFFICIENTS CORRESPONDING TO C NODES ON THE LINE X=BX C C CALL LSTCOL(LAST,NOD,ELTYPE,NGDXM1,NGDYM1,IDCOEF,MXNEQ,MXNCOE) C C ---- FINISH BY SETTING NUMBEQ AND NUMCOE C NUMBEQ = NROW NUMCOE = 16 IF (PLOTIT) CALL COLPLT(SCAL,X,Y,0,3) IF (LEVEL.LT.4) GO TO 190 C C DEBUG -- PRINT MATRIX C WRITE (MOUTPT,9011) DO 180 NR = 1,NROW WRITE (MOUTPT,9021) NR, (COEF(NR,NC),NC=1,16),COEF(NR,MXNCOE) WRITE (MOUTPT,9031) (IDCOEF(NR,NC),NC=1,16),IDCOEF(NR,MXNCOE) 180 CONTINUE C C PRINT INFORMATION TO INDICATE COMPLETION C 190 WRITE (MOUTPT,9041) NROW,NOD,NUMEL,NBCPT IF (PLOTIT) WRITE (MOUTPT,9051) RETURN 9001 FORMAT (///1X,23 (1H-)/23H DISCRETIZATION MODULE/1X,23 (1H-)//5X, . 21HC O L L O C A T I O N//5X,6HDOMAIN,21X, . 14HNONRECTANGULAR/5X,10HX INTERVAL,10X,E10.3, . 1H,,E10.3/5X,10HY INTERVAL,10X,E10.3,1H,, . E10.3/5X,4HGRID,27X,I4,2H X,I4/5X,6HMAX HX, . 25X,E10.3/5X,6HMAX HY,25X,E10.3/5X, . 12HOUTPUT LEVEL,27X,I2/5X, . 12HOPTIONS USED/10X,6HDSCARE,26X,F4.2/10X, . 6HGIVOPT,24X,I6/10X,6HUSECRN,29X,L1/10X, . 19HBOUND. COLLOC. PTS.,9X,F8.6/38X,F8.6) 9011 FORMAT ('0MATRIX COEF AND IDCOEF'/) 9021 FORMAT (1X,I5,10F10.3/ (6X,10F10.3)) 9031 FORMAT (6X,10I10) 9041 FORMAT (5X,19HNUMBER OF EQUATIONS,16X,I6/5X, . 41HMAX NUMBER OF UNKNOWNS PER EQUATION 16/5X, . 15HNUMBER OF NODES,20X,I6/5X,18HNUMBER OF ELEMENTS,17X,I6/5X, . 29HNUMBER OF BOUND. COLLOC. PTS.,6X,I6/5X, . 20HEXECUTION SUCCESSFUL) 9051 FORMAT (/5X,16HDOMAIN PLOT MADE) END SUBROUTINE TYPELM(ELTYPE,NGDXM1,NGDYM1,GTYPE,NGRDXD,NGRDYD,MBNDPT, . NBDIM,FATAL,SCAL) C C C PURPOSE C C DETERMINE, FOR EACH ELEMENT, WHERE THE BOUNDARY ENTERS C AND EXITS THE ELEMENT (IF IT DOES) AND WHETHER THE ELEMENT C SHOULD BE KEPT OR DELETED C C METHOD C C STEP 1 - C PASS AROUND THE BOUNDARY NOTING WHEN IT CHANGES ELEMENTS. C AFTER THIS STEP, ELTYPE(I,J) = E + 1000*X WHERE C E AND X ARE THE INDICIES OF THE POINTS WHERE THE BOUNDARY C ENTERS AND EXITS ELEMENT I,J C C STEP 2 - C PASS THROUGH THE ELEMENTS DETERMINING WHICH SHOULD BE KEPT. C ELEMENTS ARE KEPT IF A LARGE ENOUGH PORTION OF THEM ARE C INTERIOR TO THE DOMAIN. IF AN ELEMENT IS DISCARDED AND IT C HAS SOME BOUNDARY WITHIN IT, THE BOUNDARY IS ASSOCIATED C WITH NEIGHBORING ELEMENTS. IF THIS PART OF BOUNDARY IS C SPLIT BETWEEN ELEMENTS, A NEW BOUNDARY POINT IS DEFINED C AT THE PLACE WHERE IT IS CUT. C AFTER THIS STEP, C ELTYPE(I,J) = 0 IF THE ELEMENT IS INTERIOR C = -1 IF THE ELEMENT IS EXTERIOR C = -(E+1000*X) IF THE BOUNDARY PASSES THROUGH C THE ELEMENT AND IT WAS DISCARDED C WHERE E AND X ARE AS ABOVE C = E'+1000*X' IF THE BOUNDARY PASSES THROUGH C THE ELEMENT AND IT WAS KEPT C HERE, E' AND X' ARE THE INDICIES C OF THE POINTS WHERE THE BOUNDARY C ASSOCIATED WITH THIS ELEMENT C BEGINS AND ENDS AND MAY BE C DIFFERENT THAN E AND X ABOVE IF C THE ELEMENT RECIEVED EXTRA BOUNDARY C FROM A DISCARDED ELEMENT C C INTEGER ELTYPE(NGDXM1,NGDYM1),GTYPE(NGRDXD,NGRDYD) C LOGICAL KEEP,KEEPIT,FATAL C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP,BPTYPE,BPTYPI REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C C PASS AROUND THE BOUNDARY INDICATING THE ENTRY AND EXIT C POINT OF THE BOUNDARY FOR EACH ELEMENT IT PASSES THROUGH C C C FIND THE ELEMENT THE FIRST BOUNDARY POINT IS IN C BPTYPI = BPTYPE(1) C C BGRID GIVES AN ELEMENT ASSOCIATED WITH THIS BOUNDARY POINT C JSUBO = BGRID(1)/1000 ISUBO = BGRID(1) - 1000*JSUBO C C DECREASE THE X-INDEX BY ONE IF (THERE IS A VERTICAL INTERSECTION) C AND ( (THE BOUNDARY MOVES TO THE LEFT ) C OR (THE BOUNDARY MOVES STRAIGHT DOWN) ) C IF ((BPTYPI.EQ.BOTH.OR.BPTYPI.EQ.VERT) .AND. . ((XBOUND(1).GT.XBOUND(2)+EPSGRD).OR. ((YBOUND(1).GT.YBOUND(2)+ . EPSGRD).AND. (ABS(XBOUND(1)-XBOUND(2)).LT. . EPSGRD)))) ISUBO = ISUBO - 1 C C DECREASE THE Y-INDEX BY ONE IF (THERE IS A HORIZONTAL INTERSECTION) C AND ( (THE BOUNDARY MOVES DOWN ) C OR (THE BOUNDARY MOVES STRAIGHT TO THE RIGHT) ) C IF ((BPTYPI.EQ.BOTH.OR.BPTYPI.EQ.HORZ) .AND. . ((YBOUND(1).GT.YBOUND(2)+EPSGRD).OR. ((XBOUND(1).LT.XBOUND(2)- . EPSGRD).AND. (ABS(YBOUND(1)-YBOUND(2)).LT. . EPSGRD)))) JSUBO = JSUBO - 1 C C MAKE SURE THE ELEMENT INDICIES ARE IN RANGE C IF (ISUBO.GT.NGDXM1) ISUBO = NGDXM1 IF (JSUBO.GT.NGDYM1) JSUBO = NGDYM1 C C SAVE THE ELEMENT INDICIES OF THE FIRST BOUNDARY C POINT FOR LATER REFERENCE C ISUB1 = ISUBO JSUB1 = JSUBO DO 40 I = 2,NBNDPT C C FIND THE ELEMENT THE I'TH BOUNDARY POINT IS IN C BPTYPI = BPTYPE(I) JSUB = BGRID(I)/1000 ISUB = BGRID(I) - 1000*JSUB C C DECREASE THE X-INDEX BY ONE IF (THERE IS A VERTICAL INTERSECTION) C AND ( (THE BOUNDARY MOVES TO THE LEFT ) C OR (THE BOUNDARY MOVES STRAIGHT DOWN) ) C IF ((BPTYPI.EQ.BOTH.OR.BPTYPI.EQ.VERT) .AND. . ((XBOUND(I).GT.XBOUND(I+1)+EPSGRD).OR. ((YBOUND(I).GT. . YBOUND(I+1)+EPSGRD).AND. (ABS(XBOUND(I)-XBOUND(I+1)).LT. . EPSGRD)))) ISUB = ISUB - 1 C C DECREASE THE Y-INDEX BY ONE IF (THERE IS A HORIZONTAL INTERSECTION) C AND ( (THE BOUNDARY MOVES DOWN ) C OR (THE BOUNDARY MOVES STRAIGHT TO THE RIGHT) ) C IF ((BPTYPI.EQ.BOTH.OR.BPTYPI.EQ.HORZ) .AND. . ((YBOUND(I).GT.YBOUND(I+1)+EPSGRD).OR. ((XBOUND(I).LT. . XBOUND(I+1)-EPSGRD).AND. (ABS(YBOUND(I)-YBOUND(I+1)).LT. . EPSGRD)))) JSUB = JSUB - 1 C C MAKE SURE THE ELEMENT INDICIES ARE IN RANGE C IF (ISUB.GT.NGDXM1) ISUB = NGDXM1 IF (JSUB.GT.NGDYM1) JSUB = NGDYM1 IF (ISUB.LT.1) ISUB = 1 IF (JSUB.LT.1) JSUB = 1 C C ISUBO AND JSUBO ARE THE ELEMENT INDICIES FOR THE C PREVIOUS BOUNDARY POINT. IF THE ELEMENT INDICIES C ARE THE SAME AS FOR THE PREVIOUS BOUNDARY POINT, C WE HAVE NOT ENTERED A NEW ELEMENT. GO TO NEXT POINT. C IF (ISUB.EQ.ISUBO .AND. JSUB.EQ.JSUBO) GO TO 30 C C THIS BOUNDARY POINT IS ON THE BOUNDARY OF TWO ELEMENTS C SEE IF THIS IS THE FIRST TIME THIS ELEMENT HAS BEEN ENTERED C IF (ELTYPE(ISUB,JSUB).EQ.0 .OR. . (ISUB.EQ.ISUB1.AND.JSUB.EQ.JSUB1)) GO TO 20 C C THE ELEMENT THAT THE BOUNDARY IS ENTERING HAS ALREADY BEEN ENTERED C ENTERING AN ELEMENT MORE THAN ONCE IS NOT ALLOWED IN C THIS DISCRETIZATION MODULE. C C CHECK FOR EXCEPTIONAL CASE OF IMMEDIATE REENTRY C IF (ELTYPE(ISUBO,JSUBO)-1000* (ELTYPE(ISUBO,JSUBO)/1000).EQ. . ELTYPE(ISUB,JSUB)/1000) GO TO 10 C C NOT EXCEPTIONAL CASE, SIGNAL FATAL ERROR C WRITE (MOUTPT,9001) WRITE (MOUTPT,9011) ISUB,JSUB FATAL = .TRUE. RETURN C C EXCEPTIONAL CASE, IGNORE SHORT ELEMENT C 10 ELTYPE(ISUBO,JSUBO) = 0 ELTYPE(ISUB,JSUB) = ELTYPE(ISUB,JSUB) - . 1000* (ELTYPE(ISUB,JSUB)/1000) IF (LEVEL.GE.4) WRITE (MOUTPT,9021) ISUBO,JSUBO,ISUB,JSUB GO TO 30 C C THE NEW ELEMENT IS OK, MARK THE EXIT AND ENTRY POINTS C 20 ELTYPE(ISUBO,JSUBO) = ELTYPE(ISUBO,JSUBO) + 1000*I ELTYPE(ISUB,JSUB) = ELTYPE(ISUB,JSUB) + I C C CONTINUE TO THE NEXT BOUNDARY POINT C 30 ISUBO = ISUB JSUBO = JSUB 40 CONTINUE C C DOUBLE CHECK THE FIRST AND LAST ELEMENTS C IF THE FIRST BOUNDARY POINT IS ON THE BORDER OF TWO ELEMENTS, C IT WAS NOT RECORDED AND MUST BE DONE HERE. C ICHK = ELTYPE(ISUB1,JSUB1) - 1000* (ELTYPE(ISUB1,JSUB1)/1000) IF (ICHK.NE.0) GO TO 50 ELTYPE(ISUB1,JSUB1) = ELTYPE(ISUB1,JSUB1) + 1 ELTYPE(ISUBO,JSUBO) = ELTYPE(ISUBO,JSUBO) + 1000 C C DEBUG -- PRINT ENTRY AND EXIT POINTS OF EACH ELEMENT C 50 IF (LEVEL.LT.3) GO TO 70 WRITE (MOUTPT,9031) DO 60 JJ = 1,NGDYM1 JJJ = NGRIDY - JJ WRITE (MOUTPT,9041) (ELTYPE(II,JJJ),II=1,NGDXM1) 60 CONTINUE C C C PASS THROUGH THE ELEMENTS MARKING EACH AS KEEP AND AWAY FROM THE C BOUNDARY (0), KEEP WITH BOUNDARY GOING THROUGH IT (CODE GIVING ENTRY C AND EXIT POINTS), OR DISCARD (-1 IF AWAY FROM BOUNDARY, NEGATION C OF CODE IF BOUNDARY PASSES THROUGH IT) C C 70 DO 100 I = 1,NGDXM1 DO 90 J = 1,NGDYM1 C C IF ALL 4 CORNERS OF THIS ELEMENT ARE .GT. 0 IN GTYPE, IT IS INTERIOR C IF (GTYPE(I,J).GT.0 .AND. GTYPE(I+1,J).GT.0 .AND. . GTYPE(I,J+1).GT.0 .AND. GTYPE(I+1,J+1).GT.0) GO TO 90 C C ELSE IF ELTYPE .NE. O IT IS PARTIALLY INTERIOR AND PART EXTERIOR C IF (ELTYPE(I,J).NE.0) GO TO 80 C C ELSE IT IS EXTERIOR C ELTYPE(I,J) = -1 GO TO 90 C C SOME CORNERS ARE INTERIOR AND SOME ARE EXTERIOR. C ELTYPE HAS THE ENTRY AND EXIT POINTS OF THE ELEMENT C DETERMINE WHETHER TO KEEP OR DISCARD THIS ELEMENT C 80 JSUB = ELTYPE(I,J)/1000 ISUB = ELTYPE(I,J) - 1000*JSUB XLEFT = GRIDX(I) XRIGHT = GRIDX(I+1) YDOWN = GRIDY(J) YUP = GRIDY(J+1) KEEP = KEEPIT(I,J,ISUB,JSUB,XLEFT,XRIGHT,YDOWN,YUP,NGRDXD, . NGRDYD,GTYPE,ELTYPE,NGDXM1,NGDYM1) C C IF IT IS TO BE KEPT, DO NOTHING C IF (KEEP) GO TO 90 C C IF IT IS TO BE DISCARDED, CALL DISCRD TO DETERMINE WHAT IS TO BECOME C OF THE BOUNDARY SEGMENT CONTAINED IN THIS ELEMENT C CALL DISCRD(ELTYPE,GTYPE,NGDXM1,NGDYM1,NGRDXD,NGRDYD,MBNDPT, . I,J,NBDIM,SCAL,FATAL) C C NEGATE THIS ELEMENT'S CODE TO INDICATE THAT IT HAS BEEN DISCARDED C ELTYPE(I,J) = -ELTYPE(I,J) C 90 CONTINUE 100 CONTINUE C C DEBUG -- PRINT ELEMENT TYPES C IF (LEVEL.LT.3) RETURN WRITE (MOUTPT,9051) DO 110 JJ = 1,NGDYM1 JJJ = NGRIDY - JJ WRITE (MOUTPT,9041) (ELTYPE(II,JJJ),II=1,NGDXM1) 110 CONTINUE RETURN 9001 FORMAT (/27H ------ FATAL ERROR ------ ) 9011 FORMAT (10X,23HBOUNDARY ENTERS ELEMENT,2I5,15H MORE THAN ONCE/10X, . 20HUSE A DIFFERENT MESH) 9021 FORMAT (' ELEMENT',2I5,' IS DONATING ITS BOUNDARY TO ','ELEMENT', . 2I5,/' TO AVOID ENTERING THE ELEMENT TWICE') 9031 FORMAT (/34H ENTRY AND EXIT POINTS OF BOUNDARY, . 16H IN EACH ELEMENT/) 9041 FORMAT (5X,9I8) 9051 FORMAT ('0ELEMENT TYPES'/) END FUNCTION XBD(T,I) C C C PURPOSE C C RETURNS THE X COORDINATE OF THE IMAGE UNDER THE MAPPING C OF MAPSQ OF THE POINT WITH PARAMETER T ON SIDE I OF C THE BOUNDARY OF AN ELEMENT C C PARAMETERS C C I - SIDE OF ELEMENT THE POINT TO BE MAPPED IS ON C T - 0 <= T <= 1 , WHERE THE POINT IS ON THE SIDE C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BPTYPE,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C ISEG = 1 10 ISEG = ISEG + 1 IF (TT(ISEG,I).LT.T) GO TO 10 IF (IP(ISEG,I).EQ.-1) GO TO 20 PARAM = ((TT(ISEG,I)-T)*LO(ISEG,I)+ (T-TT(ISEG-1,I))*UP(ISEG,I))/ . (TT(ISEG,I)-TT(ISEG-1,I)) IPIECE = IP(ISEG,I) CALL BCOORD(PARAM,XVAL,YVAL,IPIECE) XBD = XVAL RETURN 20 XBD = UP(ISEG,I)*T + LO(ISEG,I) RETURN END FUNCTION YBD(T,I) C C C PURPOSE C C RETURNS THE Y COORDINATE OF THE IMAGE UNDER THE MAPPING C OF MAPSQ OF THE POINT WITH PARAMETER T ON SIDE I OF C THE BOUNDARY OF AN ELEMENT C C PARAMETERS C C I - SIDE OF ELEMENT THE POINT TO BE MAPPED IS ON C T - 0 <= T <= 1 , WHERE THE POINT IS ON THE SIDE C C C C GENERAL DOMAIN COLLOCATION COMMON BLOCKS C INTEGER GIVOPT,BPTYPE,BNEIGH,BGRID,PIECE CHARACTER *4 HORZ,VERT,BOTH,INTER,JUMP REAL LO,LOA LOGICAL PLOTIT,USECRN C COMMON /COLOPT/WTBCP1,WTBCP2,DSCARE,PTSIZE,GIVOPT,PLOTIT,USECRN COMMON /COLNUM/NODELM(4,1) COMMON /PROBR/AX,BX,AY,BY COMMON /PROBI/NGRIDX,NGRIDY COMMON /INTEGS/NUMBEQ,NUMCOE,LEVEL,MOUTPT COMMON /BNDRY/IPIECE,NBOUND,NBNDPT COMMON /SYMCON/HORZ,VERT,BOTH,INTER,JUMP COMMON /NUMCON/EPSGRD COMMON /GRIDXZ/GRIDX(1) COMMON /GRIDYZ/GRIDY(1) COMMON /XBOUZZ/XBOUND(1) COMMON /YBOUZZ/YBOUND(1) COMMON /BPTYZZ/BPTYPE(1) COMMON /BNEIZZ/BNEIGH(1) COMMON /BGRIZZ/BGRID(1) COMMON /BPARZZ/BPARAM(1) COMMON /BRANZZ/BRANGE(2,1) COMMON /PIECZZ/PIECE(1) COMMON /COLICP/TT(10,4),UP(10,4),LO(10,4),UPA(10,4),LOA(10,4), . SEGLEN(10),BLEN,NSEG,IP(10,4) COMMON /CONMAP/X20,X21,X40,X41,Y10,Y11,Y30,Y31 COMMON /COLCON/SQRT3,GP1,GP2,THIRD,TWOTHR C C C C ISEG = 1 10 ISEG = ISEG + 1 IF (TT(ISEG,I).LT.T) GO TO 10 IF (IP(ISEG,I).EQ.-1) GO TO 20 PARAM = ((TT(ISEG,I)-T)*LO(ISEG,I)+ (T-TT(ISEG-1,I))*UP(ISEG,I))/ . (TT(ISEG,I)-TT(ISEG-1,I)) IPIECE = IP(ISEG,I) CALL BCOORD(PARAM,XVAL,YVAL,IPIECE) YBD = YVAL RETURN 20 YBD = UPA(ISEG,I)*T + LOA(ISEG,I) RETURN END C///////////////////////////////////////////////////////////////////// C//////////////// END OF LOGICAL FILE 5 ///////////////////////////// C//////////////////////////////////////////////////////////////////// C/////////////////////////////////////////////////////////////////// C////////////// ALGORITHM GENCOL /////////////////////////////////// C/////////////////////////////////////////////////////////////////// C>>>>>>>>>>> LOGICAL FILE 6 : EXAMPLE 1 <<<<<<<<<<<<<<<<<<<<<<<<<<< C/////////////////////////////////////////////////////////////////// REAL FUNCTION BCOND(I,X,Y,BVALUS) C REAL BVALUS(4) COMMON /PARAMS/ALPHA,RL C C GO TO (10,20,30,40),I 10 BVALUS(1) = 1. BVALUS(2) = 0. BVALUS(3) = 0. BVALUS(4) = 0. BCOND = BVALUS(4) C RETURN C C 20 CONTINUE BVALUS(1) = 0. BVALUS(2) = 0. BVALUS(3) = 1. BVALUS(4) = 0. BCOND = BVALUS(4) RETURN 30 BVALUS(1) = 0. BVALUS(2) = 1. BVALUS(3) = 0. BVALUS(4) = 0. BCOND = BVALUS(4) RETURN 40 IF (X.GE..5) GO TO 50 BVALUS(1) = 0. BVALUS(2) = 0. BVALUS(3) = 1. BVALUS(4) = 0. BCOND = BVALUS(4) RETURN 50 BVALUS(1) = 1. BVALUS(2) = 0. BVALUS(3) = 0. BVALUS(4) = 0. BCOND = BVALUS(4) RETURN END SUBROUTINE BCOORD(P,X,Y,I) C C UNIT SQUARE C GO TO (10,20,30,40),I C RIGHT SIDE 10 X = 1. Y = 1. - P RETURN C BOTTOM 20 X = 1. - P Y = 0. RETURN C LEFT SIDE 30 X = 0. Y = P RETURN C TOP 40 X = P Y = 1. RETURN END SUBROUTINE PDE(X,Y,CVALUS) C REAL CVALUS(6) C C 10 CONTINUE CVALUS(1) = 1. CVALUS(2) = 0. CVALUS(3) = 1./ (X*X) CVALUS(4) = 1./X CVALUS(5) = 0. CVALUS(6) = 0. RETURN END REAL FUNCTION PDERHS(X,Y) C C PDERHS = -1. RETURN END REAL FUNCTION TRUE(X,Y) C C TRUE SOLUTION IS UNKNOWN -- THIS IS A DUMMY C TRUE = 0. RETURN END C/////////////////////////////////////////////////////////////////// C/////////////// END OF FILE 6 ///////////////////////////////////// C/////////////////////////////////////////////////////////////////// C//////////////////////////////////////////////////////////////// C////////////// ALGORITHM GENCOL //////////////////////////// C//////////////////////////////////////////////////////////////// C>>>>>>>>>>>>>>>> LOGICAL FILE 7 : EXAMPLE 2 <<<<<<<<<<<<<<<<<<<< C//////////////////////////////////////////////////////////////// REAL FUNCTION BCOND(I,X,Y,BVALUS) C REAL BVALUS(4) C C BVALUS(1) = 1. BVALUS(2) = 0. BVALUS(3) = 0. BVALUS(4) = TRUE(X,Y) BCOND = BVALUS(4) C RETURN END SUBROUTINE BCOORD(P,X,Y,I) C C RECTANGULAR DOMAIN OF EXAMPLE 2 C GO TO (10,20,30,40),I 10 X = 1. Y = 1. - P RETURN C 20 X = 1. - P Y = 0. RETURN C 30 X = 0. Y = P RETURN C 40 X = P Y = 1. RETURN END SUBROUTINE PDE(X,Y,CVALUS) C REAL CVALUS(6) C C 10 CONTINUE CVALUS(1) = 1. CVALUS(2) = 0. CVALUS(3) = 1./ (X*X) CVALUS(4) = 2./X CVALUS(5) = 1./ (X*TAN(Y)) CVALUS(6) = 0. RETURN END REAL FUNCTION PDERHS(X,Y) C C PDERHS = (1.+1./ (X*X)+2./X+1./ (X*TAN(Y)))*EXP(X+Y) RETURN END REAL FUNCTION TRUE(X,Y) TRUE = EXP(X+Y) RETURN END C///////////////////////////////////////////////////////////////////// C///////////////// END OF LOGICAL FILE 7 ///////////////////////////// C///////////////////////////////////////////////////////////////////// C///////////////////////////////////////////////////////////////// C//////////////// ALGORITHM GENCOL ///////////////////////////// C//////////////////////////////////////////////////////////////// C>>>>>>>>>>>>>>>> LOGICAL FILE 8 : EXAMPLE 3 <<<<<<<<<<<<<<<<<<<< C//////////////////////////////////////////////////////////////// REAL FUNCTION BCOND(I,X,Y,BVALUS) C REAL BVALUS(4) C C BVALUS(1) = 1. BVALUS(2) = 0. BVALUS(3) = 0. BVALUS(4) = TRUE(X,Y) BCOND = BVALUS(4) C RETURN END SUBROUTINE BCOORD(P,X,Y,I) C C NONRECTANGULAR DOMAIN OF EXAMPLE 3 C GO TO (10,20,30,40),I 10 X = 1. - P Y = 0. RETURN C 20 X = .1*P Y = .5*P RETURN C 30 X = (1.-P)*.1 + .5*P Y = .5 RETURN C 40 X = .5 + .5*SIN(P) Y = .5*COS(P) RETURN END SUBROUTINE PDE(X,Y,CVALUS) C REAL CVALUS(6) C C 10 CONTINUE CVALUS(1) = 1. CVALUS(2) = 0. CVALUS(3) = 1./ (X*X) CVALUS(4) = 2./X CVALUS(5) = 1./ (X*TAN(Y)) CVALUS(6) = 0. RETURN END REAL FUNCTION PDERHS(X,Y) C C PDERHS = (1.+1./ (X*X)+2./X+1./ (X*TAN(Y)))*EXP(X+Y) RETURN END REAL FUNCTION TRUE(X,Y) TRUE = EXP(X+Y) RETURN END C/////////////////////////////////////////////////////////////////// C///////////////// END OF LOGICAL FILE 8 ////////////////////////// C////////////////////////////////////////////////////////////////// C////////////////////////////////////////////////////////////////// C/////////////////////// ALGORITHM GENCOL ///////////////////////// C////////////////////////////////////////////////////////////////// C////////////////// DUMMY SUBPROGRAMS FOR PLOTTING /////////////// C////////////////////////////////////////////////////////////////// SUBROUTINE PLOT(X,Y,I) C DUMMY RETURN END SUBROUTINE PLOTS C DUMMY RETURN END