c Euclidean norm of the n-vector stored in sx() with storage increment incx.

	real function snrm2(n, sx, incx)

	implicit none

c	Parameters:
	integer	n
	real	sx(n)	! (1..n)
	integer	incx

c	Local variables:
	real	cuthi
	real	cutlo
	real	hitest
	integer	i, j
	integer	next
	integer	nn
	real	one
	real	sum
	real	xmax
	real	zero

	data   zero, one /0.0e0, 1.0e0/

c     if    n .le. 0 return with result = 0.
c     if n .ge. 1 then incx must be .ge. 1
c
c           c.l.lawson, 1978 jan 08
c
c     four phase method     using two built-in constants that are
c     hopefully applicable to all machines.
c         cutlo = maximum of  sqrt(u/eps)  over all known machines.
c         cuthi = minimum of  sqrt(v)      over all known machines.
c     where
c         eps = smallest no. such that eps + 1. .gt. 1.
c         u   = smallest positive no.   (underflow limit)
c         v   = largest  no.            (overflow  limit)
c
c     brief outline of algorithm..
c
c     phase 1    scans zero components.
c     move to phase 2 when a component is nonzero and .le. cutlo
c     move to phase 3 when a component is .gt. cutlo
c     move to phase 4 when a component is .ge. cuthi/m
c     where m = n for x() real and m = 2*n for complex.
c
c     values for cutlo and cuthi..
c     from the environmental parameters listed in the imsl converter
c     document the limiting values are as follows..
c     cutlo, s.p.   u/eps = 2**(-102) for  honeywell.  close seconds are
c                   univac and dec at 2**(-103)
c                   thus cutlo = 2**(-51) = 4.44089e-16
c     cuthi, s.p.   v = 2**127 for univac, honeywell, and dec.
c                   thus cuthi = 2**(63.5) = 1.30438e19
c     cutlo, d.p.   u/eps = 2**(-67) for honeywell and dec.
c                   thus cutlo = 2**(-33.5) = 8.23181d-11
c     cuthi, d.p.   same as s.p.  cuthi = 1.30438d19
c     data cutlo, cuthi / 8.232d-11,  1.304d19 /
c     data cutlo, cuthi / 4.441e-16,  1.304e19 /
      data cutlo, cuthi / 4.441e-16,  1.304e19 /

      if(n .gt. 0) go to 10
         snrm2  = zero
         go to 300

   10 assign 30 to next
      sum = zero
      nn = n * incx
c                                                 begin main loop
      i = 1
   20    go to next,(30, 50, 70, 110)
   30 if( abs(sx(i)) .gt. cutlo) go to 85
      assign 50 to next
      xmax = zero

c                        phase 1.  sum is zero

   50 if( sx(i) .eq. zero) go to 200
      if( abs(sx(i)) .gt. cutlo) go to 85

c                                prepare for phase 2.
      assign 70 to next
      go to 105

c                                prepare for phase 4.

  100 i = j
      assign 110 to next
      sum = (sum / sx(i)) / sx(i)
  105 xmax = abs(sx(i))
      go to 115

c                   phase 2.  sum is small.
c                             scale to avoid destructive underflow.

   70 if( abs(sx(i)) .gt. cutlo ) go to 75

c                     common code for phases 2 and 4.
c                     in phase 4 sum is large.  scale to avoid overflow.

  110 if( abs(sx(i)) .le. xmax ) go to 115
         sum = one + sum * (xmax / sx(i))**2
         xmax = abs(sx(i))
         go to 200

  115 sum = sum + (sx(i)/xmax)**2
      go to 200

c                  prepare for phase 3.

   75 sum = (sum * xmax) * xmax

c     for real or d.p. set hitest = cuthi/n
c     for complex      set hitest = cuthi/(2*n)

   85 hitest = cuthi/float( n )

c                   phase 3.  sum is mid-range.  no scaling.

      do 95 j =i,nn,incx
      if(abs(sx(j)) .ge. hitest) go to 100
   95    sum = sum + sx(j)**2
      snrm2 = sqrt( sum )
      go to 300

  200 continue
      i = i + incx
      if ( i .le. nn ) go to 20

c              end of main loop.

c              compute square root and adjust for scaling.

      snrm2 = xmax * sqrt(sum)
  300 continue
      return
      end


      SUBROUTINE DGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2001-11-04 DGBSL Krogh  Fixes for F77 and conversion to single
c--D replaces "?": ?GBSL, ?GBCO, ?GBFA, ?DOT, ?AXPY
c      IMPLICIT NONE
C***BEGIN PROLOGUE  DGBSL
C***PURPOSE  Solve the real band system A*X=B or TRANS(A)*X=B using
C            the factors computed by DGBCO or DGBFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2A2
C***TYPE      DOUBLE PRECISION (SGBSL-S, DGBSL-D, CGBSL-C)
C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DGBSL solves the double precision band system
C     A * X = B  or  TRANS(A) * X = B
C     using the factors computed by DGBCO or DGBFA.
C
C     On Entry
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                the output from DGBCO or DGBFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C
C        IPVT    INTEGER(N)
C                the pivot vector from DGBCO or DGBFA.
C
C        B       DOUBLE PRECISION(N)
C                the right hand side vector.
C
C        JOB     INTEGER
C                = 0         to solve  A*X = B ,
C                = nonzero   to solve  TRANS(A)*X = B , where
C                            TRANS(A)  is the transpose.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains a
C        zero on the diagonal.  Technically this indicates singularity
C        but it is often caused by improper arguments or improper
C        setting of LDA .  It will not occur if the subroutines are
C        called correctly and if DGBCO has set RCOND .GT. 0.0
C        or DGBFA has set INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)
C           IF (RCOND is too small) GO TO ...
C           DO 10 J = 1, P
C              CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0)
C        10 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DGBSL
      INTEGER LDA,N,ML,MU,IPVT(*),JOB
      DOUBLE PRECISION ABD(LDA,*),B(*)
