*DECK DSICS
      SUBROUTINE DSICS (N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D,
     +   R, IWARN)
C***BEGIN PROLOGUE  DSICS
C***PURPOSE  Incompl. Cholesky Decomposition Preconditioner SLAP Set Up.
C            Routine to generate the Incomplete Cholesky decomposition,
C            L*D*L-trans, of a symmetric positive definite matrix, A,
C            which is stored in SLAP Column format.  The unit lower
C            triangular matrix L is stored by rows, and the inverse of
C            the diagonal matrix D is stored.
C***LIBRARY   SLATEC (SLAP)
C***CATEGORY  D2E
C***TYPE      DOUBLE PRECISION (SSICS-S, DSICS-D)
C***KEYWORDS  INCOMPLETE CHOLESKY FACTORIZATION,
C             ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP SPARSE
C***AUTHOR  Greenbaum, Anne, (Courant Institute)
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-60
C             Livermore, CA 94550 (510) 423-3141
C             seager@llnl.gov
C***DESCRIPTION
C
C *Usage:
C     INTEGER N, NELT, IA(NELT), JA(NELT), ISYM
C     INTEGER NEL, IEL(NEL), JEL(NEL), IWARN
C     DOUBLE PRECISION A(NELT), EL(NEL), D(N), R(N)
C
C     CALL DSICS( N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D, R,
C    $    IWARN )
C
C *Arguments:
C N      :IN       Integer.
C         Order of the Matrix.
C NELT   :IN       Integer.
C         Number of elements in arrays IA, JA, and A.
C IA     :INOUT    Integer IA(NELT).
C JA     :INOUT    Integer JA(NELT).
C A      :INOUT    Double Precision A(NELT).
C         These arrays should hold the matrix A in the SLAP Column
C         format.  See "Description", below.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all non-zero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the lower
C         triangle of the matrix is stored.
C NEL    :OUT      Integer.
C         Number of non-zeros in the lower triangle of A.   Also
C         corresponds to the length of the IEL, JEL, EL arrays.
C IEL    :OUT      Integer IEL(NEL).
C JEL    :OUT      Integer JEL(NEL).
C EL     :OUT      Double Precision EL(NEL).
C         IEL, JEL, EL contain the unit lower triangular factor  of the
C         incomplete decomposition   of the A  matrix  stored  in  SLAP
C         Row format.   The Diagonal of   ones   *IS*   stored.     See
C         "Description", below for more details about the SLAP Row fmt.
C D      :OUT      Double Precision D(N)
C         Upon return this array holds D(I) = 1./DIAG(A).
C R      :WORK     Double Precision R(N).
C         Temporary double precision workspace needed for the
C         factorization.
C IWARN  :OUT      Integer.
C         This is a warning variable and is zero if the IC factoriza-
C         tion goes well.  It is set to the row index corresponding to
C         the last zero pivot found.  See "Description", below.
C
C *Description
C       =================== S L A P Column format ==================
C       This routine  requires that  the matrix A  be stored in  the
C       SLAP Column format.  In this format the non-zeros are stored
C       counting down columns (except for  the diagonal entry, which
C       must appear first in each  "column")  and are stored  in the
C       double precision array A.   In other words,  for each column
C       in the matrix put the diagonal entry in  A.  Then put in the
C       other non-zero  elements going down  the column (except  the
C       diagonal) in order.   The  IA array holds the  row index for
C       each non-zero.  The JA array holds the offsets  into the IA,
C       A arrays  for  the  beginning  of each   column.   That  is,
C       IA(JA(ICOL)),  A(JA(ICOL)) points   to the beginning  of the
C       ICOL-th   column    in    IA and   A.      IA(JA(ICOL+1)-1),
C       A(JA(ICOL+1)-1) points to  the  end of the   ICOL-th column.
C       Note that we always have  JA(N+1) = NELT+1,  where N is  the
C       number of columns in  the matrix and NELT  is the number  of
C       non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C           5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C                              1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       ==================== S L A P Row format ====================
C
C       This routine requires  that the matrix A  be  stored  in the
C       SLAP  Row format.   In this format  the non-zeros are stored
C       counting across  rows (except for the diagonal  entry, which
C       must  appear first  in each  "row")  and  are stored  in the
C       double precision  array A.  In other words, for each row  in
C       the matrix  put the diagonal  entry in A.   Then put in  the
C       other  non-zero elements  going across  the row  (except the
C       diagonal) in order.  The JA array holds the column index for
C       each non-zero.  The IA array holds the offsets  into the JA,
C       A  arrays  for  the   beginning  of  each  row.    That  is,
C       JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW-
C       th row in  JA and A,  and  JA(IA(IROW+1)-1), A(IA(IROW+1)-1)
C       are  the last elements  of the  IROW-th row.   Note  that we
C       always have  IA(N+1) = NELT+1, where N is the number of rows
C       in the matrix  and  NELT is the  number of non-zeros  in the
C       matrix.
C
C       Here is an example of the SLAP Row storage format for a  5x5
C       Matrix (in the A and JA arrays '|' denotes the end of a row):
C
C           5x5 Matrix         SLAP Row format for 5x5 matrix on left.
C                              1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53
C       |21 22  0  0  0|  JA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  IA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       With the SLAP  format some  of  the   "inner  loops" of this
C       routine should vectorize  on  machines with hardware support
C       for vector   gather/scatter  operations.  Your compiler  may
C       require a compiler directive to  convince it that  there are
C       no  implicit  vector  dependencies.  Compiler directives for
C       the Alliant    FX/Fortran and CRI   CFT/CFT77 compilers  are
C       supplied with the standard SLAP distribution.
C
C       The IC factorization does not always exist for SPD matrices.
C       In the event that a zero pivot is found it is set  to be 1.0
C       and the factorization proceeds.   The integer variable IWARN
C       is set to the last row where the Diagonal was fudged.  This
C       eventuality hardly ever occurs in practice.
C
C***SEE ALSO  DCG, DSICCG
C***REFERENCES  1. Gene Golub and Charles Van Loan, Matrix Computations,
C                  Johns Hopkins University Press, Baltimore, Maryland,
C                  1983.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   890404  DATE WRITTEN
C   890404  Previous REVISION DATE
C   890915  Made changes requested at July 1989 CML Meeting.  (MKS)
C   890922  Numerous changes to prologue to make closer to SLATEC
C           standard.  (FNF)
C   890929  Numerous changes to reduce SP/DP differences.  (FNF)
C   900805  Changed XERRWV calls to calls to XERMSG.  (RWC)
C   910411  Prologue converted to Version 4.0 format.  (BAB)
C   920511  Added complete declaration section.  (WRB)
C   920929  Corrected format of reference.  (FNF)
C   930701  Updated CATEGORY section.  (FNF, WRB)
C***END PROLOGUE  DSICS
C     .. Scalar Arguments ..
      INTEGER ISYM, IWARN, N, NEL, NELT
C     .. Array Arguments ..
      DOUBLE PRECISION A(NELT), D(N), EL(NEL), R(N)
      INTEGER IA(NELT), IEL(NEL), JA(NELT), JEL(NEL)
C     .. Local Scalars ..
      DOUBLE PRECISION ELTMP
      INTEGER I, IBGN, IC, ICBGN, ICEND, ICOL, IEND, IR, IRBGN, IREND,
     +        IROW, IRR, J, JBGN, JELTMP, JEND
      CHARACTER XERN1*8
C     .. External Subroutines ..
      EXTERNAL XERMSG
C***FIRST EXECUTABLE STATEMENT  DSICS
C
C         Set the lower triangle in IEL, JEL, EL
C
      IWARN = 0
C
C         All matrix elements stored in IA, JA, A.  Pick out the lower
C         triangle (making sure that the Diagonal of EL is one) and
C         store by rows.
C
      NEL = 1
      IEL(1) = 1
      JEL(1) = 1
      EL(1) = 1
      D(1) = A(1)
CVD$R NOCONCUR
      DO 30 IROW = 2, N
C         Put in the Diagonal.
         NEL = NEL + 1
         IEL(IROW) = NEL
         JEL(NEL) = IROW
         EL(NEL) = 1
         D(IROW) = A(JA(IROW))
C
C         Look in all the lower triangle columns for a matching row.
C         Since the matrix is symmetric, we can look across the
C         IROW-th row by looking down the IROW-th column (if it is
C         stored ISYM=0)...
         IF( ISYM.EQ.0 ) THEN
            ICBGN = JA(IROW)
            ICEND = JA(IROW+1)-1
         ELSE
            ICBGN = 1
            ICEND = IROW-1
         ENDIF
         DO 20 IC = ICBGN, ICEND
            IF( ISYM.EQ.0 ) THEN
               ICOL = IA(IC)
               IF( ICOL.GE.IROW ) GOTO 20
            ELSE
               ICOL = IC
            ENDIF
            JBGN = JA(ICOL)+1
            JEND = JA(ICOL+1)-1
            IF( JBGN.LE.JEND .AND. IA(JEND).GE.IROW ) THEN
CVD$ NOVECTOR
               DO 10 J = JBGN, JEND
                  IF( IA(J).EQ.IROW ) THEN
                     NEL = NEL + 1
                     JEL(NEL) = ICOL
                     EL(NEL)  = A(J)
                     GOTO 20
                  ENDIF
 10            CONTINUE
            ENDIF
 20      CONTINUE
 30   CONTINUE
      IEL(N+1) = NEL+1
C
C         Sort ROWS of lower triangle into descending order (count out
C         along rows out from Diagonal).
C
      DO 60 IROW = 2, N
         IBGN = IEL(IROW)+1
         IEND = IEL(IROW+1)-1
         IF( IBGN.LT.IEND ) THEN
            DO 50 I = IBGN, IEND-1
CVD$ NOVECTOR
               DO 40 J = I+1, IEND
                  IF( JEL(I).GT.JEL(J) ) THEN
                     JELTMP = JEL(J)
                     JEL(J) = JEL(I)
                     JEL(I) = JELTMP
                     ELTMP = EL(J)
                     EL(J) = EL(I)
                     EL(I) = ELTMP
                  ENDIF
 40            CONTINUE
 50         CONTINUE
         ENDIF
 60   CONTINUE
C
C         Perform the Incomplete Cholesky decomposition by looping
C         over the rows.
C         Scale the first column.  Use the structure of A to pick out
C         the rows with something in column 1.
C
      IRBGN = JA(1)+1
      IREND = JA(2)-1
      DO 65 IRR = IRBGN, IREND
         IR = IA(IRR)
C         Find the index into EL for EL(1,IR).
C         Hint: it's the second entry.
         I = IEL(IR)+1
         EL(I) = EL(I)/D(1)
 65   CONTINUE
C
      DO 110 IROW = 2, N
C
C         Update the IROW-th diagonal.
C
         DO 66 I = 1, IROW-1
            R(I) = 0
 66      CONTINUE
         IBGN = IEL(IROW)+1
         IEND = IEL(IROW+1)-1
         IF( IBGN.LE.IEND ) THEN
CLLL. OPTION ASSERT (NOHAZARD)
CDIR$ IVDEP
CVD$ NODEPCHK
            DO 70 I = IBGN, IEND
               R(JEL(I)) = EL(I)*D(JEL(I))
               D(IROW) = D(IROW) - EL(I)*R(JEL(I))
 70         CONTINUE
C
C         Check to see if we have a problem with the diagonal.
C
            IF( D(IROW).LE.0.0D0 ) THEN
               IF( IWARN.EQ.0 ) IWARN = IROW
               D(IROW) = 1
            ENDIF
         ENDIF
C
C         Update each EL(IROW+1:N,IROW), if there are any.
C         Use the structure of A to determine the Non-zero elements
C         of the IROW-th column of EL.
C
         IRBGN = JA(IROW)
         IREND = JA(IROW+1)-1
         DO 100 IRR = IRBGN, IREND
            IR = IA(IRR)
            IF( IR.LE.IROW ) GOTO 100
C         Find the index into EL for EL(IR,IROW)
            IBGN = IEL(IR)+1
            IEND = IEL(IR+1)-1
            IF( JEL(IBGN).GT.IROW ) GOTO 100
            DO 90 I = IBGN, IEND
               IF( JEL(I).EQ.IROW ) THEN
                  ICEND = IEND
 91               IF( JEL(ICEND).GE.IROW ) THEN
                     ICEND = ICEND - 1
                     GOTO 91
                  ENDIF
C         Sum up the EL(IR,1:IROW-1)*R(1:IROW-1) contributions.
CLLL. OPTION ASSERT (NOHAZARD)
CDIR$ IVDEP
CVD$ NODEPCHK
                  DO 80 IC = IBGN, ICEND
                     EL(I) = EL(I) - EL(IC)*R(JEL(IC))
 80               CONTINUE
                  EL(I) = EL(I)/D(IROW)
                  GOTO 100
               ENDIF
 90         CONTINUE
