Commit 4f7fe35f by rabgra

### correction of bugs, add scheme 8

parent 9ae45a58
 MODULE quickhull !-------------------------------------------------- ! compute the convex hull of a family of points !Ref: https://en.wikibooks.org/wiki/Algorithm_Implementation/Geometry/Convex_hull/Monotone_chain#Pseudo-code ! 2D, complexity O(nlog(n)) ! algo: ! Input: a list P of points in the plane. ! !Precondition: There must be at least 3 points. ! !Sort the points of P by x-coordinate (in case of a tie, sort by y-coordinate). ! !Initialize U and L as empty lists. !The lists will hold the vertices of upper and lower hulls respectively. ! !for i = 1, 2, ..., n: ! while L contains at least two points and the sequence of last two points ! of L and the point P[i] does not make a counter-clockwise turn: ! remove the last point from L ! append P[i] to L ! !for i = n, n-1, ..., 1: ! while U contains at least two points and the sequence of last two points ! of U and the point P[i] does not make a counter-clockwise turn: ! remove the last point from U ! append P[i] to U ! !Remove the last point of each list (it's the same as the first point of the other list). !Concatenate L and U to obtain the convex hull of P. !Points in the result will be listed in counter-clockwise order. !__________________________________________________________ USE PRECISION IMPLICIT NONE PRIVATE PUBLIC:: test_quick REAL(DP), PARAMETER:: tol=-SQRT(EPSILON(0.0_dp)) REAL(dp), PARAMETER:: tol_hull=1.e-4!0._dp!-epsilon(0.0_dp) CONTAINS SUBROUTINE tri(x,y) IMPLICIT NONE REAL(DP), DIMENSION(:,:), INTENT(in) :: x REAL(DP), DIMENSION(:,:), INTENT(out) :: y REAL(DP), DIMENSION(2, SIZE(x, dim=2)):: buff LOGICAL, DIMENSION(SIZE(x,dim=2)) :: ind INTEGER :: m, j, k, i m=SIZE(x,dim=2) ind=.TRUE. k=0 DO i=1, m j=MINLOC(x(1,:),1, ind) k=k+1 buff(:, k)=x(:,j) ind(j)=.FALSE. ENDDO y=buff END SUBROUTINE tri REAL(dp) FUNCTION Cross(v1,v2,v3) ! IMPLICIT VARIABLE HANDLING IMPLICIT NONE !----------------------------------------------- ! INPUT VARIABLES REAL(DP),INTENT(IN) :: v1(2) !< input vector 1 REAL(DP),INTENT(IN) :: v2(2) !< input vector 2 REAL(DP),INTENT(IN) :: v3(2) !< input vector 3 !----------------------------------------------- ! OUTPUT VARIABLES REAL(DP) :: w1(2), w2(2) !----------------------------------------------- ! LOCAL VARIABLES !=============================================== w1=(v2-v1)/( SQRT( dot_PRODUCT( (v2-v1) , (v2-v1) ) ) -tol ) w2=(v3-v1)/( SQRT( dot_PRODUCT( (v3-v1) , (v3-v1) ) ) -tol ) Cross= w1(1) * w2(2) - w1(2) * w2(1) END FUNCTION Cross SUBROUTINE ConvHull(nPoints,Points_o,nHull,Hull)!, ilower, Lower, iupper, upper) ! IMPLICIT VARIABLE HANDLING IMPLICIT NONE CHARACTER(LEN = *), PARAMETER :: mod_name ="ConvHull" !------------------------------------------------ ! INPUT VARIABLES INTEGER,INTENT(IN) :: nPoints REAL(DP),INTENT(IN) :: Points_o(2,0:nPoints-1) !------------------------------------------------ ! OUTPUT VARIABLES INTEGER,INTENT(OUT) :: nHull ! NOTE: allocate Hull always one point greater than Points, because we save the first value twice REAL(DP),INTENT(OUT) :: Hull(2,0:nPoints) !------------------------------------------------ REAL(DP) :: Points(2,0:nPoints-1) ! LOCAL VARIABLES REAL(DP) :: Lower(2,0:nPoints-1) REAL(DP) :: Upper(2,0:nPoints-1) INTEGER :: iLower,iUpper INTEGER :: i !================================================ IF(nPoints.LE.1)THEN Hull = Points nHull = nPoints ELSE CALL tri(Points_o,Points) iLower = 0 Lower = -HUGE(1._dp) DO i=0,nPoints-1 DO WHILE(iLower.GE.2.AND.Cross(Lower(:,iLower-2),Lower(:,iLower-1),Points(:,i)).LE.0._dp) Lower(:,iLower) = -HUGE(1.) iLower = iLower - 1 END DO Lower(:,iLower) = Points(:,i) iLower = iLower + 1 END DO iUpper = 0 Upper = HUGE(1._dp) DO i=nPoints-1,0,-1 DO WHILE(iUpper.GE.2.AND.Cross(Upper(:,iUpper-2),Upper(:,iUpper-1),Points(:,i)).LE.0._dp) Upper(:,iUpper) = HUGE(1._dp) iUpper = iUpper - 1 END DO Upper(:,iUpper) = Points(:,i) iUpper = iUpper + 1 END DO iLower = iLower-1 iUpper = iUpper-1 nHull = iLower+iUpper+1 ! NOTE: Initialize Hull with zeros Hull = 0._dp ! NOTE: save values in Hull Hull(:,0 :iLower -1) = Lower(:,0:iLower-1) Hull(:,iLower:iLower+iUpper-1) = Upper(:,0:iUpper-1) ! NOTE: save first value twice Hull(:, iLower+iUpper ) = Hull (:,0 ) END IF END SUBROUTINE ConvHull LOGICAL FUNCTION is_in (Nhull, Hull, x, lk, jt) IMPLICIT NONE ! The parameter tol must be negative to be less strict that <0. CHARACTER(LEN = *), PARAMETER :: mod_name ="is_in" INTEGER, INTENT(in):: Nhull, lk, jt REAL(DP), DIMENSION(2,0:Nhull-1), INTENT(in):: Hull REAL(DP), DIMENSION(2), INTENT(in):: x REAL(DP), DIMENSION(Nhull-1):: prod INTEGER:: l DO l=1, Nhull-1 prod(l)=cross(x, hull(:,l-1), hull(:,l)) ENDDO IF (MINVAL(prod)*MAXVAL(prod).LE.-tol_hull) THEN! this is essential is_in=.FALSE. ELSE is_in=.TRUE. ENDIF END FUNCTION is_in LOGICAL FUNCTION test_quick(nPoints,Points,x,n,jt, lk, flag) IMPLICIT NONE CHARACTER(LEN = *), PARAMETER :: mod_name ="test_quick" ! INPUT VARIABLES INTEGER,INTENT(IN) :: nPoints,n, jt, lk REAL(DP),INTENT(IN) :: Points(2,0:nPoints-1) REAL(DP), DIMENSION(2,n), INTENT(in):: x LOGICAL, INTENT(in), OPTIONAL:: flag INTEGER :: nHull ! NOTE: allocate Hull always one point greater than Points, because we save the first value twice REAL(DP) :: Hull(2,0:nPoints) INTEGER:: i LOGICAL:: test CALL ConvHull(npoints, Points, nHull,Hull) IF (PRESENT(flag)) THEN PRINT*, nhull DO i=0, nhull-1 WRITE(3,*) hull(:,i) ENDDO ENDIF DO i=1, n test=is_in(Nhull,Hull,x(:,i),lk, jt) IF (.NOT.test) THEN test_quick=.FALSE. RETURN ENDIF ENDDO test_quick=.TRUE. END FUNCTION test_quick END MODULE quickhull