c-----------------------------------------------------------------------
c
c Header with common subroutine
c
      include 't310-basis-f.h'
c-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      integer p,q,d
      parameter(p=6)
      parameter(q=4)
      parameter(d=2)

      real*8 qref(d*q)
      real*8 qweight(q)
      real*8 interp(p*q)
      real*8 grad(d*p*q)

      integer b

      character arg*32

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)

      call buildmats(qref,qweight,interp,grad)

      call ceedbasiscreateh1(ceed,ceed_triangle,1,p,q,
     $  interp,grad,qref,qweight,b,err)
      call ceedbasisview(b,err)

      call ceedbasisdestroy(b,err)
      call ceeddestroy(ceed,err)

      end
c-----------------------------------------------------------------------


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c ... file ivrtec.f
c
c     this file includes documentation and code for
c     subroutine ivrtec         i
c
c ... files which must be loaded with ivrtec.f
c
c     sphcom.f, hrfft.f, vhsec.f,shaec.f
c
c     subroutine ivrtec(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,
c    +                  wvhsec,lvhsec,work,lwork,pertrb,ierror)
c
c     given the scalar spherical harmonic coefficients a and b, precomputed
c     by subroutine shaec for a scalar array vort, subroutine ivrtec computes
c     a divergence free vector field (v,w) whose vorticity is vt - pertrb.
c     w is the east longitude component and v is the colatitudinal component.
c     pertrb is a constant which must be subtracted from vort for (v,w) to
c     exist (see the description of pertrb below).  usually pertrb is zero
c     or small relative to vort.  the divergence of (v,w), as computed by
c     ivrtec, is the zero scalar field.  i.e., v(i,j) and w(i,j) are the
c     colaatitudinal and east longitude velocity components at colatitude
c
c            theta(i) = (i-1)*pi/(nlat-1)
c
c     and longitude
c
c            lambda(j) = (j-1)*2*pi/nlon.
c
c     the
c
c            vorticity(v(i,j),w(i,j))
c
c         =  [-dv/dlambda + d(sint*w)/dtheta]/sint
c
c         =  vort(i,j) - pertrb
c
c     and
c
c            divergence(v(i,j),w(i,j))
c
c         =  [d(sint*v)/dtheta + dw/dlambda]/sint
c
c         =  0.0
c
c     where sint = sin(theta(i)).  required associated legendre polynomials
c     are recomputed rather than stored as they are in subroutine ivrtes.
c
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than 3. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   this has the same value as the isym that was input to
c            subroutine shaec to compute the arrays a and b.  isym
c            determines whether (v,w) are computed on the full or half
c            sphere as follows:
c
c      = 0
c            vort is not symmetric about the equator. in this case
c            the vector field (v,w) is computed on the entire sphere.
c            i.e., in the arrays  v(i,j),w(i,j) for i=1,...,nlat and
c            j=1,...,nlon.
c
c      = 1
c
c            vort is symmetric about the equator. in this case w is
c            antiymmetric and v is symmetric about the equator. v
c            and w are computed on the northern hemisphere only.  i.e.,
c            if nlat is odd they are computed for i=1,...,(nlat+1)/2
c            and j=1,...,nlon.  if nlat is even they are computed for
c            i=1,...,nlat/2 and j=1,...,nlon.
c
c       = 2
c
c            vort is antisymmetric about the equator. in this case w is
c            symmetric and v is antisymmetric about the equator. w
c            and v are computed on the northern hemisphere only.  i.e.,
c            if nlat is odd they are computed for i=1,...,(nlat+1)/2
c            and j=1,...,nlon.  if nlat is even they are computed for
c            i=1,...,nlat/2 and j=1,...,nlon.
c
c
c     nt     in the program that calls ivrtec, nt is the number of vorticity
c            and vector fields.  some computational efficiency is obtained
c            for multiple fields.  the arrays a,b,v, and w can be three
c            dimensional and pertrb can be one dimensional corresponding
c            to an indexed multiple array vort.  in this case, multiple vector
c            synthesis will be performed to compute each vector field.  the
c            third index for a,b,v,w and first for pertrb is the synthesis
c            index which assumes the values k=1,...,nt.  for a single
c            synthesis set nt=1. the description of the remaining parameters
c            is simplified by assuming that nt=1 or that a,b,v,w are two
c            dimensional and pertrb is a constant.
c
c     idvw   the first dimension of the arrays v,w as it appears in
c            the program that calls ivrtec. if isym = 0 then idvw
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then idvw must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays v,w as it appears in
c            the program that calls ivrtec. jdvw must be at least nlon.
c
c     a,b    two or three dimensional arrays (see input parameter nt)
c            that contain scalar spherical harmonic coefficients
c            of the vorticity array vort as computed by subroutine shaec.
c     ***    a,b must be computed by shaec prior to calling ivrtec.
c
c     mdab   the first dimension of the arrays a and b as it appears in
c            the program that calls ivrtec (and shaec). mdab must be at
c            least min0(nlat,(nlon+2/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays a and b as it appears in
c            the program that calls ivrtec (and shaec). ndab must be at
c            least nlat.
c
c
c  wvhsec    an array which must be initialized by subroutine vhseci.
c            once initialized
c            wvhsec can be used repeatedly by ivrtec as long as nlon
c            and nlat remain unchanged.  wvhsec must not be altered
c            between calls of ivrtec.
c
c
c  lvhsec    the dimension of the array wvhsec as it appears in the
c            program that calls ivrtec. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhsec must be at least
c
c            4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls ivrtec. define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,nlon/2  )       if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2)     if nlon is odd
c
c            if isym = 0 then lwork must be at least
c
c               nlat*(2*nt*nlon+max0(6*l2,nlon) + 2*nt*l1 + 1)
c
c            if isym = 1 or 2 then lwork must be at least
c
c               l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(2*nt*l1+1)
c
c     **************************************************************
c
c     output parameters
c
c
c     v,w   two or three dimensional arrays (see input parameter nt) that
c           contain a divergence free vector field whose vorticity is
c           vort - pertrb at the lattitude point theta(i)=pi/2-(i-1)*pi/(nlat-1)
c           and longitude point lambda(j)=(j-1)*2*pi/nlon.  w is the east
c           longitude component and v is the colatitudinal component.  the
c           indices for v and w are defined at the input parameter isym.
c           the divergence of (v,w) is the zero scalar field.
c
c   pertrb  a nt dimensional array (see input parameter nt and assume nt=1
c           for the description that follows).  vort - pertrb is a scalar
c           field which can be the vorticity of a vector field (v,w).
c           pertrb is related to the scalar harmonic coefficients a,b
c           of vort (computed by shaec) by the formula
c
c                pertrb = a(1,1)/(2.*sqrt(2.))
c
c           an unperturbed vort can be the vorticity of a vector field
c           only if a(1,1) is zero.  if a(1,1) is nonzero (flagged by
c           pertrb nonzero) then subtracting pertrb from vort yields a
c           scalar field for which a(1,1) is zero.
c
c    ierror = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of idvw
c           = 6  error in the specification of jdvw
c           = 7  error in the specification of mdab
c           = 8  error in the specification of ndab
c           = 9  error in the specification of lvhsec
c           = 10 error in the specification of lwork
c **********************************************************************
c
c
      subroutine ivrtec(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,
     +                  wvhsec,lvhsec,work,lwork,pertrb,ierror)
      dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt)
      dimension a(mdab,ndab,nt),b(mdab,ndab,nt)
      dimension wvhsec(lvhsec),work(lwork)
c
c     check input parameters
c
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 4) return
      ierror = 3
      if(isym.lt.0 .or. isym.gt.2) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((isym.eq.0 .and. idvw.lt.nlat) .or.
     +   (isym.ne.0 .and. idvw.lt.imid)) return
      ierror = 6
      if(jdvw .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,(nlon+1)/2)
      if(mdab .lt. min0(nlat,(nlon+2)/2)) return
      ierror = 8
      if(ndab .lt. nlat) return
      ierror = 9
      lzz1 = 2*nlat*imid
      labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
      if(lvhsec .lt. 2*(lzz1+labc)+nlon+15) return
      ierror = 10
c
c     verify unsaved work space length
c
      mn = mmax*nlat*nt
      if(isym.ne.0  .and. lwork .lt.
     +nlat*(2*nt*nlon+max0(6*imid,nlon))+2*mn+nlat) return
      if(isym.eq.0  .and. lwork .lt.
     +imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat) return
      ierror = 0
c
c     set work space pointers
c
      icr = 1
      ici = icr + mn
      is = ici + mn
      iwk = is + nlat
      liwk = lwork-2*mn-nlat
      call ivtec1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(icr),work(ici),
     +            mmax,work(is),mdab,ndab,a,b,wvhsec,lvhsec,work(iwk),
     +            liwk,pertrb,ierror)
      return
      end

      subroutine ivtec1(nlat,nlon,isym,nt,v,w,idvw,jdvw,cr,ci,mmax,
     +sqnn,mdab,ndab,a,b,wsav,lwsav,wk,lwk,pertrb,ierror)
      dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt)
      dimension cr(mmax,nlat,nt),ci(mmax,nlat,nt),sqnn(nlat)
      dimension a(mdab,ndab,nt),b(mdab,ndab,nt)
      dimension wsav(lwsav),wk(lwk)
c
c     preset coefficient multiplyers in vector
c
      do 1 n=2,nlat
      fn = float(n-1)
      sqnn(n) = sqrt(fn*(fn+1.))
    1 continue
c
c     compute multiple vector fields coefficients
c
      do 2 k=1,nt
c
c     set vorticity field perturbation adjustment
c
      pertrb(k) = a(1,1,k)/(2.*sqrt(2.))
c
c     preset cr,ci to 0.0
c
      do 3 n=1,nlat
      do 4 m=1,mmax
      cr(m,n,k) = 0.0
      ci(m,n,k) = 0.0
    4 continue
    3 continue
c
c     compute m=0 coefficients
c
      do 5 n=2,nlat
      cr(1,n,k) = a(1,n,k)/sqnn(n)
      ci(1,n,k) = b(1,n,k)/sqnn(n)
    5 continue
c
c     compute m>0 coefficients
c
      do 6 m=2,mmax
      do 7 n=m,nlat
      cr(m,n,k) = a(m,n,k)/sqnn(n)
      ci(m,n,k) = b(m,n,k)/sqnn(n)
    7 continue
    6 continue
    2 continue
c
c     set ityp for vector synthesis with divergence=0
c
      if (isym.eq.0) then
      ityp = 2
      else if (isym.eq.1) then
      ityp = 5
      else if (isym.eq.2) then
      ityp = 8
      end if