C
C         If we get here, we have real problems...
            WRITE (XERN1, '(I8)') IROW
            CALL XERMSG ('SLATEC', 'DSICS',
     $         'A and EL data structure mismatch in row '// XERN1, 1, 2)
 100     CONTINUE
 110  CONTINUE
C
C         Replace diagonals by their inverses.
C
CVD$ CONCUR
      DO 120 I =1, N
         D(I) = 1.0D0/D(I)
 120  CONTINUE
      RETURN
C------------- LAST LINE OF DSICS FOLLOWS ----------------------------
      END


      program prog
      parameter(n1=110, n2=120, n3=130)
      dimension field1(n1, n2, n3)
      dimension field2(n1, n2, n3)
      dimension field3(n1, n2, n3)
      dimension max_indices(3)
      jr = 0
      call set_random(jr, field1, n1*n2*n3)
      call set_random(jr, field2, n1*n2*n3)
      call set_random(jr, field3, n1*n2*n3)
      i = 0
      j = 0
      k = 0
      do iter=1,300
        i = mod(i + iter * 13, n1) + 1
        j = mod(j + iter * 17, n2) + 1
        k = mod(k + iter * 19, n3) + 1
        field1(i,j,k) = field2(i,j,k) * -1.3
        call find_max_sq(max_indices,
     &    field1, field2, field3, n1, n2, n3)
      enddo
      write(6, *) max_indices
      end

      subroutine set_random(jr, a, n)
      dimension a(*)
      do i=1,n
        jr = mod(jr*1366+150889, 714025)
        a(i) = (mod(jr, 20000) - 10000) / 10000.0
      enddo
      end

      subroutine find_max_sq(max_indices,
     &  field1, field2, field3, n1, n2, n3)
      dimension max_indices(3)
      dimension field1(n1, n2, n3)
      dimension field2(n1, n2, n3)
      dimension field3(n1, n2, n3)
      max_f = 0
      do k=1,n3
        do j=1,n2
          do i=1,n1
            f = ((field1(i,j,k) - field2(i,j,k)) * field3(i,j,k))**2
            if (max_f .lt. f) then
              max_f = f
              max_indices(1) = i
              max_indices(2) = j
              max_indices(3) = k
            endif
          enddo
        enddo
      enddo
      end


!----------------------------------------
      subroutine smoothtwicewithA(msk,A,x,b,coef,m,n,yo)

! compute
!        z=x+(A*x-b)*coef
!        y=z+(A*z-b)*coef
! using a buffer technique that
! minimizes memory access
!
! result is only valid in (i,j)=(3..n-2)x(3..n-2)
! need to have a halo width of 2 to be working

      implicit none

      integer,intent(in):: n,m
      integer*1,dimension(m,n) :: msk
      real*8,dimension(m,n,5) :: A
!      real*8,dimension(m,n) :: D
      real*8,dimension(m,n) :: b
      real*8,dimension(m,n) :: x
      real*8,intent(in):: coef

!f2py intent(inplace)::msk,R,D,b,yo
!f2py intent(inplace)::x

      real*8,dimension(3,n) :: yo
!      real*8,dimension(n,2) :: bo
      integer:: i,j,k,jm,km,ko,kp,lm,lo,lp,jo,jmo,jmm,im,ip,jp
!      real*8::w
      integer*1::s

      real*8::c1,c2,c3

!      xo(:,1)=x(1,:)
!      xo(:,2)=x(2,:)
!      bo(:,1)=b(1,:)

!      km=1
!      ko=2
!      kp=3

      lm=1
      lo=2
      lp=3

      c1=coef
      c2=1.-c1

      do i=1,n
	yo(lo,i)=x(1,i)
      enddo

      do j=2,m-1
         ! read x from the memory and store it into xo
!         xo(:,kp)=x(j+1,:)
!         bo(:,jo)=b(j,:)
         jm=j-1
         jp=j+1
         yo(lo,1)=x(j-1,1)
	 yo(lp,1)=x(j,1)
!	 yo(lp,n)=x(j,n)
         do i=2,n-1
            ip=i+1
            im=i-1
            ! compute the inner yo=A*x at row j
            if (msk(j,i).ne.0)then
               c3=c1/abs(A(j,i,5))
            yo(lp,i)= x(j,i)*c2 + c3*(
     $           +A(j,i,1)*x(j-1,i-1)
     $           +A(j,i,2)*x(j-1,i  )
     $           +A(j,i,3)*x(j-1,i+1)
     $           +A(j,i,4)*x(j,i-1)
!     $           +A(j,i,5)*x(j,i  )
     $           +A(j,ip,4)*x(j,ip)
     $           +A(jp,im,3)*x(jp,im)
     $           +A(jp,i,2)*x(jp,i  )
     $           +A(jp,ip,1)*x(jp,ip)
!!$     $           +A(j,i,6)*x(j,i+1)
!!$     $           +A(j,i,7)*x(j+1,i-1)
!!$     $           +A(j,i,8)*x(j+1,i  )
!!$     $           +A(j,i,9)*x(j+1,i+1)
     $           -b(j,i) )
             else
                yo(lp,i)=0.
             endif
         enddo
!	 yo(lp,n)=x(j,n)
         jmm=jm-1
!	 x(jmm,2)=yo(lm,2)
!	 x(jmm,n-1)=yo(lm,n-1)
!	 x(jm,2)=yo(lo,2)
         if (jm.ge.3) then
             x(jmm,2)=yo(lm,2)
             x(jmm,n-1)=yo(lm,n-1)
             x(jm,2)=yo(lo,2)
            do i=3,n-2
               ip=i+1
               im=i-1
               ! yo is known at row j-2,j-1,j
               ! so we can compute y=A*yo at row jm=j-1
               if (msk(jm,i).ne.0)then

               c3=c1/abs(A(jm,i,5))
               x(jm,i)= yo(lo,i  )*c2 + c3*(
     $           +A(jm,i,1)*yo(lm,i-1)
     $           +A(jm,i,2)*yo(lm,i  )
     $           +A(jm,i,3)*yo(lm,i+1)
     $           +A(jm,i,4)*yo(lo,i-1)
     $           +A(jm,ip,4)*yo(lo,ip )
     $           +A(j,im,3) *yo(lp,im )
     $           +A(j,i,2)  *yo(lp,i   )
     $           +A(j,ip,1) *yo(lp,ip )
     $           -b(jm,i) )
               else
                  x(jm,i)=0.
               endif
              enddo
          endif
         ! swap the buffers by permuting the indices

         lm=mod(lm,3)+1
         lo=mod(lo,3)+1
         lp=mod(lp,3)+1

      enddo

      end subroutine

!----------------------------------------
      subroutine smoothoncewithA(msk,A,x,b,coef,m,n,yo)

! compute
!        z=x+(A*x-b)*coef
!        y=z+(A*z-b)*coef
! using a buffer technique that
! minimizes memory access
!
! result is only valid in (i,j)=(3..n-2)x(3..n-2)
! need to have a halo width of 2 to be working

      implicit none

      integer,intent(in):: n,m
      integer*1,dimension(m,n) :: msk
      real*8,dimension(m,n,5) :: A
!      real*8,dimension(m,n) :: D
      real*8,dimension(m,n) :: b
      real*8,dimension(m,n) :: x
      real*8,intent(in):: coef

!f2py intent(inplace)::msk,R,D,b,yo
!f2py intent(inplace)::x

      real*8,dimension(3,n) :: yo
!      real*8,dimension(n,2) :: bo
      integer:: i,j,k,jm,km,ko,kp,lm,lo,lp,jo,jmo,jmm,im,ip,jp
!      real*8::w
      integer*1::s

      real*8::c1,c2,c3

!      xo(:,1)=x(1,:)
!      xo(:,2)=x(2,:)
!      bo(:,1)=b(1,:)

!      km=1
!      ko=2
!      kp=3

      lm=1
      lo=2
      lp=3

      c1=coef
      c2=1.-c1

!      do i=1,n
!	yo(lo,i)=x(1,i)
!      enddo

      do j=2,m-1
         ! read x from the memory and store it into xo
!         xo(:,kp)=x(j+1,:)
!         bo(:,jo)=b(j,:)
         jm=j-1
         jp=j+1
!         yo(lo,1)=x(j-1,1)
!	 yo(lp,1)=x(j,1)
!	 yo(lp,n)=x(j,n)
         do i=2,n-1
            ip=i+1
            im=i-1
            ! compute the inner yo=A*x at row j
            if (msk(j,i).ne.0)then
               c3=c1/abs(A(j,i,5))
            x(j,i)= x(j,i)*c2 + c3*(
     $           +A(j,i,1)*x(jm,im)!x(j-1,i-1)
     $           +A(j,i,2)*x(jm,i)!x(j-1,i  )
     $           +A(j,i,3)*x(jm,ip)!x(j-1,i+1)
     $           +A(j,i,4)*x(j,im)!x(j,i-1)
     $           +A(j,ip,4)*x(j,ip)
     $           +A(jp,im,3)*x(jp,im)
     $           +A(jp,i,2)*x(jp,i  )
     $           +A(jp,ip,1)*x(jp,ip)
     $           -b(j,i) )
             else
                x(j,i)=0.
             endif
         enddo
      enddo

      end subroutine

!----------------------------------------
      subroutine smoothtridiag(msk,A,x,b,m,n)

! compute
!        y=V^{-1}*(b-H*x)
! where
! Laplacian = V+H
! V is the vertical part (including the diagonal term)
!

      implicit none

      integer,intent(in):: n,m
      integer*1,dimension(m,n) :: msk
      real*8,dimension(m,n,5) :: A
!      real*8,dimension(m,n) :: D
      real*8,dimension(m,n) :: b
      real*8,dimension(m,n) :: x

!f2py intent(inplace)::msk,b
!f2py intent(inplace)::x

      real*8,dimension(m) :: y,d,ud,rhs

      integer:: i,j,im,ip,jm,jp

      do i=2,n-1
         ip=i+1
         im=i-1
         ! here we assume a halo width = 3
         ! since psi(j,i) is on the (top right) corner
         ! of cell (j,i)
         ! the bottom bry is x(4,:)=0
         ! the top    bry is x(m-3,:)=0
         ! the tridiagonal inversion is done
         ! on interior points 4 <= j <= m-4
         ! watch out Fortran starts with index 1...
         ! whereas Python starts with index 0
         if(msk(4,i).ne.0) then
         y(:)=0.
         do j=4,m-4
            jm=j-1
            jp=j+1

! y = b - A*x reads
!!$            y(j,i)=b(j,i)
!!$     $           -A(j,i,1)*x(j-1,i-1)
!!$     $           -A(j,i,2)*x(j-1,i  )
!!$     $           -A(j,i,3)*x(j-1,i+1)
!!$     $           -A(j,i,4)*x(j,i-1)
!!$     $           -A(j,i,5)*x(j,i  )
!!$     $           -A(j,i+1,4)*x(j,i+1)
!!$     $           -A(j+1,i-1,3)*x(j+1,i-1)
!!$     $           -A(j+1,i,2)*x(j+1,i  )
!!$     $           -A(j+1,i+1,1)*x(j+1,i+1)

            rhs(j)= b(j,i)
     $       -A(j,i,1)*x(jm,im)
     $       -A(j,i,3)*x(jm,ip)
     $       -A(j,i,4)*x(j,im)
     $       -A(j,ip,4)*x(j,ip)
     $       -A(jp,im,3)*x(jp,im)
     $       -A(jp,ip,1)*x(jp,ip)

            d(j) = A(j,i,5)
            ud(j) = A(jp,i,2)
         enddo
         call tridiag(d,ud,rhs,y,m)
         do j=4,m-4
            x(j,i)=y(j)
         enddo
         endif
      enddo

      end subroutine
!----------------------------------------
      subroutine tridiag(d,dd,b,xc,l)
        !     Axc = b
        !     Solve tridiagonal system
        implicit none
        integer,intent(in)  :: l
        real*8,dimension(l) :: d,b
        real*8,dimension(l) :: dd
        real*8,dimension(l) :: xc

!f2py intent(inplace)::d,dd,b,xc

        integer:: k,k0
        real*8,dimension(l):: gam
        real*8             :: bet

        k0 = 4
        bet   = 1. / d(k0)
        xc(k0) = b(k0)*bet
        do k=k0+1,l-4
           gam(k)= dd(k-1)*bet
           bet     = 1. /(d(k)-dd(k-1)*gam(k))
           xc(k) = (b(k)-dd(k-1)*xc(k-1))*bet
        enddo
        do k=l-5,k0,-1
           xc(k) = xc(k)-gam(k+1)*xc(k+1)
        enddo

      end subroutine tridiag

!----------------------------------------
      subroutine computeresidualwithA(msk,A,x,b,y,m,n)

! compute y=b-A*x

      implicit none

      integer,intent(in):: n,m
      integer*1,dimension(m,n) :: msk
      real*8,dimension(m,n,5) :: A
      real*8,dimension(m,n) :: x,b
      real*8,dimension(m,n) :: y

!f2py intent(inplace)::msk,A,x,b
!f2py intent(inplace)::y

!      real*8,dimension(n,3) :: xo
      integer:: i,j,km,ko,kp

      do j=2,m-1
         do i=2,n-1
            if(msk(j,i).ne.0)then
            y(j,i)=b(j,i)
     $           -A(j,i,1)*x(j-1,i-1)
     $           -A(j,i,2)*x(j-1,i  )
     $           -A(j,i,3)*x(j-1,i+1)
     $           -A(j,i,4)*x(j,i-1)
     $           -A(j,i,5)*x(j,i  )
     $           -A(j,i+1,4)*x(j,i+1)
     $           -A(j+1,i-1,3)*x(j+1,i-1)
     $           -A(j+1,i,2)*x(j+1,i  )
     $           -A(j+1,i+1,1)*x(j+1,i+1)
!!$     $           -A(j,i,6)*x(j,i+1)
!!$     $           -A(j,i,7)*x(j+1,i-1)
!!$     $           -A(j,i,8)*x(j+1,i  )
!!$     $           -A(j,i,9)*x(j+1,i+1)
             else
                y(j,i)=0.
             endif
         enddo
      enddo

      end subroutine

!----------------------------------------
      subroutine fillhalo(x,nh,m,n)

! compute y=sum(x*x)

      implicit none

      integer,intent(in):: n,m,nh
      real*8,dimension(m,n) :: x

!f2py intent(inplace)::x

      integer:: i,j,jj,n2,m2

      n2=n-2*nh
      m2=m-2*nh
      do j=1,nh
         do i=1,nh
            x(j,i)=x(m2+j,n2+i)
         enddo
         do i=1,n2
            x(j,i+nh)=x(m2+j,i+nh)
         enddo
         do i=1,nh
            x(j,i+n-nh)=x(m2+j,nh+i)
         enddo
      enddo
      do j=1,m2
         jj=j+nh
         do i=1,nh
            x(jj,i)=x(jj,n2+i)
            x(jj,i+n-nh)=x(jj,i+nh)
         enddo
      enddo
      do j=1,nh
         jj=j+m2+nh
         do i=1,nh
            x(jj,i)=x(j+nh,n2+i)
         enddo
         do i=1,n-2*nh
            x(jj,i+nh)=x(j+nh,i+nh)
         enddo
         do i=1,nh
            x(jj,i+n-nh)=x(j+nh,i+nh)
         enddo
      enddo

      end subroutine

!----------------------------------------
      subroutine interpolate(msk1,msk2,x2,nh,n2,m2,n1,m1,x1)

! compute x1=I*x2 where x2 is on the coarse grid, x1 is on the fine grid

      implicit none

      integer,intent(in):: n1,m1,n2,m2,nh
      integer*1,dimension(m1,n1) :: msk1
      integer*1,dimension(m2,n2) :: msk2
      real*8,dimension(m2,n2) :: x2
      real*8,dimension(m1,n1) :: x1

!f2py intent(inplace)::x2,msk1,msk2
!f2py intent(inplace)::x1

!      real*8,dimension(n2,2) :: xo
      integer:: i1,j1,i2,j2,ko,kp
      real*8,dimension(0:1)::c1
      real*8,dimension(0:2)::c2
      real*8,dimension(0:4)::c3
      integer*1::s

      data c1/0.,1./
      data c2/0.,1.,0.5/
      data c3/0.,1.,0.5,0.3333333333333333333333333333,0.25/

!!$      data c1/0.,1./
!!$      data c2/0.,0.5,0.5/
!!$      data c3/0.,0.25,0.25,0.25,0.25/

!      xo(:,1)=x2(2,:)
      ko=1
      kp=2
!      j1=nh
      if (nh.eq.2)j1=2
      if (nh.eq.3)j1=1
      ! mapping is (i1,j1)=(2,2) coincides with (i2,j2)=(2,2)

!      do j2=nh,m2-nh
      do j2=2,m2-2
!         i1=nh
         if (nh.eq.2)i1=2
         if (nh.eq.3)i1=1
!         xo(:,kp)=x2(j2+1,:)
!         x1(j1,:)=0.
!         x1(j1+1,:)=0.
!         do i2=nh,n2-nh
         do i2=2,n2-2
            !s=msk2(j2,i2)
            if (msk1(j1,i1).gt.0)then
               x1(j1,i1) = x2(j2,i2)
            else
               x1(j1,i1) = 0.
            endif

            if (msk1(j1,i1+1).gt.0) then
               s=msk2(j2,i2)+msk2(j2,i2+1)
               x1(j1,i1+1) = (x2(j2,i2)+x2(j2,i2+1))*c2(s)!*c2(s)!*0.5!*msk1(j1,i1+1)*c2(s)
            else
               x1(j1,i1+1) = 0.
            endif

            if (msk1(j1+1,i1).gt.0) then
               s=msk2(j2,i2)+msk2(j2+1,i2)
               x1(j1+1,i1) = (x2(j2,i2)+x2(j2+1,i2))*c2(s)!*0.5!msk1(j1+1,i1)*c2(s)
            else
               x1(j1+1,i1) = 0.
            endif

            if (msk1(j1+1,i1+1).gt.0) then
               s=msk2(j2,i2)+msk2(j2,i2+1)+msk2(j2+1,i2)+msk2(j2+1,i2+1)
               x1(j1+1,i1+1) = c3(s)*(x2(j2,i2)+x2(j2,i2+1)
     $                     +x2(j2+1,i2)+x2(j2+1,i2+1))!*msk1(j1+1,i1+1)
             else
                x1(j1+1,i1+1) = 0.
             endif
               i1=i1+2
         enddo
         j1=j1+2
!         ko=mod(ko,2)+1
!         kp=mod(kp,2)+1
      enddo

      end subroutine

!----------------------------------------
      subroutine restrict(msk2,x1,nh,n2,m2,n1,m1,x2)

! compute x1=I*x2 where x2 is on the coarse grid, x1 is on the fine grid

      implicit none

      integer,intent(in):: n1,m1,n2,m2,nh
      integer*1,dimension(m2,n2) :: msk2
      real*8,dimension(m2,n2) :: x2
      real*8,dimension(m1,n1) :: x1

!f2py intent(inplace)::x1,msk2
!f2py intent(inplace)::x2

!      real*8,dimension(n1,3) :: xo
      integer:: i1,j1,i2,j2,km,ko,kp
      real*8:: w

      km=1
      ko=2
      kp=3
      j1=nh
!      xo(:,1)=x1(j1-1,:)
      ! mapping is (i1,j1)=(2,2) coincides with (i2,j2)=(2,2)
      do j2=nh,m2-nh
         i1=nh
!         xo(:,km)=x1(j1-1,:)
!         xo(:,ko)=x1(j1,:)
!         xo(:,kp)=x1(j1+1,:)
         do i2=nh,n2-nh
            if(msk2(j2,i2).ne.0)then
               x2(j2,i2) = 0.25*x1(j1,i1)
     $ +0.125 *(x1(j1  ,i1-1)+x1(j1  ,i1+1)+x1(j1-1,i1)  +x1(j1+1,i1)  )
     $ +0.0625*(x1(j1-1,i1-1)+x1(j1-1,i1+1)+x1(j1+1,i1-1)+x1(j1+1,i1+1))
            else
              x2(j2,i2) = 0.
           endif
            i1=i1+2
         enddo
         j1=j1+2
         ! km=mod(km+1,3)+1
         ! ko=mod(ko+1,3)+1
         ! kp=mod(kp+1,3)+1
      enddo

      end subroutine

!----------------------------------------
      subroutine halotobuffer(x,b0,b1,b2,b3,b4,b5,b6,b7,nh,n,m,n2,m2)

! copy halo of array x into buffers
! x is assumed in 2D shape, Fortran order

      implicit none

      integer,intent(in):: n,m,nh,n2,m2
      real*8,dimension(m,n) :: x
      ! inout is important because buffers are preallocated
      real*8,dimension(nh,nh) :: b0,b2,b5,b7
      real*8,dimension(nh,n2) :: b1,b6
      real*8,dimension(m2,nh) :: b3,b4

!f2py intent(inplace,c)::b0,b2,b5,b7
!f2py intent(inplace,c)::b1,b6
!f2py intent(inplace,c)::b3,b4
!f2py intent(inplace)::x

      integer:: i,j,jj

      do j=1,nh
         do i=1,nh
            b0(j,i)=x(j+nh,i+nh)
         enddo
      enddo
      do j=1,nh
         do i=1,n2
            b1(j,i)=x(j+nh,i+nh)
         enddo
      enddo
      do j=1,nh
         do i=1,nh
            b2(j,i)=x(j+nh,i+n2)
         enddo
      enddo
      do j=1,m2
         jj=j+nh
         do i=1,nh
            b3(j,i)=x(jj,i+nh)
         enddo
      enddo
      do j=1,m2
         jj=j+nh
         do i=1,nh
            b4(j,i)=x(jj,i+n2)
         enddo
      enddo
      do j=1,nh
         jj=j+m2
         do i=1,nh
            b5(j,i)=x(jj,i+nh)
         enddo
      enddo
      do j=1,nh
         jj=j+m2
         do i=1,n-2*nh
            b6(j,i)=x(jj,i+nh)
         enddo
      enddo
      do j=1,nh
         jj=j+m2
         do i=1,nh
            b7(j,i)=x(jj,i+n-2*nh)
         enddo
      enddo

      end subroutine

!----------------------------------------
      subroutine buffertohalo(x,b0,b1,b2,b3,b4,b5,b6,b7,nh,n,m,n2,m2)

! copy halo of array x into buffers
! x is assumed in 2D shape, Fortran order

      implicit none

      integer,intent(in):: n,m,nh,n2,m2
      real*8,dimension(m,n) :: x
      ! inout is important because buffers are preallocated
      real*8,dimension(nh,nh) :: b0,b2,b5,b7
      real*8,dimension(nh,n2) :: b1,b6
      real*8,dimension(m2,nh) :: b3,b4

!f2py intent(inplace,c)::b0,b1,b2,b3,b4,b5,b6,b7
!f2py intent(inplace)::x

      integer:: i,j,jj

      do j=1,nh
         do i=1,nh
            x(j,i)=b7(j,i)
         enddo
         do i=1,n-2*nh
            x(j,i+nh)=b6(j,i)
         enddo
         do i=1,nh
            x(j,i+n-nh)=b5(j,i)
         enddo
      enddo

      do j=1,m2
         jj=j+nh
         do i=1,nh
            x(jj,i)=b4(j,i)
            x(jj,i+n-nh)=b3(j,i)
         enddo
      enddo
      do j=1,nh
         jj=j+m-nh
         do i=1,nh
            x(jj,i)=b2(j,i)
         enddo
         do i=1,n2
            x(jj,i+nh)=b1(j,i)
         enddo
         do i=1,nh
            x(jj,i+n-nh)=b0(j,i)
         enddo
      enddo

      end subroutine

!----------------------------------------
      subroutine buffertodomain(b,x,nh,m1,n1,m,n,mp,np)

! copy buffer

      implicit none

      integer,intent(in):: n1,m1,n,m,nh,np,mp
!      real*8,dimension(2*nh+np*(n-2*nh),2*nh+mp*(m-2*nh)),intent(out) :: x
      real*8,dimension(m1,n1) :: x
      real*8,dimension(mp,np,m,n) :: b

!f2py intent(inplace)::b
!f2py intent(inplace)::x

      integer:: i,j,k,l,ii,jj

      do l=1,mp
         jj=1+(l-1)*(m-2*nh)
         do j=1,m
            do k=1,np
               ii=1+(k-1)*(n-2*nh)
               do i=1,n
                  x(jj,ii) = b(l,k,j,i)
                  ii=ii+1
               enddo
            enddo
            jj=jj+1
         enddo
      enddo

      end subroutine

!----------------------------------------
      subroutine coarsenmatrix(Afine,Acoarse,msk1,msk2,nh,n1,m1,n2,m2)

! compute the matrix A on the coarse grid

      implicit none

      integer,intent(in):: n1,m1,n2,m2,nh
!      real*8,dimension(2*nh+np*(n-2*nh),2*nh+mp*(m-2*nh)),intent(out) :: x
      real*8,dimension(m2,n2,9) :: Acoarse
      real*8,dimension(m1,n1,9) :: Afine
      integer*1,dimension(m1,n1):: msk1
      integer*1,dimension(m2,n2):: msk2

!f2py intent(out)::Acoarse
!f2py intent(in)::Afine,msk1,msk2

      real*8::w
      real*8,dimension(-1:1,-1:1)::coef,z3
      real*8,dimension(-2:2,-2:2)::z5
      real*8,dimension(0:3):: w2
      integer:: i,j,k,l
      integer::i1,j1,i2,j2,ii,jj,di2,dj2
      integer::ki,kj

      integer::loc,m

      data coef/0.125,0.25,0.125,0.25,0.5,0.25,0.125,0.25,0.125/
      data w2/1,0.5,0.5,0.25/

      do j2=nh,m2-nh
         do i2=nh,n2-nh
            if(msk2(j2,i2).eq.1)then
            do l=1,9 ! loop on each 9 points to be connected with
               ! (i2,j2) location on the coarse grid
               ! (i1,j1) location on the fine grid
               i1= 2*(i2-nh)+nh
               j1= 2*(j2-nh)+nh
               !
               di2=mod(l-1,3)-1
               dj2=   (l-1)/3-1
               ! fill the 5x5 matrix (interpolation phase)
               z5(:,:)=0.
               do kj=-1,1
                  do ki=-1,1
                     i=2*di2+ki
                     j=2*dj2+kj
                     if ((abs(i).le.2).and.(abs(j).le.2))then
                     loc=mod(i+2,2)+mod(j+2,2)*2
!                     write(*,*)i,j,loc
                       if (msk1(j1+j,i1+i).eq.1)
     $                   z5(i,j)=2.*coef(ki,kj)
!                        z5(i,j)=2.*coef(ki,kj)
                        if(msk1(j1+j,i1+i).eq.1)then
                           if(loc.eq.0)
     $       m=msk2(j2+dj2,i2+di2)
                           if(loc.eq.1)
     $       m=(msk2(j2+dj2,i2+di2)+msk2(j2+dj2,i2+di2+1))
                           if(loc.eq.2)
     $       m=(msk2(j2+dj2,i2+di2)+msk2(j2+dj2+1,i2+di2))
                           if(loc.eq.3)
     $       m=(msk2(j2+dj2  ,i2+di2)+msk2(j2+dj2  ,i2+di2+1)
     $         +msk2(j2+dj2+1,i2+di2)+msk2(j2+dj2+1,i2+di2+1))
!                          if(m.gt.0) z5(i,j)=1./m
!                          z5(i,j)=w2(loc)!*msk2(j2+dj2,i2+di2)
!                          m=m-1./w2(loc)
!                          if(m.ne.0)write(*,*)i1,j1,m
                        endif
                     endif
                  enddo
               enddo
               ! compute the laplacian on the 3x3 matrix
               z3(:,:)=0.
               do jj=-1,1
                  do ii=-1,1
                     do kj=-1,1
                        do ki=-1,1
                           k=1+(ki+1)+(kj+1)*3
!                           if((i1+ii+ki.gt.0).and.(j1+jj+kj.gt.0))
                           if(msk1(j1+jj,i1+ii).eq.1)
     $                     z3(ii,jj) = z3(ii,jj)
     $                    + Afine(j1+jj,i1+ii,k)*z5(ii+ki,jj+kj)
                        enddo
                     enddo
                  enddo
               enddo
               ! now do the restriction using the 3x3 matrix
               w=0.
               if (msk2(j2,i2).ne.0) then
                  do jj=-1,1
                     do ii=-1,1
                        w = w + 0.5*coef(ii,jj)*z3(ii,jj)
                     enddo
                  enddo
               endif
               Acoarse(j2,i2,l) = w
            enddo
            else
               do l=1,9
                  Acoarse(j2,i2,l) = 0.
               enddo
            endif
         enddo
      enddo

      end subroutine
!----------------------------------------
      subroutine computenorm(msk,x,nh,n,m,y)

! compute y=sum(x*x)
!

      implicit none

      integer,intent(in):: n,m,nh
      integer*1,dimension(m,n) :: msk
      real*8,dimension(m,n) :: x
      real*8,intent(out) :: y

!f2py intent(inplace)::x,msk
!f2py intent(out)::y

      integer:: i,j

      y=0.
      do j=nh+1,m-nh
         do i=nh+1,n-nh
            if(msk(j,i).ne.0)then
               y = y + x(j,i)**2
            endif
         enddo
      enddo

      end subroutine
!----------------------------------------
      subroutine computeinner(msk,x,y,nh,n,m,z)

! compute z=sum(x*y)
!

      implicit none

      integer,intent(in):: n,m,nh
      integer*1,dimension(m,n) :: msk
      real*8,dimension(m,n) :: x,y
      real*8,intent(out) :: z

!f2py intent(inplace)::x,y,msk
!f2py intent(out)::z

      integer:: i,j

      z=0.
      do j=nh+1,m-nh
         do i=nh+1,n-nh
            if(msk(j,i).ne.0)then
               z = z + x(j,i)*y(j,i)
            endif
         enddo
      enddo

      end subroutine


! ###################################################################
! Copyright (c) 2016-2022, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

module MODQuaternionsTest
  !! author: MDG
  !! version: 1.0
  !! date: 01/05/20
  !!
  !! perform a series of unit tests on the quaternion module
  !!
  !! TODO: add test for quaternion slerp ?

contains

subroutine MODQuaternionsExecuteTest(res) &
           bind(c, name='MODQuaternionsExecuteTest')    ! this routine is callable from a C/C++ program
!DEC$ ATTRIBUTES DLLEXPORT :: MODQuaternionsExecuteTest

use,INTRINSIC :: ISO_C_BINDING
use mod_kinds
use mod_quaternions

IMPLICIT NONE

integer(C_INT32_T),INTENT(OUT)  :: res

type(Quaternion_T)      :: u, v, w
real(kind=dbl)          :: x, a=2.D0, diffd, dd(4)
real(kind=sgl)          :: y, b=2.0, diff, d(4)

type(QuaternionArray_T) :: uA, vA, wA

! threshold values
real(kind=dbl),parameter:: epsd = 1.0D-12
real(kind=sgl),parameter:: eps  = 1.0E-7

! various parameters
integer(kind=irg)       :: i, errcnt

!===================================================
! set the reference values (verified with Mathematica scripts)

! correct answers for the Quaternion_T class
type(Quaternion_T) :: resdzero
type(Quaternion_T) :: resdupv
type(Quaternion_T) :: resdumv
type(Quaternion_T) :: resduta
type(Quaternion_T) :: resdutv
type(Quaternion_T) :: resduc
type(Quaternion_T) :: resdudv
real(kind=dbl), parameter  :: absvald = 5.477225575051661D0
real(kind=dbl),parameter   :: ipd = 70.D0
real(kind=dbl),parameter   :: qand = 0.25019592042251176D0
real(kind=dbl)             :: vecd(3) = (/ 1.D0, 0.D0, 0.D0 /), rvecd(3)
real(kind=dbl)             :: rvecarrd(3,4)

type(Quaternion_T) :: resszero
type(Quaternion_T) :: ressupv
type(Quaternion_T) :: ressumv
type(Quaternion_T) :: ressuta
type(Quaternion_T) :: ressutv
type(Quaternion_T) :: ressuc
type(Quaternion_T) :: ressudv
real(kind=sgl), parameter  :: absvals = 5.4772256
real(kind=sgl),parameter   :: ips = 70.0
real(kind=sgl),parameter   :: qans = 0.2501958
real(kind=sgl)             :: vecs(3) = (/ 1.0, 0.0, 0.0 /), rvecs(3)
real(kind=sgl)             :: rvecarrs(3,4)

resdzero = Quaternion_T( qd = (/ 0.D0, 0.D0, 0.D0, 0.D0/) )
resdupv  = Quaternion_T( qd = (/ 6.D0, 8.D0, 10.D0, 12.D0/) )
resdumv  = Quaternion_T( qd = (/-4.D0, -4.D0, -4.D0, -4.D0/) )
resduta  = Quaternion_T( qd = (/2.D0, 4.D0, 6.D0, 8.D0/) )
resdutv  = Quaternion_T( qd = (/-60.D0, 12.D0, 30.D0, 24.D0/) )
resduc   = Quaternion_T( qd = (/1.D0,-2.D0,-3.D0,-4.D0/) )
resdudv  = Quaternion_T( qd = (/0.40229885057471D0, 0.045977011494252D0, 0.D0, 0.09195402298850575D0/) )

resszero = Quaternion_T( q = (/ 0.0, 0.0, 0.0, 0.0/))
ressupv  = Quaternion_T( q = (/6.0, 8.0, 10.0, 12.0/) )
ressumv  = Quaternion_T( q = (/-4.0, -4.0, -4.0, -4.0/) )
ressuta  = Quaternion_T( q = (/2.0, 4.0, 6.0, 8.0/) )
ressutv  = Quaternion_T( q = (/-60.0, 12.0, 30.0, 24.0/) )
ressuc   = Quaternion_T( q = (/1.0,-2.0,-3.0,-4.0/) )
ressudv  = Quaternion_T( q = (/0.40229885, 0.045977011, 0.0, 0.091954023/) )

! correct answers for the QuaternionArray_T class
! type(QuaternionArray_T) :: resarrdadd

! resarrdadd = QuaternionArray_T( n=4, )

! initialize the error identifier to zero (should remain zero upon successful exit)
res = 0

!===================================================
!=============Double Precision Tests================
!===================================================

!===================================================
! initialize zero quaternion
u = Quaternion_T( qd = (/0.D0, 0.D0, 0.D0, 0.D0/) )
diffd = cabs(u)
if (diffd.gt.epsd) then
  res = 1
  write (*,"('double precision zero initialization test failed = ',D18.10)") diff
  return
end if

if (.not.(u%quatsequal(resdzero))) then
  res = 2
  write (*,"('double precision zero comparison test failed = ',D18.10)") diff
  return
end if

! arithmetic tests
! ! u = Quaternion_T( qd=(/ 1.D0,2.D0,3.D0,4.D0/) )
! v = Quaternion_T( qd=(/ 5.D0,6.D0,7.D0,8.D0/) )
u = Quaternion_T( qd=(/ 1.0_dbl,2.0_dbl,3.0_dbl,4.0_dbl/) )
v = Quaternion_T( qd=(/ 5.0_dbl,6.0_dbl,7.0_dbl,8.0_dbl/) )

w = u+v
if (.not.(w%quatsequal(resdupv))) then
  res = 3
  write (*,"('double precision addition test failed = ')")
  return
end if

w = u-v
if (.not.(w%quatsequal(resdumv))) then
  res = 4
  write (*,"('double precision subtraction test failed = ')")
  return
end if

w = u*a
if (.not.(w%quatsequal(resduta))) then
  res = 5
  write (*,"('double precision scalar multiplication test failed = ')")
  return
end if

w = u*v
if (.not.(w%quatsequal(resdutv))) then
  res = 6
  write (*,"('double precision quaternion multiplication test failed = ')")
  return
end if

w = u/v
if (.not.(w%quatsequal(resdudv))) then
  res = 7
  write (*,"('double precision division test failed = ')")
  return
end if

w = conjg(u)
if (.not.(w%quatsequal(resduc))) then
  res = 8
  write (*,"('double precision conjugation test failed = ')")
  return
end if

diffd = abs(cabs(u) - absvald)
if (diffd.gt.epsd) then
  res = 9
  write (*,"('double precision norm test failed = ',D18.10)") diffd
  return
end if

diffd = abs(u%quat_innerproduct(v) - ipd)
if (diffd.gt.epsd) then
  res = 10
  write (*,"('double precision innerproduct test failed = ',D18.10)") diffd
  return
end if

diffd = abs(u%quat_angle(v) - qand)
if (diffd.gt.epsd) then
  res = 11
  write (*,"('double precision quaternion angle test failed = ',D18.10)") diffd
  return
end if

! from here on we work with unit quaternions
call u%quat_normalize()
diffd = abs(cabs(u) - 1.D0)
if (diffd.gt.epsd) then
  res = 12
  write (*,"('double precision normalization test failed = ',D18.10)") diffd
  return
end if

! make u a rotation of 120° around the [111] axis
u = Quaternion_T( qd=(/ 0.5_dbl, 0.5_dbl, 0.5_dbl, 0.5_dbl /) )
rvecd = u%quat_Lp(vecd)
diffd = sum( abs(rvecd - (/ 0.D0, 1.D0, 0.D0/)) )
if (diffd.gt.epsd) then
  res = 13
  write (*,"('double precision vector rotation test failed = ',D18.10)") diffd
  return
end if

!===================================================
!=============Single Precision Tests================
!===================================================

!===================================================
! initialize zero quaternion
u = Quaternion_T( q = (/0.0, 0.0, 0.0, 0.0/) )
diff = cabs( u )
if (diff.gt.eps) then
  res = 20
  write (*,"('single precision zero initialization test failed = ',F12.8)") diff
  return
end if

if (.not.(u%quatsequal(resszero))) then
  res = 21
  write (*,"('single precision zero comparison test failed = ')")
  return
end if

! arithmetic tests
u = Quaternion_T( q=(/1.0,2.0,3.0,4.0/) )
v = Quaternion_T( q=(/5.0,6.0,7.0,8.0/) )

w = u+v
if (.not.(w%quatsequal(ressupv))) then
  res = 22
  write (*,"('single precision addition test failed = ')")
  return
end if

w = u-v
if (.not.(w%quatsequal(ressumv))) then
  res = 23
  write (*,"('single precision subtraction test failed = ')")
  return
end if

w = u*b
if (.not.(w%quatsequal(ressuta))) then
  res = 24
  write (*,"('single precision scalar multiplication test failed = ')")
  return
end if

w = u*v
if (.not.(w%quatsequal(ressutv))) then
  res = 25
  write (*,"('single precision quaternion multiplication test failed = ')")
  return
end if

w = u/v
if (.not.(w%quatsequal(ressudv))) then
  res = 26
  write (*,"('single precision division test failed = ')")
  return
end if

w = conjg(u)
if (.not.(w%quatsequal(ressuc))) then
  res = 27
  write (*,"('single precision conjugation test failed = ')")
  return
end if

diff = abs(cabs(u) - absvals)
if (diff.gt.eps) then
  res = 28
  write (*,"('single precision norm test failed = ',F12.8)") diff
  return
end if

diff = abs(u%quat_innerproduct(v) - ips)
if (diff.gt.eps) then
  res = 29
  write (*,"('single precision innerproduct test failed = ',F12.8)") diff
  return
end if

diff = abs(u%quat_angle(v) - qans)
if (diff.gt.eps) then
  res = 30
  write (*,"('single precision quaternion angle test failed = ',F12.8)") diff
  return
end if

! from here on we work with unit quaternions
call u%quat_normalize()
call v%quat_normalize()

diff = abs(cabs(u) - 1.0)
if (diff.gt.eps) then
  res = 31
  write (*,"('single precision normalization test failed = ',F12.8)") diff
  return
end if

! make u a rotation of 120° around the [111] axis
u = Quaternion_T( q=(/ 0.5_sgl, 0.5_sgl, 0.5_sgl, 0.5_sgl /) )
rvecs = u%quat_Lp(vecs)
diff = sum( abs(rvecs - (/ 0.0, 1.0, 0.0/)) )
if (diff.gt.eps) then
  res = 32
  write (*,"('single precision vector rotation test failed = ',D18.10)") diff
  return
end if

!===================================================
!==========Double Precision Array Tests=============
!===================================================

!===================================================
! declare two arrays with identical quaternions to simplify the testing ...
uA = QuaternionArray_T( n=4, qd = reshape( (/ 1.0_dbl,2.0_dbl,3.0_dbl,4.0_dbl, &
                                              1.0_dbl,2.0_dbl,3.0_dbl,4.0_dbl, &
                                              1.0_dbl,2.0_dbl,3.0_dbl,4.0_dbl, &
                                              1.0_dbl,2.0_dbl,3.0_dbl,4.0_dbl /), (/ 4, 4 /) ) )

vA = QuaternionArray_T( n=4, qd = reshape( (/ 5.0_dbl,6.0_dbl,7.0_dbl,8.0_dbl, &
                                              5.0_dbl,6.0_dbl,7.0_dbl,8.0_dbl, &
                                              5.0_dbl,6.0_dbl,7.0_dbl,8.0_dbl, &
                                              5.0_dbl,6.0_dbl,7.0_dbl,8.0_dbl /), (/ 4, 4 /) ) )

wA = uA + vA
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(resdupv))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 40
  write (*,"('double precision quaternion array addition test failed = ')")
  return
