INTCPT Subroutine

private subroutine INTCPT(NV1, NV2, NV3, NS1, NS2)

Arguments

Type	Intent		Name
integer,	intent(in)	::	NV1
integer,	intent(in)	::	NV2
integer,	intent(inout)	::	NV3
integer,	intent(in)	::	NS1
integer,	intent(in)	::	NS2
Called By

Help
Source Code

INTCPT
Source Code

SUBROUTINE INTCPT(NV1,NV2,NV3,NS1,NS2)

          ! SUBROUTINE INFORMATION:
          !       AUTHOR         Legacy Code
          !       DATE WRITTEN
          !       MODIFIED       na
          !       RE-ENGINEERED  Lawrie, Oct 2000

          ! PURPOSE OF THIS SUBROUTINE:
          ! This subroutine determines all intercepts between the sides of figure NS1
          ! and the sides of figure NS2.

          ! METHODOLOGY EMPLOYED:
          ! The requirements for intersection are that the end points of
          ! line N lie on both sides of line M and vice versa.  Also
          ! eliminate cases where the end point of one line lies exactly
          ! on the other to reduce duplication with the enclosed points.

          ! REFERENCES:
          ! BLAST/IBLAST code, original author George Walton

          ! USE STATEMENTS:
          ! na

  IMPLICIT NONE    ! Enforce explicit typing of all variables in this routine

          ! SUBROUTINE ARGUMENT DEFINITIONS:
  INTEGER, INTENT(IN)    :: NV1      ! Number of vertices of figure NS1
  INTEGER, INTENT(IN)    :: NV2      ! Number of vertices of figure NS2
  INTEGER, INTENT(INOUT) :: NV3      ! Number of vertices of figure NS3
  INTEGER, INTENT(IN)    :: NS1      ! Number of the figure being overlapped
  INTEGER, INTENT(IN)    :: NS2      ! Number of the figure doing overlapping

          ! SUBROUTINE PARAMETER DEFINITIONS:
          ! na

          ! INTERFACE BLOCK SPECIFICATIONS
          ! na

          ! DERIVED TYPE DEFINITIONS
          ! na

          ! SUBROUTINE LOCAL VARIABLE DECLARATIONS:
  REAL(r64) W        ! Normalization factor
  REAL(r64) XUntrunc ! Untruncated X coordinate
  REAL(r64) YUntrunc ! Untruncated Y coordinate
  INTEGER(i64) :: I1       ! Intermediate result for testing intersection
  INTEGER(i64) :: I2       ! Intermediate result for testing intersection
  INTEGER K                 !
  INTEGER KK                !
  INTEGER M                 ! Side number of figure NS2
  INTEGER N                 ! Side number of figure NS1
  REAL(r64), ALLOCATABLE, DIMENSION(:)      :: XTEMP1  ! Temporary 'X' values for HC vertices of the overlap
  REAL(r64), ALLOCATABLE, DIMENSION(:)      :: YTEMP1  ! Temporary 'Y' values for HC vertices of the overlap

  DO N = 1, NV1
    DO M = 1, NV2

          ! Eliminate cases where sides N and M do not intersect.

      I1 = HCA(N,NS1)*HCX(M,NS2)   + HCB(N,NS1)*HCY(M,NS2)   + HCC(N,NS1)
      I2 = HCA(N,NS1)*HCX(M+1,NS2) + HCB(N,NS1)*HCY(M+1,NS2) + HCC(N,NS1)
      IF (I1 >= 0 .AND. I2 >= 0) CYCLE
      IF (I1 <= 0 .AND. I2 <= 0) CYCLE

      I1 = HCA(M,NS2)*HCX(N,NS1)   + HCB(M,NS2)*HCY(N,NS1)   + HCC(M,NS2)
      I2 = HCA(M,NS2)*HCX(N+1,NS1) + HCB(M,NS2)*HCY(N+1,NS1) + HCC(M,NS2)
      IF (I1 >= 0 .AND. I2 >= 0) CYCLE
      IF (I1 <= 0 .AND. I2 <= 0) CYCLE

          ! Determine the point of intersection and record in the temporary array.

      KK         = NV3
      NV3        = NV3 + 1
      W          = HCB(M,NS2)*HCA(N,NS1) - HCA(M,NS2)*HCB(N,NS1)
      XUntrunc   = (HCC(M,NS2)*HCB(N,NS1)-HCB(M,NS2)*HCC(N,NS1))/W
      YUntrunc   = (HCA(M,NS2)*HCC(N,NS1)-HCC(M,NS2)*HCA(N,NS1))/W
      IF (NV3 > SIZE(XTEMP)) THEN
!        write(outputfiledebug,*) 'nv3=',nv3,' size(xtemp)=',size(xtemp)
        ALLOCATE(XTEMP1(SIZE(XTEMP)+10))
        ALLOCATE(YTEMP1(SIZE(YTEMP)+10))
        XTEMP1=0.0d0
        YTEMP1=0.0d0
        XTEMP1(1:NV3-1)=XTEMP(1:NV3-1)
        YTEMP1(1:NV3-1)=YTEMP(1:NV3-1)
        DEALLOCATE(XTEMP)
        DEALLOCATE(YTEMP)
        ALLOCATE(XTEMP(SIZE(XTEMP1)))
        ALLOCATE(YTEMP(SIZE(YTEMP1)))
        XTEMP=XTEMP1
        YTEMP=YTEMP1
        DEALLOCATE(XTEMP1)
        DEALLOCATE(YTEMP1)
      ENDIF
      XTEMP(NV3) = NINT(XUntrunc,i64)
      YTEMP(NV3) = NINT(YUntrunc,i64)

          ! Eliminate near-duplicate points.

      IF (KK /= 0) THEN
        DO K = 1, KK
          IF (ABS(XTEMP(NV3)-XTEMP(K)) > 2.0d0) CYCLE
          IF (ABS(YTEMP(NV3)-YTEMP(K)) > 2.0d0) CYCLE
          NV3 = KK
          EXIT ! K DO loop
        END DO
      END IF

    END DO

  END DO

  RETURN

END SUBROUTINE INTCPT
All Procedures
