C 
C Subroutine file 'rp3d.for' to control parameters of rays
C during 3-D shooting.
C
C Version: 7.30
C Date: 2016, January 14
C
C                                                  
C Coded by Petr Bulant
C     Department of Geophysics, Charles University Prague,
C     Ke Karlovu 3, 121 16 Praha 2, Czech Republic,
C     http://sw3d.cz/staff/bulant.htm
C
C=======================================================================
C
      SUBROUTINE RP3D(IRAY,ITYPE,G1NEW,G2NEW)
C
C----------------------------------------------------------------------
      INTEGER IRAY,ITYPE
      REAL G1NEW,G2NEW
C
C This subroutine determines the take-off parameters of the ray during
C 3-D two-point ray tracing by means of the shooting method.
C
C                                                  
C The subroutine is not fully debugged. If you will obtain the error
C message due to the bug in any of the RP* subroutine, you may try to
C change slightly the input data for the take-off parameters of rays
C (anyone of the
C AERR, PRM0,
C PAR1L, PAR2L, PAR1A, PAR2A, PAR1B, PAR2B, ANUM, BNUM)
C and run again.  The authors will appreciate any information concerning
C the bugs in the code.
C
C Most important numerical parameters for 3-D two-point ray tracing are
C the parameters listed above, together with parameter XERR.
C See also parameters controlling the computation of a single ray.
C
C To choose the best shooting parameters it may be useful to
C generate simple plots of the distribution of rays on the normalized
C ray domain or on the reference surface using, e.g., program
C RPPLOT.
C
C Do not forget to view logout file after finishing a computation.
C
C The subroutine is able to produce formatted output files, suitable
C for plotting. This may be very useful for
C debugging or when choosing the optimum shooting parameters.
C Remove the first "RETURN" command in the subroutine
C RPSTOR for getting the output files.
C See the subroutine RPSTOR for the description of the output files.
C
C For the detailed description of the shooting algorithm refer to
C Bulant,P.,1996, Two-point ray tracing in 3-D.
C  Pure and Applied Geophysics vol 148, 421-446
C Bulant,P.,1995, Two-point ray tracing in 3-D.  In: Seismic Waves
C  in Complex 3-D Structures, Report 3, pp. 37-64, Department of
C  Geophysics, Charles University, Prague.
C
C----------------------------------------------------------------------
C
C Input:
C     IRAY... Number of the already  computed rays.  IRAY=0 at the
C             beginning of  computation of a new elementary wave.
C             Otherwise, the output from the previous invocation of
C             RP3D.
C     ITYPE... Type of the last computed ray.
C             -1000-I:..... Two-point ray to the I'th receiver.
C             other   ..... Other ray.
C
C Output:
C     IRAY... IRAY=0 when all rays have been computed and the
C             computation of the elementary wave is at termination.
C             Otherwise, input value increased by 1.
C     ITYPE... Type of ray:
C             0: .......... Basic ray.
C             -2:.......... Auxiliary ray.
C             -1000-I:..... Auxiliary ray when searching for two-point
C                           ray to the I'th receiver.
C     G1NEW,G2NEW... If a new ray is to be traced, take-off parameters
C             of the new ray.
C
C Subroutines and external functions required:
      EXTERNAL RPDIV,RPNEW,RPINTS,RPWHAD,RPMEM,RPTRI1,RPAUX1,RPINTP,
     *RPERAS,RPTMEA,RPLRIT,RPLRIP,RPDI2G,RPLRIL,RPCROS,RPXMEA,RPLRTC,
     *RPDPA,RPHPDI,RPLTCR,RPMEGS,RPERR,RPKBR,RPSTOR,ERROR,WARN,
     *WRITTR,WRITBR
C     LENGTH ... Called by RPMEM and RPINTP.
      LOGICAL RPLRIT,RPLRIP,RPLRIL,RPLTCR
      REAL RPDI2G
C     RPDIV,RPNEW,RPINTS,RPWHAD,RPMEM,RPTRI1,RPAUX1,RPINTP,RPERAS,
C     RPTMEA,RPLRIT,RPLRIP,RPDI2G,RPLRIL,RPCROS,RPXMEA,RPLRTC,RPDPA,
C     RPHPDI,RPLTCR,RPMEGS,RPERR,RPKBR,RPSTOR ... This file.
C     ERROR,WARN ... File error.for.
C     WRITTR,WRITBR ... File writ.for.
C     LENGTH ... File length.for.
C
C.......................................................................
C
C Common block /RPARD/:
      INCLUDE 'rpard.inc'
C     rpard.inc
C     PRM0(2) ... Maximum allowed length of the homogeneous triangles
C                 sides (measured on the reference surface).
C None of the storage locations of the common block are altered.
C............................
C
C Common block /GLIM/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C.......................................................................
C Auxiliary storage locations:
      INTEGER IRAY0,ITRI0,ITRI
      INTEGER ITRI0D,ITRI0S,ITRI0X,ITRI0I,ITRI1,ITRIE
      INTEGER KTRID(6),KTRIN(6),KTRIS(6)
      INTEGER ITRNAR
      INTEGER ISHEET,ISH
      REAL G1,G2,G11,G12,G22,S11,S12,S22,X1,X2
      REAL G1X1,G2X1,G1X2,G2X2
      INTEGER ITRAS(3)
      REAL G1S(3),G2S(3)
      INTEGER IGOTO
      INTEGER I1,I2
      LOGICAL LNEWAR,LTRI,LRAY,LAB20,LEND
C
      SAVE IRAY0,ITRI0,ITRI,ITRI0D,ITRI0S,ITRI0X,ITRI0I
      SAVE ITRI1,ITRIE,KTRID,KTRIS,ITRNAR
      SAVE LNEWAR,LAB20,LEND
      SAVE IGOTO,I1
C
C     IRAY0,ITRI0... Number of the already computed rays (triangles)
C             before adding a new homogeneous triangle.
C     ITRI... Number of the already computed triangles.
C     ITRI0_... Index of the last processed triangle when:
C          D... Dividing the triangles into homogeneous ones.
C          G... Measuring the triangles in the normalized ray domain.
C          X... Measuring the triangles on the reference surface.
C          I... Searching for two-point rays (interpolation).
C     ITRI1... Number of the already computed triangles when starting
C             the loop for the triangles.
C     ITRIE... When ITRI .gt. ITRIE, RPERAS is to be called.
C     KTRI_... One column from list of triangles.(all parameters
C             of the triangle):
C             KTRI(1),KTRI(2),KTRI(3)... Indices of vertices of the
C               triangle.
C             KTRI(4)... Index of the triangle.
C             KTRI(5)... Index of the basic triangle containing given
C               triangle, zero for basic triangles.
C             KTRI(6)... Type of the triangle.
C               0: new triangle.
C               1: triangle being processed.
C               2: divided triangle.
C               3: homogeneous triangle.
C               4: triangle with all two-point rays determined.
C     KTRID... Working triangle when dividing triangles and when
C             searching for two-point rays.
C     KTRIS... Auxiliary triangle when searching for two-point rays,
C             working triangle when dividing triangle with strange ray.
C     KTRIN... A new triangle to be registrated.
C     ITRNAR... Index of the triangle containing the new auxiliary ray,
C             which have been actually traced during interpolation.
C     ISHEET... Value of integer function distinguishing between rays of
C             different histories, the so-called history function.
C             The history function assigns the rays to various
C             groups according to their history, i.e. according to the
C             structural blocks and interfaces through which the ray
C             has propagated, as well as to the position of its
C             endpoint, and the caustics encountered. Rays, which have
C             propagated through the same model blocks, have crossed
C             the same boundaries, have the same phase shift due to
C             caustics, and are incident, e.g., on the surface of
C             the model, are assigned the same value of the
C             history function.
C     G1,G2... Normalized parameters of rays.
C     G11,G12,G22... Ray-parameter metric tensor.
C     S11,S12,S22... Ray-tube metric tensor.
C     X1,X2... Coordinates of the ray on the reference surface.
C     G1X1,G2X1,G1X2,G2X2... Derivations of ray parameters according to
C             the surface coordinates.
C     ITRAS,G1S,G2S... Types and normalized ray parameters
C             of the vertices of the triangle, in which new auxiliary
C             ray starts.
C     IGOTO... Indicates where to go after computing a new ray.
C     I1,I2,... Implied-do variables or variables controlling the loop.
C     J1...   Auxiliary variable  (number).
C     LNEWAR... Indicates whether the new ray is to be traced.
C     LTRI... Indicates whether a triangle is in memory.
C     LRAY ...Indicates whether a ray is in memory.
C     LAB20... Indicates that inhomogeneous triangles have been created
C             running subroutine RPTMEA or RPDIV.
C     LEND... Indicates the end of the computation (all the normalized
C             ray domain covered by basic triangles).
C-----------------------------------------------------------------------
C
C
      IF(IRAY.EQ.0) THEN
        GLIMIT(1)= 0.0
        GLIMIT(2)= 1.0
        GLIMIT(3)= 0.0
        GLIMIT(4)= 1.0
        ITRI=0
        LNEWAR=.FALSE.
        LAB20=.FALSE.
        LEND=.FALSE.
        ITRI0D=0
        ITRI0S=0
        ITRI0X=0
        ITRI0I=0
        ITRIE=100
        CALL RPTRI1(ITRI,KTRIS)
        CALL RPAUX1(ITRI,IRAY)
        CALL RPMEM(IRAY,ITYPE,ISHEET,G1,G2,G11,S11,S12,S22,G12,G22,X1,X2
     *             ,G1X1,G2X1,G1X2,G2X2)
        CALL RPDIV(KTRIS,IRAY,ITRI,G1NEW,G2NEW,LNEWAR,LAB20)
        CALL RPSTOR('R',0,KTRIS)
        CALL RPTMEA(I1,ITRI,IRAY,LNEWAR,LAB20,G1NEW,G2NEW)
        CALL RPXMEA(I1,ITRI,IRAY,LNEWAR,LAB20,G1NEW,G2NEW)
        GOTO 10
      ENDIF
C
      CALL RPSTOR('R',IRAY,KTRIS)
      GOTO (19,40,50,150,60) IGOTO
C
C
C     Covering of the ray domain with new basic triangles:
   10 CONTINUE
      IRAY0=IRAY
      ITRI0=ITRI
      LNEWAR=.FALSE.
      CALL RPNEW(IRAY,ITRI,G1NEW,G2NEW,LNEWAR)
      IF (LNEWAR) THEN
C       Trace a new ray, then go to 19.
        ITYPE=0
        IGOTO=1
        GOTO 90
      ENDIF
C
C
  19  CONTINUE
C     Storing new basic triangles:
      DO 18, I1=ITRI0+1,ITRI
        CALL RPTRI3 (I1,LTRI,KTRID)
        IF (LTRI.AND.KTRID(6).EQ.0) CALL RPSTOR ('T',1,KTRID)
  18  CONTINUE
C
C     Dividing new triangles into homogeneous triangles:
  20  CONTINUE
      I1=ITRI0D
      ITRI1=ITRI
      LAB20=.FALSE.
C
C     Loop for new triangles:
  30  CONTINUE
        I1=I1+1
        IF (I1.GT.ITRI1) GOTO 42
        CALL RPTRI3 (I1,LTRI,KTRID)
        IF (.NOT.((KTRID(6).EQ.0).AND.LTRI)) THEN
          ITRI0D=I1
          GOTO 30
        ENDIF
C
C       Dividing triangle I1 into homogeneous triangles:
  40    CONTINUE
        CALL RPDIV(KTRID,IRAY,ITRI,G1NEW,G2NEW,LNEWAR,LAB20)
        IF (LNEWAR) THEN
C         Trace a new ray, then go to 40.
          ITYPE=-2
          IGOTO=2
          GOTO 90
        ENDIF
        ITRI0D=I1
C
        IF (LAB20) THEN
C         Inhomogeneous triangles have been formed running RPDIV:
          GOTO 20
        ENDIF
      GOTO 30
C
C
C     Controlling the size of the homogeneous triangles,
C     dividing triangles too large in the ray-tube metric.
  42  CONTINUE
      I1=ITRI0S
      ITRI1=ITRI
      LNEWAR=.FALSE.
      LAB20=.FALSE.
C
C     Loop for new triangles:
  45  CONTINUE
        I1=I1+1
        IF (I1.GT.ITRI1) GOTO 51
  50    CONTINUE
        CALL RPTMEA(I1,ITRI,IRAY,LNEWAR,LAB20,G1NEW,G2NEW)
        IF (LNEWAR) THEN
C         Trace a new ray, then go to 50.
          ITYPE=-2
          IGOTO=3
          GOTO 90
        ENDIF
        ITRI0S=I1
      GOTO 45
C
  51  CONTINUE
      IF (LAB20) THEN
C       Inhomogeneous triangles have been formed running RPTMEA:
        GOTO 20
      ENDIF
      IF (I1.LT.ITRI) THEN
C       New homogeneous triangles to be measured
C       have been formed running RPTMEA:
        GOTO 42
      ENDIF
C
C
C
C     Controlling the size of the homogeneous triangles,
C     dividing triangles too large in reference surface.
  142 CONTINUE
      IF (PRM0(2).EQ.0.) THEN
C       The value of PRM0(2) is given by input data. PRM0(2)=0 indicates
C       that triangles are not to be measured on the reference surface.
        GOTO 53
      ENDIF
      I1=ITRI0X
      ITRI1=ITRI
      LNEWAR=.FALSE.
      LAB20=.FALSE.
C
C     Loop for new triangles:
  145 CONTINUE
        I1=I1+1
        IF (I1.GT.ITRI1) GOTO 151
  150   CONTINUE
        CALL RPXMEA(I1,ITRI,IRAY,LNEWAR,LAB20,G1NEW,G2NEW)
        IF (LNEWAR) THEN
C         Trace a new ray, then go to 150.
          ITYPE=-2
          IGOTO=4
          GOTO 90
        ENDIF
        ITRI0X=I1
      GOTO 145
C
  151 CONTINUE
      IF (LAB20) THEN
C       Inhomogeneous triangles have been formed running RPXMEA:
        GOTO 20
      ENDIF
      IF (I1.LT.ITRI) THEN
C       New homogeneous triangles have been formed running RPXMEA:
        GOTO 142
      ENDIF
C
C
C     Searching for two-point rays in new homogeneous triangles:
  53  CONTINUE
      I1=ITRI0I
      ITRI1=ITRI
C
C     Loop for new homogeneous triangles:
  55  CONTINUE
        I1=I1+1
        IF (I1.GT.ITRI1) THEN
          IF ((ITRI.NE.ITRI0).OR.(IRAY.NE.IRAY0)) THEN
            IF (ITRI.GE.ITRIE) THEN
C             Deleting unneeded rays and triangles:
              CALL RPERAS
              ITRIE=ITRIE+100
            ENDIF
C           New basic triangle.
            GOTO 10
          ELSE
            IF (.NOT.LEND) THEN
              LEND=.TRUE.
              GOTO 53
            ELSE
C             End of the two-point ray tracing.
              GOTO 95
            ENDIF
          ENDIF
        ENDIF
        CALL RPTRI3(I1,LTRI,KTRID)
        IF (.NOT.((KTRID(6).EQ.3).AND.LTRI)) THEN
          IF (I1.EQ.ITRI0I+1) ITRI0I=I1
          GOTO 55
        ENDIF
        CALL RPRAY(KTRID(1),LRAY,ITYPE,ISHEET,G1,G2,
     *             G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        LNEWAR=.FALSE.
C
  60    CONTINUE
        IF (LNEWAR) THEN
C         Last traced ray:
          CALL RPRAY(IRAY,LRAY,ITYPE,ISHEET,G1,G2,
     *               G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
C         First ray of the triangle in which the last traced ray starts:
          CALL RPTRI3(ITRNAR,LTRI,KTRIS)
          IF (.NOT.LTRI) CALL RPERR(2)
          CALL RPRAY(KTRIS(1),LRAY,ITRAS(1),ISH,G1S(1),G2S(1),
     *               G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
C
          IF (ISH.NE.ISHEET) THEN
C           Strange ray identified inside homogeneous triangle:
            GOTO 70
          ENDIF
        ENDIF
        CALL RPINTP(KTRID,LNEWAR,IRAY,ITRI,LEND,
     *              G1NEW,G2NEW,ITRNAR,ITYPE)
        IF (LNEWAR) THEN
C         Trace a new ray, then go to 60.
          IGOTO=5
          GOTO 90
        ENDIF
        IF ((KTRID(6).EQ.4).AND.(I1.EQ.ITRI0I+1)) ITRI0I=I1
      GOTO 55
C
C
C     A strange ray identified inside the homogeneous triangle ITRNAR:
  70  CONTINUE
      CALL RPRAY(KTRIS(2),LRAY,ITRAS(2),ISH,G1S(2),G2S(2),
     *           G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KTRIS(3),LRAY,ITRAS(3),ISH,G1S(3),G2S(3),
     *           G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
C     Dividing of the triangle into inhomogeneous triangles:
      KTRIS(6)=2
      CALL RPTRI2(KTRIS(4),LTRI,KTRIS)
      IF (.NOT.LTRI) CALL RPERR(2)
      IF (KTRIS(5).EQ.0) THEN
        KTRIN(5)=KTRIS(4)
      ELSE
        KTRIN(5)=KTRIS(5)
      ENDIF
      KTRIN(6)=0
      DO 72, I2=1,3
        ITRI=ITRI+1
        KTRIN(1)=KTRIS(I2)
        KTRIN(2)=KTRIS(I2+1)
        IF (I2.EQ.3) KTRIN(2)=KTRIS(1)
        KTRIN(3)=IRAY
        KTRIN(4)=ITRI
        CALL RPTRI1(ITRI,KTRIN)
        CALL RPSTOR('T',1,KTRIN)
  72  CONTINUE
      GOTO 20
C
C
C     Tracing a new ray:
  90  CONTINUE
      IRAY=IRAY+1
      RETURN
C
C
C     End of computation:
  95  CONTINUE
C
      CALL RPSTOR('R',-1,KTRIS)
      IRAY=0
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RPDIV(KTRID,IRAY,ITRI,G1NEW,G2NEW,LNEWAR,LAB20)
C
C-----------------------------------------------------------------------
      INTEGER KTRID(6),IRAY,ITRI
      REAL G1NEW,G2NEW
      LOGICAL LNEWAR,LAB20
C Subroutine designed to divide the given triangle into homogeneous
C triangles.  The given triangle must not be altered between individual
C invocations of this subroutine until the given triangle is completely
C covered by homogeneous triangles.
C
C Input:
C     KTRID... Parameters of the triangle to be divided (one column of
C             array KTRI).
C     IRAY... Index of the last traced ray.
C     ITRI... Index of the last triangle.
C Output:
C     G1NEW,G2NEW... If a new ray is to be traced,
C             parameters of the new ray.
C     LNEWAR... Indicates whether a new ray is to be traced.
C     LAB20... Indicates that inhomogeneous triangles were made running
C             the subroutine RPDIV.
C
C Subroutines and external functions required:
      EXTERNAL RPLRIP,RPLRIL,RPLRIT,RPDI2G
      REAL RPDI2G
      LOGICAL RPLRIP,RPLRIL,RPLRIT
C
C Coded by Petr Bulant
C
C.......................................................................
C
C Common blocks /GLIM/ and /BOURA/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C............................
C
C Common block /RPARD/:
      INCLUDE 'rpard.inc'
C     rpard.inc
C     AERR... Maximum distance of the boundary rays.
C     PRM0(1)... Maximum allowed distance of the boundary ray from the
C             shadow zone (measured on the reference surface).
C.......................................................................
C
      REAL ZERO,ZERO1,SIDE
      PARAMETER (ZERO =.0000001)
      PARAMETER (ZERO1=.0000000001)
      PARAMETER (SIDE=1.1547)
      REAL BSTEP2
      PARAMETER (BSTEP2=0.23)
      REAL AERR2
      REAL AR0
C                                                   
      INTEGER MPOL,MPOLH
      PARAMETER (MPOL=500)
      PARAMETER (MPOLH=500)
      INTEGER NPOL,NPOLH,KPOL(MPOL,4),KPOLH(MPOLH,4)
      REAL GPOL(MPOL,2),GPOLH(MPOLH,2)
      INTEGER MLINE
      PARAMETER (MLINE=500)
      INTEGER NLINE,KLINE(MLINE,4)
      INTEGER KTRIN(6),KTRIS(6),KTRIT(6)
      INTEGER MAXR
      INTEGER ITYPE,ISH
      REAL G1,G2,G11,G12,G22,X1,X2
      REAL G1X1,G2X1,G1X2,G2X2
      INTEGER KRAYA0,KRAYB0
      INTEGER KRAYA,ITYPEA,ISHA,KRAYB,ITYPEB,ISHB,KRAYC,ITYPEC,ISHC,
     *        KRAYD,ITYPED,ISHD,KRAYE,KRAYI,KRAYJ
      INTEGER KRAYD0
      INTEGER ITYPEX,ISHX
      REAL G1X,G2X,G11X,G12X,G22X
      REAL G1A,G2A,G11A,G12A,G22A,G1X1A,G2X1A,G1X2A,G2X2A,
     *     G1B,G2B,G11B,G12B,G22B,G1X1B,G2X1B,G1X2B,G2X2B,
     *     G1C,G2C,G11C,G12C,G22C,G1X1C,G2X1C,G1X2C,G2X2C,
     *     G1D,G2D,G11D,G12D,G22D,G1X1D,G2X1D,G1X2D,G2X2D,
     *     G1E,G2E,G1I,G2I,G1J,G2J,G1K,G2K
      REAL AREA,AREA1,DIST2,MINDIS
      REAL G11POM,G12POM,G22POM
      REAL DG1,DG2,AAA,BBB,DETG,SQ
      REAL DG1N,DG2N,PAR
      INTEGER IGOTO,ISTART,INEWR,ISHP
      INTEGER I1,I2,I3,I4,I5
      INTEGER J1,J2,J3,J4,J5,J6,J30
      LOGICAL LRAY,LTRI,LSTORE,LINTS,LDGEAE
      SAVE AERR2,AR0,
     *     NPOL,KPOL,GPOL,I1,IGOTO,KRAYA,KRAYB,ISHA,ISHB,ITYPEA,ITYPEB,
     *     G1A,G2A,G1B,G2B,G11A,G11B,G12A,G12B,G22A,G22B,NLINE,KLINE,
     *     KRAYA0,KRAYB0,ISTART,J1,J2,J3,J4,INEWR,AAA,BBB,SQ,KRAYE
     *    ,KRAYC,ISHC,ITYPEC,G1C,G2C,G11C,G12C,G22C,LSTORE,ISHP,J5
     *    ,NPOLH,KPOLH,GPOLH,DG1N,DG2N,PAR,G11POM,G12POM,G22POM
     *    ,KRAYD0,LDGEAE,J30
C     ZERO... Constant used to decide whether the real variable.EQ.zero.
C     SIDE... Length of basic triangles sides.
C     BSTEP2... The boundary is traced with minimal
C             step BSTEP(=SQRT(BSTEP2)).
C     AERR2... Second power of the maximum distance of the boundary rays.
C     AR0...  Area of the smallest considered triangle.
C     MPOL,MPOLH... Dimension of arrays KPOL,GPOL,KPOLH,GPOLH.
C     NPOL,NPOLH... Number of rays forming the polygons KPOL,GPOL,KPOLH.
C     KPOL(I,1)... Indices of rays forming the inhomogeneous polygon
C             to be divided into homogeneous polygons.
C     KPOL(I,2)... Values of integer history functions of rays forming
C             the polygon.
C     KPOL(I,3)... Types of rays forming the polygon.
C     KPOL(I,4)... For boundary ray, the value of history function of
C                  the other ray from the pair of the boundary rays.
C                  Otherwise zero.
C     GPOL(I,1),GPOL(I,2)... Normalized parameters of rays forming
C             the polygon.
C     KPOLH(I,1)... Indices of the rays forming the homogeneous polygon
C             to be divided into homogeneous triangles.
C     KPOLH(I,2)... Histories of rays forming the polygon.
C     KPOLH(I,3)... Types of rays forming the polygon.
C     KPOLH(I,4)... For boundary ray the value of history function of
C             the other ray from the pair of the boundary rays or zero.
C     GPOLH(I,1),GPOLH(I,2)... Normalized parameters of the rays forming
C             the homogeneous polygon.
C     NLINE... Number of rays in KLINE.
C     KLINE... When searching for boundary rays on the sides of divided
C             triangle by halving intervals:
C             KLINE(I,1)... Rays shot during the division of the
C               interval.
C             KLINE(I,2)... Histories of these rays.
C             KLINE(I,3)... Types of these rays.
C             KLINE(I,4)... The value of history function of the other
C               ray from the pair of the boundary rays or zero.
C     KLINE... When demarcating the boundary of the homogeneous polygon:
C             KLINE(1,1)... The first ray of the homogeneous polygon.
C             KLINE(NLINE,1)... The last ray of the homogeneous polygon.
C             KLINE(I,1)... Rays shot during demarcating the boundary.
C               KLINE(I,1).LT.0 notes that side I,I+1 in KLINE is to be
C               divided.
C             KLINE(I,2)... Histories of these rays.
C             KLINE(I,3)... Types of these rays.
C             KLINE(I,4) .. The value of history function of the other
C               ray from the pair of the boundary rays.
C     KTRIN... Parameters of the new triangle to be registrated (new
C             column to be added into array KTRI).
C     KTRIS... Working triangle when dividing incorrectly made triangle.
C     MAXR... Maximum number of the rays in one group.
C     ITYPE... Type of ray:
C             0: .......... Basic ray.
C             ITYPE.GT.0:.. Boundary ray, ITYPE is the index of the
C                           boundary ray at the other side of the bound.
C             -2:.......... Auxiliary ray,not used.
C             -3:.......... Auxiliary ray,used.
C             -1000-I:..... Two-point ray (to the I'th receiver).
C     ISHEET... Value of integer function distinguishing between rays of
C             different histories.
C     G1,G2... Normalized parameters of rays.
C     G11,G12,G22... Ray-parameter metric tensor.
C     X1,X2... Coordinates of the ray on the reference surface.
C     G1X1,G2X1,G1X2,G2X2... Derivations of ray parameters according to
C             surface coordinates.
C     KRAYA0,KRAYB0... Indices of rays forming original divided
C             interval.
C     KRAYD0... Index of the ray which has indicated that previous
C             triangles have not been formed correctly.
C     KRAYA,B,C,...  Signs of rays.            |   Auxiliary
C     ITYPEA,B,C,... Types of rays.            |   variables used
C     ISHA,B,C,...   Value of history function.|   for different rays.
C     Gi(i)A,B,C,... Parameters of rays.       |
C     AREA... Auxiliary variable (area of the triangle).
C     DIST2... Second power of the distance of two rays.
C     MINDIS... Minimum of the distances between the rays.
C     GiiPOM... Average value of the metric tensor.
C     DG1,DG2,AAA,BBB,DETG,SQ...  Auxiliary variables used to compute
C             the distance of rays or the parameters of a new ray.
C     DG1N,DG2N... Differences of a new ray D from ray C.
C     PAR...  Parameter controlling the difference of a new ray D and C.
C     IGOTO... Indicates where to go after computing a new ray.
C     ISTART... Counts the groups of rays in NPOL, where the demarcation
C             of the boundary leads to crash.
C     INEWR... Counts how many times the new ray D was proposed.
C             INEWR=-1 indicates that D is an intersection point.
C     ISHP... Isheet of the rays of the homogeneous polygon.
C     I1,2,3,4... Implied-do variables or variables controlling a loop.
C     I1...   Controls the main loop of checking KPOL (until label 50).
C     I4...   When ISTART.GT.0 and searching for basic homogeneous
C             polygon, I4 is the reduced value of ISTART.
C     J1,2,3,4... Auxiliary variables (numbers).
C     J1..    Free until label 100, than sequence in KPOL of the
C             beginning of the KPOLH.
C     J2...   Free until label 100, than sequence in KPOL of the
C             end of the KPOLH.
C     J3...   Free until label 105, than shows actual position in KLINE.
C     J4...   The sequence in KPOL of the side where
C             the intersection has occurred.
C     J5...   When MAXR=0 and starting consequently from all the groups,
C             the sequence of the group.
C     J30...  Used when closing the homogeneous polygon:
C               J30.LE.J3 initiates the search for neighbouring rays of
C                 KLINE with different values of KLINE(I,3).
C               Then the part of boundary between these rays is
C                 demarcated and J30 stores the value of J3.
C               After this J30 is assigned the value 999999 and the
C                 demarcation of the boundary continues.
C     LRAY... Indicates whether the ray IRAY is in memory.
C     LTRI... Indicates whether the triangle ITRI is in memory.
C     LSTORE... LSTORE=TRUE indicates that the polygon was repaired and
C             that new boundary rays may have to be stored in KBR.
C     LINTS... Indicates whether the intersection appeared.
C     LDGEAE... Indicates that the new ray D is being searched with
C             minimal step DG equal to AERR.
C-----------------------------------------------------------------------
C
C     Start of triangle dividing
      IF (IRAY.EQ.0) THEN
        NBR=0
        AERR2=AERR**2
        AR0=AERR2*0.4330127/9.
        ISTART=0
        PAR=0.05
        LNEWAR=.FALSE.
        LSTORE=.FALSE.
        J5=0
        RETURN
      ENDIF
C
      IF (KTRID(6).EQ.1) THEN
        GOTO (30,110,120,130,160) IGOTO
      ENDIF
C
      IF (AERR.GT.1.) THEN
C       Boundary rays are not to be searched for,
C       triangle is not to be divided:
        KTRID(6)=2
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C
      LNEWAR=.FALSE.
      ISTART=0
      LSTORE=.FALSE.
      J5=0
      CALL RPRAY(KTRID(1),LRAY,ITYPEA,ISHA,G1A,G2A,G11A,G12A,G22A,
     *           X1,X2,G1X1A,G2X1A,G1X2A,G2X2A)
      IF (.NOT.LRAY) CALL RPERR(1)
      KRAYA=KTRID(1)
      CALL RPRAY(KTRID(2),LRAY,ITYPEB,ISHB,G1B,G2B,G11B,G12B,G22B,
     *           X1,X2,G1X1B,G2X1B,G1X2B,G2X2B)
      IF (.NOT.LRAY) CALL RPERR(1)
      KRAYB=KTRID(2)
      CALL RPRAY(KTRID(3),LRAY,ITYPEC,ISHC,G1C,G2C,G11C,G12C,G22C,
     *           X1,X2,G1X1C,G2X1C,G1X2C,G2X2C)
      IF (.NOT.LRAY) CALL RPERR(1)
      KRAYC=KTRID(3)
C     ..A,..B,..C .. Vertices of divided triangle.
C     Controlling the size of triangle surface :
      G11POM=(G11A+G11C+G11B)/3.
      G12POM=(G12A+G12C+G12B)/3.
      G22POM=(G22A+G22C+G22B)/3.
      DG1=G1B-G1A
      DG2=G2B-G2A
      DETG=G11POM*G22POM - G12POM*G12POM
      IF (DETG.LT.ZERO) CALL RPERR(4)
      AREA=SQRT(DETG)*((DG1*(G2C-G2A)-DG2*(G1C-G1A))*.5)
      IF (AREA.LT.AR0) THEN
C       0.4330127=SQRT(3)/4
C       Triangle too small or left-handed.
        KTRID(6)=2
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C     Controlling the size of triangle sides:
      DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
      IF (DIST2.LE.AERR2*0.25) KTRID(6)=2
      DIST2=RPDI2G(G1C,G2C,G1B,G2B,G11POM,G12POM,G22POM)
      IF (DIST2.LE.AERR2*0.25) KTRID(6)=2
      DIST2=RPDI2G(G1A,G2A,G1C,G2C,G11POM,G12POM,G22POM)
      IF (DIST2.LE.AERR2*0.25) KTRID(6)=2
      IF (KTRID(6).EQ.2) THEN
C       Triangle too small.
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C
      KTRID(6)=1
      NPOL=3
      KPOL(1,1)=KTRID(1)
      KPOL(2,1)=KTRID(2)
      KPOL(3,1)=KTRID(3)
      KPOL(1,2)=ISHA
      KPOL(2,2)=ISHB
      KPOL(3,2)=ISHC
      KPOL(1,3)=ITYPEA
      KPOL(2,3)=ITYPEB
      KPOL(3,3)=ITYPEC
      KPOL(1,4)=0
      KPOL(2,4)=0
      KPOL(3,4)=0
      GPOL(1,1)=G1A
      GPOL(2,1)=G1B
      GPOL(3,1)=G1C
      GPOL(1,2)=G2A
      GPOL(2,2)=G2B
      GPOL(3,2)=G2C
C
C     Array KBR must be searched and the rays from KBR must be used.
C     Loop for rays in array KBR:
      KRAYB0=0
      I2=1
      IF (NBR.GT.2) THEN
  1   CONTINUE
        IF ((KRAYA.EQ.KBR(I2,1)).AND.(KRAYB.EQ.KBR(I2+1,1))) THEN
          KRAYB0=KRAYB
          KRAYA0=KRAYA
        ENDIF
        IF ((KRAYB.EQ.KBR(I2,1)).AND.(KRAYC.EQ.KBR(I2+1,1))) THEN
          KRAYB0=KRAYC
          KRAYA0=KRAYB
        ENDIF
        IF ((KRAYC.EQ.KBR(I2,1)).AND.(KRAYA.EQ.KBR(I2+1,1))) THEN
          KRAYB0=KRAYA
          KRAYA0=KRAYC
        ENDIF
        J1=KBR(I2+2,1)
        IF (KRAYB0.NE.0) THEN
C         Boundary rays found in KBR, correcting polygon:
          DO 2, I1=1,NPOL
            IF (KPOL(I1,1).EQ.KRAYB0) J3=I1
  2       CONTINUE
C
          IF (KRAYB.NE.KBR(I2+3,1)) THEN
            IF (NPOL.GE.MPOL) CALL RPERR(5)
            DO 4, I3=NPOL,J3,-1
              KPOL(I3+1,1)=KPOL(I3,1)
              KPOL(I3+1,2)=KPOL(I3,2)
              KPOL(I3+1,3)=KPOL(I3,3)
              KPOL(I3+1,4)=KPOL(I3,4)
              GPOL(I3+1,1)=GPOL(I3,1)
              GPOL(I3+1,2)=GPOL(I3,2)
  4         CONTINUE
            KPOL(J3,1)=KBR(I2+3,1)
            KPOL(J3,2)=KBR(I2+3,2)
            KPOL(J3,3)=KBR(I2+3,3)
            KPOL(J3,4)=0
            IF (KPOL(J3,3).GT.0) THEN
              CALL RPRAY(KPOL(J3,3),LRAY,ITYPE,ISH,G1,G2,
     *                   G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
              IF (LRAY) THEN
                KPOL(J3,4)=ISH
              ENDIF
            ENDIF
            GPOL(J3,1)=GBR(I2+3,1)
            GPOL(J3,2)=GBR(I2+3,2)
            NPOL=NPOL+1
            J3=J3+1
          ENDIF
C
          IF (J1.GE.3) THEN
            IF (NPOL+J1-2.GT.MPOL) CALL RPERR(5)
            DO 6, I3=NPOL,J3,-1
              KPOL(I3+J1-2,1)=KPOL(I3,1)
              KPOL(I3+J1-2,2)=KPOL(I3,2)
              KPOL(I3+J1-2,3)=KPOL(I3,3)
              KPOL(I3+J1-2,4)=KPOL(I3,4)
              GPOL(I3+J1-2,1)=GPOL(I3,1)
              GPOL(I3+J1-2,2)=GPOL(I3,2)
  6         CONTINUE
            DO 8, I3=2,J1-1
              KPOL(J3-2+I3,1)=KBR(I2+2+I3,1)
              KPOL(J3-2+I3,2)=KBR(I2+2+I3,2)
              KPOL(J3-2+I3,3)=KBR(I2+2+I3,3)
              KPOL(J3-2+I3,4)=0
              IF (KPOL(J3-2+I3,3).GT.0) THEN
                CALL RPRAY(KPOL(J3-2+I3,3),LRAY,ITYPE,ISH,G1,G2,
     *                     G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
                IF (LRAY) THEN
                  KPOL(J3-2+I3,4)=ISH
                ENDIF
              ENDIF
              GPOL(J3-2+I3,1)=GBR(I2+2+I3,1)
              GPOL(J3-2+I3,2)=GBR(I2+2+I3,2)
  8         CONTINUE
            NPOL=NPOL+J1-2
            J3=J3+J1-2
          ENDIF
C
          IF (J1.GE.2) THEN
            IF (KRAYA.NE.KBR(I2+2+J1,1)) THEN
              IF (NPOL+1.GT.MPOL) CALL RPERR(5)
              DO 10, I3=NPOL,J3,-1
                KPOL(I3+1,1)=KPOL(I3,1)
                KPOL(I3+1,2)=KPOL(I3,2)
                KPOL(I3+1,3)=KPOL(I3,3)
                KPOL(I3+1,4)=KPOL(I3,4)
                GPOL(I3+1,1)=GPOL(I3,1)
                GPOL(I3+1,2)=GPOL(I3,2)
  10          CONTINUE
              KPOL(J3,1)=KBR(I2+2+J1,1)
              KPOL(J3,2)=KBR(I2+2+J1,2)
              KPOL(J3,3)=KBR(I2+2+J1,3)
              KPOL(J3,4)=0
              IF (KPOL(J3,3).GT.0) THEN
                CALL RPRAY(KPOL(J3,3),LRAY,ITYPE,ISH,G1,G2,
     *                     G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
                IF (LRAY) THEN
                  KPOL(J3,4)=ISH
                ENDIF
              ENDIF
              GPOL(J3,1)=GBR(I2+2+J1,1)
              GPOL(J3,2)=GBR(I2+2+J1,2)
              NPOL=NPOL+1
            ENDIF
          ENDIF
C
          J2=J1+3
          NBR=NBR-J2
          DO 12, I3=I2,NBR
            KBR(I3,1)=KBR(I3+J2,1)
            KBR(I3,2)=KBR(I3+J2,2)
            KBR(I3,3)=KBR(I3+J2,3)
            GBR(I3,1)=GBR(I3+J2,1)
            GBR(I3,2)=GBR(I3+J2,2)
  12      CONTINUE
          KRAYB0=0
          IF (I2.LT.NBR) GOTO 1
C
        ENDIF
        I2=I2+3+J1
      IF (I2.LT.NBR) GOTO 1
      ENDIF
C     End of the loop for KBR.
      IF ((NPOL.EQ.3).AND.(ISHA.EQ.ISHB).AND.(ISHA.EQ.ISHC)) THEN
C       Triangle is really homogeneous:
        KTRID(6)=3
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C
C     Checking the integrity of the inhomogeneous polygon.
C     Finding boundary rays, if needed.
C
  15  CONTINUE
C     Checking the size of the sides of the polygon:
      J6=0
      CALL RPRAY(KPOL(NPOL,1),LRAY,ITYPE,ISH,G1,G2,G11A,G12A,G22A,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KPOL(1,1),LRAY,ITYPE,ISH,G1,G2,G11B,G12B,G22B,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      G11POM=(G11A+G11B)/2.
      G12POM=(G12A+G12B)/2.
      G22POM=(G22A+G22B)/2.
      DIST2=RPDI2G(GPOL(1,1),GPOL(1,2),GPOL(NPOL,1),GPOL(NPOL,2),
     *             G11POM,G12POM,G22POM)
      IF (DIST2.LE.AERR2) THEN
        J6=J6+1
      ENDIF
      DO 16, I1=1,NPOL-1
        CALL RPRAY(KPOL(I1,1),LRAY,ITYPE,ISH,G1,G2,G11A,G12A,G22A,
     *             X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(KPOL(I1+1,1),LRAY,ITYPE,ISH,G1,G2,G11B,G12B,G22B,
     *             X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        G11POM=(G11A+G11B)/2.
        G12POM=(G12A+G12B)/2.
        G22POM=(G22A+G22B)/2.
        DIST2=RPDI2G(GPOL(I1,1),GPOL(I1,2),GPOL(I1+1,1),GPOL(I1+1,2),
     *               G11POM,G12POM,G22POM)
        IF (DIST2.LE.AERR2) THEN
          J6=J6+1
        ENDIF
  16  CONTINUE
      IF (J6.EQ.NPOL) THEN
C       All of the sides of the polygon are shorter than AERR:
        GOTO 21
      ENDIF
C     Checking the size of the polygon:
      AREA1=0.
      DO 19, I1=1,NPOL-2
        CALL RPRAY(KPOL(I1,1),LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *             X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        DG1=GPOL(I1,1)-GPOL(NPOL,1)
        DG2=GPOL(I1,2)-GPOL(NPOL,2)
        DETG=G11*G22 - G12*G12
        IF (DETG.LT.ZERO) CALL RPERR(4)
        AREA=SQRT(DETG)*((DG1*(GPOL(I1+1,2)-GPOL(I1,2))
     *       -DG2*(GPOL(I1+1,1)-GPOL(I1,1)))*.5)
        AREA1=AREA1+AREA
 19   CONTINUE
      IF (AREA1.GE.AR0) THEN
        I1=2
        GOTO 20
      ENDIF
C     The area of the polygon is quite little:
  21  CONTINUE
C       The inhomogeneous polygon will be simply divided into
C       homogeneous triangles:
        I1=1
  18    CONTINUE
          IF(I1.GT.1) THEN
            J1=I1-1
          ELSE
            J1=NPOL
          ENDIF
          IF(I1.LT.NPOL) THEN
            J2=I1+1
          ELSE
            J2=1
          ENDIF
          IF ((KPOL(J1,2).EQ.KPOL(I1,2)).AND.
     *        (KPOL(J2,2).EQ.KPOL(I1,2))) THEN
            IF (RPLRIT(.FALSE.,GPOL(J1,1),GPOL(J1,2),GPOL(I1,1),
     *          GPOL(I1,2),GPOL(J2,1),GPOL(J2,2),G1A,G2A,AREA)) THEN
              ITRI=ITRI+1
              KTRIN(1)=IABS(KPOL(J1,1))
              KTRIN(2)=IABS(KPOL(I1,1))
              KTRIN(3)=IABS(KPOL(J2,1))
              KTRIN(4)=ITRI
              IF (KTRID(5).EQ.0) THEN
                KTRIN(5)=KTRID(4)
              ELSE
                KTRIN(5)=KTRID(5)
              ENDIF
              KTRIN(6)=3
              CALL RPTRI1(ITRI,KTRIN)
              CALL RPSTOR('T',1,KTRIN)
              NPOL=NPOL-1
              DO 17, I2=I1,NPOL
                KPOL(I1,1)=KPOL(I1+1,1)
                KPOL(I1,2)=KPOL(I1+1,2)
                KPOL(I1,3)=KPOL(I1+1,3)
                KPOL(I1,4)=KPOL(I1+1,4)
                GPOL(I1,1)=GPOL(I1+1,1)
                GPOL(I1,2)=GPOL(I1+1,2)
  17          CONTINUE
              I1=1
              GOTO 18
            ENDIF
          ENDIF
        I1=I1+1
        IF (I1.LE.NPOL) GOTO 18
        KTRID(6)=2
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        LNEWAR=.FALSE.
        RETURN
C     The inhomogeneous polygon was simply divided into
C     homogeneous triangles.
C
C     Loop for rays in the inhomogeneous polygon:
  20  CONTINUE
C       Rays with the same ISHEET:
        IF (KPOL(I1-1,2).EQ.KPOL(I1,2)) GOTO 50
C
C       Boundary rays:
        IF ((KPOL(I1-1,3).EQ.KPOL(I1,1)).OR.
     *      (KPOL(I1-1,1).EQ.KPOL(I1,3))) GOTO 50
C
        KRAYA=KPOL(I1-1,1)
        KRAYB=KPOL(I1,1)
        IF ((GPOL(I1-1,2).EQ.GLIMIT(3)).AND.(GPOL(I1,2).EQ.GLIMIT(3)))
     *    THEN
          KRAYA0=0
          KRAYB0=0
        ELSE
          KRAYA0=KRAYA
          KRAYB0=KRAYB
        ENDIF
C
C       Dividing the interval KPOL(I1-1,1),KPOL(I1,1):
        CALL RPRAY(KRAYA,LRAY,ITYPEA,ISHA,G1A,G2A,
     *            G11A,G12A,G22A,X1,X2,G1X1A,G2X1A,G1X2A,G2X2A)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(KRAYB,LRAY,ITYPEB,ISHB,G1B,G2B,
     *            G11B,G12B,G22B,X1,X2,G1X1B,G2X1B,G1X2B,G2X2B)
        IF (.NOT.LRAY) CALL RPERR(1)
        NLINE=0
        GOTO 40
C
C       Entry point when a new ray C was traced during the
C       division of the interval formed by rays A and B.
  30    CALL RPRAY(IRAY,LRAY,ITYPEC,ISHC,G1C,G2C,G11C,G12C,G22C,X1,X2
     *            ,G1X1C,G2X1C,G1X2C,G2X2C)
        IF (.NOT.LRAY) CALL RPERR(1)
        KRAYC=IRAY
        IF (ISHC.EQ.ISHA) THEN
           KRAYA= KRAYC
          ITYPEA=ITYPEC
             G1A=   G1C
             G2A=   G2C
            G11A=  G11C
            G12A=  G12C
            G22A=  G22C
           G1X1A= G1X1C
           G2X1A= G2X1C
           G1X2A= G1X2C
           G2X2A= G2X2C
        ELSE
          IF (NLINE.GE.MLINE) CALL RPERR(7)
          NLINE=NLINE+1
          KLINE(NLINE,1)=KRAYB
          KLINE(NLINE,2)=ISHB
          KLINE(NLINE,3)=ITYPEB
          KLINE(NLINE,4)=0
          IF (ITYPEB.GT.0) THEN
            CALL RPRAY(ITYPEB,LRAY,ITYPE,ISH,G1,G2,
     *                 G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
            IF (LRAY) THEN
              KLINE(NLINE,4)=ISH
            ENDIF
          ENDIF
           KRAYB= KRAYC
          ITYPEB=ITYPEC
            ISHB=  ISHC
             G1B=   G1C
             G2B=   G2C
            G11B=  G11C
            G12B=  G12C
            G22B=  G22C
           G1X1B= G1X1C
           G2X1B= G2X1C
           G1X2B= G1X2C
           G2X2B= G2X2C
        ENDIF
C
  40    CONTINUE
C       Interval A,B is proposed, now deciding whether is to be divided:
        G11POM=(G11A+G11B)/2.
        G12POM=(G12A+G12B)/2.
        G22POM=(G22A+G22B)/2.
        DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
        IF (DIST2.GT.AERR2) THEN
          G1NEW=(G1A+G1B)/2.
          G2NEW=(G2A+G2B)/2.
          IF (((G1NEW.EQ.G1A).AND.(G2NEW.EQ.G2A)).OR.
     *        ((G1NEW.EQ.G1B).AND.(G2NEW.EQ.G2B))) CALL RPERR(3)
C         Trace a new ray, then go to 30.
          IGOTO=1
          LNEWAR=.TRUE.
          RETURN
        ELSE
          IF (PRM0(1).NE.0.) THEN
            IF ((ISHA.GT.0).OR.(ISHB.GT.0)) THEN
              CALL RPMEGS(ISHA,ISHB,G1X1A,G2X1A,G1X2A,G2X2A,
     *                              G1X1B,G2X1B,G1X2B,G2X2B,G11,G12,G22)
              DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11,G12,G22)
              IF (DIST2.GT.1.) THEN
                G1NEW=(G1A+G1B)/2.
                G2NEW=(G2A+G2B)/2.
                IF (((G1NEW.EQ.G1A).AND.(G2NEW.EQ.G2A)).OR.
     *              ((G1NEW.EQ.G1B).AND.(G2NEW.EQ.G2B))) CALL RPERR(3)
C               Trace a new ray, then go to 30.
                IGOTO=1
                LNEWAR=.TRUE.
                RETURN
              ENDIF
            ENDIF
          ENDIF
C         Rays A and B are boundary rays:
          CALL RPRAY(KRAYA,LRAY,ITYPEA,ISHA,G1A,G2A,G11A,G12A,G22A,X1,X2
     *               ,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          ITYPEA=KRAYB
          CALL RPMC1(KRAYA,ITYPEA)
          CALL RPSTOR('R',KRAYA,KTRIS)
          CALL RPRAY(KRAYB,LRAY,ITYPEB,ISHB,G1B,G2B,G11B,G12B,G22B,X1,X2
     *               ,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          ITYPEB=KRAYA
          CALL RPMC1(KRAYB,ITYPEB)
          CALL RPSTOR('R',KRAYB,KTRIS)
          IF (LSTORE) THEN
C           When the rays are on the sides of the basic triangle which
C           contains the divided triangle, storing them to the KBR:
            IF (KTRID(5).NE.0) THEN
              CALL RPTRI3(KTRID(5),LTRI,KTRIS)
              IF (.NOT.LTRI) CALL RPERR(2)
            ELSE
              KTRIS(1)=KTRID(1)
              KTRIS(2)=KTRID(2)
              KTRIS(3)=KTRID(3)
            ENDIF
            CALL RPRAY(KTRIS(1),LRAY,ITYPEC,ISHC,G1C,G2C,G11C,G12C,G22C,
     *                 X1,X2,G1X1,G2X1,G1X2,G2X2)
            IF (.NOT.LRAY) CALL RPERR(1)
            CALL RPRAY(KTRIS(2),LRAY,ITYPED,ISHD,G1D,G2D,G11D,G12D,G22D,
     *                 X1,X2,G1X1,G2X1,G1X2,G2X2)
            IF (.NOT.LRAY) CALL RPERR(1)
            CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1E,G2E,G11,G12,G22,
     *                 X1,X2,G1X1,G2X1,G1X2,G2X2)
            IF (.NOT.LRAY) CALL RPERR(1)
            IF (RPLRIL(G1A,G2A,G1C,G2C,G1E,G2E).AND.
     *          RPLRIL(G1B,G2B,G1C,G2C,G1E,G2E)) THEN
C             Boundary rays are lying on the side CE (side 3,1):
              KRAYC=KTRIS(1)
              KRAYD=KTRIS(3)
            ELSEIF (RPLRIL(G1A,G2A,G1C,G2C,G1D,G2D).AND.
     *              RPLRIL(G1B,G2B,G1C,G2C,G1D,G2D)) THEN
C             Boundary rays are lying on the side CD (side 1,2):
              KRAYC=KTRIS(2)
              KRAYD=KTRIS(1)
            ELSEIF (RPLRIL(G1A,G2A,G1D,G2D,G1E,G2E).AND.
     *              RPLRIL(G1B,G2B,G1D,G2D,G1E,G2E)) THEN
C             Boundary rays are lying on the side DE (side 2,3):
              KRAYC=KTRIS(3)
              KRAYD=KTRIS(2)
            ELSE
C             Rays are not on the sides of the basic triangle:
              GOTO 42
            ENDIF
            J4=1
            IF (NBR.GT.2) THEN
  41        CONTINUE
C             Loop for the rays in KBR:
              IF ((KBR(J4,1).EQ.KRAYC).AND.(KBR(J4+1,1).EQ.KRAYD)) THEN
                IF (KBR(J4+2,1).LE.0) THEN
                  J3=J4+3
                  GOTO 413
                ENDIF
                J3=0
                IF (G1A.NE.G1B) THEN
                  IF ((G1A.LE.GBR(J4,1).AND.
     *                 G1A.GE.GBR(J4+3,1)).OR.
     *                (G1A.GE.GBR(J4,1).AND.
     *                 G1A.LE.GBR(J4+3,1))) J3=J4+3
                  DO 412, I4=J4+3,J4+1+KBR(J4+2,1)
                    IF ((G1A.GE.GBR(I4,1).AND.G1A.LE.GBR(I4+1,1)).OR.
     *              (G1A.LE.GBR(I4,1).AND.G1A.GE.GBR(I4+1,1))) J3=I4+1
  412             CONTINUE
                  I4=J4+2+KBR(J4+2,1)
                  IF ((G1A.LE.GBR(I4,1).AND.
     *                 G1A.GE.GBR(J4+1,1)).OR.
     *                (G1A.GE.GBR(I4,1).AND.
     *                 G1A.LE.GBR(J4+1,1))) J3=I4+1
                ELSE
                  IF ((G2A.LE.GBR(J4,2).AND.
     *                 G2A.GE.GBR(J4+3,2)).OR.
     *                (G2A.GE.GBR(J4,2).AND.
     *                 G2A.LE.GBR(J4+3,2))) J3=J4+3
                  DO 414, I4=J4+3,J4+1+KBR(J4+2,1)
                    IF ((G2A.GE.GBR(I4,2).AND.G2A.LE.GBR(I4+1,2)).OR.
     *              (G2A.LE.GBR(I4,2).AND.G2A.GE.GBR(I4+1,2))) J3=I4+1
  414             CONTINUE
                  I4=J4+2+KBR(J4+2,1)
                  IF ((G2A.LE.GBR(I4,2).AND.
     *                 G2A.GE.GBR(J4+1,2)).OR.
     *                (G2A.GE.GBR(I4,2).AND.
     *                 G2A.LE.GBR(J4+1,2))) J3=I4+1
                ENDIF
  413           IF (J3.NE.0) THEN
C                 Now J3 points to the position in KBR,
C                 where ray A is to be added:
                  IF (NBR+1.GT.MBR) CALL RPERR(8)
                  IF (NBR.GE.J3) NBR=NBR+1
                  DO 415, I4=NBR,J3+1,-1
                    KBR(I4,1)=KBR(I4-1,1)
                    KBR(I4,2)=KBR(I4-1,2)
                    KBR(I4,3)=KBR(I4-1,3)
                    GBR(I4,1)=GBR(I4-1,1)
                    GBR(I4,2)=GBR(I4-1,2)
  415             CONTINUE
                  NBR=MAX0(NBR,J3)
                  KBR(J3,1)=KRAYA
                  KBR(J3,2)=ISHA
                  KBR(J3,3)=ITYPEA
                  GBR(J3,1)=G1A
                  GBR(J3,2)=G2A
                  KBR(J4+2,1)=KBR(J4+2,1)+1
                ENDIF
C
                J3=0
                IF (G1A.NE.G1B) THEN
                  IF ((G1B.LE.GBR(J4,1).AND.
     *                 G1B.GE.GBR(J4+3,1)).OR.
     *                (G1B.GE.GBR(J4,1).AND.
     *                 G1B.LE.GBR(J4+3,1))) J3=J4+3
                  DO 417, I4=J4+3,J4+1+KBR(J4+2,1)
                    IF ((G1B.GE.GBR(I4,1).AND.G1B.LE.GBR(I4+1,1)).OR.
     *              (G1B.LE.GBR(I4,1).AND.G1B.GE.GBR(I4+1,1))) J3=I4+1
  417             CONTINUE
                  I4=J4+2+KBR(J4+2,1)
                  IF ((G1B.LE.GBR(I4,1).AND.
     *                 G1B.GE.GBR(J4+1,1)).OR.
     *                (G1B.GE.GBR(I4,1).AND.
     *                 G1B.LE.GBR(J4+1,1))) J3=I4+1
                ELSE
                  IF ((G2B.LE.GBR(J4,2).AND.
     *                 G2B.GE.GBR(J4+3,2)).OR.
     *                (G2B.GE.GBR(J4,2).AND.
     *                 G2B.LE.GBR(J4+3,2))) J3=J4+3
                  DO 418, I4=J4+3,J4+1+KBR(J4+2,1)
                    IF ((G2B.GE.GBR(I4,2).AND.G2B.LE.GBR(I4+1,2)).OR.
     *              (G2B.LE.GBR(I4,2).AND.G2B.GE.GBR(I4+1,2))) J3=I4+1
  418             CONTINUE
                  I4=J4+2+KBR(J4+2,1)
                  IF ((G2B.LE.GBR(I4,2).AND.
     *                 G2B.GE.GBR(J4+1,2)).OR.
     *                (G2B.GE.GBR(I4,2).AND.
     *                 G2B.LE.GBR(J4+1,2))) J3=I4+1
                ENDIF
                IF (J3.NE.0) THEN
C                 Now J3 points to the position in KBR,
C                 where ray B is to be added:
                  IF (NBR+1.GT.MBR) CALL RPERR(8)
                  IF (NBR.GE.J3) NBR=NBR+1
                  DO 410, I4=NBR,J3+1,-1
                    KBR(I4,1)=KBR(I4-1,1)
                    KBR(I4,2)=KBR(I4-1,2)
                    KBR(I4,3)=KBR(I4-1,3)
                    GBR(I4,1)=GBR(I4-1,1)
                    GBR(I4,2)=GBR(I4-1,2)
  410             CONTINUE
                  NBR=MAX0(NBR,J3)
                  KBR(J3,1)=KRAYB
                  KBR(J3,2)=ISHB
                  KBR(J3,3)=ITYPEB
                  GBR(J3,1)=G1B
                  GBR(J3,2)=G2B
                  KBR(J4+2,1)=KBR(J4+2,1)+1
                ENDIF
                GOTO 42
              ENDIF
              J4=J4+3+KBR(J4+2,1)
            IF (J4.LT.NBR) GOTO 41
            ENDIF
C           The previous triangles possibly
C           have not been formed correctly:
            CALL RPTRIP(-KTRID(4)+1,LTRI,KTRIS)
C           Loop for all the triangles in the memory:
  423       CONTINUE
              CALL RPTRIP(0,LTRI,KTRIS)
              IF (LTRI) THEN
                IF (KTRIS(5).NE.0) GOTO 423
                IF (KTRIS(4).EQ.KTRID(4)) GOTO 423
                IF (KTRIS(4).EQ.KTRID(5)) GOTO 423
                DO 422, I2=1,3
C                 There are indices of the divided side
C                 stored in KRAYC and KRAYD:
                  IF (KRAYC.EQ.KTRIS(I2)) THEN
                    DO 421, I3=1,3
                      IF (KRAYD.EQ.KTRIS(I3)) THEN
C                       Now one must divide either the basic triangle
C                       with index I4, or some of the triangles created
C                       by the division of this triangle:
                        IF (KTRIS(6).NE.2) THEN
                          KTRIS(6)=2
                          CALL RPTRI2(KTRIS(4),LTRI,KTRIS)
                          IF (.NOT.LTRI) CALL RPERR(2)
C                         KRAYD0 is the index of the ray which has
C                         indicated that this triangle is to be divided:
                          ITRI=ITRI+1
                          KTRIN(1)=KTRIS(1)
                          KTRIN(2)=KTRIS(2)
                          KTRIN(3)=KTRIS(3)
                          KTRIN(I2)=KRAYD0
                          KTRIN(4)=ITRI
                          IF (KTRIS(5).EQ.0) THEN
                            KTRIN(5)=KTRIS(4)
                          ELSE
                            KTRIN(5)=KTRIS(5)
                          ENDIF
                          KTRIN(6)=0
                          CALL RPTRI1(ITRI,KTRIN)
                          CALL RPSTOR('T',1,KTRIN)
                          ITRI=ITRI+1
                          KTRIN(1)=KTRIS(1)
                          KTRIN(2)=KTRIS(2)
                          KTRIN(3)=KTRIS(3)
                          KTRIN(I3)=KRAYD0
                          KTRIN(4)=ITRI
                          CALL RPTRI1(ITRI,KTRIN)
                          CALL RPSTOR('T',1,KTRIN)
                          LAB20=.TRUE.
                          GOTO 42
                        ENDIF
                        CALL RPRAY(KRAYD0,LRAY,ITYPE,ISH,G1J,G2J,
     *                            G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
                        IF (.NOT.LRAY) CALL RPERR(1)
                        CALL RPTRIP(-KTRID(4)+1,LTRI,KTRIS)
C                       Loop for all the triangles in the memory:
  431                   CONTINUE
                          CALL RPTRIP(0,LTRI,KTRIT)
                          IF (LTRI) THEN
      IF (KTRIT(5).NE.KTRIS(4)) GOTO 431
      CALL RPRAY(KTRIT(1),LRAY,ITYPE,ISH,G1C,G2C,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KTRIT(2),LRAY,ITYPE,ISH,G1D,G2D,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KTRIT(3),LRAY,ITYPE,ISH,G1E,G2E,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      IF (RPLRIL(G1J,G2J,G1C,G2C,G1E,G2E)) THEN
C       Boundary rays are lying on the side CE (side 3,1):
        I4=1
        I5=3
      ELSEIF (RPLRIL(G1J,G2J,G1C,G2C,G1D,G2D)) THEN
C       Boundary rays are lying on the side CD (side 1,2):
        I4=1
        I5=2
      ELSEIF (RPLRIL(G1J,G2J,G1D,G2D,G1E,G2E)) THEN
C       Boundary rays are lying on the side DE (side 2,3):
        I4=2
        I5=3
      ELSE
C       Rays are not on the sides of this triangle:
        GOTO 431
      ENDIF
      ITRI=ITRI+1
      KTRIN(1)=KTRIT(1)
      KTRIN(2)=KTRIT(2)
      KTRIN(3)=KTRIT(3)
      KTRIN(I4)=KRAYD0
      KTRIN(4)=ITRI
      KTRIN(5)=KTRIT(5)
      KTRIN(6)=0
      CALL RPTRI1(ITRI,KTRIN)
      CALL RPSTOR('T',1,KTRIN)
      ITRI=ITRI+1
      KTRIN(1)=KTRIT(1)
      KTRIN(2)=KTRIT(2)
      KTRIN(3)=KTRIT(3)
      KTRIN(I5)=KRAYD0
      KTRIN(4)=ITRI
      CALL RPTRI1(ITRI,KTRIN)
      CALL RPSTOR('T',1,KTRIN)
      LAB20=.TRUE.
      GOTO 431
                          ENDIF
C                       End of the loop for all the triangles
C                       in the memory.
                      ENDIF
  421               CONTINUE
                  ENDIF
  422           CONTINUE
                GOTO 423
              ENDIF
C           End of the loop for all the triangles in the memory.
C
C           The side KRAYC-KRAYD is not in KBR, but there is no other
C           triangle with this side. Rays will be stored to KBR:
            IF (NBR.GE.MBR) CALL RPERR(8)
            CALL RPRAY(KRAYC,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *                 X1,X2,G1X1,G2X1,G1X2,G2X2)
            IF (.NOT.LRAY) CALL RPERR(1)
            NBR=NBR+1
            KBR(NBR,1)=KRAYC
            KBR(NBR,2)=0
            KBR(NBR,3)=0
            GBR(NBR,1)=G1
            GBR(NBR,2)=G2
            IF (NBR.GE.MBR) CALL RPERR(8)
            CALL RPRAY(KRAYD,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *                 X1,X2,G1X1,G2X1,G1X2,G2X2)
            IF (.NOT.LRAY) CALL RPERR(1)
            NBR=NBR+1
            KBR(NBR,1)=KRAYD
            KBR(NBR,2)=0
            KBR(NBR,3)=0
            GBR(NBR,1)=G1
            GBR(NBR,2)=G2
            IF (NBR.GE.MBR) CALL RPERR(8)
            NBR=NBR+1
            KBR(NBR,1)=0
            KBR(NBR,2)=0
            KBR(NBR,3)=0
            GBR(NBR,1)=0
            GBR(NBR,2)=0
            J1=NBR
C           The side C,D were turned.
C           Now the sequence of the rays is as follows: C,B,A,D
            IF (KRAYB.NE.KRAYC) THEN
              IF (NBR.GE.MBR) CALL RPERR(8)
              NBR=NBR+1
              KBR(NBR,1)=KRAYB
              KBR(NBR,2)=ISHB
              KBR(NBR,3)=ITYPEB
              GBR(NBR,1)=G1B
              GBR(NBR,2)=G2B
              KBR(J1,1)=KBR(J1,1)+1
            ENDIF
            IF (KRAYA.NE.KRAYD) THEN
              IF (NBR.GE.MBR) CALL RPERR(8)
              NBR=NBR+1
              KBR(NBR,1)=KRAYA
              KBR(NBR,2)=ISHA
              KBR(NBR,3)=ITYPEA
              GBR(NBR,1)=G1A
              GBR(NBR,2)=G2A
              KBR(J1,1)=KBR(J1,1)+1
            ENDIF
          ENDIF
C         End IF (LSTORE)
C         Correcting polygon:
  42      CONTINUE
          IF (KRAYA.NE.KPOL(I1-1,1)) THEN
            IF (NPOL.GE.MPOL) CALL RPERR(5)
            DO 44, I2=NPOL,I1,-1
              KPOL(I2+1,1)=KPOL(I2,1)
              KPOL(I2+1,2)=KPOL(I2,2)
              KPOL(I2+1,3)=KPOL(I2,3)
              KPOL(I2+1,4)=KPOL(I2,4)
              GPOL(I2+1,1)=GPOL(I2,1)
              GPOL(I2+1,2)=GPOL(I2,2)
  44        CONTINUE
            KPOL(I1,1)=KRAYA
            KPOL(I1,2)=ISHA
            KPOL(I1,3)=ITYPEA
            KPOL(I1,4)=ISHB
            GPOL(I1,1)=G1A
            GPOL(I1,2)=G2A
            NPOL=NPOL+1
            I1=I1+1
          ELSE
            KPOL(I1-1,3)=ITYPEA
          ENDIF
          IF (KRAYB.NE.KPOL(I1,1)) THEN
            IF (NPOL.GE.MPOL) CALL RPERR(5)
            DO 46, I2=NPOL,I1,-1
              KPOL(I2+1,1)=KPOL(I2,1)
              KPOL(I2+1,2)=KPOL(I2,2)
              KPOL(I2+1,3)=KPOL(I2,3)
              KPOL(I2+1,4)=KPOL(I2,4)
              GPOL(I2+1,1)=GPOL(I2,1)
              GPOL(I2+1,2)=GPOL(I2,2)
  46        CONTINUE
            KPOL(I1,1)=KRAYB
            KPOL(I1,2)=ISHB
            KPOL(I1,3)=ITYPEB
            KPOL(I1,4)=ISHA
            GPOL(I1,1)=G1B
            GPOL(I1,2)=G2B
            NPOL=NPOL+1
            I1=I1+1
          ELSE
            KPOL(I1,3)=ITYPEB
          ENDIF
C         Storing ray B to KLINE:
          IF (NLINE.GE.MLINE) CALL RPERR(7)
          NLINE=NLINE+1
          KLINE(NLINE,1)=KRAYB
          KLINE(NLINE,2)=ISHB
          KLINE(NLINE,3)=ITYPEB
          KLINE(NLINE,4)=ISHA
C         Searching for new rays A and B in KLINE:
          DO 48, I2=NLINE,2,-1
            IF (KLINE(I2,2).NE.KLINE(I2-1,2)) THEN
              KRAYA=KLINE(I2,1)
              KRAYB=KLINE(I2-1,1)
              NLINE=I2-2
              CALL RPRAY(KRAYA,LRAY,ITYPEA,ISHA,G1A,G2A,
     *                   G11A,G12A,G22A,X1,X2,G1X1A,G2X1A,G1X2A,G2X2A)
              IF (.NOT.LRAY) CALL RPERR(1)
              CALL RPRAY(KRAYB,LRAY,ITYPEB,ISHB,G1B,G2B,
     *                   G11B,G12B,G22B,X1,X2,G1X1B,G2X1B,G1X2B,G2X2B)
              IF (.NOT.LRAY) CALL RPERR(1)
              GOTO 40
            ENDIF
  48      CONTINUE
C         No other rays in KLINE:
          NLINE=0
          IF (KTRID(5).NE.0) THEN
            CALL RPTRI3(KTRID(5),LTRI,KTRIS)
            IF (.NOT.LTRI) GOTO 50
          ELSE
            KTRIS(1)=KTRID(1)
            KTRIS(2)=KTRID(2)
            KTRIS(3)=KTRID(3)
          ENDIF
          IF (((KRAYA0.EQ.KTRIS(1)).AND.(KRAYB0.EQ.KTRIS(2))).OR.
     *        ((KRAYA0.EQ.KTRIS(2)).AND.(KRAYB0.EQ.KTRIS(3))).OR.
     *        ((KRAYA0.EQ.KTRIS(3)).AND.(KRAYB0.EQ.KTRIS(1)))) THEN
C           Saving found boundary rays:
            IF (NBR.GE.MBR) CALL RPERR(8)
            NBR=NBR+1
            CALL RPRAY(KRAYB0,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *                 X1,X2,G1X1,G2X1,G1X2,G2X2)
            IF (.NOT.LRAY) CALL RPERR(1)
            KBR(NBR,1)=KRAYB0
            KBR(NBR,2)=0
            KBR(NBR,3)=0
            GBR(NBR,1)=G1
            GBR(NBR,2)=G2
            IF (NBR.GE.MBR) CALL RPERR(8)
            NBR=NBR+1
            CALL RPRAY(KRAYA0,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *                 X1,X2,G1X1,G2X1,G1X2,G2X2)
            IF (.NOT.LRAY) CALL RPERR(1)
            KBR(NBR,1)=KRAYA0
            KBR(NBR,2)=0
            KBR(NBR,3)=0
            GBR(NBR,1)=G1
            GBR(NBR,2)=G2
            IF (NBR.GE.MBR) CALL RPERR(8)
            NBR=NBR+1
            KBR(NBR,1)=0
            KBR(NBR,2)=0
            KBR(NBR,3)=0
            GBR(NBR,1)=0
            GBR(NBR,2)=0
            J1=NBR
            I2=I1-1
  49        IF (KPOL(I2,1).NE.KRAYA0) THEN
              IF (NBR.GE.MBR) CALL RPERR(8)
              NBR=NBR+1
              KBR(NBR,1)=KPOL(I2,1)
              KBR(NBR,2)=KPOL(I2,2)
              KBR(NBR,3)=KPOL(I2,3)
              GBR(NBR,1)=GPOL(I2,1)
              GBR(NBR,2)=GPOL(I2,2)
              KBR(J1,1)=KBR(J1,1)+1
              I2=I2-1
              GOTO 49
            ENDIF
          ENDIF
        ENDIF
  50  CONTINUE
      I1=I1+1
      IF (I1.LE.NPOL) GOTO 20
C
C     Shifting the polygon in such a way, that the first and the last
C     rays of the polygon are boundary rays:
      IF (KPOL(1,2).EQ.KPOL(NPOL,2)) THEN
C       Inhomogeneous polygon will be shifted now:
        I2=0
  55    CONTINUE
        I2=I2+1
        IF (NPOL.GE.MPOL) CALL RPERR(5)
        DO 52, I1=NPOL+1,2,-1
          KPOL(I1,1)=KPOL(I1-1,1)
          KPOL(I1,2)=KPOL(I1-1,2)
          KPOL(I1,3)=KPOL(I1-1,3)
          KPOL(I1,4)=KPOL(I1-1,4)
          GPOL(I1,1)=GPOL(I1-1,1)
          GPOL(I1,2)=GPOL(I1-1,2)
  52    CONTINUE
        KPOL(1,1)=KPOL(NPOL+1,1)
        KPOL(1,2)=KPOL(NPOL+1,2)
        KPOL(1,3)=KPOL(NPOL+1,3)
        KPOL(1,4)=KPOL(NPOL+1,4)
        GPOL(1,1)=GPOL(NPOL+1,1)
        GPOL(1,2)=GPOL(NPOL+1,2)
        IF ((KPOL(1,2).EQ.KPOL(NPOL,2)).AND.(I2.LT.NPOL)) GOTO 55
      ELSE
        IF ((KPOL(1,3).EQ.KPOL(NPOL,1)).OR.
     *      (KPOL(1,1).EQ.KPOL(NPOL,3))) THEN
C         Boundary rays, no action.
        ELSE
C         Inhomogeneous polygon will be shifted and then checked.
          IF (NPOL.GE.MPOL) CALL RPERR(5)
          KPOL(NPOL+1,1)=KPOL(1,1)
          KPOL(NPOL+1,2)=KPOL(1,2)
          KPOL(NPOL+1,3)=KPOL(1,3)
          KPOL(NPOL+1,4)=KPOL(1,4)
          GPOL(NPOL+1,1)=GPOL(1,1)
          GPOL(NPOL+1,2)=GPOL(1,2)
          DO 58, I1=1,NPOL
            KPOL(I1,1)=KPOL(I1+1,1)
            KPOL(I1,2)=KPOL(I1+1,2)
            KPOL(I1,3)=KPOL(I1+1,3)
            KPOL(I1,4)=KPOL(I1+1,4)
            GPOL(I1,1)=GPOL(I1+1,1)
            GPOL(I1,2)=GPOL(I1+1,2)
  58      CONTINUE
          GOTO 15
        ENDIF
      ENDIF
C
C
C     The inhomogeneous polygon is created.
C     Homogeneous polygons will be found and separated from it now.
C     Firstly preferring basic homogeneous polygons with rays of such
C     ISH, that other rays have not:
  60  CONTINUE
      I4=ISTART
      LSTORE=.FALSE.
      DO 64, I1=1,NPOL
        IF (KPOL(I1,1).GE.1) THEN
          J1=I1
          ISHP=KPOL(I1,2)
          GOTO 65
        ENDIF
  64  CONTINUE
  65  CONTINUE
      DO 66, I1=J1+1,NPOL
        IF (KPOL(I1,2).NE.ISHP) THEN
          J2=I1-1
          GOTO 67
        ENDIF
  66  CONTINUE
      J2=NPOL
  67  CONTINUE
      DO 70, I1=J2+1,NPOL
        IF (KPOL(I1,2).EQ.ISHP) THEN
          GOTO 701
        ENDIF
  70  CONTINUE
C     Rays J1 and J2 should not be marked as boundary rays:
      IF ((KPOL(J1,1).EQ.KPOL(J2,3)).OR.(KPOL(J1,3).EQ.KPOL(J2,1)))
     *  GOTO 701
C     Neighbouring rays ought to have the same ISH:
      IF (J1.EQ.1) THEN
        J3=NPOL
      ELSE
        J3=J1-1
      ENDIF
      IF (J2.EQ.NPOL) THEN
        J4=1
      ELSE
        J4=J2+1
      ENDIF
      IF (KPOL(J3,2).NE.KPOL(J4,2)) THEN
        GOTO 701
      ENDIF
      IF (I4.GT.0) THEN
C       In case ISTART .gt. 0 starting from other rays.
        I4=I4-1
        GOTO 701
      ENDIF
      GOTO 100
  701 CONTINUE
C
C     These rays are not very suitable to create
C     the homogeneous polygon:
      DO 69, I2=NPOL,1,-1
        IF ((KPOL(I2,1).GE.1).AND.(KPOL(I2,2).NE.ISHP)) THEN
C         Start from other rays:
          DO 68, I3=1,NPOL
            IF (KPOL(I3,2).EQ.ISHP) KPOL(I3,1)=-IABS(KPOL(I3,1))
  68      CONTINUE
          GOTO 60
        ENDIF
  69  CONTINUE
C     No other rays with such ISH, that other rays have not.
C     Now preferring basic homogeneous polygons with the higher
C     number of rays:
      DO 72, I2=1,NPOL
        KPOL(I2,1)=IABS(KPOL(I2,1))
  72  CONTINUE
  73  CONTINUE
      MAXR=0
      J2=0
  81  CONTINUE
      DO 82, I1=J2+1,NPOL
        IF (KPOL(I1,1).GE.1) THEN
          J1=I1
          GOTO 83
        ENDIF
  82  CONTINUE
C     All the groups were counted:
      GOTO 86
  83  CONTINUE
      DO 84, I1=J1+1,NPOL
        IF (KPOL(I1,2).NE.KPOL(J1,2)) THEN
          J2=I1-1
          GOTO 85
        ENDIF
  84  CONTINUE
      J2=NPOL
  85  CONTINUE
      I3=J2-J1+1
C     Rays J1 and J2 should not be marked as boundary rays:
      IF ((KPOL(J1,1).EQ.KPOL(J2,3)).OR.(KPOL(J1,3).EQ.KPOL(J2,1)))
     *  GOTO 81
      IF (I3.GT.MAXR) MAXR=I3
      GOTO 81
C
C     All the groups were counted:
  86  CONTINUE
      IF (MAXR.EQ.0) THEN
C       The best group is not chosen, trying groups consequently:
        J5=J5+1
        J2=0
        I4=J5
  900   CONTINUE
        I4=I4-1
        IF (J2.GE.NPOL) THEN
C         The inhomogeneous polygon will be simply divided into
C         homogeneous triangles:
          I1=1
  901     CONTINUE
            IF(I1.GT.1) THEN
              J1=I1-1
            ELSE
              J1=NPOL
            ENDIF
            IF(I1.LT.NPOL) THEN
              J2=I1+1
            ELSE
              J2=1
            ENDIF
            IF ((KPOL(J1,2).EQ.KPOL(I1,2)).AND.
     *          (KPOL(J2,2).EQ.KPOL(I1,2))) THEN
              IF (RPLRIT(.FALSE.,GPOL(J1,1),GPOL(J1,2),GPOL(I1,1),
     *            GPOL(I1,2),GPOL(J2,1),GPOL(J2,2),G1A,G2A,AREA)) THEN
                ITRI=ITRI+1
                KTRIN(1)=IABS(KPOL(J1,1))
                KTRIN(2)=IABS(KPOL(I1,1))
                KTRIN(3)=IABS(KPOL(J2,1))
                KTRIN(4)=ITRI
                IF (KTRID(5).EQ.0) THEN
                  KTRIN(5)=KTRID(4)
                ELSE
                  KTRIN(5)=KTRID(5)
                ENDIF
                KTRIN(6)=3
                CALL RPTRI1(ITRI,KTRIN)
                CALL RPSTOR('T',1,KTRIN)
                NPOL=NPOL-1
                DO 902, I2=I1,NPOL
                  KPOL(I1,1)=KPOL(I1+1,1)
                  KPOL(I1,2)=KPOL(I1+1,2)
                  KPOL(I1,3)=KPOL(I1+1,3)
                  KPOL(I1,4)=KPOL(I1+1,4)
                  GPOL(I1,1)=GPOL(I1+1,1)
                  GPOL(I1,2)=GPOL(I1+1,2)
  902           CONTINUE
                I1=1
                GOTO 901
              ENDIF
            ENDIF
          I1=I1+1
          IF (I1.LE.NPOL) GOTO 901
          KTRID(6)=2
          CALL RPTRI2(KTRID(4),LTRI,KTRID)
          IF (.NOT.LTRI) CALL RPERR(2)
          LNEWAR=.FALSE.
          RETURN
        ENDIF
        J1=J2+1
        ISHP=KPOL(J1,2)
        DO 903, I1=J1+1,NPOL
          IF (KPOL(I1,2).NE.ISHP) THEN
            J2=I1-1
            GOTO 904
          ENDIF
  903   CONTINUE
        J2=NPOL
  904   CONTINUE
        IF (I4.GT.0) GOTO 900
        GOTO 100
      ENDIF
C     MAXR .gt. 0, the first group with this number of rays will become
C     to be the basic homogeneous polygon:
      J2=0
  91  CONTINUE
      DO 92, I1=J2+1,NPOL
        IF (KPOL(I1,1).GE.1) THEN
          J1=I1
          GOTO 93
        ENDIF
  92  CONTINUE
  93  CONTINUE
      DO 94, I1=J1+1,NPOL
        IF (KPOL(I1,2).NE.KPOL(J1,2)) THEN
          J2=I1-1
          GOTO 95
        ENDIF
  94  CONTINUE
      J2=NPOL
  95  CONTINUE
      I3=J2-J1+1
      IF (I3.NE.MAXR) GOTO 91
      ISHP=KPOL(J1,2)
      IF (I4.GT.0) THEN
C       In case ISTART .gt. 0 starting from other rays.
        I4=I4-1
        DO 96, I1=J1,J2
          KPOL(I1,1)=-IABS(KPOL(I1,1))
  96    CONTINUE
        GOTO 73
      ENDIF
C
C     The group with ISH=ISHP of rays in KPOL from J1 to J2 becomes
C     to be the basic homogeneous polygon:
  100 CONTINUE
      DO 101, I1=1,NPOL
        KPOL(I1,1)=IABS(KPOL(I1,1))
  101 CONTINUE
      NPOLH=J2-J1+1
      IF (NPOLH.GT.MPOLH) CALL RPERR(6)
      DO 102, I1=J1,J2
        KPOLH(I1-J1+1,1)=KPOL(I1,1)
        KPOLH(I1-J1+1,2)=KPOL(I1,2)
        KPOLH(I1-J1+1,3)=KPOL(I1,3)
        KPOLH(I1-J1+1,4)=KPOL(I1,4)
        GPOLH(I1-J1+1,1)=GPOL(I1,1)
        GPOLH(I1-J1+1,2)=GPOL(I1,2)
  102 CONTINUE
C
C
C     The basic homogeneous polygon is formed,
C     now demarcating the boundary:
C
      IF (NPOLH.EQ.1) THEN
C       In this situation a very small part of the domain
C       will escape notice.
        NPOLH=0
        DO 104, I1=1,NPOL
          IF (KPOL(I1,1).EQ.KPOLH(1,1)) THEN
            IF ((I1.GT.1).AND.(I1.LT.NPOL)) THEN
              KPOL(I1-1,3)=KPOL(I1+1,1)
            ELSEIF (I1.EQ.1) THEN
              KPOL(NPOL,3)=KPOL(2,1)
            ELSE
              KPOL(NPOL-1,3)=KPOL(1,1)
            ENDIF
            NPOL=NPOL-1
            DO 103, I2=I1,NPOL
              KPOL(I2,1)=KPOL(I2+1,1)
              KPOL(I2,2)=KPOL(I2+1,2)
              KPOL(I2,3)=KPOL(I2+1,3)
              KPOL(I2,4)=KPOL(I2+1,4)
              GPOL(I2,1)=GPOL(I2+1,1)
              GPOL(I2,2)=GPOL(I2+1,2)
  103       CONTINUE
            GOTO 105
          ENDIF
  104   CONTINUE
  105   CONTINUE
        IF (NPOL.GE.2) THEN
          GOTO 15
        ELSE
          KTRID(6)=2
          CALL RPTRI2(KTRID(4),LTRI,KTRID)
          IF (.NOT.LTRI) CALL RPERR(2)
          LNEWAR=.FALSE.
          RETURN
        ENDIF
      ENDIF
C
      IF (NPOLH.EQ.NPOL) THEN
C       Whole polygon is homogeneous, it is prepared to be divided
C       into triangles now. (New boundary need not be traced).
        NPOL=0
        GOTO 155
      ENDIF
C
C     NPOLH is greater or equal 2:
C
      KLINE(1,1)=KPOLH(1,1)
      KLINE(1,2)=KPOLH(1,2)
      KLINE(1,3)=KPOLH(1,3)
      KLINE(1,4)=KPOLH(1,4)
      KLINE(2,1)=KPOLH(NPOLH,1)
      KLINE(2,2)=KPOLH(NPOLH,2)
      KLINE(2,3)=KPOLH(NPOLH,3)
      KLINE(2,4)=KPOLH(NPOLH,4)
      NLINE=2
      J3=1
      J30=1
C
C     Entry point when boundary rays were found and
C     added to KLINE:
  107 CONTINUE
      IF (J3.GE.J30) THEN
        DO 108, I1=J3,NLINE-1
          IF ((KLINE(I1,4).NE.0).AND.(KLINE(I1+1,4).NE.0)) THEN
            IF (KLINE(I1,4).NE.KLINE(I1+1,4)) THEN
              IF (J30.EQ.0) J30=J3
              J3=I1
              GOTO 111
            ENDIF
          ENDIF
  108   CONTINUE
        J3=J30
        J30=999999
      ENDIF
  111 KRAYA=IABS(KLINE(J3,1))
      KRAYB=IABS(KLINE(J3+1,1))
      CALL RPRAY(KRAYA,LRAY,ITYPEA,ISHA,G1A,G2A,
     *          G11A,G12A,G22A,X1,X2,G1X1A,G2X1A,G1X2A,G2X2A)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KRAYB,LRAY,ITYPEB,ISHB,G1B,G2B,
     *          G11B,G12B,G22B,X1,X2,G1X1B,G2X1B,G1X2B,G2X2B)
      IF (.NOT.LRAY) CALL RPERR(1)
      G11POM=(G11A+G11B)/2.
      G12POM=(G12A+G12B)/2.
      G22POM=(G22A+G22B)/2.
      DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
      IF (DIST2.LT.AERR2) THEN
C       Rays are too close, boundary is not to be demarcated:
        J3=J3+1
        IF (J3.NE.NLINE) THEN
          GOTO 107
        ELSE
          IF (J30.NE.999999) THEN
            J3=J30
            J30=999999
            GOTO 107
          ENDIF
          GOTO 143
        ENDIF
      ENDIF
      G1NEW=(G1A+G1B)/2.
      G2NEW=(G2A+G2B)/2.
      IF (((G1NEW.EQ.G1A).AND.(G2NEW.EQ.G2A)).OR.
     *    ((G1NEW.EQ.G1B).AND.(G2NEW.EQ.G2B))) CALL RPERR(3)
      IF (.NOT.RPLRIP(NPOL,GPOL,G1NEW,G2NEW)) THEN
C       Ray C will be replaced by intersection point of
C       the abscissa perpendicular to abscissa AB with
C       the abscissae of the polygon. The point nearest to the point C
C       is preferred:
C       Looking for the intersection point of abscissa DE
C       with the abscissae of the polygon:
C       ..J,..K ... The rays of tested polygon abscissa.
C       ..D,..E ... The rays of intersecting abscissa.
C       ..X ... The intersection point.
        G1C=G1NEW
        G2C=G2NEW
C
C       Computing the parameters of points D and E:
        AAA=(G11POM*(G1A-G1B)+G12POM*(G2A-G2B))
        BBB=(G12POM*(G1A-G1B)+G22POM*(G2A-G2B))
        DETG=G11POM*G22POM - G12POM*G12POM
        IF (DETG.LT.ZERO) CALL RPERR(4)
        DIST2=(G1A-G1B)*AAA + (G2A-G2B)*BBB
        G1D=(G1A+G1B)/2. + SIDE/SQRT(DIST2)*SQRT(3./DETG)*BBB
        G2D=(G2A+G2B)/2. - SIDE/SQRT(DIST2)*SQRT(3./DETG)*AAA
        G1E=(G1A+G1B)/2. - SIDE/SQRT(DIST2)*SQRT(3./DETG)*BBB
        G2E=(G2A+G2B)/2. + SIDE/SQRT(DIST2)*SQRT(3./DETG)*AAA
C
C       Searching for intersection point nearest to the point C:
        MINDIS=999999.
        G1J=GPOL(NPOL,1)
        G2J=GPOL(NPOL,2)
        G1K=GPOL(1,1)
        G2K=GPOL(1,2)
        I1=0
  109   CONTINUE
          CALL RPCROS(G1D,G2D,G1E,G2E,G1J,G2J,G1K,G2K,LINTS,G1X,G2X)
          IF (LINTS) THEN
            DIST2=RPDI2G(G1X,G2X,G1C,G2C,G11POM,G12POM,G22POM)
            IF (DIST2.LT.MINDIS) THEN
              MINDIS=DIST2
              G1NEW=G1X
              G2NEW=G2X
            ENDIF
          ENDIF
          I1=I1+1
          IF ((KPOL(I1,1).EQ.IABS(KLINE(J3,1))).AND.
     *        (KPOL(I1+1,1).EQ.IABS(KLINE(J3+1,1)))) I1=I1+1
          IF (I1.LT.NPOL) THEN
            G1J=GPOL(I1,1)
            G2J=GPOL(I1,2)
            G1K=GPOL(I1+1,1)
            G2K=GPOL(I1+1,2)
            GOTO 109
          ENDIF
C       End of the loop.
        IF (MINDIS.EQ.999999.) THEN
C         RP3D-009
          CALL ERROR('RP3D-009: Intersection not found in RPDIV.')
C         This error should not appear.
C         Please contact the author or try to
C         change the input data.
        ENDIF
      ENDIF
C     Trace a new ray, then go to 110:
      KRAYC=IRAY+1
      IGOTO=2
      LNEWAR=.TRUE.
      RETURN
C
C
C     Ray C=(A+B)/2. was actually traced.
  110 CONTINUE
      CALL RPRAY(KRAYC,LRAY,ITYPEC,ISHC,G1C,G2C,G11C,G12C,G22C,X1,X2,
     *           G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      IF (ISHC.NE.ISHA) THEN
        I1=NPOL
        I2=1
  112   CONTINUE
          IF (RPLRIL(G1C,G2C,GPOL(I1,1),GPOL(I1,2),
     *               GPOL(I2,1),GPOL(I2,2))) THEN
            IF ((KPOL(I1,2).NE.ISHC).AND.(KPOL(I2,2).NE.ISHC)) THEN
C             Ray C is between the rays of different history:
              IF ((KPOL(I1,3).NE.KPOL(I2,1)).AND.
     *            (KPOL(I1,1).NE.KPOL(I2,3))) THEN
C               New ray is not between the rays signed as boundary rays.
                CALL RPRAY(KPOL(I1,1),LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *                     X1,X2,G1X1,G2X1,G1X2,G2X2)
                IF (.NOT.LRAY) CALL RPERR(1)
                CALL RPRAY(KPOL(I2,1),LRAY,ITYPEX,ISHX,G1X,G2X,G11X,G12X
     *                    ,G22X,X1,X2,G1X1,G2X1,G1X2,G2X2)
                IF (.NOT.LRAY) CALL RPERR(1)
                G11POM=(G11X+G11)/2.
                G12POM=(G12X+G12)/2.
                G22POM=(G22X+G22)/2.
                DIST2=RPDI2G(GPOL(I1,1),GPOL(I1,2),GPOL(I2,1),GPOL(I2,2)
     *                      ,G11POM,G12POM,G22POM)
                IF (DIST2.GT.AERR2) THEN
C                 New ray is between the rays which are not
C                 as near as boundary rays.
C                 Ray C is to be added to the polygon:
                  IF (NPOL.GE.MPOL) CALL RPERR(5)
                  NPOL=NPOL+1
                  DO 114, I3=NPOL,I2+1,-1
                    KPOL(I3,1)=KPOL(I3-1,1)
                    KPOL(I3,2)=KPOL(I3-1,2)
                    KPOL(I3,3)=KPOL(I3-1,3)
                    KPOL(I3,4)=KPOL(I3-1,4)
                    GPOL(I3,1)=GPOL(I3-1,1)
                    GPOL(I3,2)=GPOL(I3-1,2)
  114             CONTINUE
                  KPOL(I2,1)=KRAYC
                  KPOL(I2,2)=ISHC
                  KPOL(I2,3)=ITYPEC
                  KPOL(I2,4)=0
                  IF (ITYPEC.GT.0) THEN
                    CALL RPRAY(ITYPEC,LRAY,ITYPE,ISH,G1,G2,
     *                         G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
                    IF (LRAY) THEN
                      KPOL(I2,4)=ISH
                    ENDIF
                  ENDIF
                  GPOL(I2,1)=G1C
                  GPOL(I2,2)=G2C
C                 When the ray C is on the sides of the basic triangle
C                 which contains the divided triangle, storing it to
C                 the array KBR:
                  IF (KTRID(5).NE.0) THEN
                    CALL RPTRI3(KTRID(5),LTRI,KTRIS)
                    IF (.NOT.LTRI) CALL RPERR(2)
                  ELSE
                    KTRIS(1)=KTRID(1)
                    KTRIS(2)=KTRID(2)
                    KTRIS(3)=KTRID(3)
                  ENDIF
                  CALL RPRAY(KTRIS(1),LRAY,ITYPE,ISH,G1I,G2I,G11,G12,G22
     *                       ,X1,X2,G1X1,G2X1,G1X2,G2X2)
                  IF (.NOT.LRAY) CALL RPERR(1)
                  CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISH,G1J,G2J,G11,G12,G22
     *                       ,X1,X2,G1X1,G2X1,G1X2,G2X2)
                  IF (.NOT.LRAY) CALL RPERR(1)
                  CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1K,G2K,G11,G12,G22
     *                       ,X1,X2,G1X1,G2X1,G1X2,G2X2)
                  IF (.NOT.LRAY) CALL RPERR(1)
                  KRAYI=0
                  IF (RPLRIL(G1C,G2C,G1K,G2K,G1I,G2I)) THEN
C                   Boundary rays are lying on the side IK (side 3,1):
                    KRAYI=KTRIS(1)
                    KRAYJ=KTRIS(3)
                  ELSEIF (RPLRIL(G1C,G2C,G1I,G2I,G1J,G2J)) THEN
C                   Boundary rays are lying on the side IJ (side 1,2):
                    KRAYI=KTRIS(2)
                    KRAYJ=KTRIS(1)
                  ELSEIF (RPLRIL(G1C,G2C,G1J,G2J,G1K,G2K)) THEN
C                   Boundary rays are lying on the side JK (side 2,3):
                    KRAYI=KTRIS(3)
                    KRAYJ=KTRIS(2)
                  ENDIF
                  IF (KRAYI.NE.0) CALL RPKBR(KRAYI,KRAYJ,KRAYC)
C                 Noting that new boundary rays are to be stored:
                  KRAYD0=KRAYC
                  LSTORE=.TRUE.
                  ISTART=0
                  NPOLH=0
                  NLINE=0
                  GOTO 15
                ENDIF
              ENDIF
            ENDIF
C           Ray C is on the polygon, but it is not to be added to it.
            GOTO 116
          ENDIF
          I1=I2
          I2=I2+1
        IF (I2.LE.NPOL) GOTO 112
      ENDIF
  116 CONTINUE
C     Entry point when ray C=(A+B)/2. was chosen from the polygon
C     (or was traced and lies on the polygon).
C     Proposing of ray parameters G1NEW,G2NEW of a new ray D:
      G11POM=(G11A+G11B+G11C)/3.
      G12POM=(G12A+G12B+G12C)/3.
      G22POM=(G22A+G22B+G22C)/3.
      DETG=G11POM*G22POM - G12POM*G12POM
      IF (DETG.LT.ZERO) CALL RPERR(4)
      DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
      IF (ISHC.EQ.ISHA) THEN
        DG1=G1A-G1B
        DG2=G2A-G2B
      ELSE
        DG1=G1B-G1A
        DG2=G2B-G2A
      ENDIF
      AAA=G11POM*DG1+G12POM*DG2
      BBB=G12POM*DG1+G22POM*DG2
C     DGIN constructed so that vector C-N is normalized to one:
      SQ=SQRT(1./(DETG*DIST2))
      DG1N= SQ*BBB
      DG2N=-SQ*AAA
C     Choosing the length of the vector C-N:
      DG1N=DG1N*(PAR*SQRT(DIST2))
      DG2N=DG2N*(PAR*SQRT(DIST2))
      IF (ABS(DG1N).LT.ZERO) THEN
        IF (DG1N.LT.0.) THEN
          DG1N=-ZERO
        ELSE
          DG1N=ZERO
        ENDIF
      ENDIF
      IF (ABS(DG2N).LT.ZERO) THEN
        IF (DG2N.LT.0.) THEN
          DG2N=-ZERO
        ELSE
          DG2N=ZERO
        ENDIF
      ENDIF
      G1NEW=G1C + DG1N
      G2NEW=G2C + DG2N
      INEWR=1
      MINDIS=0.
      IF (.NOT.(RPLRIP(NPOL,GPOL,G1NEW,G2NEW))) THEN
C       New ray D proposed out of the polygon will be replaced by
C       the intersection point.
C       Looking for the intersection point of abscissa KRAYC,KRAYD
C       with the abscissae of the polygon:
C       ..J,..K ... The rays of tested polygon abscissa.
C       ..C,..D ... The rays of intersecting abscissa.
C       ..X ... The intersection point.
        MINDIS=999999.
        G1J=GPOL(NPOL,1)
        G2J=GPOL(NPOL,2)
        G1K=GPOL(1,1)
        G2K=GPOL(1,2)
        G1D=G1NEW
        G2D=G2NEW
        I1=0
  117   CONTINUE
        CALL RPCROS(G1C,G2C,G1D,G2D,G1J,G2J,G1K,G2K,LINTS,G1X,G2X)
        IF (LINTS) THEN
          DIST2=RPDI2G(G1X,G2X,G1C,G2C,G11POM,G12POM,G22POM)
          IF ((DIST2.LT.MINDIS).AND.(DIST2.GT.ZERO1)) THEN
            J4=I1
            MINDIS=DIST2
            G1NEW=G1X
            G2NEW=G2X
          ENDIF
        ENDIF
        I1=I1+1
        IF ((KPOL(I1,1).EQ.IABS(KLINE(J3,1))).AND.
     *      (KPOL(I1+1,1).EQ.IABS(KLINE(J3+1,1)))) I1=I1+1
        IF (I1.LT.NPOL) THEN
          G1J=GPOL(I1,1)
          G2J=GPOL(I1,2)
          G1K=GPOL(I1+1,1)
          G2K=GPOL(I1+1,2)
          GOTO 117
        ENDIF
        INEWR=-1
      ENDIF
      IF (MINDIS.EQ.999999.) THEN
        ISTART=ISTART+1
        INEWR=0
        NPOLH=0
        NLINE=0
        GOTO 60
      ENDIF
C     Trace a new ray, then go to 120:
      KRAYE=KRAYC
      IGOTO=3
      LNEWAR=.TRUE.
      RETURN
C
C     New ray D was actually traced:
  120 CONTINUE
      KRAYD=IRAY
      CALL RPRAY(IRAY,LRAY,ITYPED,ISHD,G1D,G2D,G11D,G12D,G22D,X1,X2,
     *           G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      IF (ISHD.NE.ISHC) THEN
C       Ray D has another history than previous ray (C or D).
C       Halving the interval (on label 140):
        LDGEAE=.FALSE.
        IF ((ISHD.NE.ISHP).AND.(ISHC.NE.ISHP)) THEN
          ISTART=ISTART+1
          NPOLH=0
          NLINE=0
          GOTO 60
        ENDIF
        IF (ISHD.NE.ISHA) THEN
          KRAYA=KRAYE
          KRAYB=KRAYD
        ELSE
          KRAYA=KRAYD
          KRAYB=KRAYE
        ENDIF
        CALL RPRAY(KRAYA,LRAY,ITYPEA,ISHA,G1A,G2A,G11A,G12A,G22A,X1,X2,
     *             G1X1A,G2X1A,G1X2A,G2X2A)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(KRAYB,LRAY,ITYPEB,ISHB,G1B,G2B,G11B,G12B,G22B,X1,X2,
     *             G1X1B,G2X1B,G1X2B,G2X2B)
        IF (.NOT.LRAY) CALL RPERR(1)
        GOTO 140
      ELSEIF (INEWR.GT.0) THEN
C       Ray D has the same history than previous ray (C or D),
C       proposing the parameters of a new ray D:
        G1NEW=G1C + DG1N*(2.**(INEWR))
        G2NEW=G2C + DG2N*(2.**(INEWR))
        KRAYE=KRAYD
        INEWR=INEWR+1
        MINDIS=0.
        IF (.NOT.(RPLRIP(NPOL,GPOL,G1NEW,G2NEW))) THEN
C         New ray D proposed out of the polygon will be replaced by
C         the intersection point.
C         Looking for the intersection point of abscissa KRAYC,KRAYD
C         with the abscissae of the polygon:
C         ..J,..K ... The rays of tested polygon abscissa.
C         ..C,..D ... The rays of intersecting abscissa.
C         ..X ... The intersection point.
          MINDIS=999999.
          G1J=GPOL(NPOL,1)
          G2J=GPOL(NPOL,2)
          G1K=GPOL(1,1)
          G2K=GPOL(1,2)
          G1D=G1NEW
          G2D=G2NEW
          I1=0
  122     CONTINUE
          CALL RPCROS(G1C,G2C,G1D,G2D,G1J,G2J,G1K,G2K,LINTS,G1X,G2X)
          IF (LINTS) THEN
            DIST2=RPDI2G(G1X,G2X,G1C,G2C,G11POM,G12POM,G22POM)
            IF ((DIST2.LT.MINDIS).AND.(DIST2.GT.ZERO1)) THEN
              J4=I1
              MINDIS=DIST2
              G1NEW=G1X
              G2NEW=G2X
            ENDIF
          ENDIF
          I1=I1+1
          IF (I1.LT.NPOL) THEN
            G1J=GPOL(I1,1)
            G2J=GPOL(I1,2)
            G1K=GPOL(I1+1,1)
            G2K=GPOL(I1+1,2)
            GOTO 122
          ENDIF
          INEWR=-1
        ENDIF
        IF (MINDIS.EQ.999999.) THEN
          ISTART=ISTART+1
          INEWR=0
          NPOLH=0
          NLINE=0
          GOTO 60
        ENDIF
C       Trace a new ray, then go to 120:
        IGOTO=3
        LNEWAR=.TRUE.
        RETURN
      ELSE
C       Ray D is an intersection point and has the same history as a
C       previous ray (C or D). This ray will be placed to the polygon
C       and the polygon will be divided again.
C       The intersection appeared with J4-th abscissa of the polygon:
        IF (J4.EQ.0) THEN
          I1=NPOL
          I2=1
        ELSE
          I1=J4
          I2=J4+1
        ENDIF
        IF ((ISHD.EQ.KPOL(I1,2)).AND.(ISHD.EQ.KPOL(I2,2))) THEN
C         Ray D is between the rays of the same history:
          IF (.NOT.LDGEAE) THEN
C           Trying to find ray D once more, starting from the ray C
C           and going with the first step equal to AERR.
C           Hereinafter DETG is not the determinant:
            DETG=DG1N*G11C*DG1N + 2.*G12C*DG1N*DG2N + DG2N*G22C*DG2N
            DETG=SQRT(DETG)
            IF (DETG.LT.ZERO1) DETG=ZERO1
            DETG=SQRT(AERR2)/DETG
            DG1N=DG1N*DETG
            DG2N=DG2N*DETG
            G1NEW=G1C + DG1N
            G2NEW=G2C + DG2N
            IF (RPLRIP(NPOL,GPOL,G1NEW,G2NEW)) THEN
C             New ray must be in the inhomogeneous polygon:
              INEWR=1
C             Trace a new ray, then go to 120:
              KRAYE=KRAYC
              IGOTO=3
              LNEWAR=.TRUE.
              LDGEAE=.TRUE.
              RETURN
            ENDIF
          ENDIF
          ISTART=ISTART+1
          LDGEAE=.FALSE.
        ELSE
C         Ray D is between the rays of different history:
          IF ((KPOL(I1,3).EQ.KPOL(I2,1)).OR.(KPOL(I1,1).EQ.KPOL(I2,3)))
     *        THEN
C           New ray is between the rays signed as boundary rays,
C           this ray is not to be stored to KPOL:
            ISTART=ISTART+1
            NPOLH=0
            NLINE=0
            GOTO 60
          ENDIF
          CALL RPRAY(KPOL(I1,1),LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *               X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          CALL RPRAY(KPOL(I2,1),LRAY,ITYPEX,ISHX,G1X,G2X,G11X,G12X,
     *               G22X,X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          G11POM=(G11X+G11)/2.
          G12POM=(G12X+G12)/2.
          G22POM=(G22X+G22)/2.
          DIST2=RPDI2G(GPOL(I1,1),GPOL(I1,2),GPOL(I2,1),GPOL(I2,2),
     *                 G11POM,G12POM,G22POM)
          IF (DIST2.LT.AERR2) THEN
C           New ray is between the rays which are
C           as near as boundary rays,
C           this ray is not to be stored to KPOL:
            ISTART=ISTART+1
            NPOLH=0
            NLINE=0
            GOTO 60
          ENDIF
C         New ray D is to be added to the polygon:
          IF (NPOL.GE.MPOL) CALL RPERR(5)
          NPOL=NPOL+1
          DO 128, I4=NPOL,I2+1,-1
            KPOL(I4,1)=KPOL(I4-1,1)
            KPOL(I4,2)=KPOL(I4-1,2)
            KPOL(I4,3)=KPOL(I4-1,3)
            KPOL(I4,4)=KPOL(I4-1,4)
            GPOL(I4,1)=GPOL(I4-1,1)
            GPOL(I4,2)=GPOL(I4-1,2)
  128     CONTINUE
          KPOL(I2,1)=KRAYD
          KPOL(I2,2)=ISHD
          KPOL(I2,3)=ITYPED
          KPOL(I2,4)=0
          IF (ITYPED.GT.0) THEN
            CALL RPRAY(ITYPED,LRAY,ITYPE,ISH,G1,G2,
     *                 G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
            IF (LRAY) THEN
              KPOL(I2,4)=ISH
            ENDIF
          ENDIF
          GPOL(I2,1)=G1D
          GPOL(I2,2)=G2D
C         When the ray D is on the sides of the basic triangle which
C         contains the divided triangle, storing it to the KBR:
          IF (KTRID(5).NE.0) THEN
            CALL RPTRI3(KTRID(5),LTRI,KTRIS)
            IF (.NOT.LTRI) CALL RPERR(2)
          ELSE
            KTRIS(1)=KTRID(1)
            KTRIS(2)=KTRID(2)
            KTRIS(3)=KTRID(3)
          ENDIF
          CALL RPRAY(KTRIS(1),LRAY,ITYPE,ISH,G1I,G2I,G11,G12,G22,
     *               X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISH,G1J,G2J,G11,G12,G22,
     *               X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1K,G2K,G11,G12,G22,
     *               X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          KRAYI=0
          IF (RPLRIL(G1D,G2D,G1K,G2K,G1I,G2I)) THEN
C           Boundary rays are lying on the side IK (side 3,1):
            KRAYI=KTRIS(1)
            KRAYJ=KTRIS(3)
          ELSEIF (RPLRIL(G1D,G2D,G1I,G2I,G1J,G2J)) THEN
C           Boundary rays are lying on the side IJ (side 1,2):
            KRAYI=KTRIS(2)
            KRAYJ=KTRIS(1)
          ELSEIF (RPLRIL(G1D,G2D,G1J,G2J,G1K,G2K)) THEN
C           Boundary rays are lying on the side JK (side 2,3):
            KRAYI=KTRIS(3)
            KRAYJ=KTRIS(2)
          ENDIF
          IF (KRAYI.NE.0) CALL RPKBR(KRAYI,KRAYJ,KRAYD)
C         Noting that new boundary rays are to be stored:
          KRAYD0=KRAYD
          LSTORE=.TRUE.
          ISTART=0
        ENDIF
        NPOLH=0
        NLINE=0
        GOTO 15
      ENDIF
C
C     Entry point when a new ray was traced during the
C     division of the interval formed by rays A and B.
C     (The interval is divided to demarcate the boundary.)
  130 CALL RPRAY(IRAY,LRAY,ITYPED,ISHD,G1D,G2D,G11D,G12D,G22D,X1,X2
     *          ,G1X1D,G2X1D,G1X2D,G2X2D)
      IF (.NOT.LRAY) CALL RPERR(1)
      KRAYD=IRAY
      IF (ISHD.EQ.ISHA) THEN
         KRAYA= KRAYD
        ITYPEA=ITYPED
           G1A=   G1D
           G2A=   G2D
          G11A=  G11D
          G12A=  G12D
          G22A=  G22D
         G1X1A= G1X1D
         G2X1A= G2X1D
         G1X2A= G1X2D
         G2X2A= G2X2D
      ELSE
         KRAYB= KRAYD
        ITYPEB=ITYPED
           G1B=   G1D
           G2B=   G2D
          G11B=  G11D
          G12B=  G12D
          G22B=  G22D
         G1X1B= G1X1D
         G2X1B= G2X1D
         G1X2B= G1X2D
         G2X2B= G2X2D
      ENDIF
C
  140 CONTINUE
C     Interval A,B is proposed, now deciding whether it must be divided:
C     (The interval is divided to demarcate the boundary.)
      G11POM=(G11A+G11B)/2.
      G12POM=(G12A+G12B)/2.
      G22POM=(G22A+G22B)/2.
      DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
      IF (DIST2.LE.AERR2) THEN
        IF (PRM0(1).NE.0.) THEN
          IF ((ISHA.GT.0).OR.(ISHB.GT.0)) THEN
            CALL RPMEGS(ISHA,ISHB,G1X1A,G2X1A,G1X2A,G2X2A,
     *                            G1X1B,G2X1B,G1X2B,G2X2B,G11,G12,G22)
            DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11,G12,G22)
            IF (DIST2.GT.1.) THEN
              DIST2=AERR2+1.
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      IF ((DIST2.GT.AERR2).OR.(KRAYA.EQ.IABS(KLINE(J3,1))).OR.
     *                      (KRAYA.EQ.IABS(KLINE(J3+1,1)))) THEN
        IF ((ABS(G1B-G1A).GE.ZERO).OR.(ABS(G2B-G2A).GE.ZERO)) THEN
C         Trace a new ray, then go to 130:
          G1NEW=(G1A+G1B)/2.
          G2NEW=(G2A+G2B)/2.
          IF (((G1NEW.EQ.G1A).AND.(G2NEW.EQ.G2A)).OR.
     *        ((G1NEW.EQ.G1B).AND.(G2NEW.EQ.G2B))) CALL RPERR(3)
          IGOTO=4
          LNEWAR=.TRUE.
          RETURN
        ELSE
          J3=J3+1
          IF (J3+2.LE.NLINE) THEN
            GOTO 141
          ELSE
            GOTO 145
          ENDIF
        ENDIF
      ENDIF
C     Rays A and B are boundary rays:
      CALL RPRAY(KRAYA,LRAY,ITYPEA,ISHA,G1A,G2A,G11A,G12A,G22A,X1,X2
     *           ,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      ITYPEA=KRAYB
      CALL RPMC1(KRAYA,ITYPEA)
      CALL RPSTOR('R',KRAYA,KTRIS)
      CALL RPRAY(KRAYB,LRAY,ITYPEB,ISHB,G1B,G2B,G11B,G12B,G22B,X1,X2
     *           ,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      ITYPEB=KRAYA
      CALL RPMC1(KRAYB,ITYPEB)
      CALL RPSTOR('R',KRAYB,KTRIS)
C     Storing boundary rays to KLINE:
      IF (NLINE.GE.MLINE) CALL RPERR(7)
      NLINE=NLINE+1
      DO 142, I2=NLINE,J3+2,-1
        KLINE(I2,1)=KLINE(I2-1,1)
        KLINE(I2,2)=KLINE(I2-1,2)
        KLINE(I2,3)=KLINE(I2-1,3)
        KLINE(I2,4)=KLINE(I2-1,4)
  142 CONTINUE
      KLINE(J3+1,1)=KRAYA
      KLINE(J3+1,2)=ISHA
      KLINE(J3+1,3)=ITYPEA
      KLINE(J3+1,4)=ISHB
  141 CONTINUE
C     Deciding whether the side formed by rays J3,J3+1 of KLINE
C     is to be divided:
      IF (KLINE(J3,1).LT.0) THEN
        KLINE(J3,1)=IABS(KLINE(J3,1))
      ELSE
C       Criterion 1: (Distance of the ray J3+1 from the
C                     line connecting rays J3 and J3+2) .lt. (4*AERR)
        CALL RPRAY(IABS(KLINE(J3,1)),LRAY,ITYPEB,ISHB,G1B,G2B,G11B,G12B,
     *             G22B,X1,X2,G1X1B,G2X1B,G1X2B,G2X2B)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(IABS(KLINE(J3+1,1)),LRAY,ITYPEA,ISHA,G1A,G2A,
     *                     G11A,G12A,G22A,X1,X2,G1X1A,G2X1A,G1X2A,G2X2A)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(IABS(KLINE(J3+2,1)),LRAY,ITYPEC,ISHC,G1C,G2C,
     *                     G11C,G12C,G22C,X1,X2,G1X1C,G2X1C,G1X2C,G2X2C)
        IF (.NOT.LRAY) CALL RPERR(1)
        G11POM=(G11A+G11C+G11B)/3.
        G12POM=(G12A+G12C+G12B)/3.
        G22POM=(G22A+G22C+G22B)/3.
        DIST2=RPDI2G(G1C,G2C,G1B,G2B,G11POM,G12POM,G22POM)
        DETG=G11POM*G22POM - G12POM*G12POM
        IF (DETG.LT.ZERO) CALL RPERR(4)
        AREA=DETG*(((G1C-G1B)*(G2A-G2B)-(G2C-G2B)*(G1A-G1B))**2)
C       Distance:      (AREA is the area**2)
        IF (DIST2.GE.ZERO) DIST2=AREA/DIST2
        IF (DIST2.LE.16*AERR2) THEN
C         Criterion 2: (Distance of the rays J3 and J3+1)**2.lt.BSTEP2:
          DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
          IF (DIST2.LE.BSTEP2) THEN
C           Criterion 3: (Boundary rays on the other side
C           of the boundary then rays J3 and J3+1 should display
C           the same value of the history function.)
            IF ((KLINE(J3,4).NE.0).AND.(KLINE(J3+1,4).NE.0).AND.
     *          (KLINE(J3,4).NE.KLINE(J3+1,4))) THEN
              GOTO 107
            ENDIF
C           Now proceeding with the next ray of KLINE:
            J3=J3+1
            IF (J3+2.LE.NLINE) THEN
              GOTO 141
            ELSE
              GOTO 145
            ENDIF
          ENDIF
        ELSE
          KLINE(J3+1,1)=-IABS(KLINE(J3+1,1))
        ENDIF
      ENDIF
      GOTO 107
C
  145 CONTINUE
      IF (J3.LE.NLINE-1) THEN
C       Criterion 2: (Distance of the rays J3 and J3+1)**2 .lt. BSTEP2:
        IF (KLINE(J3,1).LT.0) THEN
          KLINE(J3,1)=IABS(KLINE(J3,1))
          GOTO 107
        ENDIF
        CALL RPRAY(IABS(KLINE(J3,1)),LRAY,ITYPEB,ISHB,G1B,G2B,G11B,G12B,
     *             G22B,X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(IABS(KLINE(J3+1,1)),LRAY,ITYPEA,ISHA,G1A,G2A,
     *             G11A,G12A, G22A,X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        G11POM=(G11A+G11B)/2.
        G12POM=(G12A+G12B)/2.
        G22POM=(G22A+G22B)/2.
        DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
        IF (DIST2.GT.BSTEP2) GOTO 107
C       Criterion 3: (Boundary rays on the other side
C       of the boundary then rays J3 and J3+1 should display
C       the same value of the history function.)
        IF ((KLINE(J3,4).NE.0).AND.(KLINE(J3+1,4).NE.0).AND.
     *      (KLINE(J3,4).NE.KLINE(J3+1,4)))    GOTO 107
      ENDIF
C
C     Boundary is found:
      IF (J30.NE.999999) THEN
        J3=J30
        J30=999999
        GOTO 107
      ENDIF
C     GOTO 143
C
C     The boundary closing the homogeneous polygon is found.
C     Both homogeneous and inhomogeneous polygons will be corrected now:
  143 CONTINUE
      IF (NPOL.EQ.NPOLH) THEN
C       End of the division of this triangle:
        NPOL=0
      ELSE
        NPOL=NPOL-NPOLH
        DO 144, I2=J1,NPOL
          KPOL(I2,1)=KPOL(I2+NPOLH,1)
          KPOL(I2,2)=KPOL(I2+NPOLH,2)
          KPOL(I2,3)=KPOL(I2+NPOLH,3)
          KPOL(I2,4)=KPOL(I2+NPOLH,4)
          GPOL(I2,1)=GPOL(I2+NPOLH,1)
          GPOL(I2,2)=GPOL(I2+NPOLH,2)
  144   CONTINUE
        NPOL=NPOL+NLINE-2
        IF (NPOL.GT.MPOL) CALL RPERR(5)
        DO 146, I2=NPOL,NLINE+J1-2,-1
          KPOL(I2,1)=KPOL(I2-NLINE+2,1)
          KPOL(I2,2)=KPOL(I2-NLINE+2,2)
          KPOL(I2,3)=KPOL(I2-NLINE+2,3)
          KPOL(I2,4)=KPOL(I2-NLINE+2,4)
          GPOL(I2,1)=GPOL(I2-NLINE+2,1)
          GPOL(I2,2)=GPOL(I2-NLINE+2,2)
  146   CONTINUE
        DO 148, I2=2,NLINE-1
          KPOL(J1+I2-2,1)=KLINE(I2,3)
          KPOL(J1+I2-2,4)=KLINE(I2,2)
          CALL RPRAY(KLINE(I2,3),LRAY,ITYPEA,ISHA,G1A,G2A,G11A,G12A,G22A
     *              ,X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          KPOL(J1+I2-2,2)=ISHA
          KPOL(J1+I2-2,3)=ITYPEA
          GPOL(J1+I2-2,1)=G1A
          GPOL(J1+I2-2,2)=G2A
  148   CONTINUE
        IF (NLINE.LE.2) THEN
          IF ((J1.GT.1).AND.(J1.LE.NPOL)) THEN
            KPOL(J1-1,3)=KPOL(J1,1)
          ELSE
            KPOL(NPOL,3)=KPOL(1,1)
          ENDIF
        ENDIF
      ENDIF
      IF (NPOLH+NLINE-2.GE.MPOLH) CALL RPERR(6)
      DO 149, I2=NLINE-1,2,-1
        NPOLH=NPOLH+1
        KPOLH(NPOLH,1)=IABS(KLINE(I2,1))
        KPOLH(NPOLH,2)=KLINE(I2,2)
        KPOLH(NPOLH,3)=KLINE(I2,3)
        KPOLH(NPOLH,4)=KLINE(I2,4)
        CALL RPRAY(KPOLH(NPOLH,1),LRAY,ITYPEA,ISHA,G1A,G2A,G11A,G12A,
     *             G22A,X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        GPOLH(NPOLH,1)=G1A
        GPOLH(NPOLH,2)=G2A
  149 CONTINUE
      NLINE=0
C
      J5=0
      IF (ISTART.GT.0.) THEN
C       Inhomogeneous polygon will be shifted now:
        ISTART=0
        I2=0
  152   CONTINUE
        I2=I2+1
        IF (NPOL.GE.MPOL) CALL RPERR(5)
        KPOL(NPOL+1,1)=KPOL(1,1)
        KPOL(NPOL+1,2)=KPOL(1,2)
        KPOL(NPOL+1,3)=KPOL(1,3)
        KPOL(NPOL+1,4)=KPOL(1,4)
        GPOL(NPOL+1,1)=GPOL(1,1)
        GPOL(NPOL+1,2)=GPOL(1,2)
        DO 153, I1=1,NPOL
          KPOL(I1,1)=KPOL(I1+1,1)
          KPOL(I1,2)=KPOL(I1+1,2)
          KPOL(I1,3)=KPOL(I1+1,3)
          KPOL(I1,4)=KPOL(I1+1,4)
          GPOL(I1,1)=GPOL(I1+1,1)
          GPOL(I1,2)=GPOL(I1+1,2)
  153   CONTINUE
        IF ((KPOL(1,2).EQ.KPOL(NPOL,2)).AND.(I2.LT.NPOL)) GOTO 152
      ENDIF
C
C     The homogeneous polygon is prepared to be divided:
  155 CONTINUE
      LNEWAR=.FALSE.
      IF (NPOLH.LT.3) THEN
C       In this situation a very small part of the domain
C       will escape notice.
        DO 156, I1=1,NPOL
          IF (KPOL(I1,1).EQ.KPOLH(1,1)) THEN
            IF ((I1.GT.1).AND.(I1+NPOLH.LE.NPOL)) THEN
              KPOL(I1-1,3)=KPOL(I1+NPOLH,1)
            ELSEIF (I1.EQ.1) THEN
              KPOL(NPOL,3)=KPOL(I1+NPOLH,1)
            ELSE
              KPOL(I1-1,3)=KPOL(1,1)
            ENDIF
          ENDIF
  156   CONTINUE
        NPOLH=0
        IF (NPOL.GE.2) THEN
          GOTO 15
        ENDIF
        KTRID(6)=2
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C
      IF (NPOLH.EQ.3) THEN
        IF (RPLRIT(.FALSE.,GPOLH(1,1),GPOLH(1,2),GPOLH(2,1),GPOLH(2,2),
     *            GPOLH(3,1),GPOLH(3,2),G1A,G2A,AREA)) THEN
          ITRI=ITRI+1
          KTRIN(1)=KPOLH(1,1)
          KTRIN(2)=KPOLH(2,1)
          KTRIN(3)=KPOLH(3,1)
          KTRIN(4)=ITRI
          IF (KTRID(5).EQ.0) THEN
            KTRIN(5)=KTRID(4)
          ELSE
            KTRIN(5)=KTRID(5)
          ENDIF
          KTRIN(6)=3
          CALL RPTRI1(ITRI,KTRIN)
          CALL RPSTOR('T',1,KTRIN)
        ENDIF
        NPOLH=0
        IF (NPOL.GE.2) THEN
          GOTO 15
        ENDIF
        KTRID(6)=2
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C
C     Dividing the homogeneous polygon into triangles:
      CALL RPRAY(KPOLH(1,1),LRAY,ITYPEX,ISHX,G1X,G2X,G11X,G12X,G22X
     *                     ,X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
  160 CALL RPHPDI(NPOLH,KPOLH,GPOLH,IRAY,ITRI,KTRID,LNEWAR,
     *            G1NEW,G2NEW)
      IF (LNEWAR) THEN
C       Trace the new ray and go to 160:
        IGOTO=5
        RETURN
      ENDIF
      IF (NPOLH.LE.0) THEN
        IF (NPOL.GE.2) THEN
          GOTO 15
        ENDIF
        KTRID(6)=2
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        LNEWAR=.FALSE.
        RETURN
      ENDIF
      GOTO 155
      END
C
C=======================================================================
C
      SUBROUTINE RPNEW(IRAY,ITRI,G1NEW,G2NEW,LNEWAR)
C
C-----------------------------------------------------------------------
      INTEGER IRAY,ITRI
      REAL G1NEW,G2NEW
      LOGICAL LNEWAR
C
C Subroutine designed to determine a new basic triangle and
C to adjust the boundary of the region covered by the basic triangles.
C Subroutine also determines normalized ray parameters of a new ray,
C if needed.
C
C Input:
C     IRAY... Index of the last computed ray.
C     ITRI... Index of the last computed triangle.
C Output:
C     G1NEW,G2NEW... If a new basic ray is to be traced,
C             parameters of the new ray.
C     LNEWAR... Indicates whether the new basic ray is to be computed.
C
C Subroutines and external functions required:
      EXTERNAL RPDI2G,RPLRIL,RPLRIT
      REAL RPDI2G
      LOGICAL RPLRIL,RPLRIT
C
C Coded by Petr Bulant
C
C.......................................................................
C
C Common blocks /GLIM/ and /POLY/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C.......................................................................
C
      REAL SIDE,NEAR,SIDE2,NEAR2
      PARAMETER (SIDE=1.1547)
      PARAMETER (SIDE2=SIDE**2)
      PARAMETER (NEAR=SIDE*.618)
      PARAMETER (NEAR2=NEAR**2)
      REAL ZERO
      PARAMETER (ZERO =.0000001)
      INTEGER IRADD1,IRADD2
      INTEGER IONPOL,ICOR
      INTEGER NPL0
      INTEGER KTRIN(6)
      INTEGER ITYPE,ISHEET
      REAL G1,G2,G11,G12,G22,X1,X2
      REAL G1X1,G2X1,G1X2,G2X2
      REAL G1I,G2I,G11I,G12I,G22I,X1I,X2I
      REAL G1J,G2J,G11J,G12J,G22J,X1J,X2J
      REAL G1R2,G2R2,G11R2,G12R2,G22R2,X1R2,X2R2
      REAL G1M,G2M,G11M,G12M,G22M,X1M,X2M
      REAL G1N,G2N,G11N,G12N,G22N,X1N,X2N
      REAL G11POM,G12POM,G22POM,AAA,BBB,BBB1,DETG,VECT,DIST2,DIST21
      INTEGER I1,J1
      LOGICAL LRAY,LINTS,LIONPL
C     SIDE... Length of basic triangles sides.
C     NEAR... Length to identify rays.
C             SIDE=SQRT(4/3) , NEAR=SIDE*0.618
C     SIDE2,NEAR2... Second powers of SIDE and NEAR.
C     ZERO... Constant used to decide whether the real variable.EQ.zero.
C     IRADD1,IRADD2... Sequence (in KPL) of two rays of polyline,
C             suitable to add a new ray between them.
C     IONPOL... When as the new ray is taken some ray of the polyline,
C             the sequence (in KPL) of this ray on polyline;
C             when as the new ray is taken a corner ray of the
C             normalized domain, zero.
C     ICOR... ICOR.NE.0 indicates that the new ray is a corner ray
C             of domain.  (then in ICOR is sign of this corner ray.)
C     NPL0... Number of the rays on the polyline before adding a new
C             triangle.
C     KTRIN... All parameters of a new triangle to be registrated.
C     ITYPE... Type of ray:
C             0: .......... Basic ray.
C             ITYPE.GT.0:.. Boundary ray, ITYPE is the index of the
C                           boundary ray at the other side of the bound.
C             -2:.......... Auxiliary ray, not used.
C             -3:.......... Auxiliary ray, used.
C             -1000-I:..... Two-point ray (to the I'th receiver).
C     ISHEET... Value of integer function distinguishing between rays of
C             different histories.
C     G1,G2... Normalized parameters of rays.
C     G11,G12,G22... Ray-parameter metric tensor.
C     X1,X2... Coordinates of the ray on the reference surface.
C     G1X1,G2X1,G1X2,G2X2... Derivations of ray parameters according to
C             surface coordinates.
C     G1.,G2.,G11..,G12..,G22..,X1..,X2..,... Auxiliary variables.
C     AAA,BBB... Auxiliary variables.
C     DETG... Determinant.
C     VECT... Vector product.
C     DIST2... (Distance of rays)**2.
C     I1...   Implied-do variable or variable controlling the loop.
C     J1...   Auxiliary variable (number).
C     LRAY... Indicates whether the ray IRAY is in memory.
C     LINTS... Indicates whether the intersection appeared.
C     LIONPL... Indicates that the new ray is the IONPOL's ray on
C             polyline or that it is a corner ray of domain
C             (then IONPOL=0).
C-----------------------------------------------------------------------
C
      LIONPL=.FALSE.
C
C     Start of computation -  computation of first polyline rays:
      IF (IRAY.EQ.0) THEN
        NPL=0
      ENDIF
      IF (NPL.EQ.0) THEN
        IF (IRAY.EQ.0) THEN
          G1NEW=GLIMIT(1)
          G2NEW=GLIMIT(3)
          LNEWAR=.TRUE.
          RETURN
        ELSEIF (IRAY.EQ.1) THEN
          G1NEW=GLIMIT(2)
          G2NEW=GLIMIT(3)
          LNEWAR=.TRUE.
          RETURN
        ELSEIF (IRAY.EQ.2) THEN
          G1NEW=GLIMIT(1)
          G2NEW=GLIMIT(4)
          LNEWAR=.TRUE.
          RETURN
        ELSEIF (IRAY.EQ.3) THEN
          G1NEW=GLIMIT(2)
          G2NEW=GLIMIT(4)
          LNEWAR=.TRUE.
          RETURN
        ELSEIF (IRAY.EQ.4) THEN
          J1=1
        ELSE
          J1=IRAY
        ENDIF
        CALL RPRAY(J1,LRAY,ITYPE,ISHEET,G1I,G2I,G11I,G12I,G22I,X1I,X2I,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(2,LRAY,ITYPE,ISHEET,G1R2,G2R2,G11R2,G12R2,G22R2,
     *             X1R2,X2R2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        G1NEW=SQRT(SIDE2/G11I)+G1I
        G2NEW=GLIMIT(3)
        G11POM=(G11I+G11R2)/2.
        G12POM=(G12I+G12R2)/2.
        G22POM=(G22I+G22R2)/2.
        DIST2=RPDI2G(G1NEW,G2NEW,G1R2,G2R2,G11POM,G12POM,G22POM)
        IF ((DIST2.GT.NEAR2).AND.(G1NEW.LT.GLIMIT(2))) THEN
          LNEWAR=.TRUE.
          RETURN
        ENDIF
        KPL(1)=1
        NPL=1
        DO 10, I1=5,IRAY
          IF (NPL.GE.MPL) CALL RPERR(10)
          NPL=NPL+1
          KPL(NPL)=I1
  10    CONTINUE
        IF(NPL.GE.MPL) CALL RPERR(10)
        NPL=NPL+1
        KPL(NPL)=2
      ENDIF
C
C     Determination where to add a new ray.
      NPL0=NPL
      CALL RPWHAD(IRADD1,IRADD2)
      CALL RPRAY(KPL(IRADD1),LRAY,ITYPE,ISHEET,G1M,G2M,
     *           G11M,G12M,G22M,X1M,X2M,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KPL(IRADD2),LRAY,ITYPE,ISHEET,G1N,G2N,
     *           G11N,G12N,G22N,X1N,X2N,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
C     ..M,..N ... Two rays of polyline between which we are
C                 adding a new ray.
C
C     All domain covered - return without adding new ray or triangle.
      IF ((G2M.EQ.GLIMIT(4)).AND.(G2N.EQ.GLIMIT(4))) THEN
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C
C     Proposing of ray parameters G1NEW, G2NEW of a new ray.
      G11POM=(G11M+G11N)/2.
      G12POM=(G12M+G12N)/2.
      G22POM=(G22M+G22N)/2.
      AAA=(G11POM*(G1M-G1N)+G12POM*(G2M-G2N))
      BBB=(G12POM*(G1M-G1N)+G22POM*(G2M-G2N))
      DETG=G11POM*G22POM - G12POM*G12POM
      IF (DETG.LT.ZERO) CALL RPERR(4)
      DIST2=(G1M-G1N)*AAA + (G2M-G2N)*BBB
      G1NEW=(G1M+G1N)/2. + SIDE/SQRT(DIST2)*0.5*SQRT(3./DETG)*BBB
      G2NEW=(G2M+G2N)/2. - SIDE/SQRT(DIST2)*0.5*SQRT(3./DETG)*AAA
C
C     Checking whether the new ray is not out of the domain.
      IF (G1NEW.LT.GLIMIT(1)) THEN
        G2=G2NEW + (G1NEW-GLIMIT(1))*G12POM/G22POM
        G1NEW=GLIMIT(1)
        IF (RPLRIT(.FALSE.,G1M,G2M,G1N,G2N,G1NEW,G2,0.,0.,AAA)) G2NEW=G2
      ENDIF
      IF (G1NEW.GT.GLIMIT(2)) THEN
        G2=G2NEW + (G1NEW-GLIMIT(2))*G12POM/G22POM
        G1NEW=GLIMIT(2)
        IF (RPLRIT(.FALSE.,G1M,G2M,G1N,G2N,G1NEW,G2,0.,0.,AAA)) G2NEW=G2
      ENDIF
      IF (G2NEW.LT.GLIMIT(3)) THEN
        G1=G1NEW + (G2NEW-GLIMIT(3))*G12POM/G11POM
        G2NEW=GLIMIT(3)
        IF (RPLRIT(.FALSE.,G1M,G2M,G1N,G2N,G1,G2NEW,0.,0.,AAA)) G1NEW=G1
      ENDIF
      IF (G2NEW.GT.GLIMIT(4)) THEN
        G1=G1NEW + (G2NEW-GLIMIT(4))*G12POM/G11POM
        G2NEW=GLIMIT(4)
        IF (RPLRIT(.FALSE.,G1M,G2M,G1N,G2N,G1,G2NEW,0.,0.,AAA)) G1NEW=G1
      ENDIF
C
C     Checking whether the new ray is not too near
C     the domain boundary.
      BBB=GLIMIT(4)-G2NEW
      AAA=-BBB*G12POM/G11POM
      DIST2=AAA*(AAA*G11POM+2*BBB*G12POM)+BBB*G22POM*BBB
      IF (DIST2.LT.NEAR2) THEN
        G2=GLIMIT(4)
        G1=G1NEW+AAA
        IF (RPLRIT(.FALSE.,G1M,G2M,G1N,G2N,G1,G2,0.,0.,AAA)) THEN
          IF ((G1.GE.GLIMIT(1)).AND.(G1.LE.GLIMIT(2))) G1NEW=G1
          IF ((G2.GE.GLIMIT(3)).AND.(G2.LE.GLIMIT(4))) G2NEW=G2
        ENDIF
      ENDIF
C
      IF ((G1NEW.EQ.GLIMIT(1)).OR.(G1NEW.EQ.GLIMIT(2))) GOTO 12
C
      AAA=GLIMIT(1)-G1NEW
      BBB=-AAA*G12POM/G22POM
      DIST2=AAA*(AAA*G11POM+2*BBB*G12POM)+BBB*G22POM*BBB
      AAA=GLIMIT(2)-G1NEW
      BBB1=-AAA*G12POM/G22POM
      DIST21=AAA*(AAA*G11POM+2*BBB1*G12POM)+BBB1*G22POM*BBB1
      IF ((DIST2.LT.NEAR2).OR.(DIST21.LT.NEAR2)) THEN
        IF (DIST2.LT.DIST21) THEN
          G1=GLIMIT(1)
          G2=G2NEW+BBB
          IF (RPLRIT(.FALSE.,G1M,G2M,G1N,G2N,G1,G2,0.,0.,AAA)) THEN
            IF ((G1.GE.GLIMIT(1)).AND.(G1.LE.GLIMIT(2))) G1NEW=G1
            IF ((G2.GE.GLIMIT(3)).AND.(G2.LE.GLIMIT(4))) G2NEW=G2
          ENDIF
        ELSE
          G1=GLIMIT(2)
          G2=G2NEW+BBB1
          IF (RPLRIT(.FALSE.,G1M,G2M,G1N,G2N,G1,G2,0.,0.,AAA)) THEN
            IF ((G1.GE.GLIMIT(1)).AND.(G1.LE.GLIMIT(2))) G1NEW=G1
            IF ((G2.GE.GLIMIT(3)).AND.(G2.LE.GLIMIT(4))) G2NEW=G2
          ENDIF
        ENDIF
      ENDIF
C
  12  CONTINUE
C
      IF (((G1NEW.EQ.GLIMIT(1)).OR.(G1NEW.EQ.GLIMIT(2))).AND.
     *    (G2NEW.EQ.GLIMIT(4))) THEN
        LIONPL=.TRUE.
        IONPOL=0
        GOTO 16
      ENDIF
C
C     Checking whether the new ray is not too near to any other ray
C     in polyline or to the domain corner ray.
      DO 15, I1=3,4
        CALL RPRAY(I1,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        DIST2=RPDI2G(G1NEW,G2NEW,G1,G2,G11,G12,G22)
        IF ((DIST2.LT.NEAR2).AND.
     *      RPLRIT(.FALSE.,G1M,G2M,G1N,G2N,G1,G2,0.,0.,AAA)) THEN
          G1NEW=G1
          G2NEW=G2
          LIONPL=.TRUE.
          IONPOL=0
          GOTO 16
        ENDIF
  15  CONTINUE
  16  CONTINUE
ccc   DO 20, I1=MAX0(1,IRADD1-1),MIN0(NPL,IRADD2+1)
      DO 20, I1=MAX0(2,IRADD1-1),MIN0(NPL-1,IRADD2+1)
        IF ((I1.NE.IRADD1).AND.(I1.NE.IRADD2)) THEN
          CALL RPRAY(KPL(I1),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *               G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          DIST2=RPDI2G(G1NEW,G2NEW,G1,G2,G11,G12,G22)
          IF ((DIST2.LT.NEAR2).AND.
     *        RPLRIT(.FALSE.,G1M,G2M,G1N,G2N,G1,G2,0.,0.,AAA)) THEN
            G1NEW=G1
            G2NEW=G2
            LIONPL=.TRUE.
            IONPOL=I1
            GOTO 21
          ENDIF
        ENDIF
  20  CONTINUE
  21  CONTINUE
C
C     Checking intersection of polyline.
  30  CALL RPINTS(IRADD1,G1NEW,G2NEW,IRADD1,IRADD2,LIONPL,IONPOL,LINTS)
      IF (LINTS) GOTO 30
      CALL RPINTS(IRADD2,G1NEW,G2NEW,IRADD1,IRADD2,LIONPL,IONPOL,LINTS)
      IF (LINTS) GOTO 30
      IF (.NOT.LIONPL) GOTO 50
      IF (IONPOL.EQ.0) GOTO 50
      IF (((IRADD1-IONPOL).EQ.1).OR.((IRADD2-IONPOL).EQ.-1)) GOTO 50
      IF ((IRADD1-IONPOL).GT.0) THEN
        CALL RPRAY(KPL(IRADD1-1),LRAY,ITYPE,ISHEET,G1J,G2J,
     *             G11J,G12J,G22J,X1J,X2J,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        VECT=(G1M-G1NEW)*(G2J-G2NEW)-(G1J-G1NEW)*(G2M-G2NEW)
        IF (VECT.GT.ZERO) THEN
          IONPOL=IRADD1-1
          G1NEW=G1J
          G2NEW=G2J
        ELSE
C         RP3D-011
          CALL ERROR('RP3D-011: Error in coverage of the ray domain.')
C         A part of the ray domain is probably not covered by basic
C         triangles.
C         This error should not appear.
C         Please contact the author or try to
C         change the input data.
        ENDIF
      ELSE
        CALL RPRAY(KPL(IRADD2+1),LRAY,ITYPE,ISHEET,G1J,G2J,
     *              G11J,G12J,G22J,X1J,X2J,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        VECT=(G1N-G1NEW)*(G2J-G2NEW)-(G1J-G1NEW)*(G2N-G2NEW)
        IF (VECT.LT.ZERO) THEN
          IONPOL=IRADD2+1
          G1NEW=G1J
          G2NEW=G2J
        ELSE
C         RP3D-012
          CALL ERROR('RP3D-012: Error in coverage of the ray domain.')
C         A part of the ray domain is probably not covered by basic
C         triangles.
C         This error should not appear.
C         Please contact the author or try to
C         change the input data.
        ENDIF
      ENDIF
  50  CONTINUE
C
C     New ray is proposed, now performing the last check:
      IF (((G1NEW.EQ.G1M).AND.(G2NEW.EQ.G2M)).OR.
     *    ((G1NEW.EQ.G1N).AND.(G2NEW.EQ.G2N)).OR.
     *    RPLRIL(G1NEW,G2NEW,G1N,G2N,G1M,G2M)) THEN
        IF (G2NEW.EQ.GLIMIT(4)) THEN
          G1NEW=(G1M+G1N)/2.
          GOTO 30
        ELSE
C         RP3D-013
          CALL ERROR('RP3D-013: Error in proposing a new ray.')
C         A new ray, which should create a new basic triangle together
C         with the rays M and N lies on the line connecting the rays.
C         This error should not appear.
C         Please contact the author or try to
C         change the input data.
        ENDIF
      ENDIF
      IF (LIONPL) THEN
        LNEWAR=.FALSE.
      ELSE
        LNEWAR=.TRUE.
      ENDIF
C
      IF (.NOT.RPLRIT(.FALSE.,G1M,G2M,G1N,G2N,G1NEW,G2NEW,0.,0.,AAA))
     *    THEN
C       RP3D-030
        CALL ERROR('RP3D-030: Error in proposing a new ray.')
C       A new ray was proposed in such a way, that a left-handed
C       triangle was constructed.
C       This error should not appear.
C       Please contact the author or try to
C       change the input data.
      ENDIF
C     Adding new triangle and correcting polyline in the case that the
C     new ray is on polyline.
      IF ((LIONPL).AND.(IONPOL.NE.0)) THEN
        ITRI=ITRI+1
        KTRIN(1)=KPL(IRADD1)
        KTRIN(2)=KPL(IRADD2)
        KTRIN(3)=KPL(IONPOL)
        KTRIN(4)=ITRI
        KTRIN(5)=0
        KTRIN(6)=0
        CALL RPTRI1 (ITRI,KTRIN)
        IF ((IRADD1-IONPOL).GT.0) THEN
          DO 100, I1=1,(NPL-IRADD2+1)
            KPL(IONPOL+I1)=KPL(IRADD2+I1-1)
  100     CONTINUE
          NPL=NPL-(IRADD1-IONPOL)
        ELSE
          DO 110, I1=1,(NPL-IONPOL+1)
            KPL(IRADD1+I1)=KPL(IONPOL+I1-1)
  110     CONTINUE
          NPL=NPL-(IONPOL-IRADD2)
        ENDIF
      ENDIF
C
C     Adding new triangle and correcting polyline in the case that the
C     new ray is really the new one.
      IF (.NOT.LIONPL) THEN
        ITRI=ITRI+1
        KTRIN(1)=KPL(IRADD1)
        KTRIN(2)=KPL(IRADD2)
        KTRIN(3)=IRAY+1
        KTRIN(4)=ITRI
        KTRIN(5)=0
        KTRIN(6)=0
        CALL RPTRI1 (ITRI,KTRIN)
        IF (NPL.GE.MPL) CALL RPERR(10)
        NPL=NPL+1
        DO 120, I1=NPL,(IRADD2+1),-1
          KPL(I1)=KPL(I1-1)
  120   CONTINUE
        KPL(IRADD2)=IRAY+1
      ENDIF
C
C     Adding new triangle and correcting polyline in the case that the
C     new ray is a corner ray of domain.
      ICOR=0
      IF ((LIONPL).AND.(IONPOL.EQ.0)) THEN
        IF (G1NEW.EQ.GLIMIT(1)) THEN
          ICOR=3
        ELSE
          ICOR=4
        ENDIF
        ITRI=ITRI+1
        KTRIN(1)=KPL(IRADD1)
        KTRIN(2)=KPL(IRADD2)
        KTRIN(3)=ICOR
        KTRIN(4)=ITRI
        KTRIN(5)=0
        KTRIN(6)=0
        CALL RPTRI1 (ITRI,KTRIN)
        IF(NPL.GE.MPL) CALL RPERR(10)
        NPL=NPL+1
        DO 130, I1=NPL,(IRADD2+1),-1
          KPL(I1)=KPL(I1-1)
  130   CONTINUE
        KPL(IRADD2)=ICOR
      ENDIF
C
C     Correcting polyline in the case when the second and the third
C     polyline ray or the second and the third one from the end are
C     on the boundary of the normalized ray domain.
      IF (IRADD1.EQ.2) THEN
        IF (G1NEW.EQ.GLIMIT(1)) THEN
C         Correcting polyline:
          DO 142, I1=2,(NPL-1)
            KPL(I1)=KPL(I1+1)
  142     CONTINUE
          NPL=NPL-1
        ENDIF
      ENDIF
      IF (IRADD2.EQ.NPL0-1) THEN
C       NPL0 ... Value of NPL when calling subroutine RPWHAD.
        IF (G1NEW.EQ.GLIMIT(2)) THEN
          KPL(NPL-1)=KPL(NPL)
          NPL=NPL-1
        ENDIF
      ENDIF
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RPINTS(ISIGN,G1NEW,G2NEW,IRADD1,IRADD2,
     *                  LIONPL,IONPOL,LINTS)
C
C-----------------------------------------------------------------------
      INTEGER ISIGN,IRADD1,IRADD2,IONPOL
      REAL G1NEW,G2NEW
      LOGICAL LINTS,LIONPL
C Subroutine will test whether the abscissa
C  [ (ISIGN's ray on polyline) , (ray with parameters G1NEW,G2NEW) ]
C has intersection with some abscissa of polyline.
C If the intersection appears, the nearer ray is taken as the new one.
C Input:
C     ISIGN... Sequence (in KPL) of ray of tested abscissa.
C     G1NEW,G2NEW... New ray parameters proposed.
C     IRADD1,IRADD2... Sequence (in KPL) of two rays of polyline,
C             between them a new ray is to be added.
C     LIONPL... Indicates that the new ray is the IONPOL's ray on
C             polyline or that it is a corner ray of domain
C             (then IONPOL=0).
C     IONPOL... When as the new ray is taken some ray of the polyline,
C             the sequence (in KPL) of this ray on polyline;
C             when as the new ray is taken a corner ray of the
C             normalized domain, zero.
C Output:
C     LINTS... Indicates whether the intersection appeared.
C     LIONPL... Indicates that the new ray is the IONPOL's ray on
C             polyline or that it is a corner ray of domain
C             (then IONPOL=0).
C     IONPOL... When as the new ray is taken some ray of the polyline,
C             the sequence (in KPL) of this ray on polyline;
C             when as the new ray is taken a corner ray of the
C             normalized domain, zero.
C
C Coded by Petr Bulant
C
C.......................................................................
C Common block /POLY/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C.......................................................................
C
      REAL ZERO
      PARAMETER (ZERO =.0000001)
      INTEGER ITYPE,ISHEET
      REAL G1J,G2J,G11J,G12J,G22J,X1J,X2J
      REAL G1K,G2K,G11K,G12K,G22K,X1K,X2K
      REAL G1L,G2L,G11L,G12L,G22L,X1L,X2L
      REAL G1IO,G2IO,G11IO,G12IO,G22IO,X1IO,X2IO
      REAL G1IP,G2IP,G11IP,G12IP,G22IP,X1IP,X2IP
      REAL G1X1,G2X1,G1X2,G2X2
      REAL G1X,G2X
      INTEGER I1
      LOGICAL LRAY
C     ZERO... Constant used to decide whether the real variable.EQ.zero.
C     ITYPE... Type of ray:
C             0: .......... Basic ray.
C             ITYPE.GT.0:.. Boundary ray, ITYPE is the index of the
C                           boundary ray at the other side of the bound.
C             -2:.......... Auxiliary ray,not used.
C             -3:.......... Auxiliary ray,used.
C             -1000-I:..... Two-point ray (to the I'th receiver).
C     ISHEET... Value of integer function distinguishing between rays of
C             different histories.
C     G1.,G2.... Normalized parameters of rays.
C     G11.,G12.,G22.... Ray-parameter metric tensor.
C     X1.,X2.... Coordinates of the ray on the reference surface.
C     G1X1,G2X1,G1X2,G2X2... Derivations of ray parameters according to
C             surface coordinates.
C     I1...   Implied-do variable or variable controlling the loop.
C     LRAY... Indicates whether the ray IRAY is in memory.
C-----------------------------------------------------------------------
      DO 10, I1=1,NPL-1
        IF (I1.EQ.ISIGN-1) GOTO 10
        IF (I1.EQ.ISIGN) GOTO 10
        IF (LIONPL) THEN
          IF (I1.EQ.IONPOL) GOTO 10
          IF (I1.EQ.IONPOL-1) GOTO 10
        ENDIF
        CALL RPRAY(KPL(I1),LRAY,ITYPE,ISHEET,G1J,G2J,G11J,G12J,G22J,
     *             X1J,X2J,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(KPL(I1+1),LRAY,ITYPE,ISHEET,G1K,G2K,G11K,G12K,G22K,
     *             X1K,X2K,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(KPL(ISIGN),LRAY,ITYPE,ISHEET,G1L,G2L,
     *             G11L,G12L,G22L,X1L,X2L,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
C       ..J,..K ... The rays of tested polyline abscissa.
C       ..L     ... The ray of tested triangle abscissa.
C       ..IO,..IP ..The rays beside the polyline abscissa
C                   in which we are adding a new ray.
        CALL RPCROS(G1L,G2L,G1NEW,G2NEW,G1J,G2J,G1K,G2K,LINTS,G1X,G2X)
        IF (LINTS) GOTO 20
  10  CONTINUE
C     No intersection with polyline.
      LINTS=.FALSE.
      RETURN
  20  CONTINUE
C     Intersection with polyline between I1 and I1+1 polyline ray.
      IF (I1.LT.ISIGN) THEN
        IF (I1.EQ.ISIGN-1) THEN
          CALL RPRAY(KPL(IRADD1-1),LRAY,ITYPE,ISHEET,G1IO,G2IO,G11IO,
     *                     G12IO,G22IO,X1IO,X2IO,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          G1NEW=G1IO
          G2NEW=G2IO
          LIONPL=.TRUE.
          IONPOL=IRADD1-1
        ELSE
          G1NEW=G1J
          G2NEW=G2J
          LIONPL=.TRUE.
          IONPOL=I1
        ENDIF
      ELSE
        IF (I1.EQ.ISIGN+1) THEN
          CALL RPRAY(KPL(IRADD2+1),LRAY,ITYPE,ISHEET,G1IP,G2IP,G11IP,
     *                     G12IP,G22IP,X1IP,X2IP,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          G1NEW=G1IP
          G2NEW=G2IP
          LIONPL=.TRUE.
          IONPOL=IRADD2+1
        ELSE
          G1NEW=G1J
          G2NEW=G2J
          LIONPL=.TRUE.
          IONPOL=I1
        ENDIF
      ENDIF
      LINTS=.TRUE.
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RPWHAD(IRADD1,IRADD2)
C-----------------------------------------------------------------------
      INTEGER IRADD1,IRADD2
C Subroutine designed to determine two rays of polyline, suitable
C to add a new ray between them. The normalized ray domain is covered
C from G2MIN to G2MAX.
C
C No input.
C Output:
C     IRADD1,IRADD2... Sequence (in KPL) of two rays of polyline,
C             suitable to add a new ray between them.
C
C Coded by Petr Bulant
C
C.......................................................................
C
C Common blocks /GLIM/ and /POLY/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C.......................................................................
      INTEGER ITYPE,ISHEET
      REAL G1,G2,G11,G12,G22,X1,X2
      REAL G1J,G2J,G11J,G12J,G22J,X1J,X2J
      REAL G1K,G2K,G11K,G12K,G22K,X1K,X2K
      REAL G1X1,G2X1,G1X2,G2X2
      REAL MIN
      INTEGER I1
      LOGICAL LRAY
C     ITYPE... Type of ray:
C             0: .......... Basic ray.
C             ITYPE.GT.0:.. Boundary ray, ITYPE is the index of the
C                           boundary ray at the other side of the bound.
C             -2:.......... Auxiliary ray,not used.
C             -3:.......... Auxiliary ray,used.
C             -1000-I:..... Two-point ray (to the I'th receiver).
C     ISHEET... Value of integer function distinguishing between rays of
C             different histories.
C     G1,G2... Normalized parameters of rays.
C     G11,G12,G22... Ray-parameter metric tensor.
C     X1,X2... Coordinates of the ray on the reference surface.
C     G1X1,G2X1,G1X2,G2X2... Derivations of ray parameters according to
C             surface coordinates.
C     G1.,G2.,G11..,G12..,G22..,X1..,X2..,... Auxiliary variables.
C     MIN...  Minimum G2 of rays of polyline.
C     I1...   Implied-do variable or variable controlling the loop.
C     LRAY... Indicates whether the ray IRAY is in memory.
C-----------------------------------------------------------------------
C
C     First ray:
      IF (NPL.LT.2) THEN
C         RP3D-014
          CALL ERROR('RP3D-014: Error in adding a new ray.')
C         This error should not appear.
C         Please contact the author or try to
C         change the input data.
      ENDIF
      IRADD1=2
      MIN=GLIMIT(4)
      DO 10, I1=NPL-1,2,-1
        CALL RPRAY(KPL(I1),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        IF (G2.LE.MIN) THEN
          MIN=G2
          IRADD1=I1
        ENDIF
  10  CONTINUE
C
C     Second ray:
      IF (IRADD1.EQ.2) THEN
        CALL RPRAY(KPL(2),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        IF (G1.EQ.GLIMIT(1)) THEN
          IF (G2.EQ.GLIMIT(4)) THEN
            CALL RPRAY(KPL(NPL-1),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,
     *                 X1,X2,G1X1,G2X1,G1X2,G2X2)
            IF (.NOT.LRAY) CALL RPERR(1)
            IF (G1.EQ.GLIMIT(2)) THEN
              IRADD1=NPL-2
              IRADD2=NPL-1
            ELSE
              IRADD1=NPL-1
              IRADD2=NPL
            ENDIF
          ELSE
            IRADD2=3
          ENDIF
        ELSE
          IRADD1=1
          IRADD2=2
        ENDIF
        RETURN
      ENDIF
      IF (IRADD1.EQ.NPL-1) THEN
        CALL RPRAY(KPL(NPL-1),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        IF (G1.EQ.GLIMIT(2)) THEN
          IRADD1=NPL-2
          IRADD2=NPL-1
        ELSE
          IRADD2=NPL
        ENDIF
        RETURN
      ENDIF
      CALL RPRAY(KPL(IRADD1+1),LRAY,ITYPE,ISHEET,G1J,G2J,
     *           G11J,G12J,G22J,X1J,X2J,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KPL(IRADD1-1),LRAY,ITYPE,ISHEET,G1K,G2K,
     *           G11K,G12K,G22K,X1K,X2K,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      IF (G2J.LT.G2K) THEN
        IRADD2=IRADD1+1
      ELSE
        IRADD2=IRADD1
        IRADD1=IRADD2-1
      ENDIF
      END
C
C=======================================================================
C
      SUBROUTINE RPMEM(IRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,S11,S12,S22,
     *                 X1,X2,G1X1,G2X1,G1X2,G2X2)
C-----------------------------------------------------------------------
      INTEGER IRAY,ITYPE,ISHEET,ICRTB
      REAL G1,G2,G11,G12,G22,S11,S12,S22,X1,X2
      REAL G1X1,G2X1,G1X2,G2X2
C Subroutine designed to store the computed rays.
C Input:
C     IRAY... Sign of the stored ray.
C     ITYPE... Type of ray:
C             0: .......... Basic ray.
C             ITYPE.GT.0:.. Boundary ray, ITYPE is the index of the
C                           boundary ray at the other side of the bound.
C             -2:.......... Auxiliary ray,not used.
C             -3:.......... Auxiliary ray,used.
C             -1000-I:..... Two-point ray (to the I'th receiver).
C     ISHEET... Value of integer function distinguishing between rays of
C             different histories. Two rays with different histories
C             have different values of ISHEET. For instance, rays
C             refracted in different layers or incident at different
C             surfaces have different histories.
C     G1,G2... Normalized parameters of ray.
C     G11,G12,G22... Components of the ray-parameter
C             metric tensor.
C     S11,S12,S22... Components of the ray-tube metric tensor,
C             describing thickness of the ray tubes.
C     X1,X2... Coordinates of the ray on the reference surface.
C     G1X1,G2X1,G1X2,G2X2... Derivations of ray parameters according to
C             surface coordinates.
C No output.
C
C Subroutines and external functions required:
C
      EXTERNAL LENGTH
      INTEGER LENGTH
C
C Coded by Petr Bulant
C
C.......................................................................
C Common block /RPARD/:
      INCLUDE 'rpard.inc'
C     rpard.inc
C     XERR... Maximum distance of the two-point ray from the receiver
C             at the reference surface.
C     PRM0(5)... Maximum distance of the two-point ray from the receiver
C             at the reference surface, if no ray distant less than XERR
C             has been found.
C None of the storage locations of the common block are altered.
C............................
C Common block /RAY/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C............................
C Common block /NST/:
C     Common block storing the ray, which was nearest to the current
C     receiver. If a two-point ray to the receiver cannot be found,
C     this ray is taken instead of the two-point ray and a warning is
C     generated to the logout file.
      REAL DISNST
      LOGICAL LNST
      COMMON/NST/LNST,DISNST
      SAVE/NST/
C     DISNST... Distance of the ray from the receiver.
C     LNST... Indicates, that the nearest ray is to be taken
C             as a two-point ray.
C.......................................................................
      INTEGER IREC
      INTEGER INDRAY,IIRAY
      INTEGER ID
      INTEGER I1,I2,I3,I4,KALL
      REAL DIST2,DISNS
      LOGICAL LRAY
      CHARACTER*24  FORMAT
      CHARACTER*240 TXTERR
      SAVE I1,I2
C
C     IREC... If the two-point ray is being determined, index
C             of the corresponding receiver.
C     INDRAY... Sequence in KRAY of the given ray.
C     IIRAY... Absolute value of IRAY.
C     I1,I2... Implied-do variables or variables controlling the loop.
C     LRAY... Indicates whether the ray IRAY is in memory.
C-----------------------------------------------------------------------
C
      IF (IRAY.EQ.0) THEN
        NRAY=0
        IF ((PRM0(5).NE.0.).AND.(PRM0(5).LE.XERR)) THEN
C         RP3D-034
          CALL ERROR('RP3D-034: Wrong value of PRM0(5)')
C         PRM0(5), if specified, should be positive and greater
C         than XERR. See the description in file
C         rpar.for.
        ENDIF
      ELSE
        IF (ITYPE.LT.-1000) THEN
          IREC=-ITYPE-1000
          IF ((IREC.LT.1).OR.(IREC.GT.NREC)) THEN
C           RP3D-646
            CALL ERROR('RP3D-646: Wrong index of the receiver')
C           This error should not appear.
C           Please contact the author.
          ENDIF
          IF (LNST) THEN
            DISNS=SQRT(DISNST)
            IF ((PRM0(5).NE.0.).AND.(DISNS.GT.PRM0(5))) THEN
C               RP3D-035
                FORMAT='(A,1I0,A,1I0,A,1F15.6,A)'
                I4=INT(ALOG10(FLOAT(IRAY)))+1
                FORMAT(6:6)=CHAR(ICHAR('0')+I4)
                I4=INT(ALOG10(FLOAT(IREC)))+1
                FORMAT(12:12)=CHAR(ICHAR('0')+I4)
                CALL FORM1(DISNS,DISNS,FORMAT(17:24))
                FORMAT(24:24)=')'
                WRITE(TXTERR,FORMAT)
     *          ' RP3D-035: The ray with index ',IRAY,
     *          ' is nearest ray to the receiver ',IREC,
     *          ' but its distance ',DISNS,
     *          ' is greater than PRM0(5)'
                CALL WARN(TXTERR(1:LENGTH(TXTERR)))
C               The program failed to find a ray distant from the
C               receiver under consideration less then XERR. The nearest
C               found ray (distant DISNS from the receiver) is
C               distant more than PRM0(5) and thus cannot be taken
C               instead.
                ITYPE=-2
            ELSE
C             RP3D-031
                FORMAT='(A,1I0,A,1I0,A,1F15.6,A)'
                I4=INT(ALOG10(FLOAT(IRAY)))+1
                FORMAT(6:6)=CHAR(ICHAR('0')+I4)
                I4=INT(ALOG10(FLOAT(IREC)))+1
                FORMAT(12:12)=CHAR(ICHAR('0')+I4)
                CALL FORM1(DISNS,DISNS,FORMAT(17:24))
                FORMAT(24:24)=')'
                WRITE(TXTERR,FORMAT)
     *        ' RP3D-031: The two-point ray with index ',IRAY,
     *        ' to the receiver ',IREC,
     *        ' is distant ',DISNS,
     *        ' from the receiver'
              CALL WARN(TXTERR(1:LENGTH(TXTERR)))
C             The program failed to find a ray distant from the receiver
C             under consideration less then XERR. The nearest found ray
C             (distant DISNS from the receiver) was taken
C             instead.
            ENDIF
          ELSE
            IF (ISHEET.GT.0) THEN
C             Determination of two-point rays:
              DIST2=(X1-XREC(1,IREC))**2+(X2-XREC(2,IREC))**2
              IF (DIST2.GT.XERR**2) THEN
                ITYPE=-2
              ENDIF
            ELSE
              ITYPE=-2
            ENDIF
          ENDIF
        ENDIF
C
        IF(NRAY.GE.MRAY) THEN
C         RP3D-015
          CALL ERROR('RP3D-015: Insufficient memory for rays.')
C         This error may be caused by too small dimension of array
C         KRAY. Try to enlarge the parameter MRAY in common block RAY
C         in file rp3d.inc.
        ENDIF
        NRAY=NRAY+1
        KRAY(NRAY)=IRAY
        ITRAY(NRAY)=ITYPE
        ISRAY(NRAY)=ISHEET
        IBRAY(NRAY)=0
        G1RAY(NRAY)=G1
        G2RAY(NRAY)=G2
        X1RAY(NRAY)=X1
        X2RAY(NRAY)=X2
        G11RAY(NRAY)=G11
        G12RAY(NRAY)=G12
        G22RAY(NRAY)=G22
        S11RAY(NRAY)=S11
        S12RAY(NRAY)=S12
        S22RAY(NRAY)=S22
        G1X1RA(NRAY)=G1X1
        G1X2RA(NRAY)=G1X2
        G2X1RA(NRAY)=G2X1
        G2X2RA(NRAY)=G2X2
      ENDIF
      RETURN
C
C-----------------------------------------------------------------------
C
      ENTRY RPMC1(IRAY,ITYPE)
      KALL=1
      GOTO 5
C.......................................................................
      ENTRY RPMC2(IRAY,ICRTB)
      KALL=2
C.......................................................................
  5   CONTINUE
C
C-----------------------------------------------------------------------
C     Entry designed to change value ITYPE
C     for ray with sign IRAY.
C Input:
C     IRAY... Sign of the ray which is to be changed.
C     ITYPE... Type of ray.
C     ICRTB... Identification, whether the ray has been written to the
C             file 'CRT-B'.
C No output.
C-----------------------------------------------------------------------
      I2=MAX0(2,NRAY-KRAY(NRAY)+IRAY)
      DO 1, I1=I2,I2-1,-1
        IF(KRAY(I1).EQ.IRAY) THEN
          INDRAY=I1
          GOTO 10
        ENDIF
  1   CONTINUE
      DO 2, I1=I2+1,NRAY
        IF(KRAY(I1).EQ.IRAY) THEN
          INDRAY=I1
          GOTO 10
        ENDIF
  2   CONTINUE
      DO 3, I1=I2-2,1,-1
        IF(KRAY(I1).EQ.IRAY) THEN
          INDRAY=I1
          GOTO 10
        ENDIF
  3   CONTINUE
      CALL RPERR(1)
C
  10  CONTINUE
      IF (KALL.EQ.1) ITRAY(INDRAY)=ITYPE
      IF (KALL.EQ.2) IBRAY(INDRAY)=ICRTB
      RETURN
C
C-----------------------------------------------------------------------
C
      ENTRY RPRAY (IRAY,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,
     *             X1,X2,G1X1,G2X1,G1X2,G2X2)
      KALL=1
      GOTO 11
C.......................................................................
      ENTRY RPRAY2(IRAY,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,
     *             S11,S12,S22,X1,X2,G1X1,G2X1,G1X2,G2X2)
      KALL=2
      GOTO 11
C.......................................................................
      ENTRY RPRAY3(IRAY,LRAY,ITYPE,ISHEET,ICRTB,G1,G2,G11,G12,G22,
     *             X1,X2,G1X1,G2X1,G1X2,G2X2)
C.......................................................................
      KALL=3
  11  CONTINUE
C
C-----------------------------------------------------------------------
C
C Entry designed to give all information about ray with sign IRAY
C or to remove the ray from the memory (if IRAY is negative).
C Input:
C     IRAY... Index of the ray.
C Output:
C     LRAY... Identifies whether the ray has been found in the memory.
C     ITYPE... Type of ray:
C             0:.......... Basic ray.
C             ITYPE.GT.0:. Boundary ray, ITYPE is the index of the
C                          boundary ray at the other side of the
C                          boundary.
C             -2:........  Auxiliary ray,not used.
C             -3:........  Auxiliary ray,used.
C             -1000-I:...  Two-point ray.
C     ISHEET... Value of integer function distinguishing between rays of
C             different histories.  Two rays with different histories
C             have different values of ISHEET.  For instance, rays
C             refracted in different layers or incident at different
C             surfaces have different histories.
C     ICRTB... Identification, whether the ray has been written to CRT-B.
C     G1,G2... Normalized parameters of ray.
C     G11,G12,G22... Components of the ray-parameter metric tensor.
C     S11,S12,S22... Components of the ray-tube metric tensor.
C     X1,X2... Coordinates of the ray on the ref. surface.
C     G1X1,G2X1,G1X2,G2X2... Derivations of ray parameters according to
C             surface coordinates.
C-----------------------------------------------------------------------
C
      IIRAY=IABS(IRAY)
      I1=1
      I2=NRAY
C     The ray is being searched for within interval I1,I2.
   15 CONTINUE
        I3=I2-KRAY(I2)+IIRAY
        IF(I3.EQ.I2) THEN
          INDRAY=I2
          GOTO 20
        ELSE IF(I3.GT.I2) THEN
          LRAY=.FALSE.
          RETURN
        ELSE
          I2=I2-1
          IF(I3.GT.I1) THEN
            I1=I3
          ENDIF
        ENDIF
C
        I3=I1-KRAY(I1)+IIRAY
        IF(I3.EQ.I1) THEN
          INDRAY=I1
          GOTO 20
        ELSE IF(I3.LT.I1) THEN
          LRAY=.FALSE.
          RETURN
        ELSE
          I1=I1+1
          IF(I3.LT.I2) THEN
            I2=I3
          ENDIF
        ENDIF
C
        IF(I1.LT.I2) THEN
          I3=(I1+I2)/2
          IF(KRAY(I3).EQ.IIRAY) THEN
            INDRAY=I3
            GOTO 20
          ELSE IF(KRAY(I3).LT.IIRAY) THEN
            I1=I3+1
          ELSE
            I2=I3-1
          ENDIF
        ENDIF
C
        IF(I1.GT.I2) THEN
          LRAY=.FALSE.
          RETURN
        ENDIF
       GOTO 15
C
   20 CONTINUE
      LRAY=.TRUE.
      IF(IRAY.GT.0) THEN
        ITYPE =ITRAY(INDRAY)
        ISHEET=ISRAY(INDRAY)
        IF (KALL.EQ.3) THEN
          ICRTB =IBRAY(INDRAY)
        ENDIF
        G1    =G1RAY(INDRAY)
        G2    =G2RAY(INDRAY)
        X1    =X1RAY(INDRAY)
        X2    =X2RAY(INDRAY)
        G11   =G11RAY(INDRAY)
        G12   =G12RAY(INDRAY)
        G22   =G22RAY(INDRAY)
        IF (KALL.EQ.2) THEN
          S11   =S11RAY(INDRAY)
          S12   =S12RAY(INDRAY)
          S22   =S22RAY(INDRAY)
        ENDIF
        G1X1  =G1X1RA(INDRAY)
        G1X2  =G1X2RA(INDRAY)
        G2X1  =G2X1RA(INDRAY)
        G2X2  =G2X2RA(INDRAY)
      ELSE
C       Removing the ray from the memory:
        IF (IRAY.GE.-4) THEN
          RETURN
        END IF
        NRAY=NRAY-1
        DO 21, I1=INDRAY,NRAY
          I2=I1+1
          KRAY(I1)  =KRAY(I2)
          ITRAY(I1) =ITRAY(I2)
          ISRAY(I1) =ISRAY(I2)
          IBRAY(I1) =IBRAY(I2)
          G1RAY(I1) =G1RAY(I2)
          G2RAY(I1) =G2RAY(I2)
          X1RAY(I1) =X1RAY(I2)
          X2RAY(I1) =X2RAY(I2)
          G11RAY(I1)=G11RAY(I2)
          G12RAY(I1)=G12RAY(I2)
          G22RAY(I1)=G22RAY(I2)
          S11RAY(I1)=S11RAY(I2)
          S12RAY(I1)=S12RAY(I2)
          S22RAY(I1)=S22RAY(I2)
          G1X1RA(I1)=G1X1RA(I2)
          G1X2RA(I1)=G1X2RA(I2)
          G2X1RA(I1)=G2X1RA(I2)
          G2X2RA(I1)=G2X2RA(I2)
   21   CONTINUE
      ENDIF
      RETURN
C
C-----------------------------------------------------------------------
C
      ENTRY RPRAYP(ID,LRAY,IRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,
     *             X1,X2,G1X1,G2X1,G1X2,G2X2)
C
C-----------------------------------------------------------------------
C
C Entry designed to give consequently an information about all the rays
C stored in the memory.
C Input:
C     ID:     ID.NE.0... Initialization of the listing:
C               ID.GT.0... The listing is started from the ID's ray
C                 stored in the memory going up.
C               ID.LT.0... The listing is started from the (IABS(ID))'s
C                 ray stored in the memory going down.
C               No output when ID.NE.0.
C             ID.EQ.0... Next ray.
C Output:
C     LRAY... Identifies whether some ray has been found in the memory.
C     IRAY,ITYPE,ISHEET,G1,...,G2X2... Information about the ray.
C-----------------------------------------------------------------------
      IF (ID.EQ.0) THEN
        I1=I1+I2
      ELSEIF (ID.GT.0) THEN
        I1=ID-1
        I2= 1
      ELSE
        I1=MIN0(NRAY,-ID)+1
        I2=-1
      ENDIF
      IF ((I1.LT.1).OR.(I1.GT.NRAY)) THEN
        LRAY=.FALSE.
      ELSE
        IRAY  =KRAY  (I1)
        ITYPE =ITRAY (I1)
        ISHEET=ISRAY (I1)
        G1    =G1RAY (I1)
        G2    =G2RAY (I1)
        X1    =X1RAY (I1)
        X2    =X2RAY (I1)
        G11   =G11RAY(I1)
        G12   =G12RAY(I1)
        G22   =G22RAY(I1)
        G1X1  =G1X1RA(I1)
        G1X2  =G1X2RA(I1)
        G2X1  =G2X1RA(I1)
        G2X2  =G2X2RA(I1)
        LRAY=.TRUE.
      ENDIF
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RPTRI1(ITRI,KTRIL)
C
C-----------------------------------------------------------------------
      INTEGER ITRI,KTRIL(6)
C Subroutine designed to store triangles.
C Input:
C     ITRI... Index of the stored triangle.
C     KTRIL... All parameters of the triangle which will be stored.
C No output.
C
C Subroutines and external functions required:
C
C Coded by Petr Bulant
C
C.......................................................................
C Common block /TRIAN/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C ...........................
      INTEGER ITRIA,INDTRI
      INTEGER ITYPE,ISHEET
      REAL G1,G2,G11,G12,G22,X1,X2
      REAL G1X1,G2X1,G1X2,G2X2
      INTEGER I1,I2,I3,J1
      INTEGER ID
      LOGICAL LTRI
      LOGICAL LRAY
      SAVE I1,I2
C     ITRIA... Absolute value of ITRI.
C     INDTRI... Sequence in KTRI of the triangle with index ITRIA.
C     ITYPE... Type of ray:
C             0: .......... Basic ray.
C             ITYPE.GT.0:.. Boundary ray, ITYPE is the index of the
C                           boundary ray at the other side of the bound.
C             -2:.......... Auxiliary ray,not used.
C             -3:.......... Auxiliary ray,used.
C             -1000-I:..... Two-point ray (to the I'th receiver).
C     ISHEET... Value of integer function distinguishing between rays of
C             different histories.
C     G1,G2... Normalized parameters of rays.
C     G11,G12,G22... Ray-parameter metric tensor.
C     X1,X2... Coordinates of the ray on the reference surface.
C     G1X1,G2X1,G1X2,G2X2... Derivations of ray parameters according to
C             surface coordinates.
C     I1,I2... Implied-do variables or variables controlling the loop.
C     J1...   Auxiliary variable (number).
C     LTRI... Indicates whether the triangle ITRI is in memory.
C     LRAY... Indicates whether the ray IRAY is in memory.
C-----------------------------------------------------------------------
      IF (ITRI.EQ.0) THEN
C       Initialization:
        NTRI=0
        RETURN
      ENDIF
      IF (KTRIL(6).EQ.3) THEN
        CALL RPRAY(KTRIL(1),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        IF (ISHEET.GT.0)  CALL RPAUX1(ITRI,0)
      ENDIF
C
      IF (NTRI.GE.MTRI) THEN
C       RP3D-016
        CALL ERROR('RP3D-016: Insufficient memory for triangles.')
C       This error may be caused by too small dimension of array
C       KTRI. Try to enlarge the parameter MTRI in common block TRIAN
C       in file rp3d.inc.
      ENDIF
      NTRI=NTRI+1
      DO 10, I1=1,6
        KTRI(I1,NTRI)=KTRIL(I1)
  10  CONTINUE
      RETURN
C
C-----------------------------------------------------------------------
C
      ENTRY RPTRI2(ITRI,LTRI,KTRIL)
C
C-----------------------------------------------------------------------
C Entry designed to change values (in array KTRI) for triangle
C with sign ITRI.
C Input:
C     ITRI... Index of the triangle which is to be changed.
C     KTRIL... All parameters of this triangle.
C Output:
C     LTRI... Indicates whether the triangle ITRI is in memory.
C-----------------------------------------------------------------------
C
      CALL RPSTOR('T',1,KTRIL)
      J1=MAX0(2,NTRI-KTRI(4,NTRI)+ITRI)
      DO 11, I1=J1,J1-1,-1
        IF(KTRI(4,I1).EQ.ITRI) THEN
          INDTRI=I1
          GOTO 20
        ENDIF
  11   CONTINUE
      DO 12, I1=J1+1,NTRI
        IF(KTRI(4,I1).EQ.ITRI) THEN
          INDTRI=I1
          GOTO 20
        ENDIF
  12   CONTINUE
      DO 13, I1=J1-2,1,-1
        IF(KTRI(4,I1).EQ.ITRI) THEN
          INDTRI=I1
          GOTO 20
        ENDIF
  13   CONTINUE
      LTRI=.FALSE.
      RETURN
C
  20  CONTINUE
      DO 25, I1=1,6
        KTRI(I1,INDTRI)=KTRIL(I1)
  25  CONTINUE
      IF (KTRIL(6).EQ.3) THEN
        CALL RPRAY(KTRIL(1),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        IF (ISHEET.GT.0)  CALL RPAUX1(ITRI,0)
      ENDIF
      LTRI=.TRUE.
      RETURN
C
C-----------------------------------------------------------------------
C
      ENTRY RPTRI3(ITRI,LTRI,KTRIL)
C
C-----------------------------------------------------------------------
C
C Entry designed to give all information about triangle with sign ITRI
C or to remove the triangle from the memory (when ITRI is negative).
C Input:
C     ITRI... Index of the triangle.
C Output:
C     LTRI... Indicates whether the triangle ITRI is in memory.
C     KTRIL... All parameters of the triangle with index ITRI.
C-----------------------------------------------------------------------
C
      IF (NTRI.LE.0) THEN
        LTRI=.FALSE.
        RETURN
      ENDIF
      ITRIA=IABS(ITRI)
      J1=MAX0(2,NTRI-KTRI(4,NTRI)+ITRIA)
      DO 31, I1=J1,J1-1,-1
        IF(KTRI(4,I1).EQ.ITRIA) THEN
          INDTRI=I1
          GOTO 40
        ENDIF
  31  CONTINUE
      DO 32, I1=J1+1,NTRI
        IF(KTRI(4,I1).EQ.ITRIA) THEN
          INDTRI=I1
          GOTO 40
        ENDIF
  32  CONTINUE
      DO 33, I1=J1-2,1,-1
        IF(KTRI(4,I1).EQ.ITRIA) THEN
          INDTRI=I1
          GOTO 40
        ENDIF
  33  CONTINUE
      LTRI=.FALSE.
      RETURN
C
  40  CONTINUE
      IF (ITRI.GT.0) THEN
        DO 45, I1=1,6
          KTRIL(I1)=KTRI(I1,INDTRI)
  45    CONTINUE
        LTRI=.TRUE.
        RETURN
      ELSE
C       Removing the triangle from the memory:
        J1=MIN0(NTRI,MTRI-1)
        DO 100, I1=INDTRI,J1
          DO 95, I2=1,6
            KTRI(I2,I1)=KTRI(I2,I1+1)
  95      CONTINUE
  100   CONTINUE
        NTRI=NTRI-1
      ENDIF
C
C-----------------------------------------------------------------------
C
      ENTRY RPTRIP(ID,LTRI,KTRIL)
C
C-----------------------------------------------------------------------
C
C Entry designed to give consequently all information about all the
C triangles stored in the memory.
C Input:
C     ID:     ID.NE.0... Initialization of the listing:
C               ID.GT.0... The listing is started from the ID's triangle
C                 stored in the memory going up.
C               ID.LT.0 .. The listing is started from the (IABS(ID))'s
C                 triangle stored in the memory going down.
C               No output when ID.NE.0.
C             ID.EQ.0... Next triangle.
C Output:
C     LTRI... Identifies whether some triangle has been found in memory.
C     KTRIL... Information about the triangle.
C-----------------------------------------------------------------------
      IF (ID.EQ.0) THEN
        I1=I1+I2
      ELSEIF (ID.GT.0) THEN
        I1=ID-1
        I2= 1
      ELSE
        I1=MIN0(NTRI,-ID)+1
        I2=-1
      ENDIF
      IF ((I1.LT.1).OR.(I1.GT.NTRI)) THEN
        LTRI=.FALSE.
      ELSE
        DO 55, I3=1,6
          KTRIL(I3)=KTRI(I3,I1)
  55    CONTINUE
        LTRI=.TRUE.
      ENDIF
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RPAUX1(ITRI,IRAY)
C
C-----------------------------------------------------------------------
      INTEGER ITRI,IRAY
C Subroutine designed to store auxiliary rays according to triangles,
C where they most probably start and terminate, to delete ray from the
C register or to remove triangle from the register.
C In current version only the vertices of homogeneous triangles
C and found two-point rays are stored.
C Input:
C     ITRI... Index of the triangle in which the ray most probably
C             terminates, or of a new triangle. ITRI=0 when erasing
C             auxiliary ray IRAY from register. ITRI .LT. 0 when
C             deleting triangle from register.
C     IRAY... IRAY=0 if a new triangle has been created,
C             otherwise IRAY is the index of an auxiliary ray.
C No output.
C
C Subroutines and external functions required:
C
C Coded by Petr Bulant
C
C.......................................................................
C     Common block /AUX/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C
C............................
      INTEGER ISEQ
      INTEGER ITYPE,ISHEET
      REAL G1,G2,G11,G12,G22,X1,X2
      REAL G1X1,G2X1,G1X2,G2X2
      INTEGER I1,I2
      INTEGER J1,J2
      LOGICAL LRAY
      INTEGER KTRIS(6)
C
C     MARAY... Maximum number of auxiliary rays in memory
C             (dimension of array KARAY).
C     NARAY... Number of auxiliary rays in memory.
C     KARAY... List of triangle indices,numbers of auxiliary rays and
C             indices of auxiliary rays.
C     ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2... All parameters of ray.
C     G1X1,G2X1,G1X2,G2X2... Derivations of ray parameters according to
C             surface coordinates.
C     I1,I2... Implied-do variables or variables controlling the loop.
C     J1,J2... Auxiliary variables (numbers).
C     LRAY... Indicates whether the ray IRAY is in memory.
C     KTRIS... Not used here.
C-----------------------------------------------------------------------
C
      IF (ITRI.EQ.0) THEN
        IF (IRAY.EQ.0) THEN
C         Initialization:
          NARAY=0
          RETURN
        ENDIF
C       Removing the ray from register of auxiliary rays:
        IF (NARAY.LE.0) RETURN
        J1=2
  5     DO 7, I1=1,KARAY(J1)
          IF (KARAY(J1+I1).EQ.IRAY) THEN
            KARAY(J1)=KARAY(J1)-1
            NARAY=NARAY-1
            DO 8, I2=J1+I1,NARAY
              KARAY(I2)=KARAY(I2+1)
  8         CONTINUE
            GOTO 5
          ENDIF
  7     CONTINUE
        J1=J1+KARAY(J1)+2
        IF (J1.GE.NARAY) RETURN
        GOTO 5
      ELSEIF (ITRI.LT.0) THEN
C       Removing the triangle from the register:
        IF (NARAY.LE.0) RETURN
        J1=1
  9     IF (KARAY(J1).EQ.(-ITRI)) THEN
          J2=KARAY(J1+1) + 2
          DO 11, I1=J1,NARAY-J2
            KARAY(I1)=KARAY(I1+J2)
  11      CONTINUE
          NARAY=NARAY-J2
          IF (J1.LT.NARAY) GOTO 9
        ELSE
          J2=KARAY(J1+1)
          J1=J1+2+J2
          IF (J1.LT.NARAY) GOTO 9
        ENDIF
        RETURN
      ELSE
        IF (IRAY.EQ.0) THEN
          IF (NARAY.GE.MARAY-1) THEN
C           RP3D-017
            CALL ERROR('RP3D-017: Insufficient memory for KARAY.')
C           This error may be caused by too small dimension of array
C           KARAY. Try to enlarge the parameter MARAY in common block
C           AUX in file
C           rp3d.inc.
          ENDIF
          NARAY=NARAY+1
          KARAY(NARAY)=ITRI
          NARAY=NARAY+1
          KARAY(NARAY)=0
          RETURN
        ELSE
          J1=1
  10      IF (KARAY(J1).EQ.ITRI) THEN
            IF (NARAY.GE.MARAY) THEN
C             RP3D-018
              CALL ERROR('RP3D-018: Insufficient memory for KARAY.')
C             This error may be caused by too small dimension of array
C             KARAY. Try to enlarge the parameter MARAY in common block
C             AUX in file
C             rp3d.inc.
            ENDIF
            NARAY=NARAY+1
            DO 20, I2=NARAY,J1+3,-1
              KARAY(I2)=KARAY(I2-1)
  20        CONTINUE
            KARAY(J1+2)=IRAY
            KARAY(J1+1)=KARAY(J1+1)+1
C           Noting that auxiliary ray has been used:
            CALL RPRAY(IRAY,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *                 G1X1,G2X1,G1X2,G2X2)
            IF (.NOT.LRAY) CALL RPERR(1)
            IF (ITYPE.EQ.-2) THEN
              CALL RPMC1(IRAY,-3)
              CALL RPSTOR('R',IRAY,KTRIS)
            ENDIF
            RETURN
          ELSE
            J2=KARAY(J1+1)
            J1=J1+2+J2
            IF (J1.GE.NARAY) THEN
C             RP3D-019
              CALL ERROR('RP3D-019: Error in RPAUX.')
C             This error should not appear.
C             Please contact the author or try to
C             change the input data.
            ENDIF
            GOTO 10
          ENDIF
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C
      ENTRY RPAUX2(ITRI,ISEQ,IRAY)
C
C-----------------------------------------------------------------------
C Entry designed to give the number of auxiliary rays terminating in
C triangle ITRI, or to give the index of the ISEQ-th auxiliary ray
C terminating in triangle ITRI, or to indicate, whether the ray IRAY is
C in register.
C Input:
C     ITRI... Index of a triangle or zero (when we are asking whether
C             the ray IRAY is in register).
C     ISEQ... Zero or the sequential index of a ray within triangle
C             ITRI.
C     IRAY... For ITRI=0: sign of the ray.
C Output:
C     ITRI... Zero if ray is not in register,otherwise index of triangle
C     IRAY... For ISEQ=0: Number of auxiliary rays terminating in
C               triangle ITRI.
C             For ISEQ.GT.0: Index of the ISEQ-th auxiliary ray
C               terminating in triangle ITRI, IRAY=0 if the
C               number of auxiliary rays terminating in
C               triangle ITRI is .LT. ISEQ.
C             FOR ITRI=0: Sign of the ray.
C-----------------------------------------------------------------------
C
      IF (ITRI.EQ.0) THEN
        J1=2
  21    DO 22, I1=1,KARAY(J1)
          IF (KARAY(J1+I1).EQ.IRAY) THEN
            ITRI=KARAY(J1-1)
            RETURN
          ENDIF
  22    CONTINUE
        J1=J1+KARAY(J1)+2
        IF (J1.LT.NARAY) GOTO 21
        RETURN
      ENDIF
      J1=1
  30  IF (KARAY(J1).EQ.ITRI) THEN
        IF (ISEQ.EQ.0) THEN
          IRAY=KARAY(J1+1)
          RETURN
        ELSEIF (ISEQ.GT.KARAY(J1+1)) THEN
          IRAY=0
          RETURN
        ELSE
          IRAY=KARAY(J1+1+ISEQ)
          RETURN
        ENDIF
      ELSE
        J2=KARAY(J1+1)
        J1=J1+2+J2
        IF ((J1.GE.NARAY).AND.(ISEQ.EQ.0)) THEN
          IRAY=0
          RETURN
        ENDIF
        IF (J1.GE.NARAY) THEN
C         RP3D-020
          CALL ERROR('RP3D-020: Error in RPAUX.')
C         This error should not appear.
C         Please contact the author or try to
C         change the input data.
        ENDIF
        GOTO 30
      ENDIF
      END
C
C=======================================================================
C
      SUBROUTINE RPINTP(KTRIS,LNEWAR,IRAY,ITRI,LEND,
     *                  G1NEW,G2NEW,ITRNAR,ITYPEN)
C
C-----------------------------------------------------------------------
C Subroutine designed to search for two-point ray(s) inside homogeneous
C triangle with receiver(s) in its reference surface projection.
C Homogeneous triangle formed by not successful rays or without
C receivers in its reference surface projection will be marked as
C searched (type 4), as well as the triangle with all the two-point rays
C identified.
C Only the rays traced on request of RPINTP may be marked as
C two-point rays, thus any ray cannot be two-point ray for two or more
C receivers, and any basic or other ray cannot be later signed as
C two-point ray.
      INTEGER KTRIS(6),IRAY,ITRI,ITRNAR,ITYPEN
      REAL G1NEW,G2NEW
      LOGICAL LNEWAR,LEND
C Input:
C     KTRIS... One column from KTRI (all parameters of the triangle
C             where we are searching for two-point rays).
C     LNEWAR... Indicates whether the new auxiliary ray have been computed
C     IRAY... Index of last computed ray.
C     ITRI... Index of last triangle.
C     LEND... Indicates the end of the computation (all the normalized
C             ray domain covered by basic triangles).
C     ITRNAR... Unchanged output value from previous invocation,
C             if the new auxiliary ray was traced. Otherwise undefined.
C Output:
C     LNEWAR... Indicates whether the new auxiliary ray is to be computed.
C     G1NEW,G2NEW... Normalized ray parameters of the new ray.
C     ITYPEN... ITYPE of the new ray. For all new rays ITYPEN at first
C             equals -1000-IREC, ray tracer then computes the ray,
C             and RPMEM then makes decision whether the
C             ray is two-point ray and sets final ITYPE.
C     ITRNAR... Index of the triangle containing the new auxiliary ray,
C             which will be actually traced.
C
C Subroutines and external functions required:
      EXTERNAL RPLRIT,LENGTH,RPDI2L
      INTEGER LENGTH
      REAL RPDI2L
      LOGICAL RPLRIT
C
C Coded by Petr Bulant
C
C.......................................................................
C
C Common blocks /GLIM/, /BOURA/ and /POLY/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C............................
C
C Common block /RPARD/:
      INCLUDE 'rpard.inc'
C     rpard.inc
C     NREC... Number of receivers.
C     XREC... Receiver surface coordinates (x-coordinates along the
C             reference surface).
C     XERR... Maximum distance of the two-point ray from the receiver
C             at the reference surface.
C     AERR... Maximum distance of the boundary rays.
C None of the storage locations of the common block are altered.
C............................
C Common block /NST/:
C     Common block storing the ray, which was nearest to the current
C     receiver. If a two-point ray to the receiver cannot be found,
C     this ray is taken instead of the two-point ray and a warning is
C     generated to the logout file.
      REAL DISNST,G1NST,G2NST
      LOGICAL LNST
      COMMON/NST/LNST,DISNST
      SAVE/NST/
      SAVE G1NST,G2NST
C     G1NST,G2NST... Parameters of a ray, which was nearest to the
C             receiver being examined.
C     DISNST... Distance of the ray from the receiver; DISNST=-1.
C             indicates, that there is any nearest ray.
C     LNST... Indicates, that the nearest ray is to be taken
C             as a two-point ray in subroutine RPMEM.
C.......................................................................
C
      REAL ZERO,ZERO1
      PARAMETER (ZERO =.0000001)
      PARAMETER (ZERO1=.0000000001)
      INTEGER MTRIN
      PARAMETER (MTRIN=500)
      REAL VTRI(4,3),VTRIN(0:MTRIN,4,3)
      INTEGER NTRIN,INTRIN(0:MTRIN),KTRIN(0:MTRIN,3),ITTRIN(0:MTRIN,3)
      INTEGER MNOT
      PARAMETER (MNOT=20)
      INTEGER INOT,KNOT(MNOT)
      INTEGER IREC
      INTEGER INTERS,ISTART
      INTEGER NEAR1,NEAR2,NEAR3,INEAR
      INTEGER ITRIP,KTRIT(6)
      INTEGER ITYPE,ISHEET,ISH,ISHP
      INTEGER ITYPS(3),ICRTB(3),IB1,IB2,IB3,IB4,IBN
      REAL G1,G2,G11,G12,G22,X1,X2
      REAL G1X1,G2X1,G1X2,G2X2
      INTEGER ISHA
      REAL G1A,G2A,G1B,G2B,G1C,G2C
      REAL X1MIN,X1MAX,X2MIN,X2MAX
      REAL DG1,DG2,DX1,DX2
      REAL DIST1,DIST2
      REAL AREA,AREA1,AREA2,AREA3
      INTEGER I1,I2,I3,I4,I5,I6,I7,I8
      INTEGER J1,J2
      CHARACTER*14  FORMAT
      CHARACTER*240 TXTERR
      LOGICAL LTRI,LRAY,LINTS,LDISTG
      SAVE VTRI,VTRIN,NTRIN,INTRIN,KTRIN,ITTRIN,INOT,KNOT,IREC,
     *  ISTART,NEAR1,NEAR2,NEAR3,INEAR,ITRIP,X1MIN,X1MAX,X2MIN,X2MAX,
     *  DIST1,DG1,DG2,LDISTG
C     ZERO... Constant used to decide whether the real variable .EQ. 0.
C     MTRIN... Maximum number of neighbouring triangles.
C     VTRI ...Vertices of triangle ITRIP:
C               VTRI(1,I) ... G1 of ray I   (I=1,2,3)
C               VTRI(2,I) ... G2 of ray I
C               VTRI(3,I) ... X1 of ray I
C               VTRI(4,I) ... X2 of ray I
C     VTRIN(J, )... Parameters of the vertices of J-th
C             neighbouring triangle:
C               VTRIN(J,1,I) ... G1 of ray I   (I=1,2,3)
C               VTRIN(J,2,I) ... G2 of ray I
C               VTRIN(J,3,I) ... X1 of ray I
C               VTRIN(J,4,I) ... X2 of ray I
C     KTRIN(J,I)... Indices of the vertices of J-th
C             neighbouring triangle (I=1,2,3).
C     ITTRIN(J,I)... Types of the vertices of J-th
C             neighbouring triangle.
C     NTRIN... Number of neighbouring triangles.
C     INTRIN... Indices of neighbouring triangles.
C     MNOT,INOT,KNOT... Indices of the rays not suitable for
C             interpolation to actual receiver.
C     IREC... Index of the receiver we are searching for.
C     INTERS... Counts intersection points.
C     ISTART... Counts from which nearest ray we start the interpolation.
C     INEAR... Number of rays to start interpolation.
C     NEAR1,2,3... Signs of the rays nearest to the receiver.
C             Interpolation is started from these rays.
C     ITRIP... Index of processed triangle.
C     KTRIT... One column from KTRI (all parameters of the triangle
C             which we are testing).
C     ITYPE,ISHEET,ISH,G1,G2,G11,G12,G22,X1,X2... All parameters of ray.
C     G1X1,G2X1,G1X2,G2X2... Derivatives.
C     ISHA,GIA,B,C... Auxiliary variables.
C     X1MIN,X1MAX,X2MIN,X2MAX... Extremes of X1,X2 of triangle ITRIP.
C     DG1,DG2,DX1,DX2... Differences.
C     DIST1,2... (Distances of rays)**2
C     AREA1,2,3... Auxiliary variables used when examining whether the
C             ray lies in triangle.
C     I1,2,3... Implied-do variables or variables controlling the loop.
C     J1,2,3... Auxiliary variables (numbers).
C     LTRI... Indicates whether the triangle ITRI is in memory.
C     LRAY... Indicates whether the ray IRAY is in memory.
C     LINTS... Indicates whether the intersection appeared.
C     LDISTG... Indicates that the distance was greater in interpolating
C             and the last ray was proposed as G1+DG1/2.
C-----------------------------------------------------------------------
C
      IF (LNEWAR) GOTO 50
      ITRIP=KTRIS(4)
      CALL RPRAY3(KTRIS(1),LRAY,ITYPS(1),ISHP,ICRTB(1),VTRI(1,1),
     *  VTRI(2,1),G11,G12,G22,VTRI(3,1),VTRI(4,1),G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY3(KTRIS(2),LRAY,ITYPS(2),ISHEET,ICRTB(2),VTRI(1,2),
     *  VTRI(2,2),G11,G12,G22,VTRI(3,2),VTRI(4,2),G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY3(KTRIS(3),LRAY,ITYPS(3),ISHEET,ICRTB(3),VTRI(1,3),
     *  VTRI(2,3),G11,G12,G22,VTRI(3,3),VTRI(4,3),G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
C
C     Triangles by the boundary of covered part of the ray domain:
      IF (.NOT.LEND) THEN
        DO 2, I2=1,NPL
          IF ((KTRIS(1).EQ.KPL(I2)).OR.
     *        (KTRIS(2).EQ.KPL(I2)).OR.
     *        (KTRIS(3).EQ.KPL(I2))) RETURN
  2     CONTINUE
        J1=0
        IF (NBR.GT.2) THEN
  4     CONTINUE
          DO 6, I2=J1+4,J1+3+KBR(J1+3,1)
            IF ((KTRIS(1).EQ.KBR(I2,1)).OR.
     *          (KTRIS(2).EQ.KBR(I2,1)).OR.
     *          (KTRIS(3).EQ.KBR(I2,1))) RETURN
  6       CONTINUE
          J1=J1+KBR(J1+3,1)+3
        IF (J1.LT.NBR) GOTO 4
        ENDIF
      ENDIF
C
C     Recording the triangle to the file CRT-T:
      CALL WRITTR(KTRIS(1),KTRIS(2),KTRIS(3))
C
      IF ((ISHP.LT.0).AND.
     *    (.NOT.(((ITYPS(1).GT.0).AND.(ICRTB(1).EQ.0)).OR.
     *           ((ITYPS(2).GT.0).AND.(ICRTB(2).EQ.0)).OR.
     *           ((ITYPS(3).GT.0).AND.(ICRTB(3).EQ.0))))) THEN
C       These rays do not end on the reference surface, receivers
C       cannot lie here, and no boundary rays to store to CRT-B:
        KTRIS(6)=4
        CALL RPTRI2(ITRIP,LTRI,KTRIS)
        IF (.NOT.LTRI) CALL RPERR(2)
        RETURN
      ENDIF
C
C     Now searching for neighbouring homogeneous triangles.
      NTRIN=0
      INTRIN(0)=ITRIP
      KTRIN(NTRIN,  1)=KTRIS( 1)
      ITTRIN(NTRIN, 1)=ITYPS( 1)
      VTRIN(NTRIN,1,1)=VTRI(1,1)
      VTRIN(NTRIN,2,1)=VTRI(2,1)
      VTRIN(NTRIN,3,1)=VTRI(3,1)
      VTRIN(NTRIN,4,1)=VTRI(4,1)
      KTRIN(NTRIN,  2)=KTRIS( 2)
      ITTRIN(NTRIN, 2)=ITYPS( 2)
      VTRIN(NTRIN,1,2)=VTRI(1,2)
      VTRIN(NTRIN,2,2)=VTRI(2,2)
      VTRIN(NTRIN,3,2)=VTRI(3,2)
      VTRIN(NTRIN,4,2)=VTRI(4,2)
      KTRIN(NTRIN,  3)=KTRIS( 3)
      ITTRIN(NTRIN, 3)=ITYPS( 3)
      VTRIN(NTRIN,1,3)=VTRI(1,3)
      VTRIN(NTRIN,2,3)=VTRI(2,3)
      VTRIN(NTRIN,3,3)=VTRI(3,3)
      VTRIN(NTRIN,4,3)=VTRI(4,3)
      CALL RPTRIP(1,LTRI,KTRIT)
C     Loop for all the triangles in the memory:
  8   CONTINUE
        CALL RPTRIP(0,LTRI,KTRIT)
        IF (LTRI) THEN
          IF (((KTRIT(6).EQ.3).OR.(KTRIT(6).EQ.4)).AND.
     *        (KTRIT(4).NE.ITRIP)) THEN
            IF (((KTRIT(1).EQ.KTRIS(1)).OR.(KTRIT(1).EQ.KTRIS(2)).OR.
     *           (KTRIT(1).EQ.KTRIS(3))).OR.
     *          ((KTRIT(2).EQ.KTRIS(1)).OR.(KTRIT(2).EQ.KTRIS(2)).OR.
     *           (KTRIT(2).EQ.KTRIS(3))).OR.
     *          ((KTRIT(3).EQ.KTRIS(1)).OR.(KTRIT(3).EQ.KTRIS(2)).OR.
     *           (KTRIT(3).EQ.KTRIS(3)))) THEN
              DO 9, I2=1,NTRIN
                IF (KTRIT(4).EQ.INTRIN(I2)) GOTO 8
  9           CONTINUE
              NTRIN=NTRIN+1
              IF (NTRIN.GT.MTRIN) THEN
C               RP3D-021
                CALL ERROR
     * ('RP3D-021: Insufficient memory for the neighbouring triangles.')
C               This error may be caused by too small dimension of array
C               KTRIN. Try to enlarge the parameter MTRIN at the
C               beginning of this subroutine.
              ENDIF
              KTRIN(NTRIN,1)=KTRIT(1)
              CALL RPRAY(KTRIT(1),LRAY,ITTRIN(NTRIN,1),ISHEET,
     *          VTRIN(NTRIN,1,1),VTRIN(NTRIN,2,1),G11,G12,G22,
     *          VTRIN(NTRIN,3,1),VTRIN(NTRIN,4,1),G1X1,G2X1,G1X2,G2X2)
              IF (.NOT.LRAY) CALL RPERR(1)
              KTRIN(NTRIN,2)=KTRIT(2)
              CALL RPRAY(KTRIT(2),LRAY,ITTRIN(NTRIN,2),ISHEET,
     *          VTRIN(NTRIN,1,2),VTRIN(NTRIN,2,2),G11,G12,G22,
     *          VTRIN(NTRIN,3,2),VTRIN(NTRIN,4,2),G1X1,G2X1,G1X2,G2X2)
              IF (.NOT.LRAY) CALL RPERR(1)
              KTRIN(NTRIN,3)=KTRIT(3)
              CALL RPRAY(KTRIT(3),LRAY,ITTRIN(NTRIN,3),ISHEET,
     *          VTRIN(NTRIN,1,3),VTRIN(NTRIN,2,3),G11,G12,G22,
     *          VTRIN(NTRIN,3,3),VTRIN(NTRIN,4,3),G1X1,G2X1,G1X2,G2X2)
              IF (.NOT.LRAY) CALL RPERR(1)
              INTRIN(NTRIN)=KTRIT(4)
            ENDIF
          ENDIF
          GOTO 8
        ENDIF
C     End of the loop for all the triangles in the memory.
C
C     Recording the boundary rays to the file CRT-B:
      DO 18, I1=1,3
        IF ((ITYPS(I1).GT.0).AND.(ICRTB(I1).EQ.0)) THEN
C         Boundary ray IB1=KTRIS(I1) to be recorded to CRT-B:
          IB1=KTRIS(I1)
          IB2=ITYPS(I1)
          IB3=0
          IB4=0
C         Storing history of the ray IB2 to I4:
          CALL RPRAY(IB2,LRAY,ITYPE,I4,G1,G2,
     *             G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
C         Loop over all rays of the neighbouring triangles:
          DO 14, I2=0,NTRIN
            DO 12, I3=1,3
              I5=I3-1
              IF (I5.EQ.0) I5=3
              I6=I3+1
              IF (I6.EQ.4) I6=1
              IF ((ITTRIN(I2,I3).GT.0).AND.
     *            (KTRIN(I2,I3).NE.IB1).AND.
     *            ((KTRIN(I2,I5).EQ.IB1).OR.(KTRIN(I2,I6).EQ.IB1))) THEN
C               Boundary ray IBN different from IB1 found:
                IBN=KTRIN(I2,I3)
                CALL RPRAY(ITTRIN(I2,I3),LRAY,ITYPE,ISHEET,G1,G2,
     *             G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
                IF (.NOT.LRAY) CALL RPERR(1)
                IF (ISHEET.EQ.I4) THEN
C                 The boundary ray corresponding to the boundary
C                 ray IBN is of the same history as the ray IB2.
C                 Now looking, whether the side [IB1,IBN] is
C                 contained only once within the set of neighbouring
C                 triangles:
                  DO 11, I7=0,NTRIN
                    IF (I7.EQ.I2) GOTO 11
                    IF (((IB1.EQ.KTRIN(I7,1)).OR.(IB1.EQ.KTRIN(I7,2))
     *               .OR.(IB1.EQ.KTRIN(I7,3))).AND.
     *                  ((IBN.EQ.KTRIN(I7,1)).OR.(IBN.EQ.KTRIN(I7,2))
     *               .OR.(IBN.EQ.KTRIN(I7,3)))) THEN
C                     The side [IB1,IBN] is contained within triangles
C                     INTRIN(I2) and INTRIN(I7).  Such side is not
C                     located at the boundary of the ray history, and
C                     cannot be used.
                      GOTO 12
                    ENDIF
  11              CONTINUE
C                 The ray IBN may be used as the ray IB3 or IB4:
                  IF ((IB3.EQ.0).OR.(IB3.EQ.IBN)) THEN
                    IB3=IBN
                  ELSEIF ((IB4.EQ.0).OR.(IB4.EQ.IBN)) THEN
                    IB4=IBN
                  ELSE
C                   Three mutually different boundary rays IB3, IB4
C                   and IBN found.
                    IF (RPDI2L(IB3,IB1,IB4).GT.16*AERR**2) THEN
C                     Boundary demarcated by IB3,IB1,IB4 is too curved:
                      IF     (RPDI2L(IBN,IB1,IB4).LE.16*AERR**2) THEN
C                       Boundary demarcated by IBN,IB1,IB4 is OK:
                        IB3=IBN
                      ELSEIF (RPDI2L(IB3,IB1,IBN).LE.16*AERR**2) THEN
C                       Boundary demarcated by IB3,IB1,IBN is OK:
                        IB4=IBN
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
  12        CONTINUE
  14      CONTINUE
  16      CONTINUE
C         IF (IB3.EQ.0) THEN
C           No neighbouring boundary ray found.
C         ENDIF
          IF (IB4.NE.0) THEN
C           Checking the curvature of the boundary:
            IF (RPDI2L(IB3,IB1,IB4).GT.16*AERR**2) THEN
              IB3=0
              IB4=0
            ENDIF
          ENDIF
          CALL WRITBR(IB1,IB2,IB3,IB4)
          CALL RPMC2(IB1,1)
        ENDIF
  18  CONTINUE
C
      IF (ISHP.LT.0) THEN
C       These rays do not end on the reference surface, receivers
C       cannot lie here:
        KTRIS(6)=4
        CALL RPTRI2(ITRIP,LTRI,KTRIS)
        IF (.NOT.LTRI) CALL RPERR(2)
        RETURN
      ENDIF
C
C     Searching for receivers, lying (on reference surface)
C     in triangle ITRIP:
      IF (NREC.LE.0) GOTO 200
      IREC=1
      X1MIN=AMIN1(VTRI(3,1),VTRI(3,2),VTRI(3,3))
      X1MAX=AMAX1(VTRI(3,1),VTRI(3,2),VTRI(3,3))
      X2MIN=AMIN1(VTRI(4,1),VTRI(4,2),VTRI(4,3))
      X2MAX=AMAX1(VTRI(4,1),VTRI(4,2),VTRI(4,3))
  20  INOT=0
      IF ((XREC(1,IREC).LT.X1MIN).OR.(XREC(1,IREC).GT.X1MAX).OR.
     *    (XREC(2,IREC).LT.X2MIN).OR.(XREC(2,IREC).GT.X2MAX)) THEN
        IREC=IREC+1
        IF (IREC.LE.NREC) GOTO 20
        GOTO 200
      ENDIF
      AREA1=(VTRI(3,2)-XREC(1,IREC))*(VTRI(4,3)-XREC(2,IREC))-
     *      (VTRI(3,3)-XREC(1,IREC))*(VTRI(4,2)-XREC(2,IREC))
      IF (ABS(AREA1).LT.ZERO1) AREA1=0.
      AREA2=(VTRI(3,3)-XREC(1,IREC))*(VTRI(4,1)-XREC(2,IREC))-
     *      (VTRI(3,1)-XREC(1,IREC))*(VTRI(4,3)-XREC(2,IREC))
      IF (ABS(AREA2).LT.ZERO1) AREA2=0.
      AREA3=(VTRI(3,1)-XREC(1,IREC))*(VTRI(4,2)-XREC(2,IREC))-
     *      (VTRI(3,2)-XREC(1,IREC))*(VTRI(4,1)-XREC(2,IREC))
      IF (ABS(AREA3).LT.ZERO1) AREA3=0.
      IF (((AREA1.LT.0.).OR.(AREA2.LT.0.).OR.(AREA3.LT.0.)).AND.
     *    ((AREA1.GT.0.).OR.(AREA2.GT.0.).OR.(AREA3.GT.0.))) THEN
        IREC=IREC+1
        IF (IREC.LE.NREC) GOTO 20
        GOTO 200
      ENDIF
C
C     Controlling, whether two-point ray has not yet been found:
      CALL RPRAY(KTRIS(1),LRAY,ITYPE,ISHEET,G1,G2,
     *               G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAYP(5,LRAY,I1,ITYPE,ISH,G1,G2,
     *               G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
C     Loop for all the rays in the memory:
  26  CONTINUE
        CALL RPRAYP(0,LRAY,I1,ITYPE,ISH,G1,G2,
     *               G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (LRAY) THEN
          IF ((ITYPE.EQ.(-1000-IREC)).AND.(ISH.EQ.ISHEET)) THEN
C           Two-point ray with this ISHEET is already found.  Now
C           examining, whether it starts in triangles being considered:
            IF (RPLRIT(.TRUE.,VTRI(1,1),VTRI(2,1),VTRI(1,2),
     *          VTRI(2,2),VTRI(1,3),VTRI(2,3),G1,G2,AREA)) THEN
C             Two-point ray starts in tested triangle,continuing with
C             the next receiver:
              IREC=IREC+1
              IF (IREC.LE.NREC) GOTO 20
              GOTO 200
            ENDIF
            DO 28, I2=1,NTRIN
              IF (RPLRIT(.TRUE.,
     *            VTRIN(I2,1,1),VTRIN(I2,2,1),VTRIN(I2,1,2)
     *           ,VTRIN(I2,2,2),VTRIN(I2,1,3),VTRIN(I2,2,3)
     *           ,G1,G2,AREA)) THEN
C               Two-point ray starts in neighbouring triangle,
C               continuing with the next receiver:
                IREC=IREC+1
                IF (IREC.LE.NREC) GOTO 20
                GOTO 200
              ENDIF
  28        CONTINUE
          ENDIF
          GOTO 26
        ENDIF
C     End of the loop for all the rays in the memory.
C
C     Receiver IREC lies (on ref. surface) in triangle ITRIP.
      DISNST=-1.
C     Now searching for 3 rays nearest to the receiver:
C     Searching among auxiliary rays:
  30  CONTINUE
      INEAR=0
      CALL RPAUX2(ITRIP,0,J1)
      DO 32, I1=1,J1
        CALL RPAUX2(ITRIP,I1,J2)
        DO 31, I3=1,INOT
          IF (J2.EQ.KNOT(I3)) GOTO 32
  31    CONTINUE
        CALL RPRAY(J2,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        DIST2=(X1-XREC(1,IREC))**2 +(X2-XREC(2,IREC))**2
        IF ((DIST2.LT.DIST1).OR.(INEAR.EQ.0)) THEN
          NEAR3=NEAR2
          NEAR2=NEAR1
          NEAR1=J2
          DIST1=DIST2
          IF (INEAR.LT.3) INEAR=INEAR+1
        ENDIF
  32  CONTINUE
C     Searching among vertices of the triangle:
      DO 33, I1=1,3
        J2=KTRIS(I1)
        DO 37, I3=1,INOT
          IF (J2.EQ.KNOT(I3)) GOTO 33
  37    CONTINUE
        CALL RPRAY(J2,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        DIST2=(X1-XREC(1,IREC))**2 +(X2-XREC(2,IREC))**2
        IF ((DIST2.LT.DIST1).OR.(INEAR.EQ.0)) THEN
          NEAR3=NEAR2
          NEAR2=NEAR1
          NEAR1=J2
          DIST1=DIST2
          IF (INEAR.LT.3) INEAR=INEAR+1
        ENDIF
  33  CONTINUE
C     Searching also in neighbouring triangles:
      DO 36, I1=1,NTRIN
        CALL RPAUX2(INTRIN(I1),0,J1)
        DO 34, I2=1,J1
          CALL RPAUX2(INTRIN(I1),I2,J2)
          DO 38, I3=1,INOT
            IF (J2.EQ.KNOT(I3)) GOTO 34
  38      CONTINUE
          CALL RPRAY(J2,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *               G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          DIST2=(X1-XREC(1,IREC))**2 +(X2-XREC(2,IREC))**2
          IF (DIST2.LT.DIST1) THEN
            NEAR3=NEAR2
            NEAR2=NEAR1
            NEAR1=J2
            DIST1=DIST2
            IF (INEAR.LT.3) INEAR=INEAR+1
          ENDIF
  34    CONTINUE
        DO 35, I2=1,3
          J2=KTRIN(I1,I2)
          DO 39, I3=1,INOT
            IF (J2.EQ.KNOT(I3)) GOTO 35
  39      CONTINUE
          CALL RPRAY(J2,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *               G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          DIST2=(X1-XREC(1,IREC))**2 +(X2-XREC(2,IREC))**2
          IF (DIST2.LT.DIST1) THEN
            NEAR3=NEAR2
            NEAR2=NEAR1
            NEAR1=J2
            DIST1=DIST2
            IF (INEAR.LT.3) INEAR=INEAR+1
          ENDIF
  35    CONTINUE
  36  CONTINUE
      IF (INEAR.EQ.0) THEN
        IF (DISNST.NE.-1.) THEN
C         The nearest ray will be taken as a two-point ray:
          G1NEW=G1NST
          G2NEW=G2NST
          DIST1=DISNST
          LNST=.TRUE.
          LDISTG=.FALSE.
          GOTO 90
        ELSE
C         RP3D-032
          WRITE(TXTERR,'(2A,1I6,A,1I6)')
     *    'Error RP3D-032: There is no ray to start the interpolation',
     *    ' of a two-point ray of history ',ISHEET,
     *    ' to the receiver ',IREC
          CALL ERROR(TXTERR(1:LENGTH(TXTERR)))
C         This error should not appear.
        ENDIF
        IREC=IREC+1
        IF (IREC.LE.NREC) GOTO 20
        GOTO 200
      ENDIF
C
C
C     Start of interpolation (from NEAR1):
      ISTART=1
  40  IF ((ISTART.EQ.1).AND.(ISTART.LE.INEAR)) THEN
        CALL RPRAY(NEAR1,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (DISNST.EQ.-1.) THEN
C         Noting the nearest ray for the case that no better ray
C         will be found:
          DISNST=DIST1
          G1NST=G1
          G2NST=G2
        ENDIF
      ELSEIF ((ISTART.EQ.2).AND.(ISTART.LE.INEAR)) THEN
        CALL RPRAY(NEAR2,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
      ELSEIF ((ISTART.EQ.3).AND.(ISTART.LE.INEAR)) THEN
        CALL RPRAY(NEAR3,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
      ELSE
C       Deleting unneeded auxiliary rays from register
C       of auxiliary rays:
        IF (INEAR.GE.1) THEN
          INOT=INOT+1
          IF (INOT.GE.MNOT) THEN
            IREC=IREC+1
            IF (IREC.LE.NREC) GOTO 20
            GOTO 200
          ENDIF
          KNOT(INOT)=NEAR1
        ENDIF
        IF (INEAR.GE.2) THEN
          INOT=INOT+1
          IF (INOT.GE.MNOT) THEN
            IREC=IREC+1
            IF (IREC.LE.NREC) GOTO 20
            GOTO 200
          ENDIF
          KNOT(INOT)=NEAR2
        ENDIF
        IF (INEAR.GE.3) THEN
          INOT=INOT+1
          IF (INOT.GE.MNOT) THEN
            IREC=IREC+1
            IF (IREC.LE.NREC) GOTO 20
            GOTO 200
          ENDIF
          KNOT(INOT)=NEAR3
        ENDIF
        GOTO 30
      ENDIF
      IF (.NOT.LRAY) CALL RPERR(1)
      DX1=XREC(1,IREC)-X1
      DX2=XREC(2,IREC)-X2
      DG1=G1X1*DX1+G1X2*DX2
      DG2=G2X1*DX1+G2X2*DX2
      G1NEW=G1+DG1
      G2NEW=G2+DG2
      DIST1=(X1-XREC(1,IREC))**2 +(X2-XREC(2,IREC))**2
      LDISTG=.FALSE.
      GOTO 90
C
C
  50  CALL RPRAY(IRAY,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *           G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
C
      IF (ISHEET.LT.0) THEN
C       This may happen, when the ray starts in a triangle formed
C       by unsuccessful rays and is of the same history as the rays
C       of the triangle.
C       Start of interpolation from other ray:
        ISTART=ISTART+1
        GOTO 40
      ENDIF
C
      IF ((ITYPE.LT.-1000).OR.(LNST)) THEN
        IF (ITYPE.LT.-1000) THEN
C         The ray IRAY is two-point ray !
          CALL RPAUX1(ITRNAR,IRAY)
        ENDIF
        LNST=.FALSE.
        LNEWAR=.FALSE.
C       End of interpolation for this receiver:
        IREC=IREC+1
        IF (IREC.LE.NREC) GOTO 20
        GOTO 200
      ENDIF
C
      DIST2=(X1-XREC(1,IREC))**2 +(X2-XREC(2,IREC))**2
      IF (DIST2.GE.DIST1) THEN
        IF (.NOT.LDISTG) THEN
          DG1=-DG1*.5
          DG2=-DG2*.5
          G1NEW=G1+DG1
          G2NEW=G2+DG2
          LDISTG=.TRUE.
          GOTO 90
        ENDIF
        ISTART=ISTART+1
        GOTO 40
      ELSE
        IF (DIST2.LT.DISNST) THEN
C         Noting the nearest ray for the case that no better ray
C         will be found:
          DISNST=DIST2
          G1NST=G1
          G2NST=G2
        ENDIF
        DX1=XREC(1,IREC)-X1
        DX2=XREC(2,IREC)-X2
        DG1=G1X1*DX1+G1X2*DX2
        DG2=G2X1*DX1+G2X2*DX2
        G1NEW=G1+DG1
        G2NEW=G2+DG2
        DIST1=DIST2
        LDISTG=.FALSE.
C       Go to label 90.
      ENDIF
C
C     Now verifying, whether the new ray lies in the triangle or
C     in neighbouring triangles:
  90  CONTINUE
      IF ((ABS (DG1).LT.ZERO).AND.(ABS(DG2).LT.ZERO).AND.
     *     (.NOT.LNST)) THEN
C       RP3D-033
        FORMAT='(2A,1I6,A,1I6)'
        I8=INT(ALOG10(FLOAT(ISHEET)))+1
        FORMAT(7:7)=CHAR(ICHAR('0')+I8)
        I8=INT(ALOG10(FLOAT(IREC)))+1
        FORMAT(13:13)=CHAR(ICHAR('0')+I8)
        WRITE(TXTERR,FORMAT)
     *  'RP3D-033: Differences DG1, DG2 equal to zero',
     *  ' when searching for a two-point ray of history ',ISHEET,
     *  ' to the receiver ',IREC
        CALL WARN(TXTERR(1:LENGTH(TXTERR)))
C       Parameters of a new ray proposed as
C                         new ray = old ray +DGi
C       are computed here in order to find a two-point ray.
C       Small differences DGi indicate inconsistency between the
C       geometrical spreading of computed rays and values of input data
C       (e.g. too small XERR, too big STEP, ... ).
C       Input data RPAR.
C       Input data DCRT.
C       Start of interpolation from other ray:
        ISTART=ISTART+1
        GOTO 40
      ENDIF
      IF (RPLRIT(.TRUE.,VTRI(1,1),VTRI(2,1),VTRI(1,2),
     *    VTRI(2,2),VTRI(1,3),VTRI(2,3),G1NEW,G2NEW,AREA)) THEN
C       Auxiliary ray starts in tested triangle:
        ITYPEN=-1000-IREC
        ITRNAR=ITRIP
        LNEWAR=.TRUE.
        RETURN
      ENDIF
      DO 92, I1=1,NTRIN
        IF (RPLRIT(.TRUE.,VTRIN(I1,1,1),VTRIN(I1,2,1),VTRIN(I1,1,2),
     *      VTRIN(I1,2,2),VTRIN(I1,1,3),VTRIN(I1,2,3),
     *      G1NEW,G2NEW,AREA)) THEN
C         Auxiliary ray starts in neighbouring triangle:
          ITYPEN=-1000-IREC
          ITRNAR=INTRIN(I1)
          LNEWAR=.TRUE.
          RETURN
        ENDIF
  92  CONTINUE
C     Now verifying, whether the new ray lies in the part of domain
C     covered by basic triangles:
      IF (G1NEW.LT.GLIMIT(1)) THEN
        G1NEW=GLIMIT(1)
        GOTO 90
      ENDIF
      IF (G1NEW.GT.GLIMIT(2)) THEN
        G1NEW=GLIMIT(2)
        GOTO 90
      ENDIF
      IF (G2NEW.LT.GLIMIT(3)) THEN
        G2NEW=GLIMIT(3)
        GOTO 90
      ENDIF
      IF (G2NEW.GT.GLIMIT(4)) THEN
        G2NEW=GLIMIT(4)
        GOTO 90
      ENDIF
C     Testing whether the abscissa
C [(ray with parameters G1NEW,G2MIN),(ray with parameters G1NEW,G2NEW)]
C     has intersection with some abscissa of polyline.
      INTERS=0
      DO 94, I1=1,NPL-1
        CALL RPRAY(KPL(I1),LRAY,ITYPE,ISH,G1A,G2A,G11,G12,G22,
     *             X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(KPL(I1+1),LRAY,ITYPE,ISH,G1B,G2B,G11,G12,G22,
     *             X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        G1C=G1NEW
        G2C=GLIMIT(3)
C       ..A,..B ... 'indices' of rays of tested polyline abscissa.
C       ..C,..NEW.. 'indices' of rays of tested abscissa.
        CALL RPCROS(G1C,G2C,G1NEW,G2NEW,G1A,G2A,G1B,G2B,LINTS,G1A,G2A)
        IF (LINTS) INTERS=INTERS+1
  94  CONTINUE
      IF (AMOD(REAL(INTERS),2.).NE.0.) THEN
C       Auxiliary ray does not start in the part of domain covered
C       by basic triangles:
        ITRNAR=0
        IF (.NOT.LDISTG) THEN
          DG1=DG1*.5
          DG2=DG2*.5
          G1NEW=G1+DG1
          G2NEW=G2+DG2
          LDISTG=.TRUE.
          GOTO 90
        ENDIF
        ISTART=ISTART+1
        GOTO 40
      ENDIF
C     Auxiliary ray starts in the part
C     of domain covered by basic triangles:
      CALL RPTRIP(-ITRI,LTRI,KTRIT)
C     Loop for all the triangles in the memory:
  101 CONTINUE
        CALL RPTRIP(0,LTRI,KTRIT)
        IF (LTRI) THEN
          IF (KTRIT(4).EQ.ITRIP) GOTO 101
          IF (KTRIT(6).NE.3) GOTO 101
          DO 102, I2=1,NTRIN
            IF (KTRIT(4).EQ.INTRIN(I2)) GOTO 101
  102     CONTINUE
          CALL RPRAY(KTRIT(1),LRAY,ITYPE,ISHA,G1A,G2A,
     *              G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          CALL RPRAY(KTRIT(2),LRAY,ITYPE,ISH,G1B,G2B,
     *              G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          CALL RPRAY(KTRIT(3),LRAY,ITYPE,ISH,G1C,G2C,
     *              G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          IF (RPLRIT(.TRUE.,G1A,G2A,G1B,G2B,G1C,G2C,
     *               G1NEW,G2NEW,AREA)) THEN
C           Auxiliary ray starts in this triangle.
C           Controlling, whether two-point ray has not yet been found:
            CALL RPRAYP(5,LRAY,I1,ITYPE,ISH,G1,G2,
     *                  G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
C           Loop for all the rays in the memory:
  104       CONTINUE
              CALL RPRAYP(0,LRAY,I2,ITYPE,ISH,G1,G2,
     *                    G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
              IF (LRAY) THEN
                IF ((ITYPE.EQ.(-1000-IREC)).AND.(ISH.EQ.ISHA)) THEN
C                 Two-point ray with this ISHEET is already found.  Now
C                 examining, whether it starts in this triangle:
                  IF (RPLRIT(.TRUE.,G1A,G2A,G1B,G2B,G1C,G2C,
     *                       G1,G2,AREA)) THEN
C                   Two-point ray starts in tested triangle,continuing
C                   with the next receiver:
                    IREC=IREC+1
                    IF (IREC.LE.NREC) GOTO 20
                    GOTO 200
                  ENDIF
                ENDIF
                GOTO 104
              ENDIF
C           End of the loop for all the rays in the memory.
            ITRNAR=KTRIT(4)
            ITYPEN=-1000-IREC
            LNEWAR=.TRUE.
            RETURN
          ENDIF
          GOTO 101
        ENDIF
C     End of the loop for all the triangles in the memory.
C
C     Auxiliary ray starts neither in the triangle nor
C     in the neighbouring triangles, but it starts in the part
C     of domain covered by basic triangles:
      ITRNAR=0
      IF (.NOT.LDISTG) THEN
        DG1=DG1*.5
        DG2=DG2*.5
        G1NEW=G1+DG1
        G2NEW=G2+DG2
        LDISTG=.TRUE.
        GOTO 90
      ENDIF
      ISTART=ISTART+1
      GOTO 40
C
C     No other receivers lying in triangle ITRIP. End of interpolation.
  200 CONTINUE
      KTRIS(6)=4
      CALL RPTRI2(ITRIP,LTRI,KTRIS)
      LNEWAR=.FALSE.
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RPERAS
C
C----------------------------------------------------------------------
C
C Subroutine designed to delete unneeded triangles and rays from memory.
C
C No input
C No output
C
C Subroutines and external functions required:
C
C Coded by Petr Bulant
C
C.......................................................................
C
C Common blocks /GLIM/, /POLY/, /BOURA/, /TRIAN/, /AUXER/ and /RAY/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C.......................................................................
      REAL ZERO
      PARAMETER (ZERO =.0000001)
      INTEGER MREC
      PARAMETER (MREC=1024)
      INTEGER KTRIS(6)
      INTEGER ITYPE,ISH
      REAL G1,G2,G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2
      REAL G2MI
      INTEGER I1,I2,I3,I4
      INTEGER J1,J2
      LOGICAL LERASE,LRAY
C     ZERO... Constant used to decide whether the real variable.EQ.zero.
C     MAUAR... Maximum number of rays in KAUAR.
C     NAUAR... Number of rays in KAUAR.
C     KAUAR... Array with indices of rays which are not to be erased.
C     MREC... Maximum number of receivers in the memory.
C     KTRIS... All parameters of the triangle to be erased.
C     G2MI... Minimum of G2 of all the rays on the polyline.
C     I1,2,3,4... Implied-do variables or variables controlling the loop.
C     J1,J2... Auxiliary variables (numbers).
C     LERASE... Indicates whether the part of the KBR being processed
C             is to be erased.
C     LRAY... Indicates whether the ray is in the memory.
C----------------------------------------------------------------------
C
C     First rays - return without erasing:
      IF (NPL.EQ.0) THEN
        RETURN
      ENDIF
C
C     Deleting unneeded rays in array KBR:
      G2MI=GLIMIT(4)
      DO 5, I1=2,NPL-1
        CALL RPRAY(KPL(I1),LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        IF (G2.LT.G2MI) G2MI=G2
  5   CONTINUE
      IF (G2MI.LE.GLIMIT(3)) GOTO 13
      LERASE=.FALSE.
      IF (NBR.EQ.0) GOTO 13
      J1=0
      IF (NBR.GT.2) THEN
  10  CONTINUE
        IF ((KBR(J1+2,1).EQ.KPL(2)).OR.(KBR(J1+1,1).EQ.KPL(NPL-1)))
     *    LERASE=.TRUE.
        IF (.NOT.LERASE) THEN
          CALL RPRAY(KBR(J1+1,1),LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *               X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          IF (G2.LT.G2MI-ZERO) LERASE=.TRUE.
        ENDIF
        IF (LERASE) THEN
          J2=KBR(J1+3,1)+3
          NBR=NBR-J2
          DO 12, I1=J1+1,NBR
            KBR(I1,1)=KBR(I1+J2,1)
            KBR(I1,2)=KBR(I1+J2,2)
            KBR(I1,3)=KBR(I1+J2,3)
            GBR(I1,1)=GBR(I1+J2,1)
            GBR(I1,2)=GBR(I1+J2,2)
  12      CONTINUE
          LERASE=.FALSE.
        ENDIF
        J1=J1+KBR(J1+3,1)+3
      IF (J1.LT.NBR) GOTO 10
      ENDIF
C
C     Searching for new triangles and for unprocessed homogeneous ones,
C     storing their vertices to the array KAUAR:
  13  CONTINUE
      NAUAR=0
      DO 30, I1=1,NTRI
        IF ((KTRI(6,I1).EQ.0).OR.(KTRI(6,I1).EQ.3)) THEN
          DO 40, I2=1,3
            IF (NAUAR.GE.MAUAR) THEN
C             RP3D-022
              CALL ERROR('RP3D-022: Insufficient memory for KAUAR.')
C             This error may be caused by too small dimension of array
C             KAUAR. Try to enlarge the parameter MAUAR in common block
C             AUXER in file
C             rp3d.inc.
            ENDIF
            NAUAR=NAUAR+1
            KAUAR(NAUAR)=KTRI(I2,I1)
  40      CONTINUE
        ENDIF
  30  CONTINUE
C
C     Marking unneeded triangles,deleting them from arrays in RPAUX:
      DO 50, I1=1,NTRI
        IF (KTRI(6,I1).EQ.2) THEN
          IF (KTRI(5,I1).EQ.0) THEN
C           Basic triangle:
            DO 55, I2=1,NPL
              IF ((KTRI(1,I1).EQ.KPL(I2)).OR.
     *            (KTRI(2,I1).EQ.KPL(I2)).OR.
     *            (KTRI(3,I1).EQ.KPL(I2))) GOTO 50
  55        CONTINUE
          ENDIF
          CALL RPAUX1(-KTRI(4,I1),0)
          KTRI(4,I1)=0
        ELSEIF (KTRI(6,I1).EQ.4) THEN
          DO 60, I2=1,NPL
            IF ((KTRI(1,I1).EQ.KPL(I2)).OR.
     *          (KTRI(2,I1).EQ.KPL(I2)).OR.
     *          (KTRI(3,I1).EQ.KPL(I2))) GOTO 50
  60      CONTINUE
          DO 70, I2=1,NAUAR
            IF ((KTRI(1,I1).EQ.KAUAR(I2)).OR.
     *          (KTRI(2,I1).EQ.KAUAR(I2)).OR.
     *          (KTRI(3,I1).EQ.KAUAR(I2))) GOTO 50
  70      CONTINUE
          J1=0
          IF (NBR.GT.2) THEN
  73      CONTINUE
            DO 75, I2=J1+4,J1+3+KBR(J1+3,1)
              IF ((KTRI(1,I1).EQ.KBR(I2,1)).OR.
     *            (KTRI(2,I1).EQ.KBR(I2,1)).OR.
     *            (KTRI(3,I1).EQ.KBR(I2,1))) GOTO 50
  75        CONTINUE
            J1=J1+KBR(J1+3,1)+3
          IF (J1.LT.NBR) GOTO 73
          ENDIF
          CALL RPAUX1(-KTRI(4,I1),0)
          KTRI(4,I1)=0
        ENDIF
  50  CONTINUE
C
      DO 78, I2=1,NTRI
        IF (KTRI(4,I2).EQ.0) THEN
C         This triangle will be deleted:
          KTRIS(1)=KTRI(1,I2)
          KTRIS(2)=KTRI(2,I2)
          KTRIS(3)=KTRI(3,I2)
          KTRIS(4)=KTRI(4,I2)
          KTRIS(5)=KTRI(5,I2)
          KTRIS(6)=2
          CALL RPSTOR('T',1,KTRIS)
        ENDIF
  78  CONTINUE
C
C     Marking all rays as unneeded:
      DO 80, I1=5,NRAY
        IF (ITRAY(I1).GT.-1000) KRAY(I1)=-KRAY(I1)
  80  CONTINUE
C
C     Marking needed rays,erasing unneeded triangles:
C     Marking vertices of triangles as needed:
      I1=0
      DO 90, I2=1,NTRI
        IF (KTRI(4,I2).EQ.0) THEN
C         This triangle will be deleted:
          GOTO 90
        ENDIF
        I1=I1+1
        DO 100, I3=1,6
          KTRI(I3,I1)=KTRI(I3,I2)
  100   CONTINUE
        DO 120, I3=1,3
          DO 114, I4=1,NRAY
C           Marking ray KTRI(I3,I1) as needed:
            IF (IABS(KRAY(I4)).EQ.KTRI(I3,I1)) THEN
              KRAY(I4)=IABS(KRAY(I4))
              ITYPE=ITRAY(I4)
              GOTO 116
            ENDIF
  114     CONTINUE
          CALL RPERR(1)
  116     CONTINUE
          IF (ITYPE.GT.0) THEN
C           Marking boundary ray coupled with KTRI(I3,I1) as needed:
            DO 118, I4=1,NRAY
              IF (IABS(KRAY(I4)).EQ.ITYPE) THEN
                KRAY(I4)=IABS(KRAY(I4))
                GOTO 120
              ENDIF
  118       CONTINUE
            CALL RPERR(1)
          ENDIF
  120   CONTINUE
C       Marking auxiliary rays:
        CALL RPAUX2(KTRI(4,I1),0,J2)
        DO 130, I3=1,J2
          CALL RPAUX2(KTRI(4,I1),I3,J1)
          DO 140, I4=1,NRAY
            IF (IABS(KRAY(I4)).EQ.J1) THEN
              KRAY(I4)=IABS(KRAY(I4))
              ITYPE=ITRAY(I4)
              GOTO 138
            ENDIF
  140     CONTINUE
          CALL RPERR(1)
  138     CONTINUE
          IF (ITYPE.GT.0) THEN
C           Marking boundary ray coupled with ray J1 as needed:
            DO 136, I4=1,NRAY
              IF (IABS(KRAY(I4)).EQ.ITYPE) THEN
                KRAY(I4)=IABS(KRAY(I4))
                GOTO 130
              ENDIF
  136       CONTINUE
            CALL RPERR(1)
          ENDIF
  130   CONTINUE
  90  CONTINUE
      NTRI=I1
C     Marking rays on the polyline:
      DO 150, I1=1,NPL
        DO 160, I4=1,NRAY
          IF (IABS(KRAY(I4)).EQ.KPL(I1)) THEN
            KRAY(I4)=IABS(KRAY(I4))
            ITYPE=ITRAY(I4)
            GOTO 158
          ENDIF
  160   CONTINUE
        CALL RPERR(1)
  158   CONTINUE
        IF (ITYPE.GT.0) THEN
C         Marking boundary ray coupled with ray KPL(I1) as needed:
          DO 156, I4=1,NRAY
            IF (IABS(KRAY(I4)).EQ.ITYPE) THEN
              KRAY(I4)=IABS(KRAY(I4))
              GOTO 150
            ENDIF
  156     CONTINUE
          CALL RPERR(1)
        ENDIF
  150 CONTINUE
C     Marking rays in the array KBR:
      J1=0
      IF (NBR.GT.2) THEN
  165 CONTINUE
        DO 170, I1=J1+1,J1+3+KBR(J1+3,1)
          IF (I1.EQ.J1+3) GOTO 170
          DO 180, I4=1,NRAY
            IF (IABS(KRAY(I4)).EQ.KBR(I1,1)) THEN
              KRAY(I4)=IABS(KRAY(I4))
              ITYPE=ITRAY(I4)
              GOTO 178
            ENDIF
  180     CONTINUE
          CALL RPERR(1)
  178     CONTINUE
          IF (ITYPE.GT.0) THEN
C           Marking boundary ray coupled with ray KBR(I1,1) as needed:
            DO 176, I4=1,NRAY
              IF (IABS(KRAY(I4)).EQ.ITYPE) THEN
                KRAY(I4)=IABS(KRAY(I4))
                GOTO 170
              ENDIF
  176       CONTINUE
            CALL RPERR(1)
          ENDIF
  170   CONTINUE
        J1=J1+KBR(J1+3,1)+3
      IF (J1.LT.NBR) GOTO 165
      ENDIF
C     Marking rays in the array KAUAR:
      DO 200, I1=1,NAUAR
        DO 190, I4=1,NRAY
          IF (IABS(KRAY(I4)).EQ.KAUAR(I1)) THEN
            KRAY(I4)=IABS(KRAY(I4))
            ITYPE=ITRAY(I4)
            GOTO 192
          ENDIF
  190   CONTINUE
        CALL RPERR(1)
  192   CONTINUE
        IF (ITYPE.GT.0) THEN
C         Marking boundary ray coupled with ray KAUAR(I1) as needed:
          DO 196, I4=1,NRAY
            IF (IABS(KRAY(I4)).EQ.ITYPE) THEN
              KRAY(I4)=IABS(KRAY(I4))
              GOTO 200
            ENDIF
  196     CONTINUE
          CALL RPERR(1)
        ENDIF
  200 CONTINUE
C
C     Deleting unneeded rays:
      J1=4
      DO 210, I1=5,NRAY
        IF (KRAY(I1).LT.0) GOTO 210
        J1=J1+1
        KRAY(J1)=KRAY(I1)
        ITRAY(J1)=ITRAY(I1)
        ISRAY(J1)=ISRAY(I1)
        IBRAY(J1)=IBRAY(I1)
        G1RAY(J1)=G1RAY(I1)
        G2RAY(J1)=G2RAY(I1)
        X1RAY(J1)=X1RAY(I1)
        X2RAY(J1)=X2RAY(I1)
        G11RAY(J1)=G11RAY(I1)
        G12RAY(J1)=G12RAY(I1)
        G22RAY(J1)=G22RAY(I1)
        S11RAY(J1)=S11RAY(I1)
        S12RAY(J1)=S12RAY(I1)
        S22RAY(J1)=S22RAY(I1)
        G1X1RA(J1)=G1X1RA(I1)
        G1X2RA(J1)=G1X2RA(I1)
        G2X1RA(J1)=G2X1RA(I1)
        G2X2RA(J1)=G2X2RA(I1)
  210 CONTINUE
      NRAY=J1
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RPTMEA(JTRI,ITRI,IRAY,LNEWAR,
     *                  LAB20,G1NEW,G2NEW)
C
C----------------------------------------------------------------------
C Subroutine designed to measure the sides of the triangle JTRI in the
C ray-tube metric and to divide this triangle if it is too large.
C
      INTEGER JTRI,ITRI,IRAY
      LOGICAL LNEWAR,LAB20
      REAL G1NEW,G2NEW
C Input:
C     JTRI... Index of the measured triangle.
C     ITRI... Index of last computed triangle.
C     IRAY... Index of last computed ray.
C     LNEWAR... Indicates whether the new auxiliary ray was computed.
C Output:
C     LNEWAR... Indicates whether the new auxiliary ray is to be computed.
C     LAB20... Indicates that inhomogeneous triangles have been formed
C             running RPTMEA.
C     G1NEW,G2NEW... Coordinates of the new ray.
C
C Subroutines and external functions required:
      EXTERNAL RPDI2G,RPLRIL
      REAL RPDI2G
      LOGICAL RPLRIL
C
C Coded by Petr Bulant
C
C.......................................................................
C
C Common blocks /GLIM/, /DRAYS/ and /BOURA/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C............................
C
C Common block /RPARD/:
      INCLUDE 'rpard.inc'
C     rpard.inc
C     AERR... The distance of boundary rays.
C     PRM0(4)... Maximum allowed thickness of the ray tubes.
C.......................................................................
      REAL ZERO
      PARAMETER (ZERO =.0000001)
      INTEGER KTRID(6),KTRIN(6),KTRIS(6)
      INTEGER KRAYA,ITYPEA,ISHA
      REAL G1A,G2A,G11A,G12A,G22A,G1X1A,G2X1A,G1X2A,G2X2A
      INTEGER KRAYB,ITYPEB,ISHB
      REAL G1B,G2B,G11B,G12B,G22B,G1X1B,G2X1B,G1X2B,G2X2B
      INTEGER KRAYC,ITYPEC,ISHC
      REAL G1C,G2C,G11C,G12C,G22C,G1X1C,G2X1C,G1X2C,G2X2C
      INTEGER KRAYD,ITYPED,ISHD
      REAL S11A,S12A,S22A,S11B,S12B,S22B,S11C,S12C,S22C
      REAL G1D,G2D,G11D,G12D,G22D
      INTEGER ITYPEG,ISHG
      REAL G1G,G2G,G11G,G12G,G22G
      INTEGER KRAYI,KRAYJ,ITYPE,ISH
      REAL G1I,G2I,G1J,G2J,G1K,G2K,G11,G12,G22
      REAL X1,X2,G1X1,G2X1,G1X2,G2X2
      REAL AREA,DIST2A,DIST2B,DIST2C,AERR2,PRM042
      REAL G11POM,G12POM,G22POM
      REAL DG1,DG2,DIST2,DETG
      INTEGER I1,I2,I3
      LOGICAL LRAY,LTRI
      SAVE KRAYA,KRAYB,KRAYC,ISHA,ITYPEA,ITYPEB,G1A,G1B,G2A,G2B
     *    ,G11A,G12A,G22A,G11B,G12B,G22B,AERR2,PRM042,KTRID
C     ZERO... Constant used to decide whether the real variable .EQ. 0.
C     KTRID... Parameters of the triangle to be measured.
C     KTRIN... Parameters of the new triangle to be registrated
C             (new column to be added into array KTRI).
C     KTRIS... Parameters of the examined triangle.
C     G1X1,G2X1,G1X2,G2X2... Derivatives.
C     KRAYA,(B),(C)... Signs of rays            |   Auxiliary
C     ITYPEA,(B),(C)... Types of rays           |   variables used
C     ISHA,(B),(C)... Value of history function |   for different rays.
C     GiA,(B),(C)... Parameters of rays         |
C     AREA... Auxiliary variable (area of the triangle).
C     DIST2A,B,C... Auxiliary variables (second powers of the lengths
C             of the triangle sides).
C     AERR2... Second power of the maximum distance between the couple
C             of boundary rays in the normalized ray domain.
C     GiiPOM... Auxiliary variables (metric tensor).
C     DG1,DG2,DIST2... Auxiliary variables.
C     DETG... Determinant.
C     I1,2,3... Implied-do variables or variables controlling the loop.
C     LRAY... Indicates whether the ray IRAY is in memory.
C     LTRI... Indicates whether the triangle ITRI is in memory.
C-----------------------------------------------------------------------
C
      IF (IRAY.EQ.0) THEN
        AERR2=AERR**2
        PRM042=PRM0(4)**2
        NDRAYS=0
      ENDIF
C
      IF (LNEWAR) GOTO 10
C
      CALL RPTRI3(JTRI,LTRI,KTRID)
      IF ((.NOT.LTRI).OR.(KTRID(6).NE.3)) THEN
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C     Reading the rays of the triangle:
      KRAYA=KTRID(1)
      CALL RPRAY2(KTRID(1),LRAY,ITYPEA,ISHA,G1A,G2A,G11A,G12A,G22A,
     *            S11A,S12A,S22A,X1,X2,G1X1A,G2X1A,G1X2A,G2X2A)
      IF (.NOT.LRAY) CALL RPERR(1)
      KRAYB=KTRID(2)
      CALL RPRAY2(KTRID(2),LRAY,ITYPEB,ISHB,G1B,G2B,G11B,G12B,G22B,
     *            S11B,S12B,S22B,X1,X2,G1X1B,G2X1B,G1X2B,G2X2B)
      IF (.NOT.LRAY) CALL RPERR(1)
      KRAYC=KTRID(3)
      CALL RPRAY2(KTRID(3),LRAY,ITYPEC,ISHC,G1C,G2C,G11C,G12C,G22C,
     *            S11C,S12C,S22C,X1,X2,G1X1C,G2X1C,G1X2C,G2X2C)
      IF (.NOT.LRAY) CALL RPERR(1)
      IF ((ISHA.NE.ISHB).OR.(ISHA.NE.ISHC)) THEN
        KTRID(6)=0
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        LAB20=.TRUE.
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C     ..A,..B,..C .. Vertices of measured triangle.
C     Controlling the size of triangle surface :
      G11POM=(G11A+G11C+G11B)/3.
      G12POM=(G12A+G12C+G12B)/3.
      G22POM=(G22A+G22C+G22B)/3.
      DG1=G1B-G1A
      DG2=G2B-G2A
      DETG=G11POM*G22POM - G12POM*G12POM
      IF (DETG.LT.ZERO) CALL RPERR(4)
      AREA=SQRT(DETG)*((DG1*(G2C-G2A)-DG2*(G1C-G1A))*.5)
      IF (AREA.LT.(AERR2*0.4330127/9.)) THEN
C       0.4330127=Sqrt(3)/4
C       Triangle too small or left-handed.
        KTRID(6)=2
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        RETURN
      ENDIF
C     Measuring the size of triangle sides using the ray-domain
C     matrix:
      G11POM=(G11A+G11B)/2.
      G12POM=(G12A+G12B)/2.
      G22POM=(G22A+G22B)/2.
      DIST2A=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
      G11POM=(G11B+G11C)/2.
      G12POM=(G12B+G12C)/2.
      G22POM=(G22B+G22C)/2.
      DIST2B=RPDI2G(G1B,G2B,G1C,G2C,G11POM,G12POM,G22POM)
      G11POM=(G11A+G11C)/2.
      G12POM=(G12A+G12C)/2.
      G22POM=(G22A+G22C)/2.
      DIST2C=RPDI2G(G1A,G2A,G1C,G2C,G11POM,G12POM,G22POM)
C
      IF ((DIST2A.LE.AERR2/9.).OR.(DIST2B.LE.AERR2/9.).OR.
     *    (DIST2C.LE.AERR2/9.)) THEN
C       Triangle too small.
        KTRID(6)=2
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        RETURN
      ENDIF
C
      IF (PRM0(4).EQ.0.) RETURN
C
C     Measuring the size of triangle sides using the ray-tube matrix:
      G11POM=(S11A+S11B)/2.
      G12POM=(S12A+S12B)/2.
      G22POM=(S22A+S22B)/2.
      DIST2A=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
      G11POM=(S11B+S11C)/2.
      G12POM=(S12B+S12C)/2.
      G22POM=(S22B+S22C)/2.
      DIST2B=RPDI2G(G1B,G2B,G1C,G2C,G11POM,G12POM,G22POM)
      G11POM=(S11A+S11C)/2.
      G12POM=(S12A+S12C)/2.
      G22POM=(S22A+S22C)/2.
      DIST2C=RPDI2G(G1A,G2A,G1C,G2C,G11POM,G12POM,G22POM)
C
      IF ((DIST2A.LE.PRM042).AND.(DIST2B.LE.PRM042).AND.
     *    (DIST2C.LE.PRM042)) THEN
C       The triangle is O.K.
        RETURN
      ENDIF
C
C     Choosing the longest side to be divided:
      IF ((DIST2A.GE.DIST2B).AND.(DIST2A.GE.DIST2C)) THEN
C       No action
      ELSEIF ((DIST2B.GE.DIST2A).AND.(DIST2B.GE.DIST2C)) THEN
         KRAYD= KRAYA
        ITYPED=ITYPEA
          ISHD=  ISHA
           G1D=   G1A
           G2D=   G2A
          G11D=  G11A
          G12D=  G12A
          G22D=  G22A
         KRAYA= KRAYB
        ITYPEA=ITYPEB
          ISHA=  ISHB
           G1A=   G1B
           G2A=   G2B
          G11A=  G11B
          G12A=  G12B
          G22A=  G22B
         KRAYB= KRAYC
        ITYPEB=ITYPEC
          ISHB=  ISHC
           G1B=   G1C
           G2B=   G2C
          G11B=  G11C
          G12B=  G12C
          G22B=  G22C
         KRAYC= KRAYD
        ITYPEC=ITYPED
          ISHC=  ISHD
           G1C=   G1D
           G2C=   G2D
          G11C=  G11D
          G12C=  G12D
          G22C=  G22D
      ELSEIF ((DIST2C.GE.DIST2A).AND.(DIST2C.GE.DIST2B)) THEN
         KRAYD= KRAYA
        ITYPED=ITYPEA
          ISHD=  ISHA
           G1D=   G1A
           G2D=   G2A
          G11D=  G11A
          G12D=  G12A
          G22D=  G22A
         KRAYA= KRAYC
        ITYPEA=ITYPEC
          ISHA=  ISHC
           G1A=   G1C
           G2A=   G2C
          G11A=  G11C
          G12A=  G12C
          G22A=  G22C
         KRAYC= KRAYB
        ITYPEC=ITYPEB
          ISHC=  ISHB
           G1C=   G1B
           G2C=   G2B
          G11C=  G11B
          G12C=  G12B
          G22C=  G22B
         KRAYB= KRAYD
        ITYPEB=ITYPED
          ISHB=  ISHD
           G1B=   G1D
           G2B=   G2D
          G11B=  G11D
          G12B=  G12D
          G22B=  G22D
      ENDIF
C     Proposing the ray parameters of a new ray:
      G1NEW=(G1A+G1B)/2.
      G2NEW=(G2A+G2B)/2.
      IF (((G1NEW.EQ.G1A).AND.(G2NEW.EQ.G2A)).OR.
     *    ((G1NEW.EQ.G1B).AND.(G2NEW.EQ.G2B))) CALL RPERR(3)
C
C     Checking whether the ray has not yet been computed:
  2   CONTINUE
      IF (NDRAYS.GT.0) THEN
        IF ((G1NEW.NE.GLIMIT(1)).AND.(G1NEW.NE.GLIMIT(2)).AND.
     *      (G2NEW.NE.GLIMIT(3)).AND.(G2NEW.NE.GLIMIT(4))) THEN
          DO 5, I1=1,NDRAYS
            CALL RPRAY(KDRAYS(I1),LRAY,ITYPED,ISHD,G1D,G2D,
     *                G11G,G12G,G22G,X1,X2,G1X1,G2X1,G1X2,G2X2)
            IF (.NOT.LRAY) THEN
              DO 3, I2=I1,NDRAYS-1
                KDRAYS(I2)=KDRAYS(I2+1)
  3           CONTINUE
              NDRAYS=NDRAYS-1
              GOTO 2
            ENDIF
            IF ((ABS(G1D-G1NEW).LT.ZERO).AND.
     *          (ABS(G2D-G2NEW).LT.ZERO)) THEN
C             New ray found in the array KDRAYS:
              KRAYD=KDRAYS(I1)
              DO 4, I2=I1,NDRAYS-1
                KDRAYS(I2)=KDRAYS(I2+1)
 4            CONTINUE
              NDRAYS=NDRAYS-1
              GOTO 21
            ENDIF
 5        CONTINUE
        ENDIF
      ENDIF
      LNEWAR=.TRUE.
      RETURN
C
C
  10  CONTINUE
      KRAYD=IRAY
      CALL RPRAY(IRAY,LRAY,ITYPED,ISHD,G1D,G2D,G11D,G12D,G22D,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
C     Checking whether the ray is to be stored to the array KDRAYS:
      IF (((G1A.NE.GLIMIT(1)).OR.(G1B.NE.GLIMIT(1))).AND.
     *    ((G1A.NE.GLIMIT(2)).OR.(G1B.NE.GLIMIT(2))).AND.
     *    ((G2A.NE.GLIMIT(3)).OR.(G2B.NE.GLIMIT(3))).AND.
     *    ((G2A.NE.GLIMIT(4)).OR.(G2B.NE.GLIMIT(4)))) THEN
        NDRAYS=NDRAYS+1
        IF (NDRAYS.GT.MDRAYS) THEN
C         RP3D-023
          CALL ERROR('RP3D-023: Insufficient memory for KDRAYS.')
C         This error may be caused by too small dimension of array
C         KDRAYS. Try to enlarge the parameter MDRAYS in common block
C         DRAYS in file
C         rp3d.inc.
        ENDIF
        KDRAYS(NDRAYS)=KRAYD
      ENDIF
C
C     When the ray D is on the sides of the basic triangle which
C     contains the divided triangle, storing it to the KBR:
      IF (KTRID(5).NE.0) THEN
        CALL RPTRI3(KTRID(5),LTRI,KTRIS)
        IF (.NOT.LTRI) CALL RPERR(2)
      ELSE
        KTRIS(1)=KTRID(1)
        KTRIS(2)=KTRID(2)
        KTRIS(3)=KTRID(3)
      ENDIF
      CALL RPRAY(KTRIS(1),LRAY,ITYPE,ISH,G1I,G2I,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISH,G1J,G2J,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1K,G2K,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      IF (RPLRIL(G1D,G2D,G1K,G2K,G1I,G2I)) THEN
C       Boundary rays are lying on the side IK (side 3,1):
        KRAYI=KTRIS(1)
        KRAYJ=KTRIS(3)
      ELSEIF (RPLRIL(G1D,G2D,G1I,G2I,G1J,G2J)) THEN
C       Boundary rays are lying on the side IJ (side 1,2):
        KRAYI=KTRIS(2)
        KRAYJ=KTRIS(1)
      ELSEIF (RPLRIL(G1D,G2D,G1J,G2J,G1K,G2K)) THEN
C       Boundary rays are lying on the side JK (side 2,3):
        KRAYI=KTRIS(3)
        KRAYJ=KTRIS(2)
      ELSE
C       Ray is not on the sides of the basic triangle:
        GOTO 21
      ENDIF
      CALL RPKBR(KRAYI,KRAYJ,KRAYD)
C
  21  CONTINUE
      LNEWAR=.FALSE.
      IF (ISHD.EQ.ISHA) THEN
C       New triangles will be homogeneous:
        KTRIN(6)=3
      ELSE
C       A strange ray was identified inside the triangle.
C       New triangles will be inhomogeneous:
        KTRIN(6)=0
        LAB20=.TRUE.
      ENDIF
C     Now dividing the triangle KTRID into two new triangles:
      KTRID(6)=2
      IF (KTRID(5).EQ.0) THEN
        KTRIN(5)=KTRID(4)
      ELSE
        KTRIN(5)=KTRID(5)
      ENDIF
      CALL RPTRI2(KTRID(4),LTRI,KTRID)
      ITRI=ITRI+1
      KTRIN(1)=KRAYA
      KTRIN(2)=KRAYD
      KTRIN(3)=KRAYC
      KTRIN(4)=ITRI
      CALL RPTRI1(ITRI,KTRIN)
      CALL RPSTOR('T',1,KTRIN)
      ITRI=ITRI+1
      KTRIN(1)=KRAYD
      KTRIN(2)=KRAYB
      KTRIN(3)=KRAYC
      KTRIN(4)=ITRI
      CALL RPTRI1(ITRI,KTRIN)
      CALL RPSTOR('T',1,KTRIN)
C
      IF ((ITYPEA.GT.0).AND.(ITYPEB.GT.0)) THEN
C       Confirmation that the previous triangles
C       have been formed correctly:
        CALL RPTRIP(-ITRI+2,LTRI,KTRIS)
C       Loop for all the triangles in the memory:
  20    CONTINUE
          CALL RPTRIP(0,LTRI,KTRIS)
          IF (LTRI) THEN
            IF (KTRIS(6).EQ.2) GOTO 20
            IF (KTRIS(4).EQ.ITRI) GOTO 20
            IF (KTRIS(4).EQ.ITRI-1) GOTO 20
            DO 30, I2=1,3
              CALL RPRAY(KTRIS(I2),LRAY,ITYPEG,ISHG,G1G,G2G,
     *                  G11G,G12G,G22G,X1,X2,G1X1,G2X1,G1X2,G2X2)
              IF (.NOT.LRAY) CALL RPERR(1)
              G11POM=(G11A+G11G)/2.
              G12POM=(G12A+G12G)/2.
              G22POM=(G22A+G22G)/2.
              DIST2=RPDI2G(G1A,G2A,G1G,G2G,G11POM,G12POM,G22POM)
              IF (DIST2.LE.AERR2) THEN
                IF (KRAYA.EQ.KTRIS(I2)) GOTO 20
                DO 40, I3=1,3
                  IF (I3.EQ.I2) GOTO 40
                  CALL RPRAY(KTRIS(I3),LRAY,ITYPEG,ISHG,G1G,G2G,
     *                 G11G,G12G,G22G,X1,X2,G1X1,G2X1,G1X2,G2X2)
                  IF (.NOT.LRAY) CALL RPERR(1)
                  G11POM=(G11B+G11G)/2.
                  G12POM=(G12B+G12G)/2.
                  G22POM=(G22B+G22G)/2.
                  DIST2=RPDI2G(G1B,G2B,G1G,G2G,G11POM,G12POM,G22POM)
                  IF (DIST2.LE.AERR2) THEN
                    IF (KRAYB.EQ.KTRIS(I3)) GOTO 20
C                   Triangle KTRIS must be divided:
                    KTRIS(6)=2
                    CALL RPTRI2(KTRIS(4),LTRI,KTRIS)
                    IF (.NOT.LTRI) CALL RPERR(2)
                    ITRI=ITRI+1
                    KTRIN(1)=KTRIS(1)
                    KTRIN(2)=KTRIS(2)
                    KTRIN(3)=KTRIS(3)
                    KTRIN(I2)=KRAYD
                    KTRIN(4)=ITRI
                    IF (KTRIS(5).EQ.0) THEN
                      KTRIN(5)=KTRIS(4)
                    ELSE
                      KTRIN(5)=KTRIS(5)
                    ENDIF
                    KTRIN(6)=0
                    CALL RPTRI1(ITRI,KTRIN)
                    CALL RPSTOR('T',1,KTRIN)
                    ITRI=ITRI+1
                    KTRIN(1)=KTRIS(1)
                    KTRIN(2)=KTRIS(2)
                    KTRIN(3)=KTRIS(3)
                    KTRIN(I3)=KRAYD
                    KTRIN(4)=ITRI
                    CALL RPTRI1(ITRI,KTRIN)
                    CALL RPSTOR('T',1,KTRIN)
                    LAB20=.TRUE.
                    GOTO 50
                  ENDIF
  40            CONTINUE
              ENDIF
  30        CONTINUE
            GOTO 20
          ENDIF
C       End of the loop for all the triangles in the memory.
  50    CONTINUE
      ENDIF
      RETURN
      END
C
C=======================================================================
C
      LOGICAL FUNCTION RPLRIT(LRAY,S1A,S2A,S1B,S2B,S1C,S2C,S1X,S2X,AREA)
C
C----------------------------------------------------------------------
      REAL S1A,S2A,S1B,S2B,S1C,S2C,S1X,S2X,AREA
      LOGICAL LRAY
C In case LRAY=.TRUE. :
C Subroutine designed to decide, whether the ray X lies
C inside the triangle formed by rays A,B,C.
C In case LRAY=.FALSE. :
C Subroutine designed to decide, whether the triangle
C formed by rays A,B,C is right-handed.
C
C Cartesian metric tensor is used in both cases.
C
C Input:
C     LRAY... Says what to do.
C     S1A,S2A,B,C... Coordinates of rays forming the triangle.
C     S1X,S2X... Coordinates of fourth ray.
C
C Output:
C     RPLRIT... .TRUE.  Means yes, ray lies in the triangle or the
C                       triangle is right-handed.
C               .FALSE. Means no, the ray is not in the triangle or the
C                       triangle is left-handed.
C     AREA... Area of the triangle.
C
C Coded by Petr Bulant
C
      INCLUDE 'rpard.inc'
C     rpard.inc
C
C......................................................................
      REAL ZERO,ZERO1
      PARAMETER (ZERO =.0000001)
      PARAMETER (ZERO1=.0000000001)
      REAL AREA1,AREA2,AREA3
C     ZERO... Constant used to decide whether the AREAI .EQ. zero.
C     AREA1,2,3... Auxiliary variables used when examining whether the
C             ray X lies in triangle.
C-----------------------------------------------------------------------
      IF (.NOT.LRAY) THEN
        AREA=((S1B-S1A)*(S2C-S2A)-(S1C-S1A)*(S2B-S2A))/2.
        IF (AREA.LT.ZERO) AREA=0.
C       Triangle too small, it will be treated as left-handed.
        IF (AREA.GT.0.) THEN
C         Triangle A,B,C is right-handed.
          RPLRIT=.TRUE.
        ELSE
          RPLRIT=.FALSE.
        ENDIF
      ELSE
        IF (((S1A.EQ.S1X).AND.(S2A.EQ.S2X)).OR.
     *      ((S1B.EQ.S1X).AND.(S2B.EQ.S2X)).OR.
     *      ((S1C.EQ.S1X).AND.(S2C.EQ.S2X))) THEN
          RPLRIT=.TRUE.
        ELSE
          AREA1=(S1B-S1X)*(S2C-S2X)-(S1C-S1X)*(S2B-S2X)
          IF (ABS(AREA1).LT.ZERO1) AREA1=0.
          AREA2=(S1C-S1X)*(S2A-S2X)-(S1A-S1X)*(S2C-S2X)
          IF (ABS(AREA2).LT.ZERO1) AREA2=0.
          AREA3=(S1A-S1X)*(S2B-S2X)-(S1B-S1X)*(S2A-S2X)
          IF (ABS(AREA3).LT.ZERO1) AREA3=0.
          IF (((AREA1.GE.0.).AND.(AREA2.GE.0.).AND.(AREA3.GE.0.)).OR.
     *        ((AREA1.LE.0.).AND.(AREA2.LE.0.).AND.(AREA3.LE.0.))) THEN
C           Ray X lies in the triangle A,B,C.
            RPLRIT=.TRUE.
          ELSE
            RPLRIT=.FALSE.
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END
C
C=======================================================================
C
      LOGICAL FUNCTION RPLRIP(NPOL,GPOL,G1X,G2X)
C
C----------------------------------------------------------------------
      INTEGER MPOL,NPOL
C                                                   
      PARAMETER (MPOL=500)
      REAL GPOL(MPOL,2)
      REAL G1X,G2X
C Subroutine designed to decide, whether the ray X lies in the polygon
C formed by rays stored in GPOL.
C
C Cartesian metric tensor is used.
C
C Input:
C     NPOL... Number of rays forming the polygon GPOL.
C     GPOL(I,1),GPOL(I,2)... Normalized parameters of rays forming
C             the polygon.
C     G1X,G2X... Normalized parameters of the examined ray.
C
C Output:
C     RPLRIP... .TRUE.  Means yes, ray lies in the polygon.
C               .FALSE. Means no, the ray is not in the polygon.
C
C Subroutines and external functions required:
      EXTERNAL RPLRIL
      LOGICAL RPLRIL
C
C Coded by Petr Bulant
C
C......................................................................
      REAL ZERO
      PARAMETER (ZERO=.0000001)
      INTEGER INTERS
      REAL G1A,G2A,G1B,G2B,G1P
      REAL SMER1,SMER2
      INTEGER I1,I2,J1,J2
C     INTERS... Counts the intersection points.
C     SMER1,2... The direction of a line.
C-----------------------------------------------------------------------
      INTERS=0
      I1=NPOL
      I2=1
C     Loop for all the sides of the polygon:
  10  CONTINUE
        G1A=GPOL(I1,1)
        G2A=GPOL(I1,2)
        G1B=GPOL(I2,1)
        G2B=GPOL(I2,2)
        IF ((G2A.GT.G2X).AND.(G2B.GT.G2X)) GOTO 100
        IF ((G2A.LT.G2X).AND.(G2B.LT.G2X)) GOTO 100
        IF ((G1A.LT.G1X).AND.(G1B.LT.G1X)) GOTO 100
        IF (ABS(G1A-G1B).LT.ZERO) THEN
          IF (G2A.LT.G2B) THEN
            SMER1=999.
          ELSEIF (G2A.GT.G2B) THEN
            SMER1=-999.
          ELSE
            SMER1=0.
          ENDIF
        ELSE
          SMER1=(G2B-G2A)/(G1B-G1A)
        ENDIF
        IF (SMER1.EQ.0.) GOTO 100
        IF ((G1A.GE.G1X).AND.(G1B.GE.G1X)) THEN
          IF ((ABS(G1A-G1X).LT.ZERO).AND.(ABS(G1B-G1X).LT.ZERO)) THEN
            RPLRIP=.TRUE.
            RETURN
          ENDIF
          INTERS=INTERS+1
          IF (ABS(G2B-G2X).LT.ZERO) THEN
            J1=I2
            J2=I2+1
            IF (I2.EQ.NPOL) J2=1
  20        CONTINUE
            IF (ABS(GPOL(J1,1)-GPOL(J2,1)).LT.ZERO) THEN
              IF (GPOL(J1,2).LT.GPOL(J2,2)) THEN
                SMER2=999.
              ELSEIF (GPOL(J1,2).GT.GPOL(J2,2)) THEN
                SMER2=-999.
              ELSE
                SMER2=0.
              ENDIF
            ELSE
              SMER2=(GPOL(J2,2)-GPOL(J1,2))/(GPOL(J2,1)-GPOL(J1,1))
            ENDIF
            IF (SMER2.EQ.0) THEN
              I2=I2+1
              IF (I2.EQ.NPOL) THEN
                J1=NPOL
                J2=1
                GOTO 20
              ENDIF
              IF (I2.GT.NPOL) THEN
                J1=J2
                J2=J2+1
                GOTO 20
              ENDIF
            ENDIF
            IF (SMER1*SMER2.GT.0.) THEN
              I2=I2+1
            ENDIF
          ENDIF
        ELSE
          G1P=G1A+((G1B-G1A)/(G2B-G2A))*(G2X-G2A)
          IF (ABS(G1P-G1X).LT.ZERO) THEN
            RPLRIP=.TRUE.
            RETURN
          ENDIF
          IF (G1P.GE.G1X) INTERS=INTERS+1
        ENDIF
  100 CONTINUE
      I1=I2
      I2=I2+1
      IF (I2.LE.NPOL) GOTO 10
C
      IF (MOD(INTERS,2).EQ.0) THEN
        RPLRIP=.FALSE.
      ELSE
        RPLRIP=.TRUE.
      ENDIF
      RETURN
      END
C
C=======================================================================
C
      REAL FUNCTION RPDI2G(G1A,G2A,G1B,G2B,G11,G12,G22)
C
C----------------------------------------------------------------------
      REAL G1A,G2A,G1B,G2B,G11,G12,G22
C Subroutine designed to compute the second power of the distance
C between two rays A and B on the normalized ray domain using metric
C tensor of components G11, G12, G22.
C
C Input:
C     G1A,G2A,B,C... Coordinates of the two rays.
C     G11,G12,G22... Components of the metric tensor.
C
C Output:
C     RPDI2G... Distance of the rays.
C
C Coded by Petr Bulant
C
C......................................................................
      REAL DG1,DG2,AAA,BBB
C-----------------------------------------------------------------------
      DG1=G1A-G1B
      DG2=G2A-G2B
      AAA=G11*DG1+G12*DG2
      BBB=G12*DG1+G22*DG2
      RPDI2G=DG1*AAA + DG2*BBB
      END
C
C=======================================================================
C
      LOGICAL FUNCTION RPLRIL(G1A,G2A,G1B,G2B,G1C,G2C)
C
C----------------------------------------------------------------------
      REAL G1A,G2A,G1B,G2B,G1C,G2C
C
C Subroutine designed to decide whether the ray A lies on the abscissa
C formed by the rays B and C.
C
C Cartesian metric is used.
C
C Input:  coordinates of the three points.
C
C Output: RPLRIL... Indicates whether the ray is on the abscissa.
C
C Coded by Petr Bulant
C
C.......................................................................
      REAL ZERO
      PARAMETER (ZERO=.0000001)
      REAL A,B,C,D
C     ZERO... Constant used to decide whether the real variable.EQ.zero.
C     A,B,C,D... Auxiliary variables.
C-----------------------------------------------------------------------
C
      RPLRIL=.FALSE.
      A=(G2A-G2B)
      B=(G1C-G1B)
      C=(G1A-G1B)
      D=(G2C-G2B)
      IF (C.EQ.0.) THEN
        IF (A.EQ.0.) RPLRIL=.TRUE.
      ELSEIF (D.EQ.0.) THEN
        IF (C.EQ.0.) RPLRIL=.TRUE.
      ELSE
        IF (ABS(A*B-C*D).LE.ZERO) THEN
          IF ((G2A.GE.AMIN1(G2B,G2C)).AND.(G2A.LE.AMAX1(G2B,G2C)).AND.
     *        (G1A.GE.AMIN1(G1B,G1C)).AND.(G1A.LE.AMAX1(G1B,G1C)))
     *         RPLRIL=.TRUE.
        ENDIF
      ENDIF
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RPCROS(G1A,G2A,G1B,G2B,G1C,G2C,G1D,G2D,LINTS,G1X,G2X)
C
C----------------------------------------------------------------------
      REAL G1A,G2A,G1B,G2B,G1C,G2C,G1D,G2D,G1X,G2X
      LOGICAL LINTS
C
C This subroutine looks for the intersection point of abscissa A-B
C with the abscissa C-D. If the intersection appears, it computes the
C coordinates of the intersection point.
C
C Cartesian metric is used.
C
C Input:  coordinates of the four points.
C
C Output: LINTS... Indicates whether the intersection appeared.
C         G1X,G2X... Coordinates of the intersection point (if any).
C
C Coded by Petr Bulant
C
C.......................................................................
      REAL ZERO,ZERO1
      PARAMETER (ZERO=.0000001)
      PARAMETER (ZERO1=.0000000001)
      REAL AAA,BBB,PART
      REAL A,B,C,D
C     ZERO1... Constant used to decide whether the real variable.EQ.0.
C     AAA,BBB,PART,A,B,C,D... Auxiliary variables.
C-----------------------------------------------------------------------
C
      IF (ABS(G1A-G1B).LT.ZERO) THEN
        IF (ABS(G1D-G1C).LT.ABS(G1A-G1C)) GOTO 118
        IF (ABS(G1D-G1C).LT.ZERO) THEN
          IF (G1A.NE.G1C) GOTO 118
          IF ((G2A.GE.AMIN1(G2C,G2D)).AND.(G2A.LE.AMAX1(G2C,G2D))) THEN
            G1X=G1A
            G2X=G2A
            GOTO 114
          ENDIF
          IF ((G2B.GE.AMIN1(G2C,G2D)).AND.(G2B.LE.AMAX1(G2C,G2D))) THEN
            G1X=G1B
            G2X=G2B
            GOTO 114
          ENDIF
          GOTO 118
        ENDIF
        PART=(G1A-G1C)/(G1D-G1C)
        IF ((PART.GE.0.).AND.(PART.LE.1.)) THEN
          G1X=G1A
          G2X=G2C+PART*(G2D-G2C)
          IF ((G2X.LT.AMIN1(G2A,G2B)).OR.(G2X.GT.AMAX1(G2A,G2B)))
     *      GOTO 118
          GOTO 114
        ELSE
          GOTO 118
        ENDIF
      ELSEIF (ABS(G2A-G2B).LT.ZERO) THEN
        IF (ABS(G2D-G2C).LT.ABS(G2A-G2C)) GOTO 118
        IF (ABS(G2D-G2C).LT.ZERO) THEN
          IF (G2A.NE.G2C) GOTO 118
          IF ((G1A.GE.AMIN1(G1C,G1D)).AND.(G1A.LE.AMAX1(G1C,G1D))) THEN
            G1X=G1A
            G2X=G2A
            GOTO 114
          ENDIF
          IF ((G1B.GE.AMIN1(G1C,G1D)).AND.(G1B.LE.AMAX1(G1C,G1D))) THEN
            G1X=G1B
            G2X=G2B
            GOTO 114
          ENDIF
          GOTO 118
        ENDIF
        PART=(G2A-G2C)/(G2D-G2C)
        IF ((PART.GE.0.).AND.(PART.LE.1.)) THEN
          G2X=G2A
          G1X=G1C+PART*(G1D-G1C)
          IF ((G1X.LT.AMIN1(G1A,G1B)).OR.(G1X.GT.AMAX1(G1A,G1B)))
     *      GOTO 118
          GOTO 114
        ELSE
          GOTO 118
        ENDIF
      ELSE
        AAA=(G1D-G1C)*(G2B-G2A)-(G2D-G2C)*(G1B-G1A)
        BBB=(G1B-G1A)*(G2C-G2A)-(G2B-G2A)*(G1C-G1A)
        IF (ABS(AAA).LT.ZERO1) AAA=0.
        IF (ABS(BBB).LT.ZERO1) BBB=0.
        IF ((AAA.EQ.0.).AND.(BBB.EQ.0.)) THEN
          IF((G1A.GE.AMIN1(G1C,G1D)).AND.(G1A.LE.AMAX1(G1C,G1D)))THEN
            G1X=G1A
            G2X=G2A
            GOTO 114
          ENDIF
          IF (((G1C.GE.AMIN1(G1A,G1B)).AND.(G1C.LE.AMAX1(G1A,G1B))).
     *    AND.((G1D.GE.AMIN1(G1A,G1B)).AND.(G1D.LE.AMAX1(G1A,G1B))))
     *        THEN
            IF (ABS(G1A-G1C).LT.ABS(G1A-G1D)) THEN
              G1X=G1C
              G2X=G2C
              GOTO 114
            ELSE
              G1X=G1D
              G2X=G2D
              GOTO 114
            ENDIF
          ENDIF
          IF((G1C.GE.AMIN1(G1A,G1B)).AND.(G1C.LE.AMAX1(G1A,G1B)))THEN
            G1X=G1C
            G2X=G2C
            GOTO 114
          ELSEIF((G1D.GE.AMIN1(G1A,G1B)).AND.(G1D.LE.AMAX1(G1A,G1B)))
     *      THEN
            G1X=G1D
            G2X=G2D
            GOTO 114
          ELSE
            GOTO 118
          ENDIF
        ELSEIF (BBB.EQ.0.) THEN
          IF((G1C.GE.AMIN1(G1A,G1B)).AND.(G1C.LE.AMAX1(G1A,G1B)))THEN
            G1X=G1C
            G2X=G2C
            GOTO 114
          ELSE
            GOTO 118
          ENDIF
        ELSEIF (AAA.EQ.0.) THEN
          GOTO 118
        ELSEIF (ABS(AAA).LT.ABS(BBB)) THEN
          GOTO 118
        ELSE
          PART=BBB/AAA
          IF ((PART.LT.0.).OR.(PART.GT.1.)) GOTO 118
          G1X=G1C+PART*(G1D-G1C)
          IF ((G1X.LT.AMIN1(G1A,G1B)).OR.(G1X.GT.AMAX1(G1A,G1B)))
     *      GOTO 118
          G2X=G2C+PART*(G2D-G2C)
        ENDIF
      ENDIF
  114 CONTINUE
      LINTS=.TRUE.
C     Correcting the coordinates of the intersection point:
      A=(G2X-G2C)
      B=(G1D-G1C)
      C=(G1X-G1C)
      D=(G2D-G2C)
      IF (ABS(B).GT.ZERO) THEN
        G2X=(C*D)/B+G2C
      ELSEIF (ABS(D).GT.ZERO) THEN
        G1X=(A*B)/D+G1C
      ELSE
        G1X=(G1C+G1D)/2.
        G2X=(G2C+G2D)/2.
      ENDIF
      RETURN
  118 CONTINUE
      LINTS=.FALSE.
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RPXMEA(JTRI,ITRI,IRAY,LNEWAR,
     *                  LAB20,G1NEW,G2NEW)
C
C----------------------------------------------------------------------
C Subroutine designed to measure the sides of the triangle JTRI in the
C reference surface and to divide this triangle if it is too large.
C
      INTEGER JTRI,ITRI,IRAY
      LOGICAL LNEWAR,LAB20
      REAL G1NEW,G2NEW
C Input:
C     JTRI... Index of the measured triangle.
C     ITRI... Index of last computed triangle.
C     IRAY... Index of last computed ray.
C     LNEWAR... Indicates whether the new auxiliary ray was computed.
C Output:
C     LNEWAR... Indicates whether the new auxiliary ray is to be computed.
C     LAB20... Indicates that inhomogeneous triangles have been formed
C             running RPXMEA.
C     G1NEW,G2NEW... Coordinates of the new ray.
C
C Subroutines and external functions required:
      EXTERNAL RPDI2G,RPLRIL
      REAL RPDI2G
      LOGICAL RPLRIL
C
C Coded by Petr Bulant
C
C.......................................................................
C Common block /RPARD/:
      INCLUDE 'rpard.inc'
C     rpard.inc
C     AERR... The distance of boundary rays.
C     PRM0(2)... Maximum allowed length of the homogeneous triangles
C             sides (measured on the reference surface).
C............................
C
C Common block /BOURA/ and /DRAYS/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C
C.......................................................................
      REAL ZERO
      PARAMETER (ZERO =.0000001)
      INTEGER KTRID(6),KTRIN(6),KTRIS(6)
      INTEGER KRAYA,ITYPEA,ISHA
      REAL G1A,G2A,G11A,G12A,G22A,X1A,X2A,G1X1A,G2X1A,G1X2A,G2X2A
      INTEGER KRAYB,ITYPEB,ISHB
      REAL G1B,G2B,G11B,G12B,G22B,X1B,X2B,G1X1B,G2X1B,G1X2B,G2X2B
      INTEGER KRAYC,ITYPEC,ISHC
      REAL G1C,G2C,G11C,G12C,G22C,X1C,X2C,G1X1C,G2X1C,G1X2C,G2X2C
      INTEGER KRAYD,ITYPED,ISHD
      REAL G1D,G2D
      INTEGER KRAYI,KRAYJ,ITYPE,ISH
      REAL G1I,G2I,G1J,G2J,G1K,G2K
      REAL G11,G12,G22
      REAL X1,X2,G1X1,G2X1,G1X2,G2X2
      REAL AREA,AERR2,PRM022
      REAL G11POM,G12POM,G22POM
      REAL DG1,DG2,DETG
      REAL DIST2A,DIST2B,DIST2C
      INTEGER I1,I2
      LOGICAL LRAY,LTRI
      SAVE KRAYA,KRAYB,KRAYC,ISHA,KTRID,AERR2,PRM022
C     ZERO... Constant used to decide whether the real variable .EQ. zero.
C     KTRID... Parameters of the triangle to be measured.
C     KTRIN... Parameters of the new triangle to be registrated
C             (new column to be added into array KTRI).
C     KTRIS... Parameters of the examined triangle.
C     G1X1,G2X1,G1X2,G2X2... Derivatives.
C     KRAYA,(B),(C).... Signs of rays            |   Auxiliary
C     ITYPEA,(B),(C)... Types of rays            |   variables used
C     ISHA,(B),(C)... Value of history function  |   for different rays.
C     GiA,(B),(C)... Parameters of rays          |
C     AREA... Auxiliary variable (area of the triangle).
C     DIST2A,B,C... Auxiliary variables (second powers of the lengths
C             of the triangle sides).
C     AERR2... Second power of the distance of boundary rays.
C     PRM022... Second power of the parameter PRM0(2).
C     GiiPOM... Auxiliary variables (metric tensor).
C     DG1,DG2,DIST2... Auxiliary variables.
C     DETG... Determinant.
C     I1,2,3.. Implied-do variables or variables controlling the loop.
C     LRAY... Indicates whether the ray IRAY is in memory.
C     LTRI... Indicates whether the triangle ITRI is in memory.
C-----------------------------------------------------------------------
C
      IF (IRAY.EQ.0) THEN
        AERR2=AERR**2
        PRM022=PRM0(2)**2
        NDRAYS=0
      ENDIF
C
      IF (LNEWAR) GOTO 10
C
      CALL RPTRI3(JTRI,LTRI,KTRID)
      IF ((.NOT.LTRI).OR.(KTRID(6).NE.3)) THEN
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C     Calculating lengths of the triangle's sides:
      KRAYA=KTRID(1)
      CALL RPRAY(KTRID(1),LRAY,ITYPEA,ISHA,G1A,G2A,G11A,G12A,G22A,
     *           X1A,X2A,G1X1A,G2X1A,G1X2A,G2X2A)
      IF (.NOT.LRAY) CALL RPERR(1)
      IF (ISHA.LE.0) THEN
        LNEWAR=.FALSE.
        RETURN
      ENDIF
      KRAYB=KTRID(2)
      CALL RPRAY(KTRID(2),LRAY,ITYPEB,ISHB,G1B,G2B,G11B,G12B,G22B,
     *           X1B,X2B,G1X1B,G2X1B,G1X2B,G2X2B)
      IF (.NOT.LRAY) CALL RPERR(1)
      KRAYC=KTRID(3)
      CALL RPRAY(KTRID(3),LRAY,ITYPEC,ISHC,G1C,G2C,G11C,G12C,G22C,
     *           X1C,X2C,G1X1C,G2X1C,G1X2C,G2X2C)
      IF (.NOT.LRAY) CALL RPERR(1)
      IF ((ISHA.NE.ISHB).OR.(ISHA.NE.ISHC)) THEN
        KTRID(6)=0
        CALL RPTRI2(KTRID(4),LTRI,KTRID)
        IF (.NOT.LTRI) CALL RPERR(2)
        LAB20=.TRUE.
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C     ..A,..B,..C .. Vertices of measured triangle.
C     Controlling the size of triangle surface :
      G11POM=(G11A+G11C+G11B)/3.
      G12POM=(G12A+G12C+G12B)/3.
      G22POM=(G22A+G22C+G22B)/3.
      DG1=G1B-G1A
      DG2=G2B-G2A
      DETG=G11POM*G22POM - G12POM*G12POM
      IF (DETG.LT.ZERO) CALL RPERR(4)
      AREA=SQRT(DETG)*((DG1*(G2C-G2A)-DG2*(G1C-G1A))*.5)
      IF (AREA.LT.(AERR2*0.4330127)) THEN
C       0.4330127=Sqrt(3)/4
C       Triangle too small, it is not to be divided:
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C     Measuring the size of triangle sides using matrix G:
      G11POM=(G11A+G11B)/2.
      G12POM=(G12A+G12B)/2.
      G22POM=(G22A+G22B)/2.
      DIST2A=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
      G11POM=(G11B+G11C)/2.
      G12POM=(G12B+G12C)/2.
      G22POM=(G22B+G22C)/2.
      DIST2B=RPDI2G(G1B,G2B,G1C,G2C,G11POM,G12POM,G22POM)
      G11POM=(G11A+G11C)/2.
      G12POM=(G12A+G12C)/2.
      G22POM=(G22A+G22C)/2.
      DIST2C=RPDI2G(G1A,G2A,G1C,G2C,G11POM,G12POM,G22POM)
C
      IF ((DIST2A.LE.AERR2).OR.(DIST2B.LE.AERR2).OR.
     *    (DIST2C.LE.AERR2)) THEN
C       Triangle too small, it is not to be divided:
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C
C
C     Measuring the size of triangle sides on the reference surface:
      DIST2A=((X1B-X1A)**2+(X2B-X2A)**2)
      DIST2B=((X1C-X1B)**2+(X2C-X2B)**2)
      DIST2C=((X1A-X1C)**2+(X2A-X2C)**2)
C
      IF ((DIST2A.LE.PRM022).AND.(DIST2B.LE.PRM022).AND.
     *    (DIST2C.LE.PRM022)) THEN
C       The triangle is O.K.
        RETURN
      ENDIF
C
C     Choosing the longest side to be divided:
      IF ((DIST2A.GE.DIST2B).AND.(DIST2A.GE.DIST2C)) THEN
C       No action.
      ELSEIF ((DIST2B.GE.DIST2A).AND.(DIST2B.GE.DIST2C)) THEN
         KRAYD= KRAYA
          ISHD=  ISHA
           G1D=   G1A
           G2D=   G2A
         KRAYA= KRAYB
          ISHA=  ISHB
           G1A=   G1B
           G2A=   G2B
         KRAYB= KRAYC
          ISHB=  ISHC
           G1B=   G1C
           G2B=   G2C
         KRAYC= KRAYD
          ISHC=  ISHD
           G1C=   G1D
           G2C=   G2D
      ELSEIF ((DIST2C.GE.DIST2A).AND.(DIST2C.GE.DIST2B)) THEN
         KRAYD= KRAYA
          ISHD=  ISHA
           G1D=   G1A
           G2D=   G2A
         KRAYA= KRAYC
          ISHA=  ISHC
           G1A=   G1C
           G2A=   G2C
         KRAYC= KRAYB
          ISHC=  ISHB
           G1C=   G1B
           G2C=   G2B
         KRAYB= KRAYD
          ISHB=  ISHD
           G1B=   G1D
           G2B=   G2D
      ENDIF
C     Proposing the ray parameters of a new ray:
      G1NEW=(G1A+G1B)/2.
      G2NEW=(G2A+G2B)/2.
      IF (((G1NEW.EQ.G1A).AND.(G2NEW.EQ.G2A)).OR.
     *    ((G1NEW.EQ.G1B).AND.(G2NEW.EQ.G2B))) CALL RPERR(3)
C
C     Checking whether the ray has not yet been computed:
  2   CONTINUE
      IF (NDRAYS.GT.0) THEN
        DO 5, I1=1,NDRAYS
          CALL RPRAY(KDRAYS(I1),LRAY,ITYPED,ISHD,G1D,G2D,
     *              G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) THEN
            DO 3, I2=I1,NDRAYS-1
              KDRAYS(I2)=KDRAYS(I2+1)
  3         CONTINUE
            NDRAYS=NDRAYS-1
            GOTO 2
          ENDIF
          IF ((ABS(G1D-G1NEW).LT.ZERO).AND.
     *        (ABS(G2D-G2NEW).LT.ZERO)) THEN
C           New ray found in the array KDRAYS:
            KRAYD=KDRAYS(I1)
            DO 4, I2=I1,NDRAYS-1
              KDRAYS(I2)=KDRAYS(I2+1)
 4          CONTINUE
            NDRAYS=NDRAYS-1
            GOTO 21
          ENDIF
 5      CONTINUE
      ENDIF
      LNEWAR=.TRUE.
      RETURN
C
C
  10  CONTINUE
      KRAYD=IRAY
      CALL RPRAY(IRAY,LRAY,ITYPED,ISHD,G1D,G2D,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
C     The ray is to be stored to the array KDRAYS:
      NDRAYS=NDRAYS+1
      IF (NDRAYS.GT.MDRAYS) THEN
C         RP3D-025
          CALL ERROR('RP3D-025: Insufficient memory for KDRAYS.')
C         This error may be caused by too small dimension of array
C         KDRAYS. Try to enlarge the parameter MDRAYS in common block
C         DRAYS in file
C         rp3d.inc.
      ENDIF
      KDRAYS(NDRAYS)=KRAYD
C
C     When the ray D is on the sides of the basic triangle which
C     contains the divided triangle, storing it to the KBR:
      IF (KTRID(5).NE.0) THEN
        CALL RPTRI3(KTRID(5),LTRI,KTRIS)
        IF (.NOT.LTRI) CALL RPERR(2)
      ELSE
        KTRIS(1)=KTRID(1)
        KTRIS(2)=KTRID(2)
        KTRIS(3)=KTRID(3)
      ENDIF
      CALL RPRAY(KTRIS(1),LRAY,ITYPE,ISH,G1I,G2I,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISH,G1J,G2J,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1K,G2K,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      IF (RPLRIL(G1D,G2D,G1K,G2K,G1I,G2I)) THEN
C       Boundary rays are lying on the side IK (side 3,1):
        KRAYI=KTRIS(1)
        KRAYJ=KTRIS(3)
      ELSEIF (RPLRIL(G1D,G2D,G1I,G2I,G1J,G2J)) THEN
C       Boundary rays are lying on the side IJ (side 1,2):
        KRAYI=KTRIS(2)
        KRAYJ=KTRIS(1)
      ELSEIF (RPLRIL(G1D,G2D,G1J,G2J,G1K,G2K)) THEN
C       Boundary rays are lying on the side JK (side 2,3):
        KRAYI=KTRIS(3)
        KRAYJ=KTRIS(2)
      ELSE
C       Ray is not on the sides of the basic triangle:
        GOTO 21
      ENDIF
      CALL RPKBR(KRAYI,KRAYJ,KRAYD)
C
  21  CONTINUE
      LNEWAR=.FALSE.
      IF (ISHD.EQ.ISHA) THEN
C       New triangles will be homogeneous:
        KTRIN(6)=3
      ELSE
C       A strange ray was identified inside the triangle.
C       New triangles will be inhomogeneous:
        KTRIN(6)=0
        LAB20=.TRUE.
      ENDIF
C     Now dividing the triangle KTRID into two new triangles:
      KTRID(6)=2
      CALL RPTRI2(KTRID(4),LTRI,KTRID)
      ITRI=ITRI+1
      KTRIN(1)=KRAYA
      KTRIN(2)=KRAYD
      KTRIN(3)=KRAYC
      KTRIN(4)=ITRI
      IF (KTRID(5).EQ.0) THEN
        KTRIN(5)=KTRID(4)
      ELSE
        KTRIN(5)=KTRID(5)
      ENDIF
      CALL RPTRI1(ITRI,KTRIN)
      CALL RPSTOR('T',1,KTRIN)
      ITRI=ITRI+1
      KTRIN(1)=KRAYD
      KTRIN(2)=KRAYB
      KTRIN(3)=KRAYC
      KTRIN(4)=ITRI
      CALL RPTRI1(ITRI,KTRIN)
      CALL RPSTOR('T',1,KTRIN)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RPLRTC(G1NEW,G2NEW,KTRID,KRAYI,KRAYJ,IGOTO)
C
C----------------------------------------------------------------------
      REAL G1NEW,G2NEW
      INTEGER KTRID(6),KRAYI,KRAYJ,IGOTO
C Subroutine designed to decide, whether the ray NEW lies on the
C sides of the basic triangle containing the triangle KTRID.
C If so, the subroutine looks, whether the ray NEW lies on the
C boundary of the covered part of the normalized ray domain.
C
C Input:
C     G1NEW,G2NEW... Coordinates of the ray.
C     KTRID... All the parameters of the triangle.
C
C Output:
C     KRAYI,KRAYJ... Indices of the rays forming the side of the basic
C             triangle where the ray NEW lies.
C     IGOTO...1 in case that the ray NEW lies on the side of the
C               basic triangle, which contains the triangle KTRID,
C               and that the ray NEW lies on the polyline - boundary
C               of the covered part of the normalized ray domain.
C             0 otherwise.
C
C Coded by Petr Bulant
C
C Subroutines and external functions required:
      EXTERNAL RPLRIL
      LOGICAL RPLRIL
C......................................................................
C
C Common blocks /GLIM/ and /POLY/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C ...........................
      INTEGER KTRIS(6)
      INTEGER ITYPE,ISH
      REAL G1I,G2I,G1J,G2J,G1K,G2K
      REAL G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2
      INTEGER I1
      LOGICAL LTRI,LRAY
C......................................................................
      IF ((G1NEW.EQ.GLIMIT(1)).OR.(G1NEW.EQ.GLIMIT(2)).OR.
     *    (G2NEW.EQ.GLIMIT(3))) THEN
        IGOTO=1
        KRAYI=0
        RETURN
      ENDIF
      IF (KTRID(5).NE.0) THEN
        CALL RPTRI3(KTRID(5),LTRI,KTRIS)
        IF (.NOT.LTRI) CALL RPERR(2)
      ELSE
        KTRIS(1)=KTRID(1)
        KTRIS(2)=KTRID(2)
        KTRIS(3)=KTRID(3)
      ENDIF
      CALL RPRAY(KTRIS(1),LRAY,ITYPE,ISH,G1I,G2I,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISH,G1J,G2J,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1K,G2K,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      IF (RPLRIL(G1NEW,G2NEW,G1K,G2K,G1I,G2I)) THEN
C       New ray is lying on the side IK (side 3,1):
        KRAYI=KTRIS(1)
        KRAYJ=KTRIS(3)
      ELSEIF (RPLRIL(G1NEW,G2NEW,G1I,G2I,G1J,G2J)) THEN
C       New ray is lying on the side IJ (side 1,2):
        KRAYI=KTRIS(2)
        KRAYJ=KTRIS(1)
      ELSEIF (RPLRIL(G1NEW,G2NEW,G1J,G2J,G1K,G2K)) THEN
C       New ray is lying on the side JK (side 2,3):
        KRAYI=KTRIS(3)
        KRAYJ=KTRIS(2)
      ELSE
C       Ray is not on the sides of the basic triangle:
        IGOTO=0
        RETURN
      ENDIF
C     Loop for the rays on the boundary of the covered part
C     of the normalized ray domain:
      DO 10, I1=1,NPL-1
        IF (KPL(I1).EQ.KRAYI) THEN
          IF (KPL(I1+1).EQ.KRAYJ) THEN
C           Ray is on polyline:
            IGOTO=1
            RETURN
          ENDIF
        ENDIF
  10  CONTINUE
      IGOTO=0
      END
C
C=======================================================================
C
      SUBROUTINE RPDPA(G1C,G2C,G1A,G2A,G1B,G2B,G11,G12,G22,
     *                 VERTEX,G1X,G2X)
C
C----------------------------------------------------------------------
      REAL G1A,G2A,G1B,G2B,G1C,G2C,G11,G12,G22,G1X,G2X
      CHARACTER VERTEX
C
C This subroutine computes the normalized parameters of the ray X,
C which lies on the abscissa A-B and is nearest to the point C.
C
C Input:
C     G1C,G2C,G1A,G2A,G1B,G2B... Coordinates of the three points.
C     G11,G12,G22... Value of the symmetric metric tensor which is
C             to be used.
C
C Output:
C     VERTEX... Indicates the position of the nearest point:
C             'A'... Point A (vertex of the abscissa).
C             'B'... Point B (vertex of the abscissa).
C             'X'... Other point of the abscissa.
C     G1X,G2X... Coordinates of the nearest point.
C
C Subroutines and external functions required:
      EXTERNAL RPDI2G,RPLRIT,RPLRIP
      REAL RPDI2G
      LOGICAL RPLRIT,RPLRIP
C
C Coded by Petr Bulant
C
C.......................................................................
      REAL ZERO
      PARAMETER (ZERO=.0000001)
      REAL AAA,BBB,CCC,PAR
      REAL DIST2
      REAL A,B
C     ZERO... Constant used to decide whether the real variable.EQ.zero.
C     AAA,BBB,PART,A,B,C,D... Auxiliary variables.
C-----------------------------------------------------------------------
C
      A=(G1B-G1A)
      B=(G2B-G2A)
      AAA=A*G11+B*G12
      BBB=A*G12+B*G22
      CCC=-A*G11*G1C-A*G12*G2C-B*G12*G1C-B*G22*G2C
      DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11,G12,G22)
      IF (DIST2.LT.ZERO) THEN
        G1X=(G1A+G1B)/2.
        G2X=(G2A+G2B)/2.
        VERTEX='X'
        RETURN
      ENDIF
      PAR=(-CCC-G1A*AAA-G2A*BBB)/(A*AAA+B*BBB)
      IF (PAR.GT.1.) THEN
        G1X=G1B
        G2X=G2B
        VERTEX='B'
      ELSEIF (PAR.LT.0.) THEN
        G1X=G1A
        G2X=G2A
        VERTEX='A'
      ELSE
        G1X=G1A+PAR*A
        G2X=G2A+PAR*B
        VERTEX='X'
      ENDIF
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RPHPDI(NPOLH,KPOLH,GPOLH,IRAY,ITRI,KTRID,
     *                  LNEWAR,G1NEW,G2NEW)
C
C-----------------------------------------------------------------------
      INTEGER MPOLH
      PARAMETER (MPOLH=500)
      INTEGER NPOLH,KPOLH(MPOLH,4)
      REAL GPOLH(MPOLH,2)
      INTEGER IRAY,ITRI,KTRID(6)
      LOGICAL LNEWAR
      REAL G1NEW,G2NEW
C
C Subroutine designed to divide the homogeneous polygon KPOLH into
C the homogeneous triangles. NPOLH should be greater than 3.
C Method: searching for the two neighbouring shortest polygon
C     sides, adding new ray and making thus two triangles.
C Note: inhomogeneous triangles marked as homogeneous may be created
C     (RPXMEA must be run after).
C Subroutine also determines normalized ray parameters of a new ray,
C if needed.
C
C Input:
C     NPOLH... Number of rays forming the polygons GPOLH and KPOLH.
C     KPOLH(I,1)... Indices of the rays forming the homogeneous polygon
C             to be divided into homogeneous triangles.
C     KPOLH(I,2)... Sheets of rays forming the polygon.
C     KPOLH(I,3)... Types of rays forming the polygon.
C     KPOLH(I,4)... For boundary ray the value of history function of
C             the other ray from the pair of the boundary rays or zero.
C     GPOLH(I,1),GPOLH(I,2)... Normalized parameters of the rays forming
C             the homogeneous polygon.
C     IRAY... Index of the last computed ray.
C     ITRI... Index of the last computed triangle.
C     KTRID... Parameters of the divided triangle.
C     LNEWAR... Indicates whether the new ray was actually traced.
C Output:
C     NPOLH,KPOLH,GPOLH... New values.
C     G1NEW,G2NEW... If a new ray is to be traced,
C             parameters of the new ray.
C     LNEWAR... Indicates whether the new ray is to be computed.
C
C Subroutines and external functions required:
      EXTERNAL RPDI2G,RPLRIT,RPLRIP,RPLRIL,RPLTCR
      REAL RPDI2G
      LOGICAL RPLRIT,RPLRIP,RPLRIL,RPLTCR
C
C Coded by Petr Bulant
C
C
C.......................................................................
C Common block /RPARD/:
      INCLUDE 'rpard.inc'
C     rpard.inc
C     AERR ... The distance of boundary rays.
C............................
C
C Common block /BOURA/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C
C.......................................................................
      REAL ZERO,ZERO1
      PARAMETER (ZERO =.000001)
      PARAMETER (ZERO1=.0000000001)
      REAL AR0
      REAL NEAR
C     PARAMETER (NEAR=.618**2)
      PARAMETER (NEAR=.471**2)
C     0.471=3/2 * SQRT(2)/2
      INTEGER KTRIN(6)
      REAL G1,G2,G11,G12,G22
      REAL X1,X2,G1X1,G2X1,G1X2,G2X2
      INTEGER ITYPE,ISH,ISHEET
      INTEGER ITYPEA,ISHA,ITYPEB,ISHB
      REAL G1A,G2A,G11A,G12A,G22A,G1B,G2B,G11B,G12B,G22B
      REAL G1M,G2M,G11M,G12M,G22M,G1N,G2N,G11N,G12N,G22N
      INTEGER KRAYI,KRAYJ
      REAL G1X,G2X
      REAL DIST2,MINDIS,NEAR2
      REAL G11POM,G12POM,G22POM
      REAL AREA,AREA1,AREA2,AAA,BBB,DG1,DG2,DETG
      INTEGER KPOL(4)
      REAL GPOL(4,2)
      REAL COS
      INTEGER IDIAG,IGOTO
      INTEGER I1,I2,I3,I4,I5
      INTEGER J1,J2
      CHARACTER VERTEX
      LOGICAL LRAY,LINTS
      SAVE KRAYI,KRAYJ,IGOTO,KPOL,GPOL
C     ZERO... Constant used to decide whether the real variable.EQ.zero.
C     AR0...  Area of the smallest considered triangle.
C     NEAR... Relative length to identify rays.
C     KTRIN... Parameters of the new triangle to be registrated (new
C             column to be added into array KTRI).
C     X1,X2... Coordinates of the ray on the reference surface.
C     G1X1,G2X1,G1X2,G2X2... Derivatives of ray parameters according to
C             surface coordinates.
C     KRAYA,B... Signs of rays            |   Auxiliary
C     ITYPEA,B... Types of rays           |   variables used
C     ISHA,B... Value of history function |   for different rays.
C     Gi(i)A,B... Parameters of rays      |  (always commented)
C     DIST2... Second power of the distance of two rays.
C     MINDIS... Minimum of the distances between the rays.
C     NEAR2... Length to identify rays.
C     GiiPOM... Average value of the metric tensor.
C     AREA,AREA1,2... Auxiliary variable (area of the triangle).
C     DG1,DG2,AAA,BBB,DETG... Auxiliary variables used to compute
C             the parameters of a new ray.
C     KPOL,GPOL... Indices and normalized ray parameters of the four
C             rays, which become vertices of the two new triangles.
C     COS...  Cosine of the angle of two vectors.
C     IDIAG... Sequence in KPOLH of the ray whose neighbouring rays form
C             the shortest polygon diagonal.
C     I1,2... Implied-do variables or variables controlling the loop.
C     I1,I2,I3... From label 1 the rays where a new ray is to be added.
C     J1,2... Auxiliary variables (numbers).
C     VERTEX... Identifies, which point of the abscissa is the nearest
C             to the ray.
C     LRAY... Indicates whether the ray IRAY is in memory.
C     LINTS... Indicates whether the intersection appeared.
C-----------------------------------------------------------------------
      IF (LNEWAR) THEN
        LNEWAR=.FALSE.
        GOTO (120,150) IGOTO
      ENDIF
      AR0=(AERR**2)*0.4330127/9.
C
C     Checking the size of the homogeneous polygon:
      AREA1=0.
      DO 2, I1=1,NPOLH-2
        CALL RPRAY(KPOLH(I1,1),LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *             X1,X2,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        DG1=GPOLH(I1,1)-GPOLH(NPOLH,1)
        DG2=GPOLH(I1,2)-GPOLH(NPOLH,2)
        DETG=G11*G22 - G12*G12
        IF (DETG.LT.ZERO) CALL RPERR(4)
        AREA=SQRT(DETG)*((DG1*(GPOLH(I1+1,2)-GPOLH(I1,2))
     *       -DG2*(GPOLH(I1+1,1)-GPOLH(I1,1)))*.5)
        AREA1=AREA1+AREA
  2   CONTINUE
      IF (AREA1.LT.AR0) THEN
C       The area of the polygon is quite little,
C       polygon is not to be divided.
C       The polygon will be simply divided into homogeneous triangles:
        I1=1
  4     CONTINUE
          IF(I1.GT.1) THEN
            J1=I1-1
          ELSE
            J1=NPOLH
          ENDIF
          IF(I1.LT.NPOLH) THEN
            J2=I1+1
          ELSE
            J2=1
          ENDIF
          IF (RPLRIT(.FALSE.,GPOLH(J1,1),GPOLH(J1,2),GPOLH(I1,1),
     *        GPOLH(I1,2),GPOLH(J2,1),GPOLH(J2,2),G1A,G2A,AREA)) THEN
            IF (.NOT.RPLTCR(J1,I1,GPOLH(J2,1),GPOLH(J2,2),
     *                      NPOLH,GPOLH)) THEN
              ITRI=ITRI+1
              KTRIN(1)=KPOLH(J1,1)
              KTRIN(2)=KPOLH(I1,1)
              KTRIN(3)=KPOLH(J2,1)
              KTRIN(4)=ITRI
              IF (KTRID(5).EQ.0) THEN
                KTRIN(5)=KTRID(4)
              ELSE
                KTRIN(5)=KTRID(5)
              ENDIF
              KTRIN(6)=3
              CALL RPTRI1(ITRI,KTRIN)
              CALL RPSTOR('T',IRAY,KTRIN)
              NPOLH=NPOLH-1
              DO 6, I2=I1,NPOLH
                KPOLH(I1,1)=KPOLH(I1+1,1)
                KPOLH(I1,2)=KPOLH(I1+1,2)
                KPOLH(I1,3)=KPOLH(I1+1,3)
                KPOLH(I1,4)=KPOLH(I1+1,4)
                GPOLH(I1,1)=GPOLH(I1+1,1)
                GPOLH(I1,2)=GPOLH(I1+1,2)
  6           CONTINUE
              I1=1
              GOTO 4
            ENDIF
          ENDIF
        I1=I1+1
        IF (I1.LE.NPOLH) GOTO 4
        NPOLH=0
        LNEWAR=.FALSE.
        RETURN
      ENDIF
C
C
C     Easy dividing polygon with four rays:
  10  CONTINUE
      IF (NPOLH.EQ.4) THEN
        DO 8, I1=1,4
          KPOL(I1)=KPOLH(I1,1)
          GPOL(I1,1)=GPOLH(I1,1)
          GPOL(I1,2)=GPOLH(I1,2)
  8     CONTINUE
        NPOLH=0
        LNEWAR=.FALSE.
        GOTO 100
      ENDIF
C
C
C     Choosing the ray with minimal distance from his neighbours:
      IDIAG=0
      MINDIS=999999.
      DO 155, I2=1,NPOLH
        I1=I2-1
        IF (I1.EQ.0) I1=NPOLH
        I3=I2+1
        IF (I3.EQ.NPOLH+1) I3=1
        IF (KPOLH(I2,1).GT.0) THEN
          CALL RPRAY(IABS(KPOLH(I2,1)),LRAY,ITYPEA,ISHA,G1A,G2A,G11A,
     *               G12A,G22A,X1,X2,G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          DIST2=RPDI2G(G1A,G2A,GPOLH(I1,1),GPOLH(I1,2),G11A,G12A,G22A)
          DIST2=DIST2 +
     *          RPDI2G(G1A,G2A,GPOLH(I3,1),GPOLH(I3,2),G11A,G12A,G22A)
          IF (DIST2.LT.MINDIS) THEN
            IDIAG=I2
            MINDIS=DIST2
          ENDIF
        ENDIF
  155 CONTINUE
C
C
      IF (IDIAG.LE.0) THEN
C       All rays marked as not suitable for adding a new ray.
C       Trying to find a right-handed triangle which does not
C       contain any ray of the homogeneous polygon:
        IDIAG=2
        DO 157, I1=1,NPOLH
          IF(I1.GT.1) THEN
            J1=I1-1
          ELSE
            J1=NPOLH
          ENDIF
          IF(I1.LT.NPOLH) THEN
            J2=I1+1
          ELSE
            J2=1
          ENDIF
          IF (RPLRIT(.FALSE.,GPOLH(J1,1),GPOLH(J1,2),GPOLH(I1,1),
     *        GPOLH(I1,2),GPOLH(J2,1),GPOLH(J2,2),G1A,G2A,AREA)) THEN
            IF (.NOT.RPLTCR(J1,I1,GPOLH(J2,1),GPOLH(J2,2),
     *                      NPOLH,GPOLH)) THEN
              CALL RPRAY(IABS(KPOLH(J1,1)),LRAY,ITYPEA,ISHA,G1A,G2A,G11A
     *                   ,G12A,G22A,X1,X2,G1X1,G2X1,G1X2,G2X2)
              IF (.NOT.LRAY) CALL RPERR(1)
              CALL RPRAY(IABS(KPOLH(J2,1)),LRAY,ITYPEB,ISHB,G1B,G2B,G11B
     *                   ,G12B,G22B,X1,X2,G1X1,G2X1,G1X2,G2X2)
              IF (.NOT.LRAY) CALL RPERR(1)
              G11POM=(G11A+G11B)/2.
              G12POM=(G12A+G12B)/2.
              G22POM=(G22A+G22B)/2.
              DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
              IF (DIST2.LT.MINDIS) THEN
                  IDIAG=I1
                  MINDIS=DIST2
              ENDIF
            ENDIF
          ENDIF
  157   CONTINUE
        IF(IDIAG.GT.1) THEN
          J1=IDIAG-1
        ELSE
          J1=NPOLH
        ENDIF
        IF(IDIAG.LT.NPOLH) THEN
          J2=IDIAG+1
        ELSE
          J2=1
        ENDIF
C       Separating the chosen triangle:
        IF (RPLRIT(.FALSE.,GPOLH(J1,1),GPOLH(J1,2),GPOLH(IDIAG,1),
     *      GPOLH(IDIAG,2),GPOLH(J2,1),GPOLH(J2,2),G1A,G2A,AREA)) THEN
          ITRI=ITRI+1
          KTRIN(1)=IABS(KPOLH(J1,1))
          KTRIN(2)=IABS(KPOLH(IDIAG,1))
          KTRIN(3)=IABS(KPOLH(J2,1))
          KTRIN(4)=ITRI
          IF (KTRID(5).EQ.0) THEN
            KTRIN(5)=KTRID(4)
          ELSE
            KTRIN(5)=KTRID(5)
          ENDIF
          KTRIN(6)=3
          CALL RPTRI1(ITRI,KTRIN)
          CALL RPSTOR('T',IRAY,KTRIN)
        ENDIF
        NPOLH=NPOLH-1
        DO 158, I1=IDIAG,NPOLH
          KPOLH(I1,1)=KPOLH(I1+1,1)
          KPOLH(I1,2)=KPOLH(I1+1,2)
          KPOLH(I1,3)=KPOLH(I1+1,3)
          KPOLH(I1,4)=KPOLH(I1+1,4)
          GPOLH(I1,1)=GPOLH(I1+1,1)
          GPOLH(I1,2)=GPOLH(I1+1,2)
  158   CONTINUE
        LNEWAR=.FALSE.
        GOTO 200
      ENDIF
C
C
C     The new ray is to be computed to create new triangles and
C     separate them from the homogeneous polygon.
C
C     Sorting the rays of the polygon,
C     so that the ray I2 is the third one:
      I2=IDIAG
      IF (I2.LT.3) THEN
        DO 12, I4=1,3-I2
          IF (NPOLH.GE.MPOLH) THEN
C           RP3D-026
            CALL ERROR('RP3D-026: Insufficient memory for KPOLH.')
C           This error may be caused by too small dimension of array
C           KPOLH. Try to enlarge the parameter MPOLH at the
C           beginning of this subroutine.
          ENDIF
          DO 11, I5=NPOLH+1,2,-1
            KPOLH(I5,1)=KPOLH(I5-1,1)
            KPOLH(I5,2)=KPOLH(I5-1,2)
            KPOLH(I5,3)=KPOLH(I5-1,3)
            KPOLH(I5,4)=KPOLH(I5-1,4)
            GPOLH(I5,1)=GPOLH(I5-1,1)
            GPOLH(I5,2)=GPOLH(I5-1,2)
  11      CONTINUE
          KPOLH(1,1)=KPOLH(NPOLH+1,1)
          KPOLH(1,2)=KPOLH(NPOLH+1,2)
          KPOLH(1,3)=KPOLH(NPOLH+1,3)
          KPOLH(1,4)=KPOLH(NPOLH+1,4)
          GPOLH(1,1)=GPOLH(NPOLH+1,1)
          GPOLH(1,2)=GPOLH(NPOLH+1,2)
  12    CONTINUE
      ELSEIF (I2.GT.3) THEN
        DO 14, I4=1,I2-3
          IF (NPOLH.GE.MPOLH) THEN
C           RP3D-027
            CALL ERROR('RP3D-027: Insufficient memory for KPOLH.')
C           This error may be caused by too small dimension of array
C           KPOLH. Try to enlarge the parameter MPOLH at the
C           beginning of this subroutine.
          ENDIF
          KPOLH(NPOLH+1,1)=KPOLH(1,1)
          KPOLH(NPOLH+1,2)=KPOLH(1,2)
          KPOLH(NPOLH+1,3)=KPOLH(1,3)
          KPOLH(NPOLH+1,4)=KPOLH(1,4)
          GPOLH(NPOLH+1,1)=GPOLH(1,1)
          GPOLH(NPOLH+1,2)=GPOLH(1,2)
          DO 13, I5=1,NPOLH
            KPOLH(I5,1)=KPOLH(I5+1,1)
            KPOLH(I5,2)=KPOLH(I5+1,2)
            KPOLH(I5,3)=KPOLH(I5+1,3)
            KPOLH(I5,4)=KPOLH(I5+1,4)
            GPOLH(I5,1)=GPOLH(I5+1,1)
            GPOLH(I5,2)=GPOLH(I5+1,2)
  13      CONTINUE
  14    CONTINUE
      ENDIF
      I1=2
      I2=3
      I3=4
C
C
      IF (IABS(KPOLH(I1,1)).EQ.IABS(KPOLH(I3,1))) THEN
C       This part of the homogeneous polygon will escape notice:
        KPOLH(1,1)=IABS(KPOLH(1,1))
        KPOLH(2,1)=IABS(KPOLH(2,1))
        DO 15, I4=I2,NPOLH-2
          KPOLH(I4,1)=IABS(KPOLH(I4+2,1))
          KPOLH(I4,2)=KPOLH(I4+2,2)
          KPOLH(I4,3)=KPOLH(I4+2,3)
          KPOLH(I4,4)=KPOLH(I4+2,4)
          GPOLH(I4,1)=GPOLH(I4+2,1)
          GPOLH(I4,2)=GPOLH(I4+2,2)
   15   CONTINUE
        NPOLH=NPOLH-2
        LNEWAR=.FALSE.
        GOTO 200
      ENDIF
C
C
      CALL RPRAY(IABS(KPOLH(I1,1)),LRAY,ITYPE,ISHEET,G1M,G2M,
     *           G11M,G12M,G22M,X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(IABS(KPOLH(I3,1)),LRAY,ITYPE,ISHEET,G1N,G2N,
     *           G11N,G12N,G22N,X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
C     ..M,..N ... Two rays between which we are adding a new ray.
      G11POM=(G11M+G11N)/2.
      G12POM=(G12M+G12N)/2.
      G22POM=(G22M+G22N)/2.
C
C
C     Looking, whether it is not possible to easy separate one
C     triangle I1,I2,I3, if it does not contain any ray of the
C     homogeneous polygon, and if it is not too narrow:
      IF (RPLRIT(.FALSE.,GPOLH(I1,1),GPOLH(I1,2),GPOLH(I2,1),
     *    GPOLH(I2,2),GPOLH(I3,1),GPOLH(I3,2),G1A,G2A,AREA)) THEN
        IF (.NOT.RPLTCR(I1,I2,GPOLH(I3,1),GPOLH(I3,2),
     *                  NPOLH,GPOLH)) THEN
          COS =( (G1N-GPOLH(I2,1))*G11POM*(G1M-GPOLH(I2,1))
     *         + (G1N-GPOLH(I2,1))*G12POM*(G2M-GPOLH(I2,2))
     *         + (G2N-GPOLH(I2,2))*G12POM*(G1M-GPOLH(I2,1))
     *         + (G2N-GPOLH(I2,2))*G22POM*(G2M-GPOLH(I2,2))  )  / SQRT
     *    (RPDI2G(GPOLH(I2,1),GPOLH(I2,2),G1M,G2M,G11POM,G12POM,G22POM)
     *    *RPDI2G(GPOLH(I2,1),GPOLH(I2,2),G1N,G2N,G11POM,G12POM,G22POM))
          IF (COS.GE.-0.5878) THEN
C           This triangle is to be separated:
            ITRI=ITRI+1
            KTRIN(1)=IABS(KPOLH(I1,1))
            KTRIN(2)=IABS(KPOLH(I2,1))
            KTRIN(3)=IABS(KPOLH(I3,1))
            KTRIN(4)=ITRI
            IF (KTRID(5).EQ.0) THEN
              KTRIN(5)=KTRID(4)
            ELSE
              KTRIN(5)=KTRID(5)
            ENDIF
            KTRIN(6)=3
            CALL RPTRI1(ITRI,KTRIN)
            CALL RPSTOR('T',IRAY,KTRIN)
            NPOLH=NPOLH-1
            DO 181, I1=I2,NPOLH
              I3=I1+1
              KPOLH(I1,1)=KPOLH(I3,1)
              KPOLH(I1,2)=KPOLH(I3,2)
              KPOLH(I1,3)=KPOLH(I3,3)
              KPOLH(I1,4)=KPOLH(I3,4)
              GPOLH(I1,1)=GPOLH(I3,1)
              GPOLH(I1,2)=GPOLH(I3,2)
  181       CONTINUE
            LNEWAR=.FALSE.
            GOTO 200
          ENDIF
        ENDIF
      ENDIF
C
C     Proposing of the parameters of the new ray:
  19  AAA=(G11POM*(G1M-G1N)+G12POM*(G2M-G2N))
      BBB=(G12POM*(G1M-G1N)+G22POM*(G2M-G2N))
      DETG=G11POM*G22POM - G12POM*G12POM
      IF (DETG.LT.ZERO) CALL RPERR(4)
      DIST2=(G1M-G1N)*AAA + (G2M-G2N)*BBB
      NEAR2=DIST2*NEAR
      IF (DIST2.LT.ZERO1) DIST2=ZERO1
CCC   NEAR2=MINDIS*NEAR
CCC   NEAR2=DIST2*NEAR
      G1NEW=(G1M+G1N)/2. + SQRT(MINDIS/DIST2)*0.5*SQRT(3./DETG)*BBB
      G2NEW=(G2M+G2N)/2. - SQRT(MINDIS/DIST2)*0.5*SQRT(3./DETG)*AAA
C
C
C     Controlling whether the new ray is proposed too near
C     to any other ray of the polygon.
C     Checking the ray I2:
      DIST2=RPDI2G(G1NEW,G2NEW,GPOLH(I2,1),GPOLH(I2,2),
     *             G11POM,G12POM,G22POM)
      IF (DIST2.LT.NEAR2) THEN
C       This would lead to creation of too narrow triangles:
        KPOLH(I2,1)=-IABS(KPOLH(I2,1))
        GOTO 10
      ENDIF
C     Checking the neighbouring rays:
      DIST2=RPDI2G(G1NEW,G2NEW,GPOLH(I1-1,1),GPOLH(I1-1,2),
     *             G11POM,G12POM,G22POM)
      IF (DIST2.LT.NEAR2) THEN
        IF (RPLTCR(I1-1,I1,GPOLH(I2,1),GPOLH(I2,2),
     *             NPOLH,GPOLH).OR.
     *      RPLTCR(I1-1,I2,GPOLH(I3,1),GPOLH(I3,2),
     *             NPOLH,GPOLH)) THEN
C         The triangles contain rays of polygon:
          KPOLH(I2,1)=-IABS(KPOLH(I2,1))
          GOTO 10
        ENDIF
C       This ray of polygon will be used as a new ray:
        KPOL(1)=IABS(KPOLH(I1-1,1))
        GPOL(1,1)=GPOLH(I1-1,1)
        GPOL(1,2)=GPOLH(I1-1,2)
        KPOL(2)=IABS(KPOLH(I1,1))
        GPOL(2,1)=GPOLH(I1,1)
        GPOL(2,2)=GPOLH(I1,2)
        KPOL(3)=IABS(KPOLH(I2,1))
        GPOL(3,1)=GPOLH(I2,1)
        GPOL(3,2)=GPOLH(I2,2)
        KPOL(4)=IABS(KPOLH(I3,1))
        GPOL(4,1)=GPOLH(I3,1)
        GPOL(4,2)=GPOLH(I3,2)
        NPOLH=NPOLH-2
        DO 16, I4=I1,NPOLH
          KPOLH(I4,1)=KPOLH(I4+2,1)
          KPOLH(I4,2)=KPOLH(I4+2,2)
          KPOLH(I4,3)=KPOLH(I4+2,3)
          KPOLH(I4,4)=KPOLH(I4+2,4)
          GPOLH(I4,1)=GPOLH(I4+2,1)
          GPOLH(I4,2)=GPOLH(I4+2,2)
  16    CONTINUE
        LNEWAR=.FALSE.
        GOTO 100
      ENDIF
C
      DIST2=RPDI2G(G1NEW,G2NEW,GPOLH(I3+1,1),GPOLH(I3+1,2),
     *             G11POM,G12POM,G22POM)
      IF (DIST2.LT.NEAR2) THEN
        IF (RPLTCR(I1,I2,GPOLH(I3+1,1),GPOLH(I3+1,2),
     *             NPOLH,GPOLH).OR.
     *      RPLTCR(I2,I3,GPOLH(I3+1,1),GPOLH(I3+1,2),
     *             NPOLH,GPOLH)) THEN
C         The triangles contain rays of polygon:
          KPOLH(I2,1)=-IABS(KPOLH(I2,1))
          GOTO 10
        ENDIF
C       This ray of polygon will be used as a new ray:
        KPOL(1)=IABS(KPOLH(I1,1))
        GPOL(1,1)=GPOLH(I1,1)
        GPOL(1,2)=GPOLH(I1,2)
        KPOL(2)=IABS(KPOLH(I2,1))
        GPOL(2,1)=GPOLH(I2,1)
        GPOL(2,2)=GPOLH(I2,2)
        KPOL(3)=IABS(KPOLH(I3,1))
        GPOL(3,1)=GPOLH(I3,1)
        GPOL(3,2)=GPOLH(I3,2)
        KPOL(4)=IABS(KPOLH(I3+1,1))
        GPOL(4,1)=GPOLH(I3+1,1)
        GPOL(4,2)=GPOLH(I3+1,2)
        NPOLH=NPOLH-2
        DO 17, I4=I2,NPOLH
          KPOLH(I4,1)=KPOLH(I4+2,1)
          KPOLH(I4,2)=KPOLH(I4+2,2)
          KPOLH(I4,3)=KPOLH(I4+2,3)
          KPOLH(I4,4)=KPOLH(I4+2,4)
          GPOLH(I4,1)=GPOLH(I4+2,1)
          GPOLH(I4,2)=GPOLH(I4+2,2)
  17    CONTINUE
        LNEWAR=.FALSE.
        GOTO 100
      ENDIF
C
C     Checking the other rays (except rays I1,I2 and I3):
      DO 20, I4=1,NPOLH
        IF (I4.EQ.I1) GOTO 20
        IF (I4.EQ.I3) GOTO 20
        IF (I4.EQ.I2) GOTO 20
        DIST2=RPDI2G(G1NEW,G2NEW,GPOLH(I4,1),GPOLH(I4,2),
     *               G11POM,G12POM,G22POM)
        IF (DIST2.LT.NEAR2) THEN
C         This would separate the polygon into two parts, or this
C         would lead to creation of too narrow triangles:
          KPOLH(I2,1)=-IABS(KPOLH(I2,1))
          GOTO 10
        ENDIF
  20  CONTINUE
C
C
C     Controlling whether the new ray is proposed too near the boundary
C     of the homogeneous polygon.
C     Checking the neighbouring sides:
      CALL RPDPA(G1NEW,G2NEW,GPOLH(I1-1,1),GPOLH(I1-1,2),GPOLH(I1,1),
     *           GPOLH(I1,2),G11POM,G12POM,G22POM,VERTEX,G1X,G2X)
      IF (VERTEX.EQ.'X') THEN
        DIST2=RPDI2G(G1NEW,G2NEW,G1X,G2X,G11POM,G12POM,G22POM)
        IF (DIST2.LT.NEAR2) THEN
          CALL RPLRTC(G1X,G2X,KTRID,KRAYI,KRAYJ,IGOTO)
          IF (IGOTO.EQ.1) THEN
            IF ((.NOT.RPLTCR(I1,I2,G1X,G2X,NPOLH,GPOLH)).AND.
     *          (.NOT.RPLTCR(I2,I3,G1X,G2X,NPOLH,GPOLH))) THEN
C             The ray X will be used as a new ray:
              IF (KRAYI.EQ.0) IGOTO=2
              KPOL(2)=IABS(KPOLH(I1,1))
              GPOL(2,1)=GPOLH(I1,1)
              GPOL(2,2)=GPOLH(I1,2)
              KPOL(3)=IABS(KPOLH(I2,1))
              GPOL(3,1)=GPOLH(I2,1)
              GPOL(3,2)=GPOLH(I2,2)
              KPOL(4)=IABS(KPOLH(I3,1))
              GPOL(4,1)=GPOLH(I3,1)
              GPOL(4,2)=GPOLH(I3,2)
              G1NEW=G1X
              G2NEW=G2X
              KPOL(1)=IRAY+1
              GPOL(1,1)=G1NEW
              GPOL(1,2)=G2NEW
              NPOLH=NPOLH-1
              KPOLH(I1,1)=IRAY+1
              GPOLH(I1,1)=G1NEW
              GPOLH(I1,2)=G2NEW
              DO 22, I4=I2,NPOLH
                KPOLH(I4,1)=KPOLH(I4+1,1)
                KPOLH(I4,2)=KPOLH(I4+1,2)
                KPOLH(I4,3)=KPOLH(I4+1,3)
                KPOLH(I4,4)=KPOLH(I4+1,4)
                GPOLH(I4,1)=GPOLH(I4+1,1)
                GPOLH(I4,2)=GPOLH(I4+1,2)
  22          CONTINUE
              LNEWAR=.TRUE.
              GOTO 100
            ENDIF
          ENDIF
C         This ray is not to be used:
          KPOLH(I2,1)=-IABS(KPOLH(I2,1))
          GOTO 10
        ENDIF
      ENDIF
      CALL RPDPA(G1NEW,G2NEW,GPOLH(I3,1),GPOLH(I3,2),GPOLH(I3+1,1),
     *           GPOLH(I3+1,2),G11POM,G12POM,G22POM,VERTEX,G1X,G2X)
      IF (VERTEX.EQ.'X') THEN
        DIST2=RPDI2G(G1NEW,G2NEW,G1X,G2X,G11POM,G12POM,G22POM)
        IF (DIST2.LT.NEAR2) THEN
          CALL RPLRTC(G1X,G2X,KTRID,KRAYI,KRAYJ,IGOTO)
          IF (IGOTO.EQ.1) THEN
            IF ((.NOT.RPLTCR(I1,I2,G1X,G2X,NPOLH,GPOLH)).AND.
     *          (.NOT.RPLTCR(I2,I3,G1X,G2X,NPOLH,GPOLH))) THEN
C             The ray X will be used as a new ray:
              IF (KRAYI.EQ.0) IGOTO=2
              KPOL(1)=IABS(KPOLH(I1,1))
              GPOL(1,1)=GPOLH(I1,1)
              GPOL(1,2)=GPOLH(I1,2)
              KPOL(2)=IABS(KPOLH(I2,1))
              GPOL(2,1)=GPOLH(I2,1)
              GPOL(2,2)=GPOLH(I2,2)
              KPOL(3)=IABS(KPOLH(I3,1))
              GPOL(3,1)=GPOLH(I3,1)
              GPOL(3,2)=GPOLH(I3,2)
              G1NEW=G1X
              G2NEW=G2X
              KPOL(4)=IRAY+1
              GPOL(4,1)=G1NEW
              GPOL(4,2)=G2NEW
              NPOLH=NPOLH-1
              DO 24, I4=I3,NPOLH
                KPOLH(I4,1)=KPOLH(I4+1,1)
                KPOLH(I4,2)=KPOLH(I4+1,2)
                KPOLH(I4,3)=KPOLH(I4+1,3)
                KPOLH(I4,4)=KPOLH(I4+1,4)
                GPOLH(I4,1)=GPOLH(I4+1,1)
                GPOLH(I4,2)=GPOLH(I4+1,2)
  24          CONTINUE
              KPOLH(I2,1)=IRAY+1
              GPOLH(I2,1)=G1NEW
              GPOLH(I2,2)=G2NEW
              LNEWAR=.TRUE.
              GOTO 100
            ENDIF
          ENDIF
C         This ray is not to be used:
          KPOLH(I2,1)=-IABS(KPOLH(I2,1))
          GOTO 10
        ENDIF
      ENDIF
C
C     Checking the other sides:
      I5=1
      I4=NPOLH
  30  CONTINUE
        CALL RPDPA(G1NEW,G2NEW,GPOLH(I4,1),GPOLH(I4,2),GPOLH(I5,1),
     *             GPOLH(I5,2),G11POM,G12POM,G22POM,VERTEX,G1X,G2X)
        IF (VERTEX.EQ.'X') THEN
          DIST2=RPDI2G(G1NEW,G2NEW,G1X,G2X,G11POM,G12POM,G22POM)
          IF (DIST2.LT.NEAR2) THEN
C           This would separate the polygon into two parts.
            KPOLH(I2,1)=-IABS(KPOLH(I2,1))
            GOTO 10
          ENDIF
        ENDIF
        I5=I4
        I4=I4-1
      IF (I4.GT.I3) GOTO 30
C
C
C     Controlling whether the  abscissa (ray I2 - new ray) intersects
C     the boundary of the homogeneous polygon.
C     Checking the neighbouring sides:
      CALL RPCROS(GPOLH(I2,1),GPOLH(I2,2),G1NEW,G2NEW,
     *            GPOLH(I1-1,1),GPOLH(I1-1,2),GPOLH(I1,1),
     *            GPOLH(I1,2),LINTS,G1X,G2X)
      IF (LINTS) THEN
        CALL RPLRTC(G1X,G2X,KTRID,KRAYI,KRAYJ,IGOTO)
        IF (IGOTO.EQ.1) THEN
          IF ((.NOT.RPLTCR(I1,I2,G1X,G2X,NPOLH,GPOLH)).AND.
     *        (.NOT.RPLTCR(I2,I3,G1X,G2X,NPOLH,GPOLH))) THEN
C           The ray X will be used as a new ray:
            IF (KRAYI.EQ.0) IGOTO=2
            KPOL(2)=IABS(KPOLH(I1,1))
            GPOL(2,1)=GPOLH(I1,1)
            GPOL(2,2)=GPOLH(I1,2)
            KPOL(3)=IABS(KPOLH(I2,1))
            GPOL(3,1)=GPOLH(I2,1)
            GPOL(3,2)=GPOLH(I2,2)
            KPOL(4)=IABS(KPOLH(I3,1))
            GPOL(4,1)=GPOLH(I3,1)
            GPOL(4,2)=GPOLH(I3,2)
            G1NEW=G1X
            G2NEW=G2X
            KPOL(1)=IRAY+1
            GPOL(1,1)=G1NEW
            GPOL(1,2)=G2NEW
            NPOLH=NPOLH-1
            KPOLH(I1,1)=IRAY+1
            GPOLH(I1,1)=G1NEW
            GPOLH(I1,2)=G2NEW
            DO 32, I4=I2,NPOLH
              KPOLH(I4,1)=KPOLH(I4+1,1)
              KPOLH(I4,2)=KPOLH(I4+1,2)
              KPOLH(I4,3)=KPOLH(I4+1,3)
              KPOLH(I4,4)=KPOLH(I4+1,4)
              GPOLH(I4,1)=GPOLH(I4+1,1)
              GPOLH(I4,2)=GPOLH(I4+1,2)
  32        CONTINUE
            LNEWAR=.TRUE.
            GOTO 100
          ENDIF
        ENDIF
C       This ray is not to be used:
        KPOLH(I2,1)=-IABS(KPOLH(I2,1))
        GOTO 10
      ENDIF
      CALL RPCROS(GPOLH(I2,1),GPOLH(I2,2),G1NEW,G2NEW,
     *            GPOLH(I3,1),GPOLH(I3,2),GPOLH(I3+1,1),
     *            GPOLH(I3+1,2),LINTS,G1X,G2X)
      IF (LINTS) THEN
        CALL RPLRTC(G1X,G2X,KTRID,KRAYI,KRAYJ,IGOTO)
        IF (IGOTO.EQ.1) THEN
          IF ((.NOT.RPLTCR(I1,I2,G1X,G2X,NPOLH,GPOLH)).AND.
     *        (.NOT.RPLTCR(I2,I3,G1X,G2X,NPOLH,GPOLH))) THEN
C           The ray X will be used as a new ray:
            IF (KRAYI.EQ.0) IGOTO=2
            KPOL(1)=IABS(KPOLH(I1,1))
            GPOL(1,1)=GPOLH(I1,1)
            GPOL(1,2)=GPOLH(I1,2)
            KPOL(2)=IABS(KPOLH(I2,1))
            GPOL(2,1)=GPOLH(I2,1)
            GPOL(2,2)=GPOLH(I2,2)
            KPOL(3)=IABS(KPOLH(I3,1))
            GPOL(3,1)=GPOLH(I3,1)
            GPOL(3,2)=GPOLH(I3,2)
            G1NEW=G1X
            G2NEW=G2X
            KPOL(4)=IRAY+1
            GPOL(4,1)=G1NEW
            GPOL(4,2)=G2NEW
            NPOLH=NPOLH-1
            DO 34, I4=I3,NPOLH
              KPOLH(I4,1)=KPOLH(I4+1,1)
              KPOLH(I4,2)=KPOLH(I4+1,2)
              KPOLH(I4,3)=KPOLH(I4+1,3)
              KPOLH(I4,4)=KPOLH(I4+1,4)
              GPOLH(I4,1)=GPOLH(I4+1,1)
              GPOLH(I4,2)=GPOLH(I4+1,2)
  34        CONTINUE
            KPOLH(I2,1)=IRAY+1
            GPOLH(I2,1)=G1NEW
            GPOLH(I2,2)=G2NEW
            LNEWAR=.TRUE.
            GOTO 100
          ENDIF
        ENDIF
C       This ray is not to be used:
        KPOLH(I2,1)=-IABS(KPOLH(I2,1))
        GOTO 10
      ENDIF
C
C     Checking the other sides:
      I5=1
      I4=NPOLH
  40  CONTINUE
        CALL RPCROS(GPOLH(I2,1),GPOLH(I2,2),G1NEW,G2NEW,
     *              GPOLH(I4,1),GPOLH(I4,2),GPOLH(I5,1),
     *              GPOLH(I5,2),LINTS,G1X,G2X)
        IF (LINTS) THEN
C         This would separate the polygon into two parts.
          KPOLH(I2,1)=-IABS(KPOLH(I2,1))
          GOTO 10
        ENDIF
        I5=I4
        I4=I4-1
      IF (I4.GT.I3) GOTO 40
C
C
C     Controlling whether the ray is in the polygon:
      IF (RPLRIP(NPOLH,GPOLH,G1NEW,G2NEW)) THEN
        IF ((.NOT.RPLTCR(I1,I2,G1NEW,G2NEW,NPOLH,GPOLH)).AND.
     *      (.NOT.RPLTCR(I2,I3,G1NEW,G2NEW,NPOLH,GPOLH))) THEN
C         This ray will be used:
          KPOL(1)=IRAY+1
          GPOL(1,1)=G1NEW
          GPOL(1,2)=G2NEW
          KPOL(2)  =IABS(KPOLH(I1,1))
          GPOL(2,1)=GPOLH(I1,1)
          GPOL(2,2)=GPOLH(I1,2)
          KPOL(3)  =IABS(KPOLH(I2,1))
          GPOL(3,1)=GPOLH(I2,1)
          GPOL(3,2)=GPOLH(I2,2)
          KPOL(4)  =IABS(KPOLH(I3,1))
          GPOL(4,1)=GPOLH(I3,1)
          GPOL(4,2)=GPOLH(I3,2)
          KPOLH(I2,1)=IRAY+1
          GPOLH(I2,1)=G1NEW
          GPOLH(I2,2)=G2NEW
          LNEWAR=.TRUE.
          IGOTO=2
          GOTO 100
        ENDIF
      ENDIF
C     A very strange situation,
C     no intersection, but ray is not in polygon or contains other rays:
      KPOLH(I2,1)=-IABS(KPOLH(I2,1))
      GOTO 10
C
  100 CONTINUE
      IF (LNEWAR) THEN
C       Trace the ray and go to 120 or to 150:
        RETURN
      ELSE
        GOTO 150
      ENDIF
C
C
  120 CONTINUE
C     New ray was actually computed, storing it to the array KBR:
      CALL RPKBR(KRAYI,KRAYJ,IRAY)
C
C
C     Converting divided part of the polygon into two triangles:
  150 CONTINUE
      G11POM=-999.
      CALL RPRAY(KPOL(1),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
      IF (LRAY) THEN
        G11POM=G11
        G12POM=G12
        G22POM=G22
      ENDIF
      CALL RPRAY(KPOL(2),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
      IF (LRAY) THEN
        IF (G11POM.EQ.-999.) THEN
          G11POM=G11
          G12POM=G12
          G22POM=G22
        ELSE
          G11POM=(G11POM+G11)*.5
          G12POM=(G12POM+G12)*.5
          G22POM=(G22POM+G22)*.5
        ENDIF
      ENDIF
      CALL RPRAY(KPOL(3),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
      IF (LRAY) THEN
        G11POM=(G11POM+G11)*.5
        G12POM=(G12POM+G12)*.5
        G22POM=(G22POM+G22)*.5
      ENDIF
      CALL RPRAY(KPOL(4),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2,
     *             G1X1,G2X1,G1X2,G2X2)
      IF (LRAY) THEN
        G11POM=(G11POM+G11)*.5
        G12POM=(G12POM+G12)*.5
        G22POM=(G22POM+G22)*.5
      ENDIF
      IF (RPDI2G(GPOL(1,1),GPOL(1,2),GPOL(3,1),GPOL(3,2),
     *    G11POM,G12POM,G22POM).GT.
     *    RPDI2G(GPOL(2,1),GPOL(2,2),GPOL(4,1),GPOL(4,2),
     *    G11POM,G12POM,G22POM)) THEN
C       The diagonal 2-4 is shorter, turning polygon:
        I1=KPOL(1)
        G1=GPOL(1,1)
        G2=GPOL(1,2)
        DO 160, I2=1,3
          I3=I2+1
          KPOL(I2)=KPOL(I3)
          GPOL(I2,1)=GPOL(I3,1)
          GPOL(I2,2)=GPOL(I3,2)
  160   CONTINUE
        KPOL(4)=I1
        GPOL(4,1)=G1
        GPOL(4,2)=G2
      ENDIF
      IF (RPLRIT(.FALSE.,GPOL(1,1),GPOL(1,2),GPOL(2,1),
     *    GPOL(2,2),GPOL(3,1),GPOL(3,2),G1A,G2A,AREA1).AND.
     *    RPLRIT(.FALSE.,GPOL(3,1),GPOL(3,2),GPOL(4,1),
     *    GPOL(4,2),GPOL(1,1),GPOL(1,2),G1A,G2A,AREA2)) THEN
        ITRI=ITRI+1
        KTRIN(1)=KPOL(1)
        KTRIN(2)=KPOL(2)
        KTRIN(3)=KPOL(3)
        KTRIN(4)=ITRI
        IF (KTRID(5).EQ.0) THEN
          KTRIN(5)=KTRID(4)
        ELSE
          KTRIN(5)=KTRID(5)
        ENDIF
        KTRIN(6)=3
        CALL RPTRI1(ITRI,KTRIN)
        CALL RPSTOR('T',IRAY,KTRIN)
        ITRI=ITRI+1
        KTRIN(1)=KPOL(3)
        KTRIN(2)=KPOL(4)
        KTRIN(3)=KPOL(1)
        KTRIN(4)=ITRI
        IF (KTRID(5).EQ.0) THEN
          KTRIN(5)=KTRID(4)
        ELSE
          KTRIN(5)=KTRID(5)
        ENDIF
        KTRIN(6)=3
        CALL RPTRI1(ITRI,KTRIN)
        CALL RPSTOR('T',IRAY,KTRIN)
        GOTO 200
      ENDIF
C     The triangles 123 and 341
C     are not both right-handed. Trying the diagonal 2-4:
      IF (RPLRIT(.FALSE.,GPOL(1,1),GPOL(1,2),GPOL(2,1),
     *    GPOL(2,2),GPOL(4,1),GPOL(4,2),G1A,G2A,AREA)) THEN
        ITRI=ITRI+1
        KTRIN(1)=KPOL(1)
        KTRIN(2)=KPOL(2)
        KTRIN(3)=KPOL(4)
        KTRIN(4)=ITRI
        IF (KTRID(5).EQ.0) THEN
          KTRIN(5)=KTRID(4)
        ELSE
          KTRIN(5)=KTRID(5)
        ENDIF
        KTRIN(6)=3
        CALL RPTRI1(ITRI,KTRIN)
        CALL RPSTOR('T',IRAY,KTRIN)
      ENDIF
      IF (RPLRIT(.FALSE.,GPOL(2,1),GPOL(2,2),GPOL(3,1),
     *    GPOL(3,2),GPOL(4,1),GPOL(4,2),G1A,G2A,AREA)) THEN
        ITRI=ITRI+1
        KTRIN(1)=KPOL(2)
        KTRIN(2)=KPOL(3)
        KTRIN(3)=KPOL(4)
        KTRIN(4)=ITRI
        IF (KTRID(5).EQ.0) THEN
          KTRIN(5)=KTRID(4)
        ELSE
          KTRIN(5)=KTRID(5)
        ENDIF
        KTRIN(6)=3
        CALL RPTRI1(ITRI,KTRIN)
        CALL RPSTOR('T',IRAY,KTRIN)
      ENDIF
C     Goto 200
C
C
C     Making homogeneous polygon positive:
  200 CONTINUE
      DO 201, I1=1,NPOLH
        KPOLH(I1,1)=IABS(KPOLH(I1,1))
  201 CONTINUE
      END
C
C=======================================================================
C
      LOGICAL FUNCTION RPLTCR(I1,I2,G1,G2,NPOLH,GPOLH)
C
C----------------------------------------------------------------------
      INTEGER I1,I2
      REAL G1,G2
      INTEGER MPOLH
      PARAMETER (MPOLH=500)
      INTEGER NPOLH
      REAL GPOLH(MPOLH,2)
C
C Subroutine designed to decide whether the triangle formed by rays
C I1, I2, of KPOLH and ray G1,G2 contains any ray of the homogeneous
C polygon KPOLH.
C
C Cartesian metric is used.
C
C Input:
C     NPOLH,GPOLH... Polygon.
C     I1,I2,G1,G2... Sequence of first two rays and ray parameters
C             of third ray of examined triangle.
C
C Output:
C     RPLTCR... Indicates whether the triangle contains any ray.
C
C Coded by Petr Bulant
C
C.......................................................................
      INTEGER I4
      REAL AAA
      EXTERNAL RPLRIT
      LOGICAL RPLRIT
C-----------------------------------------------------------------------
C
      RPLTCR=.FALSE.
      DO 10, I4=1,NPOLH
        IF (I4.EQ.I1) GOTO 9
        IF (I4.EQ.I2) GOTO 9
        IF ((GPOLH(I4,1).EQ.G1).AND.(GPOLH(I4,2).EQ.G2)) GOTO 9
        IF (RPLRIT(.TRUE.,GPOLH(I1,1),GPOLH(I1,2),GPOLH(I2,1),
     *                    GPOLH(I2,2),G1         ,G2         ,
     *                    GPOLH(I4,1),GPOLH(I4,2),AAA)) THEN
C         The triangle contains ray I4 of homogeneous polygon:
          RPLTCR=.TRUE.
          RETURN
        ENDIF
   9    CONTINUE
  10  CONTINUE
      END
C
C=======================================================================
C
      SUBROUTINE RPMEGS(ISHA,ISHB,G1X1A,G2X1A,G1X2A,G2X2A,
     *                            G1X1B,G2X1B,G1X2B,G2X2B,B11,B12,B22)
C
C-----------------------------------------------------------------------
      INTEGER ISHA,ISHB
      REAL G1X1A,G2X1A,G1X2A,G2X2A,G1X1B,G2X1B,G1X2B,G2X2B
      REAL B11,B12,B22
C
C Subroutine designed to evaluate the metric tensor B, based on
C the geometrical spreading (i.e. On the derivatives dg/dx).
C           -1                 dg    dg
C    B   = A      where  A  = -- i  -- j  PRM0(1)**2.
C     ij    ij            ij   dx    dx
C                                k     k
C If ISHA.GT.0  and ISHB.GT.0, B is evaluated from both sets of
C derivatives and the greater B is taken.
C
C Input:
C     ISHA,ISHB... Values of the ray history for rays A and B.
C     GIXIA,B... Derivatives.
C Output:
C     B11,B12,B22... Computed metric tensor.
C
C Subroutines and external functions required:
C
C Coded by Petr Bulant
C
C.......................................................................
C
C Common block /RPARD/:
      INCLUDE 'rpard.inc'
C     rpard.inc
C     PRM0(1)... Maximum allowed distance of the boundary ray from the
C             shadow zone (measured on the reference surface).
C.......................................................................
      REAL A11(3),A12(3),A22(3)
      REAL DETA
C     AII(1)... Matrix based on point A. See the formula above.
C     AII(2)... Matrix based on point B. See the formula above.
C     AII(3)... Auxiliary matrix.
C     DETA... Determinant or other auxiliary variable.
C-----------------------------------------------------------------------
      IF (ISHA.GT.0) THEN
        A11(3)=G1X1A*G1X1A+G1X2A*G1X2A
        A12(3)=G1X1A*G2X1A+G1X2A*G2X2A
        A22(3)=G2X1A*G2X1A+G2X2A*G2X2A
        DETA=A11(3)*A22(3)-A12(3)*A12(3)
        IF (DETA.EQ.0.) THEN
          A11(1)=999999.
          A12(1)=0.
          A22(1)=999999.
        ELSE
          A11(1)= A22(3)/DETA
          A12(1)=-A12(3)/DETA
          A22(1)= A11(3)/DETA
        ENDIF
      ENDIF
      IF (ISHB.GT.0) THEN
        A11(3)=G1X1B*G1X1B+G1X2B*G1X2B
        A12(3)=G1X1B*G2X1B+G1X2B*G2X2B
        A22(3)=G2X1B*G2X1B+G2X2B*G2X2B
        DETA=A11(3)*A22(3)-A12(3)*A12(3)
        IF (DETA.EQ.0.) THEN
          A11(2)=999999.
          A12(2)=0.
          A22(2)=999999.
        ELSE
          A11(2)= A22(3)/DETA
          A12(2)=-A12(3)/DETA
          A22(2)= A11(3)/DETA
        ENDIF
      ENDIF
      IF ((ISHA.GT.0).AND.(ISHB.GT.0)) THEN
C       B=(A(1) + A(2) + ABS(A(1) - A(2))) / 2
        A11(3)=A11(1)-A11(2)
        A12(3)=A12(1)-A12(2)
        A22(3)=A22(1)-A22(2)
C
        DETA=ABS(A11(3)*A22(3)-A12(3)*A12(3))
        B11=A11(3)*A11(3)+A12(3)*A12(3)+DETA
        B22=A22(3)*A22(3)+A12(3)*A12(3)+DETA
        DETA=SQRT(B11+B22+0.000001*(A11(1)+A11(2))**2
     *                   +0.000001*(A22(1)+A22(2))**2)
        IF (DETA.EQ.0.) THEN
          B11=999999.
          B12=0.
          B22=999999.
        ELSE
          B11=B11/DETA
          B22=B22/DETA
          B12=A12(3)*(A11(3)+A22(3))/DETA
C
          DETA=PRM0(1)**2
          DETA=1./DETA
          B11=(B11+A11(1)+A11(2)) / 2.*DETA
          B12=(B12+A12(1)+A12(2)) / 2.*DETA
          B22=(B22+A22(1)+A22(2)) / 2.*DETA
        ENDIF
      ELSEIF (ISHA.GT.0) THEN
        DETA=PRM0(1)**2
        DETA=1./DETA
        B11=A11(1)*DETA
        B12=A12(1)*DETA
        B22=A22(1)*DETA
      ELSEIF (ISHB.GT.0) THEN
        DETA=PRM0(1)**2
        DETA=1./DETA
        B11=A11(2)*DETA
        B12=A12(2)*DETA
        B22=A22(2)*DETA
      ELSE
C       RP3D-028
        CALL ERROR('RP3D-028: Wrongly invoked RPMEGS.')
C       This error should not appear.
C       Please contact the author or try to
C       change the input data.
      ENDIF
      END
C
C=======================================================================
C
      SUBROUTINE RPERR(IERR)
C
C-----------------------------------------------------------------------
      INTEGER IERR
C
C Subroutine designed to print error messages of different
C RP* subroutines using command 'PAUSE'.
C
C Input:
C     IERR... Index of the error.
C No output.
C Coded by Petr Bulant
C-----------------------------------------------------------------------
C
      IF         (IERR.EQ.001) THEN
C           RP3D-001
        CALL ERROR('RP3D-001: A ray was not found in the memory.')
C       A ray which should have been in the computer memory was not
C       found there. This error should not appear.
C       Please contact the author or try to
C       change the input data.
C
      ELSEIF     (IERR.EQ.002) THEN
C           RP3D-002
        CALL ERROR('RP3D-002: A triangle was not found in the memory.')
C       A triangle which should have been in the computer memory was not
C       found there. This error should not appear.
C       Please contact the author or try to
C       change the input data.
C
      ELSEIF     (IERR.EQ.003) THEN
C           RP3D-003
        CALL ERROR('RP3D-003: Impossible to find boundary rays.')
C       Rounding error does not allow for sufficiently fine division of
C       the basic step in the ray parameters.  Numerically, there is no
C       ray between the two rays, and it is thus impossible to find the
C       boundary rays.  It is recommended to decrease the allowed error
C       UEB of the
C       computation of the ray, or to increase the maximum distance
C       AERR between
C       the boundary rays.
C
      ELSEIF     (IERR.EQ.004) THEN
C           RP3D-004
        CALL ERROR('RP3D-004: Determinant is not positive.')
C       This error should not appear.
C       Please contact the author or try to
C       change the input data.
C
      ELSEIF     (IERR.EQ.005) THEN
C           RP3D-005
        CALL ERROR('RP3D-005: Insufficient memory for KPOL.')
C       This error may be caused by too small dimension of array
C       KPOL. Try to enlarge the parameter MPOL in subroutines
C       RPDIV and RPLRIP.
C
      ELSEIF     (IERR.EQ.006) THEN
C           RP3D-006
        CALL ERROR('RP3D-006: Insufficient memory for KPOLH.')
C       This error may be caused by too small dimension of array
C       KPOLH. Try to enlarge the parameter MPOLH in subroutines
C       RPDIV and RPLRIP.
C
      ELSEIF     (IERR.EQ.007) THEN
C           RP3D-007
        CALL ERROR('RP3D-007: Insufficient memory for KLINE.')
C       This error may be caused by too small dimension of array
C       KLINE. Try to enlarge the parameter MLINE in subroutine
C       RPDIV.
C
      ELSEIF     (IERR.EQ.008) THEN
C           RP3D-008
        CALL ERROR('RP3D-008: Insufficient memory for KBR.')
C       This error may be caused by too small dimension of array
C       KBR. Try to enlarge the parameter MBR in common block BOURA
C       in file rp3d.inc.
C
      ELSEIF     (IERR.EQ.010) THEN
C           RP3D-010
        CALL ERROR('RP3D-010: Insufficient memory for KPL.')
C       This error may be caused by too small dimension of array
C       KPL. Try to enlarge the parameter MPL in common block POLY
C       in file rp3d.inc.
C
      ELSE
C           RP3D-999
        CALL ERROR('RP3D-999: Wrong index of an error.')
C       The subroutine was invocated with wrong error index.
C       This error should not appear.
C       Please contact the author.
      ENDIF
      END
C
C=======================================================================
C
      SUBROUTINE RPKBR(KRAYA,KRAYB,KRAYN)
C
C-----------------------------------------------------------------------
      INTEGER KRAYA,KRAYB,KRAYN
C
C Subroutine designed to store the ray with index KRAYN to the array
C KBR, assuming that KRAYA and KRAYB are indices of the basic rays,
C forming the side on which the ray KRAYN lies, in the same consequence
C in which they are stored in KBR.
C
C Input:
C     KRAYA,KRAYB... Indices of two basic rays. The rays are assumed
C             to form the side of a basic triangle on which the ray
C             KRAYN lies. The consequence of the rays KRAYA and KRAYB
C             is assumed to be the same as the consequence in which they
C             are stored in KBR.
C     KRAYN... Index of a ray to be stored to array KBR.
C No output.
C
C Coded by Petr Bulant
C
C.......................................................................
C
C Common block /BOURA/:
      INCLUDE 'rp3d.inc'
C     rp3d.inc
C
C.......................................................................
C Auxiliary storage locations:
      INTEGER J1,J2,I1
      INTEGER ITYPEN,ISHN,ITYPE,ISH
      REAL G1N,G2N,G1,G2,G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2
      LOGICAL LRAY
C-----------------------------------------------------------------------
      CALL RPRAY(KRAYN,LRAY,ITYPEN,ISHN,G1N,G2N,G11,G12,G22,
     *             X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      IF (NBR.GT.2) THEN
C       The side KRAYA,KRAYB may already be in KBR, rays might be
C       just added to it in KBR:
        J1=1
  11    CONTINUE
C       Loop for the rays in KBR:
          IF ((KBR(J1,1).EQ.KRAYA).AND.(KBR(J1+1,1).EQ.KRAYB)) THEN
            IF (KBR(J1+2,1).LE.0) THEN
              J2=J1+3
              GOTO 13
            ENDIF
            J2=0
            IF ((G1N.LE.GBR(J1,1).AND.G1N.GE.GBR(J1+3,1)).OR.
     *          (G1N.GE.GBR(J1,1).AND.G1N.LE.GBR(J1+3,1))) J2=J1+3
            DO 12, I1=J1+3,J1+1+KBR(J1+2,1)
              IF ((G1N.GE.GBR(I1,1).AND.G1N.LE.GBR(I1+1,1)).OR.
     *            (G1N.LE.GBR(I1,1).AND.G1N.GE.GBR(I1+1,1))) J2=I1+1
  12        CONTINUE
            I1=J1+2+KBR(J1+2,1)
            IF ((G1N.LE.GBR(I1,1).AND.G1N.GE.GBR(J1+1,1)).OR.
     *          (G1N.GE.GBR(I1,1).AND.G1N.LE.GBR(J1+1,1))) J2=I1+1
  13        CONTINUE
            IF (J2.NE.0) THEN
C             Now J2 points to the position in KBR,
C             where ray KRAYN is to be added:
              IF (NBR+1.GT.MBR) CALL RPERR(8)
              IF (NBR.GE.J2) NBR=NBR+1
              DO 15, I1=NBR,J2+1,-1
                KBR(I1,1)=KBR(I1-1,1)
                KBR(I1,2)=KBR(I1-1,2)
                KBR(I1,3)=KBR(I1-1,3)
                GBR(I1,1)=GBR(I1-1,1)
                GBR(I1,2)=GBR(I1-1,2)
   15         CONTINUE
              NBR=MAX0(NBR,J2)
              KBR(J2,1)=KRAYN
              KBR(J2,2)=ISHN
              KBR(J2,3)=ITYPEN
              GBR(J2,1)=G1N
              GBR(J2,2)=G2N
              KBR(J1+2,1)=KBR(J1+2,1)+1
            ENDIF
            RETURN
          ENDIF
          J1=J1+3+KBR(J1+2,1)
        IF (J1.LT.NBR) GOTO 11
C       End of the loop for the rays in KBR.
      ENDIF
C
C     The side KRAYA,KRAYB is not in KBR, rays will be stored to KBR:
      IF (NBR.GE.MBR) CALL RPERR(8)
      CALL RPRAY(KRAYA,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      NBR=NBR+1
      KBR(NBR,1)=KRAYA
      KBR(NBR,2)=0
      KBR(NBR,3)=0
      GBR(NBR,1)=G1
      GBR(NBR,2)=G2
      IF (NBR.GE.MBR) CALL RPERR(8)
      CALL RPRAY(KRAYB,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22,
     *           X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      NBR=NBR+1
      KBR(NBR,1)=KRAYB
      KBR(NBR,2)=0
      KBR(NBR,3)=0
      GBR(NBR,1)=G1
      GBR(NBR,2)=G2
      IF (NBR.GE.MBR) CALL RPERR(8)
      NBR=NBR+1
      KBR(NBR,1)=1
      KBR(NBR,2)=0
      KBR(NBR,3)=0
      GBR(NBR,1)=0
      GBR(NBR,2)=0
      IF (NBR.GE.MBR) CALL RPERR(8)
      NBR=NBR+1
      KBR(NBR,1)=KRAYN
      KBR(NBR,2)=ISHN
      KBR(NBR,3)=ITYPEN
      GBR(NBR,1)=G1N
      GBR(NBR,2)=G2N
      RETURN
      END
C
C=======================================================================
C
      REAL FUNCTION RPDI2L(IRAYB,IRAYA,IRAYC)
C
C----------------------------------------------------------------------
      INTEGER IRAYB,IRAYA,IRAYC
C Subroutine designed to compute the second power of the distance
C of the ray A from the line connecting rays B and C on the normalized
C ray domain.
C
C Input:
C     IRAYB,IRAYA,IRAYC... Indices of the rays.
C
C Output:
C     RPDI2L... Second power of the distance.
C
C Coded by Petr Bulant
C
C......................................................................
      EXTERNAL RPDI2G
      REAL     RPDI2G
      INTEGER ITYPE,ISH
      REAL ZERO,AREA2,DIST2,DETG
      PARAMETER (ZERO=.0000001)
      REAL G11POM,G12POM,G22POM,X1,X2,G1X1,G2X1,G1X2,G2X2
      REAL G1A,G2A,G11A,G12A,G22A
      REAL G1B,G2B,G11B,G12B,G22B
      REAL G1C,G2C,G11C,G12C,G22C
      LOGICAL LRAY
C-----------------------------------------------------------------------
      CALL RPRAY(IRAYB,LRAY,ITYPE,ISH,G1B,G2B,G11B,G12B,G22B,
     *                   X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(IRAYA,LRAY,ITYPE,ISH,G1A,G2A,G11A,G12A,G22A,
     *                   X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      CALL RPRAY(IRAYC,LRAY,ITYPE,ISH,G1C,G2C,G11C,G12C,G22C,
     *                   X1,X2,G1X1,G2X1,G1X2,G2X2)
      IF (.NOT.LRAY) CALL RPERR(1)
      G11POM=(G11A+G11C+G11B)/3.
      G12POM=(G12A+G12C+G12B)/3.
      G22POM=(G22A+G22C+G22B)/3.
      DIST2=RPDI2G(G1C,G2C,G1B,G2B,G11POM,G12POM,G22POM)
      IF (DIST2.GE.ZERO) THEN
        DETG=G11POM*G22POM - G12POM*G12POM
        IF (DETG.LT.ZERO) CALL RPERR(4)
        AREA2=DETG*(((G1C-G1B)*(G2A-G2B)-(G2C-G2B)*(G1A-G1B))**2)
C       Distance: (AREA2 is the area**2)
        RPDI2L=AREA2/DIST2
      ELSE
        RPDI2L=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM)
      ENDIF
      RETURN
      END
C
C=======================================================================
C
C                                                  
      SUBROUTINE RPSTOR(CHAR,IRAY,KTRIS)
C
C-----------------------------------------------------------------------
      CHARACTER CHAR
      INTEGER IRAY,KTRIS(6)
C
C Subroutine designed to store the parameters of the ray IRAY or of the
C triangle KTRIS to the output files for plotting.
C
C Attention:  To enable this subroutine, turn the first RETURN statement
C (i.e., first executable statement) of this subroutine into a
C comment line.
C
C Input:
C     CHAR... Indicates what is to be stored:
C             CHAR='R'... The ray with sign IRAY.
C             CHAR='T'... The triangle KTRIS.
C     IRAY... Index of the ray to be stored.
C             IRAY= 0 when opening the output files,
C             IRAY=-1 when closing the output files.
C     KTRIS... Parameters of the triangle to be stored (one column of
C             array KTRI).
C No output
C
C Note that only the rays and triangles of the last computed
C elementary wave are stored in the output files.
C
C Output formatted file 'rp.out' with the parameters of the rays of the last
C computed elementary wave:
C (1) For each ray:
C (1.1) IRAY,ITYPE,ISH,G1R,G2R,G11,G12,G22,X1R,X2R
C     See the description of these variables below.
C (2) End of file.
C
C Output formatted file 'rprt.out' with the parameters of the rays
C and triangles of the last computed elementary wave:
C (1) For each ray or triangle two lines of data (1.1) and (1.2):
C For a ray:
C (1.1) 'R'
C     Indicates data for a ray on the following line.
C (1.2) IRAY,ITYPE,ISH,G1R,G2R,X1R,X2R
C     Parameters of the ray. See the description of these variables
C     below.
C For a triangle:
C (1.1) 'T'
C     Indicates data for a triangle on the following line.
C (1.2) ISH,KTRIS,G1R,G2R,G1S,G2S,G1T,G2T,X1R,X2R,X1S,X2S,X1T,X2T
C     Parameters of the triangle. See the description of these variables
C     below.
C (2) End of file.
C
C.......................................................................
      INTEGER ITYPE,ISH
      REAL G1R,G2R,G1S,G2S,G1T,G2T,G11,G12,G22,X1R,X2R,X1S,X2S,X1T,X2T
      REAL G1X1,G2X1,G1X2,G2X2
      LOGICAL LRAY
C     ITYPE... Type of ray.
C     ISH...  Value of history function.
C     G1_,G2_... Normalized parameters of rays.
C     G11,G12,G22... Ray-parameter metric tensor.
C     X1_,X2_... Coordinates of the ray on the reference surface.
C     G1X1,G2X1,G1X2,G2X2... Derivations of ray parameters according to
C             the surface coordinates.
C     LRAY... Indicates whether the ray IRAY is in memory.
C-----------------------------------------------------------------------
C
      RETURN
C
      IF (CHAR.EQ.'R') THEN
        IF (IRAY.EQ.0) THEN
          OPEN (40,FILE='rp.out')
          OPEN (50,FILE='rprt.out')
        ELSEIF (IRAY.EQ.-1) THEN
          CLOSE (40)
          CLOSE (50)
        ELSE
          CALL RPRAY(IRAY,LRAY,ITYPE,ISH,G1R,G2R,G11,G12,G22,X1R,X2R,
     *             G1X1,G2X1,G1X2,G2X2)
          IF (.NOT.LRAY) CALL RPERR(1)
          WRITE(40,'(3I6,2F15.6,3F15.3,2F15.5)')
     *         IRAY,ITYPE,ISH,G1R,G2R,G11,G12,G22,X1R,X2R
          WRITE(50,*) 'R'
          WRITE(50,'(3I6,4F12.6)')
     *    IRAY,ITYPE,ISH,G1R,G2R,X1R,X2R
        ENDIF
      ELSEIF (CHAR.EQ.'T') THEN
        CALL RPRAY(KTRIS(1),LRAY,ITYPE,ISH,G1R,G2R,G11,G12,G22,X1R,X2R
     *            ,G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISH,G1S,G2S,G11,G12,G22,X1S,X2S,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1T,G2T,G11,G12,G22,X1T,X2T,
     *             G1X1,G2X1,G1X2,G2X2)
        IF (.NOT.LRAY) CALL RPERR(1)
        IF ((KTRIS(6).NE.3).AND.(KTRIS(6).NE.4)) ISH=0
        WRITE(50,*) 'T'
        WRITE(50,'(7I6,12F12.6)') ISH,KTRIS,G1R,G2R,G1S,G2S,G1T,G2T
     *                            ,X1R,X2R,X1S,X2S,X1T,X2T
      ELSE
C       RP3D-029
        CALL ERROR('RP3D-029: Wrongly invoked storing.')
C       This error should not appear.
C       Please contact the author.
      ENDIF
      RETURN
      END
C
C=======================================================================
C