Nodes of different colours represent the following:
Solid arrows point from a parent (sub)module to the submodule which is descended from it. Dashed arrows point from a module being used to the module or program unit using it. Where possible, edges connecting nodes are given different colours to make them easier to distinguish in large graphs.
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| integer, | intent(in) | :: | NS1 | |||
| integer, | intent(in) | :: | NS2 | |||
| integer, | intent(in) | :: | NV1 | |||
| integer, | intent(in) | :: | NV2 | |||
| integer, | intent(inout) | :: | NV3 |
Nodes of different colours represent the following:
Solid arrows point from a procedure to one which it calls. Dashed arrows point from an interface to procedures which implement that interface. This could include the module procedures in a generic interface or the implementation in a submodule of an interface in a parent module. Where possible, edges connecting nodes are given different colours to make them easier to distinguish in large graphs.
Nodes of different colours represent the following:
Solid arrows point from a procedure to one which it calls. Dashed arrows point from an interface to procedures which implement that interface. This could include the module procedures in a generic interface or the implementation in a submodule of an interface in a parent module. Where possible, edges connecting nodes are given different colours to make them easier to distinguish in large graphs.
SUBROUTINE CLIPPOLY(NS1,NS2,NV1,NV2,NV3)
! SUBROUTINE INFORMATION:
! AUTHOR Tyler Hoyt
! DATE WRITTEN May 4, 2010
! MODIFIED na
! RE-ENGINEERED na
! PURPOSE OF THIS SUBROUTINE:
! Populate global arrays XTEMP and YTEMP with the vertices
! of the overlap between NS1 and NS2, and determine relevant
! overlap status.
! METHODOLOGY EMPLOYED:
! The Sutherland-Hodgman algorithm for polygon clipping is employed.
! METHODOLOGY EMPLOYED:
!
! REFERENCES:
!
! USE STATEMENTS:
USE General, ONLY: ReallocateRealArray,SafeDivide
IMPLICIT NONE ! Enforce explicit typing of all variables in this routine
! SUBROUTINE ARGUMENT DEFINITIONS:
INTEGER, INTENT(IN) :: NS1 ! Figure number of figure 1 (The subject polygon)
INTEGER, INTENT(IN) :: NS2 ! Figure number of figure 2 (The clipping polygon)
INTEGER, INTENT(IN) :: NV1 ! Number of vertices of figure 1
INTEGER, INTENT(IN) :: NV2 ! Number of vertices of figure 2
INTEGER, INTENT(INOUT) :: NV3 ! Number of vertices of figure 3
! SUBROUTINE PARAMETER DEFINITIONS:
! na
! INTERFACE BLOCK SPECIFICATIONS
! na
! DERIVED TYPE DEFINITIONS
! na
! SUBROUTINE LOCAL VARIABLE DECLARATIONS:
LOGICAL INTFLAG ! For overlap status
INTEGER E ! Edge loop index
INTEGER P ! Point loop index
INTEGER S ! Test vertex
INTEGER K ! Duplicate test index
INTEGER KK ! Duplicate test index
INTEGER NVOUT ! Current output length for loops
INTEGER NVTEMP
INTEGER SaveArrayBounds
REAL(r64) W ! Normalization factor
REAL(r64) HFunct
! REAL(r64), DIMENSION(2*(MaxVerticesPerSurface + 1)) :: ATEMP ! Temporary 'A' values for HC vertices of the overlap
! REAL(r64), DIMENSION(2*(MaxVerticesPerSurface + 1)) :: BTEMP ! Temporary 'B' values for HC vertices of the overlap
! REAL(r64), DIMENSION(2*(MaxVerticesPerSurface + 1)) :: CTEMP ! Temporary 'C' values for HC vertices of the overlap
! REAL(r64), DIMENSION(2*(MaxVerticesPerSurface + 1)) :: XTEMP1 ! Temporary 'X' values for HC vertices of the overlap
! REAL(r64), DIMENSION(2*(MaxVerticesPerSurface + 1)) :: YTEMP1 ! Temporary 'Y' values for HC vertices of the overlap
#ifdef EP_Count_Calls
NumClipPoly_Calls=NumClipPoly_Calls+1
#endif
! Populate the arrays with the original polygon
DO P=1, NV1
XTEMP(P) = HCX(P,NS1)
YTEMP(P) = HCY(P,NS1)
ATEMP(P) = HCA(P,NS1)
BTEMP(P) = HCB(P,NS1)
CTEMP(P) = HCC(P,NS1)
END DO
NVOUT = NV1 ! First point-loop is the length of the subject polygon.
INTFLAG = .false.
NVTEMP = 0
KK = 0
DO E=1, NV2 ! Loop over edges of the clipping polygon
DO P=1, NVOUT
XTEMP1(P) = XTEMP(P)
YTEMP1(P) = YTEMP(P)
END DO
S = NVOUT
DO P=1, NVOUT
HFunct=XTEMP1(P)*HCA(E,NS2)+YTEMP1(P)*HCB(E,NS2)+HCC(E,NS2)
IF (HFunct <= 0.0D0 ) THEN ! Vertex is not in the clipping plane
HFunct=XTEMP1(S)*HCA(E,NS2)+YTEMP1(S)*HCB(E,NS2)+HCC(E,NS2)
IF (HFunct > 0.0D0 ) THEN ! Test vertex is in the clipping plane
! Find/store the intersection of the clip edge and the line connecting S and P
KK = NVTEMP
NVTEMP = NVTEMP + 1
W = HCB(E,NS2)*ATEMP(S)-HCA(E,NS2)*BTEMP(S)
IF (W /= 0.0d0) THEN
XTEMP(NVTEMP) = NINT((HCC(E,NS2)*BTEMP(S)-HCB(E,NS2)*CTEMP(S))/W,i64)
YTEMP(NVTEMP) = NINT((HCA(E,NS2)*CTEMP(S)-HCC(E,NS2)*ATEMP(S))/W,i64)
ELSE
XTEMP(NVTEMP) = SafeDivide((HCC(E,NS2)*BTEMP(S)-HCB(E,NS2)*CTEMP(S)),W)
YTEMP(NVTEMP) = SafeDivide((HCA(E,NS2)*CTEMP(S)-HCC(E,NS2)*ATEMP(S)),W)
ENDIF
INTFLAG = .true.
IF(E==NV2) THEN ! Remove near-duplicates on last edge
IF (KK /= 0) THEN
DO K = 1, KK
IF (ABS(XTEMP(NVTEMP)-XTEMP(K)) > 2.0d0) CYCLE
IF (ABS(YTEMP(NVTEMP)-YTEMP(K)) > 2.0d0) CYCLE
NVTEMP = KK
EXIT ! K DO loop
END DO
END IF
END IF
END IF
KK = NVTEMP
NVTEMP = NVTEMP + 1
IF (NVTEMP > MAXHCArrayBounds) THEN
SaveArrayBounds=MAXHCArrayBounds
CALL ReallocateRealArray(XTEMP,SaveArrayBounds,MAXHCArrayIncrement)
SaveArrayBounds=MAXHCArrayBounds
CALL ReallocateRealArray(YTEMP,SaveArrayBounds,MAXHCArrayIncrement)
SaveArrayBounds=MAXHCArrayBounds
CALL ReallocateRealArray(XTEMP1,SaveArrayBounds,MAXHCArrayIncrement)
SaveArrayBounds=MAXHCArrayBounds
CALL ReallocateRealArray(YTEMP1,SaveArrayBounds,MAXHCArrayIncrement)
SaveArrayBounds=MAXHCArrayBounds
CALL ReallocateRealArray(ATEMP,SaveArrayBounds,MAXHCArrayIncrement)
SaveArrayBounds=MAXHCArrayBounds
CALL ReallocateRealArray(BTEMP,SaveArrayBounds,MAXHCArrayIncrement)
SaveArrayBounds=MAXHCArrayBounds
CALL ReallocateRealArray(CTEMP,SaveArrayBounds,MAXHCArrayIncrement)
MAXHCArrayBounds=SaveArrayBounds
ENDIF
XTEMP(NVTEMP) = XTEMP1(P)
YTEMP(NVTEMP) = YTEMP1(P)
IF(E==NV2) THEN ! Remove near-duplicates on last edge
IF (KK /= 0) THEN
DO K = 1, KK
IF (ABS(XTEMP(NVTEMP)-XTEMP(K)) > 2.0d0) CYCLE
IF (ABS(YTEMP(NVTEMP)-YTEMP(K)) > 2.0d0) CYCLE
NVTEMP = KK
EXIT ! K DO loop
END DO
END IF
END IF
ELSE
HFunct=XTEMP1(S)*HCA(E,NS2)+YTEMP1(S)*HCB(E,NS2)+HCC(E,NS2)
IF (HFunct <= 0.0D0) THEN ! Test vertex is not in the clipping plane
KK = NVTEMP
NVTEMP = NVTEMP + 1
W = HCB(E,NS2)*ATEMP(S)-HCA(E,NS2)*BTEMP(S)
IF (W /= 0.0d0) THEN
XTEMP(NVTEMP) = NINT((HCC(E,NS2)*BTEMP(S)-HCB(E,NS2)*CTEMP(S))/W,i64)
YTEMP(NVTEMP) = NINT((HCA(E,NS2)*CTEMP(S)-HCC(E,NS2)*ATEMP(S))/W,i64)
ELSE
XTEMP(NVTEMP) = SafeDivide((HCC(E,NS2)*BTEMP(S)-HCB(E,NS2)*CTEMP(S)),W)
YTEMP(NVTEMP) = SafeDivide((HCA(E,NS2)*CTEMP(S)-HCC(E,NS2)*ATEMP(S)),W)
ENDIF
INTFLAG = .true.
IF(E==NV2) THEN ! Remove near-duplicates on last edge
IF (KK /= 0) THEN
DO K = 1, KK
IF (ABS(XTEMP(NVTEMP)-XTEMP(K)) > 2.0d0) CYCLE
IF (ABS(YTEMP(NVTEMP)-YTEMP(K)) > 2.0d0) CYCLE
NVTEMP = KK
EXIT ! K DO loop
END DO
END IF
END IF
END IF
END IF
S = P
END DO ! end loop over points of subject polygon
NVOUT = NVTEMP
NVTEMP = 0
IF (E /= NV2) THEN
IF (NVOUT > 2) THEN ! Compute HC values for edges of output polygon
DO P=1, NVOUT-1
ATEMP(P) = YTEMP(P)-YTEMP(P+1)
BTEMP(P) = XTEMP(P+1)-XTEMP(P)
CTEMP(P) = XTEMP(P)*YTEMP(P+1)-YTEMP(P)*XTEMP(P+1)
END DO
ATEMP(NVOUT) = YTEMP(NVOUT)-YTEMP(1)
BTEMP(NVOUT) = XTEMP(1)-XTEMP(NVOUT)
CTEMP(NVOUT) = XTEMP(NVOUT)*YTEMP(1)-YTEMP(NVOUT)*XTEMP(1)
END IF
END IF
END DO ! end loop over edges in NS2
NV3 = NVOUT
IF(NV3 < 3) THEN ! Determine overlap status
OverlapStatus = NoOverlap
ELSE IF(.not. INTFLAG) THEN
OverlapStatus = FirstSurfWithinSecond
END IF
END SUBROUTINE CLIPPOLY