CLIP Subroutine

private subroutine CLIP(NVT, XVT, YVT, ZVT)

Arguments

Type	Intent	Attributes		Name
integer,	intent(in)		::	NVT
real(kind=r64),	intent(inout),	DIMENSION(:)	::	XVT
real(kind=r64),	intent(inout),	DIMENSION(:)	::	YVT
real(kind=r64),	intent(inout),	DIMENSION(:)	::	ZVT
Called By

Help
Source Code

CLIP
Source Code

SUBROUTINE CLIP(NVT,XVT,YVT,ZVT)

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

          ! PURPOSE OF THIS SUBROUTINE:
          ! This subroutine 'clips' the shadow casting surface polygon so that
          ! none of it lies below the plane of the receiving surface polygon.  This
          ! prevents the casting of 'false' shadows.

          ! METHODOLOGY EMPLOYED:
          ! na

          ! 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)               :: NVT
  REAL(r64), INTENT(INOUT), DIMENSION(:) :: XVT
  REAL(r64), INTENT(INOUT), DIMENSION(:) :: YVT
  REAL(r64), INTENT(INOUT), DIMENSION(:) :: ZVT

          ! SUBROUTINE PARAMETER DEFINITIONS:
          ! na

          ! INTERFACE BLOCK SPECIFICATIONS
          ! na

          ! DERIVED TYPE DEFINITIONS
          ! na

          ! SUBROUTINE LOCAL VARIABLE DECLARATIONS:
  INTEGER  N            ! Loop Control (vertex number)
  INTEGER  NABOVE       ! Number of vertices of shadow casting surface. above the plane of receiving surface
  INTEGER  NEXT         ! First vertex above plane of receiving surface
  INTEGER  NON          ! Number of vertices of shadow casting surface. on plane of receiving surface
  REAL(r64) XIN  ! X of entry point of shadow casting surface. into plane of receiving surface
  REAL(r64) XOUT ! X of exit point of shadow casting surface. from plane of receiving surface
  REAL(r64) YIN  ! Y of entry point of shadow casting surface. into plane of receiving surface
  REAL(r64) YOUT ! Y of exit point of shadow casting surface. from plane of receiving surface
!  INTEGER NVS      ! Number of vertices of the shadow/clipped surface

  ! Determine if the shadow casting surface. is above, below, or intersects with the plane of the receiving surface

  NABOVE=0
  NON=0
  NumVertInShadowOrClippedSurface = NVS
  DO N = 1, NVT
    IF (ZVT(N) > 0.0d0) NABOVE = NABOVE+1
    IF (ZVT(N) == 0.0d0) NON    = NON+1
  END DO

  IF (NABOVE+NON == NVT) THEN   ! Rename the unclipped shadow casting surface.

    NVS=NVT
    NumVertInShadowOrClippedSurface = NVT
    DO N = 1, NVT
      XVC(N) = XVT(N)
      YVC(N) = YVT(N)
      ZVC(N) = ZVT(N)
    END DO

  ELSEIF (NABOVE == 0) THEN ! Totally submerged shadow casting surface.

    NVS=0
    NumVertInShadowOrClippedSurface = 0

  ELSE  ! Remove (clip) that portion of the shadow casting surface. which is below the receiving surface

    NVS        = NABOVE + 2
    NumVertInShadowOrClippedSurface = NABOVE + 2
    XVT(NVT+1) = XVT(1)
    YVT(NVT+1) = YVT(1)
    ZVT(NVT+1) = ZVT(1)
    DO N = 1, NVT
      IF (ZVT(N) >= 0.0d0 .AND. ZVT(N+1) < 0.0d0) THEN ! Line enters plane of receiving surface

        XIN=(ZVT(N+1)*XVT(N)-ZVT(N)*XVT(N+1))/(ZVT(N+1)-ZVT(N))
        YIN=(ZVT(N+1)*YVT(N)-ZVT(N)*YVT(N+1))/(ZVT(N+1)-ZVT(N))

      ELSEIF (ZVT(N) <= 0.0d0 .AND. ZVT(N+1) > 0.0d0) THEN ! Line exits plane of receiving surface

        NEXT=N+1
        XOUT=(ZVT(N+1)*XVT(N)-ZVT(N)*XVT(N+1))/(ZVT(N+1)-ZVT(N))
        YOUT=(ZVT(N+1)*YVT(N)-ZVT(N)*YVT(N+1))/(ZVT(N+1)-ZVT(N))

      END IF
    END DO

          ! Renumber the vertices of the clipped shadow casting surface. so they are still counter-clockwise sequential.

    XVC(1)   = XOUT
    YVC(1)   = YOUT
    ZVC(1)   = 0.0d0
    XVC(NVS) = XIN
    YVC(NVS) = YIN
    ZVC(NVS) = 0.0d0
    DO N = 1, NABOVE
      IF (NEXT > NVT) NEXT = 1
      XVC(N+1) = XVT(NEXT)
      YVC(N+1) = YVT(NEXT)
      ZVC(N+1) = ZVT(NEXT)
      NEXT     = NEXT+1
    END DO

  END IF

  RETURN

END SUBROUTINE CLIP
All Procedures
