      program test
! **********************************************************************
!     Author : C. Voemel
!
!     Date of last modification : 7.7.00
!
!     Description : SAMPLE ROUTINE FOR THE CERFACS TECHNICAL REPORT
! **********************************************************************

      ! include the SparseBLAS module
      use SparseBLAS

      ! matrix handle and other parameters
      integer :: a, istat, prpty

      ! dense vectors
      double precision, dimension(5) :: x,y

      ! matrix data in COO format
      double precision, parameter, dimension(14) :: A_val_coo = &
       (/ 11,51,31,32,34,52,13,23,33,14,24,42,55,44 /)
      integer, parameter, dimension(14) :: A_indx_coo = &
       (/ 1,5,3,3,3,5,1,2,3,1,2,4,5,4 /)
      integer, parameter, dimension(14) :: A_jndx_coo = &
       (/ 1,1,1,2,4,2,3,3,3,4,4,2,5,4 /)
      prpty = blas_general + blas_one_base
      istat = -1 ! copy data when creating handle

      ! create matrix handle
      call uscr_coo(5,5,A_val_coo,A_indx_coo,A_jndx_coo,14, &
                          prpty,istat,a)
      if(istat.lt.0) then
         stop 'Error! No handle created!'
      end if

      ! calculate matrix-vector product y=A*x
      x = 1.0d0
      call usmv(a,x,y,istat)
      if (istat.ne.0) then
         stop 'Error! Can''t perform MV multiplication!'
      end if

      ! release matrix handle
      call usds(a, istat)
      if (istat.ne.0) then
         stop 'Error! Handle not released!'
      end if

      end program


      SUBROUTINE SATMAK
C
C SATMASK - make a satellite mask from parameters of a line
C
C The output is an integer*2 image with weights (1 for good and 0 for bad).
C
C Richard Hook, for the GOODS project, ST-ECF, STScI, October 2002
C
      IMPLICIT NONE

      REAL X1,Y1,X2,Y2,M,C,WIDTH,HWID,F,X,Y,D
      INTEGER I,J,ISTAT,DIMS(7),ID,NX,NY
      INTEGER MAXNX
      PARAMETER (MAXNX=100000)
      INTEGER BUFFER(MAXNX)
      CHARACTER*80 MASK
      LOGICAL VERTICAL

C Get the name and dimensions of the output
      CALL UCLGST('mask',MASK,ISTAT)
      CALL UCLGSI('nx',NX,ISTAT)
      CALL UCLGSI('ny',NY,ISTAT)

C Get the line parameters - positions of two points
      CALL UCLGSR('x1',X1,ISTAT)
      CALL UCLGSR('y1',Y1,ISTAT)
      CALL UCLGSR('x2',X2,ISTAT)
      CALL UCLGSR('y2',Y2,ISTAT)

C and the width of the band
      CALL UCLGSR('width',WIDTH,ISTAT)
      HWID=WIDTH/2.0

C Check for special case of vertical line
      IF(X1.EQ.X2) THEN
         VERTICAL=.TRUE.

      ELSE

C Work out equation of line
         M=(Y2-Y1)/(X2-X1)
         C=Y1-M*X1
         F=1.0/SQRT(1.0+M*M)
         VERTICAL=.FALSE.
      ENDIF

C Check for meaningless case
      IF(X1.EQ.Y1 .AND. X2.EQ.Y2) THEN
         CALL UMSPUT('! Points are coincident',1,0,ISTAT)
         GO TO 99
      ENDIF

      DIMS(1)=NX
      DIMS(2)=NY

C Create the image
      CALL UIMCRE(MASK,4,2,DIMS,ID,ISTAT)
      IF(ISTAT.NE.0) THEN
         CALL UMSPUT('! Unable to create mask image',1,0,ISTAT)
         GO TO 99
      ENDIF

C Write out the image, line by line
      DO J=1,NY
         Y=FLOAT(J)

C File buffer with 1 or 0
         DO I=1,NX
            X=FLOAT(I)

            IF(VERTICAL) THEN
               D=ABS(X-X1)
            ELSE
               D=ABS(F*(M*X+C-Y))
            ENDIF

            IF(D.LE.HWID) THEN
               BUFFER(I)=0
            ELSE
               BUFFER(I)=1
            ENDIF
         ENDDO

C Write line of buffer
         CALL UIPL2I(ID,J,BUFFER,ISTAT)
      ENDDO

C Close
      CALL UIMCLO(ID,ISTAT)

 99   CONTINUE

      RETURN
      END


