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 fuly 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 AERR, PRM0, PAR1L, PAR2L, PAR1A, PAR2A, PAR1B, PAR2B, C ANUM, BNUM; see the file 'rpar.for') and run again. The authors will C appreciate any information concerning the bugs in the code. C !!!!!!!!!!!!!!!!!!!!!!!!!!!! C C The subroutine is able to produce formatted output files, suitable C for ploting using the programs KR*. This may be very usefull for C debugging or when choosing the optimum shooting parameters. C Replace the '*S' by ' ' at the first two columns of this file C 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. PAGEOPH, in press; 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 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 compu- C tation 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 required: C RPNEW,RPWHAD,RPINTS,RPAST,RPDIV,RPINTP,RPMEM,RPTRI1, C RPAUX1,RPERAS,RPGMEA,RPXMEA,RPCOBL,RPSTOR,RPCROS,RPLRTC, C RPDPA,RPHPDI,RPMEGS C External functions required: EXTERNAL RPLRIT,RPLRIP,RPDI2G,RPLRIL LOGICAL RPLRIT,RPLRIP,RPLRIL REAL RPDI2G C Error mesages of the subroutines RP*: C The error messages are mainly in following form: C ERROR: TRIANGLE NOT FOUND IN THE MEMORY I C ERROR: RAY NOT IN THE MEMORY I C ERROR: DETERMINANT NEGATIVE C ERROR: DETERMINANT EQUAL TO ZERO C ERROR: INSUFFICIENT MEMORY FOR ... C ERROR: WRONGLY ... C ERROR IN ... C C C Date: 1996, August 29 C C Coded by Petr Bulant C bulant@seis.karlov.mff.cuni.cz C C ........................... C Common block /RPARD/: INCLUDE 'rpard.inc' C PRM0(2) ... Maximum alloved length of the homogeneous triangles C sides (measured on the reference surface). C............................ C C Common block /GLIM/: REAL GLIMIT(4) COMMON/GLIM/GLIMIT C GLIMIT ... Limits of the normalized ray domain. C C....................................................................... INTEGER IRAY0,ITRI0,ITRI INTEGER ITRI0D,ITRI0G,ITRI0X,ITRI0I,ITRI1,ITRIE CCC INTEGER ITRI0D,ITRI0G,ITRI0X,ITRI0A,ITRI0I,ITRI1,ITRIE INTEGER KTRID(6),KTRIN(6),KTRIS(6) INTEGER ITRNAR INTEGER ISHEET,ISH REAL G1,G2,G11,G12,G22,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,ITRI0G,ITRI0X,ITRI0I CCC SAVE IRAY0,ITRI0,ITRI,ITRI0D,ITRI0G,ITRI0X,ITRI0A,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 A..Storing auxiliary rays. 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 > 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 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 C new auxiliary 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 RPGMEA 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 ITRI0G=0 ITRI0X=0 CCC ITRI0A=0 ITRI0I=0 ITRIE=100 CALL RPTRI1(ITRI,KTRIS) CALL RPAUX1(ITRI,IRAY) CALL RPMEM(IRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2, * G1X1,G2X1,G1X2,G2X2) CALL RPDIV(KTRIS,IRAY,ITRI,G1NEW,G2NEW,LNEWAR,LAB20) *S CALL RPSTOR('R',0,KTRIS) CALL RPGMEA(I1,ITRI,IRAY,LNEWAR,LAB20,G1NEW,G2NEW) CALL RPXMEA(I1,ITRI,IRAY,LNEWAR,LAB20,G1NEW,G2NEW) GOTO 10 ENDIF C *S 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) *S IF (LTRI.AND.KTRID(6).EQ.0) CALL RPSTOR ('T',1,KTRID) 18 CONTINUE CCC Shooting the basic rays only: CCC IF ((IRAY.NE.IRAY0).OR.(ITRI.NE.ITRI0)) THEN CCC GOTO 10 CCC ELSE CCC IRAY=0 CCC RETURN CCC ENDIF CCC 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 Controling the size of the homogeneous triangles, C dividing triangles too large in normalized ray domain. 42 CONTINUE I1=ITRI0G 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 RPGMEA(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 ITRI0G=I1 GOTO 45 C 51 CONTINUE IF (LAB20) THEN C Inhomogeneous triangles have been formed running RPGMEA: GOTO 20 ENDIF IF (I1.LT.ITRI) THEN C New homogeneous triangles to be measured C have been formed running RPGMEA: GOTO 42 ENDIF C C C C Controling 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 C Storing auxiliary rays according to homogeneous triangles in G1,G2 C Storing homogeneous rays starting in homogeneous triangle and C terminating in the same triangle or in the neighbouring triangles. CCC CCC Auxiliary rays are not stored, vertices of triangles are used CCC automaticaly and found two-point rays are stored in RPINTP. CCC CCC DO 52, I1=ITRI0A+1,ITRI CCC CALL RPTRI3(I1,LTRI,KTRID) CCC IF ((KTRID(6).EQ.3).AND.LTRI) THEN CCC CALL RPRAY(KTRID(1),LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2, CCC * G1X1,G2X1,G1X2,G2X2) CCC IF (.NOT.LRAY) THEN CCC PAUSE 'ERROR: RAY NOT IN THE MEMORY 1' CCC STOP CCC ENDIF CCC CCCC UKLADAM POMOCNE PAPRSKY: CCC IF (ISHEET.GT.0) THEN CCC CALL RPAUX2(I1,0,J1) CCC IF (J1.EQ.0) CALL RPAST(I1,IRAY0,IRAY) CCC ENDIF CCC CCC ENDIF CCC ITRI0A=I1 CCC 52 CONTINUE 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 2' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 3' STOP ENDIF C First ray of the triangle in which the last traced ray starts: CALL RPTRI3(ITRNAR,LTRI,KTRIS) IF (.NOT.LTRI) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 5.' STOP ENDIF CALL RPRAY(KTRIS(1),LRAY,ITRAS(1),ISH,G1S(1),G2S(1), * G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 4' STOP ENDIF C IF (ISH.NE.ISHEET) THEN C Strange ray identified inside homogeneous triangle: IF (ITYPE.NE.-2) THEN PAUSE 'ERROR: WRONGLY DETERMINED TWO-POINT RAY' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 5' STOP ENDIF CALL RPRAY(KTRIS(3),LRAY,ITRAS(3),ISH,G1S(3),G2S(3), * G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 6' STOP ENDIF C Dividing of the triangle into inhomogeneous triangles: KTRIS(6)=2 CALL RPTRI2(KTRIS(4),LTRI,KTRIS) IF (.NOT.LTRI) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 1.' STOP ENDIF 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) *S 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 *S 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 C made running 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 block /GLIM/: REAL GLIMIT(4) COMMON/GLIM/GLIMIT C GLIMIT ... Limits of the normalized ray domain. C............................ C C Common block /RPARD/: INCLUDE 'rpard.inc' C AERR...Maximum distance of the boundary rays. C PRM0(1) ... Maximum alloved distance of the boundary ray from the C shadow zone (measured on the reference surface). C............................ C C Common block /BOURA/: INTEGER MBR PARAMETER (MBR=5000) INTEGER NBR,KBR(MBR,3) REAL GBR(MBR,2) COMMON/BOURA/NBR,KBR,GBR C C MBR...Dimension of arrays KBR,GBR. C NBR........Number of rays stored in KBR. C KBR...Array of boundary rays lying on the sides of basic triangles C and used only once. If a new triangle is to be divided, C boundary rays are used from KBR. C KBR(J+1,1)...Index of first vertice of the basic triangle. C KBR(J+2,1)...Index of second vertice of the basic triangle. C KBR(J+3,1)...Number of rays, lying on the side formed by C these two rays. C KBR(I,1)...Array of indices of boundary rays. C (I=J+4...J+3+KBR(J+3,1)) C KBR(I,2)...Array of sheets of boundary rays. C KBR(I,3)...Array of types of boundary rays. C GBR(I,1)...Array of normalized ray parameters G1 of boundary rays. C GBR(I,2)...Array of normalized ray parameters G2 of boundary rays. C C....................................................................... C REAL ZERO,ZERO1 PARAMETER (ZERO =.0000001) PARAMETER (ZERO1=.0000000001) REAL BSTEP2 PARAMETER (BSTEP2=0.23) REAL AERR2 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 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,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,J30 LOGICAL LRAY,LTRI,LSTORE,LINTS,LDGEAE SAVE AERR2, * 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 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 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 polygone C to be divided into homogeneous polygons. C KPOL(I,2) ...Values of integer history functions of rays forming C the polygone. 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 or 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 polygone 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 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 interval. C KLINE(I,2)...Sheets 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 hom. 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,2)...Sheets 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 KLINE(I,1)<0 notes that side I,I+1 in KLINE is to be divided. 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 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 | (always commented) 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 controling the loop. C I1 ... Controls the main loop of checking KPOL (until label 50). C I4 ... When ISTART>0 and searching for basic hom. pol., I4 is the C 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 occured. C J5 ... When MAXR=0 and starting consequently from all the groups, C the sequence of the group. C J30... Used when closing the hom. pol.: C J30.LE.J3 iniciates 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 repared 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 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 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 25' STOP ENDIF KRAYA=KTRID(1) CALL RPRAY(KTRID(2),LRAY,ITYPEB,ISHB,G1B,G2B,G11B,G12B,G22B, * X1,X2,G1X1B,G2X1B,G1X2B,G2X2B) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 26' STOP ENDIF KRAYB=KTRID(2) CALL RPRAY(KTRID(3),LRAY,ITYPEC,ISHC,G1C,G2C,G11C,G12C,G22C, * X1,X2,G1X1C,G2X1C,G1X2C,G2X2C) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 27' STOP ENDIF 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) THEN PAUSE 'ERROR: DETERMINANT NEGATIVE' STOP ENDIF IF (DETG.LT.ZERO) THEN PAUSE 'ERROR: DETERMINANT EQUAL TO ZERO' STOP ENDIF AREA=SQRT(DETG)*((DG1*(G2C-G2A)-DG2*(G1C-G1A))*.5) IF (AREA.LT.((AERR2)*0.4330127/4.)) 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 2.' STOP ENDIF 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 3.' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOL IN RPDIV1' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOL IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOL IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 4.' STOP ENDIF LNEWAR=.FALSE. RETURN ENDIF C C Checking the integrity of the inhomogeneous polygon. C Finding boundary rays, if needed. 15 CONTINUE C Controlling the size of the polygon: AREA1=0. CALL RPRAY(KPOL(1,1),LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 27' STOP ENDIF DG1=GPOL(1,1)-GPOL(NPOL,1) DG2=GPOL(1,2)-GPOL(NPOL,2) DETG=G11*G22 - G12*G12 IF (DETG.LT.-ZERO) THEN PAUSE 'ERROR: DETERMINANT NEGATIVE' STOP ENDIF IF (DETG.LT.ZERO) THEN PAUSE 'ERROR: DETERMINANT EQUAL TO ZERO' STOP ENDIF AREA=SQRT(DETG)*((DG1*(GPOL(2,2)-GPOL(1,2)) * -DG2*(GPOL(2,1)-GPOL(1,1)))*.5) IF (AREA.GT.0.) AREA1=AREA DO 16, I1=2,NPOL-1 CALL RPRAY(KPOL(I1,1),LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 27' STOP ENDIF DG1=GPOL(I1,1)-GPOL(I1-1,1) DG2=GPOL(I1,2)-GPOL(I1-1,2) DETG=G11*G22 - G12*G12 IF (DETG.LT.-ZERO) THEN PAUSE 'ERROR: DETERMINANT NEGATIVE' STOP ENDIF IF (DETG.LT.ZERO) THEN PAUSE 'ERROR: DETERMINANT EQUAL TO ZERO' STOP ENDIF AREA=SQRT(DETG)*((DG1*(GPOL(I1+1,2)-GPOL(I1,2)) * -DG2*(GPOL(I1+1,1)-GPOL(I1,1)))*.5) IF (AREA.GT.0.) AREA1=AREA1+AREA 16 CONTINUE IF (AREA1.LT.((AERR2)*0.4330127/4.)) THEN C The area of the polygon is quite little, C polygon is not to be divided. C The inhom. polygon will be simply divided into hom. 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)) 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) *S 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 2.' STOP ENDIF LNEWAR=.FALSE. RETURN ENDIF I1=2 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 28' STOP ENDIF CALL RPRAY(KRAYB,LRAY,ITYPEB,ISHB,G1B,G2B, * G11B,G12B,G22B,X1,X2,G1X1B,G2X1B,G1X2B,G2X2B) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 29' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 51' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KLINE IN RPDIV 1' STOP ENDIF 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 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 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 51' STOP ENDIF ITYPEA=KRAYB CALL RPMEMC(KRAYA,ITYPEA,ISHA,G1A,G2A,G11A,G12A,G22A,X1,X2, * G1X1,G2X1,G1X2,G2X2) *S 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF ITYPEB=KRAYA CALL RPMEMC(KRAYB,ITYPEB,ISHB,G1B,G2B,G11B,G12B,G22B,X1,X2, * G1X1,G2X1,G1X2,G2X2) *S 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 9.' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF CALL RPRAY(KTRIS(2),LRAY,ITYPED,ISHD,G1D,G2D,G11D,G12D,G22D, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1E,G2E,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: TRIANGLE NOT IN THE MEMORY 3.' STOP ENDIF 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) *S 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) *S 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF CALL RPRAY(KTRIT(2),LRAY,ITYPE,ISH,G1D,G2D,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF CALL RPRAY(KTRIT(3),LRAY,ITYPE,ISH,G1E,G2E,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF 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) *S 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) *S CALL RPSTOR('T',1,KTRIN) LAB20=.TRUE. GOTO 431 ENDIF C End of the loop for all the tr. 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF CALL RPRAY(KRAYC,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF CALL RPRAY(KRAYD,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOL IN RPDIV2' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOL IN RPDIV3' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KLINE IN RPDIV 2' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 28' STOP ENDIF CALL RPRAY(KRAYB,LRAY,ITYPEB,ISHB,G1B,G2B, * G11B,G12B,G22B,X1,X2,G1X1B,G2X1B,G1X2B,G2X2B) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 29' STOP ENDIF 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 9.' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF NBR=NBR+1 CALL RPRAY(KRAYB0,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF KBR(NBR,1)=KRAYB0 KBR(NBR,2)=0 KBR(NBR,3)=0 GBR(NBR,1)=G1 GBR(NBR,2)=G2 IF (NBR.GE.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF NBR=NBR+1 CALL RPRAY(KRAYA0,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF KBR(NBR,1)=KRAYA0 KBR(NBR,2)=0 KBR(NBR,3)=0 GBR(NBR,1)=G1 GBR(NBR,2)=G2 IF (NBR.GE.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF 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 I1=I1+1 IF (I1.LE.NPOL) GOTO 20 C 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOL IN RPDIV4' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOL IN RPDIV5' STOP ENDIF 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 prefering basic hom. polygons with rays of such ISH, C 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 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 > 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 the hom. 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 prefering basic hom. polygons with the higher 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 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 inhom. polygon will be simply divided into hom. 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.,GPOLH(J1,1),GPOLH(J1,2),GPOLH(I1,1), * GPOLH(I1,2),GPOLH(J2,1),GPOLH(J2,2),G1A,G2A)) 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) *S 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 2.' STOP ENDIF 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 > 0, the first group with this number of rays will become to C 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 > 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOLH IN RPDIV' STOP ENDIF 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 hom. pol. is formed, 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 6.' STOP ENDIF 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 150 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 28' STOP ENDIF CALL RPRAY(KRAYB,LRAY,ITYPEB,ISHB,G1B,G2B, * G11B,G12B,G22B,X1,X2,G1X1B,G2X1B,G1X2B,G2X2B) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 29' STOP ENDIF 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 (RPLRIP(NPOL,GPOL,G1NEW,G2NEW)) THEN C Trace a new ray, then go to 110: KRAYC=IRAY+1 IGOTO=2 LNEWAR=.TRUE. RETURN ELSE C Ray C will be replaced by nearest ray of the polygon: MINDIS=999999. DIST2=RPDI2G(G1A,G2A,G1NEW,G2NEW,G11POM,G12POM,G22POM) IF (DIST2.LT.MINDIS) THEN MINDIS=DIST2 KRAYC=KRAYA ENDIF DO 109, I1=1,NPOL DIST2=RPDI2G(GPOL(I1,1),GPOL(I1,2),G1NEW,G2NEW, * G11POM,G12POM,G22POM) IF (DIST2.LT.MINDIS) THEN MINDIS=DIST2 KRAYC=KPOL(I1,1) ENDIF 109 CONTINUE IF (MINDIS.EQ.999999.) THEN PAUSE 'ERROR IN RPDIV AFTER LABEL 109' STOP ENDIF CALL RPRAY(KRAYC,LRAY,ITYPEC,ISHC,G1C,G2C,G11C,G12C,G22C,X1,X2, * G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF GOTO 116 ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 25' STOP ENDIF CALL RPRAY(KPOL(I2,1),LRAY,ITYPEX,ISHX,G1X,G2X,G11X,G12X * ,G22X,X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 25' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOL, RPDIV6' STOP ENDIF 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 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) THEN PAUSE 'ERROR: DETERMINANT NEGATIVE' STOP ENDIF IF (DETG.LT.ZERO) THEN PAUSE 'ERROR: DETERMINANT EQUAL TO ZERO' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF CALL RPRAY(KRAYB,LRAY,ITYPEB,ISHB,G1B,G2B,G11B,G12B,G22B,X1,X2, * G1X1B,G2X1B,G1X2B,G2X2B) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 25' STOP ENDIF CALL RPRAY(KPOL(I2,1),LRAY,ITYPEX,ISHX,G1X,G2X,G11X,G12X, * G22X,X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 25' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOL IN RPDIV7' STOP ENDIF 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 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 51' STOP ENDIF 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.ZERO1).OR.(ABS(G2B-G2A).GE.ZERO1)) THEN C Trace a new ray, then go to 130: G1NEW=(G1A+G1B)/2 G2NEW=(G2A+G2B)/2 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 51' STOP ENDIF ITYPEA=KRAYB CALL RPMEMC(KRAYA,ITYPEA,ISHA,G1A,G2A,G11A,G12A,G22A,X1,X2, * G1X1,G2X1,G1X2,G2X2) *S 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF ITYPEB=KRAYA CALL RPMEMC(KRAYB,ITYPEB,ISHB,G1B,G2B,G11B,G12B,G22B,X1,X2, * G1X1,G2X1,G1X2,G2X2) *S CALL RPSTOR('R',KRAYB,KTRIS) C Storing boundary rays to KLINE: IF (NLINE.GE.MLINE) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KLINE IN RPDIV 3' STOP ENDIF 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 Criterium 1: (Distance of the ray J3+1 from the C line connecting rays J3 and J3+2) < (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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF CALL RPRAY(IABS(KLINE(J3+1,1)),LRAY,ITYPEA,ISHA,G1A,G2A, * G11A,G12A,G22A,X1,X2,G1X1A,G2X1A,G1X2A,G2X2A) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF CALL RPRAY(IABS(KLINE(J3+2,1)),LRAY,ITYPEC,ISHC,G1C,G2C, * G11C,G12C,G22C,X1,X2,G1X1C,G2X1C,G1X2C,G2X2C) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF 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) THEN PAUSE 'ERROR: DETERMINANT NEGATIVE' STOP ENDIF IF (DETG.LT.ZERO) THEN PAUSE 'ERROR: DETERMINANT EQUAL TO ZERO' STOP ENDIF AREA=DETG*(((G1C-G1B)*(G2A-G2B)-(G2C-G2B)*(G1A-G1B))**2) C Distance: (AREA is the area**2) DIST2=AREA/DIST2 IF (DIST2.LE.16*AERR2) THEN C Criterium 2: (Distance of the rays J3 and J3+1)**2 < BSTEP2 : DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM) IF (DIST2.LE.BSTEP2) THEN C Criterium 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 J3 = NLINE-1 now: C Criterium 2: (Distance of the rays J3 and J3+1)**2 < BSTEP2: 145 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF CALL RPRAY(IABS(KLINE(J3+1,1)),LRAY,ITYPEA,ISHA,G1A,G2A,G11A,G12A, * G22A,X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF G11POM=(G11A+G11B)/2 G12POM=(G12A+G12B)/2 G22POM=(G22A+G22B)/2 DIST2=RPDI2G(G1A,G2A,G1B,G2B,G11POM,G12POM,G22POM) IF (DIST2.LE.BSTEP2) THEN C Criterium 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 Boundary is found: IF (J30.NE.999999) THEN J3=J30 J30=999999 GOTO 107 ENDIF GOTO 143 ENDIF GOTO 107 C C The boundary closing the homogeneous polygon is found. C Both homogeneous and inhomogeneous polygons will be corrected now: 143 CONTINUE J5=0 ISTART=0 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOL IN RPDIV8' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOLH IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF GPOLH(NPOLH,1)=G1A GPOLH(NPOLH,2)=G2A 149 CONTINUE NLINE=0 C C C The homogeneous polygon is prepared to be divided: 150 CONTINUE LNEWAR=.FALSE. IF (NPOLH.LT.3) THEN C In this situation a very small part of the domain C will escape notice. DO 151, 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 151 CONTINUE NPOLH=0 ISTART=0 IF (NPOL.GE.2) THEN GOTO 15 ENDIF KTRID(6)=2 CALL RPTRI2(KTRID(4),LTRI,KTRID) IF (.NOT.LTRI) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 8.' STOP ENDIF 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)) 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) *S CALL RPSTOR('T',1,KTRIN) ENDIF NPOLH=0 ISTART=0 IF (NPOL.GE.2) THEN GOTO 15 ENDIF KTRID(6)=2 CALL RPTRI2(KTRID(4),LTRI,KTRID) IF (.NOT.LTRI) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 8.' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 30' STOP ENDIF 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 ISTART=0 IF (NPOL.GE.2) THEN GOTO 15 ENDIF KTRID(6)=2 CALL RPTRI2(KTRID(4),LTRI,KTRID) IF (.NOT.LTRI) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 8.' STOP ENDIF LNEWAR=.FALSE. RETURN ENDIF GOTO 150 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 REAL RPDI2G LOGICAL RPLRIL C C Coded by Petr Bulant C C....................................................................... C C Common block /GLIM/: REAL GLIMIT(4) COMMON/GLIM/GLIMIT C GLIMIT ... Limits of the normalized ray domain. C............................ C Common block /POLY/: INTEGER MPL PARAMETER (MPL=800) INTEGER NPL,KPL(MPL) COMMON /POLY/NPL,KPL C MPL ... Maximum dimension of KPL. C NPL ... Number of points of polyline boundary of the region C covered by the basic triangles. C KPL ... Indices of rays forming the polyline. 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,ZERO1 PARAMETER (ZERO =.0000001) PARAMETER (ZERO1=.0000000001) 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,DETG,VECT,DIST2 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, the C sequence (in KPL) of this ray on polyline; C when as the new ray is taken a corner ray of the normali- C zed 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 controling 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 polyline C or that it is a corner ray of domain (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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 7' STOP ENDIF CALL RPRAY(2,LRAY,ITYPE,ISHEET,G1R2,G2R2,G11R2,G12R2,G22R2, * X1R2,X2R2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 8' STOP ENDIF 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 G2NEW=GLIMIT(3) LNEWAR=.TRUE. RETURN ENDIF KPL(1)=1 NPL=1 DO 10, I1=5,IRAY IF (NPL.GE.MPL) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR POLYLINE IN RPNEW 1' STOP ENDIF NPL=NPL+1 KPL(NPL)=I1 10 CONTINUE IF(NPL.GE.MPL) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR POLYLINE IN RPNEW 2' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 9' STOP ENDIF CALL RPRAY(KPL(IRADD2),LRAY,ITYPE,ISHEET,G1N,G2N, * G11N,G12N,G22N,X1N,X2N,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 10' STOP ENDIF 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) THEN PAUSE 'ERROR: DETERMINANT NEGATIVE' STOP ENDIF IF (DETG.LT.ZERO) THEN PAUSE 'ERROR: DETERMINANT EQUAL TO ZERO' STOP ENDIF 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 G2NEW=G2NEW - (G1NEW-GLIMIT(1))*G12POM/G22POM G1NEW=GLIMIT(1) ENDIF IF (G1NEW.GT.GLIMIT(2)) THEN G2NEW=G2NEW - (G1NEW-GLIMIT(2))*G12POM/G22POM G1NEW=GLIMIT(2) ENDIF IF (G2NEW.LT.GLIMIT(3)) THEN G1NEW=G1NEW - (G2NEW-GLIMIT(3))*G12POM/G11POM G2NEW=GLIMIT(3) ENDIF IF (G2NEW.GT.GLIMIT(4)) THEN G1NEW=G1NEW - (G2NEW-GLIMIT(4))*G12POM/G11POM G2NEW=GLIMIT(4) 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 G2NEW=GLIMIT(4) G1NEW=G1NEW+AAA ENDIF C AAA=GLIMIT(1)-G1NEW BBB=-AAA*G12POM/G22POM DIST2=AAA*(AAA*G11POM+2*BBB*G12POM)+BBB*G22POM*BBB IF (DIST2.LT.NEAR2) THEN G1NEW=GLIMIT(1) G2NEW=G2NEW+BBB ENDIF C AAA=GLIMIT(2)-G1NEW BBB=-AAA*G12POM/G22POM DIST2=AAA*(AAA*G11POM+2*BBB*G12POM)+BBB*G22POM*BBB IF (DIST2.LT.NEAR2) THEN G1NEW=GLIMIT(2) G2NEW=G2NEW+BBB ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 11' STOP ENDIF DIST2=RPDI2G(G1NEW,G2NEW,G1,G2,G11,G12,G22) IF (DIST2.LT.NEAR2) THEN G1NEW=G1 G2NEW=G2 LIONPL=.TRUE. IONPOL=0 GOTO 16 ENDIF 15 CONTINUE 16 CONTINUE DO 20, I1=MAX0(1,IRADD1-1),MIN0(NPL,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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 12' STOP ENDIF DIST2=RPDI2G(G1NEW,G2NEW,G1,G2,G11,G12,G22) IF (DIST2.LT.NEAR2) 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 13' STOP ENDIF VECT=(G1M-G1NEW)*(G2J-G2NEW)-(G1J-G1NEW)*(G2M-G2NEW) IF (VECT.GT.ZERO) THEN IONPOL=IRADD1-1 G1NEW=G1J G2NEW=G2J ELSE PAUSE 'ERROR IN RPNEW, M E Z E R A' STOP ENDIF ELSE CALL RPRAY(KPL(IRADD2+1),LRAY,ITYPE,ISHEET,G1J,G2J, * G11J,G12J,G22J,X1J,X2J,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 14' STOP ENDIF VECT=(G1N-G1NEW)*(G2J-G2NEW)-(G1J-G1NEW)*(G2N-G2NEW) IF (VECT.LT.ZERO) THEN IONPOL=IRADD2+1 G1NEW=G1J G2NEW=G2J ELSE PAUSE 'ERROR IN RPNEW, M E Z E R A' STOP ENDIF ENDIF 50 CONTINUE C C New ray is proposed, now performing the last control: 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 PAUSE 'ERROR: WRONGLY PROPOSED NEW RAY' STOP ENDIF ENDIF IF (LIONPL) THEN LNEWAR=.FALSE. ELSE LNEWAR=.TRUE. ENDIF C 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR POLYLINE IN RPNEW 3' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR POLYLINE IN RPNEW 4' STOP ENDIF 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 polyline C or that it is a corner ray of domain (then IONPOL=0). C IONPOL..When as the new ray is taken some ray of the polyline, the C sequence (in KPL) of this ray on polyline; C when as the new ray is taken a corner ray of the normali- C zed domain, zero. C Output: C LINTS...Indicates whether the intersection appeared. C LIONPL..Indicates that the new ray is the IONPOL's ray on polyline C or that it is a corner ray of domain (then IONPOL=0). C IONPOL..When as the new ray is taken some ray of the polyline, the C sequence (in KPL) of this ray on polyline; C when as the new ray is taken a corner ray of the normali- C zed domain, zero. C C Coded by Petr Bulant C C....................................................................... C Common block /POLY/: INTEGER MPL PARAMETER (MPL=800) INTEGER NPL,KPL(MPL) COMMON /POLY/NPL,KPL C MPL ... Maximum dimension of KPL. C NPL ... Number of points of polyline boundary of the region C covered by the basic triangles. C KPL ... Indices of rays forming the polyline. C None of the storage locations of the common block are altered. C....................................................................... C REAL ZERO,ZERO1 PARAMETER (ZERO =.0000001) PARAMETER (ZERO1=.0000000001) 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 controling 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 15' STOP ENDIF CALL RPRAY(KPL(I1+1),LRAY,ITYPE,ISHEET,G1K,G2K,G11K,G12K,G22K, * X1K,X2K,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 16' STOP ENDIF CALL RPRAY(KPL(ISIGN),LRAY,ITYPE,ISHEET,G1L,G2L, * G11L,G12L,G22L,X1L,X2L,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 17' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 18' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 19' STOP ENDIF 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 block /GLIM/: REAL GLIMIT(4) COMMON/GLIM/GLIMIT C GLIMIT ... Limits of the normalized ray domain. C............................ C Common block /POLY/: INTEGER MPL PARAMETER (MPL=800) INTEGER NPL,KPL(MPL) COMMON /POLY/NPL,KPL C MPL ... Maximum dimension of KPL. C NPL ... Number of points of polyline boundary of the region C covered by the basic triangles. C KPL ... Indices of rays forming the polyline. C None of the storage locations of the common block are altered. 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 controling the loop. C LRAY ...Indicates whether the ray IRAY is in memory. C----------------------------------------------------------------------- C C First ray: IF (NPL.LT.2) THEN PAUSE 'ERROR IN ADDING A NEW RAY' STOP 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 20' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 21' STOP ENDIF 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) THEN PAUSE 'ERROR:RAY NOT IN THE MEMORY 21' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 22' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 23' STOP ENDIF CALL RPRAY(KPL(IRADD1-1),LRAY,ITYPE,ISHEET,G1K,G2K, * G11K,G12K,G22K,X1K,X2K,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 24' STOP ENDIF 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,X1,X2, * G1X1,G2X1,G1X2,G2X2) C----------------------------------------------------------------------- INTEGER IRAY,ITYPE,ISHEET REAL G1,G2,G11,G12,G22,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 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 Coded by Petr Bulant C C....................................................................... C Common block /RAY/: INTEGER MRAY PARAMETER (MRAY=25000) INTEGER NRAY,KRAY(MRAY),ITRAY(MRAY),ISRAY(MRAY) REAL G1RAY(MRAY),G2RAY(MRAY) REAL X1RAY(MRAY),X2RAY(MRAY) REAL G11RAY(MRAY),G12RAY(MRAY),G22RAY(MRAY) REAL G1X1RA(MRAY),G1X2RA(MRAY),G2X1RA(MRAY),G2X2RA(MRAY) COMMON /RAY/NRAY,KRAY,ITRAY,ISRAY,G1RAY,G2RAY,G11RAY,G12RAY, * G22RAY,X1RAY,X2RAY,G1X1RA,G1X2RA,G2X1RA,G2X2RA C MRAY... Maximum number of rays in memory (dimension of arrays C KRAY,ITRAY,ISRAY,G1RAY,G2RAY,...) C NRAY... Number of rays in memory - the last ray is the newest one. C NRAY=0 when starting the computation of a new wave. C KRAY... Indices of rays stored in the memory. C ITRAY...Types of rays: C 0:.............. Basic ray. C ITRAY(I).GT.0:.. Boundary ray, ITRAY(I) is the index C of the boundary ray at the other side C of the boundary. C -2:............. Auxiliary ray,not used. C -3:............. Auxiliary ray,used. C -1000-I:........ Two-point ray (to the I'th receiver). C ISRAY.. Sheets of the wave on which the rays lie. C G1RAY,G2RAY... Normalized parameters of rays. C X1RAY,X2RAY... Coordinates of the ray on the ref. surface. C G11RAY,G12RAY,G22RAY... Ray-parameter metric tensor. C G1X1RA,G1X2RA,G2X1RA,G2X2RA ...Derivations of ray parameters C according to surface coordinates. C................................ INTEGER INDRAY,IIRAY INTEGER ID INTEGER I1,I2,I3 LOGICAL LRAY SAVE I1,I2 C C INDRAY..Sequence in KRAY of the given ray. C IIRAY ..Absolute value of IRAY. C I1,I2...Implied-do variables or variables controling the loop. C LRAY ...Indicates whether the ray IRAY is in memory. C----------------------------------------------------------------------- C IF(IRAY.EQ.0) THEN NRAY=0 ELSE CCC IF(NRAY.GE.MRAY) CALL RPERAS IF(NRAY.GE.MRAY) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR RAYS.' STOP ENDIF NRAY=NRAY+1 KRAY(NRAY)=IRAY ITRAY(NRAY)=ITYPE ISRAY(NRAY)=ISHEET G1RAY(NRAY)=G1 G2RAY(NRAY)=G2 X1RAY(NRAY)=X1 X2RAY(NRAY)=X2 G11RAY(NRAY)=G11 G12RAY(NRAY)=G12 G22RAY(NRAY)=G22 G1X1RA(NRAY)=G1X1 G1X2RA(NRAY)=G1X2 G2X1RA(NRAY)=G2X1 G2X2RA(NRAY)=G2X2 ENDIF RETURN C C----------------------------------------------------------------------- C ENTRY RPMEMC(IRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2, * G1X1,G2X1,G1X2,G2X2) C C----------------------------------------------------------------------- C Entry designed to change values ITYPE,ISHEET,G1,G2,G11,G12,G22, C X1,X2 for ray with sign IRAY. C Input: C IRAY... Sign of the ray which is to be changed. C ITYPE.. Type of 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 G1,G2.. Parameters of the ray. C G11,G12,G22... Components of the ray-parameter C 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 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 PAUSE 'ERROR: RAY NOT IN THE MEMORY 100' STOP C 10 CONTINUE KRAY(INDRAY)=IRAY ITRAY(INDRAY)=ITYPE ISRAY(INDRAY)=ISHEET G1RAY(INDRAY)=G1 G2RAY(INDRAY)=G2 X1RAY(INDRAY)=X1 X2RAY(INDRAY)=X2 G11RAY(INDRAY)=G11 G12RAY(INDRAY)=G12 G22RAY(INDRAY)=G22 G1X1RA(INDRAY)=G1X1 G2X1RA(INDRAY)=G2X1 G1X2RA(INDRAY)=G1X2 G2X2RA(INDRAY)=G2X2 RETURN C C----------------------------------------------------------------------- C ENTRY RPRAY(IRAY,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2, * G1X1,G2X1,G1X2,G2X2) 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 boun. C ray at the other side of the 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 G1,G2.. Normalized parameters of ray. C G11,G12,G22... Components of the ray-parameter 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) G1 =G1RAY(INDRAY) G2 =G2RAY(INDRAY) X1 =X1RAY(INDRAY) X2 =X2RAY(INDRAY) G11 =G11RAY(INDRAY) G12 =G12RAY(INDRAY) G22 =G22RAY(INDRAY) 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) 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) 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 all information about all the rays C stored in the memory. C Input: C ID: ID.NE.0 ... Initialization of the listing: C ID > 0 .. The listing is started from the ID's ray C stored in the memory going up. C ID < 0 .. The listing is started from the (IABS(ID))'s ray C 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,... ... 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/: INTEGER MTRI PARAMETER (MTRI=10000) INTEGER NTRI,KTRI(6,MTRI) COMMON /TRIAN/NTRI,KTRI C MTRI... Maximum number of triangles in memory C (dimension of array KTRI). C NTRI... Number of triangles. C KTRI... List of triangles. C KTRI(1,I),KTRI(2,I),KTRI(3,I)...Indices of vertices of the C I-th triangle. C KTRI(4,I)... Index of the I-th triangle. C KTRI(5,I)... Index of the triangle containing the I-th C triangle, zero for basic triangles. C KTRI(6,I)... Type of the I-th 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 ........................... 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 controling 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 55' STOP ENDIF IF (ISHEET.GT.0) CALL RPAUX1(ITRI,0) ENDIF C CCC IF(NTRI.GE.MTRI) CALL RPERAS IF(NTRI.GE.MTRI) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR TRIANGLES.' STOP 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 *S 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 56' STOP ENDIF 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 > 0 .. The listing is started from the ID's triangle C stored in the memory going up. C ID < 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 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....................................................................... INTEGER MARAY,NARAY PARAMETER (MARAY=20000) INTEGER KARAY(MARAY) 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) SAVE NARAY,KARAY 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 controling 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 PAUSE 'ERROR: INSUFFICIENT MEMORY FOR AUXILIARY RAYS 1' STOP 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 PAUSE 'ERROR: INSUFFICIENT MEMORY FOR AUXILIARY RAYS 2' STOP 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 57' STOP ENDIF IF (ITYPE.EQ.-2) THEN CALL RPMEMC(IRAY,-3,ISHEET,G1,G2,G11,G12,G22,X1,X2, * G1X1,G2X1,G1X2,G2X2) *S CALL RPSTOR('R',IRAY,KTRIS) ENDIF RETURN ELSE J2=KARAY(J1+1) J1=J1+2+J2 IF (J1.GE.NARAY) THEN PAUSE 'ERROR IN RPAUX 1' STOP 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 in C 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 PAUSE 'ERROR IN RPAUX 2' STOP ENDIF GOTO 30 ENDIF END C C======================================================================= C SUBROUTINE RPAST(ITRIS,IRAY0,IRAY) C C----------------------------------------------------------------------- C Subroutine designed to choose (from interval IRAY0 - IRAY) auxiliary C rays starting in triangle ITRIS and terminating in triangle ITRIS and C in the neighbouring homogeneous triangles and to put this rays in C subroutine RPAUX1, where auxiliary rays are stored. C Vertices of the triangle are also stored among auxiliary rays. INTEGER ITRIS,IRAY0,IRAY C Input : C ITRIS ... Index of triangle according which auxilliary rays are to C be stored. C IRAY0,IRAY ... Two indices of rays; subroutine will store all C auxiliary rays with indices between IRAY0 and IRAY. C No output. C C Subroutines and external functions required: EXTERNAL RPLRIT LOGICAL RPLRIT C C Coded by Petr Bulant C C....................................................................... REAL ZERO,ZERO1 PARAMETER (ZERO =.0000001) PARAMETER (ZERO1=.0000000001) INTEGER MTRIN PARAMETER (MTRIN=500) INTEGER NTRIN,INTRIN(MTRIN) REAL VTRI(4,3),VTRIN(MTRIN,4,3) INTEGER KTRIS(6),KTRIT(6) INTEGER ITYPE,ISHEET REAL G1,G2,G11,G12,G22,X1,X2 REAL G1X1,G2X1,G1X2,G2X2 REAL G1MIN,G1MAX,G2MIN,G2MAX REAL AREA1,AREA2,AREA3 INTEGER I1,I2 LOGICAL LTRI,LRAY C ZERO ...Constant used to decide whether the real variable.EQ.zero. C MTRIN ..Maximum number of neighbouring triangles. C NTRIN ..Number of neighbouring triangles. C INTRIN..Indices of neighbouring triangles. C VTRI ...Vertices of triangle ITRIS: 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, ) ... Vertices of J-th 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 KTRIS ..One column from KTRI (all parameters of the triangle C according which the auxiliary rays are to be stored). C KTRIT ..ONE COLUMN FROM KTRI (ALL PARAMETERS OF THE TRIANGLE C which we are testing whether is it the neighbouring one). 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 G1MIN,G1MAX,G2MIN,G2MAX ... Extremes of g1,G2 of triangle ITRIS. C AREA1,2,3.. Auxiliary variables used when examining whether the C ray lies in triangle. C I1,I2,..Implied-do variables or variables controlling the loop. C LTRI ...Indicates whether the triangle ITRI is in memory. C LRAY ...Indicates whether the ray IRAY is in memory. C----------------------------------------------------------------------- C CALL RPTRI3(ITRIS,LTRI,KTRIS) IF (.NOT.LTRI) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 9.' STOP ENDIF CALL RPRAY(KTRIS(1),LRAY,ITYPE,ISHEET,VTRI(1,1),VTRI(2,1), * G11,G12,G22,VTRI(3,1),VTRI(4,1),G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 58' STOP ENDIF IF (ISHEET.LT.0) THEN C This rays do not end on the reference surface,receivers C cannot lie here. RETURN ENDIF CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISHEET,VTRI(1,2),VTRI(2,2), * G11,G12,G22,VTRI(3,2),VTRI(4,2),G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 59' STOP ENDIF CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISHEET,VTRI(1,3),VTRI(2,3), * G11,G12,G22,VTRI(3,3),VTRI(4,3),G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 60' STOP ENDIF C C Now searching for neighbouring homogeneous triangles: NTRIN=0 CALL RPTRIP(1,LTRI,KTRIT) C Loop for all the triangles in the memory: 15 CONTINUE CALL RPTRIP(0,LTRI,KTRIT) IF (LTRI) THEN IF (((KTRIT(6).EQ.3).OR.(KTRIT(6).EQ.4)).AND. * (KTRIT(4).NE.ITRIS)) 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 13, I2=1,NTRIN IF (KTRIT(4).EQ.INTRIN(I2)) GOTO 15 13 CONTINUE IF(NTRIN.GE.MTRIN) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR NEIGHB. TRIAN.' STOP ENDIF NTRIN=NTRIN+1 IF (NTRIN.GT.MTRIN) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR * THE NEIGHBOURING TRIANGLES 1' STOP ENDIF CALL RPRAY(KTRIT(1),LRAY,ITYPE,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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 61' STOP ENDIF CALL RPRAY(KTRIT(2),LRAY,ITYPE,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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 62' STOP ENDIF CALL RPRAY(KTRIT(3),LRAY,ITYPE,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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 63' STOP ENDIF INTRIN(NTRIN)=KTRIT(4) ENDIF ENDIF GOTO 15 ENDIF C End of the loop for all the triangles in the memory. C C Storing vertices of the triangle among auxiliary rays: CALL RPAUX1(ITRIS,KTRIS(1)) CALL RPAUX1(ITRIS,KTRIS(2)) CALL RPAUX1(ITRIS,KTRIS(3)) C C Storing auxiliary rays: DO 30, I1=IRAY0+1,IRAY CALL RPRAY(I1,LRAY,ITYPE,ISHEET,G1,G2,G11,G12,G22,X1,X2, * G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) GOTO 30 IF (ITYPE.EQ.-2) THEN G1MIN=AMIN1(VTRI(1,1),VTRI(1,2),VTRI(1,3)) G1MAX=AMAX1(VTRI(1,1),VTRI(1,2),VTRI(1,3)) G2MIN=AMIN1(VTRI(2,1),VTRI(2,2),VTRI(2,3)) G2MAX=AMAX1(VTRI(2,1),VTRI(2,2),VTRI(2,3)) IF ((G1.GE.G1MIN).AND.(G1.LE.G1MAX).AND. * (G2.GE.G2MIN).AND.(G2.LE.G2MAX)) THEN IF (RPLRIT(.TRUE.,VTRI(1,1),VTRI(2,1),VTRI(1,2), * VTRI(2,2),VTRI(1,3),VTRI(2,3),G1,G2)) THEN C Auxiliary ray starts in the tested triangle: AREA1=(VTRI(3,2)-X1)*(VTRI(4,3)-X2)- * (VTRI(3,3)-X1)*(VTRI(4,2)-X2) IF (ABS(AREA1).LT.ZERO1) AREA1=0. AREA2=(VTRI(3,3)-X1)*(VTRI(4,1)-X2)- * (VTRI(3,1)-X1)*(VTRI(4,3)-X2) IF (ABS(AREA2).LT.ZERO1) AREA2=0. AREA3=(VTRI(3,1)-X1)*(VTRI(4,2)-X2)- * (VTRI(3,2)-X1)*(VTRI(4,1)-X2) 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 Auxiliary ray starts and terminates in the C tested triangle: CALL RPAUX1(ITRIS,I1) GOTO 30 ENDIF DO 40, I2=1,NTRIN AREA1=(VTRIN(I2,3,2)-X1)*(VTRIN(I2,4,3)-X2)- * (VTRIN(I2,3,3)-X1)*(VTRIN(I2,4,2)-X2) IF (ABS(AREA1).LT.ZERO1) AREA1=0. AREA2=(VTRIN(I2,3,3)-X1)*(VTRIN(I2,4,1)-X2)- * (VTRIN(I2,3,1)-X1)*(VTRIN(I2,4,3)-X2) IF (ABS(AREA2).LT.ZERO1) AREA2=0. AREA3=(VTRIN(I2,3,1)-X1)*(VTRIN(I2,4,2)-X2)- * (VTRIN(I2,3,2)-X1)*(VTRIN(I2,4,1)-X2) 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 Auxiliary ray terminates in the triangle: CALL RPAUX1(ITRIS,I1) GOTO 30 ENDIF 40 CONTINUE C Auxiliary ray starts in the tested triangle but it termi- C nates neither in it nor in the neighbouring triangles C (no action). ENDIF ENDIF ENDIF 30 CONTINUE 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 succesfull rays or without recei- C vers in its reference surface projection will be marked as searched C (type 4), as well as the triangle with all the two-point rays C identified. 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 Output: C LNEWAR..Indicates whether the new auxiliary ray is to be computed. C G1NEW,G2NEW ... Normalized ray parameters of this new ray. C ITYPEN ...Itype of this new ray. For all new rays ITYPEN at first C equals -1000-IREC, CRT then makes decision whether the C new ray is two-point ray and CRT then 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 LOGICAL RPLRIT C C Coded by Petr Bulant C C....................................................................... C C Common block /GLIM/: REAL GLIMIT(4) COMMON/GLIM/GLIMIT C GLIMIT ... Limits of the normalized ray domain. C............................ C C Common block /RPARD/: INCLUDE '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 None of the storage locations of the common block are altered. C ........................... C C Common block /BOURA/: INTEGER MBR PARAMETER (MBR=5000) INTEGER NBR,KBR(MBR,3) REAL GBR(MBR,2) COMMON/BOURA/NBR,KBR,GBR C C MBR...Dimension of arrays KBR,GBR. C NBR...Number of rays stored in KBR. C KBR...Array of boundary rays lying on the sides of basic triangles C and used only once. If a new triangle is to be divided, C boundary rays are used from KBR. C KBR(J+1,1)...Index of first vertice of the basic triangle. C KBR(J+2,1)...Index of second vertice of the basic triangle. C KBR(J+3,1)...Number of rays, lying on the side formed by C these two rays. C KBR(I,1)...Array of indices of boundary rays. C (I=J+4...J+3+KBR(J+3,1)) C KBR(I,2)...Array of sheets of boundary rays. C KBR(I,3)...Array of types of boundary rays. C GBR(I,1)...Array of normalized ray parameters G1 of boundary rays. C GBR(I,2)...Array of normalized ray parameters G2 of boundary rays. C C ........................... C C Common block /POLY/: INTEGER MPL PARAMETER (MPL=800) INTEGER NPL,KPL(MPL) COMMON /POLY/NPL,KPL C MPL... Maximum dimension of KPL. C NPL... Number of points of polyline boundary of the region C covered by the basic triangles. C KPL... Indices of rays forming the polyline. C None of the storage locations of the common block are altered. C....................................................................... C REAL ZERO,ZERO1 PARAMETER (ZERO =.0000001) PARAMETER (ZERO1=.0000000001) INTEGER MTRIN PARAMETER (MTRIN=500) REAL VTRI(4,3),VTRIN(MTRIN,4,3) INTEGER NTRIN,INTRIN(MTRIN),KTRIN(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 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 AREA1,AREA2,AREA3 INTEGER I1,I2,I3 INTEGER J1,J2 LOGICAL LTRI,LRAY,LINTS,LDISTG SAVE VTRI,VTRIN,NTRIN,INTRIN,KTRIN,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. zero. 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, ) ... Indices of the vertices of J-th C neighbouring triangle (I=1,2,3). 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 .... Derivations. C ISHA,GIA,B,C, ... Auxiliary variables C X1MIN,X1MAX,X2MIN,X2MAX..Extremes of X1,X2 of triangle ITRIP. C DG1,DG2,DX1,DX2 ........ Diferentials. 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 controling 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 interpoling C and the last ray was proposed as G1+DG1/2. C----------------------------------------------------------------------- C IF (LNEWAR) GOTO 50 ITRIP=KTRIS(4) CALL RPRAY(KTRIS(1),LRAY,ITYPE,ISHEET,VTRI(1,1),VTRI(2,1), * G11,G12,G22,VTRI(3,1),VTRI(4,1),G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 64' STOP ENDIF C IF (ISHEET.LT.0) THEN C These rays do not end on the reference surface,receivers C cannot lie here. KTRIS(6)=4 CALL WRITA(KTRIS(1),KTRIS(2),KTRIS(3)) CALL RPTRI2(ITRIP,LTRI,KTRIS) IF (.NOT.LTRI) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 11.' STOP ENDIF RETURN ENDIF C CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISHEET,VTRI(1,2),VTRI(2,2), * G11,G12,G22,VTRI(3,2),VTRI(4,2),G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 65' STOP ENDIF CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISHEET,VTRI(1,3),VTRI(2,3), * G11,G12,G22,VTRI(3,3),VTRI(4,3),G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 66' STOP ENDIF 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 Now searching for neighbouring homogeneous triangles. NTRIN=0 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 PAUSE 'ERROR: INSUFFICIENT MEMORY FOR * THE NEIGHBOURING TRIANGLES 2' STOP ENDIF KTRIN(NTRIN,1)=KTRIT(1) CALL RPRAY(KTRIT(1),LRAY,ITYPE,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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 67' STOP ENDIF KTRIN(NTRIN,2)=KTRIT(2) CALL RPRAY(KTRIT(2),LRAY,ITYPE,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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 68' STOP ENDIF KTRIN(NTRIN,3)=KTRIT(3) CALL RPRAY(KTRIT(3),LRAY,ITYPE,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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 69' STOP ENDIF INTRIN(NTRIN)=KTRIT(4) ENDIF ENDIF GOTO 8 ENDIF C End of the loop for all the triangles in the memory. C C Searching for receivers, lying (on reference surface) C in triangle ITRIP: 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)) 10 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 10 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 10 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 70' STOP ENDIF 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: 18 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)) THEN C Two-point ray starts in tested triangle,continuing with C the next receiver: IREC=IREC+1 IF (IREC.LE.NREC) GOTO 10 GOTO 200 ENDIF DO 16, 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)) THEN C Two-point ray starts in neighbouring triangle, C continuing with the next receiver: IREC=IREC+1 IF (IREC.LE.NREC) GOTO 10 GOTO 200 ENDIF 16 CONTINUE ENDIF GOTO 18 ENDIF C End of the loop for all the rays in the memory. C C Receiver IREC lies (on ref. surface) in triangle ITRIP. C Now searching for 3 rays nearest to the receiver: C Searching among auxiliary rays: 30 CONTINUE DIST1=999999. 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 73' STOP ENDIF 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 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 73' STOP ENDIF 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 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 74' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 74' STOP ENDIF 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 CCC WRITE(*,'(A,A)') CURSOR(21),'THERE IS NOT RAY ' CCC WRITE(*,'(A,A)') CURSOR(22),'TO START THE ' CCC WRITE(*,'(A,A)') CURSOR(23),'INTERPOLATION ' CCC WRITE(*,'(A,A)') CURSOR(24),' PRESS ENTER ' CCC READ(*,*) CCC WRITE(*,'(A,A)') CURSOR(24),' ' IREC=IREC+1 IF (IREC.LE.NREC) GOTO 10 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) 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 10 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 10 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 10 GOTO 200 ENDIF KNOT(INOT)=NEAR3 ENDIF GOTO 30 ENDIF IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 77' STOP 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=(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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 78' STOP ENDIF C IF (ITYPE.LT.-1000) THEN C The ray IRAY is two-point ray ! CALL RPAUX1(ITRIP,IRAY) LNEWAR=.FALSE. C End of interpolation for this receiver: IREC=IREC+1 IF (IREC.LE.NREC) GOTO 10 GOTO 200 ENDIF C DIST2=(X1-XREC(1,IREC))**2 +(X2-XREC(2,IREC))**2 IF (DIST2.GE.DIST1) THEN IF (.NOT.LDISTG) THEN G1NEW=G1-DG1*.5 G2NEW=G2-DG2*.5 LDISTG=.TRUE. GOTO 90 ENDIF ISTART=ISTART+1 GOTO 40 ELSE 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)) THEN C This situation may be caused by invalid input data C (too small xerr, for example) C start of interpolation from other ray: CCC WRITE(*,'(A,A)') CURSOR(21),'DIFFERENCES DG1,DG2 ' CCC WRITE(*,'(A,A)') CURSOR(22),'EQUAL TO ZERO ' CCC WRITE(*,'(A,A,1I4)') CURSOR(23),'RECEIVER ',IREC CCC WRITE(*,'(A,A)') CURSOR(24),'PRESS ENTER ' CCC READ(*,*) CCC WRITE(*,'(A,A)') CURSOR(24),' ' 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)) 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)) 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: 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 15' STOP ENDIF CALL RPRAY(KPL(I1+1),LRAY,ITYPE,ISH,G1B,G2B,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 16' STOP ENDIF 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: CCC WRITE(*,'(A,A)') CURSOR(21),'RAY PROPOSED OUTSIDE' CCC WRITE(*,'(A,A)') CURSOR(22),'THE COVERED PART OF ' CCC WRITE(*,'(A,A)') CURSOR(23),'THE RAY DOMAIN. ' CCC WRITE(*,'(A,A)') CURSOR(24),'PRESS ENTER ' CCC READ(*,*) CCC WRITE(*,'(A,A)') CURSOR(24),' ' ITRNAR=0 G1NEW=(G1+G1NEW)/2 G2NEW=(G2+G2NEW)/2 DG1=(G1NEW-G1) DG2=(G2NEW-G2) GOTO 90 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 81' STOP ENDIF CALL RPRAY(KTRIT(2),LRAY,ITYPE,ISH,G1B,G2B, * G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 81' STOP ENDIF CALL RPRAY(KTRIT(3),LRAY,ITYPE,ISH,G1C,G2C, * G11,G12,G22,X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 81' STOP ENDIF IF (RPLRIT(.TRUE.,G1A,G2A,G1B,G2B,G1C,G2C,G1NEW,G2NEW)) 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)) THEN C Two-point ray starts in tested triangle,continuing C with the next receiver: IREC=IREC+1 IF (IREC.LE.NREC) GOTO 10 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 G1NEW=(G1+G1NEW)/2 G2NEW=(G2+G2NEW)/2 DG1=(G1NEW-G1) DG2=(G2NEW-G2) GOTO 90 C C No other receivers lying in triangle ITRIP. End of interpolation. 200 CONTINUE KTRIS(6)=4 CALL WRITA(KTRIS(1),KTRIS(2),KTRIS(3)) CALL RPTRI2(ITRIP,LTRI,KTRIS) LNEWAR=.FALSE. RETURN END C C======================================================================= C SUBROUTINE RPERAS C C---------------------------------------------------------------------- C C Subroutine designed to delete unneeded triangels 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 block /GLIM/: REAL GLIMIT(4) COMMON/GLIM/GLIMIT C GLIMIT ... Limits of the normalized ray domain. C............................ C Common block /POLY/: INTEGER MPL PARAMETER (MPL=800) INTEGER NPL,KPL(MPL) COMMON /POLY/NPL,KPL C MPL ... Maximum dimension of KPL. C NPL ... Number of points of polyline boundary of the region C covered by the basic triangles. C KPL ... Indices of rays forming the polyline. C ........................... C C Common block /BOURA/: INTEGER MBR PARAMETER (MBR=5000) INTEGER NBR,KBR(MBR,3) REAL GBR(MBR,2) COMMON/BOURA/NBR,KBR,GBR C C MBR...Dimension of arrays KBR,GBR. C NBR........Number of rays stored in KBR. C KBR...Array of boundary rays lying on the sides of basic triangles C and used only once. If a new triangle is to be divided, C boundary rays are used from KBR. C KBR(J+1,1)...Index of first vertice of the basic triangle. C KBR(J+2,1)...Index of second vertice of the basic triangle. C KBR(J+3,1)...Number of rays, lying on the side formed by C these two rays. C KBR(I,1)...Array of indices of boundary rays. C (I=J+4...J+3+KBR(J+3,1)) C KBR(I,2)...Array of sheets of boundary rays. C KBR(I,3)...Array of types of boundary rays. C GBR(I,1)...Array of normalized ray parameters G1 of boundary rays. C GBR(I,2)...Array of normalized ray parameters G2 of boundary rays. C C ........................... C C Common block /TRIAN/: INTEGER MTRI PARAMETER (MTRI=10000) INTEGER NTRI,KTRI(6,MTRI) COMMON /TRIAN/NTRI,KTRI C MTRI... Maximum number of triangles in memory C (dimension of array KTRI). C NTRI... Number of triangles. C KTRI... List of triangles. C KTRI(1,I),KTRI(2,I),KTRI(3,I)...Indices of vertices of the C I-th triangle. C KTRI(4,I)... Index of the I-th triangle. C KTRI(5,I)... Index of the triangle containing the I-th C triangle, zero for basic triangles. C KTRI(6,I)... Type of the I-th 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 ........................... C Common block /RAY/: INTEGER MRAY PARAMETER (MRAY=25000) INTEGER NRAY,KRAY(MRAY),ITRAY(MRAY),ISRAY(MRAY) REAL G1RAY(MRAY),G2RAY(MRAY) REAL X1RAY(MRAY),X2RAY(MRAY) REAL G11RAY(MRAY),G12RAY(MRAY),G22RAY(MRAY) REAL G1X1RA(MRAY),G1X2RA(MRAY),G2X1RA(MRAY),G2X2RA(MRAY) COMMON /RAY/NRAY,KRAY,ITRAY,ISRAY,G1RAY,G2RAY,G11RAY,G12RAY, * G22RAY,X1RAY,X2RAY,G1X1RA,G1X2RA,G2X1RA,G2X2RA C MRAY... Maximum number of rays in memory (dimension of arrays C KRAY,ITRAY,ISRAY,G1RAY,G2RAY,...) C NRAY... Number of rays in memory - the last ray is the newest one. C NRAY=0 when starting the computation of a new wave. C KRAY... Indices of rays stored in the memory. C ITRAY...Types of rays: C 0:.............. Basic ray. C ITRAY(I).GT.0:.. Boundary ray, ITRAY(I) is the index C of the boundary ray at the other side C of the boundary. C -2:............. Auxiliary ray, not used. C -3:............. Auxiliary ray, used. C -1000-I:........ Two-point ray (to the I'th receiver). C ISRAY.. Sheets of the wave on which the rays lie. C G1RAY,G2RAY... Normalized parameters of rays. C X1RAY,X2RAY... Coordinates of the ray on the ref. surface. C G11RAY,G12RAY,G22RAY... Ray-parameter metric tensor. C G1X1RA,G1X2RA,G2X1RA,G2X2RA ...Derivations of ray parameters C according to surface coordinates. C....................................................................... REAL ZERO,ZERO1 PARAMETER (ZERO =.0000001) PARAMETER (ZERO1=.0000000001) INTEGER MAUAR PARAMETER (MAUAR=10000) INTEGER NAUAR,KAUAR(MAUAR) 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...Auxiliary array (indices of triangles). 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 controling 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 871' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 872' STOP ENDIF 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: 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 PAUSE 'ERROR: INSUFFICIENT MEMORY FOR AUXILIARY ARRAY' STOP 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 *S 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: 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 110, I3=1,3 DO 120, I4=5,NRAY IF (IABS(KRAY(I4)).EQ.KTRI(I3,I1)) THEN KRAY(I4)=IABS(KRAY(I4)) GOTO 110 ENDIF 120 CONTINUE 110 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=5,NRAY IF (IABS(KRAY(I4)).EQ.J1) THEN KRAY(I4)=IABS(KRAY(I4)) GOTO 130 ENDIF 140 CONTINUE 130 CONTINUE 90 CONTINUE NTRI=I1 C Marking rays on the polyline: DO 150, I1=1,NPL DO 160, I2=5,NRAY IF (IABS(KRAY(I2)).EQ.KPL(I1)) THEN KRAY(I2)=IABS(KRAY(I2)) GOTO 150 ENDIF 160 CONTINUE 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, I2=5,NRAY IF (IABS(KRAY(I2)).EQ.KBR(I1,1)) THEN KRAY(I2)=IABS(KRAY(I2)) GOTO 170 ENDIF 180 CONTINUE 170 CONTINUE J1=J1+KBR(J1+3,1)+3 IF (J1.LT.NBR) GOTO 165 ENDIF C C Deleting unneeded rays: J1=4 DO 190, I1=5,NRAY IF (KRAY(I1).LT.0) GOTO 190 J1=J1+1 KRAY(J1)=KRAY(I1) ITRAY(J1)=ITRAY(I1) ISRAY(J1)=ISRAY(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) G1X1RA(J1)=G1X1RA(I1) G1X2RA(J1)=G1X2RA(I1) G2X1RA(J1)=G2X1RA(I1) G2X2RA(J1)=G2X2RA(I1) 190 CONTINUE NRAY=J1 RETURN END C C======================================================================= C SUBROUTINE RPGMEA(JTRI,ITRI,IRAY,LNEWAR, * LAB20,G1NEW,G2NEW) C C---------------------------------------------------------------------- C Subroutine designed to measure the sides of the triangle JTRI in the C normalized ray domain 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 rpgmea. 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 block /GLIM/: REAL GLIMIT(4) COMMON/GLIM/GLIMIT C GLIMIT ... Limits of the normalized ray domain. C............................ C C Common block /RPARD/: INCLUDE 'rpard.inc' C AERR ... The distance of boundary rays. C............................ C C Common block /BOURA/: INTEGER MBR PARAMETER (MBR=5000) INTEGER NBR,KBR(MBR,3) REAL GBR(MBR,2) COMMON/BOURA/NBR,KBR,GBR C C MBR...Dimension of arrays KBR,GBR. C NBR...Number of rays stored in KBR. C KBR...Array of boundary rays lying on the sides of basic triangles C and used only once. If a new triangle is to be divided, C boundary rays are used from KBR. C KBR(J+1,1)...Index of first vertice of the basic triangle. C KBR(J+2,1)...Index of second vertice of the basic triangle. C KBR(J+3,1)...Number of rays, lying on the side formed by C these two rays. C KBR(I,1)...Array of indices of boundary rays. C (I=J+4...J+3+KBR(J+3,1)) C KBR(I,2)...Array of sheets of boundary rays. C KBR(I,3)...Array of types of boundary rays. C GBR(I,1)...Array of normalized ray parameters G1 of boundary rays. C GBR(I,2)...Array of normalized ray parameters G2 of boundary rays. C C....................................................................... REAL ZERO,ZERO1 PARAMETER (ZERO =.0000001) PARAMETER (ZERO1=.0000000001) REAL SIDE,HSIDE2,NEAR PARAMETER (SIDE=1.1547) PARAMETER (NEAR=SIDE*.618) PARAMETER (HSIDE2=(SIDE+NEAR)**2) 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 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,G1,G2,G11,G12,G22 INTEGER MDRAYS PARAMETER (MDRAYS=3000) INTEGER KDRAYS(MDRAYS),NDRAYS REAL X1,X2,G1X1,G2X1,G1X2,G2X2 REAL AREA,DIST2A,DIST2B,DIST2C,AERR2 REAL G11POM,G12POM,G22POM REAL DG1,DG2,DIST2,DETG INTEGER I1,I2,I3,I4 INTEGER J3,J4 LOGICAL LRAY,LTRI SAVE KRAYA,KRAYB,KRAYC,ISHA,ITYPEA,ITYPEB,G1A,G1B,G2A,G2B * ,G11A,G12A,G22A,G11B,G12B,G22B,KDRAYS,NDRAYS,AERR2,KTRID C ZERO..Constant used to decide whether the real variable .EQ. zero. C SIDE... Length of basic triangles sides. C HSIDE2..Second power of the maximum length of homogeneous C triangles sides. 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 ... Derivations. 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 KDRAYS ... Array of indices of the rays, that were used to divide C the side of the triangle right once. New rays are C searched for in this array. C NDRAYS ... Number of the rays in array KDRAYS. C AREA ...Auxiliary variable (area of the triangle). C DIST2A,B,C ...Auxiliary variables (second powers of the lenghts 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 controling 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 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 lenghts of the triangle's sides: KRAYA=KTRID(1) CALL RPRAY(KTRID(1),LRAY,ITYPEA,ISHA,G1A,G2A,G11A,G12A,G22A, * X1,X2,G1X1A,G2X1A,G1X2A,G2X2A) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 873' STOP ENDIF KRAYB=KTRID(2) CALL RPRAY(KTRID(2),LRAY,ITYPEB,ISHB,G1B,G2B,G11B,G12B,G22B, * X1,X2,G1X1B,G2X1B,G1X2B,G2X2B) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 874' STOP ENDIF KRAYC=KTRID(3) CALL RPRAY(KTRID(3),LRAY,ITYPEC,ISHC,G1C,G2C,G11C,G12C,G22C, * X1,X2,G1X1C,G2X1C,G1X2C,G2X2C) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 875' STOP ENDIF IF ((ISHA.NE.ISHB).OR.(ISHA.NE.ISHC)) THEN KTRID(6)=0 CALL RPTRI2(KTRID(4),LTRI,KTRID) IF (.NOT.LTRI) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 2.' STOP ENDIF 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) THEN PAUSE 'ERROR: DETERMINANT NEGATIVE' STOP ENDIF IF (DETG.LT.ZERO) THEN PAUSE 'ERROR: DETERMINANT EQUAL TO ZERO' STOP ENDIF AREA=SQRT(DETG)*((DG1*(G2C-G2A)-DG2*(G1C-G1A))*.5) IF (AREA.LT.((AERR2)*0.4330127/4.)) 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 2.' STOP ENDIF 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/4.).OR.(DIST2B.LE.AERR2/4.).OR. * (DIST2C.LE.AERR2/4.)) THEN C Triangle too small. KTRID(6)=2 CALL RPTRI2(KTRID(4),LTRI,KTRID) IF (.NOT.LTRI) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 3.' STOP ENDIF RETURN ENDIF C IF ((DIST2A.LE.HSIDE2).AND.(DIST2B.LE.HSIDE2).AND. * (DIST2C.LE.HSIDE2)) 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 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.ZERO1).AND. * (ABS(G2D-G2NEW).LT.ZERO1)) 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 876' STOP ENDIF 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 PAUSE 'ERROR: INSUFFIC. MEMORY FOR DIVISION RAYS IN RPGMEA' STOP ENDIF KDRAYS(NDRAYS)=KRAYD ENDIF C C When the ray 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 9.' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISH,G1J,G2J,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1K,G2K,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF 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 J4=1 IF (NBR.GT.2) THEN 11 CONTINUE C Loop for the rays in KBR: IF ((KBR(J4,1).EQ.KRAYI).AND.(KBR(J4+1,1).EQ.KRAYJ)) THEN IF (KBR(J4+2,1).LE.0) THEN J3=J4+3 GOTO 13 ENDIF J3=0 IF ((G1D.LE.GBR(J4,1).AND. * G1D.GE.GBR(J4+3,1)).OR. * (G1D.GE.GBR(J4,1).AND. * G1D.LE.GBR(J4+3,1))) J3=J4+3 DO 12, I4=J4+3,J4+1+KBR(J4+2,1) IF ((G1D.GE.GBR(I4,1).AND.G1D.LE.GBR(I4+1,1)).OR. * (G1D.LE.GBR(I4,1).AND.G1D.GE.GBR(I4+1,1))) J3=I4+1 12 CONTINUE I4=J4+2+KBR(J4+2,1) IF ((G1D.LE.GBR(I4,1).AND. * G1D.GE.GBR(J4+1,1)).OR. * (G1D.GE.GBR(I4,1).AND. * G1D.LE.GBR(J4+1,1))) J3=I4+1 13 IF (J3.NE.0) THEN C Now j3 points to the position in KBR, C where ray D is to be added: IF (NBR+1.GT.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF IF (NBR.GE.J3) NBR=NBR+1 DO 15, 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) 15 CONTINUE NBR=MAX0(NBR,J3) KBR(J3,1)=KRAYD KBR(J3,2)=ISHD KBR(J3,3)=ITYPED GBR(J3,1)=G1D GBR(J3,2)=G2D KBR(J4+2,1)=KBR(J4+2,1)+1 ENDIF GOTO 21 ENDIF J4=J4+3+KBR(J4+2,1) IF (J4.LT.NBR) GOTO 11 ENDIF C C The side KRAYI-KRAYJ is not in KBR, C rays will be stored to KBR: IF (NBR.GE.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF CALL RPRAY(KRAYI,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF NBR=NBR+1 KBR(NBR,1)=KRAYI KBR(NBR,2)=0 KBR(NBR,3)=0 GBR(NBR,1)=G1 GBR(NBR,2)=G2 IF (NBR.GE.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF CALL RPRAY(KRAYJ,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF NBR=NBR+1 KBR(NBR,1)=KRAYJ KBR(NBR,2)=0 KBR(NBR,3)=0 GBR(NBR,1)=G1 GBR(NBR,2)=G2 IF (NBR.GE.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF NBR=NBR+1 KBR(NBR,1)=KRAYD KBR(NBR,2)=ISHD KBR(NBR,3)=ITYPED GBR(NBR,1)=G1D GBR(NBR,2)=G2D 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) *S CALL RPSTOR('T',1,KTRIN) ITRI=ITRI+1 KTRIN(1)=KRAYD KTRIN(2)=KRAYB KTRIN(3)=KRAYC KTRIN(4)=ITRI CALL RPTRI1(ITRI,KTRIN) *S 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 342' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 36' STOP ENDIF 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) THEN PAUSE 'ERROR: TRIANGLE NOT IN THE MEMORY 3.' STOP ENDIF 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) *S 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) *S 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 BLOCK DATA RPCOBL C C---------------------------------------------------------------------- C Subroutine designed to define all common blocks used in C two-point ray tracing subroutines only. C C No input C No output C C Coded by Petr Bulant C C...................................................................... C C Common block /GLIM/: REAL GLIMIT(4) COMMON/GLIM/GLIMIT C GLIMIT ... Limits of the normalized ray domain. C............................ C Common block /POLY/: INTEGER MPL PARAMETER (MPL=800) INTEGER NPL,KPL(MPL) COMMON /POLY/NPL,KPL C MPL ... Maximum dimension of KPL. C NPL ... Number of points of polyline boundary of the region C covered by the basic triangles. C KPL ... Indices of rays forming the polyline. C ........................... C C Common block /BOURA/: INTEGER MBR PARAMETER (MBR=5000) INTEGER NBR,KBR(MBR,3) REAL GBR(MBR,2) COMMON/BOURA/NBR,KBR,GBR C C MBR...Dimension of arrays KBR,GBR. C NBR...Number of rays stored in KBR. C KBR...Array of boundary rays lying on the sides of basic triangles C and used only once. If a new triangle is to be divided, C boundary rays are used from KBR. C KBR(J+1,1)...Index of first vertice of the basic triangle. C KBR(J+2,1)...Index of second vertice of the basic triangle. C KBR(J+3,1)...Number of rays, lying on the side formed by C these two rays. C KBR(I,1)...Array of indices of boundary rays. C (I=J+4...J+3+KBR(J+3,1)) C KBR(I,2)...Array of sheets of boundary rays. C KBR(I,3)...Array of types of boundary rays. C GBR(I,1)...Array of normalized ray parameters G1 of boundary rays. C GBR(I,2)...Array of normalized ray parameters G2 of boundary rays. C C ........................... C C Common block /RAY/: INTEGER MRAY PARAMETER (MRAY=25000) INTEGER NRAY,KRAY(MRAY),ITRAY(MRAY),ISRAY(MRAY) REAL G1RAY(MRAY),G2RAY(MRAY) REAL X1RAY(MRAY),X2RAY(MRAY) REAL G11RAY(MRAY),G12RAY(MRAY),G22RAY(MRAY) REAL G1X1RA(MRAY),G1X2RA(MRAY),G2X1RA(MRAY),G2X2RA(MRAY) COMMON /RAY/NRAY,KRAY,ITRAY,ISRAY,G1RAY,G2RAY,G11RAY,G12RAY, * G22RAY,X1RAY,X2RAY,G1X1RA,G1X2RA,G2X1RA,G2X2RA C MRAY... Maximum number of rays in memory (dimension of arrays C KRAY,ITRAY,ISRAY,G1RAY,G2RAY,...) C NRAY... Number of rays in memory - the last ray is the newest one. C NRAY=0 when starting the computation of a new wave. C KRAY... Indices of rays stored in the memory. C ITRAY...Types of rays: C 0:.............. Basic ray. C ITRAY(I).GT.0:.. Boundary ray, ITRAY(I) is the index C of the boundary ray at the other side C of the boundary. C -2:............. Auxiliary ray, not used. C -3:............. Auxiliary ray, used. C -1000-I:........ Two-point ray (to the I'th receiver). C ISRAY.. Sheets of the wave on which the rays lie. C G1RAY,G2RAY... Normalized parameters of rays. C X1RAY,X2RAY... Coordinates of the ray on the ref. surface. C G11RAY,G12RAY,G22RAY... Ray-parameter metric tensor. C G1X1RA,G1X2RA,G2X1RA,G2X2RA ...Derivations of ray parameters C according to surface coordinates. C............................ C C Common block /TRIAN/: INTEGER MTRI PARAMETER (MTRI=10000) INTEGER NTRI,KTRI(6,MTRI) COMMON /TRIAN/NTRI,KTRI C MTRI... Maximum number of triangles in memory C (dimension of array KTRI). C NTRI... Number of triangles. C KTRI... List of triangles. C KTRI(1,I),KTRI(2,I),KTRI(3,I)...Indices of vertices of the C I-th triangle. C KTRI(4,I)... Index of the I-th triangle. C KTRI(5,I)... Index of the triangle containing the I-th C triangle, zero for basic triangles. C KTRI(6,I)... Type of the I-th 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 ........................... C END C C======================================================================= C LOGICAL FUNCTION RPLRIT(LRAY,S1A,S2A,S1B,S2B,S1C,S2C,S1X,S2X) C C---------------------------------------------------------------------- REAL S1A,S2A,S1B,S2B,S1C,S2C,S1X,S2X 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 C Coded by Petr Bulant C INCLUDE '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----------------------------------------------------------------------- AREA1=(S1B-S1A)*(S2C-S2A)-(S1C-S1A)*(S2B-S2A) CCC IF (AREA1.LT.ZERO1) AREA1=0. IF (AREA1.LT.((AERR**2)*0.4330127/4.)) AREA1=0. C 0.4330127=SQRT(3)/4 C Triangle too small, it will be treated as left-handed. IF (AREA1.GT.0.) THEN C Triangle A,B,C is right-handed. RPLRIT=.TRUE. ELSE RPLRIT=.FALSE. ENDIF IF (LRAY) THEN IF (.NOT.RPLRIT) THEN PAUSE 'ERROR IN LPLRIT, LEFT HANDED TRIANGLE' STOP ENDIF 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. ELSE RPLRIT=.FALSE. ENDIF ENDIF RETURN END C C======================================================================= C LOGICAL FUNCTION RPLRIP(NPOL,GPOL,G1X,G2X) C C---------------------------------------------------------------------- INTEGER MPOL,NPOL 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 ZERO1 PARAMETER (ZERO1=.0000000001) 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.ZERO1) 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.ZERO1).AND.(ABS(G1B-G1X).LT.ZERO1)) THEN RPLRIP=.TRUE. RETURN ENDIF INTERS=INTERS+1 IF (ABS(G2B-G2X).LT.ZERO1) THEN J1=I2 J2=I2+1 IF (I2.EQ.NPOL) J2=1 20 CONTINUE IF (ABS(GPOL(J1,1)-GPOL(J2,1)).LT.ZERO1) 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.ZERO1) 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 SUBROUTINE RPSTOR(CHAR,IRAY,KTRIS) C C----------------------------------------------------------------------- CHARACTER CHAR INTEGER IRAY,KTRIS(6) C Subroutine designed to store the parameters of the ray IRAY or of the C triangle KTRIS to the output files for plotting. 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 Structure of the formatted output files: C Note that only the rays and triangles of the last computed C elementary wave are stored in the output files. C The file 'rp.out' with the parameters of the rays of the last C computed elementary wave: C The file is formed of same lines, each line containing the C information about one ray in the following form: C IRAY,ITYPE,ISH,G1R,G2R,G11,G12,G22,X1R,X2R; C see the description of these variables below. C The file 'rprt.out' with the parameters of the rays and triangles C of the last computed elementary wave: C The file is formed of odd lines containing just one character, C indicating the type of the information on the following (even) C line. C Odd line: C 'R' indicates the ray on the following line. C 'T' indicates the triangle on the following line. C Even line: C IRAY,ITYPE,ISH,G1R,G2R,X1R,X2R for 'R' on previous line. C ISH,KTRIS,G1R,G2R,G1S,G2S,G1T,G2T,X1R,X2R,X1S,X2S,X1T,X2T C for 'T' on previous line. C See the description of these variables below. C C Coded by Petr Bulant 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----------------------------------------------------------------------- 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 55' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 55' STOP ENDIF CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISH,G1S,G2S,G11,G12,G22,X1S,X2S, * G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 55' STOP ENDIF CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1T,G2T,G11,G12,G22,X1T,X2T, * G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 55' STOP ENDIF 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 PAUSE 'ERROR: WRONGLY INVOKED STORING' STOP 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,ZERO1 PARAMETER (ZERO=.0000001) PARAMETER (ZERO1=.0000000001) REAL A,B,C,D C ZERO1...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 (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 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 abscisse A-B C with the abscis 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 appeard. 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.zero. C AAA,BBB,PART,A,B,C,D ... Auxiliary variables. C----------------------------------------------------------------------- C IF (ABS(G1A-G1B).LT.ZERO1) THEN IF (ABS(G1D-G1C).LT.ABS(G1A-G1C)) GOTO 118 IF (ABS(G1D-G1C).LT.ZERO1) 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.ZERO1) THEN IF (ABS(G2D-G2C).LT.ABS(G2A-G2C)) GOTO 118 IF (ABS(G2D-G2C).LT.ZERO1) 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 AERR ... The distance of boundary rays. C PRM0(2) ... Maximum alloved length of the homogeneous triangles C sides (measured on the reference surface). C............................ C C Common block /BOURA/: INTEGER MBR PARAMETER (MBR=5000) INTEGER NBR,KBR(MBR,3) REAL GBR(MBR,2) COMMON/BOURA/NBR,KBR,GBR C C MBR...Dimension of arrays KBR,GBR. C NBR...Number of rays stored in KBR. C KBR...Array of boundary rays lying on the sides of basic triangles C and used only once. If a new triangle is to be divided, C boundary rays are used from KBR. C KBR(J+1,1)...Index of first vertice of the basic triangle. C KBR(J+2,1)...Index of second vertice of the basic triangle. C KBR(J+3,1)...Number of rays, lying on the side formed by C these two rays. C KBR(I,1)...Array of indices of boundary rays. C (I=J+4...J+3+KBR(J+3,1)) C KBR(I,2)...Array of sheets of boundary rays. C KBR(I,3)...Array of types of boundary rays. C GBR(I,1)...Array of normalized ray parameters G1 of boundary rays. C GBR(I,2)...Array of normalized ray parameters G2 of boundary rays. C C....................................................................... REAL ZERO,ZERO1 PARAMETER (ZERO =.0000001) PARAMETER (ZERO1=.0000000001) 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 G1,G2,G11,G12,G22 INTEGER MDRAYS PARAMETER (MDRAYS=3000) INTEGER KDRAYS(MDRAYS),NDRAYS REAL X1,X2,G1X1,G2X1,G1X2,G2X2 REAL AREA,AERR2 REAL G11POM,G12POM,G22POM REAL DG1,DG2,DETG REAL DIST2A,DIST2B,DIST2C INTEGER I1,I2,I4 INTEGER J3,J4 LOGICAL LRAY,LTRI SAVE KRAYA,KRAYB,KRAYC,ISHA,KDRAYS,NDRAYS,KTRID,AERR2 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 ...Derivations. 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 KDRAYS ... Array of indices of the rays, that were used to divide C the side of the triangle right once. New rays are C searched for in this array. C NDRAYS ... Number of the rays in array KDRAYS. C AREA ...Auxiliary variable (area of the triangle). C DIST2A,B,C ...Auxiliary variables (second powers of the lenghts C of the triangle sides). C AERR2 ... Second power of the distance of boundary rays. C GiiPOM ...Auxiliary variables (metric tensor). C DG1,DG2,DIST2 ..auxiliary variables. C DETG... Determinant. C I1,2,3..Implied-do variables or variables controling 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 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 lenghts 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 873' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 874' STOP ENDIF KRAYC=KTRID(3) CALL RPRAY(KTRID(3),LRAY,ITYPEC,ISHC,G1C,G2C,G11C,G12C,G22C, * X1C,X2C,G1X1C,G2X1C,G1X2C,G2X2C) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 875' STOP ENDIF IF ((ISHA.NE.ISHB).OR.(ISHA.NE.ISHC)) THEN KTRID(6)=0 CALL RPTRI2(KTRID(4),LTRI,KTRID) IF (.NOT.LTRI) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 2.' STOP ENDIF 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) THEN PAUSE 'ERROR: DETERMINANT NEGATIVE' STOP ENDIF IF (DETG.LT.ZERO) THEN PAUSE 'ERROR: DETERMINANT EQUAL TO ZERO' STOP ENDIF AREA=SQRT(DETG)*((DG1*(G2C-G2A)-DG2*(G1C-G1A))*.5) IF (AREA.LT.((AERR2)*0.4330127*4.)) 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*4.).OR.(DIST2B.LE.AERR2*4.).OR. * (DIST2C.LE.AERR2*4.)) 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.PRM0(2)).AND.(DIST2B.LE.PRM0(2)).AND. * (DIST2C.LE.PRM0(2))) 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 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.ZERO1).AND. * (ABS(G2D-G2NEW).LT.ZERO1)) 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 876' STOP ENDIF C The ray is to be stored to the array KDRAYS: NDRAYS=NDRAYS+1 IF (NDRAYS.GT.MDRAYS) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR DIVISION RAYS IN RPXMEA' STOP ENDIF KDRAYS(NDRAYS)=KRAYD C C When the ray 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 9.' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISH,G1J,G2J,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1K,G2K,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF 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 J4=1 IF (NBR.GT.2) THEN 11 CONTINUE C Loop for the rays in KBR: IF ((KBR(J4,1).EQ.KRAYI).AND.(KBR(J4+1,1).EQ.KRAYJ)) THEN IF (KBR(J4+2,1).LE.0) THEN J3=J4+3 GOTO 13 ENDIF J3=0 IF ((G1D.LE.GBR(J4,1).AND. * G1D.GE.GBR(J4+3,1)).OR. * (G1D.GE.GBR(J4,1).AND. * G1D.LE.GBR(J4+3,1))) J3=J4+3 DO 12, I4=J4+3,J4+1+KBR(J4+2,1) IF ((G1D.GE.GBR(I4,1).AND.G1D.LE.GBR(I4+1,1)).OR. * (G1D.LE.GBR(I4,1).AND.G1D.GE.GBR(I4+1,1))) J3=I4+1 12 CONTINUE I4=J4+2+KBR(J4+2,1) IF ((G1D.LE.GBR(I4,1).AND. * G1D.GE.GBR(J4+1,1)).OR. * (G1D.GE.GBR(I4,1).AND. * G1D.LE.GBR(J4+1,1))) J3=I4+1 13 IF (J3.NE.0) THEN C Now j3 points to the position in KBR, C where ray D is to be added: IF (NBR+1.GT.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF IF (NBR.GE.J3) NBR=NBR+1 DO 15, 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) 15 CONTINUE NBR=MAX0(NBR,J3) KBR(J3,1)=KRAYD KBR(J3,2)=ISHD KBR(J3,3)=ITYPED GBR(J3,1)=G1D GBR(J3,2)=G2D KBR(J4+2,1)=KBR(J4+2,1)+1 ENDIF GOTO 21 ENDIF J4=J4+3+KBR(J4+2,1) IF (J4.LT.NBR) GOTO 11 ENDIF C C The side KRAYI-KRAYJ is not in KBR, C rays will be stored to KBR: IF (NBR.GE.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF CALL RPRAY(KRAYI,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF NBR=NBR+1 KBR(NBR,1)=KRAYI KBR(NBR,2)=0 KBR(NBR,3)=0 GBR(NBR,1)=G1 GBR(NBR,2)=G2 IF (NBR.GE.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF CALL RPRAY(KRAYJ,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF NBR=NBR+1 KBR(NBR,1)=KRAYJ KBR(NBR,2)=0 KBR(NBR,3)=0 GBR(NBR,1)=G1 GBR(NBR,2)=G2 IF (NBR.GE.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF NBR=NBR+1 KBR(NBR,1)=KRAYD KBR(NBR,2)=ISHD KBR(NBR,3)=ITYPED GBR(NBR,1)=G1D GBR(NBR,2)=G2D 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) *S CALL RPSTOR('T',1,KTRIN) ITRI=ITRI+1 KTRIN(1)=KRAYD KTRIN(2)=KRAYB KTRIN(3)=KRAYC KTRIN(4)=ITRI CALL RPTRI1(ITRI,KTRIN) *S 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 block /GLIM/: REAL GLIMIT(4) COMMON/GLIM/GLIMIT C GLIMIT ... Limits of the normalized ray domain. C............................ C Common block /POLY/: INTEGER MPL PARAMETER (MPL=800) INTEGER NPL,KPL(MPL) COMMON /POLY/NPL,KPL C MPL ... Maximum dimension of KPL. C NPL ... Number of points of polyline boundary of the region C covered by the basic triangles. C KPL ... Indices of rays forming the polyline. 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) THEN PAUSE 'ERROR: TRIANGLE NOT FOUND IN THE MEMORY 9.' STOP ENDIF 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF CALL RPRAY(KTRIS(2),LRAY,ITYPE,ISH,G1J,G2J,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF CALL RPRAY(KTRIS(3),LRAY,ITYPE,ISH,G1K,G2K,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF 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: coordinates of the three points, value of the symetric metric C tensor which is to be used. C C Output: 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,ZERO1 PARAMETER (ZERO=.0000001) PARAMETER (ZERO1=.0000000001) REAL AAA,BBB,CCC,PAR REAL DIST2 REAL A,B C ZERO1...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 then 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 runned 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 polygone 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 REAL RPDI2G LOGICAL RPLRIT,RPLRIP,RPLRIL C C Coded by Petr Bulant C C C....................................................................... C Common block /RPARD/: INCLUDE 'rpard.inc' C AERR ... The distance of boundary rays. C............................ C C Common block /BOURA/: INTEGER MBR PARAMETER (MBR=5000) INTEGER NBR,KBR(MBR,3) REAL GBR(MBR,2) COMMON/BOURA/NBR,KBR,GBR C C MBR...Dimension of arrays KBR,GBR. C NBR...Number of rays stored in KBR. C KBR...Array of boundary rays lying on the sides of basic triangles C and used only once. If a new triangle is to be divided, C boundary rays are used from KBR. C KBR(J+1,1)...Index of first vertice of the basic triangle. C KBR(J+2,1)...Index of second vertice of the basic triangle. C KBR(J+3,1)...Number of rays, lying on the side formed by C these two rays. C KBR(I,1)...Array of indices of boundary rays. C (I=J+4...J+3+KBR(J+3,1)) C KBR(I,2)...Array of sheets of boundary rays. C KBR(I,3)...Array of types of boundary rays. C GBR(I,1)...Array of normalized ray parameters G1 of boundary rays. C GBR(I,2)...Array of normalized ray parameters G2 of boundary rays. C C....................................................................... REAL ZERO,ZERO1 PARAMETER (ZERO =.000001) PARAMETER (ZERO1=.0000000001) REAL NEAR PARAMETER (NEAR=.618**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 INTEGER KRAYD,ISHD,ITYPED REAL G1D,G2D REAL G1X,G2X REAL DIST2,MINDIS,NEAR2 REAL G11POM,G12POM,G22POM REAL AREA,AREA1,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,J3,J4 CHARACTER VERTEX LOGICAL LRAY,LINTS SAVE KRAYI,KRAYJ,IGOTO,KPOL,GPOL C ZERO... Constant used to decide whether the real variable.EQ.zero. 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 ... Derivations 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 ... 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 ... Cosinus 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 controling 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 C C Controlling the size of the polygon: AREA1=0. CALL RPRAY(IABS(KPOLH(1,1)),LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 27' STOP ENDIF DG1=GPOLH(1,1)-GPOLH(NPOLH,1) DG2=GPOLH(1,2)-GPOLH(NPOLH,2) DETG=G11*G22 - G12*G12 IF (DETG.LT.-ZERO) THEN PAUSE 'ERROR: DETERMINANT NEGATIVE' STOP ENDIF IF (DETG.LT.ZERO) THEN PAUSE 'ERROR: DETERMINANT EQUAL TO ZERO' STOP ENDIF AREA=SQRT(DETG)*((DG1*(GPOLH(2,2)-GPOLH(1,2)) * -DG2*(GPOLH(2,1)-GPOLH(1,1)))*.5) IF (AREA.GT.0.) AREA1=AREA DO 2, I1=2,NPOLH-1 CALL RPRAY(KPOLH(I1,1),LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 27' STOP ENDIF DG1=GPOLH(I1,1)-GPOLH(I1-1,1) DG2=GPOLH(I1,2)-GPOLH(I1-1,2) DETG=G11*G22 - G12*G12 IF (DETG.LT.-ZERO) THEN PAUSE 'ERROR: DETERMINANT NEGATIVE' STOP ENDIF IF (DETG.LT.ZERO) THEN PAUSE 'ERROR: DETERMINANT EQUAL TO ZERO' STOP ENDIF AREA=SQRT(DETG)*((DG1*(GPOLH(I1+1,2)-GPOLH(I1,2)) * -DG2*(GPOLH(I1+1,1)-GPOLH(I1,1)))*.5) IF (AREA.GT.0.) AREA1=AREA1+AREA 2 CONTINUE IF (AREA1.LT.((AERR**2)*0.4330127/4.)) 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 hom. 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)) 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) *S 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 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 53' STOP ENDIF 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)) THEN DO 156, I2=1,NPOLH IF (I2.EQ.J1) GOTO 156 IF (I2.EQ.I1) GOTO 156 IF (I2.EQ.J2) GOTO 156 IF (RPLRIT(.TRUE.,GPOLH(J1,1),GPOLH(J1,2),GPOLH(I1,1), * GPOLH(I1,2),GPOLH(J2,1),GPOLH(J2,2), * GPOLH(I2,1),GPOLH(I2,2))) THEN C Proposed triangle contains ray I2 of hom. pol.: GOTO 157 ENDIF 156 CONTINUE CALL RPRAY(IABS(KPOLH(J1,1)),LRAY,ITYPEA,ISHA,G1A,G2A,G11A, * G12A,G22A,X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 53' STOP ENDIF CALL RPRAY(IABS(KPOLH(J2,1)),LRAY,ITYPEB,ISHB,G1B,G2B,G11B, * G12B,G22B,X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 53' STOP ENDIF 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 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)) 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) *S 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 PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOLH' STOP 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 PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KPOLH' STOP 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) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 9' STOP ENDIF CALL RPRAY(IABS(KPOLH(I3,1)),LRAY,ITYPE,ISHEET,G1N,G2N, * G11N,G12N,G22N,X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 10' STOP ENDIF 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: IF (RPLRIT(.FALSE.,GPOLH(I1,1),GPOLH(I1,2),GPOLH(I2,1), * GPOLH(I2,2),GPOLH(I3,1),GPOLH(I3,2),G1A,G2A)) THEN DO 18, I4=1,NPOLH IF (I4.EQ.I1) GOTO 18 IF (I4.EQ.I2) GOTO 18 IF (I4.EQ.I3) GOTO 18 IF (RPLRIT(.TRUE.,GPOLH(I1,1),GPOLH(I1,2),GPOLH(I2,1), * GPOLH(I2,2),GPOLH(I3,1),GPOLH(I3,2), * GPOLH(I4,1),GPOLH(I4,2))) THEN C Proposed triangle contains ray I4 of hom. pol.: GOTO 19 ENDIF 18 CONTINUE 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) *S 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 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) THEN PAUSE 'ERROR: DETERMINANT NEGATIVE' STOP ENDIF IF (DETG.LT.ZERO) THEN PAUSE 'ERROR: DETERMINANT EQUAL TO ZERO' STOP ENDIF 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 narow 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 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 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 narow triangles: KPOLH(I2,1)=-IABS(KPOLH(I2,1)) GOTO 10 ENDIF 20 CONTINUE C C C Controling 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 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. ELSE C This ray is not to be used: KPOLH(I2,1)=-IABS(KPOLH(I2,1)) GOTO 10 ENDIF GOTO 100 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 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. ELSE C This ray is not to be used: KPOLH(I2,1)=-IABS(KPOLH(I2,1)) GOTO 10 ENDIF GOTO 100 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 Controling 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 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. ELSE C This ray is not to be used: KPOLH(I2,1)=-IABS(KPOLH(I2,1)) GOTO 10 ENDIF GOTO 100 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 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. ELSE C This ray is not to be used: KPOLH(I2,1)=-IABS(KPOLH(I2,1)) GOTO 10 ENDIF GOTO 100 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 Controling wheather the ray is in the polygon: IF (RPLRIP(NPOLH,GPOLH,G1NEW,G2NEW)) 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 C Go to 100. ELSE C A very strange situation, no intersection, but ray not in polyg. KPOLH(I2,1)=-IABS(KPOLH(I2,1)) GOTO 10 ENDIF 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: KRAYD=IRAY CALL RPRAY(IRAY,LRAY,ITYPED,ISHD,G1D,G2D,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 876' STOP ENDIF J4=1 IF (NBR.GT.2) THEN 111 CONTINUE C Loop for the rays in KBR: IF ((KBR(J4,1).EQ.KRAYI).AND.(KBR(J4+1,1).EQ.KRAYJ))THEN IF (KBR(J4+2,1).LE.0) THEN J3=J4+3 GOTO 113 ENDIF J3=0 IF ((G1D.LE.GBR(J4,1).AND. * G1D.GE.GBR(J4+3,1)).OR. * (G1D.GE.GBR(J4,1).AND. * G1D.LE.GBR(J4+3,1))) J3=J4+3 DO 112, I4=J4+3,J4+1+KBR(J4+2,1) IF ((G1D.GE.GBR(I4,1).AND.G1D.LE.GBR(I4+1,1)).OR. * (G1D.LE.GBR(I4,1).AND.G1D.GE.GBR(I4+1,1))) J3=I4+1 112 CONTINUE I4=J4+2+KBR(J4+2,1) IF ((G1D.LE.GBR(I4,1).AND. * G1D.GE.GBR(J4+1,1)).OR. * (G1D.GE.GBR(I4,1).AND. * G1D.LE.GBR(J4+1,1))) J3=I4+1 113 IF (J3.NE.0) THEN C Now j3 points to the position in KBR, C where the new ray is to be added: IF (NBR+1.GT.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF IF (NBR.GE.J3) NBR=NBR+1 DO 115, 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) 115 CONTINUE NBR=MAX0(NBR,J3) KBR(J3,1)=KRAYD KBR(J3,2)=ISHD KBR(J3,3)=ITYPED GBR(J3,1)=G1D GBR(J3,2)=G2D KBR(J4+2,1)=KBR(J4+2,1)+1 ENDIF GOTO 150 ENDIF J4=J4+3+KBR(J4+2,1) IF (J4.LT.NBR) GOTO 111 ENDIF C C The side KRAYI-KRAYJ is not in KBR, C ray will be stored to KBR: IF (NBR.GE.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF CALL RPRAY(KRAYI,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF NBR=NBR+1 KBR(NBR,1)=KRAYI KBR(NBR,2)=0 KBR(NBR,3)=0 GBR(NBR,1)=G1 GBR(NBR,2)=G2 IF (NBR.GE.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF CALL RPRAY(KRAYJ,LRAY,ITYPE,ISH,G1,G2,G11,G12,G22, * X1,X2,G1X1,G2X1,G1X2,G2X2) IF (.NOT.LRAY) THEN PAUSE 'ERROR: RAY NOT IN THE MEMORY 52' STOP ENDIF NBR=NBR+1 KBR(NBR,1)=KRAYJ KBR(NBR,2)=0 KBR(NBR,3)=0 GBR(NBR,1)=G1 GBR(NBR,2)=G2 IF (NBR.GE.MBR) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF 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) THEN PAUSE 'ERROR: INSUFFICIENT MEMORY FOR KBR IN RPDIV' STOP ENDIF NBR=NBR+1 KBR(NBR,1)=KRAYD KBR(NBR,2)=ISHD KBR(NBR,3)=ITYPED GBR(NBR,1)=G1D GBR(NBR,2)=G2D 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).AND. * RPLRIT(.FALSE.,GPOL(3,1),GPOL(3,2),GPOL(4,1), * GPOL(4,2),GPOL(1,1),GPOL(1,2),G1A,G2A)) 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) *S CALL RPSTOR('T',IRAY,KTRIN) ITRI=ITRI+1 KTRIN(1)=KPOL(3) KTRIN(2)=KPOL(4) KTRIN(3)=KPOL(1) KTRIN(4)=ITRI CALL RPTRI1(ITRI,KTRIN) *S 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)) 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) *S 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)) 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) *S CALL RPSTOR('T',IRAY,KTRIN) ENDIF C Go to 200. C C Making hom. pol. positive: 200 CONTINUE DO 201, I1=1,NPOLH KPOLH(I1,1)=IABS(KPOLH(I1,1)) 201 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 > 0 and ISHB > 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 PRM0(1) ... Maximum alloved 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) A11(1)= A22(3)/DETA A12(1)=-A12(3)/DETA A22(1)= A11(3)/DETA 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) A11(2)= A22(3)/DETA A12(2)=-A12(3)/DETA A22(2)= A11(3)/DETA 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) 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 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 PAUSE 'ERROR: WRONGLY INVOKED RPMEGS' STOP ENDIF END