!_______________________________________________________________________
      SUBROUTINE HNDIAG(NMAX,N,M,HH,NN,E,EN,FF,DD,GG,RR,WW,Z,NOS,IS,IFL)
!
!......................................................................C
!     diagonalizes    HH*FF = E * NN*FF                                C
!     diagonalizes    NN*DD = EN * DD                                  C
!     eigenvalus of the norm EN<EPS are neglected                      C
!     IS = 0   only eigenvalues E,EN  and eigenvectors GG,DD           C
!     IS = 1   also eigenvectors  FF (possibly redundant)              C
!     IS = 2   also covariant components  WW = NN*FF                   C
!     IS = 3   also orthogonal wave functions RR = DD * GG             C
!              NN**(-1/2) * HH * NN**(-1/2) * RR  =  E  RR             C
!                                                                      C
!     HH(N,N),GG(N,N),NN(N,N),DD(N,N),FF(N,N),WW(N,N),RR(N,N)          C
!     E(N)  eigenvalues of the generalized eigenvalue problem          C
!     EN(N) eigenvalues of the norm matrix NN                          C
!     Z(N)  auxiliary field                                            C
!                                                                      C
!......................................................................C
      USE VAPHFB_Par
      implicit real*8 (a-h,o-z)
      real*8 NN
!
      dimension HH(NMAX,N),NN(NMAX,N),GG(NMAX,NMAX),DD(NMAX,N),FF(NMAX,N)
      DIMENSION WW(NMAX,N),RR(NMAX,N)
      dimension E(N),E1(N),EN(N),Z(N)
!------------------------------------
      EPS = GCM%eps !1.d-6
      IFL = 0
      do K=1,N
         do I=1,N
            DD(I,K)=-NN(I,K)
        enddo
      enddo
!-----diagonalization of NN
      CALL SDIAG(NMAX,N,DD,EN,DD,Z,1)
!
      do I=1,N
         EN(I)=-EN(I)
      enddo
!     ............... number of natural state is defined by the cutoff in the eigen values of norm
!--- find out all the eigenvalues which are large enough compared with the largest one,
!    and drop the small ones
      do 1 I=1,N
         IF (EN(I)/EN(1).LT.EPS) GOTO 2
    1    CONTINUE
    2 M=I-1
!     ............... number of natural state is given by NOS
      M=min(M,NOS)
      IF (M.LE.0) THEN
         WRITE(6,*) ' SUBR. HNDIAG: NO EIGENVALUE OF N LARGER THAN EPS'
         IFL=1
         RETURN
      ENDIF
!----- up here, all left eigenvalues are large enough, the number is M
!      parepare the new Hamiltonian in the collective subspace
!-----
!----- DD = u
      do K=1,M
         S=1./SQRT(EN(K))
         do I=1,N
           RR(I,K)=DD(I,K)*S
         enddo !I
      enddo !K
!-------------
      do K=1,M
         do I=1,N
            S=0.
            do L=1,N
               S=S+HH(I,L)*RR(L,K)
            enddo !L
            E1(I)=S
         enddo !I
         do J=K,M
            S=0.
            do L=1,N
               S=S+RR(L,J)*E1(L)
            enddo ! L
               GG(J,K)=S
         enddo !J
       enddo !K
  100 format(5x,12f10.5)

!---- diagonalization of the new Hamiltonian
!
      CALL sdiag(NMAX,M,GG,E,GG,Z,1) ! dim(E) = M
!
!     calculation of the contra-variant components FF
      IF (IS.EQ.0) RETURN
      CALL MAB(NMAX,NMAX,NMAX,N,M,M,RR,GG,FF,1,0)
!
!     calculation of the co-variant components WW (overlaps)
      IF (IS.LT.2) RETURN
      CALL MAB(NMAX,NMAX,NMAX,N,N,M,NN,FF,WW,1,0)
!
!     BESTIMMUNG DER ORTHOGONALEN WELLENFUNKTIONEN RR
      IF (IS.LT.3) RETURN
!     calculation of the orthogonal wave functions RR
      CALL MAB(NMAX,NMAX,NMAX,N,M,M,DD,GG,RR,1,0)
!-----
      RETURN
!-end-HNDIAG
      END
!_______________________________________________________________________
      subroutine mab(ma,mb,mc,n1,n2,n3,a,b,c,iph,is)
!
!......................................................................
!
      implicit real*8 (a-h,o-z)
!
      dimension a(ma,ma),b(mb,mb),c(mc,mc)
!      dimension a(n1,n2),b(n2,n3),c(n1,n3)
!
      if (is.eq.0) then
         if (iph.lt.0) then
            do i = 1,n1
            do k = 1,n3
               s = 0.0d0
               do l = 1,n2
                  s = s+a(i,l)*b(l,k)
               enddo
               c(i,k) = - s
            enddo
            enddo
         else
            do i = 1,n1
            do k = 1,n3
               s = 0.0d0
               do l = 1,n2
                  s = s+a(i,l)*b(l,k)
               enddo
               c(i,k) = s
            enddo
            enddo
         endif
      else
         if (iph.lt.0) then
            do i = 1,n1
            do k = 1,n3
               s = c(i,k)
               do l = 1,n2
                  s = s-a(i,l)*b(l,k)
               enddo
               c(i,k) = s
            enddo
            enddo
        else
            do i = 1,n1
            do k = 1,n3
               s = c(i,k)
               do l = 1,n2
                  s = s+a(i,l)*b(l,k)
               enddo
               c(i,k)=s
            enddo
            enddo
         endif
      endif
      return
!-end-MAB
      end


program main
  use mod_monolis
  implicit none
  type(monolis_structure) :: mat !> 疎行列変数
  integer(kint) :: nnode, nelem, nbase_func, i
  real(kdouble) :: resid
  integer(kint), allocatable :: elem(:,:)
  real(kdouble), allocatable :: node(:,:), coef(:), B(:), X(:)
  character :: fname*128

  call monolis_set_debug(.true.)

  call monolis_global_initialize()

  fname = "node.dat"
  call monolis_input_mesh_node(fname, nnode, node)

  fname = "elem.dat"
  call monolis_input_mesh_elem(fname, nelem, nbase_func, elem)

  open(20, file = "coef.dat", status = "old")
    read(20,*) i
    if(i /= nelem) stop "ncoef /= nelem"
    allocate(coef(nelem), source = 0.0d0)
    do i = 1, nelem
      read(20,*) coef(i)
    enddo
  close(20)

  call monolis_initialize(mat, "./") !> 疎行列変数の初期化

  call monolis_get_nonzero_pattern(mat, nnode, nbase_func, 1, nelem, elem)

  do i = 1, nelem
    if(elem(1,i) == elem(2,i))then
      call monolis_add_scalar_to_sparse_matrix(mat, elem(1,i), elem(2,i), 1, 1, coef(i))
    else
      call monolis_add_scalar_to_sparse_matrix(mat, elem(1,i), elem(2,i), 1, 1, coef(i))
      call monolis_add_scalar_to_sparse_matrix(mat, elem(2,i), elem(1,i), 1, 1, coef(i))
    endif
  enddo

  allocate(B(nnode), source = 0.0d0)
  allocate(X(nnode), source = 0.0d0)

  X = 1.0d0
  call monolis_matvec_product(mat, X, B)
  X = 0.0d0

  call monolis_solve(mat, B, X)

  resid = 0.0d0
  do i = 1, nnode
    resid = resid + (X(i) - 1.0d0)**2
  enddo
  write(*,*)"resid: ", dsqrt(resid)

  call monolis_finalize(mat) !> 疎行列変数の解放

  call monolis_global_finalize()

end program main


c****************************************************************

	subroutine look_coord_conv(l0,x0,l,x)

c****************************************************************
c**
c**	FILE NAME: look_coord_conv.f
c**
c**     DATE WRITTEN: 4/20/2017
c**
c**     PROGRAMMER:Cunren Liang
c**
c** 	FUNCTIONAL DESCRIPTION: The subroutine calculates the
c**     coordinate x with number of looks l corresponding to
c**     x0 with number of looks l0
c**
c**     ROUTINES CALLED:none
c**
c**     NOTES: none
c**
c**     UPDATE LOG:
c**
c*****************************************************************

       	implicit none

c	INPUT VARIABLES:
        integer l0
        real*8  x0
        integer l

c   	OUTPUT VARIABLES:see input

c	LOCAL VARIABLES:
	real*8 x

c  	PROCESSING STEPS:

c       compute x

        x = x0 * l0 / l + (l0-l)/(2.0*l)

        end


! Examples of single region stencils
!
! Each of these four stencils is expressed without using any
! combining operators (e.g. + or *)
program singleregion
implicit none

integer i
parameter (n=10)
real a(0:imax,0:imax)
real b(0:imax,0:imax)
real c(0:imax,0:imax)
real d(0:imax,0:imax,0:imax)
real e(0:imax,0:imax)
real f(0:imax,0:imax)

! A forwards stencil (depth 2)
do i=1, n
 != stencil readOnce, forward(depth=2, dim=1) :: a
 e(i, 0) = a(i, 0) + a(i+1, 0) + a(i+2, 0)
end do

! A backward stencil (depth 2)
do i=1, n
 != stencil readOnce, backward(depth=2, dim=1) :: b
 f(i) = b(i) + b(i-1) + b(i-2)
end do

! A centered stencil (depth 1)
do i=1, n
 do j=1, n
  != stencil readOnce, centered(depth=1, dim=1) :: c
  e(i, j) = (c(j-1) + c(j) + c(j+1))/3.0
 end do
end do

! A pointed stencil
do i=1, n
 do j=1, n
  != stencil readOnce, pointed(dim=3) :: d
  e(i, j) = d(0, 0, i)
 end do
end do

! A (backwards, depth 2) non-pointed stencil
do i=1, n
 != stencil readOnce, backward(depth=2, dim=1, nonpointed) :: a
 b(i) = a(i-1) + 10*a(i-2)
end do

end


!*==dsposv.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  DSPOSV computes the solution to system of linear equations A * X = B for PO matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DSPOSV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK,
!                          SWORK, ITER, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, ITER, LDA, LDB, LDX, N, NRHS
!       ..
!       .. Array Arguments ..
!       REAL               SWORK( * )
!       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( N, * ),
!      $                   X( LDX, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DSPOSV computes the solution to a real system of linear equations
!>    A * X = B,
!> where A is an N-by-N symmetric positive definite matrix and X and B
!> are N-by-NRHS matrices.
!>
!> DSPOSV first attempts to factorize the matrix in SINGLE PRECISION
!> and use this factorization within an iterative refinement procedure
!> to produce a solution with DOUBLE PRECISION normwise backward error
!> quality (see below). If the approach fails the method switches to a
!> DOUBLE PRECISION factorization and solve.
!>
!> The iterative refinement is not going to be a winning strategy if
!> the ratio SINGLE PRECISION performance over DOUBLE PRECISION
!> performance is too small. A reasonable strategy should take the
!> number of right-hand sides and the size of the matrix into account.
!> This might be done with a call to ILAENV in the future. Up to now, we
!> always try iterative refinement.
!>
!> The iterative refinement process is stopped if
!>     ITER > ITERMAX
!> or for all the RHS we have:
!>     RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX
!> where
!>     o ITER is the number of the current iteration in the iterative
!>       refinement process
!>     o RNRM is the infinity-norm of the residual
!>     o XNRM is the infinity-norm of the solution
!>     o ANRM is the infinity-operator-norm of the matrix A
!>     o EPS is the machine epsilon returned by DLAMCH('Epsilon')
!> The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00
!> respectively.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of linear equations, i.e., the order of the
!>          matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array,
!>          dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>          On exit, if iterative refinement has been successfully used
!>          (INFO = 0 and ITER >= 0, see description below), then A is
!>          unchanged, if double precision factorization has been used
!>          (INFO = 0 and ITER < 0, see description below), then the
!>          array A contains the factor U or L from the Cholesky
!>          factorization A = U**T*U or A = L*L**T.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          The N-by-NRHS right hand side matrix B.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] X
!> \verbatim
!>          X is DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          If INFO = 0, the N-by-NRHS solution matrix X.
!> \endverbatim
!>
!> \param[in] LDX
!> \verbatim
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (N,NRHS)
!>          This array is used to hold the residual vectors.
!> \endverbatim
!>
!> \param[out] SWORK
!> \verbatim
!>          SWORK is REAL array, dimension (N*(N+NRHS))
!>          This array is used to use the single precision matrix and the
!>          right-hand sides or solutions in single precision.
!> \endverbatim
!>
!> \param[out] ITER
!> \verbatim
!>          ITER is INTEGER
!>          < 0: iterative refinement has failed, double precision
!>               factorization has been performed
!>               -1 : the routine fell back to full precision for
!>                    implementation- or machine-specific reasons
!>               -2 : narrowing the precision induced an overflow,
!>                    the routine fell back to full precision
!>               -3 : failure of SPOTRF
!>               -31: stop the iterative refinement after the 30th
!>                    iterations
!>          > 0: iterative refinement has been successfully used.
!>               Returns the number of iterations
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, the leading minor of order i of (DOUBLE
!>                PRECISION) A is not positive definite, so the
!>                factorization could not be completed, and the solution
!>                has not been computed.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup doublePOsolve
!
!  =====================================================================
      SUBROUTINE DSPOSV(Uplo,N,Nrhs,A,Lda,B,Ldb,X,Ldx,Work,Swork,Iter,  &
     &                  Info)
      IMPLICIT NONE