c
c     vector sythesize cr,ci into divergence free vector field (v,w)
c
      call vhsec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
     +           mmax,nlat,wsav,lwsav,wk,lwk,ierror)
      return
      end


      double precision,parameter:: g(4,4)=reshape((
     & /-1d0,0d0 ,0d0 , 0d0,
     &  0d0 ,-1d0,0d0 , 0d0,
     &  0d0 , 0d0,-1d0, 0d0,
     &  0d0,  0d0, 0d0,+1d0/),(/4,4/))


          program demo_translate
          !
          !      a demonstration of objects
          !
          use M_draw

          integer SPHERE
          real RADIUS
          parameter (RADIUS = 10.0)
          parameter(SPHERE = 1)
          character(len=50) :: device
          integer           :: ios

          print*,'Enter output device:'
          read(*,'(a)',iostat=ios) device
          if(ios.ne.0)device=' '

          call vinit(device)

          call vsetflush(.false.)
          !
          ! set up our viewing transformation
          !
          call perspective(90.0, 1.0, 0.001, 500.0)
          call lookat(13.0, 13.0, 8.0, 0.0, 0.0, 0.0, 0.0)

          call color(D_BLACK)
          call clear()
          !
          ! Call a routine to make the sphere object
          !
          call makesphere()

          !
          ! Now draw the sphere object scaled down. We use the pushmatrix
          ! and the popmatrix to preserve the transformation matrix so
          ! that only this sphere is drawn scaled. The callobj then enables
          ! us to draw the sphere we generated with makeobj in makesphere.
          !
          call color(D_CYAN)

          call pushmatrix()
          call scale(0.5, 0.5, 0.5)
          call callobj(SPHERE)
          call popmatrix()
          !
          ! now we draw the same sphere translated, with a different
          ! scale and color.
          !
          call color(D_WHITE)

          call pushmatrix()
          call translate(0.0, (-1.4) * RADIUS, 1.4 * RADIUS)
          call scale(0.3, 0.3, 0.3)
          call callobj(SPHERE)
          call popmatrix()
          !
          ! and maybe a few more times....
          !
          call color(D_RED)

          call pushmatrix()
          call translate(0.0, RADIUS, 0.7 * RADIUS)
          call scale(0.2, 0.2, 0.2)
          call callobj(SPHERE)
          call popmatrix()

          call color(D_GREEN)

          call pushmatrix()
          call translate(0.0, 1.5 * RADIUS, -RADIUS)
          call scale(0.15, 0.15, 0.15)
          call callobj(SPHERE)
          call popmatrix()

          call color(D_YELLOW)

          call pushmatrix()
          call translate(0.0, -RADIUS, -RADIUS)
          call scale(0.12, 0.12, 0.12)
          call callobj(SPHERE)
          call popmatrix()

          call color(D_BLUE)

          call pushmatrix()
          call translate(0.0, (-2.0)*RADIUS, -RADIUS)
          call scale(0.3, 0.3, 0.3)
          call callobj(SPHERE)
          call popmatrix()

          idum=getkey()

          call vexit()
          contains
          subroutine makesphere
          !
          !        make a sphere object
          !
          integer SPHERE
          integer ii
          real i, r, z, a, RADIUS, PI
          parameter (PI = 3.1415926535, RADIUS = 10.0, SPHERE = 1)

          call makeobj(SPHERE)
          !
          ! create the latitudinal rings
          !
          do ii = 0, 180, 20
             call pushmatrix()
             i=real(ii)
             call rotate(i, 'y')
             call circle(0.0, 0.0, RADIUS)
             call popmatrix()
          enddo
          !
          ! create the longitudinal rings
          !
          call pushmatrix()
          call rotate(90.0, 'x')
          do ia = -90, 90, 20
             a=ia
             r = RADIUS * cos(a * PI / 180.0)
             z = RADIUS * sin(a * PI / 180.0)
             call pushmatrix()
             call translate(0.0, 0.0, -z)
             call circle(0.0, 0.0, r)
             call popmatrix()
          enddo
          call popmatrix()

          call closeobj()

          end subroutine makesphere

          end program demo_translate


      SUBROUTINE PETPNO(TMAX, TMIN)

      IMPLICIT NONE

      REAL TMAX, TMIN, ESAT, EAIR

      REAL VPSLOP, VPSAT

C      ESAT = VPSAT(VPSLOP(VPSAT(TMIN))) + VPSLOP(VPSLOP(VPSAT(TMAX)))
C      ESAT = VPSAT(VPSLOP(VPSAT(TMIN)))
C      ESAT = VPSAT(VPSLOP(TMIN))

C      ESAT = (VPSAT(TMAX)+VPSAT(TMIN)) / 2.0
C      EAIR = VPSAT(TDEW)

C      EAIR = (VPSLOP(TMAX)+VPSLOP(TMIN)) / 2.0

      RETURN
      END SUBROUTINE PETPNO

C=======================================================================

      REAL FUNCTION VPSAT(T)

      IMPLICIT NONE
      REAL T

      VPSAT = 610.78
C      VPSAT = 610.78 * EXP(17.269*T/(T+237.30))

      RETURN
      END FUNCTION VPSAT

C=======================================================================

      REAL FUNCTION VPSLOP(T)

      IMPLICIT NONE

      REAL T,VPSAT

      VPSLOP = 18.0
C      VPSLOP = 18.0 * (2501.0-2.373*T) * VPSAT(T) / (8.314*(T+273.0)**2)

      RETURN
      END FUNCTION VPSLOP

C=======================================================================


	PROGRAM SPITZHARM
C
C
	OPEN(UNIT=89,FILE='SPITZHARM.DAT',STATUS='OLD',READONLY)
 100	READ(89,*,END=200) X,TABLE1,TABLE2
	FMAXW = EXP(-X**2)
	F1 = TABLE1*FMAXW
	F2 = TABLE2*FMAXW
	WRITE(98,*) X,TABLE1,TABLE2,F1,F2
	GO TO 100
 200	CONTINUE
	STOP
	END


!  1st triangle
          Nb=4
          Xb(1) =  Xgrd(Imin  ,Jmin  )
	    Xb(2) =  Xgrd(Imin+1,Jmin  )
	    Xb(3) =  Xgrd(Imin+1,Jmin+1)
	    Xb(4) =  Xgrd(Imin  ,Jmin  )

	    Yb(1) =  Ygrd(Imin  ,Jmin  )
	    Yb(2) =  Ygrd(Imin+1,Jmin  )
	    Yb(3) =  Ygrd(Imin+1,Jmin+1)
	    Yb(4) =  Ygrd(Imin  ,Jmin  )

	    Xo    =  Xpos(k)
	    Yo    =  Ypos(k)

	    found= inside (Xo,Yo,Xb,Yb,Nb)
	    print *, 'FOUND : ',found, '1'
!
          IF (found) THEN
	    triX(k,1)=Xgrd(Imin  ,Jmin  )
	    triX(k,2)=Xgrd(Imin+1,Jmin  )
	    triX(k,3)=Xgrd(Imin+1,Jmin+1)

	    triY(k,1)=Ygrd(Imin  ,Jmin  )
	    triY(k,2)=Ygrd(Imin+1,Jmin  )
	    triY(k,3)=Ygrd(Imin+1,Jmin+1)
	    END IF

!  2nd triangle
          Nb=4
          Xb(1) =  Xgrd(Imin  ,Jmin  )
	    Xb(2) =  Xgrd(Imin+1,Jmin  )
	    Xb(3) =  Xgrd(Imin  ,Jmin+1)
	    Xb(4) =  Xgrd(Imin  ,Jmin  )

	    Yb(1) =  Ygrd(Imin  ,Jmin  )
	    Yb(2) =  Ygrd(Imin+1,Jmin  )
	    Yb(3) =  Ygrd(Imin  ,Jmin+1)
	    Yb(4) =  Ygrd(Imin  ,Jmin  )

	    Xo    =  Xpos(k)
	    Yo    =  Ypos(k)

	    found= inside (Xo,Yo,Xb,Yb,Nb)
	    print *, 'FOUND : ',found, '2'

	    IF (found) THEN
	    triX(k,1)=Xgrd(Imin  ,Jmin  )
	    triX(k,2)=Xgrd(Imin+1,Jmin  )
	    triX(k,3)=Xgrd(Imin  ,Jmin+1)

	    triY(k,1)=Ygrd(Imin  ,Jmin  )
	    triY(k,2)=Ygrd(Imin+1,Jmin  )
	    triY(k,3)=Ygrd(Imin  ,Jmin+1)
	    END IF

SIZ=size(Xgrd);
x=[]; y=[]; Ival=[]; Jval=[];

i=Ipos; j=Jpos;
IND = sub2ind(SIZ,i,j);
x = [x Xgrd(IND) ];
y = [y Xgrd(IND) ];
Ival = [Ival  Xgrd(IND)*0+i];
Jval = [Ival  Xgrd(IND)*0+j];

i=Ipos+1; j=Jpos;
IND = sub2ind(SIZ,i,j);
x = [x Xgrd(IND) ];
y = [y Xgrd(IND) ];
Ival = [Ival  Xgrd(IND)*0+i];
Jval = [Ival  Xgrd(IND)*0+j];

i=Ipos+1; j=Jpos+1;
IND = sub2ind(SIZ,i,j);
x = [x Xgrd(IND) ];
y = [y Xgrd(IND) ];
Ival = [Ival  Xgrd(IND)*0+i];
Jval = [Ival  Xgrd(IND)*0+j];

i=Ipos; j=Jpos+1;
IND = sub2ind(SIZ,i,j);
x = [x Xgrd(IND) ];
y = [y Xgrd(IND) ];
Ival = [Ival  Xgrd(IND)*0+i];
Jval = [Ival  Xgrd(IND)*0+j];