end if

wA = uA - vA
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(resdumv))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 41
  write (*,"('double precision quaternion array subtraction test failed = ')")
  return
end if

wA = uA * vA
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(resdutv))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 42
  write (*,"('double precision quaternion array multiplication test failed = ')")
  return
end if

wA = uA / vA
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(resdudv))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 43
  write (*,"('double precision quaternion array division test failed = ')")
  return
end if

wA = uA * a
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(resduta))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 44
  write (*,"('double precision quaternion array scalar multiplication test failed = ')")
  return
end if

wA = conjg(uA)
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(resduc))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 45
  write (*,"('double precision quaternion array conjugation test failed = ')")
  return
end if

dd = cabs(uA)
errcnt = 0
do i=1,4
  if (abs(dd(i)-absvald).gt.epsd) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 46
  write (*,"('double precision quaternion array abs test failed = ')")
  return
end if

dd = uA%quat_innerproduct(vA)
errcnt = 0
do i=1,4
  if (abs(dd(i)-ipd).gt.epsd) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 47
  write (*,"('double precision quaternion array inner product test failed = ')")
  return
end if

dd = uA%quat_angle(vA)
errcnt = 0
do i=1,4
  if (abs(dd(i)-qand).gt.epsd) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 48
  write (*,"('double precision quaternion array interquaternion angle test failed ')")
  return