C
      EXTERNAL DDOT
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,L,LA,LB,LM,M,NM1
C***FIRST EXECUTABLE STATEMENT  DGBSL
      M = MU + ML + 1
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE L*Y = B
C
         IF (ML .EQ. 0) GO TO 30
         IF (NM1 .LT. 1) GO TO 30
            DO 20 K = 1, NM1
               LM = MIN(ML,N-K)
               L = IPVT(K)
               T = B(L)
               IF (L .EQ. K) GO TO 10
                  B(L) = B(K)
                  B(K) = T
   10          CONTINUE
               CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1)
   20       CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/ABD(M,K)
            LM = MIN(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = -B(K)
            CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            LM = MIN(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = DDOT(LM,ABD(LA,K),1,B(LB),1)
            B(K) = (B(K) - T)/ABD(M,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (ML .EQ. 0) GO TO 90
         IF (NM1 .LT. 1) GO TO 90
            DO 80 KB = 1, NM1
               K = N - KB
               LM = MIN(ML,N-K)
               B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1)
               L = IPVT(K)
               IF (L .EQ. K) GO TO 70
                  T = B(L)
                  B(L) = B(K)
                  B(K) = T
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testGeom_CircCyl
#include "UnitTest.h"
USE ISO_FORTRAN_ENV
USE UnitTest
USE IntrType
USE Constants_Conversion
USE ParameterLists
USE Geom

IMPLICIT NONE

TYPE(PointType) :: point,point1,point2,point3,point4
TYPE(PointType) :: points(2),points2(2),points3(2)
TYPE(LineType) :: line1
TYPE(CircleType) :: circle1,circle2,circles(2)
TYPE(CylinderType) :: cylinder1,cylinder2,cylinders(2)
LOGICAL(SBK) :: bool

CREATE_TEST('Test Geom')
CALL eParams%setQuietMode(.TRUE.)
CALL eParams%setStopOnError(.FALSE.)

REGISTER_SUBTEST('Test Circle and Cylinder',TestCircle_and_Cylinder)
REGISTER_SUBTEST('circle%onSurface',testOnSurface)
FINALIZE_TEST()
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE TestCircle_and_Cylinder
!Test clear
  COMPONENT_TEST('Circle %clear()')
  CALL point%clear()
  CALL point2%clear()
  CALL point%init(DIM=2,X=0.1_SRK,Y=0.2_SRK)
  circle1%r=0.5_SRK
  circle1%c=point
  CALL circle1%clear()
  bool = .NOT.(circle1%r /= 0.0_SRK .OR. circle1%c%dim /= 0 .OR. &
      ALLOCATED(circle1%c%coord))
  ASSERT(bool, 'circle1%clear()')
!
!Test set
  !Error check
  COMPONENT_TEST('Circle %set()')
  CALL circle1%set(point2,0.5_SRK)
  bool=.NOT.(circle1%r /= 0.0_SRK .OR. circle1%c%dim /= 0 .OR. &
      ALLOCATED(circle1%c%coord))
  ASSERT(bool, 'circle1%set(...)')
  CALL circle1%set(point,-0.5_SRK)
  bool=.NOT.(circle1%r /= 0.0_SRK .OR. circle1%c%dim /= 0 .OR. &
      ALLOCATED(circle1%c%coord))
  ASSERT(bool, 'circle1%set(...)')
  !Real case
  CALL circle1%set(point,0.5_SRK)
  bool=.NOT.(circle1%r /= 0.5_SRK .OR. circle1%c%dim /= 2 .OR. &
      circle1%c%coord(1) /= 0.1_SRK .OR. circle1%c%coord(2) /= 0.2_SRK)
  ASSERT(bool, 'circle1%set(...)')
  CALL circle1%clear()
!
!Test intersect
  COMPONENT_TEST('Circle%intersectLine()')
  CALL point%clear()
  CALL circle1%clear()
  CALL line1%clear()
  CALL circle1%intersectLine(line1,point2,point3) !Test bad input

  !Reference circle for other tests
  CALL point%init(DIM=2,X=0.0_SRK,Y=0.0_SRK)
  CALL circle1%set(point,0.4225_SRK)

  !Test disjoint (pointing away)
  CALL line1%p1%init(DIM=2,X=0.3_SRK,Y=0.4_SRK)
  CALL line1%p2%init(DIM=2,X=0.4_SRK,Y=0.5_SRK)
  CALL circle1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -2 .OR. point3%dim /= -2)
  ASSERT(bool, 'circle1%intersectLine(...) (disjoint')
  CALL line1%clear()

  !Test disjoint (ray misses)
  CALL line1%p1%init(DIM=2,X=-0.4_SRK,Y=0.4_SRK)
  CALL line1%p2%init(DIM=2,X=-0.1_SRK,Y=0.5_SRK)
  CALL circle1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -2 .OR. point3%dim /= -2)
  ASSERT(bool, 'circle1%intersectLine(...) (disjoint 1)')
  CALL line1%clear()

  !Test disjoint although extension tagent
  CALL line1%p1%init(DIM=2,X=0.4225_SRK,Y=0.4_SRK)
  CALL line1%p2%init(DIM=2,X=0.4225_SRK,Y=0.6_SRK)
  CALL circle1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -2 .OR. point3%dim /= -2)
  ASSERT(bool, 'circle1%intersectLine(...) (disjoint 2)')

  CALL line1%clear()
  !Test tangent
  CALL line1%p1%init(DIM=2,X=0.4225_SRK,Y=0.4_SRK)
  CALL line1%p2%init(DIM=2,X=0.4225_SRK,Y=-0.5_SRK)
  CALL circle1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -3 .OR. point3%dim /= -3)
  ASSERT(bool, 'circle1%intersectLine(...) (tangent)')
  CALL line1%clear()

  !Test totally inside
  CALL line1%p1%init(DIM=2,X=0.0_SRK,Y=0.0_SRK)
  CALL line1%p2%init(DIM=2,X=0.1_SRK,Y=0.1_SRK)
  CALL circle1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= 0 .OR. point3%dim /= 0)
  ASSERT(bool, 'circle1%intersectLine(...) (inside)')
  CALL line1%clear()

  !Test 1 point of intersection
  CALL line1%p1%init(DIM=2,X=-0.4_SRK,Y=-0.3_SRK)
  CALL line1%p2%init(DIM=2,X=0.0_SRK,Y=0.0_SRK)
  CALL circle1%intersectLine(line1,point2,point3)
  bool = .NOT.(ANY(.NOT.(point2%coord .APPROXEQ. (/-0.3380_SRK,-0.2535_SRK/))) &
      .OR. point3%dim /= 0)
  ASSERT(bool, 'circle1%intersectLine(...) (1-point)')
  CALL line1%clear()

  !Test 2 points of intersection
  CALL line1%p1%init(DIM=2,X=-0.3_SRK,Y=-0.4_SRK)
  CALL line1%p2%init(DIM=2,X=0.4_SRK,Y=0.2_SRK)
  CALL circle1%intersectLine(line1,point2,point3)
  bool=ALL(point2%coord .APPROXEQ. (/-0.239446595040736_SRK,-0.348097081463488_SRK/)) &
      .AND. ALL(point3%coord .APPROXEQ. (/0.380623065628971_SRK,0.183391199110547_SRK/))
  ASSERT(bool,'circle1%intersectLine(...) (2-points)')
  CALL line1%clear()

  COMPONENT_TEST('Circle-Circle Intersect')
  !Test 1  (disjoint)
  CALL point%clear()
  CALL circle1%clear()
  CALL circle2%clear()
  CALL point%init(DIM=2,X=-1.0_SRK,Y=ZERO)
  CALL circle1%set(point,0.5_SRK)
  CALL point%clear()
  CALL point%init(DIM=2,X=1.0_SRK,Y=ZERO)
  CALL circle2%set(point,0.5_SRK)
  CALL circle1%intersectCircle(circle2,point2,point3)
  bool=(point2%dim == -2 .AND. point3%dim == -2)
  ASSERT(bool,'circle1%intersectCircle(...) (disjoint)')
  !Test 2 (tangent)
  CALL point%clear()
  CALL circle1%clear()
  CALL circle2%clear()
  CALL point%init(DIM=2,X=-1.0_SRK,Y=ZERO)
  CALL circle1%set(point,1.0_SRK)
  CALL point%clear()
  CALL point%init(DIM=2,X=1.0_SRK,Y=ZERO)
  CALL circle2%set(point,1.0_SRK)
  CALL circle1%intersectCircle(circle2,point2,point3)
  bool=(point2%dim == -3 .AND. point3%dim == -3)
  ASSERT(bool,'circle1%intersectCircle(...) (tangent)')
  !Test 3 (normal intersection)
  CALL point%clear()
  CALL circle1%clear()
  CALL circle2%clear()
  CALL point%init(DIM=2,X=ZERO,Y=ZERO)
  CALL circle1%set(point,1.0_SRK)
  CALL point%clear()
  CALL point%init(DIM=2,X=ZERO,Y=1.5_SRK)
  CALL circle2%set(point,1.0_SRK)
  CALL circle1%intersectCircle(circle2,point2,point3)
  bool=(point2%dim == 2 .AND. point3%dim == 2)
  ASSERT(bool,'circle1%intersectCircle(...) (Normal Intersect...on x-axis)')
  bool=(point2%coord(2)==point3%coord(2) .AND. point2%coord(1)==-point3%coord(1) &
      .AND. point2%coord(2)==0.75_SRK)
  ASSERT(bool,'circle1%intersectCircle(...) (Normal Intersect...on x-axis)')
  !Test 4 (normal intersection)
  CALL point%clear()
  CALL circle1%clear()
  CALL circle2%clear()
  CALL point%init(DIM=2,X=1.5_SRK,Y=1.5_SRK)
  CALL circle1%set(point,1.5_SRK)
  CALL point%clear()
  CALL point%init(DIM=2,X=2.5_SRK,Y=2.5_SRK)
  CALL circle2%set(point,SQRT(3.25_SRK-2.0_SRK*SQRT(2.0_SRK)))
  CALL circle1%intersectCircle(circle2,point2,point3)
  bool=(point2%dim == 2 .AND. point3%dim == 2)
  ASSERT(bool,'circle1%intersectCircle(...) (Normal Intersect)')
  bool=(point2%coord(1) == 2.0_SRK .AND. point3%coord(2) == 2.0_SRK)
  ASSERT(bool,'circle1%intersectCircle(...) (Normal Intersect)')
  !Test 5 (Overlapped)
  CALL point%clear()
  CALL circle1%clear()
  CALL circle2%clear()
  CALL point%init(DIM=2,X=ZERO,Y=ZERO)
  CALL circle1%set(point,1.5_SRK)
  CALL point%clear()
  CALL point%init(DIM=2,X=0.4_SRK,Y=0.25_SRK)
  CALL circle2%set(point,0.1_SRK)
  CALL circle1%intersectCircle(circle2,point2,point3)
  bool=(point2%dim == -4 .AND. point3%dim == -4)
  ASSERT(bool,'circle1%intersectCircle(...) (Overlapped)')
  !Test 6 (uninitialized circ)
  CALL point%clear()
  CALL circle1%clear()
  CALL circle2%clear()
  CALL point%init(DIM=2,X=0.4_SRK,Y=0.25_SRK)
  CALL circle2%set(point,0.1_SRK)
  CALL circle1%intersectCircle(circle2,point2,point3)
  bool=(point2%dim == -1 .AND. point3%dim == -1)
  ASSERT(bool,'circle1%intersectCircle(...) (uninitialized)')

  COMPONENT_TEST('Arc Intersect')
  CALL point%clear()
  CALL circle1%clear()
  CALL point%init(DIM=2,X=ZERO,Y=ZERO)
  CALL circle1%set(point,1.0_SRK,ANGSTT=ZERO,ANGSTP=HALFPI)
  !Test 1
  CALL line1%p1%init(DIM=2,X=-2.0_SRK,Y=1.5_SRK)
  CALL line1%p2%init(DIM=2,X=2.0_SRK,Y=-2.5_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 0 .AND. .NOT.ALLOCATED(point1%coord) .AND. &
      point2%dim == 0 .AND. .NOT.ALLOCATED(point2%coord) .AND. &
      point3%dim == -3 .AND. ALLOCATED(point3%coord) .AND. &
      point4%dim == -3 .AND. ALLOCATED(point4%coord))
  ASSERT(bool,'arc test 1 (no points)')
  !Test 2
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=-2.0_SRK,Y=0.5_SRK)
  CALL line1%p2%init(DIM=2,X=2.0_SRK,Y=0.5_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 0 .AND. .NOT.ALLOCATED(point1%coord) .AND. &
      point2%dim == 2 .AND. ALL(point2%coord .APPROXEQ. (/SQRT(0.75_SRK),0.5_SRK/)) .AND. &
      point3%dim == -3 .AND. .NOT.ALLOCATED(point3%coord) .AND. &
      point4%dim == 2 .AND. ALL(point4%coord .APPROXEQ. (/0.0_SRK,0.5_SRK/)))
  ASSERT(bool,'arc test 2 (arc and line)')
  !Test 3
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,Y=2.0_SRK,X=0.5_SRK)
  CALL line1%p2%init(DIM=2,Y=-2.0_SRK,X=0.5_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 2 .AND. ALL(point1%coord .APPROXEQ. (/0.5_SRK,SQRT(0.75_SRK)/)) .AND. &
      point2%dim == 0 .AND. .NOT.ALLOCATED(point2%coord) .AND. &
      point3%dim == 2 .AND. ALL(point3%coord .APPROXEQ. (/0.5_SRK,0.0_SRK/)) .AND. &
      point4%dim == -3 .AND. .NOT.ALLOCATED(point4%coord))
  ASSERT(bool,'arc test 3 (arc and line)')
  !Test 4
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=-2.0_SRK,Y=2.5_SRK)
  CALL line1%p2%init(DIM=2,X=2.0_SRK,Y=-1.5_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 0 .AND. .NOT.ALLOCATED(point1%coord) .AND. &
      point2%dim == 0 .AND. .NOT.ALLOCATED(point2%coord) .AND. &
      point3%dim == 2 .AND. ALL(point3%coord .APPROXEQ. (/0.5_SRK,0.0_SRK/)) .AND. &
      point4%dim == 2 .AND. ALL(point4%coord .APPROXEQ. (/0.0_SRK,0.5_SRK/)))
  ASSERT(bool,'arc test 4 (line and line)')
  !Test 5
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=0.5_SRK,Y=-0.1_SRK)
  CALL line1%p2%init(DIM=2,X=0.5_SRK,Y=0.1_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 0 .AND. .NOT.ALLOCATED(point1%coord) .AND. &
      point2%dim == 0 .AND. .NOT.ALLOCATED(point2%coord) .AND. &
      point3%dim == 2 .AND. ALL(point3%coord .APPROXEQ. (/0.5_SRK,0.0_SRK/)) .AND. &
      point4%dim == -3 .AND. .NOT.ALLOCATED(point2%coord))
  ASSERT(bool,'arc test 5 (one line inside)')
  !Test 6
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=0.5_SRK,Y=-2.0_SRK)
  CALL line1%p2%init(DIM=2,X=0.5_SRK,Y=0.1_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 0 .AND. .NOT.ALLOCATED(point1%coord) .AND. &
      point2%dim == 0 .AND. .NOT.ALLOCATED(point2%coord) .AND. &
      point3%dim == 2 .AND. ALL(point3%coord .APPROXEQ. (/0.5_SRK,0.0_SRK/)) .AND. &
      point4%dim == -3 .AND. .NOT.ALLOCATED(point2%coord))
  ASSERT(bool,'arc test 6 (one line over)')
  !Test 7
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=-2.0_SRK,Y=2.0_SRK)
  CALL line1%p2%init(DIM=2,X=2.0_SRK,Y=-2.0_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 0 .AND. .NOT.ALLOCATED(point1%coord) .AND. &
      point2%dim == 0 .AND. .NOT.ALLOCATED(point2%coord) .AND. &
      point3%dim == -3 .AND. ALL(point3%coord .APPROXEQ. (/0.0_SRK,0.0_SRK/)) .AND. &
      point4%dim == -3 .AND. ALL(point4%coord .APPROXEQ. (/0.0_SRK,0.0_SRK/)))
  ASSERT(bool,'arc test 7 (origin corner)')
  !Test 8
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=2.0_SRK,Y=1.0_SRK)
  CALL line1%p2%init(DIM=2,X=-2.0_SRK,Y=-3.0_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 0 .AND. .NOT.ALLOCATED(point1%coord) .AND. &
      point2%dim == 0 .AND. .NOT.ALLOCATED(point2%coord) .AND. &
      point3%dim == -3 .AND. ALL(point3%coord .APPROXEQ. (/1.0_SRK,0.0_SRK/)) .AND. &
      point4%dim == -3 .AND. ALL(point4%coord .APPROXEQ. (/0.0_SRK,-1.0_SRK/)))
  ASSERT(bool,'arc test 8 (arc corner)')
  !Test 9
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=-2.0_SRK,Y=2.5_SRK)
  CALL line1%p2%init(DIM=2,X=2.0_SRK,Y=-1.5_SRK)
  circle1%thetastt=HALFPI
  circle1%thetastp=TWOPI
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 2 .AND. ALL(point1%coord .APPROXEQ. (/-0.411437827766148_SRK,0.911437827766148_SRK/)) .AND. &
      point2%dim == 2 .AND. ALL(point2%coord .APPROXEQ. (/0.911437827766148_SRK,-0.411437827766148_SRK/)) .AND. &
      point3%dim == 2 .AND. ALL(point3%coord .APPROXEQ. (/0.0_SRK,0.5_SRK/)) .AND. &
      point4%dim == 2 .AND. ALL(point4%coord .APPROXEQ. (/0.5_SRK,0.0_SRK/)))
  ASSERT(bool,'arc test 9 (pacman)')
  !Test 10
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=0.0_SRK,Y=-0.1_SRK)
  CALL line1%p2%init(DIM=2,X=0.0_SRK,Y=2.0_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 0 .AND. .NOT.ALLOCATED(point1%coord) .AND. &
      point2%dim == 0 .AND. .NOT.ALLOCATED(point2%coord) .AND. &
      point3%dim == -3 .AND. .NOT.ALLOCATED(point3%coord) .AND. &
      point4%dim == -3 .AND. ALL(point4%coord .APPROXEQ. (/0.0_SRK,0.0_SRK/)))
  ASSERT(bool,'arc test 10 (y-axis)')
  !Test 11
  circle1%thetastt=ZERO
  circle1%thetastp=HALFPI
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=-2.0_SRK,Y=-2.0_SRK)
  CALL line1%p2%init(DIM=2,X=2.0_SRK,Y=2.0_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 0 .AND. .NOT.ALLOCATED(point1%coord) .AND. &
      point2%dim == 2 .AND. ALL(point2%coord .APPROXEQ. (/SQRT(0.5_SRK),SQRT(0.5_SRK)/)) .AND. &
      point3%dim == 2 .AND. ALL(point3%coord .APPROXEQ. (/0.0_SRK,0.0_SRK/)) .AND. &
      point4%dim == -3 .AND. ALL(point4%coord .APPROXEQ. (/0.0_SRK,0.0_SRK/)))
  ASSERT(bool,'arc test 11 (through origin)')
  !Test 12
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=-2.0_SRK,Y=1.5_SRK)
  CALL line1%p2%init(DIM=2,X=2.0_SRK,Y=-0.5_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 0 .AND. .NOT.ALLOCATED(point1%coord) .AND. &
      point2%dim == 0 .AND. .NOT.ALLOCATED(point2%coord) .AND. &
      point3%dim == 2 .AND. ALL(point3%coord .APPROXEQ. (/1.0_SRK,0.0_SRK/)) .AND. &
      point4%dim == 2 .AND. ALL(point4%coord .APPROXEQ. (/0.0_SRK,0.5_SRK/)))
  ASSERT(bool,'arc test 12 (corner side)')
  !Test 13
  CALL point%clear()
  CALL circle1%clear()
  CALL line1%clear()
  CALL point%init(DIM=2,X=1.0_SRK,Y=1.0_SRK)
  CALL circle1%set(point,1.0_SRK,ANGSTT=TWOPI-QTRPI,ANGSTP=QTRPI)
  CALL line1%p1%init(DIM=2,X=1.8_SRK,Y=2.5_SRK)
  CALL line1%p2%init(DIM=2,X=1.8_SRK,Y=0.0_SRK)
  CALL circle1%intersectArcLine(line1,point1,point2,point3,point4)
  bool=(point1%dim == 2 .AND. ALL(point1%coord .APPROXEQA. (/1.8_SRK,1.6_SRK/)) .AND. &
      point2%dim == 2 .AND. ALL(point2%coord .APPROXEQA. (/1.8_SRK,0.4_SRK/)) .AND. &
      point3%dim == -3 .AND. ALLOCATED(point3%coord) .AND. &
      point4%dim == -3 .AND. ALLOCATED(point4%coord))
  ASSERT(bool,'arc test 13 (arc crosses theta=0 (thetastt > thetastp))')