module m_KdTree
  !!# KdTree
  !!Build and search k-dimensional trees in 2, 3, and K dimensions.
  !!This KdTree is balanced, in that splits are made along the dimension with the largest variance.
  !!A quickselect is used to quickly find the median in each splitting dimension as the splitting value.
  !!The ends of each branch contain multiple leaves to prevent tail recursion.
  !!An in-depth example is given below on how to use all the aspects of the KdTree and KdTreeSearch classes.
  !!
  !!Important: Once a tree has been built with a set, do not change their values.  The KdTree does NOT make
  !!a copy of the input values used to build it.
  !!Important: Generating the tree does not modify the values used to build it.
  !!
  !!## Building the KdTree
  !!The KdTree object can be initialized on assignment by entering point co-ordinates.
  !!To build a 2-D tree, you can use two 1-D arrays as the x, y, co-ordinates, and optionally a third 1-D array
  !!to build a 3-D tree.
  !!```fortran
  !!use m_KdTree
  !!type(KdTree) :: tree
  !!tree = KdTree(x, y, [z])
  !!```
  !!Or you can build a k-dimensional tree using a 2-D array, where the first dimension is the number of items,
  !!and the second is the number of dimensions, k.
  !!```fortran
  !!use m_KdTree
  !!type(KdTree) :: tree
  !!tree = KdTree(D)
  !!```
  !!
  !!## Querying the KdTree
  !!After the tree is initialized, a search class can be used to perform search for the nearest neighbour,
  !!the k nearest neighbours, all neighbours within a radius, k nearest within a radius, and items within
  !!upper and lower bounds in each dimension.
  !!The searches are thread safe and can be used in a parallel region.
  !!
  !!After the KdTree is built, various queries can be carried out.  Searches that return multiple values
  !!are called using the argDynamicArray within coretran. The [[dArgDynamicArray_Class]] contains an integer index
  !!containing the indices into the co-ordinates that are closest, and a double precision that contains the
  !!distance from the query point to those points.
  !!
  !!```fortran
  !!use dArgDynamicArray_Class
  !!use m_KdTree
  !!type(KdTreeSearch) :: search
  !!integer(i32) :: i
  !!type(dArgDynamicArray) :: da
  !!! Nearest Neighbour to (0, 0), for 3D add z, and zQuery
  !!i = search%nearest(tree, x, y, [z], xQuery = 0.d0, yQuery = 0.d0, [zQuery = 0.d0])
  !!! K-Nearest to (0, 0), for 3D add z, and zQuery
  !!da = search%kNearest(tree, x, y, [z], xQuery = 0.d0, yQuery = 0.d0, [zQuery = 0.d0], k = 10)
  !!! Search for all points within a given distance
  !!da = search%kNearest(tree, x, y, [z], xQuery = 0.d0, yQuery = 0.d0, [zQuery = 0.d0], radius = 10.d0)
  !!! Search for all k points within a given distance
  !!da = search%kNearest(tree, x, y, [z], xQuery = 0.d0, yQuery = 0.d0, [zQuery = 0.d0], k = 10, radius = 10.d0)
  !!```
  !!
  !!## Full Example
  !!```fortran
  !!program kdTree_test
  !!use variableKind, only: i32, r64
  !!use m_allocate, only: allocate
  !!use m_deallocate, only: deallocate
  !!use m_random, only: rngNormal
  !!use m_KdTree, only: KdTree, KdTreeSearch
  !!use m_dArgDynamicArray, only: dArgDynamicArray
  !!use m_string, only: str
  !!implicit none
  !!real(r64), allocatable :: x(:), y(:), z(:), D(:,:)
  !!integer(i32) :: ia, N
  !!type(KdTree) :: tree
  !!type(KdSearch) :: search
  !!type(dArgDynamicArray) :: da
  !!
  !!!====================================================================!
  !!! 2D KdTree example
  !!!====================================================================!
  !!! Create some random points in space
  !!N = 1d6
  !!call allocate(x, N)
  !!call allocate(y, N)
  !!call rngNormal(x)
  !!call rngNormal(y)
  !!! Build the tree
  !!tree = KdTree(x, y)
  !!! Get the nearest neighbour to (0, 0)
  !!ia = search%kNearest(tree, x, y, xQuery = 0.d0, yQuery = 0.d0)
  !!write(*,'(a)') 'Nearest point to the query location: '//str(x(ia))//str(y(ia))
  !!! Get the 10 nearest neighbours to the query
  !!da = search%kNearest(tree, x, y, xQuery = 0.d0, yQuery = 0.d0, k = 10)
  !!write(*,'(a)') 'The 10 nearest neighbour indices and distances:'
  !!call da%print()
  !!! Find all the points within a 1.d0
  !!da = search%kNearest(tree, x, y, xQuery = 0.d0, yQuery = 0.d0, radius = 1.d0)
  !!write(*,'(a)') 'The points within a distance of 1.d0'
  !!call da%print()
  !!Deallocate any tree memory
  !!call tree%deallocate()
  !!
  !!!====================================================================!
  !!! 3D KdTree example
  !!!====================================================================!
  !!! Create the third dimension
  !!call allocate(z, N)
  !!call rngNormal(z)
  !!! Build the tree
  !!tree = KdTree(x, y, z)
  !!! Get the nearest neighbour to (0, 0, 0)
  !!ia = search%kNearest(tree, x, y, z, xQuery = 0.d0, yQuery = 0.d0, zQuery = 0.d0)
  !!write(*,'(a)')'Nearest point to the query location: '//str(x(ia))//str(y(ia))//str(z(ia))
  !!! Get the 10 nearest neighbours to the query
  !!da = search%kNearest(tree, x, y, z, xQuery = 0.d0, yQuery = 0.d0, zQuery = 0.d0, k = 10)
  !!write(*,'(a)') 'The 10 nearest neighbour indices and distances:'
  !!call da%print()
  !!! Find all the points within a 1.d0
  !!da = search%kNearest(tree, x, y, z, xQuery = 0.d0, yQuery = 0.d0, zQuery = 0.d0, radius = 1.d0)
  !!write(*,'(a)') 'The points within a distance of 1.d0'
  !!call da%print()
  !!Deallocate any tree memory
  !!call tree%deallocate()
  !!
  !!!====================================================================!
  !!! KD KdTree example
  !!!====================================================================!
  !!call allocate(D, [N, 3])
  !!D(:,1) = x
  !!D(:,2) = y
  !!D(:,3) = z
  !!! Build the tree
  !!tree = KdTree(D)
  !!! Get the nearest neighbour to (0, 0, 0)
  !!ia = search%kNearest(tree, D, query = [0.d0, 0.d0, 0.d0])
  !!write(*,'(a)')'Nearest point to the query location: '//str(D(ia, 1))//str(D(ia, 2))//str(D(ia, 3))
  !!! Get the 10 nearest neighbours to the query
  !!da = search%kNearest(tree, D, query = [0.d0, 0.d0, 0.d0], k = 10)
  !!write(*,'(a)') 'The 10 nearest neighbour indices and distances:'
  !!call da%print()
  !!! Find all the points within a 1.d0
  !!da = search%kNearest(tree, D,  query = [0.d0, 0.d0, 0.d0], radius = 1.d0)
  !!write(*,'(a)') 'The points within a distance of 1.d0'
  !!call da%print()
  !!Deallocate any tree memory
  !!call tree%deallocate()
  !!call deallocate(x)
  !!call deallocate(y)
  !!call deallocate(z)
  !!call deallocate(D)
  !!end program
  !!```
  use variableKind, only: i32, r64
  use m_allocate, only: allocate
  use m_array1D, only: arange
  use m_deallocate, only: deallocate
  use m_errors, only: eMsg
  use m_maths, only: variance
  use iDynamicArray_Class, only: iDynamicArray
  use dArgDynamicArray_Class, only: dArgDynamicArray
  use m_select, only: argSelect
  use m_strings, only: str

  implicit none

  private

  public :: KdTree
  public :: KdTreeSearch

  !====================================================================!
  ! Type Definitions
  !====================================================================!
  !====================================================================!
  type, private :: KdTreebranch
    private
    !! A branch of the tree, could be a leaf, or branch
    integer(i32) :: splitAlong  !index of median in dat d
    real(r64) :: median  !median value in dat x
    integer(i32) :: left, right ! left and right indices
    type(KdTreeBranch), pointer :: buds(:) => null()
  contains
    procedure :: init => init_branch
      !! KdTreeBranch%init() - Initialize the class
    procedure :: deallocate => deallocate_branch
      !! KdTreeBranch%deallocate() - deallocate the branch
  end type
  !====================================================================!
  !====================================================================!
  type :: KdTree
    !!KdTree in 2, 3, or N dimensions.  See [[m_KdTree]] for more information on how to use this class.
    private
    type(KdTreebranch) :: trunk
    integer(i32),allocatable :: indx(:)
    integer(i32) :: nDims
    integer(i32) :: N
    logical(i32) :: set =.false.
  contains
    procedure, public :: deallocate => deallocate_KdTree
      !! kdTree%deallocate() - deallocate the recursive pointers
  end type
  !====================================================================!
  !====================================================================!
  type :: KdTreeSearch
    !!Class to search a KdTree.  See [[m_KdTree]] for more information on how to use this class.
  contains
    generic, public :: nearest => nearest2D, nearest3D, nearestKD
      !! KdTreeSearch%nearest() - Perform a nearest neighbour search
    procedure, private :: nearest2D => nearest_2D
      !! Overloaded type bound procedure with KdTreeSearch%nearest()
    procedure, private :: nearest3D => nearest_3D
      !! Overloaded type bound procedure with KdTreeSearch%nearest()
    procedure, private :: nearestKD => nearest_KD
      !! Overloaded type bound procedure with KdTreeSearch%nearest()
    generic, public :: kNearest => kNearest2D, kNearest3D, kNearestKD
      !! KdTreeSearch%kNearest() - Perform a k nearest neighbour search or a radius search.
    procedure, private :: kNearest2D => kNearest_2D
      !! Overloaded type bound procedure with KdTreeSearch%kNearest()
    procedure, private :: kNearest3D => kNearest_3D
      !! Overloaded type bound procedure with KdTreeSearch%kNearest()
    procedure, private :: kNearestKD => kNearest_KD
      !! Overloaded type bound procedure with KdTreeSearch%kNearest()
    generic, public :: rangeSearch => rangeSearch2D, rangeSearch3D, rangeSearchKD
      !! KdTreeSearch%rangeSearch() - Find all points within axis aligned lower and upper bounds
    procedure, private :: rangeSearch2D => rangeSearch_2D
      !! Overloaded type bound procedure with KdTreeSearch%rangeSearch()
    procedure, private :: rangeSearch3D => rangeSearch_3D
      !! Overloaded type bound procedure with KdTreeSearch%rangeSearch()
    procedure, private :: rangeSearchKD => rangeSearch_KD
      !! Overloaded type bound procedure with KdTreeSearch%rangeSearch()
  end type
  !====================================================================!

  !====================================================================!
  ! Interface definitions
  !====================================================================!
  interface
    !====================================================================!
    module subroutine init_branch(this, left,right)
      !! Overloaded Type bound procedure KdTreeBranch%init()
    !====================================================================!
    class(KdTreebranch) :: this
      !! KdTreeBranch class
    integer(i32), intent(in) :: left
      !! Left index, first call normally = 1
    integer(i32), intent(in) :: right
      !! Right index, first call normally = size of coordinates
    end subroutine
    !====================================================================!
    !====================================================================!
    module recursive subroutine deallocate_branch(this)
    !====================================================================!
    class(KdTreebranch) :: this
      !! KdTreeBranch class
    end subroutine
    !====================================================================!
  end interface

  interface KdTree
    !!Overloaded Initializer for a KdTree.
    !!
    !!Can be used to create a 2D, 3D, or ND, KdTree class.
    !!
    !!See [[m_KdTree]] for more information on how to use this class
    !====================================================================!
    module function init2D_KdTree(x, y) result(this)
      !! Overloaded by interface [[KdTree(type)]]
    !====================================================================!
    type(kdTree) :: this
      !! KdTree Class
    real(r64),intent(in) :: x(:)
      !! x-coordinates of the points
    real(r64),intent(in) :: y(:)
      !! y-coordinates of the points
    end function
    !====================================================================!
    !====================================================================!
    module function init3D_KdTree(x, y, z) result(this)
      !! Overloaded by interface [[KdTree(type)]]
    !====================================================================!
    type(kdTree) :: this
      !! KdTree Class
    real(r64),intent(in) :: x(:)
      !! x-coordinates of the points
    real(r64),intent(in) :: y(:)
      !! y-coordinates of the points
    real(r64),intent(in) :: z(:)
      !! z-coordinates of the points
    end function
    !====================================================================!
    !====================================================================!
    module function initKD_KdTree(D) result(this)
      !! Overloaded by interface [[KdTree(type)]]
    !====================================================================!
    type(kdTree) :: this
      !! KdTree Class
    real(r64),intent(in) :: D(:,:)
      !! Coordinates of the points, the k columns contain the k dimensional values.
    end function
    !====================================================================!
  end interface
  interface
    !====================================================================!
    module subroutine deallocate_KdTree(this)
      !! Overloaded Type bound procedure KdTree%deallocate()
    !====================================================================!
    class(KdTree) :: this
      !! KdTree Class
    end subroutine
    !====================================================================!
  end interface