end if

call uA%quat_normalize()
errcnt = 0
dd = cabs(uA)
do i=1,4
  if (abs(dd(i)-1.D0).gt.epsd) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 49
  write (*,"('double precision normalization test failed ')")
  return
end if

! make u a rotation of 120° around the [111] axis
uA = QuaternionArray_T( n=4,  qd=reshape( (/ 0.5_dbl, 0.5_dbl, 0.5_dbl, 0.5_dbl, &
                                             0.5_dbl, 0.5_dbl, 0.5_dbl, 0.5_dbl, &
                                             0.5_dbl, 0.5_dbl, 0.5_dbl, 0.5_dbl, &
                                             0.5_dbl, 0.5_dbl, 0.5_dbl, 0.5_dbl /), (/ 4, 4 /) ) )
rvecarrd = uA%quat_Lp(vecd)
errcnt = 0
do i=1,4
  diffd = sum( abs(rvecarrd(:,i) - (/ 0.D0, 1.D0, 0.D0/)) )
  if (diffd.gt.epsd) errcnt = errcnt+1
end do
if (errcnt.gt.0) then
  res = 50
  write (*,"('double precision quaternion array vector rotation test failed ')")
  return
end if

!===================================================
!==========Single Precision Array Tests=============
!===================================================

!===================================================
! declare two arrays with identical quaternions to simplify the testing ...
uA = QuaternionArray_T( n=4, q = reshape( (/ 1.0_sgl,2.0_sgl,3.0_sgl,4.0_sgl, &
                                             1.0_sgl,2.0_sgl,3.0_sgl,4.0_sgl, &
                                             1.0_sgl,2.0_sgl,3.0_sgl,4.0_sgl, &
                                             1.0_sgl,2.0_sgl,3.0_sgl,4.0_sgl /), (/ 4, 4 /) ) )