!*--DSPOSV203
!
!  -- LAPACK driver routine (version 3.8.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , Iter , Lda , Ldb , Ldx , N , Nrhs
!     ..
!     .. Array Arguments ..
      REAL Swork(*)
      DOUBLE PRECISION A(Lda,*) , B(Ldb,*) , Work(N,*) , X(Ldx,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      LOGICAL DOITREF
      PARAMETER (DOITREF=.TRUE.)
!
      INTEGER ITERMAX
      PARAMETER (ITERMAX=30)
!
      DOUBLE PRECISION BWDMAX
      PARAMETER (BWDMAX=1.0E+00)
!
      DOUBLE PRECISION NEGONE , ONE
      PARAMETER (NEGONE=-1.0D+0,ONE=1.0D+0)
!
!     .. Local Scalars ..
      INTEGER i , iiter , ptsa , ptsx
      DOUBLE PRECISION anrm , cte , eps , rnrm , xnrm
!
!     .. External Subroutines ..
      EXTERNAL DAXPY , DSYMM , DLACPY , DLAT2S , DLAG2S , SLAG2D ,      &
     &         SPOTRF , SPOTRS , DPOTRF , DPOTRS , XERBLA
!     ..
!     .. External Functions ..
      INTEGER IDAMAX
      DOUBLE PRECISION DLAMCH , DLANSY
      LOGICAL LSAME
      EXTERNAL IDAMAX , DLAMCH , DLANSY , LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , MAX , SQRT
!     ..
!     .. Executable Statements ..
!
      Info = 0
      Iter = 0
!
!     Test the input parameters.
!
      IF ( .NOT.LSAME(Uplo,'U') .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Nrhs<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldx<MAX(1,N) ) THEN
         Info = -9
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DSPOSV',-Info)
         RETURN
      ENDIF
!
!     Quick return if (N.EQ.0).
!
      IF ( N==0 ) RETURN
!
!     Skip single precision iterative refinement if a priori slower
!     than double precision factorization.
!
      IF ( .NOT.DOITREF ) THEN
         Iter = -1
         GOTO 300
      ENDIF
!
!     Compute some constants.
!
      anrm = DLANSY('I',Uplo,N,A,Lda,Work)
      eps = DLAMCH('Epsilon')
      cte = anrm*eps*SQRT(DBLE(N))*BWDMAX
!
!     Set the indices PTSA, PTSX for referencing SA and SX in SWORK.
!
      ptsa = 1
      ptsx = ptsa + N*N
!
!     Convert B from double precision to single precision and store the
!     result in SX.
!
      CALL DLAG2S(N,Nrhs,B,Ldb,Swork(ptsx),N,Info)
!
      IF ( Info/=0 ) THEN
         Iter = -2
         GOTO 300
      ENDIF
!
!     Convert A from double precision to single precision and store the
!     result in SA.
!
      CALL DLAT2S(Uplo,N,A,Lda,Swork(ptsa),N,Info)
!
      IF ( Info/=0 ) THEN
         Iter = -2
         GOTO 300
      ENDIF
!
!     Compute the Cholesky factorization of SA.
!
      CALL SPOTRF(Uplo,N,Swork(ptsa),N,Info)
!
      IF ( Info/=0 ) THEN
         Iter = -3
         GOTO 300
      ENDIF
!
!     Solve the system SA*SX = SB.
!
      CALL SPOTRS(Uplo,N,Nrhs,Swork(ptsa),N,Swork(ptsx),N,Info)
!
!     Convert SX back to double precision
!
      CALL SLAG2D(N,Nrhs,Swork(ptsx),N,X,Ldx,Info)
!
!     Compute R = B - AX (R is WORK).
!
      CALL DLACPY('All',N,Nrhs,B,Ldb,Work,N)
!
      CALL DSYMM('Left',Uplo,N,Nrhs,NEGONE,A,Lda,X,Ldx,ONE,Work,N)
!
!     Check whether the NRHS normwise backward errors satisfy the
!     stopping criterion. If yes, set ITER=0 and return.
!
      DO i = 1 , Nrhs
         xnrm = ABS(X(IDAMAX(N,X(1,i),1),i))
         rnrm = ABS(Work(IDAMAX(N,Work(1,i),1),i))
         IF ( rnrm>xnrm*cte ) GOTO 100
      ENDDO
!
!     If we are here, the NRHS normwise backward errors satisfy the
!     stopping criterion. We are good to exit.
!
      Iter = 0
      RETURN
!
!
 100  DO iiter = 1 , ITERMAX
!
!        Convert R (in WORK) from double precision to single precision
!        and store the result in SX.
!
         CALL DLAG2S(N,Nrhs,Work,N,Swork(ptsx),N,Info)
!
         IF ( Info/=0 ) THEN
            Iter = -2
            GOTO 300
         ENDIF
!
!        Solve the system SA*SX = SR.
!
         CALL SPOTRS(Uplo,N,Nrhs,Swork(ptsa),N,Swork(ptsx),N,Info)
!
!        Convert SX back to double precision and update the current
!        iterate.
!
         CALL SLAG2D(N,Nrhs,Swork(ptsx),N,Work,N,Info)
!
         DO i = 1 , Nrhs
            CALL DAXPY(N,ONE,Work(1,i),1,X(1,i),1)
         ENDDO
!
!        Compute R = B - AX (R is WORK).
!
         CALL DLACPY('All',N,Nrhs,B,Ldb,Work,N)
!
         CALL DSYMM('L',Uplo,N,Nrhs,NEGONE,A,Lda,X,Ldx,ONE,Work,N)
!
!        Check whether the NRHS normwise backward errors satisfy the
!        stopping criterion. If yes, set ITER=IITER>0 and return.
!
         DO i = 1 , Nrhs
            xnrm = ABS(X(IDAMAX(N,X(1,i),1),i))
            rnrm = ABS(Work(IDAMAX(N,Work(1,i),1),i))
            IF ( rnrm>xnrm*cte ) GOTO 200
         ENDDO
!
!        If we are here, the NRHS normwise backward errors satisfy the
!        stopping criterion, we are good to exit.
!
         Iter = iiter
!
         RETURN
!
!
 200  ENDDO
!
!     If we are at this place of the code, this is because we have
!     performed ITER=ITERMAX iterations and never satisfied the
!     stopping criterion, set up the ITER flag accordingly and follow
!     up on double precision routine.
!
      Iter = -ITERMAX - 1
!
!
!     Single-precision iterative refinement failed to converge to a
!     satisfactory solution, so we resort to double precision.
!
 300  CALL DPOTRF(Uplo,N,A,Lda,Info)
!
      IF ( Info/=0 ) RETURN
!
      CALL DLACPY('All',N,Nrhs,B,Ldb,X,Ldx)
      CALL DPOTRS(Uplo,N,Nrhs,A,Lda,X,Ldx,Info)
!
!
!     End of DSPOSV.
!
      END SUBROUTINE DSPOSV


c fishpk28 from portlib                                  12/30/83
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                        f i s h p a k                          *
c     *                                                               *
c     *                                                               *
c     *     a package of fortran subprograms for the solution of      *
c     *                                                               *
c     *      separable elliptic partial differential equations        *
c     *                                                               *
c     *                  (version 3.1 , october 1980)                  *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *        john adams, paul swarztrauber and roland sweet         *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the national center for atmospheric research          *
c     *                                                               *
c     *                boulder, colorado  (80307)  u.s.a.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the national science foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c     program to illustrate the use of hwsssp
c
      program thwsssp
      dimension       f(19,73)   ,bdtf(73)   ,sint(19)   ,sinp(73)   ,
     1                w(600)
      dimension bdts(1), bdps(1), bdpf(1)
c
      pi = pimach(dum)
      ts = 0
      tf = pi/2.
      m = 18
      mbdcnd = 6
      ps = 0
      pf = pi+pi
      n = 72
      nbdcnd = 0
      elmbda = 0.
      idimf = 19
c
c     generate sines for use in subsequent computations
c
      dtheta = tf/float(m)
      mp1 = m+1
      do 101 i=1,mp1
         sint(i) = sin(float(i-1)*dtheta)
  101 continue
      dphi = (pi+pi)/float(n)
      np1 = n+1
      do 102 j=1,np1
         sinp(j) = sin(float(j-1)*dphi)
  102 continue
c
c     compute right side of equation and store in f
c
      do 104 j=1,np1
         do 103 i=1,mp1
            f(i,j) = 2.-6.*(sint(i)*sinp(j))**2
  103    continue
  104 continue
c
c     store derivative data at the equator
c
      do 105 j=1,np1
         bdtf(j) = 0.
  105 continue
c
      call hwsssp (ts,tf,m,mbdcnd,bdts,bdtf,ps,pf,n,nbdcnd,bdps,bdpf,
     1             elmbda,f,idimf,pertrb,ierror,w)
c
c     compute discretization error. since problem is singular, the
c     solution must be normalized.
c
      err = 0
      do 107 j=1,np1
         do 106 i=1,mp1
            z = abs(f(i,j)-(sint(i)*sinp(j))**2-f(1,1))
            if (z .gt. err) err = z
  106    continue
  107 continue
c
      iw = int(w(1))
      print 1001 , ierror,err,iw
      stop
c
c
 1001 format (1h1,20x,25hsubroutine hwsssp example///
     1        10x,46hthe output from the ncar control data 7600 was//
     2        32x,10hierror = 0/
     3        18x,34hdiscretization error = 3.38107e-03/
     4        12x,32hrequired length of w array = 600//
     5        10x,32hthe output from your computer is//
     6        32x,8hierror =,i2/18x,22hdiscretization error =,e12.5 /
     7        12x,28hrequired length of w array =,i4)
c
      end
c


let Var = Int;;

datatype Type =
  UnitTy of (u:Unit)
| Arrow of (dom:Type) (range:Type)
| Failure of (u:Unit)
/* Not sure what to do about exceptions... */
;;

let unitty = UnitTy unit;;
let failure = Failure unit;;

datatype Term =
  UnitTm of (u:Unit)
| Variable of (x:Var)
| Lambda of (ty:Type) (body:Term)
| App of (func:Term) (arg:Term)
;;

let unittm = UnitTm unit;;

datatype Context =
  EmptyCtx of (u:Unit)
| Extend of (ty:Type) (ctx:Context)
;;

let emptyctx = EmptyCtx unit;;

let rec print_ty (ty:Type) : Unit =
  caseType ty Unit
    (fn u => print "Unit")
    (fn dom range =>
       print "("; print_ty dom; print " -> "; print_ty range; print ")")
    (fn u => print "FAILURE")
;;

let rec print_tm (tm:Term) : Unit =
  caseTerm tm Unit
    (fn u => print "unit")
    (fn x => print x)
    (fn ty body =>
      print "(fun:"; print_ty ty; print "."; print_tm body; print ")")
    (fn f arg =>
      print "("; print_tm f; print " "; print_tm arg; print ")")
;;

let get_type (ctx:Context) (x:Var) : Type =
  let rec get_type_rec (ctx:Context) (count:Var) (x:Var) : Type =
    caseContext ctx Type
      (fn u => failure)
      (fn ty ctx_tail =>
        if [Type] count = x then ty else get_type_rec ctx_tail (count+1) x)
  in
  get_type_rec ctx 0 x
;;

let rec typeeq (ty1:Type) (ty2:Type) : Bool =
  caseType ty1 Bool
    (fn u => caseType ty2 Bool
               (fn u => true)
               (fn dom range => false)
               (fn u => false))
    (fn dom range => caseType ty2 Bool
               (fn u => false)
               (fn dom2 range2 => (typeeq dom dom2) && (typeeq range range2))
               (fn u => false))
    (fn u => false)
;;

let rec termeq (tm1:Term) (tm2:Term) : Bool =
  caseTerm tm1 Bool
     (fn u => caseTerm tm2 Bool
                (fn u => true)
                (fn x2 => false)
                (fn ty2 body2 => false)
                (fn f2 arg2 => false))
     (fn x1 => caseTerm tm2 Bool
                (fn u => false)
                (fn x2 => x1 = x2)
                (fn ty2 body2 => false)
                (fn f2 arg2 => false))
     (fn ty1 body1 => caseTerm tm2 Bool
                (fn u => false)
                (fn x2 => false)
                (fn ty2 body2 => (typeeq ty1 ty2) && (termeq body1 body2))
                (fn f2 arg2 => false))
     (fn f1 arg1 => caseTerm tm2 Bool
                (fn u => false)
                (fn x2 => false)
                (fn ty2 body2 => false)
                (fn f2 arg2 => (termeq f1 f2) && (termeq arg1 arg2)))
;;

let rec typeof (ctx:Context) (t:Term) : Type =
  caseTerm t Type
     (fn u => unitty)
     (fn x => get_type ctx x)
     (fn ty body => Arrow ty (typeof (Extend ty ctx) body))
     (fn func arg =>
       caseType (typeof ctx func) Type
         (fn u => Failure unit)
         (fn dom range =>
            let argty = typeof ctx arg in
            if [Type] typeeq argty dom
            then range
            else (Failure unit))
         (fn u => Failure unit))
;;

let is_well_typed (ctx:Context) (tm:Term) : Bool =
	caseType (typeof ctx tm) Bool
		(fn u => true)
		(fn dom range => true)
		(fn u => false)
;;

let rec isval (tm:Term) : Bool =
  caseTerm tm Bool
    (fn u => true)
    (fn x => true)
    (fn ty body => true)
    (fn func arg => false)
;;

let rec shift_above (threshold:Int) (distance:Int) (tm:Term) : Term =
  /* print "shift_above ";
  print threshold; print " "; print distance; newline unit; */
  caseTerm tm Term
    (fn u => tm)
    (fn x => if [Term] x >= threshold then Variable (x+distance) else tm)
    (fn ty body => Lambda ty (shift_above (threshold+1) distance body))
    (fn f arg => App (shift_above threshold distance f)
                     (shift_above threshold distance arg))
;;

let same_type_term (tm:Term) : * =
	(t : Term .
		if is_well_typed emptyctx tm then
			(typeeq (typeof emptyctx tm) (typeof emptyctx t))
		else
			true)
;;

let shift_tm (distance:Int) (tm:Term) : Term =
  /* print "shift_tm"; newline unit; */
  shift_above 0 distance tm;;

let rec subst_tm (x:Var) (into:Term) (inserted:Term) : Term =
  /* print "subst_tm"; newline unit; */
  caseTerm into Term
    (fn u => into)
    (fn y => if [Term] x = y then inserted else into)
    (fn ty body => Lambda ty (subst_tm (x+1) body (shift_tm 1 inserted)))
    (fn f arg => App (subst_tm x f inserted) (subst_tm x arg inserted))
;;

/*	Refining this return value created another Maybe without
	removing the one in eval1. NOTE: This function is
	ill-typed; the type Term is not sufficiently refined.  */
let subst_top_tm (body:Term) (arg:Term) : Term = /* (same_type_term body) = */
  /* print "subst_top_tm"; newline unit; */
  shift_tm (0 - 1) (subst_tm 0 body (shift_tm 1 arg))
;;

let rec eval1 (tm:Term/*.is_well_typed emptyctx tm*/) : (same_type_term tm) =
  let return_type =  same_type_term tm in
  /* print_tm tm; newline unit; */
  caseTerm tm return_type
     (fn u => tm)
     (fn x => tm)
     (fn ty body => tm)
     (fn func arg =>
       caseTerm func return_type
         (fn u => tm)
         (fn x => tm)
         (fn ty body =>
           if [return_type] isval arg then
             subst_top_tm body arg
           else
             App func (eval1 arg))
         (fn fn1 fn2 => App (eval1 func) arg))
;;

let rec eval_nf (tm:Term/*.is_well_typed emptyctx tm*/) : (same_type_term tm) =
	let tm2 = eval1 tm in
	if [same_type_term tm] (termeq tm tm2) then
		tm
	else (
		/*print_tm tm2; newline unit; */
		eval_nf tm2)
;;

/*
let identity = (Lambda unitty (Variable 0));;
let tm1 = (App identity unittm);;

print_tm tm1; newline unit;
print_tm (eval1 tm1); newline unit;;
print_tm (eval_nf tm1); newline unit;;
print_tm (eval_nf (App identity (App identity unittm))); newline unit;;

let church_numeral = Arrow (Arrow unitty unitty) (Arrow unitty unitty);;

let one =	(Lambda (Arrow unitty unitty)
				(Lambda unitty
					(App (Variable 1) (Variable 0))));;

let add =	(Lambda church_numeral
			(Lambda church_numeral
			(Lambda (Arrow unitty unitty)
			(Lambda unitty
				(App
					(App (Variable 3) (Variable 1))
						(App (App (Variable 2) (Variable 1)) (Variable 0))))
		)));;

print_tm one; newline unit;
print_ty (typeof emptyctx one); newline unit;;
print_ty (typeof emptyctx (App one identity)); newline unit;;
print_tm (App one identity); newline unit;;
print_tm (eval1 (App one identity)); newline unit;;
print_tm (eval_nf (App (App one identity) unittm)) ;;
print_tm (eval_nf (App (App add one) one));;

*/


subroutine read_phonon_array(arrayfile,rbin,x1,x2,nxdim,t1,t2,ntdim)
	implicit none
	real, dimension(10000,10000)   :: rbin
	real, dimension(10)          :: dummy
	character (len=200)          :: arrayfile
	integer                      :: it,ix

	real :: x1,x2,t1,t2,stnmin,stnmax,zsource
	integer :: ntdim,nxdim,iwstart,nray,nsurf

	real :: deldeg,delrad,degrad,sang,xbinwidth

	!f2py intent(in) arrayfile
	!f2py intent(out) rbin,x1,x2,nxdim,t1,t2,ntdim

	rbin=0.
	degrad=180./3.1415927

	open (11, file=arrayfile,form='unformatted')
	read (11) x1,x2,nxdim,t1,t2,ntdim,iwstart,stnmin,stnmax,zsource,zsource,nray,nsurf
	print *, x1,x2,nxdim,t1,t2,ntdim,iwstart,stnmin,stnmax,zsource,zsource,nray,nsurf
	read (11) dummy
	read (11) ((rbin(it,ix),it=1,ntdim),ix=1,nxdim)
	close (11)

	do ix=1,nxdim
		xbinwidth = (x2-x1)/real(nxdim-1)
		deldeg=(real(ix)-0.5)*xbinwidth + x1
		delrad=deldeg/degrad
		sang=sin(delrad)
		rbin(:,ix)=rbin(:,ix)/sang
		print *,'ix,deldeg,sang = ',ix,deldeg,sang
	end do

        call apply_spatial_filter(rbin, nxdim, ntdim, 10, 1)

	rbin=sqrt(rbin)

	return

end subroutine

subroutine apply_spatial_filter(A, nxdim, ntdim, itbuf, ixbuf)
        implicit none
        real, dimension(10000) :: tmp1
        real, dimension(10000,10000) :: A, B
        integer :: nxdim, ntdim, ii, jj, itbuf, ixbuf
        integer :: npts

        B=0.

        npts=(2*ixbuf+1) * (2*itbuf+1)

        do ii=1+itbuf,ntdim-itbuf
                do jj=1+ixbuf,nxdim-ixbuf
                        !tmp(1:(itbuf*ixbuf)) = reshape(A(ii-itbuf:ii+itbuf,jj-ixbuf:jj+ixbuf),(/itbuf*ixbuf/))
                  tmp1(1:npts) = reshape(A(ii-itbuf:ii+itbuf,jj-ixbuf:jj+ixbuf), (/npts/))
                  B(ii,jj)=sum(A(ii-itbuf:ii+itbuf,jj-ixbuf:jj+ixbuf))/npts
                  !call  SelectionSort(tmp1(1:npts))
                  !B(ii,jj) = tmp1((npts+1)/2)
                end do
        end do

        A=B

        return

contains

!-SelectionSort----------------------------------------------
! Subroutine to sort an array Item into ascending order using
! the simple selection sort algorithm.  For descending order
! change MINVAL to MAXVAL and MINLOC to MAXLOC.  Local
! variables used are:
!   NumItems         : number of elements in array Item
!   LargestItem      : largest item in current sublist
!   MAXLOC_array     : one-element array returned by MINLOC
!   LocationLmallest : location of LargestItem
!   I                : subscript
!
! Accepts:  Array Item
! Returns:  Array Item (modified) with elements in ascending
!           order
!
! Note:  Item is an assumed-shape array so a program unit that
!        calls this subroutine must:
!        1. contain this subroutine as an internal subprogram,
!        2. import this subroutine from a module, or
!        3. contain an interface block for this subroutine.
!--------------------------------------------------------------

SUBROUTINE SelectionSort(Item)

  REAL, DIMENSION(:), INTENT(INOUT) :: Item
  REAL :: LargestItem
  INTEGER :: NumItems, I, LocationLargest
  INTEGER, DIMENSION(1) :: MAXLOC_array

  NumItems = SIZE(Item)
  DO I = 1, NumItems - 1

     ! Find smallest item in the sublist
     ! Item(I), ..., Item(NumItems)

     LargestItem = MAXVAL(Item(I:NumItems))
     MAXLOC_array = MAXLOC(Item(I:NumItems))
     LocationLargest = (I - 1) + MAXLOC_array(1)

     ! Interchange largest item with Item(I) at
     ! beginning of sublist

     Item(LocationLargest) = Item(I)
     Item(I) = LargestItem

  END DO

END SUBROUTINE SelectionSort

end subroutine


	FUNCTION B912(X,Y,N)

c	Returns 912 A break amplitude for sed in (x,y).
c	The break is defined as the ratio of the average Fnu flux densities:
c	(800-900)/(1000-1100) (Bruzual (1983).

	real x(n),y(n),w(500),z(500)
	save a1,a2,a3,a4,i1,i2,i3,i4,x1,x2,x3,x4
	data icall/0/
	b912=0.
	if (x(1).ge.1100.) return
	if (icall.eq.0) then
		x1=800.
		call locate(x,n,x1,i1)
		a1=(x1-x(i1))/(x(i1+1)-x(i1))
		x2=900.
		call locate(x,n,x2,i2)
		a2=(x2-x(i2))/(x(i2+1)-x(i2))
		x3=1000.
		call locate(x,n,x3,i3)
		a3=(x3-x(i3))/(x(i3+1)-x(i3))
		x4=1100.
		call locate(x,n,x4,i4)
		a4=(x4-x(i4))/(x(i4+1)-x(i4))
		icall=1
	endif

c	Compute fluxes and transform to Fnu units
	i=1
	w(i)=x1
	z(i)=a1*y(i1+1)+(1.-a1)*y(i1)
	z(i)=z(i)*w(i)**2
	do j=i1+1,i2
	i=i+1
	w(i)=x(j)
	z(i)=y(j)*x(j)**2
	enddo
	i=i+1
	w(i)=x2
	z(i)=a2*y(i2+1)+(1.-a2)*y(i2)
	z(i)=z(i)*w(i)**2
	fl=trapz1(w,z,i)/(w(i)-w(1))
	i=1
	w(i)=x3
	z(i)=a3*y(i3+1)+(1.-a3)*y(i3)
	z(i)=z(i)*w(i)**2
	do j=i3+1,i4
	i=i+1
	w(i)=x(j)
	z(i)=y(j)*x(j)**2
	enddo
	i=i+1
	w(i)=x4
	z(i)=a4*y(i4+1)+(1.-a4)*y(i4)
	z(i)=z(i)*w(i)**2
	fr=trapz1(w,z,i)/(w(i)-w(1))
	if (fl.gt.0.) b912=fr/fl
	return
	end


program main
    use neb

    double precision, allocatable :: minima_array(:) ! This stores all possible minimumm
    double precision jump_amp, similarity, dx, max_rms, spring_const
    integer max_jumps, iter_max

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !! TODO: Ideally these will be read in from a .yml style file
    !! at some point, and the images in the neb will be set here
    !! currently that is set in neb.f90
    !!
    !! Parameters used by the alogrithm (flag - add 5 zeros to this!!)
    iter_max = 100000000
    max_jumps = 39

    !! Finding all the minima 1D+0
    jump_amp = 1D+0
    similarity = 1D-2

    !! Steepest descent parameters
    dx = 1D-4
    max_rms = 1D-9

    !! Spring const for neb method
    spring_const = 10D+0
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !! Seed the random number generator
    call seed_rng()

    !! Load the files for the GMM
    call fitness_init()

    !! This calculates all the minima and their corresponding energy
    !! Input: max_jumps, jump_amp, similarity, iter_max, dx, max_rms
    !! Output: minima array
    call find_minima(max_jumps, jump_amp, similarity, iter_max, dx, max_rms, minima_array)

    call write_minima(minima_array, NDIMENSION)
    !call read_minima(minima_array, NDIMENSION)

    !! Find all the barriers
    !! Input: minima_array, iter_max, dx, max_rms, spring_const
    !call find_paths(minima_array, iter_max, dx, max_rms, spring_const)

end program main


      include 'VICMAIN_FOR'
      subroutine main44
	implicit none
	integer*4 outunit,ind,cnt,count,def,nl,ns,sl,ss
	integer*4 i,j,dnmin,dnmax,x0,y0,quad
	integer*4 size(4),row1(2048),row2(2048)
	real*4 stangle,arc,ang,ang2,tangarc,c,s,t,t2,opp,opp2
	real*4 limit
	character*10 reflect
	byte dn(2048)
c
c	initialze variables
c
      sl=1
      ss=1
      dnmax=255
      dnmin=0
      stangle=0.
      arc=0.
      x0=0.
      y0=0.
	do i=1,2048
	    row1(i)=0
            row2(i)=0
	enddo
      call xvmessage('WEDGE version 2016-06-09',' ')
c      call xvsize(sl,ss,nl,ns,nli,nsi)
	call xvparm ('SIZE',size,count,def,4)
c	print *, 'def = ',def
	if (size(3).eq.0) then
	    call xvp ('NL',nl,cnt)
            call xvp ('NS',ns,cnt)
	else
	    nl=size(3)
	    ns=size(4)
        end if
	if (nl.gt.2048) then
		call xvmessage ('??E - Number of lines > 2048',' ')
		call abend
	endif
	if (ns.gt.2048) then
                call xvmessage ('??E - Number of samples > 2048',' ')
                call abend
        endif

c	print *, 'nl = ns = ',nl, ns
	call xvunit(outunit,'OUT',1,ind,' ')
	call xvopen(outunit,ind,'U_NL',nl,'U_NS',ns,'OP','WRITE',' ')
	call xvp('DNMAX',dnmax,cnt)
	call xvp('DNMIN',dnmin,cnt)
	call xvp('STANGLE',stangle,cnt)
	call xvp('ARC',arc,cnt)
	call xvp('X0',x0,cnt)
	if (cnt.eq.0) x0=ns/2
	call xvp('Y0',y0,cnt)
	if (cnt.eq.0) y0=nl/2
	reflect='reflect'
	call xvp('BOWTIE',reflect,cnt)
	if (reflect .eq.'bowtie') then
		call xvmessage ('??E - Bowtie opiton has not been implemented yet',' ')
		call abend
	endif
c	print *, 'reflect cnt = ',cnt
c	print *, 'reflect = ',reflect
c	print *, 'stangle, arc =', stangle, arc
c	print *, 'x0, y0 = ',x0,y0

	tangarc = stangle+arc
	limit = stangle+180.
	if ( tangarc.gt.limit) then
		call xvmessage ('??E - Quad1 - The sum of stangle and arc cannot be > 180',' ')
		call abend
	endif
	ang=stangle*3.14159/180.
	ang2=arc*3.14159/180.
c	ang3=(stangle+arc-90)*3.14159/180.
c	ang4=-stangle*3.14159/180.
c	print *, 'ang (radians) = ',ang
	c=cos(ang)
	s=sin(ang)
	t=tan(ang)
	t2=tan(ang+ang2)
c	t3=tan(ang3)
c	t4=tan(ang4)
	opp = y0*t
	opp2 = y0*t2
c	print *,'opp = ',opp
c	print *,'opp + arc = ',opp2,tangarc

	quad=0
c	Quadrants 1,1
	if (stangle.le.90. .and. tangarc.le.90.) then
	    quad=11		!(1,1)
	    do i=1,y0
		if (tangarc.gt.stangle) then
		   row1(i) = int((y0 - i )*t + 0.5) + y0
		   row2(i) = int((y0 - i )*t2 + 0.5) + y0
c		   print *, 'row1, row2 = ',i,row1(i),row2(i)
		else
                   row2(i) = int((y0 - i )*t + 0.5) + y0
                   row1(i) = int((y0 - i )*t2 + 0.5) + y0
c                   print *, 'row1, row2 = ',i,row1(i),row2(i)
		endif
	    enddo
c	Quadrants 1,2
	elseif (stangle.le.90. .and. tangarc.ge.90. .and. tangarc.le.180.) then
	    quad=12		!(1,2)
	    do i=1,y0
                   row1(i) = int((y0 - i )*t + 0.5) + y0
c                   print *, '!> row1 = ',i,row1(i)
	    enddo
	    do i=x0,ns
                   row2(i) = int((x0 - i )*t2 + 0.5) + x0
c                   print *, '!> row2 = ',i,row2(i)
            enddo
c 	Quadrants 1,3 - nothing greater than 180
	elseif (stangle.le.90. .and. tangarc.ge.180.) then
	    quad=13		!(1,3)
            do i=1,y0
                   row1(i) = int((y0 - i )*t + 0.5) + y0
c                   print *, '#> row1 = ',i,row1(i)
            enddo
  	    do i=y0,nl
                   row2(i) = int((y0 - i )*t2 + 0.5) + y0
c                   print *, '#> row2 = ',i,row2(i)
            enddo
c       Quadrants 2,2 -
        elseif (stangle.ge.90. .and. stangle.le.180. .and.tangarc.ge.90. .and. tangarc.le.180.) then
            quad=22             !(2,2)
	    do i=y0,nl
                   row1(i) = int((y0 - i )*t + 0.5) + y0
c                   print *, '@> row1 = ',i,row1(i)
            enddo
            do i=x0,ns
                   row2(i) = int((x0 - i )*t2 + 0.5) + x0
c                   print *, '@> row2 = ',i,row2(i)
            enddo
c       Quadrants 2,3
        elseif (stangle.ge.90. .and. stangle.le.180. .and.tangarc.ge.180. .and. tangarc.le.270.) then
	    quad=23
            do i=y0,nl
                   row1(i) = int((y0 - i )*t + 0.5) + y0
c                print *,'*> y0,t = ',y0,t,t2
c                   print *, '*> row1 = ',i,row1(i)
            enddo
            do i=y0,nl
                   row2(i) = int((y0 - i )*t2 + 0.5) + y0
c                   print *, '*> row2 = ',i,row2(i)
            enddo
        elseif (stangle.ge.90. .and. stangle.le.180. .and.tangarc.ge.270. ) then
            quad=24

c		print *, 'Quad24'
            do i=y0,nl
                   row1(i) = int((y0 - i )*t + 0.5) + y0
c                print *,'%> y0,t = ',y0,t,t2
c                   print *, '%> row1 = ',i,row1(i)
            enddo
            do i=1,y0
                   row2(i) = int((y0 - i )*t2 + 0.5) + y0
c                   print *, '%> row2 = ',i,row2(i)
            enddo

	endif
c	if (tang.le.90) then
	    do i=1,nl
            	do j=1,ns
		    dn(j) = dnmin
		    if (quad.eq.11) then
c			print *, 'i,j, quad = ',i,j, quad,row1(i),row2(i)
			if (j.ge.row1(i) .and. j.le.row2(i)) dn(j)=dnmax
		    elseif (quad.eq.12) then
c		        print *, 'i,j, quad = ',i,j, quad
		        if (j.ge.row1(i) .and. i.le.y0) dn(j)=dnmax
			if (j.ge.row2(i) .and. i.ge.y0) dn(j)=dnmax
		    elseif (quad.eq.13) then
c	                print *, 'i,j, quad = ',i,j, quad
			if (j.ge.row1(i) .and. i.le.y0) dn(j)=dnmax
			if (j.ge.row2(i) .and. i.ge.y0) dn(j)=dnmax
		    elseif (quad.eq.22) then
c			print *, 'i,j, quad = ',i,j, quad
			if (i.ge.y0 .and. j.ge.row2(i) .and. j.le.row1(i)) dn(j)=dnmax
		    elseif (quad.eq.23) then
c			print *, 'i,j, quad = ',i,j, quad
			if (i.ge.y0 .and. j.ge.row2(i) .and. j.le.row1(i)) dn(j)=dnmax
                    elseif (quad.eq.24) then
c			print *, 'i,j, quad = ',i,j, quad
			if (j.le.row2(i)) dn(j)=dnmax
			if (i.ge.y0 .and. j.le.row1(i)) dn(j)=dnmax
		    else
			dn(j)=dnmin
		    endif

	        enddo
	        call xvwrit(outunit,dn,ind,' ')
	    enddo
c	else
c	   do i=1,nl
c                do j=1,ns
c                    dn(j) = dnmin
c                    if (i.le.y0) then
c                       print *, 'j, row1(i), row2(i) = ',j, row1(i), row2(i)
c                        if (j.ge.row2(i).and.j.le.row1(i)) dn(j)=dnmax
cc                    endif
c                enddo
c                call xvwrit(outunit,dn,ind,' ')
c          enddo
c	endif
	call xvclose(outunit,ind,' ' )
	return
	end


        include 'VICMAIN_FOR'
c
        subroutine main44

        implicit none
c
        integer*4 status, def, count
	integer*4 dataformat,ninpfile
        integer*4 rdgr,wrgr,nextgr,putgr,getgr,clgr		!setgr

        real*4    viewelev, viewazi
        real*4    theta, phi, d2r
        real*4    x, y, z,  x2, y2
	real*4    rho, origin(3), zscale
        real*4    sinth, costh, costhcosph, sinthcosph, sinph
        real*4    costhsinph, sinthsinph, cosph

	logical*4 eof, zero
	character*3  dataform
        character*80  inpfile,outfile

        common /perspeccom/ dataformat, origin, zscale, rho,
     +                  sinth, costh, costhcosph, sinthcosph, sinph,
     +                  costhsinph, sinthsinph, cosph

       call ifmessage('PERSPEC version 2-10-2013 (64-bit) - rjb')

c______________________________________________________________________________
c                       start executable code
c------------------------------------------------------------------------------
c
        d2r = acos(-1.0)/180.0     !degree to radian conversion PI/180

        call xvparm('INP',inpfile,count,def,1)
          ninpfile=index(inpfile,'   ') - 1

        call xvp ('DATAFORM', dataform, count)
        if (dataform(1:3) .eq. 'XYZ') then              !X,Y,Z
            dataformat = 1
        else if (dataform(1:3) .eq. 'YXZ') then         !Y,X,Z
            dataformat = 2
        else if (dataform(1:3) .eq. 'LSZ') then         !line,sample,Z
            dataformat = 3
        else
            dataformat = 1                              !default is X,Y,Z
        endif

        call xvp ('ZSCALE', zscale, count )

c        call xvparm ('SCALE', scale, count, def,1 )
c        autoscaling = (def .eq. 1)
c        if (scale .ne. 0.0)  scale = 1.0/scale

        call xvp ('DISTANCE', rho, count)
        call xvp ('ELEV', viewelev, count)
        call xvp ('AZIMUTH', viewazi, count)
        call xvp ('ORIGIN', origin(1), count)
        phi = 90.0 - viewelev
        theta = 90.0 - viewazi

        sinth = sin (theta * d2r)
        costh = cos (theta * d2r)
        sinph = sin (phi * d2r)
        cosph = cos (phi * d2r)
        costhcosph = costh*cosph
        sinthcosph = sinth*cosph
        costhsinph = costh*sinph
        sinthsinph = sinth*sinph

c                       Open the input graphics file
        status = rdgr (1,1,3)
        if (status.ne.1) call signalgr(1,status,1)

c                       If output exists then output 2-D perspective
        call xvparm ('OUT', outfile, count, def,1 )
        if (def .eq. 0) then
            status = wrgr ( 1, 2, 3 )
            if (status.ne.1) call signalgr(2,status,1)
            eof = .false.
            do while (.not. eof)
c                       scan for the beginning of a line string
                status = nextgr (1,eof,x,y,z)
                if (status.ne.1) call signalgr(1,status,1)
                if (eof) go to 199

                zero = .false.
                do while (.not. zero .and. .not. eof)
                    call perspective (x, y, z,  x2, y2)
                    status = putgr (2,x2,y2,0.0)
                    if (status.ne.1) call signalgr(2,status,1)
                    status = getgr ( 1,zero,eof,x,y,z)
                    if (status.ne.1) call signalgr(1,status,1)
                enddo
                status = putgr (2,0.0,0.0,0.0)
                if (status.ne.1) call signalgr(2,status,1)
            enddo
199         continue
            status = clgr (1)
            if (status.ne.1) call signalgr(1,status,1)
            status = clgr (2)

            if (status.ne.1) call signalgr(2,status,1)
            return
        endif

        return
        end

C***********************************************************
        subroutine perspective (x, y, z, x2, y2)
        implicit none
        real    x, y, z,  x2, y2
        real    xp, yp, zp, x_eye, y_eye, z_eye, tmp

        integer dataformat
        real    rho, origin(3), zscale
        real    sinth, costh, costhcosph, sinthcosph, sinph
        real    costhsinph, sinthsinph, cosph

        common /perspeccom/ dataformat, origin, zscale, rho,
     +                  sinth, costh, costhcosph, sinthcosph, sinph,
     +                  costhsinph, sinthsinph, cosph

        xp = x - origin(1)
        yp = y - origin(2)
        zp = (z - origin(3))/zscale
        if (dataformat .eq. 2) then
            tmp = xp
            xp = yp
            yp = tmp
        else if (dataformat .eq. 3) then
            tmp = xp
            xp = yp
            yp = -tmp
        endif
        x_eye = -xp*sinth + yp*costh
        y_eye = -xp*costhcosph - yp*sinthcosph  + zp*sinph
        z_eye = 1.0 - (xp*costhsinph + yp*sinth*sinph + zp*cosph)/rho
        x2 = x_eye/z_eye
        y2 = y_eye/z_eye

        return
        end


! SUMMA - Structure for Unifying Multiple Modeling Alternatives
! Copyright (C) 2014-2015 NCAR/RAL
!
! This file is part of SUMMA
!
! For more information see: http://www.ral.ucar.edu/projects/summa
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

MODULE multiconst
 USE nrtype
 ! define physical constants
 REAL(DP), PARAMETER           :: ave_slp        =  101325.0_dp ! mean sea level pressure              (Pa)
 REAL(DP), PARAMETER           :: vkc            =  0.4_dp      ! von Karman constant                  (-)
 REAL(DP), PARAMETER           :: satvpfrz       =  610.8_dp    ! sat vapour pressure at 273.16K       (Pa)
 REAL(DP), PARAMETER           :: w_ratio        =  0.622_dp    ! molecular ratio water to dry air     (-)
 REAL(DP), PARAMETER           :: R_da           =  287.053_dp  ! gas constant for dry air             (Pa K-1 m3 kg-1; J kg-1 K-1)
 REAL(DP), PARAMETER           :: R_wv           = 461.285_dp   ! gas constant for water vapor         (Pa K-1 m3 kg-1; J kg-1 K-1)
 !REAL(DP), PARAMETER           :: Rgas           =  8.314462_dp ! universal gas constant               (J mol-1 K-1)
 ! use same digits as Noah-MP -- chasing the difference
 REAL(DP), PARAMETER           :: Rgas           = 8.314_dp     ! universal gas constant               (J mol-1 K-1)
 REAL(DP), PARAMETER           :: gravity        = 9.80616_dp   ! acceleration of gravity              (m s-2)
 REAL(DP), PARAMETER           :: Cp_air         = 1005._dp     ! specific heat of air                 (J kg-1 K-1)
 REAL(DP), PARAMETER           :: Cp_ice         = 2114._dp     ! specific heat of ice                 (J kg-1 K-1)
 REAL(DP), PARAMETER           :: Cp_soil        = 850._dp      ! specific heat of soil                (J kg-1 K-1)
 REAL(DP), PARAMETER           :: Cp_water       = 4181._dp     ! specific heat of liquid water        (J kg-1 K-1)
 REAL(DP), PARAMETER           :: Tfreeze        = 273.16_dp    ! temperature at freezing              (K)
 REAL(DP), PARAMETER           :: TriplPt        = 273.16_dp    ! triple point of water                (K)
 REAL(DP), PARAMETER           :: LH_fus         = 333700.0_dp  ! latent heat of fusion                (J kg-1)
 REAL(DP), PARAMETER           :: LH_vap         = 2501000.0_dp ! latent heat of vaporization          (J kg-1)
 REAL(DP), PARAMETER           :: LH_sub         = 2834700.0_dp ! latent heat of sublimation           (J kg-1)
 REAL(DP), PARAMETER           :: sb             = 5.6705d-8    ! Stefan Boltzman constant             (W m-2 K-4)
 REAL(DP), PARAMETER           :: em_sno         = 0.99_dp      ! emissivity of snow                   (-)
 REAL(DP), PARAMETER           :: lambda_air     = 0.026_dp     ! thermal conductivity of air          (W m-1 K-1)
 REAL(DP), PARAMETER           :: lambda_ice     = 2.50_dp      ! thermal conductivity of ice          (W m-1 K-1)
 REAL(DP), PARAMETER           :: lambda_water   = 0.60_dp      ! thermal conductivity of liquid water (W m-1 K-1)
 REAL(DP), PARAMETER           :: iden_air       = 1.293_dp     ! intrinsic density of air             (kg m-3)
 REAL(DP), PARAMETER           :: iden_ice       = 917.0_dp     ! intrinsic density of ice             (kg m-3)
 REAL(DP), PARAMETER           :: iden_water     = 1000.0_dp    ! intrinsic density of liquid water    (kg m-3)
 REAL(DP), PARAMETER           :: secprday       = 86400._dp    ! number of seconds in a day
 REAL(DP), PARAMETER           :: secprhour      = 3600._dp     ! number of seconds in an hour
 REAL(DP), PARAMETER           :: secprmin       = 60._dp       ! number of seconds in a minute
 REAL(DP), PARAMETER           :: minprhour      = 60._dp       ! number of minutes in an hour

! define missing values
real(dp),parameter,public      :: quadMissing    = -9999._qp    ! missing quadruple precision number
real(dp),parameter,public      :: realMissing    = -9999._dp    ! missing double precision number
integer(i4b),parameter,public  :: integerMissing = -9999        ! missing integer

END MODULE multiconst


! { dg-do compile }
! { dg-options "-fmax-errors=40" }
! PR33162 INTRINSIC functions as ACTUAL argument
! Prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org>
program double_specs

real(kind=4) :: rr, x, y
real(kind=8) :: dr, dx, dy

x = .5
y = .7
dx = .5d0
dy = .5d0

r = dabs(x) ! { dg-error "must be double precision" }
r = dacos(x) ! { dg-error "must be double precision" }
r = dacosh(x) ! { dg-error "must be double precision" }
r = dasin(x) ! { dg-error "must be double precision" }
r = dasinh(x) ! { dg-error "must be double precision" }
r = datan(x) ! { dg-error "must be double precision" }
r = datanh(x) ! { dg-error "must be double precision" }
r = datan2(y, dx) ! { dg-error "must be double precision" }
r = datan2(dy, x) ! { dg-error "must be double precision" }
r = dbesj0(x) ! { dg-error "must be double precision" }
r = dbesj1(x) ! { dg-error "must be double precision" }
r = dbesy0(x) ! { dg-error "must be double precision" }
r = dbesy1(x) ! { dg-error "must be double precision" }
r = dcos(x) ! { dg-error "must be double precision" }
r = dcosh(x) ! { dg-error "must be double precision" }
r = ddim(x, dy) ! { dg-error "must be double precision" }
r = ddim(dx, y) ! { dg-error "must be double precision" }
r = derf(x) ! { dg-error "must be double precision" }
r = derfc(x) ! { dg-error "must be double precision" }
r = dexp(x) ! { dg-error "must be double precision" }
r = dgamma(x) ! { dg-error "must be double precision" }
r = dlgama(x) ! { dg-error "must be double precision" }
r = dlog(x) ! { dg-error "must be double precision" }
r = dlog10(x) ! { dg-error "must be double precision" }
r = dmod(x, dy) ! { dg-error "must be double precision" }
r = dmod(dx, y) ! { dg-error "must be double precision" }
r = dsign(x, dy) ! { dg-error "must be double precision" }
r = dsign(dx, y) ! { dg-error "must be double precision" }
r = dsin(x) ! { dg-error "must be double precision" }
r = dsinh(x) ! { dg-error "must be double precision" }
r = dsqrt(x) ! { dg-error "must be double precision" }
r = dtan(x) ! { dg-error "must be double precision" }
r = dtanh(x) ! { dg-error "must be double precision" }
dr = dprod(dx,y) ! { dg-error "must be default real" }
dr = dprod(x,dy) ! { dg-error "must be default real" }
dr = dprod(x,y)

end program double_specs


! How to make
!
! gcc -c spglib_f.c
! gfortran -c example.f90
! gfortran -o example example.o spglib_f.o ~/spglib/src/.libs/libsymspg.a

module defs_basis
  implicit none
  integer, parameter :: dp=kind(1.0d0)
end module defs_basis

subroutine write_syminfo( max_num_sym, num_atom, &
     lattice, symprec, atom_types, positions, &
     mesh, is_shift, is_time_reversal )

  use defs_basis

  implicit none

  ! Arguments ------------------------------------
  ! scalars
  integer, intent(in) :: num_atom, max_num_sym, is_time_reversal
  real(dp), intent(in) :: symprec
  ! arrays
  integer, intent(in), dimension(num_atom) :: atom_types
  integer, intent(in), dimension(3) :: mesh, is_shift
  real(dp), intent(in), dimension(3, 3) :: lattice
  real(dp), intent(in), dimension(3, num_atom) :: positions
  ! Local variables-------------------------------
  ! scalars
  integer :: i, j, counter, weight, sum_weight, space_group, num_sym, indent
  integer :: num_ir_grid
  character(len=11) :: international
  character(len=7) :: schoenflies
  character(len=30) :: space
  ! arrays
  integer, dimension(3, 3, max_num_sym) :: rotations
  integer, dimension(3, mesh(1)*mesh(2)*mesh(3)) :: grid_point
  integer, dimension(mesh(1)*mesh(2)*mesh(3)) :: map
  real(dp), dimension(3, max_num_sym) :: translations
  real(dp), dimension(3, 3) :: lattice_t
  !**************************************************************************

  space = "                              "

  ! transpose due to array order difference between C and fortran
  lattice_t = transpose( lattice )

  call spg_get_symmetry( num_sym, rotations, translations, max_num_sym, &
       & lattice_t, positions, atom_types, num_atom, symprec)

  ! transpose due to array order difference between C and fortran
  do i = 1, num_sym
     rotations(:,:,i) = transpose(rotations(:,:,i))
  end do

  indent = 1
  call spg_get_international( space_group, international, &
       & lattice_t, positions, atom_types, num_atom, symprec );

  if (space_group /= 0) then
     call spg_get_schoenflies( space_group, schoenflies, &
          & lattice_t, positions, atom_types, num_atom, symprec );

     print('(a, "space_group: ", i3)'), space(1:indent*2), space_group
     print('(a, "international: ", a, a)' ), space(1:indent*2), trim(international)
     print('(a, "schoenflies: ", a)'), space(1:indent*2), trim(schoenflies)
  else
     print '("Space group could not be found,")'
  end if

  print ('(a, "atom-type:")'), space(1:indent*2)
  do i = 1, num_atom
     print('(a, "- { type: ", i3, " }")'), space(1:indent*2), atom_types(i)
  end do
  print('(a, "real-basis:")'), space(1:indent*2)
  do i = 1, 3
     print('(a, "- [", f19.14, ", ", f19.14, ", ", f19.14, " ]")'), space(1:indent*2), lattice(:, i)
  end do
  print('(a, "position:")'), space(1:indent*2)
  do i = 1, num_atom
     print('(a, "- [", f17.14, ", ", f17.14, ", ", f17.14, " ]")'), space(1:indent*2), positions(:, i)
  end do
  print('(a, "operation:")'), space(1:indent*2)
  do i = 1, num_sym
     print('(a, "- rotation: #", i4)'), space(1:indent*2), i
     do j = 1, 3
        print('(a, "  - [", i3,",", i3,",", i3," ]")'), space(1:indent*2), rotations(j,:, i)
     end do
     print('(a, "  translation: [ ", f10.7,", ", f10.7,", ", f10.7," ]")'), space(1:indent*2), translations(:,i)
  end do

  print('(a, "reciprocal-mesh: [", i3, ", ", i3, ", ", i3, " ]")'), space(1:indent*2), mesh(:)
  print('(a, "- is_shift: [", i3, ", ", i3, ", ", i3, " ]")'), space(1:indent*2), is_shift(:)
  print('(a, "- is_time_reversal: ", i3)'), space(1:indent*2), is_time_reversal
  call spg_get_ir_reciprocal_mesh( num_ir_grid, grid_point, map, &
       mesh, is_shift, is_time_reversal, lattice, positions, &
       atom_types, num_atom, symprec )

  print('(a, "- num-ir-grid-point:", i4)'), space(1:indent*2), num_ir_grid
  print('(a, "- ir-grid-point:")'), space(1:indent*2)
  counter = 0
  sum_weight = 0
  do i = 1, mesh(1)*mesh(2)*mesh(3)
     if ( i == map(i) ) then
        ! Ad-hoc and intuitive implementation of weight
        weight = 0
        do j = 1, mesh(1)*mesh(2)*mesh(3)
           if ( i == map(j) ) then
              weight = weight + 1
           end if
        end do

        counter = counter + 1
        sum_weight = sum_weight + weight

        print('(a, "  - #", i4)'), space(1:indent*2), counter
        print('(a, "    address: [", i3, ", ", i3, ", ", i3, " ]")'), space(1:indent*2), grid_point(:, map(i))
        print('(a, "    weight: ", i4)'), space(1:indent*2), weight
     end if
  end do
  ! print('(a, "  sum_weight: ", i4)'), space(1:indent*2), sum_weight

end subroutine write_syminfo

program spglib_example

  use defs_basis

  implicit none

  ! max_sym is the expected maximum number of symmetry operations.
  ! This can be very big if it is supercell.
  integer :: max_num_sym=192

  integer :: num_atom
  real(dp) :: symprec
  integer, dimension(3, 3, 192) :: rotations
  real(dp), dimension(3, 192) :: translations
  real(dp), dimension(3, 3) :: lattice
  real(dp), dimension(3, 1000) :: positions
  integer, dimension(1000) :: atom_types

  integer, dimension(3) :: mesh=(/ 20, 20, 20 /)
  integer, dimension(3) :: is_shift=(/ 0, 0, 0/)
  integer, dimension(3, 8000) :: grid_point
  integer, dimension(8000) :: map
  integer :: is_time_reversal=1

  symprec = 1e-5

  ! Rutile

  print '("Rutile:")'
  num_atom = 6
  lattice(1:3, 1) = (/ 4.0, 0.0, 0.0 /)
  lattice(1:3, 2) = (/ 0.0, 4.0, 0.0 /)
  lattice(1:3, 3) = (/ 0.0, 0.0, 2.6 /)
  positions(1:3, 1) = (/ 0.0, 0.0, 0.0 /)
  positions(1:3, 2) = (/ 0.5, 0.5, 0.5 /)
  positions(1:3, 3) = (/ 0.3, 0.3, 0.0 /)
  positions(1:3, 4) = (/ 0.7, 0.7, 0.0 /)
  positions(1:3, 5) = (/ 0.2, 0.8, 0.5 /)
  positions(1:3, 6) = (/ 0.8, 0.2, 0.5 /)
  atom_types(1:6) = (/ 1, 1, 2, 2, 2, 2 /)

  call write_syminfo( max_num_sym, num_atom, &
       lattice, symprec, atom_types, positions, &
       mesh, is_shift, is_time_reversal )

  ! FCC
  print '("")'
  print '("FCC:")'
  num_atom = 1
  lattice(1:3, 1) = (/ 0.0, 2.0, 2.0 /)
  lattice(1:3, 2) = (/ 2.0, 0.0, 2.0 /)
  lattice(1:3, 3) = (/ 2.0, 2.0, 0.0 /)
  positions(1:3, 1) = (/ 0.0, 0.0, 0.0 /)
  atom_types(1) = 1

  call write_syminfo( max_num_sym, num_atom, &
       lattice, symprec, atom_types, positions, &
       mesh, is_shift, is_time_reversal )

end program spglib_example


!-----------------------------------------------------------------------
! CUDA Fortran GPU Tutorial: Reduction
! written by Viktor K. Decyk, UCLA
      program example3
      use redux
      use gpuflib2
      implicit none
      integer, parameter :: nx = 3000, mx = 128, nbx = (nx - 1)/mx + 1
      integer, parameter :: nbxs = (nbx - 1)/mx + 1
      integer :: nblock = 64
      integer :: j, k, irc
      real :: s, t, eps, epsmax
      double precision :: dtime
      integer, dimension(4) :: itime
      real, dimension(nx) :: a1
      real, dimension(nbx) :: d1
      real, device, dimension(:), allocatable :: g_a1, g_d1, g_s
!
! set up GPU
      irc = 0
      call setgbsize(nblock)
      call init_cu(0,irc)
      if (irc /= 0) then
         write (*,*) 'CUDA initialization error!'
         stop
      endif
!
! allocate 1d data on GPU
      allocate(g_a1(nx),g_d1(nbx),g_s(2*nbxs))
!
! initialize 1d data on host
      do j = 1, nx
         a1(j) = real(j)
      enddo
      d1 = 0.0
      g_d1 = d1
      s = 0.0; t = 0.0
!
! measure overhead time by running empty kernel
      call dtimer(dtime,itime,-1)
      call empty_kernel()
      call dtimer(dtime,itime,1)
      write (*,*) 'Fortran empty kernel time=', real(dtime)
!
! segmented 1d sum on host with block size mx
      call dtimer(dtime,itime,-1)
!     call sum0(a1,s)
!     call sum1(a1,s,mx)
      call sum2(a1,d1,mx)
      call sum1(d1,s,mx)
      call dtimer(dtime,itime,1)
      write (*,*) 'Fortran 1d sum time=', real(dtime)
!
! 1d sum on GPU with block size mx
      g_a1 = a1
      call dtimer(dtime,itime,-1)
!     call gpu_sum1(g_a1,g_s,mx)
!     call gpu_sum2(g_a1,g_d1,mx)
!     call gpu_sum1(g_d1,g_s,mx)
      call gpu_sum3(g_a1,g_d1,g_s,mx)
      call dtimer(dtime,itime,1)
      write (*,*) 'GPU 1d sum time=', real(dtime)
      a1(1:nbx) = g_d1; t = g_s(1)
!
! Check for correctness: compare d1 and g_d1
      epsmax = 0.0
      do j = 1, nbx
         eps = abs(d1(j)-a1(j))
         if (eps > epsmax) epsmax = eps
      enddo
      write (*,*) '1d sum maximum difference = ', epsmax
      write (*,*) 's,t = ', s, t
!
! deallocate memory on GPU
      deallocate(g_a1,g_d1,g_s)
! close down GPU
      call end_cu()
!
      end program


include 'vector.f90'

module geometry
use vector
implicit none
contains
  subroutine calculate_distance(coord_1, coord_2, a_vec, b_vec, c_vec, calc_distance, m, n)
  !a_vec, b_vec, c_vec are triclinic cell vectors

    integer::m, n
    integer::i, j
    real(kind=4)::a_vec_len, b_vec_len, c_vec_len
    real(kind=4)::sign_value_a,sign_value_b,sign_value_c
    real(kind=4)::proj_a_vec_len, proj_b_vec_len, proj_c_vec_len
    real(kind=4),dimension(n)::distance_xyz
    real(kind=4),dimension(n)::a_vec, b_vec, c_vec
    real(kind=4),dimension(n)::a_vec_basis, b_vec_basis, c_vec_basis
    real(kind=4),dimension(n)::proj_a_vec, proj_b_vec, proj_c_vec
    real(kind=4),dimension(m)::calc_distance
    real(kind=4),dimension(m,n)::coord_1, coord_2

    !f2py intent(in)::m, n
    !f2py intent(in)::a_vec, b_vec, c_vec
    !f2py intent(in)::coord_1, coord_2
    !f2py intent(out)::calc_distance

    i = 0
    j = 0

    a_vec_len = 0.0
    b_vec_len = 0.0
    c_vec_len = 0.0
    proj_a_vec_len = 0.0
    proj_b_vec_len = 0.0
    proj_c_vec_len = 0.0

    do i=1,n
      a_vec_basis(i) = 0.0
      b_vec_basis(i) = 0.0
      c_vec_basis(i) = 0.0
      proj_a_vec(i) = 0.0
      proj_b_vec(i) = 0.0
      proj_c_vec(i) = 0.0
    end do

    do i=1,m
      calc_distance(i) = 0.0
    end do

    call get_vec_len(a_vec, a_vec_len, n)
    call get_vec_len(b_vec, b_vec_len, n)
    call get_vec_len(c_vec, c_vec_len, n)

    call norm_vec(a_vec, a_vec_basis, n)
    call norm_vec(b_vec, b_vec_basis, n)
    call norm_vec(c_vec, c_vec_basis, n)

    do i=1,m
      do j=1,n
        distance_xyz(j) = coord_1(i,j) - coord_2(i,j)
      end do

      call project_vec(distance_xyz, a_vec_basis, n, proj_a_vec, sign_value_a)
      call project_vec(distance_xyz, b_vec_basis, n, proj_b_vec, sign_value_b)
      call project_vec(distance_xyz, c_vec_basis, n, proj_c_vec, sign_value_c)

      call get_vec_len(proj_a_vec, proj_a_vec_len, n)
      call get_vec_len(proj_b_vec, proj_b_vec_len, n)
      call get_vec_len(proj_c_vec, proj_c_vec_len, n)

      if ( proj_a_vec_len > a_vec_len/2 ) then
        proj_a_vec_len = a_vec_len - proj_a_vec_len
        sign_value_a = -sign_value_a
      end if
      if ( proj_b_vec_len > b_vec_len/2 ) then
        proj_b_vec_len = b_vec_len - proj_b_vec_len
        sign_value_b = -sign_value_b
      end if
      if ( proj_c_vec_len > c_vec_len/2 ) then
        proj_c_vec_len = c_vec_len - proj_c_vec_len
        sign_value_c = -sign_value_c
      end if

      distance_xyz = proj_a_vec_len*a_vec_basis*sign_value_a + &
                     proj_b_vec_len*b_vec_basis*sign_value_b + &
                     proj_c_vec_len*c_vec_basis*sign_value_c

      call get_vec_len(distance_xyz, calc_distance(i), n)

    end do

    return

  end subroutine calculate_distance

  subroutine calculate_angle(coord_1,coord_2,coord_3,calc_angle,m,n)

    integer::m,n
    integer::i,j
    real(kind=4)::a,b,c
    real(kind=4),dimension(m)::calc_angle
    real(kind=4),dimension(n)::vector_1,vector_2
    real(kind=4),dimension(m,n)::coord_1,coord_2,coord_3

    !f2py intent(in)::m,n
    !f2py intent(in)::coord_1,coord_2,coord_3
    !f2py intent(out)::calc_angle

    do i=1,m
      do j=1,n
        vector_1(j)=coord_1(i,j)-coord_2(i,j)
        vector_2(j)=coord_3(i,j)-coord_2(i,j)
      end do
      a=vector_1(1)*vector_2(1)+vector_1(2)*vector_2(2)+vector_1(3)*vector_2(3)
      b=sqrt(vector_1(1)*vector_1(1)+vector_1(2)*vector_1(2)+vector_1(3)*vector_1(3))
      c=sqrt(vector_2(1)*vector_2(1)+vector_2(2)*vector_2(2)+vector_2(3)*vector_2(3))
      calc_angle(i)=acos(a/(b*c))
    end do

    return

  end subroutine calculate_angle

  subroutine trans_box_center(coord, atoms_mass, a_vec, b_vec, c_vec, new_coord, m, n)

    integer::m, n
    integer::i, j
    real(kind=4)::sign_value_a,sign_value_b,sign_value_c
    real(kind=4)::shift_a_len, shift_b_len, shift_c_len
    real(kind=4)::proj_a_vec_len, proj_b_vec_len, proj_c_vec_len
    real(kind=4),dimension(n)::coord_temp
    real(kind=4),dimension(n)::box_center_vec
    real(kind=4),dimension(n)::coord_center_mass
    real(kind=4),dimension(n)::a_vec, b_vec, c_vec
    real(kind=4),dimension(n)::a_vec_basis, b_vec_basis, c_vec_basis
    real(kind=4),dimension(n)::proj_a_vec, proj_b_vec, proj_c_vec
    real(kind=4),dimension(n)::shift
    real(kind=4),dimension(m)::atoms_mass
    real(kind=4),dimension(m,n)::coord
    real(kind=4),dimension(m,n)::new_coord

    !f2py intent(in)::m, n
    !f2py intent(in)::coord
    !f2py intent(in)::a_vec, b_vec, c_vec
    !f2py intent(in)::atoms_mass
    !f2py intent(out)::new_coord

    i = 0
    j = 0

    proj_a_vec_len = 0.0
    proj_b_vec_len = 0.0
    proj_c_vec_len = 0.0
    shift_a_len = 0.0
    shift_b_len = 0.0
    shift_c_len = 0.0

    do i=1,n
      box_center_vec(i) = 0.0
      coord_center_mass(i) = 0.0
      a_vec_basis(i) = 0.0
      b_vec_basis(i) = 0.0
      c_vec_basis(i) = 0.0
      proj_a_vec(i) = 0.0
      proj_b_vec(i) = 0.0
      proj_c_vec(i) = 0.0
    end do

    call norm_vec(a_vec, a_vec_basis, n)
    call norm_vec(b_vec, b_vec_basis, n)
    call norm_vec(c_vec, c_vec_basis, n)

    box_center_vec = 0.5*(a_vec + b_vec + c_vec)
    call center_of_mass(atoms_mass, coord, coord_center_mass, m, n)
    shift = box_center_vec - coord_center_mass

    call project_vec(shift, a_vec_basis, n, proj_a_vec, sign_value_a)
    call project_vec(shift, b_vec_basis, n, proj_b_vec, sign_value_b)
    call project_vec(shift, c_vec_basis, n, proj_c_vec, sign_value_c)

    call get_vec_len(proj_a_vec, proj_a_vec_len, n)
    call get_vec_len(proj_b_vec, proj_b_vec_len, n)
    call get_vec_len(proj_c_vec, proj_c_vec_len, n)

    if ( DOT_PRODUCT(a_vec_basis,shift) > 0 ) then
      shift_a_len = proj_a_vec_len
    else
      shift_a_len = -proj_a_vec_len
    end if
    if ( DOT_PRODUCT(b_vec_basis,shift) > 0 ) then
      shift_b_len = proj_b_vec_len
    else
      shift_b_len = -proj_b_vec_len
    end if
    if ( DOT_PRODUCT(c_vec_basis,shift) > 0 ) then
      shift_c_len = proj_c_vec_len
    else
      shift_c_len = -proj_c_vec_len
    end if

    do i=1,m
      do j=1,n
        coord_temp(j) = coord(i,j)
      end do
      coord_temp = coord_temp + shift_a_len*a_vec_basis + &
                   shift_b_len*b_vec_basis + shift_c_len*c_vec_basis
      do j=1,n
        new_coord(i,j) = coord_temp(j)
      end do
    end do

    return

  end subroutine trans_box_center

  subroutine expand_cell(coord, a_vec, b_vec, c_vec, a_exp, b_exp, c_exp, new_coord, m, n, u)

    integer::m, n, u
    integer::a_exp, b_exp, c_exp
    integer::h, i, j, k, l
    real(kind=4),dimension(n)::coord_temp
    real(kind=4),dimension(n)::a_vec, b_vec, c_vec
    real(kind=4),dimension(m,n)::coord
    real(kind=4),dimension(u,n)::new_coord

    !f2py intent(in):m,n,u
    !f2py intent(in)::a_exp, b_exp, c_exp
    !f2py intent(in)::a_vec, b_vec, c_vec
    !f2py intent(in)::coord
    !f2py intent(out)::new_coord

    do h=1,m
      do i=1,n
        coord_temp(i) = coord(h,i)
      end do
      do j=0,a_exp-1
        do k=0,b_exp-1
          do l=0,c_exp-1
            coord_temp = coord_temp + j*a_vec + k*b_vec + l*c_vec
            do i=1,n
              new_coord(h+(j*a_exp**2+k*b_exp+l)*m,i) = coord_temp(i)
            end do
          end do
        end do
      end do
    end do

    return

  end subroutine expand_cell

  subroutine periodic_center_box(coord, a_vec, b_vec, c_vec, trans_type, group_atom_1_id, &
                                 group_atoms_mass, id_list_len, mass_list_len, new_coord, m, n, x, y, z)

    integer::m, n, x, y, z
    integer::i, j, k, q, a
    integer::trans_type
    integer::atom_1_num, atoms_num
    integer,dimension(x)::id_list_len
    integer,dimension(x)::mass_list_len
    integer,dimension(x,y)::group_atom_1_id
    real(kind=4)::sign_value_a,sign_value_b,sign_value_c
    real(kind=4)::shift_a_len, shift_b_len, shift_c_len
    real(kind=4)::a_vec_len, b_vec_len, c_vec_len
    real(kind=4)::proj_a_vec_len, proj_b_vec_len, proj_c_vec_len
    real(kind=4),dimension(n)::coord_temp, coord_center_mass
    real(kind=4),dimension(n)::a_vec, b_vec, c_vec
    real(kind=4),dimension(n)::a_vec_basis, b_vec_basis, c_vec_basis
    real(kind=4),dimension(n)::proj_a_vec, proj_b_vec, proj_c_vec
    real(kind=4),dimension(x,z)::group_atoms_mass
    real(kind=4),dimension(m,n)::coord
    real(kind=4),dimension(m,n)::new_coord

    !f2py intent(in)::trans_type
    !f2py intent(in)::m, n, x, y, z
    !f2py intent(in)::coord
    !f2py intent(in)::a_vec, b_vec, c_vec
    !f2py intent(in)::group_atom_1_id
    !f2py intent(in)::group_atoms_mass
    !f2py intent(in)::id_list_len
    !f2py intent(in)::mass_list_len
    !f2py intent(out)::new_coord

    i = 0
    j = 0
    k = 0
    q = 0
    a = 0

    shift_a_len = 0.0
    shift_b_len = 0.0
    shift_c_len = 0.0
    proj_a_vec_len = 0.0
    proj_b_vec_len = 0.0
    proj_c_vec_len = 0.0

    do i=1,n
      coord_temp(i) = 0.0
      coord_center_mass(i) = 0.0
      a_vec_basis(i) = 0.0
      b_vec_basis(i) = 0.0
      c_vec_basis(i) = 0.0
      proj_a_vec(i) = 0.0
      proj_b_vec(i) = 0.0
      proj_c_vec(i) = 0.0
    end do

    call get_vec_len(a_vec, a_vec_len, n)
    call get_vec_len(b_vec, b_vec_len, n)
    call get_vec_len(c_vec, c_vec_len, n)

    call norm_vec(a_vec, a_vec_basis, n)
    call norm_vec(b_vec, b_vec_basis, n)
    call norm_vec(c_vec, c_vec_basis, n)

    do i=1,m
      do j=1,n
        new_coord(i,j) = 0.0
      end do
    end do

    if (trans_type == 0) then !center the system based on the center of mass of group
      do i =1,x
        atom_1_num = id_list_len(i)
        atoms_num = mass_list_len(i)
        do j=1,atom_1_num
          a=group_atom_1_id(i,j)
          call center_of_mass(group_atoms_mass(i,1:atoms_num), coord(a:(a+atoms_num-1),:), &
                              coord_center_mass, atoms_num, n)

          call project_vec(coord_center_mass, a_vec_basis, n, proj_a_vec, sign_value_a)
          call project_vec(coord_center_mass, b_vec_basis, n, proj_b_vec, sign_value_b)
          call project_vec(coord_center_mass, c_vec_basis, n, proj_c_vec, sign_value_c)

          call get_vec_len(proj_a_vec, proj_a_vec_len, n)
          call get_vec_len(proj_b_vec, proj_b_vec_len, n)
          call get_vec_len(proj_c_vec, proj_c_vec_len, n)

          if ( DOT_PRODUCT(a_vec_basis,coord_center_mass) > 0 ) then
            shift_a_len = a_vec_len*anint(proj_a_vec_len/a_vec_len)
          else
            shift_a_len = a_vec_len*anint(-proj_a_vec_len/a_vec_len)
          end if
          if ( DOT_PRODUCT(b_vec_basis,coord_center_mass) > 0 ) then
            shift_b_len = b_vec_len*anint(proj_b_vec_len/b_vec_len)
          else
            shift_b_len = b_vec_len*anint(-proj_b_vec_len/b_vec_len)
          end if
          if ( DOT_PRODUCT(c_vec_basis,coord_center_mass) > 0 ) then
            shift_c_len = c_vec_len*anint(proj_c_vec_len/c_vec_len)
          else
            shift_c_len = c_vec_len*anint(-proj_c_vec_len/c_vec_len)
          end if

          do k=0,atoms_num-1
            do q=1,n
              coord_temp(q) = coord(a+k,q)
            end do

            coord_temp = coord_temp - shift_a_len*a_vec_basis - &
                         shift_b_len*b_vec_basis - shift_c_len*c_vec_basis
            do q=1,n
              new_coord(a+k,q)=coord_temp(q)
            end do
          end do
        end do
      end do

    elseif (trans_type == 1) then
      do i=1,m
        do j=1,n
          coord_temp(j) = coord(i,j)
        end do
        call project_vec(coord_temp, a_vec_basis, n, proj_a_vec, sign_value_a)
        call project_vec(coord_temp, b_vec_basis, n, proj_b_vec, sign_value_b)
        call project_vec(coord_temp, c_vec_basis, n, proj_c_vec, sign_value_c)

        call get_vec_len(proj_a_vec, proj_a_vec_len, n)
        call get_vec_len(proj_b_vec, proj_b_vec_len, n)
        call get_vec_len(proj_c_vec, proj_c_vec_len, n)

        if ( DOT_PRODUCT(a_vec_basis,coord_temp) > 0 ) then
          shift_a_len = a_vec_len*anint(proj_a_vec_len/a_vec_len)
        else
          shift_a_len = a_vec_len*anint(-proj_a_vec_len/a_vec_len)
        end if
        if ( DOT_PRODUCT(b_vec_basis,coord_temp) > 0 ) then
          shift_b_len = b_vec_len*anint(proj_b_vec_len/b_vec_len)
        else
          shift_b_len = b_vec_len*anint(-proj_b_vec_len/b_vec_len)
        end if
        if ( DOT_PRODUCT(c_vec_basis,coord_temp) > 0 ) then
          shift_c_len = c_vec_len*anint(proj_c_vec_len/c_vec_len)
        else
          shift_c_len = c_vec_len*anint(-proj_c_vec_len/c_vec_len)
        end if
        coord_temp = coord_temp - shift_a_len*a_vec_basis - &
                     shift_b_len*b_vec_basis - shift_c_len*c_vec_basis

        do j=1,n
          new_coord(i,j) = coord_temp(j)
        end do
      end do
    endif

    return

  end subroutine

  subroutine periodic_center_image(coord, a_vec, b_vec, c_vec, center_coord, trans_type, group_atom_1_id, &
                                   group_atoms_mass, id_list_len, mass_list_len, new_coord, m, n, x, y, z)

    integer::m, n, x, y, z
    integer::i, j, k, q, a
    integer::trans_type
    integer::atom_1_num, atoms_num
    integer,dimension(x,y)::group_atom_1_id
    integer,dimension(x)::id_list_len
    integer,dimension(x)::mass_list_len
    real(kind=4)::sign_value_a, sign_value_b, sign_value_c
    real(kind=4)::a_vec_len, b_vec_len, c_vec_len
    real(kind=4)::shift_a_len, shift_b_len, shift_c_len
    real(kind=4)::proj_a_vec_len, proj_b_vec_len, proj_c_vec_len
    real(kind=4),dimension(x,z)::group_atoms_mass
    real(kind=4),dimension(n)::center_coord, group_center_coord
    real(kind=4),dimension(n)::coord_temp
    real(kind=4),dimension(n)::a_vec, b_vec, c_vec
    real(kind=4),dimension(n)::a_vec_basis, b_vec_basis, c_vec_basis
    real(kind=4),dimension(n)::proj_a_vec, proj_b_vec, proj_c_vec
    real(kind=4),dimension(m,n)::coord
    real(kind=4),dimension(m,n)::new_coord

    !f2py intent(in)::trans_type
    !f2py intent(in)::m, n, x, y, z
    !f2py intent(in)::center_coord
    !f2py intent(in)::coord
    !f2py intent(in)::group_atom_1_id
    !f2py intent(in)::group_atoms_mass
    !f2py intent(in)::a_vec, b_vec, c_vec
    !f2py intent(in)::id_list_len, mass_list_len
    !f2py intent(out)::new_coord

    i = 0
    j = 0
    k = 0
    q = 0
    a = 0

    a_vec_len = 0.0
    b_vec_len = 0.0
    c_vec_len = 0.0
    shift_a_len = 0.0
    shift_b_len = 0.0
    shift_c_len = 0.0
    proj_a_vec_len = 0.0
    proj_b_vec_len = 0.0
    proj_c_vec_len = 0.0

    do i=1,n
      group_center_coord(i) = 0.0
      a_vec_basis(i) = 0.0
      b_vec_basis(i) = 0.0
      c_vec_basis(i) = 0.0
      proj_a_vec(i) = 0.0
      proj_b_vec(i) = 0.0
      proj_c_vec(i) = 0.0
    end do

    do i=1,m
      do j=1,n
        new_coord(i,j) = 0.0
      end do
    end do

    call get_vec_len(a_vec, a_vec_len, n)
    call get_vec_len(b_vec, b_vec_len, n)
    call get_vec_len(c_vec, c_vec_len, n)

    call norm_vec(a_vec, a_vec_basis, n)
    call norm_vec(b_vec, b_vec_basis, n)
    call norm_vec(c_vec, c_vec_basis, n)

    if (trans_type == 0) then !center the system based on the center of mass of group
      do i =1,x
        atom_1_num = id_list_len(i)
        atoms_num = mass_list_len(i)
        do j=1,atom_1_num
          a=group_atom_1_id(i,j)
          call center_of_mass(group_atoms_mass(i,1:atoms_num), coord(a:(a+atoms_num-1),:), group_center_coord, atoms_num, n)
          do k=1,n
            coord_temp(k) = group_center_coord(k) - center_coord(k)
          end do

          call project_vec(coord_temp, a_vec_basis, n, proj_a_vec, sign_value_a)
          call project_vec(coord_temp, b_vec_basis, n, proj_b_vec, sign_value_b)
          call project_vec(coord_temp, c_vec_basis, n, proj_c_vec, sign_value_c)

          call get_vec_len(proj_a_vec, proj_a_vec_len, n)
          call get_vec_len(proj_b_vec, proj_b_vec_len, n)
          call get_vec_len(proj_c_vec, proj_c_vec_len, n)

          if ( DOT_PRODUCT(coord_temp,a_vec_basis) < 0 .and. proj_a_vec_len > a_vec_len/2.0 ) then
            shift_a_len = a_vec_len
          end if
          if ( DOT_PRODUCT(coord_temp,a_vec_basis) > 0 .and. proj_a_vec_len > a_vec_len/2.0 ) then
            shift_a_len = -a_vec_len
          end if

          if ( DOT_PRODUCT(coord_temp,b_vec_basis) < 0 .and. proj_b_vec_len > b_vec_len/2.0 ) then
            shift_b_len = b_vec_len
          end if
          if ( DOT_PRODUCT(coord_temp,b_vec_basis) > 0 .and. proj_b_vec_len > b_vec_len/2.0 ) then
            shift_b_len = -b_vec_len
          end if

          if ( DOT_PRODUCT(coord_temp,c_vec_basis) < 0 .and. proj_c_vec_len > c_vec_len/2.0 ) then
            shift_c_len = c_vec_len
          end if
          if ( DOT_PRODUCT(coord_temp,c_vec_basis) > 0 .and. proj_c_vec_len > c_vec_len/2.0 ) then
            shift_c_len = -c_vec_len
          end if

          do k=0,atoms_num-1
            do q=1,n
              coord_temp(q) = coord(a+k,q)
            end do

            !call project_vec(coord_temp, a_vec_basis, n, proj_a_vec)
            !call project_vec(coord_temp, b_vec_basis, n, proj_b_vec)
            !call project_vec(coord_temp, c_vec_basis, n, proj_c_vec)

            !call get_vec_len(proj_a_vec, proj_a_vec_len, n)
            !call get_vec_len(proj_b_vec, proj_b_vec_len, n)
            !call get_vec_len(proj_c_vec, proj_c_vec_len, n)

            coord_temp = coord_temp + shift_a_len*a_vec_basis + &
                         shift_b_len*b_vec_basis + shift_c_len*c_vec_basis

            do q=1,n
              new_coord(a+k,q) = coord_temp(q)
            end do
          end do
          shift_a_len = 0.0
          shift_b_len = 0.0
          shift_c_len = 0.0

        end do
      end do

    else if (trans_type == 1) then
      do i=1,m
        do j=1,n
          coord_temp(j) = coord(i,j) - center_coord(j)
        end do

        call project_vec(coord_temp, a_vec_basis, n, proj_a_vec, sign_value_a)
        call project_vec(coord_temp, b_vec_basis, n, proj_b_vec, sign_value_b)
        call project_vec(coord_temp, c_vec_basis, n, proj_c_vec, sign_value_c)

        call get_vec_len(proj_a_vec, proj_a_vec_len, n)
        call get_vec_len(proj_b_vec, proj_b_vec_len, n)
        call get_vec_len(proj_c_vec, proj_c_vec_len, n)

        if ( DOT_PRODUCT(coord_temp,a_vec_basis) < 0 .and. proj_a_vec_len > a_vec_len/2.0 ) then
          shift_a_len = a_vec_len
        end if
        if ( DOT_PRODUCT(coord_temp,a_vec_basis) > 0 .and. proj_a_vec_len > a_vec_len/2.0 ) then
          shift_a_len = -a_vec_len
        end if

        if ( DOT_PRODUCT(coord_temp,b_vec_basis) < 0 .and. proj_b_vec_len > b_vec_len/2.0 ) then
          shift_b_len = b_vec_len
        end if
        if ( DOT_PRODUCT(coord_temp,b_vec_basis) > 0 .and. proj_b_vec_len > b_vec_len/2.0 ) then
          shift_b_len = -b_vec_len
        end if

        if ( DOT_PRODUCT(coord_temp,c_vec_basis) < 0 .and. proj_c_vec_len > c_vec_len/2.0 ) then
          shift_c_len = c_vec_len
        end if
        if ( DOT_PRODUCT(coord_temp,c_vec_basis) > 0 .and. proj_c_vec_len > c_vec_len/2.0 ) then
          shift_c_len = -c_vec_len
        end if

        coord_temp = coord_temp + shift_a_len*a_vec_basis + &
                     shift_b_len*b_vec_basis + shift_c_len*c_vec_basis

        do k=1,n
          new_coord(a,k) = coord_temp(k)
        end do
        shift_a_len = 0.0
        shift_b_len = 0.0
        shift_c_len = 0.0
      end do

    end if

    return

  end subroutine

  subroutine unwrap_coord(coord, a_vec, b_vec, c_vec, new_coord, u, v, w, n)

    integer::u, v, w, n
    integer::i, j, k
    real(kind=4)::shift_a_len, shift_b_len, shift_c_len
    real(kind=4)::a_vec_len, b_vec_len, c_vec_len
    real(kind=4)::sign_value_a, sign_value_b, sign_value_c
    real(kind=4)::proj_a_vec_len, proj_b_vec_len, proj_c_vec_len
    real(kind=4),dimension(n)::coord_temp
    real(kind=4),dimension(n)::a_vec, b_vec, c_vec
    real(kind=4),dimension(n)::a_vec_basis, b_vec_basis, c_vec_basis
    real(kind=4),dimension(n)::proj_a_vec, proj_b_vec, proj_c_vec
    real(kind=4),dimension(u,v,w)::coord
    real(kind=4),dimension(u,v,w)::new_coord

    !f2py intent(in)::u, v, w, n
    !f2py intent(in)::a_vec, b_vec, c_vec
    !f2py intent(in)::coord
    !f2py intent(out)::new_coord

    do i=1,u
      do j=1,v
        do k=1,w
          new_coord(i,j,k) = coord(i,j,k)
        end do
      end do
    end do

    shift_a_len = 0.0
    shift_b_len = 0.0
    shift_c_len = 0.0

    call get_vec_len(a_vec, a_vec_len, n)
    call get_vec_len(b_vec, b_vec_len, n)
    call get_vec_len(c_vec, c_vec_len, n)

    call norm_vec(a_vec, a_vec_basis, n)
    call norm_vec(b_vec, b_vec_basis, n)
    call norm_vec(c_vec, c_vec_basis, n)

    do i=2,u
      do j=1,v
        do k=1,w
          coord_temp(k) = coord(i,j,k)-coord(i-1,j,k)
        end do
        call project_vec(coord_temp, a_vec_basis, n, proj_a_vec, sign_value_a)
        call project_vec(coord_temp, b_vec_basis, n, proj_b_vec, sign_value_b)
        call project_vec(coord_temp, c_vec_basis, n, proj_c_vec, sign_value_c)

        call get_vec_len(proj_a_vec, proj_a_vec_len, n)
        call get_vec_len(proj_b_vec, proj_b_vec_len, n)
        call get_vec_len(proj_c_vec, proj_c_vec_len, n)

        if ( DOT_PRODUCT(coord_temp,a_vec_basis) < 0 .and. proj_a_vec_len > a_vec_len/2.0 ) then
          shift_a_len = a_vec_len
        end if
        if ( DOT_PRODUCT(coord_temp,a_vec_basis) > 0 .and. proj_a_vec_len > a_vec_len/2.0 ) then
          shift_a_len = -a_vec_len
        end if

        if ( DOT_PRODUCT(coord_temp,b_vec_basis) < 0 .and. proj_b_vec_len > b_vec_len/2.0 ) then
          shift_b_len = b_vec_len
        end if
        if ( DOT_PRODUCT(coord_temp,b_vec_basis) > 0 .and. proj_b_vec_len > b_vec_len/2.0 ) then
          shift_b_len = -b_vec_len
        end if

        if ( DOT_PRODUCT(coord_temp,c_vec_basis) < 0 .and. proj_c_vec_len > c_vec_len/2.0 ) then
          shift_c_len = c_vec_len
        end if
        if ( DOT_PRODUCT(coord_temp,c_vec_basis) > 0 .and. proj_c_vec_len > c_vec_len/2.0 ) then
          shift_c_len = -c_vec_len
        end if

        do k=1,n
          coord_temp(k) = new_coord(i,j,k)
          !coord_temp(k) = coord(i,j,k)
        end do
        coord_temp = coord_temp + shift_a_len*a_vec_basis + &
                     shift_b_len*b_vec_basis + shift_c_len*c_vec_basis

        do k=1,n
          coord(i,j,k) = coord_temp(k)
          new_coord(i,j,k) = coord_temp(k)
        end do

        shift_a_len = 0.0
        shift_b_len = 0.0
        shift_c_len = 0.0
      end do
    end do

    return

  end subroutine unwrap_coord

  subroutine rdf(distance, increment, vol, data_num, rdf_value_final, integral_value_final, u, v, w)

    integer::data_num
    integer::u, v, w
    integer::i, j, k, l
    integer::num_2_r
    real(kind=4)::density
    real(kind=4)::increment
    real(kind=4)::sum_value_1, sum_value_2
    real(kind=4)::pi
    real(kind=4)::vol
    real(kind=4)::r_value
    real(kind=4),dimension(data_num)::rdf_value_final
    real(kind=4),dimension(data_num)::integral_value_final
    real(kind=4),dimension(u,v,w)::distance
    real(kind=4),dimension(u,v,data_num)::rdf_value
    real(kind=4),dimension(u,v,data_num)::integral_value

    !f2py intent(in)::u, v, w, data_num
    !f2py intent(in)::distance
    !f2py intent(in)::vol
    !f2py intent(in)::increment
    !f2py intent(out)::rdf_value_final, integral_value_final

    i = 0
    j = 0
    k = 0
    l = 0
    sum_value_1 = 0.0
    sum_value_2 = 0.0
    pi=3.1415926

    density = w/vol

    do i=1,u
      do j=1,v
        do k=1,data_num-1
          num_2_r = 0
          r_value = k*increment
          do l=1,w
            if ( distance(i,j,l) > r_value .and. distance(i,j,l) <= r_value+increment ) then
              num_2_r = num_2_r+1
            end if
          end do
          rdf_value(i,j,k) = num_2_r/(4*pi*density*r_value**2*increment)
        end do
      end do
    end do

    do i=1,u
      do j=1,v
        do k=1,data_num-1
          sum_value_1 = 0.0
          do l=1,k
            sum_value_1 = sum_value_1+4*pi*density*(increment*l)**2*rdf_value(i,j,l)*increment
          end do
          integral_value(i,j,k) = sum_value_1
        end do
      end do
    end do

    do i=1,data_num-1
      sum_value_1 = 0.0
      do j=1,u
        sum_value_2 = 0.0
        do k=1,v
          sum_value_2 = sum_value_2+rdf_value(j,k,i)
        end do
        sum_value_1 = sum_value_1+sum_value_2/v
      end do
      rdf_value_final(i) = sum_value_1/u
    end do

    do i=1,data_num-1
      sum_value_1 = 0.0
      do j=1,u
        sum_value_2 = 0.0
        do k=1,v
          sum_value_2 = sum_value_2+integral_value(j,k,i)
        end do
        sum_value_1 = sum_value_1+sum_value_2/v
      end do
      integral_value_final(i) = sum_value_1/u
    end do

    return

  end subroutine rdf

end module geometry


! This demo program reads the C81 file sample1.C81 and writes the values read to
! an output file sampleOutput.C81. Both files are in the Samples/ directory.
! The working demo for the getTable() function, similar to dlmread() in Matlab, is also provided

program demo1

  use libC81
  implicit none

  integer, parameter :: rows = 4
  integer, parameter :: cols = 4

  type(C81_class) :: C81
  real, dimension(4,4) :: A
  integer :: i,j

  ! Read airfoil data from C81 file
  call C81%readfile('Samples/sample1.C81')
  print*, 'Airfoil data read SUCCESSFUL'
  print*

  ! Write airfoil data to C81 file
  call C81%writefile('Samples/sampleOutput.C81')
  print*, 'Airfoil data write SUCCESSFUL'
  print*

  ! Read tabular data from csv file to Fortran array
  ! Works similar to dlmread() from Matlab
  ! Useful for creating arrays from airfoil data in CSV format
  A = getTable('Samples/sample1.csv',rows,cols)
  print*, 'Tabular data read SUCCESSFUL'
  print*

  do i=1,size(A,1)
    print*,(A(i,j),j=1,size(A,2))
  enddo
  print*

  ! Find left and right indices from 1-d sorted array in which
  ! a queried value lies
  print*, A(1,:)
  print*, getInterval(A(1,:),0.15)
  print*, 'Binary search SUCCESSFUL'

  ! Return 2-d interpolated value from 2-d array
  print*
  print*, C81%getCL(-14.5,0.425)
  print*, '2-d interpolation SUCCESSFUL'

end program demo1


program real_kinds
    implicit none
    integer :: range
    integer :: precision
    integer :: kind

    do precision = 0, 41
        do range = 0, 5100
            kind = selected_real_kind(precision, range)
            print *, range, precision, kind
        end do ! range
    end do ! precision
end program real_kinds


!> @ingroup quick_sort_flat
!>
!> @brief
!> Run a flat three way quick sort on a vector of double precision values.
!>
!> @details
!> Run a flat three way quick sort on a vector of double precision values to sort them in a specified order. The vector of intergers map is permuted in the same way that the vector vec is permuted to be sorted. It is important that map be of equal or greather length than vec.
!>
!> @param vec
!> The vector to be sorted.
!>
!> @param map
!> Vector of intergers which is permuted in the same way that vec is permuted. If map is a vector of values 1 to N, where N is the length of vec, than, map is the map from vec's original value to vec's final value after being sort.
!>
!> @param ascending
!> Indicates if the ordering is ascending or decending.
!>
!> | Value | Meaning         |
!> |:-----:| :-------------- |
!> | true  | Ascending order |
!> | false | Decending order |
!>
!> @warning
!> The length of map is not checked within this subroutine. If the length of vec is larger than the length of map, than this subroutine may attempt to access elements of map that do not exist.
!>
!> @author Arin R. Bratt
!> @date 11/07/2014

pure subroutine quick_sort_flat_map_dble(vec,map,ascending)
  ! Arguments
  double precision, intent(inout) :: vec(:)
  integer, intent(inout) :: map(:)
  logical, intent(in) :: ascending

  ! Main
  if (ascending) then
     call quick_sort_flat_asc_map_dble(vec,map)
  else
     call quick_sort_flat_dec_map_dble(vec,map)
  end if
end subroutine quick_sort_flat_map_dble


! { dg-do compile }
! PR20923 gfortran slow for large array constructors.
! Test case prepared from PR by Jerry DeLisle <jvdelisle@gcc.gnu.org>
program sel
    implicit none
    integer(kind=4),parameter      :: n=1000
    integer(kind=4)                :: i,j
    real(kind=4),dimension(n*n)    :: vect
    vect(:) = (/ ((( (i+j+3)),i=1,n),j=1,n) /)
end