interface
    !====================================================================!
    module function nearest_2D(search, tree, x, y, xQuery, yQuery) result(nearest)
      !! Overloaded Type bound procedure KdTreeSearch%nearest()
    !====================================================================!
    class(KdTreeSearch), intent(inout) :: search
      !! KdTreeSearch class
    class(kdTree),intent(in) :: tree
      !! KdTree class
    real(r64),intent(in) :: x(:)
      !! x co-ordinates of the points
    real(r64),intent(in) :: y(:)
      !! y co-ordinates of the points
    real(r64),intent(in) :: xQuery
      !! x co-ordinate of the query location
    real(r64),intent(in) :: yQuery
      !! y co-ordinate of the query location
    integer(i32) :: nearest
      !! Index of the nearest point to the query location
    end function
    !====================================================================!
    !====================================================================!
    module function nearest_3D(search, tree, x, y, z, xQuery, yQuery, zQuery) result(nearest)
      !! Overloaded Type bound procedure KdTreeSearch%nearest()
    !====================================================================!
    class(KdTreeSearch), intent(inout) :: search
      !! KdTreeSearch class
    class(kdTree),intent(in) :: tree
      !! KdTree class
    real(r64),intent(in) :: x(:)
      !! x co-ordinates of the points
    real(r64),intent(in) :: y(:)
      !! y co-ordinates of the points
    real(r64),intent(in) :: z(:)
      !! z co-ordinates of the points
    real(r64),intent(in) :: xQuery
      !! x co-ordinate of the query location
    real(r64),intent(in) :: yQuery
      !! y co-ordinate of the query location
    real(r64),intent(in) :: zQuery
      !! z co-ordinate of the query location
    integer(i32) :: nearest
      !! Index of the nearest point to the query location
    end function
    !====================================================================!
    !====================================================================!
    module function nearest_KD(search, tree, D, query) result(nearest)
      !! Overloaded Type bound procedure KdTreeSearch%nearest()
    !====================================================================!
    class(KdTreeSearch), intent(inout) :: search
      !! KdTreeSearch class
    class(kdTree),intent(in) :: tree
      !! KdTree class
    real(r64),intent(in) :: D(:,:)
      !! Co-ordinates of the points, the second dimension contains the k dimensions
    real(r64),intent(in) :: query(:)
      !! C-ordinate of the query location
    integer(i32) :: nearest
      !! Index of the nearest point to the query location
    end function
    !====================================================================!
  end interface

  interface
    !====================================================================!
    module function kNearest_2D(search, tree, x, y, xQuery, yQuery, k, radius) result(kNearest)
      !! Overloaded Type bound procedure KdTreeSearch%kNearest()
    !====================================================================!
    class(KdTreeSearch), intent(inout) :: search
      !! KdTreeSearch class
    class(kdTree),intent(in) :: tree
      !! KdTree class
    real(r64),intent(in) :: x(:)
      !! x co-ordinates of the points
    real(r64),intent(in) :: y(:)
      !! y co-ordinates of the points
    real(r64),intent(in) :: xQuery
      !! x co-ordinate of the query location
    real(r64),intent(in) :: yQuery
      !! y co-ordinate of the query location
    integer(i32), intent(in), optional :: k
      !! Number of points to find that are closest to the query
    real(r64), intent(in), optional :: radius
      !! Only find neighbours within this distance from the query
    type(dArgDynamicArray) :: kNearest
      !! Indices of the nearest points to the query location
    end function
    !====================================================================!
    !====================================================================!
    module function kNearest_3D(search, tree, x, y, z, xQuery, yQuery, zQuery, k, radius) result(kNearest)
      !! Overloaded Type bound procedure KdTreeSearch%kNearest()
    !====================================================================!
    class(KdTreeSearch), intent(inout) :: search
      !! KdTreeSearch class
    class(kdTree),intent(in) :: tree
      !! KdTree class
    real(r64),intent(in) :: x(:)
      !! x co-ordinates of the points
    real(r64),intent(in) :: y(:)
      !! y co-ordinates of the points
    real(r64),intent(in) :: z(:)
      !! z co-ordinates of the points
    real(r64),intent(in) :: xQuery
      !! x co-ordinate of the query location
    real(r64),intent(in) :: yQuery
      !! y co-ordinate of the query location
    real(r64),intent(in) :: zQuery
      !! z co-ordinate of the query location
    integer(i32), intent(in), optional :: k
      !! Number of points to find that are closest to the query
    real(r64), intent(in), optional :: radius
      !! Only find neighbours within this distance from the query
    type(dArgDynamicArray) :: kNearest
      !! Indices of the nearest points to the query location
    end function
    !====================================================================!
    !====================================================================!
    module function kNearest_KD(search, tree, D, query, k, radius) result(kNearest)
      !! Overloaded Type bound procedure KdTreeSearch%kNearest()
    !====================================================================!
    class(KdTreeSearch), intent(inout) :: search
      !! KdTreeSearch class
    class(kdTree),intent(in) :: tree
      !! KdTree class
    real(r64),intent(in) :: D(:,:)
      !! Co-ordinates of the points, the second dimension contains the k dimensions
    real(r64),intent(in) :: query(:)
      !! Co-ordinate of the query location
    integer(i32), intent(in), optional :: k
      !! Number of points to find that are closest to the query
    real(r64), intent(in), optional :: radius
      !! Only find neighbours within this distance from the query
    type(dArgDynamicArray) :: kNearest
      !! Indices of the nearest points to the query location
    end function
    !====================================================================!
  end interface

  interface
    !====================================================================!
    module function rangeSearch_2D(search, tree, x, y, lowerBound, upperBound) result(iPoints)
      !! Overloaded Type bound procedure KdTreeSearch%rangeSearch()
    !====================================================================!
    class(KdTreeSearch), intent(inout) :: search
      !! KdTreeSearch class
    class(kdTree),intent(in) :: tree
      !! KdTree class
    real(r64),intent(in) :: x(:)
      !! x co-ordinates of the points.
    real(r64),intent(in) :: y(:)
      !! y co-ordinates of the points.
    real(r64),intent(in) :: lowerBound(2)
      !! Lower bounds in x and y for the range search [xLow, yLow].
    real(r64),intent(in) :: upperBound(2)
      !! Upper bounds in x and y for the range search [xHigh, yHigh].
    type(iDynamicArray) :: iPoints
      !! Indices of the points inside the axis aligned range.
    end function
    !====================================================================!
    !====================================================================!
    module function rangeSearch_3D(search, tree, x, y, z, lowerBound, upperBound) result(iPoints)
      !! Overloaded Type bound procedure KdTreeSearch%rangeSearch()
    !====================================================================!
    class(KdTreeSearch), intent(inout) :: search
      !! KdTreeSearch class
    class(kdTree),intent(in) :: tree
      !! KdTree class
    real(r64),intent(in) :: x(:)
      !! x co-ordinates of the points.
    real(r64),intent(in) :: y(:)
      !! y co-ordinates of the points.
    real(r64),intent(in) :: z(:)
      !! y co-ordinates of the points.
    real(r64),intent(in) :: lowerBound(3)
      !! Lower bounds in x and y for the range search [xLow, yLow].
    real(r64),intent(in) :: upperBound(3)
      !! Upper bounds in x and y for the range search [xHigh, yHigh].
    type(iDynamicArray) :: iPoints
      !! Indices of the points inside the axis aligned range.
    end function
    !====================================================================!
    !====================================================================!
    module function rangeSearch_KD(search, tree, D, lowerBound, upperBound) result(iPoints)
      !! Overloaded Type bound procedure KdTreeSearch%rangeSearch()
    !====================================================================!
    class(KdTreeSearch), intent(inout) :: search
      !! KdTreeSearch class
    class(kdTree),intent(in) :: tree
      !! KdTree class
    real(r64),intent(in) :: D(:,:)
      !! Co-ordinates of the points, the second dimension contains the k dimensions
    real(r64),intent(in) :: lowerBound(size(D,2))
      !! Lower bounds in each dimension for the range search [Low1, Low2, ..., LowK].
    real(r64),intent(in) :: upperBound(size(D,2))
      !! Upper bounds in each dimension for the range search [High1, High2, ..., HighK].
    type(iDynamicArray) :: iPoints
      !! Indices of the points inside the axis aligned range.
    end function
    !====================================================================!
  end interface
end module


! Create a format for a real number so that it only shows as many decimal places
! as necessary.
! Read the real in as a string and save its length. Then find the index of the
! decimal point, and save that.

SUBROUTINE get_decimal_places(str, places)
IMPLICIT NONE
CHARACTER(len=*), INTENT(IN) :: str ! A string representing a real number
INTEGER, INTENT(OUT) :: places ! The number of decimal places in the string
IF (INDEX(str,'.') == 0) THEN
  places = 0
ELSE
  places = LEN_TRIM(str) - INDEX(str,'.')
END IF
END SUBROUTINE get_decimal_places

SUBROUTINE get_format_fragment(places, frag)
INTEGER, INTENT(IN) :: places
CHARACTER(len=*), INTENT(OUT) :: frag
CHARACTER(len=20) :: p
WRITE(p, '(I0)') places
WRITE(*, *) "Length of p: ", LEN_TRIM(p), " Places: ", places
frag = 'F0.'//TRIM(p)
END SUBROUTINE get_format_fragment

PROGRAM shrink_format
IMPLICIT NONE
REAL :: r
CHARACTER(len=20) :: str, frag, fmt
INTEGER :: places

WRITE(*, *) "Enter a real number: "
READ(*, *) str
CALL get_decimal_places(str, places)
CALL get_format_fragment(places, frag)
fmt = '(A,' // TRIM(frag) // ',A)'
!WRITE(*, *) fmt
WRITE(*, *) "Decimal places required: ", places
READ(str, *) r
WRITE(*, fmt) "Entered: ", r, ". Enjoy."
END PROGRAM shrink_format


! { dg-do run }
! This tests the fix for PR29315, in which array components of derived type arrays were
! not correctly passed to procedures because of a fault in the function that detects
! these references that do not have the span of a natural type.
!
! Contributed by Stephen Jeffrey  <stephen.jeffrey@nrm.qld.gov.au>
!
program  test_f90

    integer, parameter :: N = 2

    type test_type
        integer a(N, N)
    end type

    type (test_type) s(N, N)

    forall (l = 1:N, m = 1:N) &
        s(l, m)%a(:, :) = reshape ([((i*l + 10*j*m +100, i = 1, N), j = 1, N)], [N, N])

    call test_sub(s%a(1, 1), 1000) ! Test the original problem.

    if ( any (s(1, 1)%a(:, :) /= reshape ([1111, 112, 121, 122], [2, 2]))) STOP 1
    if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) STOP 2
    if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) STOP 3
    if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) STOP 4

    call test_sub(s(1, 1)%a(:, :), 1000)  ! Check "normal" references.

    if ( any (s(1, 1)%a(:, :) /= reshape ([2111,1112,1121,1122], [2, 2]))) STOP 5
    if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) STOP 6
    if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) STOP 7
    if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) STOP 8
contains
  subroutine test_sub(array, offset)
    integer array(:, :), offset

    forall (i = 1:N, j = 1:N) &
        array(i, j) = array(i, j) + offset
  end subroutine
end program


program test_wind
    use fplus_wind
    implicit none

    real :: u, v, dir, speed
    real, dimension(4) :: ua, va, dira, speeda

    ! Wind from SW
    u = 1
    v = 1
    call u_v_2_dir_spd(u, v, dir, speed)
    print*, "u=",u,"v=",v,"dir=",dir,"speed=",speed

    ! Wind from SE
    u = -1
    v = 1
    call u_v_2_dir_spd(u, v, dir, speed)
    print*, "u=",u,"v=",v,"dir=",dir,"speed=",speed

    ! Wind from NE
    u = -1
    v = -1
    call u_v_2_dir_spd(u, v, dir, speed)
    print*, "u=",u,"v=",v,"dir=",dir,"speed=",speed

    ! Wind from NW
    u = 1
    v = -1
    call u_v_2_dir_spd(u, v, dir, speed)
    print*, "u=",u,"v=",v,"dir=",dir,"speed=",speed

    ! no wind
    u = 0
    v = 0
    call u_v_2_dir_spd(u, v, dir, speed)
    print*, "u=",u,"v=",v,"dir=",dir,"speed=",speed

    ! array calculation
    ua = (/1,-1,-1,1/)
    va = (/1,1,-1,-1/)
    call u_v_2_dir_spd(ua, va, dira, speeda)
    print*, "dirs=  ", dira
    print*, "speeds=", speeda

    ! Wind from SW
    dir = 225
    speed = sqrt(2.0)
    call dir_spd_2_u_v(dir, speed, u, v)
    print*, "u=",u,"v=",v,"dir=",dir,"speed=",speed

    ! Wind from SE
    dir = 135
    speed = sqrt(2.0)
    call dir_spd_2_u_v(dir, speed, u, v)
    print*, "u=",u,"v=",v,"dir=",dir,"speed=",speed

    ! Wind from NE
    dir = 45
    speed = sqrt(2.0)
    call dir_spd_2_u_v(dir, speed, u, v)
    print*, "u=",u,"v=",v,"dir=",dir,"speed=",speed

    ! Wind from NW
    dir = 315
    speed = sqrt(2.0)
    call dir_spd_2_u_v(dir, speed, u, v)
    print*, "u=",u,"v=",v,"dir=",dir,"speed=",speed

    ! no wind
    dir = 0
    speed = 0
    call dir_spd_2_u_v(dir, speed, u, v)
    print*, "u=",u,"v=",v,"dir=",dir,"speed=",speed

    ! array calculation
    dira = (/225,135,45,315/)
    speeda = sqrt(2.0)
    call dir_spd_2_u_v(dira, speeda, ua, va)
    print*, "u=", ua
    print*, "v=", va

    ! average calculation
    dira = (/355, 356, 4, 5/)
    speeda = (/1,1,2,2/)
    call wind_mean(dira, speeda, dir, speed)
    print*, "Mean of:"
    print*, "dir=  ", dira
    print*, "speed=", speeda
    print*, "result:"
    print*, "dir=  ", dir
    print*, "speed=", speed