vA = QuaternionArray_T( n=4, q = reshape( (/ 5.0_sgl,6.0_sgl,7.0_sgl,8.0_sgl, &
                                             5.0_sgl,6.0_sgl,7.0_sgl,8.0_sgl, &
                                             5.0_sgl,6.0_sgl,7.0_sgl,8.0_sgl, &
                                             5.0_sgl,6.0_sgl,7.0_sgl,8.0_sgl /), (/ 4, 4 /) ) )

wA = uA + vA
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(ressupv))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 51
  write (*,"('single precision quaternion array addition test failed = ')")
  return
end if

wA = uA - vA
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(ressumv))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 52
  write (*,"('single precision quaternion array subtraction test failed = ')")
  return
end if

wA = uA * vA
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(ressutv))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 53
  write (*,"('single precision quaternion array multiplication test failed = ')")
  return
end if

wA = uA / vA
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(ressudv))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 54
  write (*,"('single precision quaternion array division test failed = ')")
  return
end if

wA = uA * b
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(ressuta))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 55
  write (*,"('single precision quaternion array scalar multiplication test failed = ')")
  return
end if

wA = conjg(uA)
errcnt = 0
do i=1,4
  u = wA%getQuatfromArray(i)
  if (.not.(u%quatsequal(ressuc))) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 56
  write (*,"('single precision quaternion array conjugation test failed = ')")
  return
end if

d = cabs(uA)
errcnt = 0
do i=1,4
  if (abs(d(i)-absvals).gt.eps) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 57
  write (*,"('single precision quaternion array abs test failed = ')")
  return
end if

d = uA%quat_innerproduct(vA)
errcnt = 0
do i=1,4
  if (abs(d(i)-ips).gt.eps) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 58
  write (*,"('single precision quaternion array inner product test failed = ')")
  return
end if

d = uA%quat_angle(vA)
errcnt = 0
do i=1,4
  if (abs(d(i)-qans).gt.eps) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 59
  write (*,"('single precision quaternion array interquaternion angle test failed ')")
  return
end if

call uA%quat_normalize()
errcnt = 0
d = cabs(uA)
do i=1,4
  if (abs(d(i)-1.0).gt.eps) errcnt = errcnt + 1
end do
if (errcnt.ne.0) then
  res = 60
  write (*,"('single precision normalization test failed ')")
  return
end if

! make u a rotation of 120° around the [111] axis
uA = QuaternionArray_T( n=4,  q=reshape( (/ 0.5_sgl, 0.5_sgl, 0.5_sgl, 0.5_sgl, &
                                            0.5_sgl, 0.5_sgl, 0.5_sgl, 0.5_sgl, &
                                            0.5_sgl, 0.5_sgl, 0.5_sgl, 0.5_sgl, &
                                            0.5_sgl, 0.5_sgl, 0.5_sgl, 0.5_sgl /), (/ 4, 4 /) ) )
rvecarrs = uA%quat_Lp(vecs)
errcnt = 0
do i=1,4
  diff = sum( abs(rvecarrs(:,i) - (/ 0.0, 1.0, 0.0/)) )
  if (diff.gt.eps) errcnt = errcnt+1
end do
if (errcnt.gt.0) then
  res = 61
  write (*,"('single precision quaternion array vector rotation test failed ')")
  return
end if

end subroutine MODQuaternionsExecuteTest

end module MODQuaternionsTest


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of alfa in reverse (adjoint) mode (with options noISIZE i8):
!   gradient     of useful results: alfa
!   with respect to varying inputs: x
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!>    @brief truncated series expansion of cosh(x) for x < 0.1
!>    @param[in] x input value
!>    @return truncated function value
SUBROUTINE ALFA_AD(x, x_ad, alfa_adv)
  IMPLICIT NONE
  double precision :: alfa_adv
  DOUBLE PRECISION :: x
  DOUBLE PRECISION :: x_ad
  INTRINSIC ABS
  INTRINSIC TANH
  DOUBLE PRECISION :: abs0
  DOUBLE PRECISION :: temporary_ad
  DOUBLE PRECISION :: temp
  DOUBLE PRECISION :: alfa
!      double precision x2, x3, x5, x7
  IF (x .GE. 0.) THEN
    abs0 = x
  ELSE
    abs0 = -x
  END IF
  IF (abs0 .GT. 1.d-30) THEN
    temp = TANH(x)
    temporary_ad = alfa_adv/x
    x_ad = (1.0/temp-(1.0-TANH(x)**2)*x/temp**2-(x/temp-1.d0)/x)*temporary_ad
  ELSE
    x_ad = 0.D0
  END IF
END SUBROUTINE ALFA_AD


program test_dairyai
  use types, only: dp
  use constants, only: i_
  use utils, only: assert
  use special, only: dairyai
  implicit none

  ! check a few value against the ones computed with SciPy:
  integer :: i
  real(dp), parameter :: eps = 1d-14
  real(dp), parameter :: xReal(5) = [1.1_dp, 3.0_dp, 10.0_dp, 2.1_dp, 5.5_dp]
  real(dp), parameter :: xImag(5) = [0.1_dp, -0.3_dp, 2.5_dp, -1.8_dp, 2.0_dp]

  complex(dp), parameter :: correctResults(5) = [(-0.145563472763267_dp, 0.013229788969267_dp),&
       (-0.010610911598755_dp, -0.005772105021642_dp), (0.000000000007158_dp, 0.000000000580016_dp),&
       (0.067991533120730_dp, -0.048089068490876_dp), (0.000009851131022_dp, -0.000124105490600_dp)]

  do i = 1,5
     call assert(abs(dairyai(xReal(i)+i_*xImag(i)) - correctResults(i)) < eps)
  end do

end program test_dairyai


      subroutine lindep(aamatr,eps100,irow1,irow2,jcol1,jcol2,kmax,
     $ qldep)
c
c     This subroutine determines whether the rows of a submatrix of
c     matrix aamatr are linearly dependent or not. The submatrix runs
c     from rows irow1 to irow2 and columns jcol1 to jcol2. If there is
c     linear dependence, qldep is returned with a value of ".true.".
c     This subroutine factors all rows if possible. It is assumed that
c     the calling subroutine may use these rows if qldep is returned
c     with a value of ".true.".
c
c     This subroutine is called by:
c
c       EQ3NR/dawfix.f
c       EQ6/eqcalc.f
c       EQ6/jgibbs.f
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       aamatr = the matrix to be tested
c       eps100 = 100 times the real*8 machine epsilon
c       irow1  = start of range of rows to examine
c       irow2  = end of range of rows to examine
c       jcol1  = start of range of columns to examine
c       jcol2  = end of range of columns to examine
c       kmax   = dimension of aamatr
c
c     Output:
c
c       qldep  = flag variable
c                  .true.  = linear dependence
c                  .false. = no linear dependence
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer kmax
c
      integer irow1,irow2,jcol1,jcol2
