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