end program


SUBROUTINE MultiGridSolveLinearSystem(r,u,Nx,Ny,Nz,GhostGridX,GhostGridY,GhostGridZ,cyclet,maxit,reltol,alpha,beta,gamma)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE GlobalVariables, ONLY: FineGrid
USE MGLevels
IMPLICIT NONE
INTEGER          :: maxit, iter, gam, GhostGridX, GhostGridY, GhostGridZ, Nx, Ny, Nz, alpha, beta, gamma
INTEGER          :: Nxg, Nyg, Nzg
REAL(KIND=long)  :: res, resold, res_init, reltol
!REAL(KIND=long), DIMENSION(maxit+1) :: resvec
REAL(KIND=long), DIMENSION((Nx+2*GhostGridX)*(Ny+2*GhostGridY)*(Nz+GhostGridZ)), INTENT(INOUT) :: u
REAL(KIND=long), DIMENSION((Nx+2*GhostGridX)*(Ny+2*GhostGridY)*(Nz+GhostGridZ)) :: Au, tmp
REAL(KIND=long), DIMENSION((Nx+2*GhostGridX)*(Ny+2*GhostGridY)*(Nz+GhostGridZ)), INTENT(IN) :: r
CHARACTER(len=1) :: cyclet

Nxg = Nx+2*GhostGridX
Nyg = Ny+2*GhostGridY
Nzg = Nz+GhostGridZ

!print*,'r=',r
!print*,'u=',u
!read*

! Initial Guess on solution
u = zero

! Cycle Type
IF (cyclet=='W' .OR. cyclet=='F') THEN
	gam = 2
ELSE
	gam = 1
END IF

!IF (0) THEN
!  tmp = r !-Au
!  res_init = MAXNORM(Nx*Ny*(Nz+GhostGridZ),tmp) ! initial residual res = r-Mu = r
!  res       = one; !ten*reltol;
!  resvec    = zero;
!  resvec(1) = one;  ! normalized
!ENDIF

iter      = 0
DO
	iter = iter + 1
	IF (iter>maxit) EXIT
!
!	IF (res<reltol) EXIT
!
	IF (MG_N_levels==1 .AND. iter>1) EXIT

	IF (MG_N_levels==1) THEN
		CALL MultiGridSolver(u,r,MG_N_levels,gam,cyclet,arrLevels(MG_N_levels)%Nx,arrLevels(MG_N_levels)%Ny,&
		   arrLevels(MG_N_levels)%Nz,arrLevels(MG_N_levels)%Nx,arrLevels(MG_N_levels)%Ny,arrLevels(MG_N_levels)%Nz,&
		   GhostGridX, GhostGridY, GhostGridZ, MIN(1,alpha), MIN(1,beta), MIN(1,gamma))
	ELSE
		CALL MultiGridSolver(u,r,MG_N_levels,gam,cyclet,arrLevels(MG_N_levels)%Nx,arrLevels(MG_N_levels)%Ny,&
		   arrLevels(MG_N_levels)%Nz,arrLevels(MG_N_levels-1)%Nx,arrLevels(MG_N_levels-1)%Ny,&
		   arrLevels(MG_N_levels-1)%Nz,GhostGridX, GhostGridY, GhostGridZ, MIN(1,alpha), MIN(1,beta), MIN(1,gamma))
	END IF

!IF (0) THEN
!
!	! Determine relative change of residual
!	resold = res
!
	! DETERMINE RESIDUAL error vector (FIXME: DO NOT NEED IT FOR FIXED ITERATIONS)
!	tmp = u
!!	! Update Ghost layer
!	CALL BuildLinearSystemGhost(Nx,Ny,Nz+GhostGridZ,tmp,tmp,arrLevels(MG_N_levels)%dsigma,arrLevels(MG_N_levels)%h,arrLevels(MG_N_levels)%hx,arrLevels(MG_N_levels)%hxx,arrLevels(MG_N_levels)%hy,arrLevels(MG_N_levels)%hyy,arrLevels(MG_N_levels)%DiffStencils,
!!	! Do Matrix-Vector product A*u to determine new residual
!	CALL BuildLinearSystem(Nx,Ny,Nz+GhostGridZ,tmp,Au,arrLevels(MG_N_levels),alpha,beta,gamma)
!!	! Make sure values in ghost layer are zero corresponding to eliminated conditions
!    CALL DiscardGhostLayer(Nx,Ny,Nz+GhostGridZ,Au)
!!
!	tmp = r-Au
!	res = MAXNORM(Nx*Ny*(Nz+GhostGridZ),tmp)
!	res = res/res_init
!!
!	resvec(iter+1) = res
!ENDIF

!	print*,'u=',u
!	print*,'r=',r
!	print*,'Au=',Au
!	print*,'iter=',iter
!	print*,'Iter=',iter,', Residual=',res
!	print*,'maxit=',maxit
! print*,'Residual=',res
! read*
END DO
!print*,u
!read*
RETURN
END SUBROUTINE MultiGridSolveLinearSystem


C$Procedure    LINROT_M ( Linear interpolation between rotations )

      SUBROUTINE LINROT_M ( INIT, FINAL, FRAC, R, SCLDAV )

C$ Abstract
C
C     Interpolate between two rotations using a constant angular rate.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ROTATIONS
C
C$ Keywords
C
C     MOSPICE
C     MATRIX
C     ROTATION
C
C$ Declarations

      DOUBLE PRECISION      INIT   ( 3, 3 )
      DOUBLE PRECISION      FINAL  ( 3, 3 )
      DOUBLE PRECISION      FRAC
      DOUBLE PRECISION      R      ( 3, 3 )
      DOUBLE PRECISION      SCLDAV ( 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     INIT       I   Initial rotation.
C     FINAL      I   Final rotation.
C     FRAC       I   Fraction of rotation from INIT to FINAL by which
C                    to interpolate.
C     R          O   Linearly interpolated rotation.
C     SCLDAV     O   Scaled angular velocity of rotation.
C
C$ Detailed_Input
C
C     INIT,
C     FINAL,
C     FRAC           are, respectively, two rotation matrices between
C                    which to interpolate, and an interpolation
C                    fraction.  See the $Detailed_Output and
C                    $Particulars sections for details.
C
C$ Detailed_Output
C
C     R              is the matrix resulting from linear interpolation
C                    between INIT and FINAL by the fraction FRAC.  By
C                    `linear interpolation' we mean the following:
C
C                       We view INIT and FINAL as two values of a
C                       time-varying rotation matrix R(t) that rotates
C                       at a constant angular velocity (that is, the
C                       row vectors of R(t) rotate with constant angular
C                       velocity).  We can say that
C
C                          INIT   =  R(t0)
C                          FINAL  =  R(t1).
C
C                       `Linear interpolation by the fraction FRAC'
C                       means that we evalute R(t) at time
C
C                          t0   +   FRAC * (t1 - t0).
C
C
C     SCLDAV         is a scaled version of the constant angular
C                    velocity vector used for interpolation.  When
C                    SCLDAV is divided by the scale factor
C
C                       t1 - t0,
C
C                    the result is the constant angular velocity
C                    assumed for the rows of R(t) in order to perform
C                    linear interpolation.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If either of INIT or FINAL is not a rotation matrix, the error
C         SPICE(NOTAROTATION) is signalled.
C
C     2)  This routine assumes that the rotation that maps INIT to FINAL
C         has a rotation angle THETA radians, where
C
C            0  <  THETA  <  pi.
C               _
C
C         This routine cannot distinguish between rotations of THETA
C         radians, where THETA is in the interval [0, pi), and
C         rotations of
C
C            THETA   +   2 * k * pi
C
C         radians, where k is any integer.  These `large' rotations will
C         yield invalid results when interpolated.  You must ensure that
C         the inputs you provide to this routine will not be subject to
C         this sort of ambiguity.  If in fact you are interpolating the
C         position of a rotating matrix with constant angular velocity
C         AV between times t0 and t1, you must ensure that
C
C            || AV ||  *  |t1 - t0|   <   pi.
C
C         Here we assume that the magnitude of AV is the angular rate
C         of the rotating matrix in units of radians per second.
C
C
C     3)  When FRAC is outside of the interval [0, 1], the process
C         performed is `extrapolation', not interpolation.  Such
C         values of FRAC are permitted.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     In the discussion below, we assume that the conditions specified
C     in item (2) of $ Exceptions have been satisfied.
C
C     As we've said, we view INIT and FINAL as two values of a
C     time-varying rotation matrix R(t) that rotates at a constant
C     angular velocity; we define R(t), t0, and t1 so that
C
C        INIT   =  R(t0)
C        FINAL  =  R(t1).
C
C     The output matrix R is R(t) evaluated at the time
C
C        t0   +   FRAC * (t1 - t0).
C
C     How do we evaluate R at times between t0 and t1?  Since the
C     column vectors of R are presumed to rotate with constant
C     angular velocity, we will first find the rotation axis of
C     the matrix M that maps the row vectors of R from their initial
C     to final position.  Since the rows of R are the columns of
C     the transpose of R, we can write:
C
C             T               T
C        R(t1)   =   M * R(t0),
C
C     or
C             T              T
C        FINAL   =   M * INIT
C
C     Since
C             T            T                T
C        FINAL   =  ( FINAL  * INIT ) * INIT
C
C     we can find M, as well as a rotation axis A and an angle THETA
C     in the range [0, pi] such that M rotates vectors by THETA
C     radians about axis A.
C
C     We'll use the notation
C
C        [ x ]
C             N
C
C     to indicate a coordinate system rotation of x radians about the
C     vector N.  Having found A and THETA, we can write
C
C            T                 (t  - t0)                 T
C        R(t)   =  [  THETA *  ---------  ]     *   R(t0)
C                              (t1 - t0)    A
C
C     Thus R(t) is determined.
C
C     The input argument FRAC plays the role of the quotient
C
C        t  - t0
C        -------
C        t1 - t0
C
C     shown above.
C
C     SCLDAV is a vector parallel to the rotation axis of M and
C     having length equal to the rotation angle of M (which is in
C     the range [0, pi]).
C
C$ Examples
C
C     1)  Suppose we want to interpolate between two rotation matrices
C         R1 and R2 that give the orientation of a spacecraft structure
C         at times t1 and t2.  We wish to find an approximation of the
C         structure's orientation at the midpoint of the time interval
C         [t1, t2].  We assume that the angular velocity of the
C         structure equals the constant AV between times t1 and t2.  We
C         also assume that
C
C            || AV ||  *  (t2 - t1)   <   pi.
C
C         Then the code fragment
C
C            CALL LINROT_M ( R1, R2, 0.5D0, R, SCLDAV )
C
C         produces the approximation we desire.
C
C
C     2)  Suppose R1 is the identity and R2 is
C
C            [ pi/2 ] .
C                    3
C
C         Then the code fragment
C
C            CALL LINROT_M ( R1, R2, FRAC, R, SCLDAV )
C
C         returns SCLDAV as the vector
C
C            ( 0, 0, pi/2 ).
C
C
C     3)  As long as R1 and R2 are not equal, the code fragment
C
C            CALL LINROT_M ( R1,     R2,            FRAC,  R,  SCLDAV )
C            CALL AXISAR   ( SCLDAV, VNORM(SCLDAV),  M                )
C            CALL MXMT     ( R1,     M,             R2                )
C
C         should leave R2 unchanged, except for round-off error.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    MOSPICE Version 1.0.0, 17-APR-1992 (NJB)
C
C-&