c
      logical qldep
c
      real*8 aamatr(kmax,kmax)
      real*8 eps100
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer i,idim,ipiv,irow,j,jcol,jdim,nrowi,nrowp
c
      real*8 aax,avmax,av,factor
c
c-----------------------------------------------------------------------
c
      idim = irow2 - irow1 + 1
      jdim = jcol2 - jcol1 + 1
c
      do i = irow1,irow2
        avmax = 0.
        do j = jcol1,jcol2
          av = abs(aamatr(i,j))
          if (av .gt. avmax) avmax = av
        enddo
        if (avmax .eq. 0.) then
c
c         Have a row containing all zeros.
c
          qldep = .true.
          go to 999
        endif
      enddo
c
      if (idim .gt. jdim) then
c
c       Have linear dependence because the number of rows is greater
c       than the number of columns.
c
        qldep = .true.
        go to 999
      endif
c
c     Note: nrowp is the number of rows processed; irow is the
c     index of the row currently being tested.
c
      nrowp = 0
c
      do jcol = jcol1,jcol2
        irow = irow1 + nrowp
        avmax = 0.
        ipiv = irow
c
        do i = irow,irow2
          av = abs(aamatr(i,jcol))
          if (av .gt. avmax) then
            avmax = av
            ipiv = i
          endif
        enddo
c
        if (avmax .gt. 0.) then
c
c         The present column is non-empty for the present and following
c         rows. This suffices to establish the existence of another
c         independent row.
c
          nrowp = nrowp + 1
c
          if (ipiv .ne. irow) then
c
c           Pivot- exchange rows irow and ipiv.
c
            do j = jcol,jcol2
              aax = aamatr(irow,j)
              aamatr(irow,j) = aamatr(ipiv,j)
              aamatr(ipiv,j) = aax
            enddo
          endif
c
c         Move down the present column from the current row to the last
c         row. If a non-zero entry is found, multiply the row by the
c         factor necessary to set this entry to unity. Note that
c         entries in any preceding columns of the submatrix are zero
c         at this point.
c
          do i = irow,irow2
            if (aamatr(i,jcol) .ne. 0.) then
              factor = 1./aamatr(i,jcol)
              do j = jcol,jcol2
                aamatr(i,j) = factor*aamatr(i,j)
              enddo
            endif
          enddo
c
          do i = irow + 1,irow2
            if (aamatr(i,jcol) .ne. 0.) then
c
c             Have a following row whose entry in the current column is
c             not zero (hence it has a value of unity). Make it zero by
c             subtracting the irow-th row (whose entry in the current
c             column is also unity) from the following row now under
c             consideration.
c
              do j = jcol,jcol2
                aamatr(i,j) = aamatr(i,j) - aamatr(irow,j)
                if (abs(aamatr(i,j)) .le. eps100) aamatr(i,j) = 0.
              enddo
            endif
          enddo
        endif
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Count the number of independent rows.
c
      nrowi = 0
      do i = irow1,irow2
        do j = jcol1,jcol2
          if (aamatr(i,j) .ne. 0.) then
            nrowi = nrowi + 1
            go to 100
          endif
        enddo
  100   continue
      enddo
c
      qldep = nrowi .lt. idim
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  999 continue
      end


module moving_average
  implicit none

  integer, parameter:: dp=kind(0.d0)

  type :: timeseries
    integer :: nb_samples, series_size  ! the window and total size
    real(dp), allocatable :: series(:)
  contains
    procedure :: init => timeseries_init
    procedure :: put_value => timeseries_put_value
    procedure :: get_average => timeseries_get_average
  end type

  type, extends(timeseries) :: timestats
    real(dp) :: minimum, maximum, stddev
  contains
    procedure :: calc_stats => timeseries_calc_stats
  end type
contains

  subroutine timeseries_init(self)
    !NOTE: use class below instead of type to allow inheritance
    class(timeseries):: self
    integer :: status

    allocate(self%series(2), stat=status)

    self%series = (/0._dp, 0._dp/)
    self%series_size = size(self%series)
  end subroutine

  subroutine timeseries_calc_stats(self)
    class(timestats):: self

    self%minimum = minval(self%series)
    self%maximum = maxval(self%series)
    self%stddev = 0._dp
  end subroutine

  subroutine timeseries_put_value(self, new_data)
    class(timeseries) :: self
    ! real(dp), dimension(1:old_size) :: old_data
    real(dp), intent(in) :: new_data(:)
    integer :: old_size, new_size

    ! old_data = self%series
    old_size = size(self%series)
    new_size = size(new_data)

    ! NOTE: incomplete
    ! deallocate(self%series)
    ! allocate(self%series(old_size + new_size))

    ! NOTE: does not work
    !self%series = reshape(self%series, (/old_size + new_size/))
    !self%series(old_size+1 : old_size + new_size) = new_data

    ! NOTE: avoid copying and extends array!
    self%series = [self%series, new_data]

    self%series_size = old_size + new_size
  end subroutine

  real(dp) function timeseries_get_average(self, average)
    class(timeseries) :: self
    real(dp), intent(out) :: timeseries_get_average(self%series_size / self%nb_samples)
    integer :: i0, nb_windows

    nb_windows = 0
    average = 0._dp
    do i0 = 1, self%series_size, self%nb_samples
      average(nb_windows) = sum(self%series(i0 : i0 + self%nb_samples)) / (self%nb_samples)
      nb_windows = nb_windows + 1
    end do

    ! average = average / nb_windows
  end subroutine

end module

program main
  use moving_average, only: timeseries, timestats, dp
  implicit none
  type(timestats) :: ts
  integer, parameter :: nb_samples = 6
  real(dp) :: average(nb_samples)

  call ts%init()
  print*, "Initial series data =", ts%series
  print*, "Initial series size =", ts%series_size
  call ts%put_value((/-1._dp, 2._dp, 5._dp, 9._dp, 4._dp/))
  print*, "Updated series data =", ts%series
  print*, "Updated series size =", ts%series_size

  ts%nb_samples = nb_samples
  call ts%get_average(average)
  print*, "Moving average =", average

  call ts%calc_stats()
  print*, "Min =", ts%minimum
  print*, "Min =", ts%maximum
  print*, "Std. dev  =", ts%stddev

end program


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          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.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief A Fortran 2003 module defining "Points" for use in geometry.
!>
!> This module provides derived data types for a "point" in any dimensional
!> space. It also provides methods for constructing and destruction the points
!> and printing the point information. Two other routines are provided to return
!> the distance between two points and to return the midpoint between two points.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE Geom_Points
USE IntrType
USE Constants_Conversion

IMPLICIT NONE
PRIVATE !Default contents of module to private
!
! List of Public items
PUBLIC :: MAX_COORD_STR_LEN
PUBLIC :: PointType
PUBLIC :: LinkedListPointType
PUBLIC :: ClearLinkedListPointType
PUBLIC :: Distance
PUBLIC :: midPoint
PUBLIC :: innerAngle
PUBLIC :: outerAngle
PUBLIC :: OPERATOR(+)
PUBLIC :: OPERATOR(-)
PUBLIC :: OPERATOR(==)
PUBLIC :: OPERATOR(/=)
PUBLIC :: OPERATOR(.APPROXEQA.)
PUBLIC :: ASSIGNMENT(=)

INTEGER(SIK),PARAMETER :: MAX_COORD_STR_LEN=128

!> @brief The derived type for a point
TYPE :: PointType
  !> The number of dimensions of space in which this point lives
  INTEGER(SIK) :: dim=0
  !> Coordinate values for each dimension of the point (X=1, Y=2, Z=3)
  REAL(SRK),ALLOCATABLE :: coord(:)
!
!List of type bound procedures
  CONTAINS
    !> @copybrief GeomPoints::init_PointType
    !> @copydetails GeomPoints::init_PointType
    PROCEDURE,PASS :: init => init_PointType
    !> @copybrief GeomPoints::clear_PointType
    !> @copydetails GeomPoints::clear_PointType
    PROCEDURE,PASS :: clear => clear_PointType
    !> @copybrief GeomPoints::coord2str_PointType
    !> @copydetails GeomPoints::coord2str_PointType
    PROCEDURE,PASS :: getCoordString => coord2str_PointType
ENDTYPE PointType

!> A linked list type of points
!>
!> This is used by the ray trace routines that determine segment information
TYPE :: LinkedListPointType
  !> A sorting value for a comparison operation. This is most likely the
  !> distance to a reference point.
  REAL(SRK) :: sortval=0.0_SRK
  !> The point type for this record in the list
  TYPE(PointType):: p
  !> Is this point a duplicate?
  LOGICAL(SBK) :: isDuplicate=.FALSE.
  !> The next record in the list.
  TYPE(LinkedListPointType),POINTER :: next => NULL()
!
!List of type bound procedures
  CONTAINS
    !> @copybrief GeomPoints::insert_LinkedListPointType
    !> @copydetails GeomPoints::insert_LinkedListPointType
    PROCEDURE,PASS :: insert => insert_LinkedListPointType
ENDTYPE LinkedListPointType

!> @brief Generic interface for computing innerAngle
!>
!> Adds the listed module procedures to the global interface name for innerAngle
INTERFACE innerAngle
  !> @copybrief GeomPoints::innerAngle_3points
  !> @copydetails GeomPoints::innerAngle_3points
  MODULE PROCEDURE innerAngle_3points
ENDINTERFACE innerAngle

!> @brief Generic interface for computing outerAngle
!>
!> Adds the listed module procedures to the global interface name for outerAngle
INTERFACE outerAngle
  !> @copybrief GeomPoints::outerAngle_3points
  !> @copydetails GeomPoints::outerAngle_3points
  MODULE PROCEDURE outerAngle_3points
ENDINTERFACE outerAngle

!> @brief Generic interface for computing midpoint
!>
!> Adds the listed module procedures to the global interface name for midPoint
INTERFACE midPoint
  !> @copybrief GeomPoints::midPoint_2points
  !> @copydetails GeomPoints::midPoint_2points
  MODULE PROCEDURE midPoint_2points
ENDINTERFACE midPoint

!> @brief Generic interface for computing distance
!>
!> Adds the listed module procedures to the global interface name for Distance
INTERFACE Distance
  !> @copybrief GeomPoints::distance_2points
  !> @copydetails GeomPoints::distance_2points
  MODULE PROCEDURE distance_2points
ENDINTERFACE Distance

!> @brief Generic interface for addition operator (+)
!>
!> Adds addition capability for point types
INTERFACE OPERATOR(+)
  !> @copybrief GeomPoints::add_PointType
  !> @copydetails GeomPoints::add_PointType
  MODULE PROCEDURE add_PointType
ENDINTERFACE

!> @brief Generic interface for subtraction operator (-)
!>
!> Adds subtraction capability for point types
INTERFACE OPERATOR(-)
  !> @copybrief GeomPoints::subtract_PointType
  !> @copydetails GeomPoints::subtract_PointType
  MODULE PROCEDURE subtract_PointType
ENDINTERFACE

!> @brief Generic interface for 'is equal to' operator (==)
!>
!> Adds 'is equal to' capability for point types
INTERFACE OPERATOR(==)
  !> @copybrief GeomPoints::isequal_PointType
  !> @copydetails GeomPoints::isequal_PointType
  MODULE PROCEDURE isequal_PointType
ENDINTERFACE

!> @brief Generic interface for 'is not equal to' operator (/=)
!>
!> Adds 'is not equal to' capability for point types
INTERFACE OPERATOR(/=)
  !> @copybrief GeomPoints::notequal_PointType
  !> @copydetails GeomPoints::notequal_PointType
  MODULE PROCEDURE notequal_PointType
ENDINTERFACE

!> @brief Generic interface for 'is approximately equal to' operator
!> (.APPROXEQA.)
!>
!> Adds 'is approximately equal to' capability for point types
INTERFACE OPERATOR(.APPROXEQA.)
  !> @copybrief GeomPoints::approxequal_PointType
  !> @copydetails GeomPoints::approxequal_PointType
  MODULE PROCEDURE approxequal_PointType
ENDINTERFACE

!> @brief Generic interface for assignment operator (=)
!>
!> Adds assignment capability for point types. Done primarily to help
!> eliminate valgrind errors in VERA.
INTERFACE ASSIGNMENT(=)
  !> @copybrief GeomPoints::assign_PointType
  !> @copydetails GeomPoints::assign_PointType
  MODULE PROCEDURE assign_PointType