!*==AA0001.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005
!   SPAG options set to convert source form only
!     =======================================================================
!     PROGRAM: The autocorrelation test for pseudorandom numbers using the
!              2-d Ising model with the Wolff algorithm.
!     -----------------------------------------------------------------------
!     for    testing of pseudorandom numbers; based on calculating some
!            physical quantities of the 2-d Ising model as well as their
!            integrated autocorrelation functions.
!     by     I. Vattulainen, vattulai@convex.csc.fi
!     alg    autocorrelation, the Ising model, Wolff updating
!     ref    Phys. Rev. Lett. 73, 2513 (1994).
!     title  acorrt_iw.f
!     size
!     prec   single/double
!     lang   Fortran77
!     -----------------------------------------------------------------------
!     The author of this software is I. Vattulainen.  Copyright (c) 1993.
!     Permission to use, copy, modify, and distribute this software for
!     any purpose without fee is hereby granted, provided that this entire
!     notice is included in all copies of any software which is or includes
!     a copy or modification of this software and in all copies of the
!     supporting documentation for such software.
!     THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED
!     WARRANTY. IN PARTICULAR, NEITHER THE AUTHOR NOR AT&T MAKE ANY
!     REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE MERCHANTABILITY
!     OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE.
!     -----------------------------------------------------------------------
!     In the autocorrelation test, we calculate averages of some physical
!     quantities such as the energy, the susceptibility, and the updated
!     cluster size in the 2-d Ising model. Additionally, their autocorrelation
!     functions and corresponding integrated autocorrelation values are
!     determined. The chosen temperature corresponds to the critical point,
!     and the Wolff updating method is utilized. The results of the
!     simulation (test) are a function of the pseudorandom number generator
!     used. Since the exact value is known only for the energy, other results
!     must be compared with corresponding results of other generators;
!     i.e. the test must be performed comparatively between several
!     pseudorandom number generators.
!     -----------------------------------------------------------------------
!     Main parameters in the test are as follows:
!     L         linear size of the lattice.
!     DK        interaction / temperature*Boltzmann constant.
!     MCBEG     number of passed initial configurations
!               (initialization time; a minimum of 10000 is suggested).
!     ISCANS    number of independent samples.
!     ICSAMP    maximum detected autocorrelation time.
!     INEWEST   tells the index of the latest (newest) configuration.
!     IZ        contains the 2-d lattice.
!     D*ROO     contains the autocorrelation function.
!     D*TAU     gives the integrated autocorrelation time, where
!     D*SIGMA   is its' error estimate.
!     ------------------------------------------------------
!     ******************
!     PRACTICAL DETAILS:
!     ******************
!
!     Required modification to this code:
!                   Initialization and implementation of the pseudorandom
!                   number generator (PRNG), which will be tested. For
!                   initialization, there is a reserved space in the code
!                   below. The PRNG may be appended to the end of the file,
!                   or may be called separately during compiling. In this
!                   version, the default generator is GGL.
!
!                   During the test, random numbers are called in two cases:
!                   in the formation of the random (initial) lattice and
!                   during its updating. The former is in the main program
!                   and the latter in the subroutine WOLFF. As a consequence,
!                   if you are testing a generator which produces a sequence
!                   of random numbers at a time (this is not the case with
!                   GGL), the code must be modified correspondingly.
!
!     Output files: general.dat         General information of the test.
!                   susc_data.dat       Autocorrelation function and its
!                                       integrated value for susceptibility
!                                       (including the error estimate).
!                   ener_data.dat       Corresponding results for the energy.
!                   clus_data.dat       Corresponding results for the
!                                       flipped cluster sizes.
!                   clus_distr.dat      Normalized probability distribution
!                                       for the flipped cluster size (as a
!                                       function of cluster size).
!
!     Keep in mind that the given results are *NOT* final. This is due to
!     the calculation of errors in a Monte Carlo simulation, in which the
!     integrated autocorrelation time plays an important role. In order to
!     find the correct error estimates, perform the following steps after
!     the test:
!        (1) First of all, determine the estimates for the integrated
!            autocorrelation times. To do that, for each of the quantities
!            energy, susceptibility, and flipped cluster size, you must find
!            the regime (plateau) in which the results have already converged
!            but where the statistical errors are not yet very large. An
!            estimate for the corresponding integrated autocorrelation time
!            (tau) is then an average over this plateau.
!        (2) The given values for the error estimates of energy,
!            susceptibility and the average flipped cluster size (given in
!            a file general.dat) must then be modified: when the
!            corresponding integrated autocorrelation time (tau) is known,
!            the error estimate must then be multiplied by tau. A square
!            root of the product then gives the correct error estimate.
!
!     For further practical details of the method see U. Wolff [Phys. Lett. B
!     228, 379 (1989) or I. Vattulainen [cond-mat@babbage.sissa.it No.
!     9411062].
!     =======================================================================

      IMPLICIT NONE
      DOUBLE PRECISION DK
      INTEGER L , L2 , MCBEG , ISCANS , ICSAMP
      PARAMETER (L=16,L2=L*L)
!     -------------------------------------
!     Coefficients at criticality (some empirical estimates for a finite
!     system are also given):
!     For an infinite lattice (L --> infinity):
!      PARAMETER( DK = 0.44068679350977D0 )
!     For a lattice size L = 64:
!      PARAMETER( DK = 0.43821982133122D0 )
!     For a lattice size L = 16:
!      PARAMETER( DK = 0.43098188945039D0 )
!     -------------------------------------
      PARAMETER (DK=0.44068679350977D0)
!     Please choose MCBEG > 9999 (time for equilibration).
      PARAMETER (MCBEG=10000)
!     Good statistics require ISCANS > 1e6.
      PARAMETER (ISCANS=1000000)
      PARAMETER (ICSAMP=25)

!     ===============================================================

      INTEGER iz(L,L) , in1(L) , ip1(L) , istack(L2,2) , ix , iy ,      &
     &        itrsum , isum , ipos(ICSAMP) , inewest , idt , ilocal ,   &
     &        icnt , ifin(2) , ifac , iclsiz , icldst(L2) , i , j ,     &
     &        itries , is , idiff , iks

!     Susceptibility variables:
!     Energy variables:
!     Cluster variables:
      DOUBLE PRECISION prob , dsauto(ICSAMP) , dsus , dsusold(ICSAMP) , &
     &                 dsusave , dsus2 , dsroo(0:ICSAMP) ,              &
     &                 dskappa(ICSAMP) , dsrw(ICSAMP) , dstau(ICSAMP) , &
     &                 dsxw(ICSAMP) , dsyw(ICSAMP) , dssigma(ICSAMP) ,  &
     &                 dsaverage , dserror , deauto(ICSAMP) , dene ,    &
     &                 deneold(ICSAMP) , deneave , dene2 ,              &
     &                 deroo(0:ICSAMP) , dekappa(ICSAMP) , derw(ICSAMP) &
     &                 , detau(ICSAMP) , dexw(ICSAMP) , deyw(ICSAMP) ,  &
     &                 desigma(ICSAMP) , deaverage , deerror ,          &
     &                 dclauto(ICSAMP) , dcl , dclold(ICSAMP) , dclave ,&
     &                 dcl2 , dclroo(0:ICSAMP) , dclkappa(ICSAMP) ,     &
     &                 dclrw(ICSAMP) , dcltau(ICSAMP) , dclxw(ICSAMP) , &
     &                 dclyw(ICSAMP) , dclsigma(ICSAMP) , dclavr ,      &
     &                 dclerror , dclrat

      REAL*8 dseed , diseed

      REAL ran , GGL

      PRINT * , 'Opening files'
      OPEN (20,STATUS='UNKNOWN',FILE='suscdata.dat',FORM='FORMATTED',   &
     &      ACCESS='SEQUENTIAL')
      OPEN (21,STATUS='UNKNOWN',FILE='enerdata.dat',FORM='FORMATTED',   &
     &      ACCESS='SEQUENTIAL')
!      OPEN(22,STATUS='UNKNOWN',FILE='general.dat',FORM='FORMATTED',
!     +     ACCESS='SEQUENTIAL')
      OPEN (23,STATUS='UNKNOWN',FILE='clusdata.dat',FORM='FORMATTED',   &
     &      ACCESS='SEQUENTIAL')
      OPEN (24,STATUS='UNKNOWN',FILE='clusdist.dat',FORM='FORMATTED',   &
     &      ACCESS='SEQUENTIAL')

!     --------------------------
!     Initialize some variables:
!     --------------------------
      PRINT * , 'Initializing variables'
      isum = 0
      itrsum = 0
!
      dsus = 0.D0
      dsusave = 0.D0
      dsus2 = 0.D0
!
      dene = 0.D0
      deneave = 0.D0
      dene2 = 0.D0
!
      dcl = 0.D0
      dclave = 0.D0
      dclrat = 0.D0
      dcl2 = 0.D0
!
      DO i = 1 , ICSAMP
         dsusold(i) = 0.D0
         deneold(i) = 0.D0
         dclold(i) = 0.D0
      ENDDO
      DO i = 1 , ICSAMP
         dsauto(i) = 0.D0
         deauto(i) = 0.D0
         dclauto(i) = 0.D0
      ENDDO
      DO i = 1 , L
         in1(i) = i - 1
         ip1(i) = i + 1
      ENDDO
      in1(1) = L
      ip1(L) = 1
      DO i = 1 , L2
         icldst(i) = 0
      ENDDO

!     ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
!     First of all, initialize the pseudorandom number generator.
!     In the case of GGL, only one number is needed:

      dseed = 14159.D0
!     ```````````````````````````````````````````````````````````
      diseed = dseed

!     ----------------------------------------------------------
!     Probability PROB to unite equal lattice sites as clusters:
!     ----------------------------------------------------------
      prob = 1.D0 - DEXP(-2.D0*DK)

!     --------------------------------------
!     Create a random initial configuration:
!     --------------------------------------
      PRINT * , 'Creating random initial configuration'
      DO iy = 1 , L
         DO ix = 1 , L
            ran = GGL(dseed)
            IF ( ran.LT.0.5D0 ) THEN
               iz(iy,ix) = -1
            ELSE
               iz(iy,ix) = 1
            ENDIF
         ENDDO
      ENDDO

!     ------------------------------------------------------------------
!     Perform the dynamic part to achieve equilibrium.
!     ------------------------------------------------------------------
!     Pass a total of MCBEG configurations. Determine MCBEG by studying
!     the order parameter of the system (as function of T), for example.
!     ------------------------------------------------------------------

      PRINT * , 'Equilibrating'
      DO i = 1 , MCBEG
         itries = 0
 711     CALL WOLFF(L,L2,iz,istack,in1,ip1,prob,dseed,isum,iclsiz)
         itries = itries + isum
         IF ( itries.LT.L2 ) GOTO 711
      ENDDO

!     ----------------------------------------------
!     Take a number of ICSAMP samples to start with:
!     ----------------------------------------------
      PRINT * , 'Taking samples'
      DO i = 1 , ICSAMP
         CALL WOLFF(L,L2,iz,istack,in1,ip1,prob,dseed,isum,iclsiz)
         CALL SUSCEP(L,iz,dsus)
         dsusold(i) = dsus
         CALL ENERG(L,L2,iz,dene,in1,ip1)
         deneold(i) = dene
         dclold(i) = DBLE(iclsiz)
      ENDDO

!     -------------------------------------------------------------------
!     Set the initial state for the vector IPOS, which gives the order of
!     appearance of the configurations. IPOS(1) gives the newest, IPOS(2)
!     the second newest, ..., and IPOS(IC) the oldest configuration.
!     -------------------------------------------------------------------
      PRINT * , 'Setting initial state'
      inewest = ICSAMP
      DO i = 1 , ICSAMP
         ipos(i) = ICSAMP - i + 1
      ENDDO

!     =================================================
!     !!!!!!!!!!!!!! MAIN PROGRAM STARTS !!!!!!!!!!!!!!
!     =================================================
!     Take a number of ISCANS independent measurements.
!     Each measurement corresponds to flipping of a
!     single cluster.
!     =================================================

      DO icnt = 1 , ISCANS

         CALL WOLFF(L,L2,iz,istack,in1,ip1,prob,dseed,isum,iclsiz)
!     -----------------------------------------------------
!     Calculate the susceptibility autocorrelation function
!     corresponding to the latest sample.
!     -----------------------------------------------------
         CALL SUSCEP(L,iz,dsus)
         dsusave = dsusave + dsus
         dsus2 = dsus2 + dsus*dsus
         DO is = 1 , ICSAMP
            dsauto(is) = dsauto(is) + dsusold(ipos(is))*dsus
         ENDDO
!     ---------------------------------------------
!     Calculate the energy autocorrelation function
!     corresponding to the latest sample.
!     ---------------------------------------------
         CALL ENERG(L,L2,iz,dene,in1,ip1)
         deneave = deneave + dene
         dene2 = dene2 + dene*dene
         DO is = 1 , ICSAMP
            deauto(is) = deauto(is) + deneold(ipos(is))*dene
         ENDDO
!     ---------------------------------------------------
!     Then calculate the distribution of updated clusters
!     and their autocorrelation function.
!     ---------------------------------------------------
         dcl = DBLE(iclsiz)
         dclave = dclave + dcl
         dcl2 = dcl2 + dcl*dcl
         DO is = 1 , ICSAMP
            dclauto(is) = dclauto(is) + dclold(ipos(is))*dcl
         ENDDO
         icldst(iclsiz) = icldst(iclsiz) + 1
!     -----------------------------------------------------------------
!     Replace the latest lattice with the second latest and so forth...
!     -----------------------------------------------------------------
         inewest = inewest + 1
         IF ( inewest.GT.ICSAMP ) inewest = 1
         dsusold(inewest) = dsus
         deneold(inewest) = dene
         dclold(inewest) = dcl
!     -----------------------------------
!     Update the order of configurations.
!     -----------------------------------
         DO i = 1 , ICSAMP
            ipos(i) = ipos(i) + 1
            IF ( ipos(i).GT.ICSAMP ) ipos(i) = 1
         ENDDO

      ENDDO

!     ==================
!     End of sampling...
!     ==================
!     ===============================================
!     !!!!!!!!!!!!!! MAIN PROGRAM ENDS !!!!!!!!!!!!!!
!     ===============================================

!     -----------------------------------------------
!     Susceptibility case:
!     Calculate the estimator for the integrated
!     autocorrelation time. In addition, determine
!     the error estimate. For further details see
!     [U. Wolff, Phys. Lett. B {\bf 228}, 379 (1989).
!     -----------------------------------------------

      dsusave = dsusave/ISCANS
!     Average of samples:
      dsaverage = dsusave
      dsusave = dsusave*dsusave
!     Average of squares of samples:
      dsus2 = dsus2/ISCANS
!     Monte Carlo error estimate squared divided by \tau:
      dserror = (dsus2-dsusave)*2.D0/DBLE(ISCANS)

      DO i = 1 , ICSAMP
         dsauto(i) = dsauto(i)/ISCANS
      ENDDO
      dsroo(0) = 1.D0
      DO i = 1 , ICSAMP
         dsroo(i) = (dsauto(i)-dsusave)/(dsus2-dsusave)
      ENDDO
      DO i = 1 , ICSAMP
         dskappa(i) = dsroo(i)/(dsroo(i-1))
      ENDDO
      DO i = 1 , ICSAMP
         dsrw(i) = dsroo(i)/(1.D0-dskappa(i))
      ENDDO
      DO i = 1 , ICSAMP
         dstau(i) = 0.5D0 + dsrw(i)
         IF ( i.GE.2 ) THEN
            DO j = 1 , (i-1)
               dstau(i) = dstau(i) + dsroo(j)
            ENDDO
         ENDIF
      ENDDO
!     Error:
      DO i = 1 , ICSAMP
         dsxw(i) = 0.5D0
         dsyw(i) = 0.5D0
         IF ( i.GE.2 ) THEN
            DO j = 1 , (i-1)
               dsxw(i) = dsxw(i) + dsroo(j)*dsroo(j)
               dsyw(i) = dsyw(i) + (dsroo(j)-dsroo(j-1))                &
     &                   *(dsroo(j)-dsroo(j-1))
            ENDDO
         ENDIF
      ENDDO
      DO i = 1 , ICSAMP
!         DSSIGMA(I) =
!     +        DSTAU(I)*DSTAU(I)*(DBLE(I) - 0.5D0 +
!     +        (1.D0 + DSKAPPA(I))/(1.D0 - DSKAPPA(I))) +
!     +        DSKAPPA(I)*DSXW(I)/((1.D0 - DSKAPPA(I))**2.D0) +
!     +        (DSKAPPA(I)**2.D0)*DSYW(I)/((1.D0 - DSKAPPA(I))**4.D0)
!     The above lines were changed to those below by K. G. Hamilton,
!     2-Sep-95, in order to avoid exponentiation errors that can
!     occur with some compilers when taking X**Y and X<0.
         dssigma(i) = dstau(i)*dstau(i)                                 &
     &                *(DBLE(i)-0.5D0+(1.D0+dskappa(i))/(1.D0-dskappa(i)&
     &                )) + dskappa(i)*dsxw(i)/((1.D0-dskappa(i))**2)    &
     &                + (dskappa(i)**2)*dsyw(i)/((1.D0-dskappa(i))**4)
      ENDDO
      DO i = 1 , ICSAMP
         dssigma(i) = dssigma(i)*4.D0/DBLE(ISCANS)
      ENDDO
      DO i = 1 , ICSAMP
         dssigma(i) = DSQRT(dssigma(i))
      ENDDO

!     -----------------------------------------------
!     Energy case:
!     Calculate the estimator for the integrated
!     autocorrelation time. In addition, determine
!     the error estimate. For further details see
!     [U. Wolff, Phys. Lett. B {\bf 228}, 379 (1989).
!     -----------------------------------------------

      deneave = deneave/ISCANS
      deaverage = deneave
      deneave = deneave*deneave
      dene2 = dene2/ISCANS
      deerror = (dene2-deneave)*2.D0/DBLE(ISCANS)

      DO i = 1 , ICSAMP
         deauto(i) = deauto(i)/ISCANS
      ENDDO
      deroo(0) = 1.D0
      DO i = 1 , ICSAMP
         deroo(i) = (deauto(i)-deneave)/(dene2-deneave)
      ENDDO
      DO i = 1 , ICSAMP
         dekappa(i) = deroo(i)/(deroo(i-1))
      ENDDO
      DO i = 1 , ICSAMP
         derw(i) = deroo(i)/(1.D0-dekappa(i))
      ENDDO
      DO i = 1 , ICSAMP
         detau(i) = 0.5D0 + derw(i)
         IF ( i.GE.2 ) THEN
            DO j = 1 , (i-1)
               detau(i) = detau(i) + deroo(j)
            ENDDO
         ENDIF
      ENDDO
!     Error:
      DO i = 1 , ICSAMP
         dexw(i) = 0.5D0
         deyw(i) = 0.5D0
         IF ( i.GE.2 ) THEN
            DO j = 1 , (i-1)
               dexw(i) = dexw(i) + deroo(j)*deroo(j)
               deyw(i) = deyw(i) + (deroo(j)-deroo(j-1))                &
     &                   *(deroo(j)-deroo(j-1))
            ENDDO
         ENDIF
      ENDDO
      DO i = 1 , ICSAMP
!         DESIGMA(I) =
!     +        DETAU(I)*DETAU(I)*(DBLE(I) - 0.5D0 +
!     +        (1.D0 + DEKAPPA(I))/(1.D0 - DEKAPPA(I))) +
!     +        DEKAPPA(I)*DEXW(I)/((1.D0 - DEKAPPA(I))**2.D0) +
!     +        (DEKAPPA(I)**2.D0)*DEYW(I)/((1.D0 - DEKAPPA(I))**4.D0)
!     The above lines were changed to those below by K. G. Hamilton,
!     2-Sep-95, in order to avoid exponentiation errors that can
!     occur with some compilers when taking X**Y and X<0.
         desigma(i) = detau(i)*detau(i)                                 &
     &                *(DBLE(i)-0.5D0+(1.D0+dekappa(i))/(1.D0-dekappa(i)&
     &                )) + dekappa(i)*dexw(i)/((1.D0-dekappa(i))**2)    &
     &                + (dekappa(i)**2)*deyw(i)/((1.D0-dekappa(i))**4)
      ENDDO
      DO i = 1 , ICSAMP
         desigma(i) = desigma(i)*4.D0/DBLE(ISCANS)
      ENDDO
      DO i = 1 , ICSAMP
         desigma(i) = DSQRT(desigma(i))
      ENDDO

!     -------------
!     Cluster case:
!     -------------------------------------------------------
      dclave = dclave/ISCANS
      dclavr = dclave
      dclrat = dclavr/L2
      dclave = dclave*dclave
      dcl2 = dcl2/ISCANS
      dclerror = (dcl2-dclave)*2.D0/DBLE(ISCANS)

      DO i = 1 , ICSAMP
         dclauto(i) = dclauto(i)/ISCANS
      ENDDO
      dclroo(0) = 1.D0
      DO i = 1 , ICSAMP
         dclroo(i) = (dclauto(i)-dclave)/(dcl2-dclave)
      ENDDO

      DO i = 1 , ICSAMP
         dclkappa(i) = dclroo(i)/(dclroo(i-1))
      ENDDO
      DO i = 1 , ICSAMP
         dclrw(i) = dclroo(i)/(1.D0-dclkappa(i))
      ENDDO
      DO i = 1 , ICSAMP
         dcltau(i) = 0.5D0 + dclrw(i)
         IF ( i.GE.2 ) THEN
            DO j = 1 , (i-1)
               dcltau(i) = dcltau(i) + dclroo(j)
            ENDDO
         ENDIF
      ENDDO
!     Error:
      DO i = 1 , ICSAMP
         dclxw(i) = 0.5D0
         dclyw(i) = 0.5D0
         IF ( i.GE.2 ) THEN
            DO j = 1 , (i-1)
               dclxw(i) = dclxw(i) + dclroo(j)*dclroo(j)
               dclyw(i) = dclyw(i) + (dclroo(j)-dclroo(j-1))            &
     &                    *(dclroo(j)-dclroo(j-1))
            ENDDO
         ENDIF
      ENDDO
      DO i = 1 , ICSAMP
!         DCLSIGMA(I) =
!     +        DCLTAU(I)*DCLTAU(I)*(DBLE(I) - 0.5D0 +
!     +        (1.D0 + DCLKAPPA(I))/(1.D0 - DCLKAPPA(I))) +
!     +        DCLKAPPA(I)*DCLXW(I)/((1.D0 - DCLKAPPA(I))**2.D0) +
!     +        (DCLKAPPA(I)**2.D0)*DCLYW(I)/((1.D0 - DCLKAPPA(I))**4.D0)
!     The above lines were changed to those below by K. G. Hamilton,
!     2-Sep-95, in order to avoid exponentiation errors that can
!     occur with some compilers when taking X**Y and X<0.
         dclsigma(i) = dcltau(i)*dcltau(i)                              &
     &                 *(DBLE(i)-0.5D0+(1.D0+dclkappa(i))               &
     &                 /(1.D0-dclkappa(i))) + dclkappa(i)*dclxw(i)      &
     &                 /((1.D0-dclkappa(i))**2) + (dclkappa(i)**2)      &
     &                 *dclyw(i)/((1.D0-dclkappa(i))**4)
      ENDDO
      DO i = 1 , ICSAMP
         dclsigma(i) = dclsigma(i)*4.D0/DBLE(ISCANS)
      ENDDO
      DO i = 1 , ICSAMP
         dclsigma(i) = DSQRT(dclsigma(i))
      ENDDO

!     ------------------
!     Write the results:
!     ------------------
!     General data:
      WRITE (*,*) ' Parameters in the autocorrelation test: '
      WRITE (*,*) '      Initial seed:                      ' , diseed
      WRITE (*,*) '      Lattice size (L):                  ' , L
      WRITE (*,*) '      Number of samples (ISCANS):        ' , ISCANS
      WRITE (*,*) '      Coupling constant (DK):            ' , DK
      WRITE (*,*) '      Number of omitted confs. (MCBEG):  ' , MCBEG
      WRITE (*,*)
      WRITE (*,*) ' Average energy of the system:           ' ,         &
     &            deaverage
      WRITE (*,*) ' and its squared (error estimate / tau): ' , deerror
      WRITE (*,*)
      WRITE (*,*) ' Average susceptibility of the system:   ' ,         &
     &            dsaverage/DBLE(L2)
      WRITE (*,*) ' and its squared (error estimate / tau): ' ,         &
     &            dserror/DBLE(L2)
      WRITE (*,*)
!     The average cluster size is given here in a non-normalized form.
!     (not divided by the system size L2).
      WRITE (*,*) ' Average flipped cluster size:           ' , dclavr
      WRITE (*,*) ' and its squared (error estimate / tau): ' , dclerror
      WRITE (*,*) ' ----------------------------------------' ,         &
     &            '--------------------------'
      WRITE (*,*) ' The notation <squared (error estimate / tau)>' ,    &
     &            ' means the following:'
      WRITE (*,*) ' to get the correct error estimate, multiply' ,      &
     &            ' the given value by'
      WRITE (*,*) ' the integrated autocorrelation time tau (see' ,     &
     &            ' comments in the code '
      WRITE (*,*) ' for details), and then take a square root.'
      WRITE (*,*) ' ========================================' ,         &
     &            '=========================='
!      CLOSE(22)
!     Susceptibility results:
      WRITE (20,*) '      ==================================='
      WRITE (20,*) '      AUTO-CORRELATION OF SUSCEPTIBILITY:'
      WRITE (20,*) '      ==================================='
      ifin(1) = 0
      ifin(2) = 1
      WRITE (20,*) ifin(1) , DBLE(ifin(2))
      DO i = 1 , ICSAMP
         WRITE (20,*) i , dsroo(i)
      ENDDO
      WRITE (20,*) '      ====================================='
      WRITE (20,*) '      INTEGRATED AC-TIME OF SUSCEPTIBILITY:'
      WRITE (20,*) '      ====================================='
      DO i = 1 , ICSAMP
         WRITE (20,*) i , dstau(i)*dclrat , dssigma(i)*dclrat
      ENDDO
      CLOSE (20)
!     Energy results:
      WRITE (21,*) '      ==========================='
      WRITE (21,*) '      AUTO-CORRELATION OF ENERGY:'
      WRITE (21,*) '      ==========================='
      WRITE (21,*) ifin(1) , DBLE(ifin(2))
      DO i = 1 , ICSAMP
         WRITE (21,*) i , deroo(i)
      ENDDO
      WRITE (21,*) '      ============================='
      WRITE (21,*) '      INTEGRATED AC-TIME OF ENERGY:'
      WRITE (21,*) '      ============================='
      DO i = 1 , ICSAMP
         WRITE (21,*) i , detau(i)*dclrat , desigma(i)*dclrat
      ENDDO
      CLOSE (21)
!     Cluster results:
      WRITE (23,*) '      ====================================='
      WRITE (23,*) '      AUTO-CORRELATION OF FLIPPED CLUSTERS:'
      WRITE (23,*) '      ====================================='
      WRITE (23,*) ifin(1) , DBLE(ifin(2))
      DO i = 1 , ICSAMP
         WRITE (23,*) i , dclroo(i)
      ENDDO
      WRITE (23,*) '      ======================================='
      WRITE (23,*) '      INTEGRATED AC-TIME OF FLIPPED CLUSTERS:'
      WRITE (23,*) '      ======================================='
      DO i = 1 , ICSAMP
         WRITE (23,*) i , dcltau(i)*dclrat , dclsigma(i)*dclrat
      ENDDO
      CLOSE (23)

!     Distribution of flipped clusters:
      DO i = 1 , L2
         iks = icldst(i)
         IF ( iks.NE.0 ) THEN
            WRITE (24,*) i , DBLE(icldst(i))/ISCANS
         ENDIF
      ENDDO
      CLOSE (24)

      CONTINUE
      END
!*==WOLFF.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

!     ============================================================
!     Wolff Monte Carlo algorithm (discrete case). The idea is by
!     U. Wolff [Phys. Rev. Lett. 60 (1988) 1461] and the program
!     is a modification of Ref. [Physica A 167 (1990) 565] by
!     J. S. Wang and R. H. Swendsen.
!     ------------------------------
!     Ilpo Vattulainen, Tampere univ. of tech., Funland.
!     14.4.1993
!     ============================================================

      SUBROUTINE WOLFF(L,L2,Iz,Istack,In1,Ip1,Prob,Dseed,Isum,Iclsiz)

      INTEGER L , L2 , Iz(L,L) , Istack(L2,2) , In1(L) , Ip1(L) ,       &
     &        nn(4,2) , isize , i , j , ipt , ky , kx , Isum , ishere , &
     &        nny , nnx , Iclsiz
      DOUBLE PRECISION Prob
      REAL*8 Dseed
      REAL ran , rans , ranx , rany

      ipt = 0
      Isum = 0

!     ------------------------------------------------------------------
!     Start a Monte Carlo loop to update a total of MC*L2 lattice sites.
!     ------------------------------------------------------------------

!     ISIZE calculates the number of tried updates.
!     ICLSIZ calculates the size of the flipped cluster.

      isize = 1
      Iclsiz = 1

!     ------------------------------------------------------------------------
!     Choose a starting position and change its state immediately. Other parts
!     of a cluster will also be changed immediately after recognition.
!     ------------------------------------------------------------------------
      rany = GGL(Dseed)
      ranx = GGL(Dseed)
      ky = rany*L + 1
      IF ( ky.GT.L ) ky = L
      kx = ranx*L + 1
      IF ( kx.GT.L ) kx = L
      ishere = Iz(ky,kx)
      Iz(ky,kx) = -ishere
!     -----------------------------
!     Periodic boundary conditions:
!     -----------------------------
 120  nn(1,1) = ky
      nn(1,2) = In1(kx)
      nn(2,1) = ky
      nn(2,2) = Ip1(kx)
      nn(3,1) = In1(ky)
      nn(3,2) = kx
      nn(4,1) = Ip1(ky)
      nn(4,2) = kx
!     ------------------------
!     Check nearest neighbors:
!     ------------------------
      DO j = 1 , 4
         nny = nn(j,1)
         nnx = nn(j,2)
         IF ( ishere.NE.Iz(nny,nnx) ) GOTO 125
         isize = isize + 1
         rans = GGL(Dseed)
         IF ( rans.GT.Prob ) GOTO 125
         Iz(nny,nnx) = -Iz(nny,nnx)
         Iclsiz = Iclsiz + 1
!     -----------------------------------------------------------------
!     Increment the stack of lattice sites which are part of a cluster,
!     but whose nearest neighbors have not yet been checked:
!     -----------------------------------------------------------------
         ipt = ipt + 1
         Istack(ipt,1) = nny
         Istack(ipt,2) = nnx
 125  ENDDO
!     --------------------------------------------------------------
!     When IPT equals zero the cluster has reached its maximum size.
!     Otherwise go back and check the remaining possibilities.
!     --------------------------------------------------------------
      IF ( ipt.EQ.0 ) GOTO 140
      ky = Istack(ipt,1)
      kx = Istack(ipt,2)
      ipt = ipt - 1
      GOTO 120
!     --------------------------------------------
!     Calculate the total amount of tried updates:
!     --------------------------------------------
 140  Isum = isize

      CONTINUE
      END
!*==SUSCEP.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

!     =============================================================
!
!     Calculate the susceptibility based on the definition of Wolff
!     [U. Wolff, Phys. Lett. B {\bf 228}, 379 (1989).
!
!     =============================================================
      SUBROUTINE SUSCEP(L,Iz,Dsus)

      INTEGER L , Iz(L,L) , iznum
      DOUBLE PRECISION Dsus

      iznum = 0
      DO iy = 1 , L
         DO ix = 1 , L
            iznum = iznum + Iz(iy,ix)
         ENDDO
      ENDDO
      Dsus = DBLE(iznum)
      Dsus = Dsus*Dsus
      Dsus = Dsus/(L*L)

      CONTINUE
      END
!*==ENERG.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

!     ==============================================================
!
!     Calculate the energy of the system (in variables of U/J).
!
!     ==============================================================

      SUBROUTINE ENERG(L,L2,Iz,Dene,In1,Ip1)

      INTEGER L , L2 , Iz(L,L) , In1(L) , Ip1(L) , iznum
      DOUBLE PRECISION Dene

      iznum = 0
      DO iy = 1 , L
         DO ix = 1 , L
            in1x = In1(ix)
            in1y = In1(iy)
            ip1x = Ip1(ix)
            ip1y = Ip1(iy)
            iznum = iznum + Iz(iy,ix)                                   &
     &              *(Iz(in1y,ix)+Iz(iy,in1x)+Iz(ip1y,ix)+Iz(iy,ip1x))
!            IZNUM = IZNUM + IZ(IY,IX)*(IZ(IN1(IY),IX) +
!     +           IZ(IY,IN1(IX)) + IZ(IP1(IY),IX) + IZ(IY,IP1(IX)))
         ENDDO
      ENDDO
      Dene = DBLE(iznum)/(2*L2)

      CONTINUE
      END
!*==GGL.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

!     ==============================================================
!     A pseudorandom number generator GGL
!     ------------------------------------------------------------

      REAL FUNCTION GGL(Ds)

!     +     D1,
      DOUBLE PRECISION Ds , d2
!      DATA D1/2147483648.D0/
      DATA d2/2147483647.D0/
      Ds = DMOD(16807.D0*Ds,d2)
!     Generate U(0,1] distributed random numbers:
      GGL = Ds/d2

      CONTINUE
      END


      SUBROUTINE EROZ (ROTANG, XFRMT)

      REAL XFRMT (4,4), SN, CS, ROTANG

      CALL IDMAT (4, XFRMT)
      SN = SIN(ROTANG)
      CS = COS(ROTANG)
      XFRMT (1,1) =  CS
      XFRMT (2,2) =  CS
      XFRMT (1,2) = -SN
      XFRMT (2,1) =  SN

      END


      SUBROUTINE DEBIAS(BUF,OBUF,NSAMPS)
C     DEBIAS COMPUTES AND REMOVES THE BIAS (THE MEAN OF THE TRACE).
C  THIS ROUTINE WORKS IN HOST MEMORY.  THE COMPANION AP ROUTINE IS DEMEAN.
C
C COPYRIGHTED BY:
C  PAUL HENKART, SEISMIC REFLECTION PROCESSORS, SAN DIEGO, CA.
C  17 JANUARY 1982.  ALL RIGHTS RESERVED.
C
      DIMENSION BUF(1),OBUF(1)
C
      REALN=FLOAT(NSAMPS)
      AVE=0.
      DO 100 I=1,NSAMPS
  100 AVE=AVE+BUF(I)                                                     /* WATCH OUT FOR OVERFLOW - THIS COULD BE BUF(I)/REALN
      AVE=AVE/REALN                                                     /* BUT SAVING THE DIVIDES WILL REALLY HELP CUT CPU TIME.
      DO 200 I=1,NSAMPS
  200 OBUF(I)=BUF(I)-AVE
      RETURN
      END


module vtk_datasets_unit_tests
    use precision, only : i4k, r8k
    use vtk_cells, only : polygon, voxel
    implicit none
    !! author: Ian Porter
    !! date: 12/17/2017
    !!
    !! unit testing for datasets
    !!
    private
    public :: vtk_datasets_unit
    ! generic information
    integer(i4k), parameter :: n_types  = 5
    integer(i4k), parameter :: vtk_unit = 20
    integer(i4k), parameter :: n_x = 11, n_y = 6, n_z = 3
    character(len=*), dimension(n_types), parameter :: filename = &
        & [ 'struct_pts.vtk      ', &
        &   'struct_grid.vtk     ', &
        &   'rectlnr_grid.vtk    ', &
        &   'polygonal_data.vtk  ', &
        &   'unstruct_grid.vtk   ' ]
    ! structured points
    integer(i4k), dimension(3), parameter :: dims    = &
        & [ n_x, n_y, n_z ]
    real(r8k), dimension(3), parameter    :: origin  = &
        & [ 0.0_r8k, 0.0_r8k, 0.0_r8k ]
    real(r8k), dimension(3), parameter    :: spacing = &
        & [ 0.1_r8k, 0.2_r8k, 0.5_r8k ]
    ! structured grid
    real(r8k), dimension(3,n_x*n_y*n_z), parameter :: points = reshape ( & !! [x, y, z]
        & [ 0.0_r8k, 0.0_r8k, 0.0_r8k, &
        &   0.0_r8k, 0.0_r8k, 0.5_r8k, &
        &   0.0_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.0_r8k, 0.2_r8k, 0.0_r8k, &
        &   0.0_r8k, 0.2_r8k, 0.5_r8k, &
        &   0.0_r8k, 0.2_r8k, 1.0_r8k, &
        &   0.0_r8k, 0.4_r8k, 0.0_r8k, &
        &   0.0_r8k, 0.4_r8k, 0.5_r8k, &
        &   0.0_r8k, 0.4_r8k, 1.0_r8k, &
        &   0.0_r8k, 0.6_r8k, 0.0_r8k, &
        &   0.0_r8k, 0.6_r8k, 0.5_r8k, &
        &   0.0_r8k, 0.6_r8k, 1.0_r8k, &
        &   0.0_r8k, 0.8_r8k, 0.0_r8k, &
        &   0.0_r8k, 0.8_r8k, 0.5_r8k, &
        &   0.0_r8k, 0.8_r8k, 1.0_r8k, &
        &   0.0_r8k, 1.0_r8k, 0.0_r8k, &
        &   0.0_r8k, 1.0_r8k, 0.5_r8k, &
        &   0.0_r8k, 1.0_r8k, 1.0_r8k, &
        &   0.1_r8k, 0.0_r8k, 0.0_r8k, &
        &   0.1_r8k, 0.0_r8k, 0.5_r8k, &
        &   0.1_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.1_r8k, 0.2_r8k, 0.0_r8k, &
        &   0.1_r8k, 0.2_r8k, 0.5_r8k, &
        &   0.1_r8k, 0.2_r8k, 1.0_r8k, &
        &   0.1_r8k, 0.4_r8k, 0.0_r8k, &
        &   0.1_r8k, 0.4_r8k, 0.5_r8k, &
        &   0.1_r8k, 0.4_r8k, 1.0_r8k, &
        &   0.1_r8k, 0.6_r8k, 0.0_r8k, &
        &   0.1_r8k, 0.6_r8k, 0.5_r8k, &
        &   0.1_r8k, 0.6_r8k, 1.0_r8k, &
        &   0.1_r8k, 0.8_r8k, 0.0_r8k, &
        &   0.1_r8k, 0.8_r8k, 0.5_r8k, &
        &   0.1_r8k, 0.8_r8k, 1.0_r8k, &
        &   0.1_r8k, 1.0_r8k, 0.0_r8k, &
        &   0.1_r8k, 1.0_r8k, 0.5_r8k, &
        &   0.1_r8k, 1.0_r8k, 1.0_r8k, &
        &   0.2_r8k, 0.0_r8k, 0.0_r8k, &
        &   0.2_r8k, 0.0_r8k, 0.5_r8k, &
        &   0.2_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.2_r8k, 0.2_r8k, 0.0_r8k, &
        &   0.2_r8k, 0.2_r8k, 0.5_r8k, &
        &   0.2_r8k, 0.2_r8k, 1.0_r8k, &
        &   0.2_r8k, 0.4_r8k, 0.0_r8k, &
        &   0.2_r8k, 0.4_r8k, 0.5_r8k, &
        &   0.2_r8k, 0.4_r8k, 1.0_r8k, &
        &   0.2_r8k, 0.6_r8k, 0.0_r8k, &
        &   0.2_r8k, 0.6_r8k, 0.5_r8k, &
        &   0.2_r8k, 0.6_r8k, 1.0_r8k, &
        &   0.2_r8k, 0.8_r8k, 0.0_r8k, &
        &   0.2_r8k, 0.8_r8k, 0.5_r8k, &
        &   0.2_r8k, 0.8_r8k, 1.0_r8k, &
        &   0.2_r8k, 1.0_r8k, 0.0_r8k, &
        &   0.2_r8k, 1.0_r8k, 0.5_r8k, &
        &   0.2_r8k, 1.0_r8k, 1.0_r8k, &
        &   0.3_r8k, 0.0_r8k, 0.0_r8k, &
        &   0.3_r8k, 0.0_r8k, 0.5_r8k, &
        &   0.3_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.3_r8k, 0.2_r8k, 0.0_r8k, &
        &   0.3_r8k, 0.2_r8k, 0.5_r8k, &
        &   0.3_r8k, 0.2_r8k, 1.0_r8k, &
        &   0.3_r8k, 0.4_r8k, 0.0_r8k, &
        &   0.3_r8k, 0.4_r8k, 0.5_r8k, &
        &   0.3_r8k, 0.4_r8k, 1.0_r8k, &
        &   0.3_r8k, 0.6_r8k, 0.0_r8k, &
        &   0.3_r8k, 0.6_r8k, 0.5_r8k, &
        &   0.3_r8k, 0.6_r8k, 1.0_r8k, &
        &   0.3_r8k, 0.8_r8k, 0.0_r8k, &
        &   0.3_r8k, 0.8_r8k, 0.5_r8k, &
        &   0.3_r8k, 0.8_r8k, 1.0_r8k, &
        &   0.3_r8k, 1.0_r8k, 0.0_r8k, &
        &   0.3_r8k, 1.0_r8k, 0.5_r8k, &
        &   0.3_r8k, 1.0_r8k, 1.0_r8k, &
        &   0.4_r8k, 0.0_r8k, 0.0_r8k, &
        &   0.4_r8k, 0.0_r8k, 0.5_r8k, &
        &   0.4_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.4_r8k, 0.2_r8k, 0.0_r8k, &
        &   0.4_r8k, 0.2_r8k, 0.5_r8k, &
        &   0.4_r8k, 0.2_r8k, 1.0_r8k, &
        &   0.4_r8k, 0.4_r8k, 0.0_r8k, &
        &   0.4_r8k, 0.4_r8k, 0.5_r8k, &
        &   0.4_r8k, 0.4_r8k, 1.0_r8k, &
        &   0.4_r8k, 0.6_r8k, 0.0_r8k, &
        &   0.4_r8k, 0.6_r8k, 0.5_r8k, &
        &   0.4_r8k, 0.6_r8k, 1.0_r8k, &
        &   0.4_r8k, 0.8_r8k, 0.0_r8k, &
        &   0.4_r8k, 0.8_r8k, 0.5_r8k, &
        &   0.4_r8k, 0.8_r8k, 1.0_r8k, &
        &   0.4_r8k, 1.0_r8k, 0.0_r8k, &
        &   0.4_r8k, 1.0_r8k, 0.5_r8k, &
        &   0.4_r8k, 1.0_r8k, 1.0_r8k, &
        &   0.5_r8k, 0.0_r8k, 0.0_r8k, &
        &   0.5_r8k, 0.0_r8k, 0.5_r8k, &
        &   0.5_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.5_r8k, 0.2_r8k, 0.0_r8k, &
        &   0.5_r8k, 0.2_r8k, 0.5_r8k, &
        &   0.5_r8k, 0.2_r8k, 1.0_r8k, &
        &   0.5_r8k, 0.4_r8k, 0.0_r8k, &
        &   0.5_r8k, 0.4_r8k, 0.5_r8k, &
        &   0.5_r8k, 0.4_r8k, 1.0_r8k, &
        &   0.5_r8k, 0.6_r8k, 0.0_r8k, &
        &   0.5_r8k, 0.6_r8k, 0.5_r8k, &
        &   0.5_r8k, 0.6_r8k, 1.0_r8k, &
        &   0.5_r8k, 0.8_r8k, 0.0_r8k, &
        &   0.5_r8k, 0.8_r8k, 0.5_r8k, &
        &   0.5_r8k, 0.8_r8k, 1.0_r8k, &
        &   0.5_r8k, 1.0_r8k, 0.0_r8k, &
        &   0.5_r8k, 1.0_r8k, 0.5_r8k, &
        &   0.5_r8k, 1.0_r8k, 1.0_r8k, &
        &   0.6_r8k, 0.0_r8k, 0.0_r8k, &
        &   0.6_r8k, 0.0_r8k, 0.5_r8k, &
        &   0.6_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.6_r8k, 0.2_r8k, 0.0_r8k, &
        &   0.6_r8k, 0.2_r8k, 0.5_r8k, &
        &   0.6_r8k, 0.2_r8k, 1.0_r8k, &
        &   0.6_r8k, 0.4_r8k, 0.0_r8k, &
        &   0.6_r8k, 0.4_r8k, 0.5_r8k, &
        &   0.6_r8k, 0.4_r8k, 1.0_r8k, &
        &   0.6_r8k, 0.6_r8k, 0.0_r8k, &
        &   0.6_r8k, 0.6_r8k, 0.5_r8k, &
        &   0.6_r8k, 0.6_r8k, 1.0_r8k, &
        &   0.6_r8k, 0.8_r8k, 0.0_r8k, &
        &   0.6_r8k, 0.8_r8k, 0.5_r8k, &
        &   0.6_r8k, 0.8_r8k, 1.0_r8k, &
        &   0.6_r8k, 1.0_r8k, 0.0_r8k, &
        &   0.6_r8k, 1.0_r8k, 0.5_r8k, &
        &   0.6_r8k, 1.0_r8k, 1.0_r8k, &
        &   0.7_r8k, 0.0_r8k, 0.0_r8k, &
        &   0.7_r8k, 0.0_r8k, 0.5_r8k, &
        &   0.7_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.7_r8k, 0.2_r8k, 0.0_r8k, &
        &   0.7_r8k, 0.2_r8k, 0.5_r8k, &
        &   0.7_r8k, 0.2_r8k, 1.0_r8k, &
        &   0.7_r8k, 0.4_r8k, 0.0_r8k, &
        &   0.7_r8k, 0.4_r8k, 0.5_r8k, &
        &   0.7_r8k, 0.4_r8k, 1.0_r8k, &
        &   0.7_r8k, 0.6_r8k, 0.0_r8k, &
        &   0.7_r8k, 0.6_r8k, 0.5_r8k, &
        &   0.7_r8k, 0.6_r8k, 1.0_r8k, &
        &   0.7_r8k, 0.8_r8k, 0.0_r8k, &
        &   0.7_r8k, 0.8_r8k, 0.5_r8k, &
        &   0.7_r8k, 0.8_r8k, 1.0_r8k, &
        &   0.7_r8k, 1.0_r8k, 0.0_r8k, &
        &   0.7_r8k, 1.0_r8k, 0.5_r8k, &
        &   0.7_r8k, 1.0_r8k, 1.0_r8k, &
        &   0.8_r8k, 0.0_r8k, 0.0_r8k, &
        &   0.8_r8k, 0.0_r8k, 0.5_r8k, &
        &   0.8_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.8_r8k, 0.2_r8k, 0.0_r8k, &
        &   0.8_r8k, 0.2_r8k, 0.5_r8k, &
        &   0.8_r8k, 0.2_r8k, 1.0_r8k, &
        &   0.8_r8k, 0.4_r8k, 0.0_r8k, &
        &   0.8_r8k, 0.4_r8k, 0.5_r8k, &
        &   0.8_r8k, 0.4_r8k, 1.0_r8k, &
        &   0.8_r8k, 0.6_r8k, 0.0_r8k, &
        &   0.8_r8k, 0.6_r8k, 0.5_r8k, &
        &   0.8_r8k, 0.6_r8k, 1.0_r8k, &
        &   0.8_r8k, 0.8_r8k, 0.0_r8k, &
        &   0.8_r8k, 0.8_r8k, 0.5_r8k, &
        &   0.8_r8k, 0.8_r8k, 1.0_r8k, &
        &   0.8_r8k, 1.0_r8k, 0.0_r8k, &
        &   0.8_r8k, 1.0_r8k, 0.5_r8k, &
        &   0.8_r8k, 1.0_r8k, 1.0_r8k, &
        &   0.9_r8k, 0.0_r8k, 0.0_r8k, &
        &   0.9_r8k, 0.0_r8k, 0.5_r8k, &
        &   0.9_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.9_r8k, 0.2_r8k, 0.0_r8k, &
        &   0.9_r8k, 0.2_r8k, 0.5_r8k, &
        &   0.9_r8k, 0.2_r8k, 1.0_r8k, &
        &   0.9_r8k, 0.4_r8k, 0.0_r8k, &
        &   0.9_r8k, 0.4_r8k, 0.5_r8k, &
        &   0.9_r8k, 0.4_r8k, 1.0_r8k, &
        &   0.9_r8k, 0.6_r8k, 0.0_r8k, &
        &   0.9_r8k, 0.6_r8k, 0.5_r8k, &
        &   0.9_r8k, 0.6_r8k, 1.0_r8k, &
        &   0.9_r8k, 0.8_r8k, 0.0_r8k, &
        &   0.9_r8k, 0.8_r8k, 0.5_r8k, &
        &   0.9_r8k, 0.8_r8k, 1.0_r8k, &
        &   0.9_r8k, 1.0_r8k, 0.0_r8k, &
        &   0.9_r8k, 1.0_r8k, 0.5_r8k, &
        &   0.9_r8k, 1.0_r8k, 1.0_r8k, &
        &   1.0_r8k, 0.0_r8k, 0.0_r8k, &
        &   1.0_r8k, 0.0_r8k, 0.5_r8k, &
        &   1.0_r8k, 0.0_r8k, 1.0_r8k, &
        &   1.0_r8k, 0.2_r8k, 0.0_r8k, &
        &   1.0_r8k, 0.2_r8k, 0.5_r8k, &
        &   1.0_r8k, 0.2_r8k, 1.0_r8k, &
        &   1.0_r8k, 0.4_r8k, 0.0_r8k, &
        &   1.0_r8k, 0.4_r8k, 0.5_r8k, &
        &   1.0_r8k, 0.4_r8k, 1.0_r8k, &
        &   1.0_r8k, 0.6_r8k, 0.0_r8k, &
        &   1.0_r8k, 0.6_r8k, 0.5_r8k, &
        &   1.0_r8k, 0.6_r8k, 1.0_r8k, &
        &   1.0_r8k, 0.8_r8k, 0.0_r8k, &
        &   1.0_r8k, 0.8_r8k, 0.5_r8k, &
        &   1.0_r8k, 0.8_r8k, 1.0_r8k, &
        &   1.0_r8k, 1.0_r8k, 0.0_r8k, &
        &   1.0_r8k, 1.0_r8k, 0.5_r8k, &
        &   1.0_r8k, 1.0_r8k, 1.0_r8k ], [3,n_x*n_y*n_z] )
    ! rectilinear grid
    real(r8k), dimension(n_x), parameter :: x_coords = &
        & [ 0.1_r8k, 0.2_r8k, 0.3_r8k, 0.4_r8k, 0.5_r8k, 0.6_r8k, 0.7_r8k, 0.8_r8k, 0.9_r8k, 1.0_r8k, 1.1_r8k ]
    real(r8k), dimension(n_y), parameter :: y_coords = &
        & [ 0.2_r8k, 0.4_r8k, 0.6_r8k, 0.8_r8k, 1.0_r8k, 1.2_r8k ]
    real(r8k), dimension(n_z), parameter :: z_coords = &
        & [ 0.5_r8k, 1.0_r8k, 1.5_r8k ]
    ! polygonal data
    integer(i4k), parameter :: n_x_poly = 3, n_y_poly = 3, n_z_poly = 3, n_faces = 20
    real(r8k), dimension(3,n_x_poly*n_y_poly*n_z_poly), parameter :: points_poly = reshape ( &
        & [ 0.0_r8k,   0.0_r8k,   0.0_r8k,  &
        &   0.5_r8k,   0.0_r8k,   0.0_r8k,  &
        &   1.0_r8k,   0.0_r8k,   0.0_r8k,  &
        &   0.0_r8k,   0.5_r8k,   0.0_r8k,  &
        &   0.5_r8k,   0.5_r8k,   0.0_r8k,  &
        &   1.0_r8k,   0.5_r8k,   0.0_r8k,  &
        &   0.0_r8k,   1.0_r8k,   0.0_r8k,  &
        &   0.5_r8k,   1.0_r8k,   0.0_r8k,  &
        &   1.0_r8k,   1.0_r8k,   0.0_r8k,  &
        &   0.25_r8k,  0.25_r8k,  0.5_r8k,  &
        &   0.50_r8k,  0.25_r8k,  0.5_r8k,  &
        &   0.75_r8k,  0.25_r8k,  0.5_r8k,  &
        &   0.25_r8k,  0.50_r8k,  0.5_r8k,  &
        &   0.50_r8k,  0.50_r8k,  0.5_r8k,  &
        &   0.75_r8k,  0.50_r8k,  0.5_r8k,  &
        &   0.25_r8k,  0.75_r8k,  0.5_r8k,  &
        &   0.50_r8k,  0.75_r8k,  0.5_r8k,  &
        &   0.75_r8k,  0.75_r8k,  0.5_r8k,  &
        &   0.375_r8k, 0.375_r8k, 0.75_r8k, &
        &   0.50_r8k,  0.375_r8k, 0.75_r8k, &
        &   0.625_r8k, 0.375_r8k, 0.75_r8k, &
        &   0.375_r8k, 0.50_r8k,  0.75_r8k, &
        &   0.50_r8k,  0.50_r8k,  0.75_r8k, &
        &   0.625_r8k, 0.50_r8k,  0.75_r8k, &
        &   0.375_r8k, 0.625_r8k, 0.75_r8k, &
        &   0.50_r8k,  0.625_r8k, 0.75_r8k, &
        &   0.625_r8k, 0.625_r8k, 0.75_r8k ], [3,n_x_poly*n_y_poly*n_z_poly] )
    type(polygon), dimension(n_faces) :: polygon_faces
    ! unstructured grid
    integer(i4k), parameter :: n_unstr_grid = 24, n_unstr_cells = 5
    real(r8k), dimension(3,n_unstr_grid), parameter :: points_unstr_grid = reshape ( &
        & [ 0.5_r8k, 0.0_r8k, 0.0_r8k, &
        &   1.0_r8k, 0.0_r8k, 0.0_r8k, &
        &   0.5_r8k, 0.5_r8k, 0.0_r8k, &
        &   1.0_r8k, 0.5_r8k, 0.0_r8k, &
        &   0.5_r8k, 0.0_r8k, 0.5_r8k, &
        &   1.0_r8k, 0.0_r8k, 0.5_r8k, &
        &   0.5_r8k, 0.5_r8k, 0.5_r8k, &
        &   1.0_r8k, 0.5_r8k, 0.5_r8k, &
        &   0.0_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.5_r8k, 0.0_r8k, 1.0_r8k, &
        &   1.0_r8k, 0.0_r8k, 1.0_r8k, &
        &   1.5_r8k, 0.0_r8k, 1.0_r8k, &
        &   0.0_r8k, 0.5_r8k, 1.0_r8k, &
        &   0.5_r8k, 0.5_r8k, 1.0_r8k, &
        &   1.0_r8k, 0.5_r8k, 1.0_r8k, &
        &   1.5_r8k, 0.5_r8k, 1.0_r8k, &
        &   0.0_r8k, 0.0_r8k, 1.5_r8k, &
        &   0.5_r8k, 0.0_r8k, 1.5_r8k, &
        &   1.0_r8k, 0.0_r8k, 1.5_r8k, &
        &   1.5_r8k, 0.0_r8k, 1.5_r8k, &
        &   0.0_r8k, 0.5_r8k, 1.5_r8k, &
        &   0.5_r8k, 0.5_r8k, 1.5_r8k, &
        &   1.0_r8k, 0.5_r8k, 1.5_r8k, &
        &   1.5_r8k, 0.5_r8k, 1.5_r8k ], [3,n_unstr_grid] )
    type(voxel), dimension(n_unstr_cells) :: cells

contains

    subroutine vtk_datasets_unit (test_pass)
        use vtk_datasets, only : dataset, struct_pts, struct_grid, rectlnr_grid, polygonal_data, unstruct_grid
        use vtk,          only : vtk_legacy_write
        implicit none
        !!
        !! loops over each dataset type, performs a write, then performs a read on a different dataset
        !! and compares the two to make sure they are identical
        class(dataset), allocatable :: vtk_dataset_1, vtk_dataset_2
        integer(i4k)                :: i
        logical, intent(out)        :: test_pass
        logical, dimension(n_types) :: individual_tests_pass

        do i = 1, n_types
            if (allocated(vtk_dataset_1)) deallocate (vtk_dataset_1)
            if (allocated(vtk_dataset_2)) deallocate (vtk_dataset_2)
            select case (i)
            case (1)
                !! structured points
                allocate(struct_pts::vtk_dataset_1, vtk_dataset_2)
                call vtk_dataset_1%init(dims=dims, origin=origin, spacing=spacing)
            case (2)
                !! structured grid
                allocate(struct_grid::vtk_dataset_1, vtk_dataset_2)
                call vtk_dataset_1%init(dims=dims, points=points)
            case (3)
                !! rectilinear grid
                allocate(rectlnr_grid::vtk_dataset_1, vtk_dataset_2)
                call vtk_dataset_1%init(dims=dims, x_coords=x_coords, y_coords=y_coords, z_coords=z_coords)
            case (4)
                !! polygonal data
                call polygon_faces(1)%setup ( [ 0, 1, 4, 3 ] )
                call polygon_faces(2)%setup ( [ 1, 2, 5, 4 ] )
                call polygon_faces(3)%setup ( [ 3, 4, 7, 6 ] )
                call polygon_faces(4)%setup ( [ 4, 5, 8, 7 ] )
                call polygon_faces(5)%setup ( [ 9, 10, 13, 12 ] )
                call polygon_faces(6)%setup ( [ 10, 11, 14, 13 ] )
                call polygon_faces(7)%setup ( [ 12, 13, 16, 15 ] )
                call polygon_faces(8)%setup ( [ 13, 14, 17, 16 ] )
                call polygon_faces(9)%setup ( [ 18, 19, 22, 21 ] )
                call polygon_faces(10)%setup ( [ 19, 20, 23, 22 ] )
                call polygon_faces(11)%setup ( [ 21, 22, 25, 24 ] )
                call polygon_faces(12)%setup ( [ 22, 23, 26, 25 ] )
                call polygon_faces(13)%setup ( [ 0, 1, 10, 19, 18, 9 ] )
                call polygon_faces(14)%setup ( [ 1, 2, 11, 20, 19, 10 ] )
                call polygon_faces(15)%setup ( [ 0, 3, 12, 21, 18, 9 ] )
                call polygon_faces(16)%setup ( [ 3, 6, 15, 24, 21, 12 ] )
                call polygon_faces(17)%setup ( [ 6, 7, 16, 25, 24, 15 ] )
                call polygon_faces(18)%setup ( [ 7, 8, 17, 26, 25, 16 ] )
                call polygon_faces(19)%setup ( [ 8, 5, 14, 23, 26, 17 ] )
                call polygon_faces(20)%setup ( [ 5, 2, 11, 20, 23, 14 ] )
                allocate(polygonal_data::vtk_dataset_1, vtk_dataset_2)
                call vtk_dataset_1%init(dims=dims, points=points_poly, polygons=polygon_faces)
            case (5)
                !! unstructured grid
                call cells(1)%setup ( [ 0, 1, 2, 3, 4, 5, 6, 7 ] )
                call cells(2)%setup ( [ 4, 5, 6, 7, 9, 10, 13, 14 ] )
                call cells(3)%setup ( [ 8, 9, 12, 13, 16, 17, 20, 21 ] )
                call cells(4)%setup ( [ 9, 10, 13, 14, 17, 18, 21, 22 ] )
                call cells(5)%setup ( [ 10, 11, 14, 15, 18, 19, 22, 23 ] )
                allocate(unstruct_grid::vtk_dataset_1, vtk_dataset_2)
                call vtk_dataset_1%init(points=points_unstr_grid, cells=cells)
            end select

            !! data type is generated from the defined values above
            open (unit=vtk_unit, file=filename(i), form='formatted')
            call vtk_dataset_1%write(vtk_unit)
            close(unit=vtk_unit)

            !! data type is generated from the read
            open (unit=vtk_unit, file=filename(i), status='old', form='formatted')
            call vtk_dataset_2%read(vtk_unit)
            close(unit=vtk_unit)

            !! compare the read file and the written/read file to ensure both types are the same
            individual_tests_pass(i) = .not. (vtk_dataset_1 .diff. vtk_dataset_2)

        end do

        test_pass = all(individual_tests_pass)

    end subroutine vtk_datasets_unit

end module vtk_datasets_unit_tests

program vtk_datasets_test
    use vtk_datasets_unit_tests, only : vtk_datasets_unit
    use vtkmofopassfail,         only : all_tests_pass
    implicit none
    !! author: Ian Porter
    !! date: 12/14/2017
    !!
    !! driver testing subroutine for the attributes information
    !!
    logical :: test_passes = .false.

    call vtk_datasets_unit (test_passes)

    if (test_passes) call all_tests_pass()

end program vtk_datasets_test


module riemann_mod

use constants_mod

contains

!! HLLE Riemann solver
pure function xriemann(U_L,U_R) result(F)

    use equations_const_mod
    use equations_mod, only: pressure
    use setup_config_mod, only: kappa

    use equations_mod, only: flux => xflux

    real(dp), intent(in) :: U_L(N_VARS), U_R(N_VARS)
    real(dp)             :: F(N_VARS)

    real(dp) :: F_L(N_VARS), F_R(N_VARS)

    real(dp) :: c_L,c_R !! sound speed
    real(dp) :: H_L,H_R !! enthalpy
    real(dp) :: p_L,p_R !! pressure
    real(dp) :: S_L,S_R !! signal wave speed
    real(dp) :: V_L(N_DIMS),V_R(N_DIMS) !! velocities

    real(dp) :: sqrtrho_L,sqrtrho_R,ssqrtrho,absvel
    real(dp), parameter :: beta = SQRT(0.5_dp*(kappa-1.0_dp)/kappa)

    real(dp) :: roeVel(N_DIMS),roeH,roeC

    !! velocities
    V_L = U_L(MOMX_VAR:MOMZ_VAR)/U_L(DENS_VAR)
    V_R = U_R(MOMX_VAR:MOMZ_VAR)/U_R(DENS_VAR)

    !! pressures
    p_L = pressure(U_L)
    p_R = pressure(U_R)

    !! sound speeds
    c_L = SQRT(kappa*p_L/U_L(DENS_VAR))
    c_R = SQRT(kappa*p_R/U_R(DENS_VAR))

    !! enthalpy
    H_L = (U_L(ENER_VAR) + p_L)/U_L(DENS_VAR)
    H_R = (U_R(ENER_VAR) + p_R)/U_R(DENS_VAR)

    !! auxiliaries
    SqrtRho_L = SQRT(U_L(DENS_VAR))
    SqrtRho_R = SQRT(U_R(DENS_VAR))
    sSqrtRho  = 1.0_dp/(SqrtRho_L+SqrtRho_R)

    !! Roe averages
    RoeVel    = (SqrtRho_R*V_R + SqrtRho_L*V_L) * sSqrtRho
    RoeH      = (SqrtRho_R*H_R + SqrtRho_L*H_L) * sSqrtRho
    absVel    = DOT_PRODUCT(RoeVel,RoeVel)
    RoeC      = SQRT((kappa-1.0_dp)*(RoeH-0.5_dp*absVel))

    !! signal velocities
    S_L = MIN(RoeVel(X_DIR) - RoeC, V_L(X_DIR) - beta*c_L, 0.0_dp)
    S_R = MAX(RoeVel(X_DIR) + RoeC, V_R(X_DIR) + beta*c_R, 0.0_dp)

    if (S_L .GE. 0.0_dp .and. S_R .GT. 0.0_dp) then

        F = flux(U_L)

    elseif (S_R .LE. 0.0_dp .and. S_L .LT. 0.0_dp) then

        F = flux(U_R)

    else

        F_L = flux(U_L)
        F_R = flux(U_R)

        F = (S_R*F_L - S_L*F_R + S_L*S_R*(U_R - U_L)) / (S_R - S_L)

    end if

end function

pure function yriemann(uL,uR) result(sf)

    use equations_const_mod

    real(dp), intent(in) :: uL(N_VARS), uR(N_VARS)
    real(dp)             :: sf(N_VARS)

    real(dp) :: ruL(N_VARS), ruR(N_VARS), rf(N_VARS) !! rotated

    ruL(DENS_VAR) = uL(DENS_VAR)
    ruL(MOMX_VAR) = uL(MOMY_VAR)
    ruL(MOMY_VAR) = uL(MOMZ_VAR)
    ruL(MOMZ_VAR) = uL(MOMX_VAR)
    ruL(ENER_VAR) = uL(ENER_VAR)

    ruR(DENS_VAR) = uR(DENS_VAR)
    ruR(MOMX_VAR) = uR(MOMY_VAR)
    ruR(MOMY_VAR) = uR(MOMZ_VAR)
    ruR(MOMZ_VAR) = uR(MOMX_VAR)
    ruR(ENER_VAR) = uR(ENER_VAR)

    rf = xriemann(ruL,ruR)

    sf(DENS_VAR) = rf(DENS_VAR)
    sf(MOMX_VAR) = rf(MOMZ_VAR)
    sf(MOMY_VAR) = rf(MOMX_VAR)
    sf(MOMZ_VAR) = rf(MOMY_VAR)
    sf(ENER_VAR) = rf(ENER_VAR)

end function

pure function zriemann(uL,uR) result(sf)

    use equations_const_mod

    real(dp), intent(in) :: uL(N_VARS), uR(N_VARS)
    real(dp)             :: sf(N_VARS)

    real(dp) :: ruL(N_VARS), ruR(N_VARS), rf(N_VARS) !! rotated

    ruL(DENS_VAR) = uL(DENS_VAR)
    ruL(MOMX_VAR) = uL(MOMZ_VAR)
    ruL(MOMY_VAR) = uL(MOMX_VAR)
    ruL(MOMZ_VAR) = uL(MOMY_VAR)
    ruL(ENER_VAR) = uL(ENER_VAR)

    ruR(DENS_VAR) = uR(DENS_VAR)
    ruR(MOMX_VAR) = uR(MOMZ_VAR)
    ruR(MOMY_VAR) = uR(MOMX_VAR)
    ruR(MOMZ_VAR) = uR(MOMY_VAR)
    ruR(ENER_VAR) = uR(ENER_VAR)

    rf = xriemann(ruL,ruR)

    sf(DENS_VAR) = rf(DENS_VAR)
    sf(MOMX_VAR) = rf(MOMY_VAR)
    sf(MOMY_VAR) = rf(MOMZ_VAR)
    sf(MOMZ_VAR) = rf(MOMX_VAR)
    sf(ENER_VAR) = rf(ENER_VAR)

end function

end module


      SUBROUTINE MF_EMTRX
     &          (lenset)

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

c     The magnetoionic eigenvectors are found. They are defined at
c     HTNTRP for the condition that the electron density is negligible.
c     The first element of each vector is Hy and the other is Ey. A
c     separate set of eigenvectors is found for upgoing waves and for
c     downgoing waves. For additional description see Section II of
c     NOSC TR 1143.

c  Change History:
c     26 Oct 95     Changed to get the LOG unit from LWPC_LUN.CMN.

c*******************!***************************************************

      implicit complex (a-h,o-z)

c     LWPC parameters
      include      'lwpc_lun.cmn'

      parameter    (mxeigen=50)

      character*  8 archive,prgm_id
      character* 20 xmtr_id,path_id
      character* 40 prfl_id
      character* 80 case_id
      character*120 file_id
      integer       pflag,pindex,rprnt,xprnt
      real          freq,tlat,tlon,bearng,rhomx,rlat,rlon,rrho,
     &              lat,lon,rho,azim,dip,bfield,sigma,epsr,beta,hprime,
     &              ranger,rangei,atnmax,lub,h,
     &              rtol,xintrp,htntrp,d,z0,zz,
     &              hofwr,topht,botht,
     &              dcl,dcm,dcn,ec,
     &              omega,wavenr,
     &              dclsq,dcmsq,dcnsq,psq,t1,t2

      common/lwpc_in/archive,file_id(3),prgm_id,
     &               case_id,prfl_id,xmtr_id,path_id,
     &               freq,tlat,tlon,bearng,rhomx,rlat,rlon,rrho,pflag,
     &               lat,lon,rho,azim,dip,bfield,sigma,epsr,beta,hprime,
     &               hofwr,topht,botht,pindex
     &      /lwpc_mf/ranger(2),rangei(2),atnmax,lub,h,
     &               eigen(mxeigen),nreigen

     &      /mf_drcs/dcl,dcm,dcn,ec,g,q
     &      /mf_emtx/e(2,2,2),de(2,2,2),ei(2,2,2),dei(2,2,2)
     &      /mf_flag/iexact,iovflo,kexact,lowg,nodivd,noevct,
     &               nofinl,nointg,nomesh,notlin
     &      /mf_hgts/rtol,xintrp,htntrp,d,z0,zz
     &      /mf_mode/theta,c,s,csq,ssq,omega,wavenr,ideriv
     &      /mf_prnt/lprnt,lgprnt,mprnt,mrprnt,msprnt,mzprnt,rprnt,xprnt
     &      /mf_rseq/r0(4),drdt(4),d2rdt2(4),d3rdt3(4),
     &               zetap(2),gammap(2),theta0,extra

c     Initialization of parameters
      dclsq=dcl**2
      dcmsq=dcm**2
      dcnsq=dcn**2

      c=COS(theta*0.01745329252)
      s=SIN(theta*0.01745329252)
      csq=c**2
      ssq=s**2

      psq=1.+ec
      qsq=csq+ec
      q=SQRT(qsq)
      if (REAL(c) .lt. 0.) q = -q

c     N=1: upgoing waves; N=2: downgoing
      ud=1.
      do n=1,2

         a= dcl*s+ud*dcn*q
         b=-dcn*s+ud*dcl*q
         w=(dcmsq*psq-b**2)*g
         hy=2.*(a+dcm*b*g)*psq
         ey=2.*(a-dcm*b*g)

         zsq=((b**2+dcmsq*psq)*g)**2-4.*a**2*psq
         zeta=SQRT(zsq)

c        LENSET is set to a non-zero value in MF_INTROE for THETA at the
c        center of the search rectangle and set to zero for all other
c        locations in the rectangle. The sign of ZETA is chosen so that
c        W+ZETA has the larger magnitude. The sign of ZETA elsewhere is
c        chosen so that the value of ZETA is closer to that of ZETA at
c        the center.

         if (lenset .ne. 0) zetap(n)=w

         t=zeta-zetap(n)
         t1=REAL(t)**2+AIMAG(t)**2
         t=zeta+zetap(n)
         t2=REAL(t)**2+AIMAG(t)**2
         if (t1 .gt. t2) zeta=-zeta
         if (lenset .ne. 0) zetap(n)=zeta

         if (mrprnt .ne. 0 .and. lenset .ne. 0)
     &      write(lwpcLOG_lun,
     &          '(''MF_EMTRX: zeta '',i1,''='',1p2e11.3)')
     &              n,zeta

         wpz=w+zeta

c        GAMMA is the denominator of each element of each eigenvector.
c        The sign of GAMMA is chosen so that the value of GAMMA is
c        closer to that of GAMMA at the center of the rectangle.

         gamsq=-2.*zeta*wpz
         gamma=SQRT(gamsq)

         if (lenset .ne. 0) gammap(n)=gamma

         t=gamma-gammap(n)
         t1=REAL(t)**2+AIMAG(t)**2
         t=gamma+gammap(n)
         t2=REAL(t)**2+AIMAG(t)**2
         if (t1 .gt. t2) gamma=-gamma

         v=1./gamma

c        The 2x2 matrix of eigenvectors
         e(1,1,n)= hy*v
         e(2,1,n)=wpz*v
         e(1,2,n)=wpz*v
         e(2,2,n)= ey*v

         if (ideriv .eq. 1) then

c           Get the derivatives with respect to cosine(THETA)
            ds=-c/s
            dq=c/q

            da= dcl*ds+ud*dcn*dq
            db=-dcn*ds+ud*dcl*dq
            dw=-2.*b*db*g
            dhy=2.*(da+dcm*db*g)*psq
            dey=2.*(da-dcm*db*g)

            dzsq=4.*(b**2+dcmsq*psq)*b*db*g**2-8.*a*da*psq
            dzeta=dzsq/(2.*zeta)

            dwpz=dw+dzeta
            dgamsq=-2.*(dzeta*wpz+zeta*dwpz)
            dgamma=dgamsq/(2.*gamma)

            dv=-dgamma/gamma**2

            de(1,1,n)=dhy*v+hy*dv
            de(2,1,n)=dwpz*v+wpz*dv
            de(1,2,n)=de(2,1,n)
            de(2,2,n)=dey*v+ey*dv
         end if

c        Inverse of the eigenvector matrix is found. The formulation for
c        GAMMA was chosen such that the determinant of the 2x2 matrix of
c        eigenvectors and, hence, its inverse are each equal to one.
         ei(1,1,n)= e(2,2,n)
         ei(2,1,n)=-e(2,1,n)
         ei(1,2,n)=-e(1,2,n)
         ei(2,2,n)= e(1,1,n)

         if (ideriv .eq. 1) then
            dei(1,1,n)= de(2,2,n)
            dei(2,1,n)=-de(2,1,n)
            dei(1,2,n)=-de(1,2,n)
            dei(2,2,n)= de(1,1,n)
         end if

c        Change the sign and index for downgoing waves.
         ud=-ud
      end do

      if (mrprnt .ne. 0 .and. lenset .ne. 0) then
         write(lwpcLOG_lun,
     &       '(''MF_EMTRX: Eigenvectors for   upgoing waves'')')
         write(lwpcLOG_lun,
     &       '((11x,2(1pe14.3,e11.3)))')
     &        ((e(l,k,1),k=1,2),l=1,2)
         write(lwpcLOG_lun,
     &       '(''MF_EMTRX: Eigenvectors for downgoing waves'')')
         write(lwpcLOG_lun,
     &       '((11x,2(1pe14.3,e11.3)))')
     &        ((e(l,k,2),k=1,2),l=1,2)
      end if
      RETURN
      END      ! MF_EMTRX


  module countdigits
   include 'cts_mprec.h'
   implicit none
   private
   public :: ctscountdigits
   contains
!
   subroutine ctscountdigits(mcountd)
   include 'cts_mpr.h'
    :: x
   integer :: i,digit
   integer, intent(out) :: mcountd
   x      = 1.d0
   x      = x/3.d0
   mcountd= 0; digit  = 3
   do while(digit.eq.3)
    digit  = nint(10*x-x)
    mcountd= mcountd+1
    x      = 10*x-3
   enddo
   mcountd  = mcountd-1
   end subroutine ctscountdigits
  end module countdigits
!
  subroutine ctsinit(limitvalue,scaloopin,ext_num_for_r1in)
   use combinatorics
   use scale
   use countdigits
   use avh_olo_forCutTools
   use avh_olo_forCutTools_units
   include 'cts_mprec.h'
   implicit none
   integer, intent(in) :: scaloopin
   include 'cts_dpr.h'
    , intent(in) :: limitvalue
   integer :: idig,ncountd
   include 'cts_dpr.h'
    :: thrsin
   include 'cts_mpr.h'
    :: one
   logical, intent(in) :: ext_num_for_r1in
   include 'cts_mpinit.h'
   limit= limitvalue ! limit of precision below which the mp routines activate
   call ctscountdigits(ncountd)
   write (*,*) ' '
   write (*,'(a72)') '------------------------------------------------------------------------'
   write (*,'(a72)') '|              You are using CutTools - Version 1.9.3                  |'
   write (*,'(a72)') '|              Authors: G. Ossola, C. Papadopoulos, R. Pittau          |'
   write (*,'(a72)') '|              Published in JHEP 0803:042,2008                         |'
   write (*,'(a72)') '|              http://www.ugr.es/~pittau/CutTools                      |'
   write (*,'(a72)') '|                                                                      |'
   if (ncountd.gt.50) then
    write(*,'(a72)') '|              Internal mproutines detected                            |'
   endif
   write(*,'(a28,i4.2,a40)')'|              Compiler with',ncountd,'  significant digits detetected        |'
   write (*,'(a72)') '---------------------------------------------------------------------- '
   write (*,*) '  '
!
!  Too large values of ncountd are not supported by avh
!
   ncountd= min(34,ncountd)
!
   call load_combinatorics
!
!  Allocate all the needed variables
!
   call allocating
!
!  Initilaization of the scalar 1-loop libraries:
!
!  scaloop= 1 -> looptools 1-loop scalar functions (not implemented yet)
!  scaloop= 2 -> avh       1-loop scalar functions (massive with complex masses)
!  scaloop= 3 -> qcdloop   1-loop scalar functions (Ellis and Zanderighi)
!
   scaloop= scaloopin
   ext_num_for_r1= ext_num_for_r1in
   call set_unit('all',-1)
   if    (scaloop.eq.2) then
!
!    avh initialization:
!
     thrsin= 1.d-6
     call olo_precision(ncountd)
     call olo_onshell(thrsin)
   elseif(scaloop.eq.3) then
!
!    qcdloop initialization:
!
     call qlinit
!
!    also OneLOop is used for rank 1 and 2 2-point functions:
!
     thrsin= 1.d-6
     call olo_precision(ncountd)
     call olo_onshell(thrsin)
   else
    stop 'value of scaloop not allowed'
   endif
   contains
!
   subroutine allocating
    use dimensions
    use denominators
    use coefficients
    use loopfunctions
    use mp_loopfunctions
    call load_dimensions
    call dp_allocate_den
    call dp_allocate_arrays(dmns)
    call mp_allocate_den
    call mp_allocate_arrays(dmns)
    call allocate_loopfun(dmns)
    call allocate_mp_loopfun(dmns)
   end subroutine allocating
  end subroutine ctsinit
!
  subroutine ctsstatistics(discarded)
  use scale
  implicit none
  logical, intent(out) :: discarded
  write(*,*) 'n_tot =',n_tot  ! total n. of points
  write(*,*) 'n_mp  =',n_mp   ! n. of points evaluated in mult. prec.
  write(*,*) 'n_unst=',n_unst ! n. of unstable points
  if (n_unst.ne.0) then
   discarded=.true.
  else
   discarded=.false.
  endif
  end subroutine ctsstatistics


module scene
    implicit none

    real, parameter :: pi = 3.14159265
    ! camera geometry
    real, dimension(3) :: cam_position = (/ 0.0,0.0,800.0 /)
    real, dimension(3) :: cam_direction = (/ 0.0,0.0, -1.0 /)
    real, dimension(3) :: ver = (/ 0.0, 1.0, 0.0 /)
    real, parameter :: fov = 50.0 /180*pi

    ! ambient lighting
    real, dimension(3) :: ambient = (/ 0.3, 0.3, 0.3 /)

    ! Spheres
    real, dimension(4,5) :: spheres= reshape( &
        (/ 0.0, 0.0, -400.0, 100.0, &
           200.0, 50.0, -100.0, 150.0, &
           0.0, -1200.0, -500.0, 1000.0, &
           -100.0, 25.0, -300.0, 50.0, &
           0.0, 100.0, -250.0, 25.0 /) ,shape(spheres))

    ! Materials
    real, dimension(8,4) :: mats = reshape( &
        (/ .7, 1.0, .7, .5, .7, .5, 25.0, .3, &
           .5, .5, .5, .5, .7, .5, 25.0, .3, &
           1.0, .6, .1, .5, .7, .5, 25.0, .3, &
           .7, .6, 1.0, .5, .4, .8, 25.0, .3 /), shape(mats))
    integer :: sphere_mats(5) = (/ 1,1,2,3,1 /)

    ! Lights
    real, dimension(6,2) :: lights = reshape( &
        (/ -100.0, 150.0, 400.0, 0.7, .7, .7, &
           400.0, 100.0, 150.0, .7, 0.0, .7 /), shape(lights))

end module scene


subroutine ApplyErrorCriteria(MPIComm,nelem,RefinerErrorCriteria,RefinerErrorLimits,error,markel)
   use typre
   use MPI
   implicit none
   integer(ip)  :: nelem,MPIcomm
   character(9) :: RefinerErrorCriteria
   real(rp)     :: RefinerErrorLimits(2),error(nelem)
   integer(ip)  :: markel(nelem)

   integer(ip) :: ielem
   integer(ip), parameter :: numboxes = 10
   real(rp) :: lmaxerror,lminerror,maxerror,minerror,lerrorboxes(numboxes),errorboxes(numboxes)
   real(rp) :: ratio,errorinterval
   integer(ip) :: ibox,gnelem
   integer(ip) :: ObjectiveNumberOfElements,ierr
   real(rp) :: BetaParameter
   real(rp) :: NelemRatio,chi,epsilon1,epsilon2,ErrorValue1,ErrorValue2
   real(rp) :: MeanValue,Deviation,RefinementRatio,ErrorCenter

   integer(ip), save :: ipass = 0

   if (RefinerErrorCriteria == 'Tolerance') then
      do ielem = 1,nelem
         if (error(ielem) > RefinerErrorLimits(1)) then
            markel(ielem) = 1
         elseif (error(ielem) < RefinerErrorLimits(2)) then
            markel(ielem) = -1
         else
            markel(ielem) = 0
         endif
      enddo
   elseif (RefinerErrorCriteria == 'Elements') then
      !This refinement criteria follows Algorithm 3 in:
      !Badia Baiges "ADAPTIVE FINITE ELEMENT SIMULATION OF INCOMPRESSIBLE FLOWS BY
      !HYBRID CONTINUOUS-DISCONTINUOUS GALERKIN FORMULATIONS"

      call runend('This is not working')

      ObjectiveNumberOfElements = RefinerErrorLimits(1)
      BetaParameter = RefinerErrorLimits(2)

      !First, determine the maximum and minimum error amongst all processors
      lmaxerror = maxval(error)
      lminerror = minval(error)

      call  MPI_AllREDUCE( lmaxerror, maxerror, 1, MPI_REAL8, MPI_MAX,MPIcomm, ierr )
      call  MPI_AllREDUCE( lminerror, minerror, 1, MPI_REAL8, MPI_MIN,MPIcomm, ierr )

      !Secondly split that interval into 10 parts and count how many elemnts
      !there are in each part
      !This allows us to build a piecewise linear model of the number of elements below a certain error threshold
      lerrorboxes(1:numboxes) = 0
      errorinterval = maxerror-minerror

      if (errorinterval == 0.0_rp) then
         markel = 0
         return
      endif

      do ielem = 1,nelem
         !Some elements are repeated in some processors, results will not be exactly the same when run with different number of processors
         ratio = (error(ielem)-minerror)/errorinterval
         ibox = min(numboxes,max(1,ceiling(ratio*numboxes)))
         lerrorboxes(ibox) = lerrorboxes(ibox)+1

      enddo

      call  MPI_AllREDUCE( lerrorboxes, errorboxes, numboxes, MPI_REAL8, MPI_SUM,MPIcomm, ierr )
      gnelem = sum(errorboxes(1:numboxes))

      !Cumulative proportion
      errorboxes = errorboxes/gnelem
      do ibox = 2,numboxes
         errorboxes(ibox) = errorboxes(ibox-1)+errorboxes(ibox)
      enddo

!       NelemRatio = BetaParameter*(gnelem**2)/(ObjectiveNumberOfElements**2)
!       chi = 1.0_rp/(1.0_rp+NelemRatio)
!       epsilon1 = chi/2.0_rp
!       epsilon2 = (1+chi)/2.0_rp
!       call LookErrorValue(numboxes,1-epsilon1,maxerror,minerror,errorboxes,ErrorValue1)
!       call LookErrorValue(numboxes,epsilon2,maxerror,minerror,errorboxes,ErrorValue2)

      ipass = ipass +1
      if (ipass > 15) ObjectiveNumberOfElements = 1000

      BetaParameter = 0.5;
      RefinementRatio = 8;
      NelemRatio = 1.0_rp*(gnelem**2)/(ObjectiveNumberOfElements**2)
      MeanValue = NelemRatio/(NelemRatio+1.0_rp)
      Deviation = BetaParameter*0.5_rp
      epsilon1 = MeanValue+RefinementRatio*Deviation
      epsilon2 = MeanValue-Deviation
      call LookErrorValue(numboxes,MeanValue,maxerror,minerror,errorboxes,ErrorCenter)
      call LookErrorValue(numboxes,epsilon1,maxerror,minerror,errorboxes,ErrorValue1)
      call LookErrorValue(numboxes,epsilon2,maxerror,minerror,errorboxes,ErrorValue2)

      ErrorValue1 = max(ErrorValue1,ErrorCenter*2)

      do ielem = 1,nelem
         if (error(ielem) > ErrorValue1) then
            markel(ielem) = 1
         elseif (error(ielem) < ErrorValue2) then
            markel(ielem) = -1
         else
            markel(ielem) = 0
         endif
      enddo

   else
      call runend('Selected Error criteria not implemented')
   endif

end subroutine

subroutine LookErrorValue(numboxes,seekedproportion,maxerror,minerror,errorboxes,ErrorValue)
   use typre
   implicit none
   integer(ip) :: numboxes
   real(rp), intent(in) :: SeekedProportion
   real(rp) :: maxerror,minerror,errorboxes(*),Errorvalue

   real(rp) :: Errorinterval,ProportionLow,ProportionTop,PropotionInterval,error0,error1,errorinterval2
   integer(ip) :: ibox

   errorinterval = maxerror - minerror
   ProportionLow = 0.0_rp
   do ibox = 1,numboxes
      if (SeekedProportion < errorboxes(ibox)) then
         ProportionTop = ErrorBoxes(ibox)
         exit
      endif
      ProportionLow = ErrorBoxes(ibox)
   enddo
   PropotionInterval = ProportionTop-ProportionLow

   error0 = minerror + errorinterval/numboxes*(ibox-1)
   error1 = minerror + errorinterval/numboxes*ibox
   errorinterval2 = error1-error0

   ErrorValue = error0 + (SeekedProportion-ProportionLow)/PropotionInterval*errorinterval2

end subroutine


!---------------------------------------------------!
! Copyright (c) 2018 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine current_2d(jxyz_intra,jxyz_inter)
  use global_variables_2d
  implicit none
  real(8),intent(out) :: jxyz_intra(3),jxyz_inter(3)
  real(8),parameter :: ss = 1d0/(2d0*pi)**2
  real(8) :: vk_xy(2,-NKx:NKx,-NKy:NKy)
  real(8) :: tmp,jx,jy
  integer :: ikx,iky
  complex(8) :: zfact

  if(mass_r < 0d0)then
    call current_2d_negative_mass(jxyz_intra,jxyz_inter)
    return
  end if

  call set_band_velocity_2d(vk_xy)

  jx = 0d0; jy = 0d0
  tmp = 0d0
!$omp parallel do private(ikx, iky) reduction(+:tmp,jx,jy) collapse(2)
  do ikx = -NKx,NKx
  do iky = -Nky,NKy
    jx = jx + vk_xy(1,ikx,iky)*abs(zCt(2,ikx,iky))**2
    jy = jy + vk_xy(2,ikx,iky)*abs(zCt(2,ikx,iky))**2
    tmp = tmp + 2d0*real(conjg(zCt(1,ikx,iky))*zCt(2,ikx,iky))
  end do
  end do

  jxyz_intra(1) = 2d0*jx*dkx*dky*ss
  jxyz_intra(2) = 2d0*jy*dkx*dky*ss
  jxyz_intra(3) = 0d0
  jxyz_inter(1) = 2d0*pix_vc*tmp*dkx*dky*ss
  jxyz_inter(2) = 2d0*piy_vc*tmp*dkx*dky*ss
  jxyz_inter(3) = 2d0*piz_vc*tmp*dkx*dky*ss

  return
end subroutine current_2d
!---------------------------------------------------------------------------
subroutine current_2d_negative_mass(jxyz_intra,jxyz_inter)
  use global_variables_2d
  implicit none
  real(8),intent(out) :: jxyz_intra(3),jxyz_inter(3)
  real(8),parameter :: ss = 1d0/(2d0*pi)**2
  real(8),parameter :: Ecut = 0d0/ev, dE = eps_g - Ecut
  real(8) :: vk_xy(2,-NKx:NKx,-NKy:NKy)
  real(8) :: weight(-NKx:NKx,-NKy:NKy)
  real(8) :: tmp,jx,jy
  integer :: ikx,iky
  complex(8) :: zfact

  call set_deps_2d

  do ikx = -NKx,NKx
  do iky = -NKy,NKy
    if(deps(ikx,iky)>Ecut)then
!      weight(ikx,iky) = 1d0
      weight(ikx,iky) = sin(0.5d0*pi*((deps(ikx,iky)-Ecut)/dE))**2
    else
      weight(ikx,iky) = 0d0
    end if
  end do
  end do

  call set_band_velocity_2d(vk_xy)

  jx = 0d0; jy = 0d0
  tmp = 0d0
!$omp parallel do private(ikx, iky) reduction(+:tmp,jx,jy) collapse(2)
  do ikx = -NKx,NKx
  do iky = -Nky,NKy
    jx = jx + vk_xy(1,ikx,iky)*abs(zCt(2,ikx,iky))**2
    jy = jy + vk_xy(2,ikx,iky)*abs(zCt(2,ikx,iky))**2
    tmp = tmp + 2d0*real(conjg(zCt(1,ikx,iky))*zCt(2,ikx,iky))*weight(ikx,iky)
  end do
  end do

  jxyz_intra(1) = 2d0*jx*dkx*dky*ss
  jxyz_intra(2) = 2d0*jy*dkx*dky*ss
  jxyz_intra(3) = 0d0
  jxyz_inter(1) = 2d0*pix_vc*tmp*dkx*dky*ss
  jxyz_inter(2) = 2d0*piy_vc*tmp*dkx*dky*ss
  jxyz_inter(3) = 2d0*piz_vc*tmp*dkx*dky*ss

end subroutine current_2d_negative_mass


      subroutine qlbox3(Y,musq,Ires)
      implicit none
c     I_4^{D=4-2 \epsilon}(0,\pd^2,0,\pq^2;s_{12},s_{23};0,0,0,0)
C ----%\cite{Bern:1993kr}
c----\bibitem{Bern:1993kr}
c----  Z.~Bern, L.~J.~Dixon and D.~A.~Kosower,
c----  %``Dimensionally regulated pentagon integrals,''
c----  Nucl.\ Phys.\ B {\bf 412}, 751 (1994)
c----  [arXiv:hep-ph/9306240].
c----  %%CITATION = HEP-PH 9306240;%%
c----  Eqs. (I.13)
c                         [                   s12     p4sq ]
c                         [   0       0     - ---   - ---- ]
c                         [                    2       2   ]
c                         [                                ]
c                         [                   p2sq    s23  ]
c                         [   0       0     - ----  - ---  ]
c                         [                    2       2   ]
c                    Y3 = [                                ]
c                         [   s12     p2sq                 ]
c                         [ - ---   - ----    0       0    ]
c                         [    2       2                   ]
c                         [                                ]
c                         [   p4sq    s23                  ]
c                         [ - ----  - ---     0       0    ]
c                         [    2       2                   ]
      include 'qlconstants.f'
      double precision si,ta,mp2sq,mp4sq,musq,r,Y(4,4)
      double complex Ires(-2:0),qlLsm1_2me,qlL0,qlL1,qllnrat,fac
      logical landau
      si=2d0*Y(1,3)
      ta=2d0*Y(2,4)
      mp4sq=2d0*Y(1,4)
      mp2sq=2d0*Y(2,3)
      r=1d0-mp2sq*mp4sq/(si*ta)

C     Use expansion only in cases where signs (si,ta,mp2sq,mp4sq) are not
C     ++-- or --++
      landau=((sign(1d0,si) .eq. sign(1d0,ta))
     . .and. (sign(1d0,mp2sq) .eq. sign(1d0,mp4sq))
     . .and. (sign(1d0,si) .ne. sign(1d0,mp2sq)))
      if ((abs(r) .lt. 1d-6) .and. (landau .eqv. .false.)) then
C---expanded case
      fac=dcmplx(1d0/(si*ta))
      Ires(-2)=czip
      Ires(-1)=-dcmplx(2d0+r)*fac
      Ires( 0)=fac*(dcmplx(2d0-0.5d0*r)
     . +dcmplx(2d0+r)*(qllnrat(si,musq)+qllnrat(ta,mp4sq))
     . +dcmplx(2d0)*(qlL0(mp4sq,ta)+qlL0(mp4sq,si))
     . +dcmplx(r)*(qlL1(mp4sq,ta)+qlL1(mp4sq,si)))
      else
C---general case
      fac=dcmplx(1d0/(si*ta-mp2sq*mp4sq))
      Ires(-2)=czip
      Ires(-1)=fac*2d0*(qllnrat(mp2sq,si)
     .                 +qllnrat(mp4sq,ta))
      Ires( 0)=fac*(+qllnrat(si,musq)**2+qllnrat(ta,musq)**2
     .              -qllnrat(mp2sq,musq)**2-qllnrat(mp4sq,musq)**2
     .  +2d0*qlLsm1_2me(-si,-ta,-mp2sq,-mp4sq))
      endif

      return
      end


      INTEGER FUNCTION ICAMAX(N,CX,INCX)
*     .. Scalar Arguments ..
      INTEGER INCX,N
*     ..
*     .. Array Arguments ..
      COMPLEX CX(*)
*     ..
*
*  Purpose
*  =======
*
*     ICAMAX finds the index of element having max. absolute value.
*
*  Further Details
*  ===============
*
*     jack dongarra, linpack, 3/11/78.
*     modified 3/93 to return if incx .le. 0.
*     modified 12/3/93, array(1) declarations changed to array(*)
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL SMAX
      INTEGER I,IX
*     ..
*     .. External Functions ..
      REAL SCABS1
      EXTERNAL SCABS1
*     ..
      ICAMAX = 0
      IF (N.LT.1 .OR. INCX.LE.0) RETURN
      ICAMAX = 1
      IF (N.EQ.1) RETURN
      IF (INCX.EQ.1) THEN
*
*        code for increment equal to 1
*
         SMAX = SCABS1(CX(1))
         DO I = 2,N
            IF (SCABS1(CX(I)).GT.SMAX) THEN
               ICAMAX = I
               SMAX = SCABS1(CX(I))
            END IF
         END DO
      ELSE
*
*        code for increment not equal to 1
*
         IX = 1
         SMAX = SCABS1(CX(1))
         IX = IX + INCX
         DO I = 2,N
            IF (SCABS1(CX(IX)).GT.SMAX) THEN
               ICAMAX = I
               SMAX = SCABS1(CX(IX))
            END IF
            IX = IX + INCX
         END DO
      END IF
      RETURN
      END


          program demo_asinh
          implicit none
          real(8), dimension(3) :: x = [ -1.0, 0.0, 1.0 ]
             write (*,*) asinh(x)
          end program demo_asinh


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED 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
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Computes the nearest node with respet to (xt,yt,zt).
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] n number of local nodes
!> @param[in] xs vertex x-coordinate of local nodes
!> @param[in] ys vertex y-coordinate of local nodes
!> @param[in] zs vertex z-coordinate of local nodes
!> @param[in] xt x-coor current vertex
!> @param[in] yt y-coor current vertex
!> @param[in] zt z-coor current vertex
!> @param[out] nt index of the  nearest node from (xt,yt,zt)
!> @param[out] dist_min minimal distance from (xt,yt,zt)

       subroutine GET_NEAREST_NODE(n,xs,ys,zs,xt,yt,zt,nt,dist_min)

      implicit none

      integer*4 :: n,nt, i
      integer*4, dimension(1) :: pos

      !real*8 :: dx,dy,dz,d2,d2min
      real*8 :: xt,yt,zt
      real*8 :: dist_min

      real*8, dimension(n) :: xs,ys,zs
      real*8, dimension(n) :: dist_all

      !d2min = 1.0d30

      !do i = 1,n
      !   dx = xs(i) - xt
      !   dy = ys(i) - yt
      !   dz = zs(i) - zt
      !   d2 = dx*dx + dy*dy + dz*dz
      !   if (d2.lt.d2min) then
      !      d2min = d2
      !      nt = i
      !
      !   endif
      !enddo

      dist_all = (xs-xt)*(xs-xt) + (ys-yt)*(ys-yt) + (zs-zt)*(zs-zt)
      dist_min = minval(dist_all)
      pos = minloc(dist_all); nt = pos(1)

      return
      end subroutine GET_NEAREST_NODE


#include "scalar.fpp"

!=====================================================================!
! A class modeling rigid body dynamics.
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module rigidbody_dynamics_class

  use constants                 , only : WP
  use dynamic_physics_interface , only : dynamics

  implicit none

  private

  public :: rigidbody

  !-------------------------------------------------------------------!
  ! Type that implements rigidbody mass damper ODE
  !-------------------------------------------------------------------!

  type, extends(dynamics) :: rigidbody

     ! Define constants and other parameters needed for residual and
     ! jacobian assembly here

     ! Inertial properties of the rigidbody (assuming 3d space)
     type(scalar) :: mass
     type(scalar) :: first_moment_mass(3)
     type(scalar) :: second_moment_mass(3,3)

     ! Initial conditions of the rigidbody (assuming 3d space)
     type(scalar) :: position(3)
     type(scalar) :: orientation(3)
     type(scalar) :: linear_velocity(3)
     type(scalar) :: angular_velocity(3)

   contains

     ! Implement deferred procedures from superclasses
     procedure :: add_residual
     procedure :: add_jacobian
     procedure :: get_initial_condition

     ! Destructor
     final :: destruct

  end type rigidbody

  ! Interface to construct rigidbody system
  interface rigidbody
     procedure construct
  end interface rigidbody

contains

  !===================================================================!
  ! Constructor for rigidbody system
  !===================================================================!

  pure type(rigidbody) function construct(mass, fmass, smass, &
       & r, theta, v, omega) result (this)

    type(scalar), intent(in) :: mass, fmass(:), smass(:,:)
    type(scalar), intent(in) :: r(:), theta(:), v(:), omega(:)

    ! Set the number of state variables of RIGIDBODY system
    call this % set_num_state_vars(6)

    ! Set time order of RIGIDBODY system
    call this % set_differential_order(2)

    ! Set the object attributes
    this % mass = mass
    this % first_moment_mass = fmass
    this % second_moment_mass = smass

    ! Set the states
    this % position = r
    this % orientation = theta
    this % linear_velocity = v
    this % angular_velocity = omega

  end function construct

  !===================================================================!
  ! Destructor for rigidbody system
  !===================================================================!

  pure subroutine destruct(this)

    type(rigidbody), intent(inout) :: this

  end subroutine destruct

  !===================================================================!
  ! Residual assembly at each time step. This is a mandary function
  ! that the user needs to implement to use the integration
  ! scheme. This is where the differential equations are supplied to
  ! the solver.
  !===================================================================!

  pure subroutine add_residual(this, residual, U, X)

    class(rigidbody) , intent(inout) :: this
    type(scalar)     , intent(inout) :: residual(:)
    type(scalar)     , intent(in)    :: U(:,:)
    type(scalar)     , intent(in)    :: X(:,:)

    associate( q => U(1,:), qdot => U(2,:), qddot => U(3,:), &
         & m => this % mass, &
         & r1m => this % first_moment_mass, &
         & r2m => this % second_moment_mass )

      !residual = residual + m*qddot - m*g

    end associate

  end subroutine add_residual

  !===================================================================!
  ! Jacobian assembly at each time step.
  !
  ! Jacobian is the matrix of partial derivatives. Each row in the
  ! Jacobian matrix arises from differentiating a single
  ! equation. Each column in the Jacobian comes from a variable in the
  ! problem. Note the NEQN should be equal to NVARS for the system to
  ! be solved.
  !
  ! Note: alpha, beta and gamma are scalars that need to be multiplied
  ! with the partial derivatives DRDQ, DRDudot and DRDuddot
  ! respectively.
  !===================================================================!

  pure subroutine add_jacobian(this, jacobian, coeff, U, X)

    class(rigidbody)   , intent(inout) :: this
    type(scalar) , intent(inout) :: jacobian(:,:)
    type(scalar) , intent(in)    :: coeff(:)
    type(scalar) , intent(in)    :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    associate( q => U(1,:), qdot => U(2,:), qddot => U(3,:), &
         & m => this % mass, &
         & r1m => this % first_moment_mass, &
         & r2m => this % second_moment_mass )

      !jacobian = jacobian + gamma*M

    end associate

  end subroutine add_jacobian

  !===================================================================!
  ! Sets the initial condition for use in the integator. If first order
  ! system just set initial Q, if a second order system set initial Q
  ! and qdot
  !===================================================================!

  pure subroutine get_initial_condition(this, U, X)

    class(rigidbody) , intent(in)    :: this
    type(scalar)     , intent(inout) :: U(:,:)
    type(scalar)     , intent(in)    :: X(:,:)

    ! location (might use displacement)
    U(1,1:3) = this % position

    ! orientation (might use ang. displacement)
    U(1,4:6) = this % orientation

    ! translational velocity
    U(2,1:3) = this % linear_velocity

    ! angular velocity
    U(2,4:6) = this % angular_velocity

  end subroutine get_initial_condition

end module rigidbody_dynamics_class


! @Copyright 2007 Kristjan Haule
subroutine dinv(A, ndim)
  IMPLICIT NONE
  REAL*8, intent(inout) :: A(ndim,ndim)
  INTEGER, intent(in)   :: ndim
  ! locals
  INTEGER    :: info, lwork, lda
  INTEGER    :: ipiv(ndim)
  REAL*8 :: work(ndim*64)
  lwork = ndim*64
  lda = ndim

  CALL DGETRF( ndim, ndim, A, lda, ipiv, info )

  if (info.ne.0) then
     print *, 'dgetrf info=', info
  endif

  CALL DGETRI( ndim, A, lda, ipiv, work, lwork, info )

  if (info.ne.0) then
     print *, 'dgetri info=', info
  endif

end subroutine dinv

SUBROUTINE kramarskronig(gr, fi, om, i0, nom)
  IMPLICIT NONE
  REAL*8, intent(out):: gr
  REAL*8, intent(in) :: fi(nom)
  REAL*8, intent(in) :: om(nom)
  INTEGER, intent(in) :: i0, nom
  !f2py integer intent(hide), depend(om)  :: nom = shape(om,0)
  !locals
  REAL*8, PARAMETER :: pi=3.14159265
  REAL*8 :: sm
  REAL*8 :: dh(nom)
  REAL*8 :: S0, x
  INTEGER :: j, i0f
  i0f = i0
  S0 = fi(i0f)
  x = om(i0f)
  dh(1) = 0.5*(om(2)-om(1))
  do j=2,nom-1
     dh(j) = 0.5*(om(j+1)-om(j-1))
  enddo
  dh(nom) = 0.5*(om(nom)-om(nom-1))
  sm=0
  do j=1,i0f-2
     sm = sm + (fi(j)-S0)*dh(j)/(om(j)-x)
  enddo
  if (i0f>1)   sm = sm + (fi(i0f-1)-S0)*(dh(i0f-1)+0.5*dh(i0f))/(om(i0f-1)-x)
  if (i0f<nom) sm = sm + (fi(i0f+1)-S0)*(dh(i0f+1)+0.5*dh(i0f))/(om(i0f+1)-x)
  do j=i0f+2,nom
     sm = sm + (fi(j)-S0)*dh(j)/(om(j)-x)
  enddo
  if (.NOT.(i0f .EQ. 1 .OR. i0f.EQ.nom)) then
     sm = sm + S0*log(abs((om(nom)-x)/(x-om(1))))
  endif
  gr = sm/pi
END SUBROUTINE kramarskronig

SUBROUTINE complex_kramarskronig(gr, fi, om, i0, nom)
  IMPLICIT NONE
  COMPLEX*16, intent(out):: gr
  COMPLEX*16, intent(in) :: fi(nom)
  REAL*8, intent(in) :: om(nom)
  INTEGER, intent(in) :: i0, nom
  !f2py integer intent(hide), depend(om)  :: nom = shape(om,0)
  !locals
  REAL*8, PARAMETER :: pi=3.14159265
  REAL*8 :: x
  REAL*8 :: dh(nom)
  COMPLEX*16 :: S0, sm
  INTEGER :: j, i0f
  i0f = i0
  S0 = fi(i0f)
  x = om(i0f)
  dh(1) = 0.5*(om(2)-om(1))
  do j=2,nom-1
     dh(j) = 0.5*(om(j+1)-om(j-1))
  enddo
  dh(nom) = 0.5*(om(nom)-om(nom-1))
  sm=0
  do j=1,i0f-2
     sm = sm + (fi(j)-S0)*dh(j)/(om(j)-x)
  enddo
  if (i0f>1)   sm = sm + (fi(i0f-1)-S0)*(dh(i0f-1)+0.5*dh(i0f))/(om(i0f-1)-x)
  if (i0f<nom) sm = sm + (fi(i0f+1)-S0)*(dh(i0f+1)+0.5*dh(i0f))/(om(i0f+1)-x)
  do j=i0f+2,nom
     sm = sm + (fi(j)-S0)*dh(j)/(om(j)-x)
  enddo
  if (.NOT.(i0f .EQ. 1 .OR. i0f.EQ.nom)) then
     sm = sm + S0*log(abs((om(nom)-x)/(x-om(1))))
  endif
  gr = sm/pi
END SUBROUTINE complex_kramarskronig

SUBROUTINE integrate_trapz(res, f, x, n)
  IMPLICIT NONE
  REAL*8,  intent(out) :: res
  REAL*8,  intent(in)  :: f(n), x(n)
  INTEGER, intent(in)  :: n
  !
  INTEGER :: i
  res = f(1)*0.5*(x(2)-x(1)) + f(n)*0.5*(x(n)-x(n-1))
  do i=2,n-1
     res = res + f(i)*0.5*(x(i+1)-x(i-1))
  enddo
END SUBROUTINE integrate_trapz

SUBROUTINE complex_integrate_trapz(res, f, x, n)
  IMPLICIT NONE
  COMPLEX*16,intent(out) :: res
  COMPLEX*16,intent(in)  :: f(n)
  REAL*8, intent(in)     :: x(n)
  INTEGER, intent(in)    :: n
  !
  INTEGER :: i
  res = f(1)*0.5*(x(2)-x(1)) + f(n)*0.5*(x(n)-x(n-1))
  do i=2,n-1
     res = res + f(i)*0.5*(x(i+1)-x(i-1))
  enddo
END SUBROUTINE complex_integrate_trapz


C*****************************************************************
C This vectorizable Voigt function is based on the paper by Hui, *
C Armstrong and Wray, JQSRT 19, 509 (1977). Errors become        *
C significant (at the < 1% level) around the knee between the    *
C Doppler core and the damping wings for 0.0 < a < 0.001. The    *
C normalization is such that the integral is equal to SQRT(PI).  *
C If J <> 0 this function returns the dispersion function.       *
C -------------------------------------------------------------- *
C Authors: Jack Harvey, Aake Nordlund.                           *
C Modified by Sami Solanki (1985).                               *
C Modified by A.D. Wittmann (1986) to include F(a,-v) and F(0,v) *
C -------------------------------------------------------------- *
C Last Update: 18-APR-86.                                        *
C*****************************************************************
      FUNCTION VOIGT(A,VV,J)
      COMPLEX Z
      DIMENSION XDWS(28),YDWS(28)
      DATA A0,A1,A2,A3,A4,A5,A6,B0,B1,B2,B3,B4,B5,B6/
     *122.607931777104326,214.382388694706425,181.928533092181549,
     *93.155580458138441,30.180142196210589,5.912626209773153,
     *.564189583562615,122.60793177387535,352.730625110963558,
     *457.334478783897737,348.703917719495792,170.354001821091472,
     *53.992906912940207,10.479857114260399/
      DATA XDWS/.1,.2,.3,.4,.5,.6,.7,.8,.9,1.,1.2,1.4,1.6,1.8,2.,
     *3.,4.,5.,6.,7.,8.,9.,10.,12.,14.,16.,18.,20./,YDWS/
     *9.9335991E-02,1.9475104E-01,2.8263167E-01,3.5994348E-01,
     *4.2443639E-01,4.7476321E-01,5.1050407E-01,5.3210169E-01,
     *5.4072434E-01,5.3807950E-01,5.0727350E-01,4.5650724E-01,
     *3.9993989E-01,3.4677279E-01,3.0134040E-01,1.7827103E-01,
     *1.2934799E-01,1.0213407E-01,8.4542692E-02,7.2180972E-02,
     *6.3000202E-02,5.5905048E-02,5.0253846E-02,4.1812878E-02,
     *3.5806101E-02,3.1311397E-02,2.7820844E-02,2.5031367E-02/

      V=ABS(VV)
      IF(A.NE.0) GOTO 1
      IF(J.NE.0) GOTO 3
      VOIGT=EXP(-V*V)
      RETURN
   3  IF(V.GT.XDWS(1)) GOTO 4
      D=V*(1.-.66666667*V*V)
      GOTO 8
   4  IF(V.GT.XDWS(28)) GOTO 5
      K=27
      DO 7 I=2,27
      IF(XDWS(I).LT.V) GOTO 7
      K=I
      GOTO 6
   7  CONTINUE
   6  KK=K-1
      KKK=K+1
      D1=V-XDWS(KK)
      D2=V-XDWS(K)
      D3=V-XDWS(KKK)
      D12=XDWS(KK)-XDWS(K)
      D13=XDWS(KK)-XDWS(KKK)
      D23=XDWS(K)-XDWS(KKK)
      D=YDWS(KK)*D2*D3/(D12*D13)-YDWS(K)*D1*D3/(D12*D23)+YDWS(KKK)*
     *D1*D2/(D13*D23)
      GOTO 8
   5  Y=.5/V
      D=Y*(1.+Y/V)
   8  VOIGT=5.641895836E-1*D
   9  IF(VV.LT.0.) VOIGT=-VOIGT
      RETURN
   1  Z=CMPLX(A,-V)
      Z=((((((A6*Z+A5)*Z+A4)*Z+A3)*Z+A2)*Z+A1)*Z+A0)/
     *(((((((Z+B6)*Z+B5)*Z+B4)*Z+B3)*Z+B2)*Z+B1)*Z+B0)
      IF(J.NE.0) GOTO 2
      VOIGT=REAL(Z)
      RETURN
   2  VOIGT=.5*AIMAG(Z)

      GOTO 9
      END

C*****************************************************************
C This vectorizable Voigt function is based on the paper by Hui, *
C Armstrong and Wray, JQSRT 19, 509 (1977). Errors become        *
C significant (at the < 1% level) around the knee between the    *
C Doppler core and the damping wings for 0.0 < a < 0.001. The    *
C normalization is such that the integral is equal to SQRT(PI).  *
C If J <> 0 this function returns the dispersion function.       *
C -------------------------------------------------------------- *
C Authors: Jack Harvey, Aake Nordlund.                           *
C Modified by Sami Solanki (1985).                               *
C Modified by A.D. Wittmann (1986) to include F(a,-v) and F(0,v) *
C convertida en rutina por Basilio Ruiz (1993)                   *
C -------------------------------------------------------------- *
C Last Update: 22-jun 93.                                        *
C*****************************************************************
      subroutine VOIGT2(A,VV,H,F)
      COMPLEX Z
      DIMENSION XDWS(28),YDWS(28)
      DATA A0,A1,A2,A3,A4,A5,A6,B0,B1,B2,B3,B4,B5,B6/
     *122.607931777104326,214.382388694706425,181.928533092181549,
     *93.155580458138441,30.180142196210589,5.912626209773153,
     *.564189583562615,122.60793177387535,352.730625110963558,
     *457.334478783897737,348.703917719495792,170.354001821091472,
     *53.992906912940207,10.479857114260399/
      DATA XDWS/.1,.2,.3,.4,.5,.6,.7,.8,.9,1.,1.2,1.4,1.6,1.8,2.,
     *3.,4.,5.,6.,7.,8.,9.,10.,12.,14.,16.,18.,20./,YDWS/
     *9.9335991E-02,1.9475104E-01,2.8263167E-01,3.5994348E-01,
     *4.2443639E-01,4.7476321E-01,5.1050407E-01,5.3210169E-01,
     *5.4072434E-01,5.3807950E-01,5.0727350E-01,4.5650724E-01,
     *3.9993989E-01,3.4677279E-01,3.0134040E-01,1.7827103E-01,
     *1.2934799E-01,1.0213407E-01,8.4542692E-02,7.2180972E-02,
     *6.3000202E-02,5.5905048E-02,5.0253846E-02,4.1812878E-02,
     *3.5806101E-02,3.1311397E-02,2.7820844E-02,2.5031367E-02/

	ivsigno=1
        if(vv.lt.0)ivsigno=-1
        v=ivsigno*vv

        IF(A.eq.0)then
	  v2=V*V
          H=EXP(-v2)

          IF(V.GT.XDWS(1)) GOTO 4
          D=V*(1.-.66666667*v2)
          GOTO 8
   4      IF(V.GT.XDWS(28)) GOTO 5
          K=27
          DO 7 I=2,27
             IF(XDWS(I).LT.V) GOTO 7
             K=I
             GOTO 6
   7      CONTINUE
   6      KK=K-1
          KKK=K+1
          D1=V-XDWS(KK)
          D2=V-XDWS(K)
          D3=V-XDWS(KKK)
          D12=XDWS(KK)-XDWS(K)
          D13=XDWS(KK)-XDWS(KKK)
          D23=XDWS(K)-XDWS(KKK)
          D=YDWS(KK)*D2*D3/(D12*D13)-YDWS(K)*D1*D3/(D12*D23)+YDWS(KKK)*
     *    D1*D2/(D13*D23)
          GOTO 8
   5      Y=.5/V
          D=Y*(1.+Y/V)
   8      F=ivsigno*5.641895836E-1*D

c si el damping no es nulo
	else

           Z=CMPLX(A,-V)
           Z=((((((A6*Z+A5)*Z+A4)*Z+A3)*Z+A2)*Z+A1)*Z+A0)/
     *       (((((((Z+B6)*Z+B5)*Z+B4)*Z+B3)*Z+B2)*Z+B1)*Z+B0)
           H=REAL(Z)
           F=.5*ivsigno*AIMAG(Z)

	end if

	return
        END


program example_02
    use CottonCandy

    Write(*, *) Integral_func(f1, 100, 10)

    contains

    function f1(x) result(y)
        Real :: x, y;
        y = x + (Plank * x)
    end function f1

    function f2(x) result(y)
        Real :: x, y;
        y = x
    end function f2
end program example_02