C$ Index_Entries
C
C     linear interpolation between rotations
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
      LOGICAL               ISROT

C
C     Local parameters
C

C
C     NTOL and DTOL are tolerances used for determining whether INIT
C     and FINAL are rotation matrices.  NTOL is bound on the deviation
C     of the norms of the columns of a matrix from 1, and DTOL is a
C     bound on the deviation of the determinant of a matrix from 1.
C
      DOUBLE PRECISION      DTOL
      PARAMETER           ( DTOL = 1.D-8 )

      DOUBLE PRECISION      NTOL
      PARAMETER           ( NTOL = 1.D-8 )

C
C     Local variables
C
      DOUBLE PRECISION      AXIS  ( 3 )
      DOUBLE PRECISION      ANGLE
      DOUBLE PRECISION      DELTA ( 3, 3 )
      DOUBLE PRECISION      M     ( 3, 3 )

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'LINROT_M' )
      END IF

C
C     INIT and FINAL must both be rotation matrices.
C
      IF (  .NOT.  ISROT ( INIT, NTOL, DTOL )  ) THEN

         CALL SETMSG ( 'INIT is not a rotation.' )
         CALL SIGERR ( 'SPICE(NOTAROTATION)'     )
         CALL CHKOUT ( 'LINROT_M'                )
         RETURN

      ELSE IF (  .NOT.  ISROT ( FINAL, NTOL, DTOL )  ) THEN

         CALL SETMSG ( 'FINAL is not a rotation.' )
         CALL SIGERR ( 'SPICE(NOTAROTATION)'      )
         CALL CHKOUT ( 'LINROT_M'                 )
         RETURN

      END IF

C
C     Little to do, really.  Define M by
C
C             T              T
C        FINAL   =   M * INIT
C
C     Since
C             T            T                T
C        FINAL   =  ( FINAL  * INIT ) * INIT
C
C     and all of the matrices here are non-singular, we have
C
C                          T
C        M       =  ( FINAL  * INIT )
C
C
C     Find an axis and angle for the rotation M, and interpolate the
C     angle.  Form the interpolated rotation DELTA.
C
      CALL MTXM   ( FINAL,  INIT,  M                   )
      CALL RAXISA ( M,      AXIS,  ANGLE               )
      CALL AXISAR (         AXIS,  ANGLE * FRAC, DELTA )

C
C     Since
C
C         T                 T
C        R   =  DELTA * INIT
C
C     we can find R directly by computing
C
C                           T
C        R   =  INIT * DELTA
C

      CALL MXMT   ( INIT, DELTA, R )