ENDINTERFACE
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief Constructor for a point with a double precision argument
!> @param p the point type variable to initialize
!> @param DIM the number of dimensions of space in which this point lives
!>        (optional).
!> @param X the x-coordinate of the point (OPTIONAL)
!> @param Y the y-coordinate of the point (OPTIONAL)
!> @param Z the z-coordinate of the point (OPTIONAL)
!> @param coord an array with the coordinates of the point (OPTIONAL)
!>
!> There are essentially only a few ways to use this routine. If it is not
!> called in this way then the routine will return the point uninitialized.
!> Below are examples of how to correctly use this routine to create a point at
!> origin in various dimensions.
!>
!> @code
!> TYPE(PointType) :: p
!> CALL p%init(COORD=(/0.0,0.0,0.0,0.0/))
!> @endcode
!>
!> @code
!> TYPE(PointType) :: p
!> CALL p%init(DIM=1,X=0.0)
!> @endcode
!>
!> @code
!> TYPE(PointType) :: p
!> CALL p%init(DIM=2,X=0.0,Y=0.0)
!> @endcode
!>
!> @code
!> TYPE(PointType) :: p
!> CALL p%init(DIM=3,X=0.0,Y=0.0,Z=0.0)
!> @endcode
PURE SUBROUTINE init_PointType(p,DIM,X,Y,Z,coord)
  CLASS(PointType),INTENT(INOUT) :: p
  INTEGER(SIK),INTENT(IN),OPTIONAL :: DIM
  REAL(SRK),INTENT(IN),OPTIONAL :: X,Y,Z
  REAL(SRK),INTENT(IN),OPTIONAL :: coord(:)

  IF(.NOT.ALLOCATED(p%coord)) THEN !initialize only if its not already initialized
    IF(PRESENT(coord)) THEN
      p%dim=SIZE(coord)
      ALLOCATE(p%coord(1:p%dim))
      p%coord=coord
    ELSEIF(PRESENT(DIM)) THEN
      SELECTCASE(DIM)
      CASE(1)
        IF(PRESENT(X)) THEN
          p%dim=1
          ALLOCATE(p%coord(1))
          p%coord(1)=X
        ENDIF
      CASE(2)
        IF(PRESENT(X) .AND. PRESENT(Y)) THEN
          p%dim=2
          ALLOCATE(p%coord(2))
          p%coord(1)=X
          p%coord(2)=Y
        ENDIF
      CASE(3)
        IF(PRESENT(X) .AND. PRESENT(Y) .AND. PRESENT(Z)) THEN
          p%dim=3
          ALLOCATE(p%coord(3))
          p%coord(1)=X
          p%coord(2)=Y
          p%coord(3)=Z
        ENDIF
      ENDSELECT
    ENDIF
  ENDIF
ENDSUBROUTINE init_PointType
!
!-------------------------------------------------------------------------------
!> @brief Routine clears the data in a point type variable
!> @param p the point type variable to clear
ELEMENTAL SUBROUTINE clear_PointType(p)
  CLASS(PointType),INTENT(INOUT) :: p
  p%dim=0
  IF(ALLOCATED(p%coord)) DEALLOCATE(p%coord)
ENDSUBROUTINE clear_PointType
!
!-------------------------------------------------------------------------------
!> @brief Defines the addition operation between two points e.g. @c p=p0+p1
!> @param p0 the first point
!> @param p1 the second point
!> @returns @c p the return point value
!>
!> Function is elemental so it can be used on an array of points.
ELEMENTAL FUNCTION add_PointType(p0,p1) RESULT(p)
  TYPE(PointType),INTENT(IN) :: p0,p1
  TYPE(PointType) :: p
  CALL p%clear()
  IF(p0%dim == p1%dim .AND. p0%dim > 0) THEN
    p%dim=p0%dim
    ALLOCATE(p%coord(p%dim))
    SELECTCASE(p%dim) !Explicit unrolling, this may improve performance
    CASE(1)
      p%coord(1)=p0%coord(1)+p1%coord(1)
    CASE(2)
      p%coord(1)=p0%coord(1)+p1%coord(1)
      p%coord(2)=p0%coord(2)+p1%coord(2)
    CASE(3)
      p%coord(1)=p0%coord(1)+p1%coord(1)
      p%coord(2)=p0%coord(2)+p1%coord(2)
      p%coord(3)=p0%coord(3)+p1%coord(3)
    CASE DEFAULT
      p%coord=p0%coord+p1%coord
    ENDSELECT
  ENDIF
ENDFUNCTION add_PointType
!
!-------------------------------------------------------------------------------
!> @brief Defines the subtraction operation between two points e.g. @c p=p0-p1
!> @param p0 the first point
!> @param p1 the second point
!> @returns @c p the return point value
!>
!> Function is elemental so it can be used on an array of points.
ELEMENTAL FUNCTION subtract_PointType(p0,p1) RESULT(p)
  TYPE(PointType),INTENT(IN) :: p0,p1
  TYPE(PointType) :: p
  CALL p%clear()
  IF(p0%dim == p1%dim .AND. p0%dim > 0) THEN
    p%dim=p0%dim
    ALLOCATE(p%coord(p%dim))
    SELECTCASE(p%dim) !Explicit unrolling, this may improve performance
    CASE(1)
      p%coord(1)=p0%coord(1)-p1%coord(1)
    CASE(2)
      p%coord(1)=p0%coord(1)-p1%coord(1)
      p%coord(2)=p0%coord(2)-p1%coord(2)
    CASE(3)
      p%coord(1)=p0%coord(1)-p1%coord(1)
      p%coord(2)=p0%coord(2)-p1%coord(2)
      p%coord(3)=p0%coord(3)-p1%coord(3)
    CASE DEFAULT
      p%coord=p0%coord-p1%coord
    ENDSELECT
  ENDIF
ENDFUNCTION subtract_PointType
!
!-------------------------------------------------------------------------------
!> @brief Defines the 'is equal to' operation between two points e.g. @c p0==p1
!> @param p0 the first point
!> @param p1 the second point
!> @returns @c bool the boolean result of the operation
!>
!> Function is elemental so it can be used on an array of points.
ELEMENTAL FUNCTION isequal_PointType(p0,p1) RESULT(bool)
  TYPE(PointType),INTENT(IN) :: p0,p1
  LOGICAL(SBK) :: bool
  bool=.FALSE.
  IF(p0%dim == p1%dim .AND. p0%dim > 0) &
      bool=ALL(p0%coord == p1%coord)
ENDFUNCTION isequal_PointType
!
!-------------------------------------------------------------------------------
!> @brief Defines the 'is not equal to' operation between two points e.g. @c p0/=p1
!> @param p0 the first point
!> @param p1 the second point
!> @returns @c bool the boolean result of the operation
!>
!> Function is elemental so it can be used on an array of points.
ELEMENTAL FUNCTION notequal_PointType(p0,p1) RESULT(bool)
  TYPE(PointType),INTENT(IN) :: p0,p1
  LOGICAL(SBK) :: bool
  bool=.TRUE.
  IF(p0%dim == p1%dim .AND. p0%dim > 0) &
      bool=ANY(p0%coord /= p1%coord)
ENDFUNCTION notequal_PointType
!
!-------------------------------------------------------------------------------
!> @brief Defines the 'approximately equal to' operation between two points
!> e.g. p0 .APPROXEQA. p1
!> @param p0 the first point
!> @param p1 the second point
!> @returns @c bool the boolean result of the operation
!>
!> Function is elemental so it can be used on an array of points.
ELEMENTAL FUNCTION approxequal_PointType(p0,p1) RESULT(bool)
  TYPE(PointType),INTENT(IN) :: p0,p1
  LOGICAL(SBK) :: bool
  bool=.FALSE.
  IF(p0%dim == p1%dim .AND. p0%dim > 0) &
      bool=ALL(p0%coord .APPROXEQA. p1%coord)
ENDFUNCTION approxequal_PointType
!
!-------------------------------------------------------------------------------
!> @brief Defines the assignment operation between two points
!> e.g. p0 = p1
!> @param p0 the first point to be assigned to
!> @param p1 the second point to be assigned from
!>
!> Function is elemental so it can be used on an array of points.
ELEMENTAL SUBROUTINE assign_PointType(p0,p1)
  TYPE(PointType),INTENT(INOUT) :: p0
  TYPE(PointType),INTENT(IN) :: p1
  p0%dim=p1%dim
  IF(ALLOCATED(p0%coord)) DEALLOCATE(p0%coord)
  IF(ALLOCATED(p1%coord)) THEN
    ALLOCATE(p0%coord(SIZE(p1%coord)))
    p0%coord=p1%coord
  ENDIF