!Test hasPoint
  COMPONENT_TEST('Circle %inside()')
  !Full circle
  CALL point%clear()
  CALL point%init(COORD=(/1.5_SRK,1.5_SRK/))
  CALL circle2%set(point,0.4225_SRK)
  CALL point%clear()
  CALL point%init(COORD=(/1.6_SRK,1.6_SRK/))
  ASSERT(circle2%inside(point),'Circle internal point, Q1')
  CALL point%clear()
  CALL point%init(COORD=(/1.4_SRK,1.6_SRK/))
  ASSERT(circle2%inside(point),'Circle internal point, Q2')
  CALL point%clear()
  CALL point%init(COORD=(/1.4_SRK,1.4_SRK/))
  ASSERT(circle2%inside(point),'Circle internal point, Q3')
  CALL point%clear()
  CALL point%init(COORD=(/1.6_SRK,1.4_SRK/))
  ASSERT(circle2%inside(point),'Circle internal point, Q4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle external point')

  !Test half circle
  CALL point%clear()
  CALL point%init(COORD=(/-1.5_SRK,-1.5_SRK/))
  CALL circle2%set(point,0.4225_SRK,ANGSTT=ZERO,ANGSTP=PI)
  ASSERT(circle2%inside(circle2%c),'Circle Arc Centroid')
  CALL point%clear()
  CALL point%init(COORD=(/-1.4_SRK,-1.4_SRK/))
  ASSERT(circle2%inside(point),'Circle Arc internal point, Q1')
  CALL point%clear()
  CALL point%init(COORD=(/-1.6_SRK,-1.4_SRK/))
  ASSERT(circle2%inside(point),'Circle Arc internal point, Q2')
  CALL point%clear()
  CALL point%init(COORD=(/-1.6_SRK,-1.6_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle Arc external point, Q3')
  CALL point%clear()
  CALL point%init(COORD=(/-1.4_SRK,-1.6_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle Arc external point, Q4')

  !Test 1st and 2nd quadrant arc
  CALL point%clear()
  CALL point%init(COORD=(/-1.5_SRK,1.5_SRK/))
  CALL circle2%set(point,0.4225_SRK,ANGSTT=QTRPI,ANGSTP=HALFPI+QTRPI)
  ASSERT(circle2%inside(circle2%c),'Circle Arc Centroid')
  CALL point%clear()
  CALL point%init(COORD=(/-1.35_SRK,1.6_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle Arc external point Q1')
  CALL point%clear()
  CALL point%init(COORD=(/-1.4_SRK,1.6_SRK/))
  ASSERT(circle2%inside(point),'Circle Arc internal point Q1')
  CALL point%clear()
  CALL point%init(COORD=(/-1.6_SRK,1.6_SRK/))
  ASSERT(circle2%inside(point),'Circle Arc internal point Q2')
  CALL point%clear()
  CALL point%init(COORD=(/-1.7_SRK,1.6_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle Arc external point Q2')
  CALL point%clear()
  CALL point%init(COORD=(/-1.6_SRK,1.4_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle Arc external point Q3')
  CALL point%clear()
  CALL point%init(COORD=(/-1.4_SRK,1.4_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle Arc external point Q4')

  !Test "reflex" arc
  CALL point%clear()
  CALL point%init(COORD=(/1.5_SRK,-1.5_SRK/))
  CALL circle2%set(point,0.4225_SRK,ANGSTT=ZERO,ANGSTP=PI+HALFPI+QTRPI)
  ASSERT(circle2%inside(circle2%c),'Circle Arc Centroid')
  CALL point%clear()
  CALL point%init(COORD=(/1.6_SRK,-1.4_SRK/))
  ASSERT(circle2%inside(point),'Circle Arc internal point Q1')
  CALL point%clear()
  CALL point%init(COORD=(/1.45_SRK,-1.4_SRK/))
  ASSERT(circle2%inside(point),'Circle Arc internal point Q2')
  CALL point%clear()
  CALL point%init(COORD=(/1.4_SRK,-1.6_SRK/))
  ASSERT(circle2%inside(point),'Circle Arc internal point, Q3')
  CALL point%clear()
  CALL point%init(COORD=(/1.6_SRK,-1.6_SRK/))
  ASSERT(circle2%inside(point),'Circle Arc internal point on bndy, Q4')
  CALL point%clear()
  CALL point%init(COORD=(/1.7_SRK,-1.6_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle Arc external point Q4')

  !Test 3rd and 4th quadrant arc
  CALL point%clear()
  CALL point%init(COORD=(/1.5_SRK,1.5_SRK/))
  CALL circle2%set(point,0.4225_SRK,ANGSTT=PI+QTRPI,ANGSTP=PI+HALFPI+QTRPI)
  ASSERT(circle2%inside(circle2%c),'Circle Arc Centroid')
  CALL point%clear()
  CALL point%init(COORD=(/1.6_SRK,1.6_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle Arc external point Q1')
  CALL point%clear()
  CALL point%init(COORD=(/1.4_SRK,1.6_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle Arc external point Q2')
  CALL point%clear()
  CALL point%init(COORD=(/1.3_SRK,1.4_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle Arc external point Q3')
  CALL point%clear()
  CALL point%init(COORD=(/1.4_SRK,1.4_SRK/))
  ASSERT(circle2%inside(point),'Circle Arc internal point Q3')
  CALL point%clear()
  CALL point%init(COORD=(/1.5_SRK,1.4_SRK/))
  ASSERT(circle2%inside(point),'Circle Arc internal point Q3-Q4')
  CALL point%clear()
  CALL point%init(COORD=(/1.6_SRK,1.4_SRK/))
  ASSERT(circle2%inside(point),'Circle Arc internal point Q4')
  CALL point%clear()
  CALL point%init(COORD=(/1.7_SRK,1.4_SRK/))
  ASSERT(.NOT.circle2%inside(point),'Circle Arc external point Q4')

  !
  !Test for equivalence operation (implicitly tests assignment operation)
  COMPONENT_TEST('OPERATOR(==)')
  circle2=circle1
  ASSERT(circle1 == circle2,'circle equivalence')
  circle2%r=0.2_SRK
  ASSERT(.NOT.(circle1 == circle2),'circle non-equivalence')
!
!Test clear
  COMPONENT_TEST('Cylinder %clear()')
  CALL point3%clear()
  CALL point2%clear()
  CALL point2%init(DIM=3,X=0.1_SRK,Y=0.2_SRK,Z=0.3_SRK)
  CALL point3%init(DIM=3,X=0.1_SRK,Y=0.2_SRK,Z=1.3_SRK)
  cylinder1%axis%p1=point2
  cylinder1%axis%p2=point2
  cylinder1%r=1.0_SRK

  CALL cylinder1%clear()
  bool = .NOT.(cylinder1%r /= 0.0_SRK .OR. cylinder1%axis%p1%dim /= 0 .OR. &
      ALLOCATED(cylinder1%axis%p1%coord) .OR. cylinder1%axis%p2%dim /= 0 .OR. &
      ALLOCATED(cylinder1%axis%p2%coord))
  ASSERT(bool, 'cylinder1%clear()')
!
!Test set
  COMPONENT_TEST('Cylinder %set()')
  !Error check
  CALL cylinder1%set(point,point3,1.0_SRK)
  bool = .NOT.(cylinder1%r /= 0.0_SRK .OR. cylinder1%axis%p1%dim /= 0 .OR. &
      ALLOCATED(cylinder1%axis%p1%coord) .OR. cylinder1%axis%p2%dim /= 0 .OR. &
      ALLOCATED(cylinder1%axis%p2%coord))
  ASSERT(bool, 'cylinder1%set(...)')
  CALL cylinder1%set(point3,point3,1.0_SRK)
  bool = .NOT.(cylinder1%r /= 0.0_SRK .OR. cylinder1%axis%p1%dim /= 0 .OR. &
      ALLOCATED(cylinder1%axis%p1%coord) .OR. cylinder1%axis%p2%dim /= 0 .OR. &
      ALLOCATED(cylinder1%axis%p2%coord))
  ASSERT(bool, 'cylinder1%set(...)')
  CALL cylinder1%set(point2,point3,-1.0_SRK)
  bool = .NOT.(cylinder1%r /= 0.0_SRK .OR. cylinder1%axis%p1%dim /= 0 .OR. &
      ALLOCATED(cylinder1%axis%p1%coord) .OR. cylinder1%axis%p2%dim /= 0 .OR. &
      ALLOCATED(cylinder1%axis%p2%coord))
  ASSERT(bool, 'cylinder1%set(...)')
  !Real test
  CALL cylinder1%set(point2,point3,1.0_SRK)
  bool = .NOT.(cylinder1%r /= 1.0_SRK .OR. cylinder1%axis%p1%dim /= 3 .OR. &
      ANY(cylinder1%axis%p1%coord /= (/0.1_SRK,0.2_SRK,0.3_SRK/)) .OR. &
      cylinder1%axis%p2%dim /= 3 .OR. &
      ANY(cylinder1%axis%p2%coord /= (/0.1_SRK,0.2_SRK,1.3_SRK/)))
  ASSERT(bool, 'cylinder1%set(...)')
  CALL cylinder1%clear()

!
!Test intersection
  COMPONENT_TEST('Cylinder %intersectLine()')
  !Test bad input
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -1 .OR. point3%dim /= -1)
  ASSERT(bool, 'cylinder1%intersectLine(...) (bad input)')

  !Reference cylinder for all cases.
  cylinder1%r=1.0_SRK
  CALL cylinder1%axis%p1%init(DIM=3,X=0.1_SRK,Y=-0.2_SRK,Z=0.0_SRK)
  CALL cylinder1%axis%p2%init(DIM=3,X=0.1_SRK,Y=-0.2_SRK,Z=1.0_SRK)
  cylinder1%thetastp=TWOPI
  CALL line1%clear()

  !Test totally "outside" P-surface
  CALL line1%p1%init(DIM=3,X=2.0_SRK,Y=2.0_SRK,Z=-0.5_SRK)
  CALL line1%p2%init(DIM=3,X=2.0_SRK,Y=2.0_SRK,Z=-1.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -2 .OR. point3%dim /= -2)
  ASSERT(bool, 'cylinder1%intersectLine(...) (outside P)')
  CALL line1%clear()

  !Test totally "outside" Q-surface
  CALL line1%p1%init(DIM=3,X=2.0_SRK,Y=2.0_SRK,Z=10.5_SRK)
  CALL line1%p2%init(DIM=3,X=2.0_SRK,Y=2.0_SRK,Z=1.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -3 .OR. point3%dim /= -3)
  ASSERT(bool, 'cylinder1%intersectLine(...) (outside Q)')
  CALL line1%clear()

  !Test parallel on cylinder surface
  CALL line1%p1%init(DIM=3,X=0.1_SRK,Y=-1.2_SRK,Z=-0.5_SRK)
  CALL line1%p2%init(DIM=3,X=0.1_SRK,Y=-1.2_SRK,Z=1.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -4 .OR. point3%dim /= -4)
  ASSERT(bool, 'cylinder1%intersectLine(...) (parallel on surface)')
  CALL line1%clear()

  !Test parallel outside radius
  CALL line1%p1%init(DIM=3,X=2.0_SRK,Y=2.0_SRK,Z=-0.5_SRK)
  CALL line1%p2%init(DIM=3,X=2.0_SRK,Y=2.0_SRK,Z=1.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -5 .OR. point3%dim /= -5)
  ASSERT(bool, 'cylinder1%intersectLine(...) (parallel outside)')
  CALL line1%clear()

  !Test parallel totally inside
  CALL line1%p1%init(DIM=3,X=0.0_SRK,Y=0.2_SRK,Z=0.2_SRK)
  CALL line1%p2%init(DIM=3,X=0.0_SRK,Y=0.2_SRK,Z=0.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -6 .OR. point3%dim /= -6)
  ASSERT(bool, 'cylinder1%intersectLine(...) (parallel inside)')
  CALL line1%clear()

  !Test parallel both intersections
  CALL line1%p1%init(DIM=3,X=0.0_SRK,Y=0.0_SRK,Z=-0.5_SRK)
  CALL line1%p2%init(DIM=3,X=0.0_SRK,Y=0.0_SRK,Z=1.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(ANY(.NOT.(point2%coord .APPROXEQ. (/0.0_SRK,0.0_SRK,0.0_SRK/))) .OR. &
      ANY(.NOT.(point3%coord .APPROXEQ. (/0.0_SRK,0.0_SRK,1.0_SRK/))))
  ASSERT(bool, 'cylinder1%intersectLine(...) (parallel inside)')
  CALL line1%clear()

  !Test not parallel and tangent
  CALL line1%p1%init(DIM=3,X=-1.1_SRK,Y=-1.2_SRK,Z=0.5_SRK)
  CALL line1%p2%init(DIM=3,X=1.1_SRK,Y=-1.2_SRK,Z=0.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -7 .OR. point3%dim /= -7)
  ASSERT(bool, 'cylinder1%intersectLine(...) (disjoint)')
  CALL line1%clear()

  !Test not parallel and disjoint
  CALL line1%p1%init(DIM=3,X=0.1_SRK,Y=2.0_SRK,Z=0.5_SRK)
  CALL line1%p2%init(DIM=3,X=1.1_SRK,Y=2.0_SRK,Z=1.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= -8 .OR. point3%dim /= -8)
  ASSERT(bool, 'cylinder1%intersectLine(...) (disjoint)')
  CALL line1%clear()

  !Test not parallel outside no intersection
  CALL line1%p1%init(DIM=3,X=0.1_SRK,Y=2.0_SRK,Z=-0.5_SRK)
  CALL line1%p2%init(DIM=3,X=0.1_SRK,Y=2.5_SRK,Z=1.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(point2%dim /= 0 .OR. point3%dim /= 0)
  ASSERT(bool, 'cylinder1%intersectLine(...) (no intersection)')
  CALL line1%clear()

  !Test not parallel intersection with P-surface only
  CALL line1%p1%init(DIM=3,X=0.0_SRK,Y=0.0_SRK,Z=-0.5_SRK)
  CALL line1%p2%init(DIM=3,X=0.0_SRK,Y=0.5_SRK,Z=0.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(ANY(.NOT.(point2%coord .APPROXEQ. (/0.0_SRK,0.25_SRK,0.0_SRK/))) .OR. &
      point3%dim /= 0)
  ASSERT(bool, 'cylinder1%intersectLine(...) (P-surface)')
  CALL line1%clear()

  !Test not parallel intersection with Q-surface only
  CALL line1%p1%init(DIM=3,X=0.0_SRK,Y=0.0_SRK,Z=0.5_SRK)
  CALL line1%p2%init(DIM=3,X=0.0_SRK,Y=0.5_SRK,Z=1.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(ANY(.NOT.(point3%coord .APPROXEQ. (/0.0_SRK,0.25_SRK,1.0_SRK/))) .OR. &
      point2%dim /= 0)
  ASSERT(bool, 'cylinder1%intersectLine(...) (Q-surface)')
  CALL line1%clear()

  !Test not parallel intersection with both PQ-surfaces
  CALL line1%p1%init(DIM=3,X=0.0_SRK,Y=0.5_SRK,Z=1.5_SRK)
  CALL line1%p2%init(DIM=3,X=0.0_SRK,Y=0.0_SRK,Z=-0.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(ANY(.NOT.(point3%coord .APPROXEQ. (/0.0_SRK,0.125_SRK,0.0_SRK/))) .OR. &
      ANY(.NOT.(point2%coord .APPROXEQ. (/0.0_SRK,0.375_SRK,1.0_SRK/))))
  ASSERT(bool, 'cylinder1%intersectLine(...) (QP-surface)')
  CALL line1%clear()

  !Test not parallel intersection with cylinder once
  CALL line1%p1%init(DIM=3,X=0.0_SRK,Y=0.0_SRK,Z=0.5_SRK)
  CALL line1%p2%init(DIM=3,X=0.0_SRK,Y=1.5_SRK,Z=0.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(ANY(.NOT.(point3%coord .APPROXEQ. (/0.0_SRK,0.794987437106620_SRK,0.5_SRK/))) .OR. &
      point2%dim /= 0)
  ASSERT(bool, 'cylinder1%intersectLine(...)')
  CALL line1%clear()

  !Test not parallel intersection with cylinder twice
  CALL line1%p1%init(DIM=3,X=0.0_SRK,Y=-1.5_SRK,Z=0.5_SRK)
  CALL line1%p2%init(DIM=3,X=0.0_SRK,Y=1.5_SRK,Z=0.5_SRK)
  CALL cylinder1%intersectLine(line1,point2,point3)
  bool = .NOT.(ANY(.NOT.(point3%coord .APPROXEQ. (/0.0_SRK,0.794987437106620_SRK,0.5_SRK/))) .OR. &
      ANY(.NOT.(point2%coord .APPROXEQ. (/0.0_SRK,-1.194987437106620_SRK,0.5_SRK/))))
  ASSERT(bool, 'cylinder1%intersectLine(...) (cyl-2)')

  !Test missed intersection for slice of cylinder
  !cylinder1%thetastt=HALFPI
  !cylinder1%thetastp=PI
  !CALL line1%p1%init(DIM=3,X=-2.0_SRK,Y=-1.0_SRK,Z=0.44_SRK)
  !CALL line1%p2%init(DIM=3,X=2.0_SRK,Y=0.0_SRK,Z=0.55_SRK)
  !CALL cylinder1%intersectLine(line1,point2,point3)
  !bool = (point2%dim == 0) .AND. (point3%dim == 0)
  !ASSERT(bool,'cylinder1%intersectLine(...) (arc miss)')
  !FINFO() point2%dim, point2%coord
  !FINFO() point3%dim, point3%coord

  !Test for equivalence operation (implicitly tests assignment operation)
  COMPONENT_TEST('OPERATOR(==)')
  cylinder2=cylinder1
  ASSERT(cylinder1 == cylinder2,'cylinder equivalence')
  cylinder2%r=0.5_SRK
  ASSERT(.NOT.(cylinder1 == cylinder2),'cylinder non-equivalence')

  WRITE(*,*) 'TESTING CIRCLETYPE (arrays)'
!
!Test clear
  COMPONENT_TEST('Elemental Circle %clear()')
  CALL point%clear()
  CALL point2%clear()
  CALL point%init(DIM=2,X=0.1_SRK,Y=0.2_SRK)
  circles(1)%r=0.5_SRK
  circles(1)%c=point
  circles(2)%r=0.5_SRK
  circles(2)%c=point
  CALL circles%clear()
  bool = .NOT.(circles(1)%r /= 0.0_SRK .OR. circles(1)%c%dim /= 0 .OR. &
      ALLOCATED(circles(1)%c%coord) .OR. circles(2)%r /= 0.0_SRK .OR. &
      circles(2)%c%dim /= 0 .OR. ALLOCATED(circles(2)%c%coord))
  ASSERT(bool, 'circles%clear()')
!
!Test set
  COMPONENT_TEST('Elemental Circle %set()')
  CALL point%init(DIM=2,X=0.1_SRK,Y=0.2_SRK)
!This no longer works with Intel 12
  CALL circles%set(point,(/0.5_SRK,0.6_SRK/))
!      CALL circles(1)%set(point,0.5_SRK)
!      CALL circles(2)%set(point,0.6_SRK)
  bool = .NOT.(circles(1)%r /= 0.5_SRK .OR. circles(2)%r /= 0.6_SRK .OR. &
      ANY(circles(1)%c%coord /= (/0.1_SRK,0.2_SRK/)) .OR. &
      ANY(circles(2)%c%coord /= (/0.1_SRK,0.2_SRK/)) .OR. &
      circles(1)%c%dim /= 2 .OR. circles(2)%c%dim /= 2)
  ASSERT(bool, 'circles%set(...)')
!
!Test intersection
  COMPONENT_TEST('Elemental Circle %intersectLine()')
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=-1.0_SRK,Y=-1.0_SRK)
  CALL line1%p2%init(DIM=2,X=1.0_SRK,Y=1.0_SRK)

  CALL circles%intersectLine(line1,points,points2)
  bool = .NOT.(ANY(.NOT.(points(1)%coord .APPROXEQ. -0.2_SRK)) .OR. &
      ANY(.NOT.(points2(1)%coord .APPROXEQ. 0.5_SRK)) .OR. &
      ANY(.NOT.(points(2)%coord .APPROXEQ. -0.271307488658817_SRK)) .OR. &
      ANY(.NOT.(points2(2)%coord .APPROXEQ. 0.571307488658817_SRK)))
  ASSERT(bool, 'circles%intersectLine(...)')
!
!Test Clear
  COMPONENT_TEST('Elemental Cylinder %clear()')
  CALL point3%clear()
  CALL point2%clear()
  CALL point2%init(DIM=3,X=0.1_SRK,Y=-0.2_SRK,Z=0.0_SRK)
  CALL point3%init(DIM=3,X=0.1_SRK,Y=-0.2_SRK,Z=1.0_SRK)
  cylinders(1)%axis%p1=point2
  cylinders(1)%axis%p2=point2
  cylinders(1)%r=1.0_SRK
  cylinders(2)=cylinders(1)

  CALL cylinders%clear()
  bool = .NOT.(cylinders(1)%r /= 0.0_SRK .OR. cylinders(1)%axis%p1%dim /= 0 .OR. &
      ALLOCATED(cylinders(1)%axis%p1%coord) .OR. cylinders(1)%axis%p2%dim /= 0 .OR. &
      ALLOCATED(cylinders(1)%axis%p2%coord) .OR. cylinders(2)%r /= 0.0_SRK .OR. &
      cylinders(2)%axis%p1%dim /= 0 .OR. ALLOCATED(cylinders(2)%axis%p1%coord) .OR. &
      cylinders(2)%axis%p2%dim /= 0 .OR. ALLOCATED(cylinders(2)%axis%p2%coord))
  ASSERT(bool, 'cylinders%clear()')
!
!Test set
  COMPONENT_TEST('Elemental Cylinder %set()')
!This no longer works with Intel 12
  CALL cylinders%set(point2,point3,(/1.0_SRK,1.5_SRK/))
!      CALL cylinders(1)%set(point2,point3,1.0_SRK)
!      CALL cylinders(2)%set(point2,point3,1.5_SRK)
  bool = .NOT.(cylinders(1)%r /= 1.0_SRK .OR. cylinders(1)%axis%p1%dim /= 3 .OR. &
      ANY(cylinders(1)%axis%p1%coord /= (/0.1_SRK,-0.2_SRK,0.0_SRK/)) .OR. &
      cylinders(1)%axis%p2%dim /= 3 .OR. &
      ANY(cylinders(1)%axis%p2%coord /= (/0.1_SRK,-0.2_SRK,1.0_SRK/)) .OR. &
      cylinders(2)%r /= 1.5_SRK .OR. cylinders(2)%axis%p1%dim /= 3 .OR. &
      ANY(cylinders(2)%axis%p1%coord /= (/0.1_SRK,-0.2_SRK,0.0_SRK/)) .OR. &
      cylinders(2)%axis%p2%dim /= 3 .OR. &
      ANY(cylinders(2)%axis%p2%coord /= (/0.1_SRK,-0.2_SRK,1.0_SRK/)))
  ASSERT(bool, 'cylinders%set(...)')
!
!Test intersectLine
  COMPONENT_TEST('Elemental Cylinder %intersectLine()')
  CALL line1%clear()
  CALL line1%p1%init(DIM=3,X=0.0_SRK,Y=-2.5_SRK,Z=0.5_SRK)
  CALL line1%p2%init(DIM=3,X=0.0_SRK,Y=2.5_SRK,Z=0.5_SRK)
  CALL cylinders%intersectLine(line1,points2,points3)
  bool = .NOT.(ANY(.NOT.(points3(1)%coord .APPROXEQ. (/0.0_SRK,0.794987437106620_SRK,0.5_SRK/))) .OR. &
      ANY(.NOT.(points2(1)%coord .APPROXEQ. (/0.0_SRK,-1.194987437106620_SRK,0.5_SRK/))) .OR. &
      ANY(.NOT.(points3(2)%coord .APPROXEQ. (/0.0_SRK,1.296662954709577_SRK,0.5_SRK/))) .OR. &
      ANY(.NOT.(points2(2)%coord .APPROXEQ. (/0.0_SRK,-1.696662954709577_SRK,0.5_SRK/))))
  ASSERT(bool, 'cylinders%intersectLine(...)')

ENDSUBROUTINE TestCircle_and_Cylinder
!
!-------------------------------------------------------------------------------
SUBROUTINE testOnSurface()
  TYPE(CircleType) :: circle

  COMPONENT_TEST('Undefined circle')
  CALL circle%clear()
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'origin')

  COMPONENT_TEST('Full Circle')
  CALL circle%set(point,1.0_SRK)
  ASSERT(.NOT.circle%onSurface(point),'inside')
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,2.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'outside')
  CALL point%clear()
  CALL point%init(COORD=(/1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'0')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,1.0_SRK/))
  ASSERT(circle%onSurface(point),'PI/2')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'3*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/-1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'PI')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'5*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,-1.0_SRK/))
  ASSERT(circle%onSurface(point),'6*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'7*PI/4')

  COMPONENT_TEST('Half Circle [0,PI]')
  circle%thetastt=0.0_SRK
  circle%thetastp=PI
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'inside')
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,2.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'outside')
  CALL point%clear()
  CALL point%init(COORD=(/1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'0')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,1.0_SRK/))
  ASSERT(circle%onSurface(point),'PI/2')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'3*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/-1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'PI')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'5*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,-1.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'6*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'7*PI/4')

  COMPONENT_TEST('Half Circle [PI,0]')
  circle%thetastt=PI
  circle%thetastp=0.0_SRK
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'inside')
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,2.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'outside')
  CALL point%clear()
  CALL point%init(COORD=(/1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'0')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,1.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'PI/2')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'3*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/-1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'PI')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'5*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,-1.0_SRK/))
  ASSERT(circle%onSurface(point),'6*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'7*PI/4')

  COMPONENT_TEST('Half Circle [PI/2,3PI/2]')
  circle%thetastt=PI*0.5_SRK
  circle%thetastp=PI*1.5_SRK
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'inside')
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,2.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'outside')
  CALL point%clear()
  CALL point%init(COORD=(/1.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'0')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,1.0_SRK/))
  ASSERT(circle%onSurface(point),'PI/2')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'3*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/-1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'PI')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'5*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,-1.0_SRK/))
  ASSERT(circle%onSurface(point),'6*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'7*PI/4')

  COMPONENT_TEST('Half Circle [3PI/2,PI/2]')
  circle%thetastt=PI*1.5_SRK
  circle%thetastp=PI*0.5_SRK
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'inside')
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,2.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'outside')
  CALL point%clear()
  CALL point%init(COORD=(/1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'0')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,1.0_SRK/))
  ASSERT(circle%onSurface(point),'PI/2')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'3*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/-1.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'PI')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'5*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,-1.0_SRK/))
  ASSERT(circle%onSurface(point),'6*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'7*PI/4')

  COMPONENT_TEST('Half Circle [PI/4,5PI/4]')
  circle%thetastt=PI*0.25_SRK
  circle%thetastp=PI*1.25_SRK
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'inside')
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,2.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'outside')
  CALL point%clear()
  CALL point%init(COORD=(/1.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'0')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,1.0_SRK/))
  ASSERT(circle%onSurface(point),'PI/2')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'3*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/-1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'PI')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'5*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,-1.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'6*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'7*PI/4')

  COMPONENT_TEST('Half Circle [5PI/4,PI/4]')
  circle%thetastt=PI*1.25_SRK
  circle%thetastp=PI*0.25_SRK
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'inside')
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,2.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'outside')
  CALL point%clear()
  CALL point%init(COORD=(/1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'0')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,1.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'PI/2')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'3*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/-1.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'PI')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'5*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,-1.0_SRK/))
  ASSERT(circle%onSurface(point),'6*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'7*PI/4')

  COMPONENT_TEST('Half Circle [3PI/4,7PI/4]')
  circle%thetastt=PI*0.75_SRK
  circle%thetastp=PI*1.75_SRK
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'inside')
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,2.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'outside')
  CALL point%clear()
  CALL point%init(COORD=(/1.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'0')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,1.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'PI/2')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'3*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/-1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'PI')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'5*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,-1.0_SRK/))
  ASSERT(circle%onSurface(point),'6*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'7*PI/4')

  COMPONENT_TEST('Half Circle [7PI/4,3PI/4]')
  circle%thetastt=PI*1.75_SRK
  circle%thetastp=PI*0.75_SRK
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'inside')
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,2.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'outside')
  CALL point%clear()
  CALL point%init(COORD=(/1.0_SRK,0.0_SRK/))
  ASSERT(circle%onSurface(point),'0')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,1.0_SRK/))
  ASSERT(circle%onSurface(point),'PI/2')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'3*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/-1.0_SRK,0.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'PI')
  CALL point%clear()
  CALL point%init(COORD=(/-SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(.NOT.circle%onSurface(point),'5*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,-1.0_SRK/))
  ASSERT(.NOT.circle%onSurface(point),'6*PI/4')
  CALL point%clear()
  CALL point%init(COORD=(/SQRT(0.5_SRK),-SQRT(0.5_SRK)/))
  ASSERT(circle%onSurface(point),'7*PI/4')

  CALL circle%clear()
  CALL point%clear()
ENDSUBROUTINE testOnSurface
!
ENDPROGRAM testGeom_CircCyl


program n_collapse
    use percolation
    use utilities
    implicit none

    integer :: num_Ls, num_ps, num_samples, i, j, fileunit
    integer :: minLpow, maxLpow
    real(kind=dp), dimension(:), allocatable :: ps, PI, dpLpow
    integer, dimension(:), allocatable :: Ls
    real(kind=dp) :: nu
    character(len=:), allocatable :: filename

    nu = 4.0d0/3
    minLpow = 4
    maxLpow = 9
    Ls = [(2**i, i = minLpow, maxLpow)]
    num_Ls = size(Ls)
    num_ps = 500
    ps = linspace(0.0d0, 1.0d0, num_ps)
    num_samples = 2**13

    open(newunit=fileunit, file="tmp/n_Lpows.dat", status="replace")
    do i = minLpow, maxLpow
        write(unit=fileunit, fmt="(i0)") i
    end do
    close(unit=fileunit)

    do i = 1, num_Ls
        associate(L => Ls(i))
            dpLpow = (ps-pc)*L**(1/nu)
            PI = [(spanning_probability(ps(j), L, num_samples/L), &
                   j = 1, num_ps)]

            filename = "tmp/n_collapse_" // stringfromint(i) // ".dat"
            open(newunit=fileunit, file=filename, status="replace")
            do j = 1, num_ps
                write(unit=fileunit, fmt=*) dpLpow(j), PI(j)
            end do
            close(unit=fileunit)
        end associate
    end do
end program n_collapse


C  file dede_lf2F.f
C  Initializer for parameter common block
      subroutine initmod(odeparms)
      external odeparms
      double precision parms(6)
      common /myparms/parms

      call odeparms(6, parms)
      return
      end

C  Derivatives and one output variable
      subroutine derivs(neq, t, y, ydot, yout, ip)
      integer neq, ip(*)
      double precision t, y(neq), ydot(neq), yout(*)

      double precision N, P, ytau(2), tlag1, tlag2
      integer nr(2)

      double precision f, g, e, m, tau1, tau2
      common /myparms/f, g, e, m, tau1, tau2

      if (ip(1) < 2) call rexit("nout should be at least 2")

      N = y(1)
      P = y(2)
      nr(1) = 0
      nr(2) = 1
      ytau(1) = 1.0
      ytau(2) = 1.0

      tlag1 = t - tau1
      tlag2 = t - tau2
      if (min(tlag1, tlag2) .GE. 0.0) then
        call lagvalue(tlag1, nr(1), 1, ytau(1))
        call lagvalue(tlag2, nr(2), 1, ytau(2))
      endif

      ydot(1) = f * N - g * N * P
      ydot(2) = e * g * ytau(1) * ytau(2) - m * P

      yout(1) = ytau(1)
      yout(2) = ytau(2)

      return
      end

      double precision function getlag(t0, t, tau, ydef, nr)
      double precision t0, t, tau, ydef
      integer nr
      double precision tlag, y
      tlag = t - tau
      y = ydef
      if (tlag .GE. t0) call lagvalue(tlag, nr, 1, y)
      getlag = y
      return
      end

      subroutine derivs2(neq, t, y, ydot, yout, ip)
      integer neq, ip(*)
      double precision t, y(neq), ydot(neq), yout(*)

      double precision N, P, ytau(2), getlag

      double precision f, g, e, m, tau1, tau2
      common /myparms/f, g, e, m, tau1, tau2

      if (ip(1) < 2) call rexit("nout should be at least 2")

      N = y(1)
      P = y(2)
      ytau(1) = 1.0
      ytau(2) = 1.0
      ytau(1) = getlag(0.0, t, tau1, ytau(1), 0)
      ytau(2) = getlag(0.0, t, tau2, ytau(2), 1)

      ydot(1) = f * N - g * N * P
      ydot(2) = e * g * ytau(1) * ytau(2) - m * P

      yout(1) = ytau(1)
      yout(2) = ytau(2)

      return
      end


      subroutine fisotropic(sy,dsy,deqpl,dtime,temp,
     & statev,tempstatev,nstatv,props,nprops)
      implicit real*8(a-h,o-z)
      dimension statev(nstatv),tempstatev(nstatv),props(nprops)
c
      character*8 cmname
      parameter(zero=0.d0,one=1.d0,two=2.d0,newtonmax=10,toler=1.0d-8,
     & ratemin=1.d-10)
c
c     material properties
      emu0=props(1)
      ed0=props(2)
      et0=props(3)
c     props(4) is used for poisson's ratio
      sa=props(5)
      se0s=props(6)
      si=props(7)
      a0e=props(8)
      a0es=props(9)
      a0i=props(10)
      hard0=props(11)
      rate0=props(12)
      rate0es=props(13)
      qe=props(14)
      pe=props(15)
      qi=props(16)
      pi=props(17)
      pow=props(18)
      cm=props(19)
c
      cmname = 'MTS_POWR'
      if(cm.gt.zero)then
        cmname = 'MTS_TANH'
      endif
c
c     check
      rate = deqpl/dtime
      if(rate.lt.ratemin)then
        rate = ratemin
      endif
c
c     harden in statev
      sep = statev(1)
      sec = sep
c
      emu = emu0 - ed0/(dexp(et0/temp)-one)
      emuSF = emu/emu0
c
      sfi0 = temp/(a0i*emu)
      sfli = dlog(rate0/rate)*sfi0
      sfi = (one-sfli**(one/qi))**(one/pi)
c
      sfe0 = temp/(a0e*emu)
      sfle = dlog(rate0/rate)*sfe0
      sfe = (one-sfle**(one/qe))**(one/pe)
c
      c0 = -temp/(emu*a0es)
      sat = se0s*(rate/rate0es)**c0
c
      if(cmname(5:8).eq.'TANH')then
        hard = hard0*(one-(dtanh(pow*sec/sat)/dtanh(pow)))
        dhard = deqpl*hard0*pow/
     &   (dtanh(pow)*sat*dcosh(pow*sec/sat)**two)
      else
        hard = hard0*(one-(sec/sat))**pow
        dhard = (deqpl*hard0*pow*(one-(sec/sat))**(pow-one))/sat
      endif
      f = sec - sep - deqpl*hard
c
      if(dabs(f).gt.toler)then
      kount=1
      do while((dabs(f).gt.toler).and.(kount.lt.newtonmax))
        kount=kount+1
        sec = sec - f/(one+dhard)
        if(cmname(5:8).eq.'TANH')then
          hard = hard0*(one-(dtanh(pow*sec/sat)/dtanh(pow)))
          dhard = deqpl*hard0*pow/
     &            (dtanh(pow)*sat*dcosh(pow*sec/sat)**two)
        else
          hard = hard0*(one-(sec/sat))**pow
          dhard = (deqpl*hard0*pow*(one-(sec/sat))**(pow-one))/sat
        endif
        f = sec - sep - deqpl*hard
      enddo
      endif
c
c     Yield stress
      sy = sa + emusf*(sfi*si+sfe*sec)
c
c     Partial gradient componenets
c     d(sec)/d(epl)
      dsecdeqpl = hard/(one+dhard)
c     d(sfi)/d(epl)
      dsfideqpl = sfi0*(one-sfli**(one/qi))**(one/pi-one)*
     &          sfli**(one/qi-one)/(pi*qi*rate)
c     d(sfe)/d(epl)
      dsfedeqpl = sfe0*(one-sfle**(one/qe))**(one/pe-one)*
     &          sfle**(one/qe-one)/(pe*qe*rate)
c     d(sec)/d(rate)
      dsecdrt = c0*dhard*se0s*sec*(rate/rate0es)**(c0-one)/
     &          ((dhard+one)*rate0es*sat)
c     Total
c     d(yield)/d(epl)
      dsy =  emuSF*(sfe*(dsecdeqpl+dsecdrt/dtime)+dsfedeqpl*sec/dtime+
     &       dsfideqpl*si/dtime)
c
      tempstatev(1) = sec
      return
      end


MODULE SOI_delta_scaling

	USE Type_Kinds, only : fpk => fp_kind

	IMPLICIT NONE

	REAL(fpk), PRIVATE, PARAMETER	:: ONE = 1.0_fpk
	REAL(fpk), PRIVATE, PARAMETER	:: TWO = 2.0_fpk
	REAL(fpk), PRIVATE, PARAMETER	:: ZERO = 0.0_fpk

PUBLIC  :: deltascaling, deltascaling_TL, deltascaling_AD

CONTAINS

	SUBROUTINE deltascaling( opd,  &  ! input
                              ssa,  &  ! input
                              asy,  &  ! input
                                f,  &  ! input
                             opd2,  &  ! output
                             ssa2,  &  ! output
                             asy2)     ! output

		REAL(fpk), intent(in), dimension(:)		::	opd, ssa, asy, f
		REAL(fpk), intent(out), dimension(:)	::	opd2, ssa2, asy2

		opd2 = opd * (ONE - ssa * f)
		ssa2 = (ONE-f)*ssa/(ONE - f*ssa)
		asy2 = (asy-f)/(ONE-f)

	END SUBROUTINE deltascaling

	SUBROUTINE deltascaling_TL( opd,   &  ! input
                                ssa,    &  ! input
                                asy,    &  ! input
                                  f,    &  ! input
						       opd_TL,  &  ! input
	                           ssa_TL,  &  ! input
                               asy_TL,  &  ! input
                                 f_TL,  &  ! input
                               opd2_TL, &  ! output
                               ssa2_TL, &  ! output
                               asy2_TL  )  ! output

		REAL(fpk), intent(in), dimension(:)		::	opd, ssa, asy, f
		REAL(fpk), intent(in), dimension(:)		::	opd_TL, ssa_TL, asy_TL, f_TL
		REAL(fpk), intent(out), dimension(:)	::	opd2_TL, ssa2_TL, asy2_TL

		opd2_TL = (ONE-ssa*f)*opd_TL - opd*(ssa*f_TL + f*ssa_TL)
		ssa2_TL = (ssa*(ssa-ONE)*f_TL + (ONE-f)*ssa_TL)/(ONE-ssa*f)**2
		asy2_TL = asy_TL / (ONE-f) - (ONE-asy)*f_TL/(ONE-f)**2

	END SUBROUTINE deltascaling_TL

	SUBROUTINE deltascaling_AD( opd,   &  ! input
                                ssa,    &  ! input
                                asy,    &  ! input
                                  f,    &  ! input
						       opd_AD,  &  ! inout
	                           ssa_AD,  &  ! inout
                               asy_AD,  &  ! inout
                                 f_AD,  &  ! inout
                               opd2_AD, &  ! inout
                               ssa2_AD, &  ! inout
                               asy2_AD  )  ! inout

		REAL(fpk), intent(in), dimension(:)     ::	opd, ssa, asy, f
		REAL(fpk), intent(inout), dimension(:)  ::	opd_AD, ssa_AD, asy_AD, f_AD
		REAL(fpk), intent(inout), dimension(:)  ::	opd2_AD, ssa2_AD, asy2_AD
		REAL(fpk), dimension(size(opd))         ::	denom1, denom2

		! useful constants
		denom1 = (ONE-ssa*f)
		denom1 = ONE/(denom1*denom1)
		denom2 = ONE/(ONE-f)

		! adjoint statements
		opd_AD = opd_AD + (ONE-ssa*f)*opd2_AD
		ssa_AD = ssa_AD + (ONE-f)*denom1 * ssa2_AD - f*opd*opd2_AD
		asy_AD = asy_AD + asy2_AD*denom2
		f_AD = f_AD - (ONE-asy)*denom2*denom2*asy2_AD + ssa*(ssa-ONE)*denom1*ssa2_AD - ssa*opd*opd2_AD
		opd2_AD = ZERO
		ssa2_AD = ZERO
		asy2_AD = ZERO

	END SUBROUTINE deltascaling_AD

END MODULE SOI_delta_scaling


C NCLFORTSTART
      SUBROUTINE DWMRQ (P,TD,PMSG,TDMSG,NMAX,WMR,WMRMSG,ISWIT)
      IMPLICIT NONE
      INTEGER  NMAX, ISWIT
      DOUBLE PRECISION P(NMAX), TD(NMAX),PMSG,TDMSG
      DOUBLE PRECISION WMR(NMAX),WMRMSG
C NCLEND
      DOUBLE PRECISION DWMRSKEWT
      EXTERNAL DWMRSKEWT

C ncl:   q = mixhum_ptd (p,td,option)   [ q=g/kg ]
c                        p  - PA
c                        td - K
C local
      INTEGER  N
      DOUBLE PRECISION T0, PA2MB
      DATA     T0    /273.15d0/
      DATA     PA2MB /0.01d0  /

C mixing ratio (kg/kg)
c the function wants hPA (mb) and degrees centigrade

      DO N=1,NMAX
         IF (TD(N).EQ.TDMSG.or.P(N).EQ.PMSG) then
             WMR(N) = WMRMSG
         ELSE
             WMR(N) = DWMRSKEWT(P(N)*PA2MB,(TD(N)-T0))*0.001d0
         END IF
      END DO

c if ISWIT=2 calculate specific humidity (kg/kg)

      IF (ABS(ISWIT).EQ.2) THEN
          DO N=1,NMAX
             IF (WMR(N).NE.WMRMSG) THEN
                 WMR(N) = (WMR(N)/(WMR(N)+1.d0))
             END IF
         END DO
      END IF

c if ISWIT < 0 then return g/kg

      IF (ISWIT.LT.0) THEN
          DO N=1,NMAX
             IF (WMR(N).NE.WMRMSG) THEN
                 WMR(N) = WMR(N)*1000.d0
             END IF
         END DO
      END IF

      RETURN
      END


	SUBROUTINE FWINDW(IWINDW)
C
	COMMON /WINBLK/ WINDOW(1024)
	DATA TWOPI /6.2831853/
C
	GO TO (100,200,300) IWINDW+1
	PRINT*,'REQUESTED WINDOW DOES NOT EXIST'
 100	CONTINUE
	PRINT*,'IWINDW =',IWINDW,'  NO WINDOWING'
	DO N = 1,1024
	  WINDOW(N) = 1.
	ENDDO
	RETURN
 200	CONTINUE
C	PRINT*,'IWINDW =',IWINDW,'  HAMMING'
	ALPHA = .54
	GO TO 310
 300	CONTINUE
	ALPHA = .5
	PRINT*,'IWINDW =',IWINDW,'  HANNING'
 310	CONTINUE
	SUMSQ = 0.
	DO N = 1,1024
	  WINDOW(N) = ALPHA + (ALPHA-1.)*COS(TWOPI*(N-1)/1024.)
	  SUMSQ = SUMSQ + WINDOW(N)**2
	ENDDO
	RMS = SQRT(SUMSQ/1024.)
	DO N = 1,1024
	  WINDOW(N) = WINDOW(N)/RMS
	ENDDO
	RETURN
	END


    program easydop853_test

    use iso_fortran_env,    only: wp => real64

    use easydop853_module

    implicit none

    procedure(deriv_func) :: fcn
    !! subroutine computing the value of \(dy/dx=f(x,y)\)
    real(wp)              :: x  = 0.0_wp
    !! `x` value (input is initial value and output is final value)
    real(wp)              :: xf = 225000.0_wp
    !! endpoint of integration (final value of `x`)
    real(wp),dimension(6) :: y  = [1.0_wp,0.0_wp,0.0_wp,0.0_wp,1.0_wp,0.0_wp]
    !! `y` value (input is initial value and output is final value)

    call easydop853(fcn,x,xf,y)

    print *, x
    print *, y

    end program easydop853_test


!
! This sample illustrates the use of cufftBox3d and cufftXtSetDistribution
! to support arbitrary user data distributions in the case of an R2C - C2R transform
!
! It performs
! - Forward FFT
! - Element wise kernel
! - Inverse FFT

module cufft_required
    integer :: planr2c, planc2r
    integer :: local_rshape_in(3), local_rshape_out(3), local_cshape_out(3)

end module cufft_required

program cufftmp_r2c_c2r_pencils
    use iso_c_binding
    use cudafor
    use cufftXt
    use cufft
    use openacc
    use mpi
    use cufft_required
    implicit none

    integer :: size, rank, ndevices, ierr
    integer :: n, nx, ny, nz ! nx slowest
    integer :: nz_complex, nz_real_padded
    integer :: i, j, k, nranks1d
    integer :: my_nx, my_ny, my_nz, ranks_cutoff, whichgpu(1)
    real, dimension(:, :, :), allocatable :: u, ref
    complex, dimension(:,:,:), allocatable :: u_permuted
    real :: max_norm, max_diff

    ! cufft-related
    integer(c_size_t) :: worksize(1)
    type(cudaLibXtDesc), pointer :: u_desc
    type(cudaXtDesc), pointer    :: u_descptr
    complex, pointer, device     :: u_dptr(:,:,:)
    integer(kind=cuda_stream_kind) :: stream
    type(cufftBox3d), dimension(:), allocatable :: input_boxes, output_boxes

    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD,size,ierr)
    call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)

    call checkCuda(cudaGetDeviceCount(ndevices))
    nranks1d = sqrt(real(size))
    if (nranks1d * nranks1d .ne. size) then
        print*,"The number of MPI ranks should be a perfect square"
        call mpi_finalize(ierr)
    end if

    call checkCuda(cudaSetDevice(mod(rank, ndevices)))
    whichgpu(1) = mod(rank, ndevices)
    print*,"Hello from rank ", rank, " gpu id", mod(rank, ndevices), "size", size

    ! Define custom data distribution
    n = 32
    nx = n * nranks1d
    ny = nx
    nz = nx
    nz_complex = nz/2+1
    nz_real_padded = 2 * nz_complex

    ! Input data is real, distributed in X and Y, contiguous at Z
    ! Output data is complex, distributed in X and Y (picked arbitrarily)
    local_rshape_in = [nz_real_padded, n, n]
    local_cshape_out = [nz_complex, n, n]
    local_rshape_out = [nz_real_padded, n, n]

    if (rank == 0) then
        write(*,*) "local_rshape_in  :", local_rshape_in(1), local_rshape_in(2), local_rshape_in(3)
        write(*,*) "local_cshape_out :", local_cshape_out(1), local_cshape_out(2), local_cshape_out(3)
    end if

    ! cufftBox3d boxes are defined as { {x_start, y_start, z_start}, {x_end, y_end, z_end}, {x%strides, y%strides, z%strides} }
    ! where
    ! - {x/y/z}_{start/end} are the lower and upper corner of the boxes relatived to the global 3D box (of size nx * ny * nz)
    ! - {x/y/z} strides are the local strides. Note the use of the padded stride at z
    allocate(input_boxes(0:size-1), output_boxes(0:size-1) )
    do i = 0 , nranks1d - 1
        do j = 0, nranks1d - 1
            ! input data are pencils in X and Y, contiguous at Z
            input_boxes( i*nranks1d + j )%lower = [i*n, j*n, 0]                              !x,y,z start global Idx
            input_boxes( i*nranks1d + j )%upper = [(i+1)*n, (j+1)*n, nz]                     !x,y,z end global Idx
            input_boxes( i*nranks1d + j )%strides = [n * nz_real_padded, nz_real_padded, 1]  !x,y,z stride local
            ! output data are pencils in X and Y, picked arbitrarily
            output_boxes( i*nranks1d + j )%lower = [i*n, j*n, 0]                             !x,y,z start global Idx
            output_boxes( i*nranks1d + j )%upper = [(i+1)*n, (j+1)*n, nz_complex]            !x,y,z end global Idx
            output_boxes( i*nranks1d + j )%strides = [n * nz_complex, nz_complex, 1]         !x,y,z stride local
        end do
    end do

	write(*,'(A18, I1, A10, 3I10)') "my rank", rank, "lower", input_boxes(rank)%lower
    write(*,'(A18, I1, A10, 3I10)') "my rank", rank, "upper", input_boxes(rank)%upper
    write(*,'(A18, I1, A10, 3I10)') "my rank", rank, "strides", input_boxes(rank)%strides

    ! Generate local, distributed data
    allocate(u(local_rshape_in(1), local_rshape_in(2), local_rshape_in(3)))
    allocate(u_permuted(local_cshape_out(1), local_cshape_out(2), local_cshape_out(3)))
    allocate(ref(local_rshape_in(1), local_rshape_in(2), local_rshape_in(3)))
    print*,'shape of u is ', shape(u)
    print*,'shape of u_permuted is ', shape(u_permuted)
    call generate_random(nz, local_rshape_in(1), local_rshape_in(2), local_rshape_in(3), u)
    ref = u
    u_permuted = (0.0,0.0)

    call checkNorm(nz, local_rshape_in(1), local_rshape_in(2), local_rshape_in(3), u, max_norm)
    print*, "initial data on ", rank, " max_norm is ", max_norm

    call checkCufft(cufftCreate(planr2c))
    call checkCufft(cufftCreate(planc2r))
    call checkCuda(cudaStreamCreate(stream))
    call checkCufft(cufftMpAttachComm(planr2c, CUFFT_COMM_MPI, MPI_COMM_WORLD), 'cufftMpAttachComm error')
    call checkCufft(cufftMpAttachComm(planc2r, CUFFT_COMM_MPI, MPI_COMM_WORLD), 'cufftMpAttachComm error')

    call checkCufft(cufftSetStream(planr2c, stream), 'cufftSetStream error')
    call checkCufft(cufftSetStream(planc2r, stream), 'cufftSetStream error')
    call checkCufft(cufftXtSetDistribution(planr2c, input_boxes(rank), output_boxes(rank)))
    call checkCufft(cufftXtSetDistribution(planc2r, input_boxes(rank), output_boxes(rank)))

    call checkCufft(cufftMakePlan3d(planr2c, nz, ny, nx, CUFFT_R2C, worksize), 'cufftMakePlan3d r2c error')
    call checkCufft(cufftMakePlan3d(planc2r, nz, ny, nx, CUFFT_C2R, worksize), 'cufftMakePlan3d c2r error')

    call checkCufft(cufftXtMalloc(planr2c, u_desc, CUFFT_XT_FORMAT_DISTRIBUTED_INPUT), 'cufftXtMalloc error')
    call cufft_memcpyH2D(u_desc, u, CUFFT_XT_FORMAT_INPLACE, .true.)
    ! now reset u to make sure the check later is valid
    u = 0.0

    !xxxxxxxxxxxxxxxxxxxxxxxxxx Forward
    call checkCufft(cufftXtExecDescriptor(planr2c, u_desc, u_desc, CUFFT_FORWARD),'forward fft failed')
    call checkCuda(cudaStreamSynchronize(stream))

    ! in case we want to check the results after Forward
    call checkCufft(cufftXtMemcpy(planr2c, u_permuted, u_desc, CUFFT_COPY_DEVICE_TO_HOST), 'permuted D2H error')
    call checkNormComplex(local_cshape_out(1), local_cshape_out(2), local_cshape_out(3), u_permuted, max_norm)
    write(*,'(A18, I1, A14, F25.8)') "after R2C ", rank, " max_norm is ", max_norm

    ! Data is now distributed as Y-Slab. We need to scale the output
    call c_f_pointer(u_desc%descriptor, u_descptr)
    call c_f_pointer(u_descptr%data(1), u_dptr, [local_cshape_out(1), local_cshape_out(2), local_cshape_out(3)])
    !$cuf kernel do (3)
    do k =1, local_cshape_out(3)
        do j = 1, local_cshape_out(2)
            do i = 1, local_cshape_out(1)
                u_dptr(i,j,k) = u_dptr(i,j,k) / real(nx*ny*nz)
            end do
        end do
    end do
    call checkCuda(cudaDeviceSynchronize())

    ! in case we want to check again after scaling
    call checkCufft(cufftXtMemcpy(planr2c, u_permuted, u_desc, CUFFT_COPY_DEVICE_TO_HOST), 'permuted D2H error')
    call checkNormComplex(local_cshape_out(1), local_cshape_out(2), local_cshape_out(3), u_permuted, max_norm)
    write(*,'(A18, I1, A14, F25.8)') "after scaling ", rank, " max_norm is ", max_norm

    !xxxxxxxxxxxxxxxxxxxxxxxxxxxx inverse
    call checkCufft(cufftXtExecDescriptor(planc2r, u_desc, u_desc, CUFFT_INVERSE), 'inverse fft failed')
    call cufft_memcpyD2H(u, u_desc, CUFFT_XT_FORMAT_INPLACE, .true.)
    call checkCufft(cufftXtFree(u_desc))
    call checkCufft(cufftDestroy(planr2c))
    call checkCufft(cufftDestroy(planc2r))
    call checkCufft(cudaStreamDestroy(stream))

    call checkNormDiff(nz, local_rshape_in(1), local_rshape_in(2), local_rshape_in(3), u, ref, max_norm, max_diff)
    write(*,'(A18, I1, A14, F25.8, A14, F15.8)') "after C2R ", rank, " max_norm is ", max_norm, " max_diff is ", max_diff
    write(*,'(A25, I1, A14, F25.8)') "Relative Linf on rank ", rank, " is ", max_diff/max_norm
    deallocate(u)
    deallocate(ref)
    deallocate(u_permuted)

    call mpi_finalize(ierr)

    if(max_diff / max_norm > 1e-5) then
        print*, ">>>> FAILED on rank ", rank
        stop 1
    else
        print*, ">>>> PASSED on rank ", rank
    end if

contains
    subroutine checkCuda(istat, message)
        implicit none
        integer, intent(in)                   :: istat
        character(len=*),intent(in), optional :: message
        if (istat /= cudaSuccess) then
            write(*,"('Error code: ',I0, ': ')") istat
            write(*,*) cudaGetErrorString(istat)
            if(present(message)) write(*,*) message
            call mpi_finalize(ierr)
        endif
    end subroutine checkCuda

    subroutine checkCufft(istat, message)
        implicit none
        integer, intent(in)                   :: istat
        character(len=*),intent(in), optional :: message
        if (istat /= CUFFT_SUCCESS) then
            write(*,"('Error code: ',I0, ': ')") istat
            write(*,*) cudaGetErrorString(istat)
            if(present(message)) write(*,*) message
            call mpi_finalize(ierr)
        endif
    end subroutine checkCufft

    subroutine generate_random(nz1, nz, ny, nx, data)
        implicit none
        integer, intent(in) :: nx, ny, nz, nz1
        real, dimension(nz, ny, nx), intent(out) :: data
        real :: rand(1)
        integer :: i,j,k
        do k =1, nx
            do j = 1, ny
                do i = 1, nz1
                    call random_number(rand)
                    data(i,j,k) = rand(1)
                end do
            end do
        end do

    end subroutine generate_random

    subroutine checkNorm(nz1, nz, ny, nx, data, max_norm)
        implicit none
        integer, intent(in)  :: nx, ny, nz, nz1
        real, dimension(nz, ny, nx), intent(in) :: data
        real :: max_norm
        integer :: i, j, k
        max_norm = 0
        do k =1, nx
            do j = 1, ny
                do i = 1, nz1
                    max_norm = max(max_norm, abs(data(i,j,k)))
                end do
            end do
        end do
    end subroutine checkNorm

    subroutine checkNormComplex(nz, ny, nx, data, max_norm)
        implicit none
        integer, intent(in)  :: nx, ny, nz
        complex, dimension(nz, ny, nx), intent(in) :: data
        real :: max_norm, max_diff
        integer :: i,j,k
        max_norm = 0
        do k =1, nx
            do j = 1, ny
                do i = 1, nz
                    max_norm = max(max_norm, abs(data(i,j,k)%re))
                    max_norm = max(max_norm, abs(data(i,j,k)%im))
                end do
            end do
        end do
    end subroutine checkNormComplex

    subroutine checkNormDiff(nz1, nz, ny, nx, data, ref, max_norm, max_diff)
        implicit none
        integer, intent(in)  :: nx, ny, nz, nz1
        real, dimension(nz, ny, nx), intent(in) :: data, ref
        real :: max_norm, max_diff
        max_norm = 0
        max_diff = 0
        do k =1, nx
            do j = 1, ny
                do i = 1, nz1
                    max_norm = max(max_norm, abs(data(i,j,k)))
                    max_diff = max(max_diff, abs(ref(i,j,k)-data(i,j,k)))
                    if (abs(ref(i,j,k)-data(i,j,k)) > 0.0001) write(*,'(A10 I3 I3 I3 A2 F18.8 A7 F18.8 A10 I2)') "diff ref[", &
                    i, j, k, "]", ref(i,j,k), "data ", data(i,j,k), " at rank ", rank
                end do
            end do
        end do
    end subroutine checkNormDiff

#ifdef ACC
    subroutine scalingData(nz, ny, nx, data, factor)
        implicit none
        integer, intent(in)  :: nx, ny, nz
        complex, dimension(nz, ny, nz) :: data
        !$acc declare deviceptr(data)
        real, intent(in)     :: factor

    !$acc parallel loop collapse(3)
        do k =1, nx
            do j = 1, ny
                do i = 1, nz
                    data(i, j, k) = data(i, j, k) / factor
                end do
            end do
        end do

    end subroutine scalingData
#endif

subroutine cufft_memcpyH2D(ulibxt, u_h, data_format, ismemcpy)
    implicit none
    type(cudaLibXtDesc), pointer, intent(out) :: ulibxt
    real, dimension(*), intent(in)          :: u_h
    integer, intent(in)                         :: data_format
    logical, intent(in)                         :: ismemcpy
    type(cudaXtDesc), pointer  :: uxt
    real, dimension(:,:,:), device, pointer :: u_d

    if(data_format == CUFFT_XT_FORMAT_INPLACE_SHUFFLED) then
      if (ismemcpy == .false.) then
        call checkCufft(cufftXtMemcpy(planc2r, ulibxt, u_h, CUFFT_COPY_HOST_TO_DEVICE), "cufft_memcpyHToD pinv Error")
      else
        call c_f_pointer(ulibxt%descriptor, uxt)
        call c_f_pointer(uxt%data(1), u_d, local_rshape_out)
        call checkCuda(cudaMemcpy(u_d, u_h, product(int(local_rshape_out,kind=8))), "cudamemcpy H2D Error")
        nullify(u_d, uxt)
      endif
    endif

    if (data_format == CUFFT_XT_FORMAT_INPLACE) then
      if (ismemcpy == .false.) then
        call checkCufft(cufftXtMemcpy(planr2c, ulibxt, u_h, CUFFT_COPY_HOST_TO_DEVICE), "cufft_memcpyHToD pfor Error")
      else
        call c_f_pointer(ulibxt%descriptor, uxt)
        call c_f_pointer(uxt%data(1), u_d, local_rshape_in)
        call checkCuda(cudaMemcpy(u_d, u_h, product(int(local_rshape_in,kind=8))), "cudamemcpy H2D Error")
        nullify(u_d, uxt)
      endif
    endif
end subroutine cufft_memcpyH2D

subroutine cufft_memcpyD2H(u_h, ulibxt, data_format,ismemcpy)
    implicit none
    type(cudaLibXtDesc), pointer, intent(in) :: ulibxt
    real, dimension(*), intent(out)      :: u_h
    integer, intent(in)                      :: data_format
    logical, intent(in)                      :: ismemcpy
    type(cudaXtDesc), pointer  :: uxt
    real, dimension(:,:,:), device, pointer :: u_d

    if(data_format == CUFFT_XT_FORMAT_INPLACE_SHUFFLED) then
      if (ismemcpy == .false.) then
        call checkCufft(cufftXtMemcpy(planr2c, u_h, ulibxt, CUFFT_COPY_DEVICE_TO_HOST), "cufft_memcpyDToH pfor Error")
      else
        call c_f_pointer(ulibxt%descriptor, uxt)
        call c_f_pointer(uxt%data(1), u_d, local_rshape_out)
        call checkCuda(cudaMemcpy(u, u_d, product(int(local_rshape_out,kind=8))), "cudamemcpy D2H Error")
        nullify(u_d, uxt)
      endif
    endif

    if (data_format == CUFFT_XT_FORMAT_INPLACE) then
      if (ismemcpy == .false.) then
        call checkCufft(cufftXtMemcpy(planc2r, u_h, ulibxt, CUFFT_COPY_DEVICE_TO_HOST), "cufft_memcpyDToH pinv Error")
      else
        call c_f_pointer(ulibxt%descriptor, uxt)
        call c_f_pointer(uxt%data(1), u_d, local_rshape_in)
        call checkCufft(cudamemcpy(u, u_d, product(int(local_rshape_in,kind=8))), "cufft_memcpyD2H error")
        nullify(u_d, uxt)
      endif
    endif
end subroutine cufft_memcpyD2H

end program cufftmp_r2c_c2r_pencils