C
C     Finding the `constant' angular velocity vector is easy to do.
C
      CALL VSCL   ( ANGLE, AXIS, SCLDAV )

      CALL CHKOUT ( 'LINROT_M' )
      RETURN
      END


module model_comp_act
	! modules that contains functions which filter out the inactive model components
	! ( yield function values, derivative vectors, derivative matrices) and return only the active components
	! as 2D arrays

	! load additional modules
	use constants
	use material_info

	use yf_all, only: yf_ret_map
	use Df_allDs, only: DfDs
	use Df_allDa, only: DfDa
	use Dg_allDs, only: DgDs
	use DDg_allDDs, only: DDgDDs
	use DDg_allDsDa, only: DDgDsDa
	use hf_all, only: hf
	use Dh_allDs, only: DhDs
	use Dh_allDa, only: DhDa

    implicit none

contains

	function yf_act(sigma, alpha, yield_flags, act_yf_ind)
		! returns array/vector with active yield function values

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(:), intent(in) :: 	sigma			! stress vector
		real(kind=dbl), dimension(:), intent(in) :: 	alpha			! internal variables vector
		logical, dimension(:), intent(in) :: 			yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(size(act_yf_ind)) :: 			yf_act		! active yield functions vector

		! internal variables
		real(kind=dbl), dimension(size(yield_flags)) ::	 yf_all		! all yield functions vector
		! --------------------------------------------------------------------------

		! compute all yield functions
		yf_all = yf_ret_map(sigma, alpha, yield_flags)

		! filter active yield functions via vector with indices of active yield functions
		yf_act = yf_all(act_yf_ind)

	end function yf_act

	function Df_actDsigma(sigma, alpha, yield_flags, act_yf_ind)
		! computes array with df_act/dsigma vectors of active yield functions

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma					! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha					! internal variables vector
		logical, dimension(:), intent(in) :: yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(6,size(act_yf_ind)) :: Df_actDsigma				! array with df/dsigma vectors of active yield functions

		! internal variables
		real(kind=dbl), dimension(6,n_yf) :: Df_all			! array with df/dsigma vectors of all yield functions
		! --------------------------------------------------------------------------

		! compute all df/dsigma vectors
		Df_all = DfDs(sigma, alpha)

		! filter active df/dsigma vectors via vector with indices of active yield functions
		Df_actDsigma = Df_all(:,act_yf_ind)

	end function Df_actDsigma

	function Df_actDalpha(sigma, alpha, yield_flags, act_yf_ind)
		! computes vector with df_act/dalpha vectors of active yield functions

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma					! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha					! internal variables vector
		logical, dimension(:), intent(in) :: yield_flags					! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(size(alpha), size(act_yf_ind)) :: Df_actDalpha	! array with df/dalpha vectors of active yield functions

		real(kind=dbl), dimension(size(alpha), n_yf) :: Df_all	! array with df/dalpha vectors of all yield functions
		! --------------------------------------------------------------------------

		! compute all df/dalpha vectors
		Df_all = DfDa(sigma, alpha)

		! filter active df/dalpha vectors via vector with indices of active yield functions
		Df_actDalpha = Df_all(:,act_yf_ind)

	end function Df_actDalpha

	function Dg_actDsigma(sigma, alpha, yield_flags, act_yf_ind)
		! computes vector with dg_act/dalpha vectors of active plastic potentials

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma					! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha					! internal variables vector
		logical, dimension(:), intent(in) :: yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(6, size(act_yf_ind)) :: Dg_actDsigma	! array with dg/dsigma vectors of active yield functions

		! internal variables
		real(kind=dbl), dimension(6, n_yf) :: Dg_all	! array with dg/dsigma vectors of all plastic potentials
		! --------------------------------------------------------------------------

		! compute all df/dalpha vectors
		Dg_all = DgDs(sigma, alpha, yield_flags)

		! filter active df/dalpha vectors via vector with indices of active yield functions
		Dg_actDsigma = Dg_all(:,act_yf_ind)

	end function Dg_actDsigma

	function DDg_actDDsigma(sigma, alpha, yield_flags, act_yf_ind)
		! computes array with ddg_act/ddsigma matrices of active plastic potentials

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma					! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha					! internal variables vector
		logical, dimension(:), intent(in) :: yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(6,6,size(act_yf_ind)) :: DDg_actDDsigma			! array, with ddg/ddsigma (hessians) arrays of active yield functions

		! internal variables
		real(kind=dbl), dimension(6,6,n_yf) :: DDg_all	! array with ddg/ddsigma (hessians) matrices of all plastic potentials
		! --------------------------------------------------------------------------

		! compute all ddg/ddsigma matrices
		DDg_all = DDgDDs(sigma, alpha)

		! filter active ddg/ddsigma matrices via vector with indices of active yield functions
		DDg_actDDsigma = DDg_all(:,:,act_yf_ind)

	end function DDg_actDDsigma

	function DDg_actDsigmaDalpha(sigma, alpha, yield_flags, act_yf_ind)
		! computes array with ddg_act/dsigmadalpha matrices of active plastic potentials

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma					! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha					! internal variables vector
		logical, dimension(:), intent(in) :: yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(6,size(alpha), size(act_yf_ind)) :: DDg_actDsigmaDalpha		! array with ddg/dsigmadalpha matrices of active plastic potentials

		! internal variables
		real(kind=dbl), dimension(6,size(alpha),n_yf) :: DDg_all	! array with ddg/dsigmadalpha matrices of all plastic potentials
		! --------------------------------------------------------------------------

		! compute all ddg/dsigmadalpha matrices
		DDg_all = DDgDsDa(sigma, alpha)

		! filter active ddg/dsigmadalpha matrices via vector with indices of active yield functions
		DDg_actDsigmaDalpha = DDg_all(:,:,act_yf_ind)

	end function DDg_actDsigmaDalpha

	function hf_act(sigma, alpha, yield_flags, act_yf_ind)
		! computes array with hardening function vectors of active yield functions

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma					! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha					! internal variables vector
		logical, dimension(:), intent(in) :: yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(size(alpha),size(act_yf_ind)) :: hf_act	! array with hardening vectors of active yield functions

		! internal variables
		real(kind=dbl), dimension(size(alpha),n_yf) :: hardening_f_all	! array with hardening vectors of all yield functions
		! --------------------------------------------------------------------------

		! compute all hardening function vectors
		hardening_f_all = hf(sigma, alpha, yield_flags)

		! filter active hardening function vectors via vector with indices of active yield functions
		hf_act = hardening_f_all(:,act_yf_ind)

	end function hf_act

	function Dh_actDsigma(sigma, alpha, yield_flags, act_yf_ind)
		! computes array with dh/dsigma matrices of active yield functions

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma					! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha					! internal variables vector
		logical, dimension(:), intent(in) :: yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(size(alpha),6, size(act_yf_ind)) :: Dh_actDsigma		! array with dh/dsigma matrices of active yield functions

		! internal variables
		real(kind=dbl), dimension(size(alpha),6, n_yf) :: dh_all	! array with dh/dsigma matrices of all yield functions
		! --------------------------------------------------------------------------

		! compute all dh/dsigma matrices
		dh_all = DhDs(sigma, alpha)

		! filter active dh/dsigma matrices via vector with indices of active yield functions
		Dh_actDsigma = dh_all(:,:,act_yf_ind)

	end function Dh_actDsigma

	function Dh_actDalpha(sigma, alpha, yield_flags, act_yf_ind)
		! computes array with dh/dalpha matrices of active yield functions

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma					! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha					! internal variables vector
		logical, dimension(:), intent(in) :: yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(size(alpha),size(alpha), size(act_yf_ind)) :: Dh_actDalpha		! array with dh/dalpha matrices of active yield functions

		! internal variables
		real(kind=dbl), dimension(size(alpha),size(alpha), n_yf) :: dh_all	! array with dh/dalpha matrices of all yield functions
		! --------------------------------------------------------------------------

		! compute all dh/dalpha matrices
		dh_all = DhDa(sigma, alpha)

		! filter active dh/dalpha matrices via vector with indices of active yield functions
		Dh_actDalpha = dh_all(:,:,act_yf_ind)

	end function Dh_actDalpha

end module model_comp_act


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program Precision_Check

      implicit none

      integer, parameter :: i4 = SELECTED_INT_KIND(8)
      integer, parameter :: i8 = SELECTED_INT_KIND(13)
      integer, parameter :: r4 = SELECTED_REAL_KIND(6,30)
      integer, parameter :: c4 = SELECTED_REAL_KIND(6,30)
      integer, parameter :: r8 = SELECTED_REAL_KIND(12)
      integer, parameter :: c8 = SELECTED_REAL_KIND(12)

      integer     :: inative
      integer(i4) :: int4
      integer(i8) :: int8

      real        :: rnative
      real(r4)    :: realr4
      real(r8)    :: realr8

      double precision :: dp ! deliberate use of 'double precision'

      write(*,*)
      write(*,*)'This explores the use of the intrinisc &
                &SELECTED_[REAL,INT]_KIND() functions'
      write(*,*)'and the interplay with the compiler options. &
                &You are encouraged to use the'
      write(*,*)'"autopromotion" flags on your compiler and compare &
                &the results.'
      write(*,*)

      write(*,'(''----------------------------------------------'')')
      write(*,*)'"integer"'
      write(*,*)'DIGITS    = ',   digits(inative)
      write(*,*)'HUGE      = ',     huge(inative)
      write(*,*)'KIND      = ',     kind(inative)

      write(*,'(''----------------------------------------------'')')
      write(*,*)'"integer(i4)" i4 = SELECTED_INT_KIND(8)'
      write(*,*)'DIGITS    = ',   digits(int4)
      write(*,*)'HUGE      = ',     huge(int4)
      write(*,*)'KIND      = ',     kind(int4)

      write(*,'(''----------------------------------------------'')')
      write(*,*)'"integer(i8)" i8 = SELECTED_INT_KIND(13)'
      write(*,*)'DIGITS    = ',   digits(int8)
      write(*,*)'HUGE      = ',     huge(int8)
      write(*,*)'KIND      = ',     kind(int8)

      write(*,'(''----------------------------------------------'')')
      write(*,*)'"real"'
      write(*,*)'DIGITS    = ',   digits(rnative)
      write(*,*)'EPSILON   = ',  epsilon(rnative)
      write(*,*)'HUGE      = ',     huge(rnative)
      write(*,*)'KIND      = ',     kind(rnative)
      write(*,*)'PRECISION = ',precision(rnative)

      write(*,'(''----------------------------------------------'')')
      write(*,*)'"real(r4)" r4 = SELECTED_REAL_KIND(6,30)'
      write(*,*)'DIGITS    = ',   digits(realr4)
      write(*,*)'EPSILON   = ',  epsilon(realr4)
      write(*,*)'HUGE      = ',     huge(realr4)
      write(*,*)'KIND      = ',     kind(realr4)
      write(*,*)'PRECISION = ',precision(realr4)

      write(*,'(''----------------------------------------------'')')
      write(*,*)'"real(r8)" r8 = SELECTED_REAL_KIND(13)'
      write(*,*)'DIGITS    = ',   digits(realr8)
      write(*,*)'EPSILON   = ',  epsilon(realr8)
      write(*,*)'HUGE      = ',     huge(realr8)
      write(*,*)'KIND      = ',     kind(realr8)
      write(*,*)'PRECISION = ',precision(realr8)

      write(*,'(''----------------------------------------------'')')
      write(*,*)'"double precision"'
      write(*,*)'DIGITS    = ',   digits(dp)
      write(*,*)'EPSILON   = ',  epsilon(dp)
      write(*,*)'HUGE      = ',     huge(dp)
      write(*,*)'KIND      = ',     kind(dp)
      write(*,*)'PRECISION = ',precision(dp)

      end program Precision_Check

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


!
! Copyright (C) 2002-2006 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!----------------------------------------------------------------------------
MODULE constants
  !----------------------------------------------------------------------------
  !
  USE kinds, ONLY : DP
  !
  ! ... The constants needed everywhere
  !
  IMPLICIT NONE
  !
  SAVE
  !
  ! ... Mathematical constants
  !
  REAL(DP), PARAMETER :: pi     = 3.14159265358979323846_DP
  REAL(DP), PARAMETER :: tpi    = 2.0_DP * pi
  REAL(DP), PARAMETER :: fpi    = 4.0_DP * pi
  REAL(DP), PARAMETER :: sqrtpi = 1.77245385090551602729_DP
  REAL(DP), PARAMETER :: sqrtpm1= 1.0_DP / sqrtpi
  REAL(DP), PARAMETER :: sqrt2  = 1.41421356237309504880_DP
  !
  ! ... Physical constants, SI (NIST CODATA 2006), Web Version 5.1
  !     http://physics.nist.gov/constants
  REAL(DP), PARAMETER :: H_PLANCK_SI      = 6.62606896E-34_DP   ! J s
  REAL(DP), PARAMETER :: K_BOLTZMANN_SI   = 1.3806504E-23_DP    ! J K^-1
  REAL(DP), PARAMETER :: ELECTRON_SI      = 1.602176487E-19_DP  ! C
  REAL(DP), PARAMETER :: ELECTRONVOLT_SI  = 1.602176487E-19_DP  ! J
  REAL(DP), PARAMETER :: ELECTRONMASS_SI  = 9.10938215E-31_DP   ! Kg
  REAL(DP), PARAMETER :: HARTREE_SI       = 4.35974394E-18_DP   ! J
  REAL(DP), PARAMETER :: RYDBERG_SI       = HARTREE_SI/2.0_DP   ! J
  REAL(DP), PARAMETER :: BOHR_RADIUS_SI   = 0.52917720859E-10_DP ! m
  REAL(DP), PARAMETER :: AMU_SI           = 1.660538782E-27_DP  ! Kg
  REAL(DP), PARAMETER :: C_SI             = 2.99792458E+8_DP    ! m sec^-1
  !
  ! ... Physical constants, atomic units:
  ! ... AU for "Hartree" atomic units (e = m = hbar = 1)
  ! ... RY for "Rydberg" atomic units (e^2=2, m=1/2, hbar=1)
  !
  REAL(DP), PARAMETER :: K_BOLTZMANN_AU   = K_BOLTZMANN_SI / HARTREE_SI
  REAL(DP), PARAMETER :: K_BOLTZMANN_RY   = K_BOLTZMANN_SI / RYDBERG_SI
  !
  ! ... Unit conversion factors: energy and masses
  !
  REAL(DP), PARAMETER :: AUTOEV           = HARTREE_SI / ELECTRONVOLT_SI
  REAL(DP), PARAMETER :: RYTOEV           = AUTOEV / 2.0_DP
  REAL(DP), PARAMETER :: AMU_AU           = AMU_SI / ELECTRONMASS_SI
  REAL(DP), PARAMETER :: AMU_RY           = AMU_AU / 2.0_DP
  !
  ! ... Unit conversion factors: atomic unit of time, in s and ps
  !
  REAL(DP), PARAMETER :: AU_SEC           = H_PLANCK_SI/tpi/HARTREE_SI
  REAL(DP), PARAMETER :: AU_PS            = AU_SEC * 1.0E+12_DP
  !
  ! ... Unit conversion factors: pressure (1 Pa = 1 J/m^3, 1GPa = 10 Kbar )
  !
  REAL(DP), PARAMETER :: AU_GPA           = HARTREE_SI / BOHR_RADIUS_SI ** 3 &
                                            / 1.0E+9_DP
  REAL(DP), PARAMETER :: RY_KBAR          = 10.0_DP * AU_GPA / 2.0_DP
  !
  ! ... Unit conversion factors: 1 debye = 10^-18 esu*cm
  ! ...                                  = 3.3356409519*10^-30 C*m
  ! ...                                  = 0.208194346 e*A
  ! ... ( 1 esu = (0.1/c) Am, c=299792458 m/s)
  !
  REAL(DP), PARAMETER :: DEBYE_SI         = 3.3356409519_DP * 1.0E-30_DP ! C*m
  REAL(DP), PARAMETER :: AU_DEBYE         = ELECTRON_SI * BOHR_RADIUS_SI / &
                                            DEBYE_SI
  !
  REAL(DP), PARAMETER :: eV_to_kelvin = ELECTRONVOLT_SI / K_BOLTZMANN_SI
  REAL(DP), PARAMETER :: ry_to_kelvin = RYDBERG_SI / K_BOLTZMANN_SI
  !
  ! .. Unit conversion factors: Energy to wavelength
  !
  REAL(DP), PARAMETER :: EVTONM = 1E+9_DP * H_PLANCK_SI * C_SI / &
                                  &ELECTRONVOLT_SI
  REAL(DP), PARAMETER :: RYTONM = 1E+9_DP * H_PLANCK_SI * C_SI / RYDBERG_SI
  !
  !  Speed of light in atomic units
  !
  REAL(DP), PARAMETER :: C_AU             = C_SI / BOHR_RADIUS_SI * AU_SEC
  !
  ! ... zero up to a given accuracy
  !
  REAL(DP), PARAMETER :: eps4  = 1.0E-4_DP
  REAL(DP), PARAMETER :: eps6  = 1.0E-6_DP
  REAL(DP), PARAMETER :: eps8  = 1.0E-8_DP
  REAL(DP), PARAMETER :: eps12 = 1.0E-12_DP
  REAL(DP), PARAMETER :: eps14 = 1.0E-14_DP
  REAL(DP), PARAMETER :: eps16 = 1.0E-16_DP
  REAL(DP), PARAMETER :: eps24 = 1.0E-24_DP
  REAL(DP), PARAMETER :: eps32 = 1.0E-32_DP
  !
  REAL(DP), PARAMETER :: gsmall = 1.0E-12_DP
  !
  REAL(DP), PARAMETER :: e2 = 2.0_DP      ! the square of the electron charge
  REAL(DP), PARAMETER :: degspin = 2.0_DP ! the number of spins per level
  !
  !!!!!! COMPATIBIILITY
  !
  REAL(DP), PARAMETER :: amconv = AMU_RY
  REAL(DP), PARAMETER :: bohr_radius_cm = bohr_radius_si * 100.0_DP
  REAL(DP), PARAMETER :: BOHR_RADIUS_ANGS = bohr_radius_cm * 1.0E8_DP
  REAL(DP), PARAMETER :: ANGSTROM_AU = 1.0_DP/BOHR_RADIUS_ANGS
  REAL(DP), PARAMETER :: DIP_DEBYE = AU_DEBYE
  REAL(DP), PARAMETER :: AU_TERAHERTZ  = AU_PS
  REAL(DP), PARAMETER :: AU_TO_OHMCMM1 = 46000.0_DP ! (ohm cm)^-1
  REAL(DP), PARAMETER :: RY_TO_THZ = 1.0_DP / AU_TERAHERTZ / FPI
  REAL(DP), PARAMETER :: RY_TO_CMM1 = 1.E+10_DP * RY_TO_THZ / C_SI
  !

END MODULE constants

! perl script to create a program to list the available constants:
! extract with: grep '^!XX!' constants.f90 | sed 's,!XX!,,' > mkconstlist.pl
! then run: perl mkconstlist.pl constants.f90 > testme.f90
! and compile and run: testme.f90
!XX!#!/usr/bin/perl -w
!XX!
!XX!use strict;
!XX!
!XX!print <<EOF
!XX!! list all available constants and derived values
!XX!
!XX!PROGRAM list_constants
!XX!
!XX!  USE kinds, ONLY : DP
!XX!  USE constants
!XX!
!XX!EOF
!XX!;
!XX!
!XX!while(<>) {
!XX!  if ( /REAL\s*\(DP\)\s*,\s*PARAMETER\s*::\s*([a-zA-Z_0-9]+)\s*=.*$/ )  {
!XX!    print "  WRITE (*,'(A18,G24.17)') '$1:',$1\n";
!XX!  }
!XX!}
!XX!
!XX!print <<EOF
!XX!
!XX!END PROGRAM list_constants
!XX!EOF
!XX!;
!XX!


program test_sympl

use orbit_symplectic
use orbit_symplectic_quasi, only: f_quasi => f, si_quasi => si, &
    orbit_timestep_quasi, orbit_timestep_multi_quasi
use field_can_mod
use diag_mod, only : icounter
use omp_lib

implicit none
save

double precision, parameter :: qe = 1d0, m = 1d0, c = 1d0, mu = 1d-5
integer :: steps_per_bounce, nbounce

integer :: ierr, kt

double precision :: z0(4), vpar0, dt, taub

type(FieldCan) :: f

type(SymplecticIntegrator) :: euler1, euler2, midpoint, gauss2, gauss4, lobatto4, gauss6, gauss8
type(MultistageIntegrator) :: verlet, order4, mclachlan4, blanes4, kahan6, kahan8

! Initial conditions
z0(1) = 0.1d0  ! r
z0(2) = 1.5d0  ! theta
z0(3) = 0.0d0  ! phi
vpar0 = 0.0d0  ! parallel velocity

call FieldCan_init(f, mu, c*m/qe, vpar0, -1)

! Compute toroidal momentum from initial conditions
call eval_field(f, z0(1), z0(2), z0(3), 0)
z0(4) = m*vpar0*f%hph + qe/c*f%Aph  ! p_phi

taub = 7800d0  ! estimated bounce time
nbounce = 1000

steps_per_bounce = 8
dt = taub/steps_per_bounce

print *, 'timesteps: ', nbounce*steps_per_bounce

call orbit_sympl_init(euler1, f, z0, dt, 1, 1d-12, 1, 1)
call test_single(euler1, 'euler1.out')

stop
call orbit_sympl_init(euler2, f, z0, dt, 1, 1d-12, 2, 1)
call test_single(euler2, 'euler2.out')
print *, ''

call orbit_sympl_init(gauss2, f, z0, dt, 1, 1d-12, 4, 0)
call test_single(gauss2, 'gauss2.out')
call orbit_sympl_init(midpoint, f, z0, dt, 1, 1d-12, 3, 0)
call test_single(midpoint, 'midpoint.out')
call orbit_sympl_init_verlet(verlet, f, z0, dt, 1, 1d-12)
call test_multi(verlet, 'verlet.out')
print *, ''

call orbit_sympl_init(gauss4, f, z0, dt, 1, 1d-12, 5, 0)
call test_single(gauss4, 'gauss4.out')
call orbit_sympl_init_mclachlan4(mclachlan4, f, z0, dt, 1, 1d-12)
call test_multi(mclachlan4, 'mclachlan4.out')
call orbit_sympl_init_blanes4(blanes4, f, z0, dt, 1, 1d-12)
call test_multi(blanes4, 'blanes4.out')
call orbit_sympl_init(lobatto4, f, z0, dt, 1, 1d-12, 15, 0)
call test_single(lobatto4, 'lobatto4.out')
call orbit_sympl_init(gauss6, f, z0, dt, 1, 1d-12, 6, 0)
call test_single(gauss6, 'gauss6.out')
print *, ''

call orbit_sympl_init(gauss4, f, z0, dt, 1, 1d-12, 5, 0)
call test_quasi(gauss4, 'gauss4q.out')
call orbit_sympl_init(gauss6, f, z0, dt, 1, 1d-12, 6, 0)
call test_quasi(gauss6, 'gauss6q.out')
call orbit_sympl_init(lobatto4, f, z0, dt, 1, 1d-12, 15, 0)
call test_quasi(lobatto4, 'lobatto4q.out')
print *, ''
stop

! call orbit_sympl_init_order4(order4, f, z0, dt, 1, 1d-12)
! call test_multi(order4, 'order4.out')
!call orbit_sympl_init(lobatto4, f, z0, dt, 1, 1d-12, 15, 0)
!call test_single(lobatto4, 'lobatto4.out')
call orbit_sympl_init(gauss4, f, z0, dt, 1, 1d-12, 5, 0)
call test_single(gauss4, 'gauss4.out')
print *, ''

call orbit_sympl_init_kahan6(kahan6, f, z0, dt, 1, 1d-12)
call test_multi(kahan6, 'kahan6.out')
call orbit_sympl_init(gauss6, f, z0, dt, 1, 1d-12, 6, 0)
call test_single(gauss6, 'gauss6.out')
print *, ''

call orbit_sympl_init_kahan8(kahan8, f, z0, dt, 1, 1d-12)
call test_multi(kahan8, 'kahan8.out')
call orbit_sympl_init(gauss8, f, z0, dt, 1, 1d-12, 7, 0)
call test_single(gauss8, 'gauss8.out')
print *, ''

call orbit_sympl_init(euler1, f, z0, dt, 1, 1d-12, 1, 0)
call test_quasi(euler1, 'euler1q.out')
call orbit_sympl_init(euler2, f, z0, dt, 1, 1d-12, 2, 0)
call test_quasi(euler2, 'euler2q.out')
print *, ''

call orbit_sympl_init_verlet(verlet, f, z0, dt, 1, 1d-12)
call test_multi_quasi(verlet, 'verletq.out')
call orbit_sympl_init(midpoint, f, z0, dt, 1, 1d-12, 3, 0)
call test_quasi(midpoint, 'midpointq.out')
call orbit_sympl_init(gauss2, f, z0, dt, 1, 1d-12, 4, 0)
call test_quasi(gauss2, 'gauss2q.out')
print *, ''

! call orbit_sympl_init_order4(order4, f, z0, dt, 1, 1d-12)
! call test_multi_quasi(order4, 'order4q.out')
call orbit_sympl_init(lobatto4, f, z0, dt, 1, 1d-12, 15, 0)
call test_quasi(lobatto4, 'lobatto4q.out')
call orbit_sympl_init_mclachlan4(mclachlan4, f, z0, dt, 1, 1d-12)
call test_multi_quasi(mclachlan4, 'mclachlan4q.out')
call orbit_sympl_init_blanes4(blanes4, f, z0, dt, 1, 1d-12)
call test_multi_quasi(blanes4, 'blanes4q.out')
call orbit_sympl_init(gauss4, f, z0, dt, 1, 1d-12, 5, 0)
call test_quasi(gauss4, 'gauss4q.out')
print *, ''

call orbit_sympl_init_kahan6(kahan6, f, z0, dt, 1, 1d-12)
call test_multi_quasi(kahan6, 'kahan6q.out')
call orbit_sympl_init(gauss6, f, z0, dt, 1, 1d-12, 6, 0)
call test_quasi(gauss6, 'gauss6q.out')
print *, ''

call orbit_sympl_init_kahan8(kahan8, f, z0, dt, 1, 1d-12)
call test_multi_quasi(kahan8, 'kahan8q.out')
call orbit_sympl_init(gauss8, f, z0, dt, 1, 1d-12, 7, 0)
call test_quasi(gauss8, 'gauss8q.out')
print *, ''

contains

subroutine test_single(si, outname)
    type(SymplecticIntegrator) :: si
    character(len=*) :: outname

    integer :: nt
    double precision :: starttime, endtime
    double precision, allocatable :: out(:, :)

    nt = nbounce*steps_per_bounce
    allocate(out(5,nt))

    icounter = 0
    out(:,1:)=0d0

    out(1:4,1) = z0
    out(5,1) = f%H
    starttime = omp_get_wtime()
    do kt = 2, nt
        ierr = 0
        call orbit_timestep_sympl(si, f, ierr)
        if (.not. ierr==0) then
            print *, si%z
            exit
        endif
        out(1:4,kt) = si%z
        out(5,kt) = f%H
    end do
    endtime = omp_get_wtime()
    print *, outname(1:10), endtime-starttime, icounter

    open(unit=20, file=outname, action='write', recl=4096)
    do kt = 1, nt
        write(20,*) out(:,kt)
    end do
    close(20)
    deallocate(out)
end subroutine test_single

subroutine test_quasi(si, outname)
    type(SymplecticIntegrator) :: si
    character(len=*) :: outname

    integer :: nt
    double precision :: starttime, endtime
    double precision, allocatable :: out(:, :)

    nt = nbounce*steps_per_bounce
    allocate(out(5,nt))

    icounter = 0
    out(:,1:)=0d0

    out(1:4,1) = z0
    out(5,1) = f%H

    f_quasi = f
    si_quasi = si

    starttime = omp_get_wtime()
    do kt = 2, nt
        ierr = 0
        call orbit_timestep_quasi(ierr)
        if (.not. ierr==0) then
            print *, si%z
            exit
        endif
        out(1:4,kt) = si_quasi%z
        out(5,kt) = f_quasi%H
    end do
    endtime = omp_get_wtime()
    print *, outname(1:10), endtime-starttime, icounter

    open(unit=20, file=outname, action='write', recl=4096)
    do kt = 1, nt
        write(20,*) out(:,kt)
    end do
    close(20)
    deallocate(out)

end subroutine test_quasi

subroutine test_multi(mi, outname)
    type(MultistageIntegrator) :: mi
    character(len=*) :: outname

    integer :: nt
    double precision :: starttime, endtime
    double precision, allocatable :: out(:, :)

    nt = nbounce*steps_per_bounce
    allocate(out(5,nt))

    icounter = 0
    out(:,1:nbounce*steps_per_bounce)=0d0

    out(1:4,1) = z0
    out(5,1) = f%H

    starttime = omp_get_wtime()
    do kt = 2, nbounce*steps_per_bounce
        ierr = 0
        call orbit_timestep_sympl_multi(mi, f, ierr)
        if (.not. ierr==0) stop 'Error'
        out(1:4,kt) = mi%stages(1)%z
        out(5,kt) = f%H
    end do
    endtime = omp_get_wtime()
    print *, outname(1:10), endtime-starttime, icounter

    open(unit=20, file=outname, action='write', recl=4096)
    do kt = 1, nbounce*steps_per_bounce
        write(20,*) out(:,kt)
    end do
    close(20)
    deallocate(out)
end subroutine test_multi

subroutine test_multi_quasi(mi, outname)
    type(MultistageIntegrator) :: mi
    character(len=*) :: outname

    integer :: nt
    double precision :: starttime, endtime
    double precision, allocatable :: out(:, :)

    f_quasi = f

    nt = nbounce*steps_per_bounce
    allocate(out(5,nt))

    icounter = 0
    out(:,1:nbounce*steps_per_bounce)=0d0

    out(1:4,1) = z0
    out(5,1) = f_quasi%H

    starttime = omp_get_wtime()
    do kt = 2, nbounce*steps_per_bounce
        ierr = 0
        call orbit_timestep_multi_quasi(mi, ierr)
        if (.not. ierr==0) stop 'Error'
        out(1:4,kt) = mi%stages(1)%z
        out(5,kt) = f_quasi%H
    end do
    endtime = omp_get_wtime()
    print *, outname(1:10), endtime-starttime, icounter

    open(unit=20, file=outname, action='write', recl=4096)
    do kt = 1, nbounce*steps_per_bounce
       write(20,*) out(:,kt)
    end do
    close(20)
    deallocate(out)
end subroutine test_multi_quasi

end program test_sympl


SUBROUTINE rhsFreeSurface3D(t,Wavefield,g,rhsE,rhsP,Nx,Ny)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
INTEGER :: Nx,Ny
REAL(KIND=long) :: g,t
REAL(KIND=long), DIMENSION(Nx,Ny) :: rhsE, rhsP
TYPE(Wavefield_FS) :: Wavefield

IF (Nx==1) THEN
   rhsE = -Wavefield%Ey*Wavefield%Py + Wavefield%W*(one + Wavefield%Ey**2)                   ! kinematic FS BC
   rhsP = -g*Wavefield%E - half*(Wavefield%Py**2 - Wavefield%W**2*(one + Wavefield%Ey**2))  &
        + Wavefield%P0 - Wavefield%Qr_x  ! dynamic FS BC!
ELSE IF (Ny==1) THEN
	rhsE = -Wavefield%Ex*Wavefield%Px + Wavefield%W*(one + Wavefield%Ex**2 ) - Wavefield%Qr_x               ! kinematic FS BC
	rhsP = -g*Wavefield%E - half*(Wavefield%Px**2 - Wavefield%W**2*(one + Wavefield%Ex**2)) + Wavefield%P0 - Wavefield%Mr_t ! dynamic FS BC!
ELSE
	rhsE = -Wavefield%Ex*Wavefield%Px-Wavefield%Ey*Wavefield%Py + Wavefield%W*(one + Wavefield%Ex**2 + Wavefield%Ey**2)         ! kinematic FS BC
	rhsP = -g*Wavefield%E - half*(Wavefield%Px**2 + Wavefield%Py**2 - Wavefield%W**2*(one + Wavefield%Ex**2 + Wavefield%Ey**2))  &
      + Wavefield%P0 ! dynamic FS BC!
ENDIF
!
! Possible pressure damping terms
!
rhsE = rhsE + Wavefield%NuD
rhsP = rhsP + Wavefield%Pd
END SUBROUTINE rhsFreeSurface3D