ENDSUBROUTINE assign_PointType
!
!-------------------------------------------------------------------------------
!> @brief Return the coordinates as a string
!> @param p the point type whose coordinates are being returned as a string
!> @param fmt_string a string giving the format statement for the write
!> statement (OPTIONAL)
!> @returns @c cstring the returned string
!>
!> The default format is '(a,100(es23.12,a))' this means the maximum dimension
!> for the point is 100 for this routine. Should be changed to the value of
!> p%dim
ELEMENTAL FUNCTION coord2str_PointType(p,fmt_string) RESULT(cstring)
  CLASS(PointType),INTENT(IN) :: p
  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: fmt_string
  CHARACTER(LEN=MAX_COORD_STR_LEN) :: cstring
  INTEGER(SIK) :: i,ioerr
  cstring=''
  IF(ALLOCATED(p%coord)) THEN
    IF(PRESENT(fmt_string)) THEN
      WRITE(cstring,FMT='(a,100('//fmt_string//',a))',IOSTAT=ioerr) &
          '(',(p%coord(i),',',i=1,p%dim-1),p%coord(p%dim),')'
    ELSE
      WRITE(cstring,'(a,100(es21.14,a))',IOSTAT=ioerr) &
          '(',(p%coord(i),',',i=1,p%dim-1),p%coord(p%dim),')'
    ENDIF
    IF(ioerr /= 0) cstring=''
  ENDIF
ENDFUNCTION coord2str_PointType
!
!-------------------------------------------------------------------------------
!> @brief Computes the distance between two points
!> @param p0 the first point
!> @param p1 the second point
!> @returns @c d the distance between @c p0 and @c p1
!> @note @c p0 and @c p1 must be defined in the same dimension or the
!>   result is 0.0.
!> The routine implicitly works for points in any dimension.
!>
!> Function is elemental so it can be used on an array of points.
ELEMENTAL FUNCTION distance_2points(p0,p1) RESULT(d)
  CLASS(PointType),INTENT(IN) :: p0,p1
  INTEGER(SIK) :: i
  REAL(SRK) :: d
  d=0.0_SRK
  IF(p0%dim == p1%dim) THEN
    !Explicit unrolling for lower order expected dimensions
    SELECTCASE(p0%dim)
    CASE(1)
      d=ABS((p1%coord(1)-p0%coord(1)))
    CASE(2)
      d=SQRT((p1%coord(1)-p0%coord(1))*(p1%coord(1)-p0%coord(1))+ &
          (p1%coord(2)-p0%coord(2))*(p1%coord(2)-p0%coord(2)))
    CASE(3)
      d=SQRT((p1%coord(1)-p0%coord(1))*(p1%coord(1)-p0%coord(1))+ &
          (p1%coord(2)-p0%coord(2))*(p1%coord(2)-p0%coord(2))+ &
          (p1%coord(3)-p0%coord(3))*(p1%coord(3)-p0%coord(3)))
    CASE DEFAULT
      DO i=1,p0%dim
        d=d+(p1%coord(i)-p0%coord(i))*(p1%coord(i)-p0%coord(i))
      ENDDO
      d=SQRT(d)
    ENDSELECT
  ENDIF
ENDFUNCTION distance_2points
!
!-------------------------------------------------------------------------------
!> @brief Computes the midpoint between two points in any dimension
!> @param p0 the first point
!> @param p1 the second point
!> @returns @c p the midpoint between @c p0 and @c p1
!>
!> Function is elemental so it can be used on an array of points.
ELEMENTAL FUNCTION midPoint_2points(p0,p1) RESULT(p)
  TYPE(PointType),INTENT(IN) :: p0,p1
  TYPE(PointType) :: p
  CALL p%clear()
  IF(p0%dim == p1%dim .AND. p0%dim > 0) THEN
    p%dim=p0%dim
    ALLOCATE(p%coord(p%dim))
    !Explicit unrolling for lower order expected dimensions
    SELECTCASE(p0%dim)
    CASE(1)
      p%coord(1)=(p1%coord(1)+p0%coord(1))*0.5_SRK
    CASE(2)
      p%coord(1)=(p1%coord(1)+p0%coord(1))*0.5_SRK
      p%coord(2)=(p1%coord(2)+p0%coord(2))*0.5_SRK
    CASE(3)
      p%coord(1)=(p1%coord(1)+p0%coord(1))*0.5_SRK
      p%coord(2)=(p1%coord(2)+p0%coord(2))*0.5_SRK
      p%coord(3)=(p1%coord(3)+p0%coord(3))*0.5_SRK
    CASE DEFAULT
      p%coord=(p1%coord+p0%coord)*0.5_SRK
    ENDSELECT
  ENDIF
ENDFUNCTION midPoint_2points
!
!-------------------------------------------------------------------------------
!> @brief Computes the interior angle between three points in up to three
!>        dimensions, where the points exist like:
!>   ^   * p0
!>    \   \
!>     v1  \
!>          \     v2->
!>        p1 *----------* p2
!> @param p0 the first point
!> @param p1 the second point
!> @param p2 the third point
!> @returns @c angle the angle between @c p0, @c p1, and @c p2
!>
!>  Equation implemented:
!> theta=ACOS(DOT(v1,v2)/(|v1|*|v2|))
!>
!> Function is elemental so it can be used on an array of points.
ELEMENTAL FUNCTION innerAngle_3points(p0,p1,p2) RESULT(angle)
  TYPE(PointType),INTENT(IN) :: p0,p1,p2
  REAL(SRK) :: vec1(3),vec2(3),angle,d1,d2
  IF((p0%dim > 1) .AND. (p0%dim == p1%dim) .AND. (p1%dim == p2%dim)) THEN
    !Explicit unrolling for lower order expected dimensions
    vec1=0.0_SRK; vec2=0.0_SRK
    d1=distance(p0,p1)
    d2=distance(p2,p1)
    SELECTCASE(p0%dim)
    CASE(2)
      vec1(1)=p0%coord(1)-p1%coord(1)
      vec1(2)=p0%coord(2)-p1%coord(2)
      vec2(1)=p2%coord(1)-p1%coord(1)
      vec2(2)=p2%coord(2)-p1%coord(2)
      angle=ACOS((vec1(1)*vec2(1)+vec1(2)*vec2(2))/(d1*d2))
    CASE(3)
      vec1(1)=p0%coord(1)-p1%coord(1)
      vec1(2)=p0%coord(2)-p1%coord(2)
      vec1(3)=p0%coord(3)-p1%coord(3)
      vec2(1)=p2%coord(1)-p1%coord(1)
      vec2(2)=p2%coord(2)-p1%coord(2)
      vec2(3)=p2%coord(3)-p1%coord(3)
      angle=ACOS((vec1(1)*vec2(1)+vec1(2)*vec2(2)+vec1(3)*vec2(3))/ &
          (d1*d2))
    ENDSELECT
  ENDIF
ENDFUNCTION innerAngle_3points
!
!-------------------------------------------------------------------------------
!> @brief Computes the exterior angle between three points in up to three
!>        dimensions, where the points exist like:
!>   ^   * p0
!>    \   \
!>     v1  \
!>          \     v2->
!>        p1 *----------* p2
!> @param p0 the first point
!> @param p1 the second point
!> @param p2 the third point
!> @returns @c angle the angle between @c p0, @c p1, and @c p2
!>
!> Function is elemental so it can be used on an array of points.
ELEMENTAL FUNCTION outerAngle_3points(p0,p1,p2) RESULT(angle)
  TYPE(PointType),INTENT(IN) :: p0,p1,p2
  REAL(SRK) :: vec1(3),vec2(3),angle,d1,d2
  IF((p0%dim > 1) .AND. (p0%dim == p1%dim) .AND. (p1%dim == p2%dim)) THEN
    !Explicit unrolling for lower order expected dimensions
    vec1=0.0_SRK; vec2=0.0_SRK
    d1=distance(p0,p1)
    d2=distance(p2,p1)
    SELECTCASE(p0%dim)
    CASE(2)
      vec1(1)=p0%coord(1)-p1%coord(1)
      vec1(2)=p0%coord(2)-p1%coord(2)
      vec2(1)=p2%coord(1)-p1%coord(1)
      vec2(2)=p2%coord(2)-p1%coord(2)
      angle=TWOPI-ACOS((vec1(1)*vec2(1)+vec1(2)*vec2(2))/(d1*d2))
    CASE(3)
      vec1(1)=p0%coord(1)-p1%coord(1)
      vec1(2)=p0%coord(2)-p1%coord(2)
      vec1(3)=p0%coord(3)-p1%coord(3)
      vec2(1)=p2%coord(1)-p1%coord(1)
      vec2(2)=p2%coord(2)-p1%coord(2)
      vec2(3)=p2%coord(3)-p1%coord(3)
      angle=TWOPI-ACOS((vec1(1)*vec2(1)+vec1(2)*vec2(2)+vec1(3)*vec2(3))/ &
          (d1*d2))
    ENDSELECT
  ENDIF
ENDFUNCTION outerAngle_3points
!
!-------------------------------------------------------------------------------
!> @brief Inserts a point into a linked list of points.
!> @param firstPoint the first point in the linked list
!> @param thisPoint the point to insert into the list
!>
!> This routine assumes that the point to be inserted will come after
!> firstPoint and before the last point in the list. If thisPoint
!> returns to the calling routine associated then it was NOT inserted
!> into the list successfully.
SUBROUTINE insert_LinkedListPointType(firstPoint,thisPoint,markDuplicates)
  CLASS(LinkedListPointType),TARGET,INTENT(INOUT) :: firstPoint
  TYPE(LinkedListPointType),POINTER,INTENT(INOUT) :: thisPoint
  LOGICAL(SBK),INTENT(IN),OPTIONAL :: markDuplicates

  LOGICAL(SBK) :: mark=.FALSE.
  LOGICAL(SBK) :: linsert
  REAL(SRK) :: d
  TYPE(LinkedListPointType),POINTER :: searchPoint1,searchPoint2

  IF(PRESENT(markDuplicates))THEN
    mark=markDuplicates
  ELSE
    mark=.FALSE.
  ENDIF

  IF(ASSOCIATED(thisPoint)) THEN
    SELECTTYPE(firstPoint); TYPE IS(LinkedListPointType)
      searchPoint1 => firstPoint
      d=thisPoint%sortval
      IF(ASSOCIATED(firstPoint%next)) THEN
        linsert=.TRUE.
        DO WHILE(linsert)
          searchPoint2 => searchPoint1%next

          !Do not allow for points that are approximately equal to
          !existing points in the list.
          !
          !Because the sort value is distance, "approximately equal to"
          !should be use SQRT(dim)*EPSREAL instead of EPSREAL for the
          !tolerance. We use a value of 2 since this caputes SQRT(3) and
          !we don't really expect higher dimensions.
          !
          !However, in practice this was determined to be too small of a
          !tolerance. It appears there are some cases where the approxeq
          !is satisfied for 2 of the 3 dimensions and because the surface
          !and line segment are nearly parallel the floating point error
          !in the 3rd dimension will be significantly larger.
          !
          !A new factor of 10 was arbitrarily chosen and may need to be
          !updated again if other degenerate cases are still encountered
          !to not be be correctly identified.
          IF(ABS(d-searchPoint1%sortval) <= 100._SRK*EPSREAL) THEN
            IF(mark) THEN
              searchPoint1%isDuplicate=.TRUE.
            ENDIF
            linsert=.FALSE.
          ELSEIF(ABS(d-searchPoint2%sortval) <= 100._SRK*EPSREAL) THEN
            IF(mark) THEN
              searchPoint2%isDuplicate=.TRUE.
            ENDIF
            linsert=.FALSE.
          ELSEIF(searchPoint1%sortval < d .AND. d < searchPoint2%sortval) THEN
            thisPoint%next => searchPoint2
            searchPoint1%next => thisPoint
            NULLIFY(thisPoint)
            linsert=.FALSE.
          ENDIF
          searchPoint1 => searchPoint2
          IF(.NOT.ASSOCIATED(searchPoint2%next)) linsert=.FALSE.
        ENDDO
      ENDIF
      NULLIFY(searchPoint1)
      NULLIFY(searchPoint2)
    ENDSELECT
  ENDIF
ENDSUBROUTINE insert_LinkedListPointType
!
!-------------------------------------------------------------------------------
!> @brief Clears a linked list of PointTypes.
!> @param firstPoint the first element in the linked list
!>
SUBROUTINE ClearLinkedListPointType(firstPoint)
  TYPE(LinkedListPointType),POINTER :: firstPoint
  TYPE(LinkedListPointType),POINTER :: thisPoint
  DO WHILE(ASSOCIATED(firstPoint))
    thisPoint => firstPoint
    CALL thisPoint%p%clear()
    firstPoint => thisPoint%next
    DEALLOCATE(thisPoint)
  ENDDO
ENDSUBROUTINE ClearLinkedListPointType
!
ENDMODULE Geom_Points


  module fluid_model_thindisk

  use class_four_vector
  use kerr, only: calc_rms, krolikc, ledd
  use phys_constants, only: G, c2, pi, sigb, msun

  implicit none

  namelist /thindisk/ mbh, mdot

  real :: mbh, mdot, rin, rout

  interface thindisk_vals
    module procedure thindisk_vals
  end interface

  interface init_thindisk
     module procedure init_thindisk
  end interface

  contains

    subroutine read_thindisk_inputs(ifile)
    character(len=20), intent(in) :: ifile
    open(unit=8,file=ifile,form='formatted',status='old')
    read(8,nml=thindisk)
    close(unit=8)
    end subroutine read_thindisk_inputs

    subroutine init_thindisk(a,ifile,mdott,mbht,rint,routt)
    real, intent(in) :: a
    character(len=20), intent(in), optional :: ifile
    character(len=20) :: default_ifile='thindisk.in'
    real, intent(in), optional :: mdott,mbht,rint,routt
!    write(6,*) 'init thindisk spin: ',a
    if (present(mdott)) then
       mdot = mdott
       mbh = mbht
       rin = rint
       rout = routt
    else
       if (present(ifile)) then
          call read_thindisk_inputs(ifile)
       else
          call read_thindisk_inputs(default_ifile)
       endif
    endif
    end subroutine init_thindisk

    subroutine thindisk_vals(r,th,a,T,omega)
      real, intent(in), dimension(:) :: r,th
      real, intent(in) :: a
      real, intent(out), dimension(size(r)) :: T, omega
      real :: rms,T0,lbh, Mdotedd
      real, dimension(size(r)) :: b,kc,d,ar,lc,hc,om
      real, dimension(size(r),10) :: metric
      lbh=MBH*msun*G/c2
      b=1.-3./r+2.*a/r**(3./2.)
      rms=calc_rms(a)
      rin=max(rms,rin)
      kc=krolikc(r,a)
      d=r*r-2.*r+a*a
      lc=(rms*rms-2.*a*sqrt(rms)+a*a)/(rms**1.5-2.*sqrt(rms)+a)
      hc=(2.*r-a*lc)/d
      ar=(r*r+a*a)**2.-a*a*d*sin(th)**2.
      om=2.*a*r/ar
      Mdotedd=ledd(MBH)/c2
!      write(6,*) 'T0: ',pi,G,MBH,msun,Mdot,Mdotedd,lbh,sigb,real(MBH*msun)
!      write(6,*) 'mbh: ',mbh,msun,mdot,mdotedd,lbh
      T0=(3.0/8.0/pi*G*MBH*msun*Mdot*Mdotedd/lbh/lbh/lbh/sigb)**(.25)
!      write(6,*) 'T0val: ',T0
      where(r.gt.rms)
        omega=max(1./(r**(3./2.)+a),om)
      elsewhere
        omega=max((lc+a*hc)/(r*r+2.*r*(1.+hc)),om)
      endwhere
      where(r.gt.rin.and.r.lt.rout)
         T=T0*(kc/b/r**3.)**(1./4.)
      elsewhere
         T=T0/1d5
      end where
!        write(6,*) 'T: ',r,rms,T,T0,MBH,Mdot
     end subroutine thindisk_vals

  end module fluid_model_thindisk


      subroutine ct2q(c1,q2,t2,ect2q)

      implicit double precision(a-h,o-z)

      dimension q2(3,3),t2(3,3)

c  this subroutine evaluates the quadrupole-quadrupole
c  electrostatic interaction

      dimension a(6),b(10)

      a(1)=t2(1,1)
      a(2)=t2(1,2)
      a(3)=t2(1,3)
      a(4)=t2(2,2)
      a(5)=t2(2,3)
      a(6)=t2(3,3)

      b(1)=q2(1,1)
      b(2)=2.d0*q2(1,2)
      b(3)=2.d0*q2(1,3)
      b(4)=q2(2,2)
      b(5)=2.d0*q2(2,3)
      b(6)=q2(3,3)

      ect2q=c1*(a(1)*b(1)+a(2)*b(2)+a(3)*b(3)+a(4)*b(4)+
     .      a(5)*b(5)+a(6)*b(6))

      return
      end