program cylinder2d
  use fluidMod,   only: fluid
  use fieldMod,   only: field
  use bodyMod,    only: body
  use mympiMod
  use gridMod
  use imageMod,   only: display
  use geom_shape
  implicit none
!
! -- numerical parameters
  real,parameter  :: D = 64             ! resolution (pnts per diameter)
  real,parameter :: nu = D/10000
  integer         :: n(3)               ! number of points
! -- MPI utils
  integer :: b(3) = (/2,2,1/)                                   ! 128 blocks
  integer :: m(3)                                               ! number of points per block
  logical :: root                                               ! root processor
  logical :: kill=.false.                                       ! exits the time loop
! -- utils
  real,parameter :: dtPrint = 0.2*D                             ! print rate
  real  :: finish = 0.5*D     ! number of timesteps
! -- variables
  type(fluid) :: flow
  type(body)  :: geom
  real :: dt, t, pforce(2), vforce(2)

! -- Initialize MPI (if MPI is OFF, b is set to 1)
  call init_mympi(2,set_blocks=b)
  root = mympi_rank()==0

! -- Print MPI info
  if (root) print *, 'Blocks: ',b

! -- Initialize grid (might need to adjust these parameters later)
  n = composite(D*(/22,9,0/), prnt=root)!.true.)
  call xg(1)%stretch(n(1), -10*D, -1.5*D, 14*D, 25*D, h_max=15., prnt=root)
  call xg(2)%stretch(n(2), -10*D, -3.5*D, 3.5*D, 10*D, prnt=root)

! -- Initialize cylinder array
  geom = cylinder(axis=3,radius=0.5*D,center=0)

! -- Initialize fluid
  m = n/b
  call flow%init(m, geom, V=[1.,0.,0.], nu=nu)

  if(root) print *, '-- init complete --'
! -- Time update loop
  finish = finish+flow%time
  do while (flow%time<finish)
    dt = flow%dt                    ! time step
    call flow%update()              ! update N-S
    t = flow%time

    pforce = -2.*geom%pforce(flow%pressure)/D
    vforce = 2.*nu*geom%vforce(flow%velocity)/D
  	if(root) write(9,'(f10.4,f8.4,4e16.8)') t/D,dt,pforce,vforce
    if(root) flush(9)

    if(mod(t,dtPrint)<dt) then
      if(root) print "('Time:',f15.3,'. Time remaining:',f15.3)",t/D,finish/D-t/D
      call display(flow%velocity%vorticity_Z(), 'out_vort', lim = 20./D)
      call flow%write()
    end if
  end do

  call flow%write()
  call mympi_end()
end program cylinder2d


program Guess_a_number
  implicit none

  integer, parameter :: limit = 100
  integer :: guess, number
  real :: rnum

  write(*, "(a, i0, a)") "I have chosen a number between 1 and ", limit, &
                         " and you have to try to guess it."
  write(*, "(a/)")  "I will score your guess by indicating whether it is higher, lower or the same as that number"

  call random_seed
  call random_number(rnum)
  number = rnum * limit + 1
  do
    write(*, "(a)", advance="no") "Enter quess: "
    read*, guess
    if(guess < number) then
      write(*, "(a/)") "That is lower"
    else if(guess > number) then
      write(*, "(a/)") "That is higher"
    else
      write(*, "(a)") "That is correct"
      exit
    end if
  end do
end program


module vector2
  INTERFACE
    subroutine vecadd_wrapper(N,a,b,c) BIND (C, NAME='vecadd_wrapper')
      USE ISO_C_BINDING
      ! import c_int, c_float
      implicit none
      integer(c_int), value :: N
      real(c_double) :: a(N),b(N),c(N)
    end subroutine vecadd_wrapper
  END INTERFACE
end module vector2

program vecAdd2
    use ISO_C_BINDING
    use vector2
    integer, parameter :: N=100000
    real*8 :: a(N),b(N),c(N)
    real*8 :: sum
    integer :: i

    do i=1,N
      a(i) = sin(i*1.d0)**2
      b(i) = cos(i*1.d0)**2
    enddo

    call vecadd_wrapper(N,a,b,c)

    sum=0.d0
    do i=1,N
      sum = sum + c(i)
    enddo

    print *, "Final result: ", sum/N

end program vecAdd2


      subroutine decompnp(neq,ndim,a)
      implicit none
      integer neq,ndim
      real*8  a(ndim,ndim)
      real*8 eps,eps2,amult,apm,apn
      integer n,nm1,i,ip1,k,j,l
      data eps,eps2 /1.d-30,1.d-60/
      nm1=neq-1
      do 100 i=1,nm1
      ip1 = i+1
      do 120 l=ip1,neq
      amult=a(l,i)/a(i,i)
      a(l,i)=amult
      if(abs(amult).lt.eps2) go to 120
      do 130 k=ip1,neq
      a(l,k)=a(l,k)-amult*a(i,k)
  130 continue
  120 continue
  100 continue
      if(abs(a(neq,neq)).lt.eps) go to 1000
      return
 1000 continue
      write(6,*)a(neq,neq)
      stop"singular matrix in decompnp"
      end

      subroutine solvenp(neq,ndim,a,b)
      implicit none
      real*8 a(ndim,ndim),b(ndim)
      integer neq,ndim
      integer nm1,l,lm1,k,j,jp1,n
      real*8 scr
      nm1 = neq-1
      do 10 l=2,neq
      lm1=l-1
      do 20 k=1,lm1
      b(l)=b(l)-a(l,k)*b(k)
  20  continue
   10 continue
      b(neq)=b(neq)/a(neq,neq)
      do 30 l=1,nm1
      j=neq-l
      jp1=j+1
      do 40 k=jp1,neq
      b(j)=b(j)-a(j,k  )*b(k)
   40 continue
      b(j)=b(j)/a(j,j)
   30 continue
      return
      end


program gonge
	use gongesub1
	real*8 x(2),A(2,2),b(2)
	integer n
	write(*,"(6A13)")"f","x1","x2","g1","g2","i"
	data a /4.0d0,-1.0d0,-1.0d0,2.0d0/
	data b/0.0d0,0.0d0/
	data x/1.0d0,1.0d0/
	n=2
	call cg(A,b,x,n)
end program gonge


*DECK DVSET
      SUBROUTINE DVSET
C-----------------------------------------------------------------------
C Call sequence communication: None
C COMMON block variables accessed:
C     /DVOD01/ -- EL(13), H, TAU(13), TQ(5), L(= NQ + 1),
C                 METH, NQ, NQWAIT
C
C Subroutines called by DVSET: None
C Function routines called by DVSET: None
C-----------------------------------------------------------------------
C DVSET is called by DVSTEP and sets coefficients for use there.
C
C For each order NQ, the coefficients in EL are calculated by use of
C  the generating polynomial lambda(x), with coefficients EL(i).
C      lambda(x) = EL(1) + EL(2)*x + ... + EL(NQ+1)*(x**NQ).
C For the backward differentiation formulas,
C                                     NQ-1
C      lambda(x) = (1 + x/xi*(NQ)) * product (1 + x/xi(i) ) .
C                                     i = 1
C For the Adams formulas,
C                              NQ-1
C      (d/dx) lambda(x) = c * product (1 + x/xi(i) ) ,
C                              i = 1
C      lambda(-1) = 0,    lambda(0) = 1,
C where c is a normalization constant.
C In both cases, xi(i) is defined by
C      H*xi(i) = t sub n  -  t sub (n-i)
C              = H + TAU(1) + TAU(2) + ... TAU(i-1).
C
C
C In addition to variables described previously, communication
C with DVSET uses the following:
C   TAU    = A vector of length 13 containing the past NQ values
C            of H.
C   EL     = A vector of length 13 in which vset stores the
C            coefficients for the corrector formula.
C   TQ     = A vector of length 5 in which vset stores constants
C            used for the convergence test, the error test, and the
C            selection of H at a new order.
C   METH   = The basic method indicator.
C   NQ     = The current order.
C   L      = NQ + 1, the length of the vector stored in EL, and
C            the number of columns of the YH array being used.
C   NQWAIT = A counter controlling the frequency of order changes.
C            An order change is about to be considered if NQWAIT = 1.
C-----------------------------------------------------------------------
C
      include "vode.H"
C
C Type declarations for local variables --------------------------------
C
      DOUBLE PRECISION AHATN0, ALPH0, CNQM1, CORTES, CSUM, ELP, EM,
     1     EM0, FLOTI, FLOTL, FLOTNQ, HSUM, ONE, RXI, RXIS, S, SIX,
     2     T1, T2, T3, T4, T5, T6, TWO, XI, ZERO
      INTEGER I, IBACK, J, JP1, NQM1, NQM2
C
      DIMENSION EM(13)
      PARAMETER(CORTES = 0.1D0, ONE = 1.0D0, SIX = 6.0D0, TWO = 2.0D0)
      PARAMETER(ZERO = 0.0D0)
C
      FLOTL = REAL(L)
      NQM1 = NQ - 1
      NQM2 = NQ - 2
      GO TO (100, 200), METH
C
C Set coefficients for Adams methods. ----------------------------------
 100  IF (NQ .NE. 1) GO TO 110
      EL(1) = ONE
      EL(2) = ONE
      TQ(1) = ONE
      TQ(2) = TWO
      TQ(3) = SIX*TQ(2)
      TQ(5) = ONE
      GO TO 300
 110  HSUM = H
      EM(1) = ONE
      FLOTNQ = FLOTL - ONE
      DO 115 I = 2, L
 115    EM(I) = ZERO
      DO 150 J = 1, NQM1
        IF ((J .NE. NQM1) .OR. (NQWAIT .NE. 1)) GO TO 130
        S = ONE
        CSUM = ZERO
        DO 120 I = 1, NQM1
          CSUM = CSUM + S*EM(I)/REAL(I+1)
 120      S = -S
        TQ(1) = EM(NQM1)/(FLOTNQ*CSUM)
 130    RXI = H/HSUM
        DO 140 IBACK = 1, J
          I = (J + 2) - IBACK
 140      EM(I) = EM(I) + EM(I-1)*RXI
        HSUM = HSUM + TAU(J)
 150    CONTINUE
C Compute integral from -1 to 0 of polynomial and of x times it. -------
      S = ONE
      EM0 = ZERO
      CSUM = ZERO
      DO 160 I = 1, NQ
        FLOTI = REAL(I)
        EM0 = EM0 + S*EM(I)/FLOTI
        CSUM = CSUM + S*EM(I)/(FLOTI+ONE)
 160    S = -S
C In EL, form coefficients of normalized integrated polynomial. --------
      S = ONE/EM0
      EL(1) = ONE
      DO 170 I = 1, NQ
 170    EL(I+1) = S*EM(I)/REAL(I)
      XI = HSUM/H
      TQ(2) = XI*EM0/CSUM
      TQ(5) = XI/EL(L)
      IF (NQWAIT .NE. 1) GO TO 300
C For higher order control constant, multiply polynomial by 1+x/xi(q). -
      RXI = ONE/XI
      DO 180 IBACK = 1, NQ
        I = (L + 1) - IBACK
 180    EM(I) = EM(I) + EM(I-1)*RXI
C Compute integral of polynomial. --------------------------------------
      S = ONE
      CSUM = ZERO
      DO 190 I = 1, L
        CSUM = CSUM + S*EM(I)/REAL(I+1)
 190    S = -S
      TQ(3) = FLOTL*EM0/CSUM
      GO TO 300
C
C Set coefficients for BDF methods. ------------------------------------
 200  DO 210 I = 3, L
 210    EL(I) = ZERO
      EL(1) = ONE
      EL(2) = ONE
      ALPH0 = -ONE
      AHATN0 = -ONE
      HSUM = H
      RXI = ONE
      RXIS = ONE
      IF (NQ .EQ. 1) GO TO 240
      DO 230 J = 1, NQM2
C In EL, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------
        HSUM = HSUM + TAU(J)
        RXI = H/HSUM
        JP1 = J + 1
        ALPH0 = ALPH0 - ONE/REAL(JP1)
        DO 220 IBACK = 1, JP1
          I = (J + 3) - IBACK
 220      EL(I) = EL(I) + EL(I-1)*RXI
 230    CONTINUE
      ALPH0 = ALPH0 - ONE/REAL(NQ)
      RXIS = -EL(2) - ALPH0
      HSUM = HSUM + TAU(NQM1)
      RXI = H/HSUM
      AHATN0 = -EL(2) - RXI
      DO 235 IBACK = 1, NQ
        I = (NQ + 2) - IBACK
 235    EL(I) = EL(I) + EL(I-1)*RXIS
 240  T1 = ONE - AHATN0 + ALPH0
      T2 = ONE + REAL(NQ)*T1
      TQ(2) = ABS(ALPH0*T2/T1)
      TQ(5) = ABS(T2/(EL(L)*RXI/RXIS))
      IF (NQWAIT .NE. 1) GO TO 300
      CNQM1 = RXIS/EL(L)
      T3 = ALPH0 + ONE/REAL(NQ)
      T4 = AHATN0 + RXI
      ELP = T3/(ONE - T4 + T3)
      TQ(1) = ABS(ELP/CNQM1)
      HSUM = HSUM + TAU(NQ)
      RXI = H/HSUM
      T5 = ALPH0 - ONE/REAL(NQ+1)
      T6 = AHATN0 - RXI
      ELP = T2/(ONE - T6 + T5)
      TQ(3) = ABS(ELP*RXI*(FLOTL + ONE)*T5)
 300  TQ(4) = CORTES*TQ(2)
      RETURN
C----------------------- End of Subroutine DVSET -----------------------
      END


c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: ssaupd
c
c\Description:
c
c  Reverse communication interface for the Implicitly Restarted Arnoldi
c  Iteration.  For symmetric problems this reduces to a variant of the Lanczos
c  method.  This method has been designed to compute approximations to a
c  few eigenpairs of a linear operator OP that is real and symmetric
c  with respect to a real positive semi-definite symmetric matrix B,
c  i.e.
c
c       B*OP = (OP`)*B.
c
c  Another way to express this condition is
c
c       < x,OPy > = < OPx,y >  where < z,w > = z`Bw  .
c
c  In the standard eigenproblem B is the identity matrix.
c  ( A` denotes transpose of A)
c
c  The computed approximate eigenvalues are called Ritz values and
c  the corresponding approximate eigenvectors are called Ritz vectors.
c
c  ssaupd is usually called iteratively to solve one of the
c  following problems:
c
c  Mode 1:  A*x = lambda*x, A symmetric
c           ===> OP = A  and  B = I.
c
c  Mode 2:  A*x = lambda*M*x, A symmetric, M symmetric positive definite
c           ===> OP = inv[M]*A  and  B = M.
c           ===> (If M can be factored see remark 3 below)
c
c  Mode 3:  K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite
c           ===> OP = (inv[K - sigma*M])*M  and  B = M.
c           ===> Shift-and-Invert mode
c
c  Mode 4:  K*x = lambda*KG*x, K symmetric positive semi-definite,
c           KG symmetric indefinite
c           ===> OP = (inv[K - sigma*KG])*K  and  B = K.
c           ===> Buckling mode
c
c  Mode 5:  A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite
c           ===> OP = inv[A - sigma*M]*[A + sigma*M]  and  B = M.
c           ===> Cayley transformed mode
c
c  NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v
c        should be accomplished either by a direct method
c        using a sparse matrix factorization and solving
c
c           [A - sigma*M]*w = v  or M*w = v,
c
c        or through an iterative method for solving these
c        systems.  If an iterative method is used, the
c        convergence test must be more stringent than
c        the accuracy requirements for the eigenvalue
c        approximations.
c
c\Usage:
c  call ssaupd
c     ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM,
c       IPNTR, WORKD, WORKL, LWORKL, INFO )
c
c\Arguments
c  IDO     Integer.  (INPUT/OUTPUT)
c          Reverse communication flag.  IDO must be zero on the first
c          call to ssaupd.  IDO will be set internally to
c          indicate the type of operation to be performed.  Control is
c          then given back to the calling routine which has the
c          responsibility to carry out the requested operation and call
c          ssaupd with the result.  The operand is given in
c          WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)).
c          (If Mode = 2 see remark 5 below)
c          -------------------------------------------------------------
c          IDO =  0: first call to the reverse communication interface
c          IDO = -1: compute  Y = OP * X  where
c                    IPNTR(1) is the pointer into WORKD for X,
c                    IPNTR(2) is the pointer into WORKD for Y.
c                    This is for the initialization phase to force the
c                    starting vector into the range of OP.
c          IDO =  1: compute  Y = OP * X where
c                    IPNTR(1) is the pointer into WORKD for X,
c                    IPNTR(2) is the pointer into WORKD for Y.
c                    In mode 3,4 and 5, the vector B * X is already
c                    available in WORKD(ipntr(3)).  It does not
c                    need to be recomputed in forming OP * X.
c          IDO =  2: compute  Y = B * X  where
c                    IPNTR(1) is the pointer into WORKD for X,
c                    IPNTR(2) is the pointer into WORKD for Y.
c          IDO =  3: compute the IPARAM(8) shifts where
c                    IPNTR(11) is the pointer into WORKL for
c                    placing the shifts. See remark 6 below.
c          IDO = 99: done
c          -------------------------------------------------------------
c
c  BMAT    Character*1.  (INPUT)
c          BMAT specifies the type of the matrix B that defines the
c          semi-inner product for the operator OP.
c          B = 'I' -> standard eigenvalue problem A*x = lambda*x
c          B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
c
c  N       Integer.  (INPUT)
c          Dimension of the eigenproblem.
c
c  WHICH   Character*2.  (INPUT)
c          Specify which of the Ritz values of OP to compute.
c
c          'LA' - compute the NEV largest (algebraic) eigenvalues.
c          'SA' - compute the NEV smallest (algebraic) eigenvalues.
c          'LM' - compute the NEV largest (in magnitude) eigenvalues.
c          'SM' - compute the NEV smallest (in magnitude) eigenvalues.
c          'BE' - compute NEV eigenvalues, half from each end of the
c                 spectrum.  When NEV is odd, compute one more from the
c                 high end than from the low end.
c           (see remark 1 below)
c
c  NEV     Integer.  (INPUT)
c          Number of eigenvalues of OP to be computed. 0 < NEV < N.
c
c  TOL     Real  scalar.  (INPUT)
c          Stopping criterion: the relative accuracy of the Ritz value
c          is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)).
c          If TOL .LE. 0. is passed a default is set:
c          DEFAULT = wslamch('EPS')  (machine precision as computed
c                    by the LAPACK auxiliary subroutine wslamch).
c
c  RESID   Real  array of length N.  (INPUT/OUTPUT)
c          On INPUT:
c          If INFO .EQ. 0, a random initial residual vector is used.
c          If INFO .NE. 0, RESID contains the initial residual vector,
c                          possibly from a previous run.
c          On OUTPUT:
c          RESID contains the final residual vector.
c
c  NCV     Integer.  (INPUT)
c          Number of columns of the matrix V (less than or equal to N).
c          This will indicate how many Lanczos vectors are generated
c          at each iteration.  After the startup phase in which NEV
c          Lanczos vectors are generated, the algorithm generates
c          NCV-NEV Lanczos vectors at each subsequent update iteration.
c          Most of the cost in generating each Lanczos vector is in the
c          matrix-vector product OP*x. (See remark 4 below).
c
c  V       Real  N by NCV array.  (OUTPUT)
c          The NCV columns of V contain the Lanczos basis vectors.
c
c  LDV     Integer.  (INPUT)
c          Leading dimension of V exactly as declared in the calling
c          program.
c
c  IPARAM  Integer array of length 11.  (INPUT/OUTPUT)
c          IPARAM(1) = ISHIFT: method for selecting the implicit shifts.
c          The shifts selected at each iteration are used to restart
c          the Arnoldi iteration in an implicit fashion.
c          -------------------------------------------------------------
c          ISHIFT = 0: the shifts are provided by the user via
c                      reverse communication.  The NCV eigenvalues of
c                      the current tridiagonal matrix T are returned in
c                      the part of WORKL array corresponding to RITZ.
c                      See remark 6 below.
c          ISHIFT = 1: exact shifts with respect to the reduced
c                      tridiagonal matrix T.  This is equivalent to
c                      restarting the iteration with a starting vector
c                      that is a linear combination of Ritz vectors
c                      associated with the "wanted" Ritz values.
c          -------------------------------------------------------------
c
c          IPARAM(2) = LEVEC
c          No longer referenced. See remark 2 below.
c
c          IPARAM(3) = MXITER
c          On INPUT:  maximum number of Arnoldi update iterations allowed.
c          On OUTPUT: actual number of Arnoldi update iterations taken.
c
c          IPARAM(4) = NB: blocksize to be used in the recurrence.
c          The code currently works only for NB = 1.
c
c          IPARAM(5) = NCONV: number of "converged" Ritz values.
c          This represents the number of Ritz values that satisfy
c          the convergence criterion.
c
c          IPARAM(6) = IUPD
c          No longer referenced. Implicit restarting is ALWAYS used.
c
c          IPARAM(7) = MODE
c          On INPUT determines what type of eigenproblem is being solved.
c          Must be 1,2,3,4,5; See under \Description of ssaupd for the
c          five modes available.
c
c          IPARAM(8) = NP
c          When ido = 3 and the user provides shifts through reverse
c          communication (IPARAM(1)=0), ssaupd returns NP, the number
c          of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark
c          6 below.
c
c          IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO,
c          OUTPUT: NUMOP  = total number of OP*x operations,
c                  NUMOPB = total number of B*x operations if BMAT='G',
c                  NUMREO = total number of steps of re-orthogonalization.
c
c  IPNTR   Integer array of length 11.  (OUTPUT)
c          Pointer to mark the starting locations in the WORKD and WORKL
c          arrays for matrices/vectors used by the Lanczos iteration.
c          -------------------------------------------------------------
c          IPNTR(1): pointer to the current operand vector X in WORKD.
c          IPNTR(2): pointer to the current result vector Y in WORKD.
c          IPNTR(3): pointer to the vector B * X in WORKD when used in
c                    the shift-and-invert mode.
c          IPNTR(4): pointer to the next available location in WORKL
c                    that is untouched by the program.
c          IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL.
c          IPNTR(6): pointer to the NCV RITZ values array in WORKL.
c          IPNTR(7): pointer to the Ritz estimates in array WORKL associated
c                    with the Ritz values located in RITZ in WORKL.
c          IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below.
c
c          Note: IPNTR(8:10) is only referenced by sseupd. See Remark 2.
c          IPNTR(8): pointer to the NCV RITZ values of the original system.
c          IPNTR(9): pointer to the NCV corresponding error bounds.
c          IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors
c                     of the tridiagonal matrix T. Only referenced by
c                     sseupd if RVEC = .TRUE. See Remarks.
c          -------------------------------------------------------------
c
c  WORKD   Real  work array of length 3*N.  (REVERSE COMMUNICATION)
c          Distributed array to be used in the basic Arnoldi iteration
c          for reverse communication.  The user should not use WORKD
c          as temporary workspace during the iteration. Upon termination
c          WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired
c          subroutine sseupd uses this output.
c          See Data Distribution Note below.
c
c  WORKL   Real  work array of length LWORKL.  (OUTPUT/WORKSPACE)
c          Private (replicated) array on each PE or array allocated on
c          the front end.  See Data Distribution Note below.
c
c  LWORKL  Integer.  (INPUT)
c          LWORKL must be at least NCV**2 + 8*NCV .
c
c  INFO    Integer.  (INPUT/OUTPUT)
c          If INFO .EQ. 0, a randomly initial residual vector is used.
c          If INFO .NE. 0, RESID contains the initial residual vector,
c                          possibly from a previous run.
c          Error flag on output.
c          =  0: Normal exit.
c          =  1: Maximum number of iterations taken.
c                All possible eigenvalues of OP has been found. IPARAM(5)
c                returns the number of wanted converged Ritz values.
c          =  2: No longer an informational error. Deprecated starting
c                with release 2 of ARPACK.
c          =  3: No shifts could be applied during a cycle of the
c                Implicitly restarted Arnoldi iteration. One possibility
c                is to increase the size of NCV relative to NEV.
c                See remark 4 below.
c          = -1: N must be positive.
c          = -2: NEV must be positive.
c          = -3: NCV must be greater than NEV and less than or equal to N.
c          = -4: The maximum number of Arnoldi update iterations allowed
c                must be greater than zero.
c          = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.
c          = -6: BMAT must be one of 'I' or 'G'.
c          = -7: Length of private work array WORKL is not sufficient.
c          = -8: Error return from trid. eigenvalue calculation;
c                Informatinal error from LAPACK routine ssteqr.
c          = -9: Starting vector is zero.
c          = -10: IPARAM(7) must be 1,2,3,4,5.
c          = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable.
c          = -12: IPARAM(1) must be equal to 0 or 1.
c          = -13: NEV and WHICH = 'BE' are incompatable.
c          = -9999: Could not build an Arnoldi factorization.
c                   IPARAM(5) returns the size of the current Arnoldi
c                   factorization. The user is advised to check that
c                   enough workspace and array storage has been allocated.
c
c
c\Remarks
c  1. The converged Ritz values are always returned in ascending
c     algebraic order.  The computed Ritz values are approximate
c     eigenvalues of OP.  The selection of WHICH should be made
c     with this in mind when Mode = 3,4,5.  After convergence,
c     approximate eigenvalues of the original problem may be obtained
c     with the ARPACK subroutine sseupd.
c
c  2. If the Ritz vectors corresponding to the converged Ritz values
c     are needed, the user must call sseupd immediately following completion
c     of ssaupd. This is new starting with version 2.1 of ARPACK.
c
c  3. If M can be factored into a Cholesky factorization M = LL`
c     then Mode = 2 should not be selected.  Instead one should use
c     Mode = 1 with  OP = inv(L)*A*inv(L`).  Appropriate triangular
c     linear systems should be solved with L and L` rather
c     than computing inverses.  After convergence, an approximate
c     eigenvector z of the original problem is recovered by solving
c     L`z = x  where x is a Ritz vector of OP.
c
c  4. At present there is no a-priori analysis to guide the selection
c     of NCV relative to NEV.  The only formal requrement is that NCV > NEV.
c     However, it is recommended that NCV .ge. 2*NEV.  If many problems of
c     the same type are to be solved, one should experiment with increasing
c     NCV while keeping NEV fixed for a given test problem.  This will
c     usually decrease the required number of OP*x operations but it
c     also increases the work and storage required to maintain the orthogonal
c     basis vectors.   The optimal "cross-over" with respect to CPU time
c     is problem dependent and must be determined empirically.
c
c  5. If IPARAM(7) = 2 then in the Reverse commuication interface the user
c     must do the following. When IDO = 1, Y = OP * X is to be computed.
c     When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user
c     must overwrite X with A*X. Y is then the solution to the linear set
c     of equations B*Y = A*X.
c
c  6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the
c     NP = IPARAM(8) shifts in locations:
c     1   WORKL(IPNTR(11))
c     2   WORKL(IPNTR(11)+1)
c                        .
c                        .
c                        .
c     NP  WORKL(IPNTR(11)+NP-1).
c
c     The eigenvalues of the current tridiagonal matrix are located in
c     WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the
c     order defined by WHICH. The associated Ritz estimates are located in
c     WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1).
c
c-----------------------------------------------------------------------
c
c\Data Distribution Note:
c
c  Fortran-D syntax:
c  ================
c  REAL       RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL)
c  DECOMPOSE  D1(N), D2(N,NCV)
c  ALIGN      RESID(I) with D1(I)
c  ALIGN      V(I,J)   with D2(I,J)
c  ALIGN      WORKD(I) with D1(I)     range (1:N)
c  ALIGN      WORKD(I) with D1(I-N)   range (N+1:2*N)
c  ALIGN      WORKD(I) with D1(I-2*N) range (2*N+1:3*N)
c  DISTRIBUTE D1(BLOCK), D2(BLOCK,:)
c  REPLICATED WORKL(LWORKL)
c
c  Cray MPP syntax:
c  ===============
c  REAL       RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL)
c  SHARED     RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:)
c  REPLICATED WORKL(LWORKL)
c
c
c\BeginLib
c
c\References:
c  1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c     a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c     pp 357-385.
c  2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c     Restarted Arnoldi Iteration", Rice University Technical Report
c     TR95-13, Department of Computational and Applied Mathematics.
c  3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall,
c     1980.
c  4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program",
c     Computer Physics Communications, 53 (1989), pp 169-179.
c  5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to
c     Implement the Spectral Transformation", Math. Comp., 48 (1987),
c     pp 663-673.
c  6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos
c     Algorithm for Solving Sparse Symmetric Generalized Eigenproblems",
c     SIAM J. Matr. Anal. Apps.,  January (1993).
c  7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines
c     for Updating the QR decomposition", ACM TOMS, December 1990,
c     Volume 16 Number 4, pp 369-377.
c  8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral
c     Transformations in a k-Step Arnoldi Method". In Preparation.
c
c\Routines called:
c     ssaup2  ARPACK routine that implements the Implicitly Restarted
c             Arnoldi Iteration.
c     sstats  ARPACK routine that initialize timing and other statistics
c             variables.
c     ivout   ARPACK utility routine that prints integers.
c     arscnd  ARPACK utility routine for timing.
c     svout   ARPACK utility routine that prints vectors.
c     wslamch  LAPACK routine that determines machine constants.
c
c\Authors
c     Danny Sorensen               Phuong Vu
c     Richard Lehoucq              CRPC / Rice University
c     Dept. of Computational &     Houston, Texas
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\Revision history:
c     12/15/93: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: saupd.F   SID: 2.8   DATE OF SID: 04/10/01   RELEASE: 2
c
c\Remarks
c     1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
      subroutine ssaupd
     &   ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam,
     &     ipntr, workd, workl, lworkl, info )
c
c     %----------------------------------------------------%
c     | Include files for debugging and timing information |
c     %----------------------------------------------------%
c
      include   'debug.h'
      include   'stat.h'
c
c     %------------------%
c     | Scalar Arguments |
c     %------------------%
c
      character  bmat*1, which*2
      integer    ido, info, ldv, lworkl, n, ncv, nev
      Real
     &           tol
c
c     %-----------------%
c     | Array Arguments |
c     %-----------------%
c
      integer    iparam(11), ipntr(11)
      Real
     &           resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Real
     &           one, zero
      parameter (one = 1.0E+0 , zero = 0.0E+0 )
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      integer    bounds, ierr, ih, iq, ishift, iupd, iw,
     &           ldh, ldq, msglvl, mxiter, mode, nb,
     &           nev0, next, np, ritz, j
      save       bounds, ierr, ih, iq, ishift, iupd, iw,
     &           ldh, ldq, msglvl, mxiter, mode, nb,
     &           nev0, next, np, ritz
c
c     %----------------------%
c     | External Subroutines |
c     %----------------------%
c
      external   ssaup2,  svout, ivout, arscnd, sstats
c
c     %--------------------%
c     | External Functions |
c     %--------------------%
c
      Real
     &           wslamch
      external   wslamch
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
      if (ido .eq. 0) then
c
c        %-------------------------------%
c        | Initialize timing statistics  |
c        | & message level for debugging |
c        %-------------------------------%
c
         call sstats
         call arscnd (t0)
         msglvl = msaupd
c
         ierr   = 0
         ishift = iparam(1)
         mxiter = iparam(3)
c         nb     = iparam(4)
         nb     = 1
c
c        %--------------------------------------------%
c        | Revision 2 performs only implicit restart. |
c        %--------------------------------------------%
c
         iupd   = 1
         mode   = iparam(7)
c
c        %----------------%
c        | Error checking |
c        %----------------%
c
         if (n .le. 0) then
            ierr = -1
         else if (nev .le. 0) then
            ierr = -2
         else if (ncv .le. nev .or.  ncv .gt. n) then
            ierr = -3
         end if
c
c        %----------------------------------------------%
c        | NP is the number of additional steps to      |
c        | extend the length NEV Lanczos factorization. |
c        %----------------------------------------------%
c
         np     = ncv - nev
c
         if (mxiter .le. 0)                     ierr = -4
         if (which .ne. 'LM' .and.
     &       which .ne. 'SM' .and.
     &       which .ne. 'LA' .and.
     &       which .ne. 'SA' .and.
     &       which .ne. 'BE')                   ierr = -5
         if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6
c
         if (lworkl .lt. ncv**2 + 8*ncv)        ierr = -7
         if (mode .lt. 1 .or. mode .gt. 5) then
                                                ierr = -10
         else if (mode .eq. 1 .and. bmat .eq. 'G') then
                                                ierr = -11
         else if (ishift .lt. 0 .or. ishift .gt. 1) then
                                                ierr = -12
         else if (nev .eq. 1 .and. which .eq. 'BE') then
                                                ierr = -13
         end if
c
c        %------------%
c        | Error Exit |
c        %------------%
c
         if (ierr .ne. 0) then
            info = ierr
            ido  = 99
            go to 9000
         end if
c
c        %------------------------%
c        | Set default parameters |
c        %------------------------%
c
         if (nb .le. 0)                         nb = 1
         if (tol .le. zero)                     tol = wslamch('EpsMach')
c
c        %----------------------------------------------%
c        | NP is the number of additional steps to      |
c        | extend the length NEV Lanczos factorization. |
c        | NEV0 is the local variable designating the   |
c        | size of the invariant subspace desired.      |
c        %----------------------------------------------%
c
         np     = ncv - nev
         nev0   = nev
c
c        %-----------------------------%
c        | Zero out internal workspace |
c        %-----------------------------%
c
         do 10 j = 1, ncv**2 + 8*ncv
            workl(j) = zero
 10      continue
c
c        %-------------------------------------------------------%
c        | Pointer into WORKL for address of H, RITZ, BOUNDS, Q  |
c        | etc... and the remaining workspace.                   |
c        | Also update pointer to be used on output.             |
c        | Memory is laid out as follows:                        |
c        | workl(1:2*ncv) := generated tridiagonal matrix        |
c        | workl(2*ncv+1:2*ncv+ncv) := ritz values               |
c        | workl(3*ncv+1:3*ncv+ncv) := computed error bounds     |
c        | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q     |
c        | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace     |
c        %-------------------------------------------------------%
c
         ldh    = ncv
         ldq    = ncv
         ih     = 1
         ritz   = ih     + 2*ldh
         bounds = ritz   + ncv
         iq     = bounds + ncv
         iw     = iq     + ncv**2
         next   = iw     + 3*ncv
c
         ipntr(4) = next
         ipntr(5) = ih
         ipntr(6) = ritz
         ipntr(7) = bounds
         ipntr(11) = iw
      end if
c
c     %-------------------------------------------------------%
c     | Carry out the Implicitly restarted Lanczos Iteration. |
c     %-------------------------------------------------------%
c
      call ssaup2
     &   ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd,
     &     ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz),
     &     workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd,
     &     info )
c
c     %--------------------------------------------------%
c     | ido .ne. 99 implies use of reverse communication |
c     | to compute operations involving OP or shifts.    |
c     %--------------------------------------------------%
c
      if (ido .eq. 3) iparam(8) = np
      if (ido .ne. 99) go to 9000
c
      iparam(3) = mxiter
      iparam(5) = np
      iparam(9) = nopx
      iparam(10) = nbx
      iparam(11) = nrorth
c
c     %------------------------------------%
c     | Exit if there was an informational |
c     | error within ssaup2.               |
c     %------------------------------------%
c
      if (info .lt. 0) go to 9000
      if (info .eq. 2) info = 3
c
      if (msglvl .gt. 0) then
         call ivout (logfil, 1, mxiter, ndigit,
     &               '_saupd: number of update iterations taken')
         call ivout (logfil, 1, np, ndigit,
     &               '_saupd: number of "converged" Ritz values')
         call svout (logfil, np, workl(Ritz), ndigit,
     &               '_saupd: final Ritz values')
         call svout (logfil, np, workl(Bounds), ndigit,
     &               '_saupd: corresponding error bounds')
      end if
c
      call arscnd (t1)
      tsaupd = t1 - t0
c
      if (msglvl .gt. 0) then
c
c        %--------------------------------------------------------%
c        | Version Number & Version Date are defined in version.h |
c        %--------------------------------------------------------%
c
         write (6,1000)
         write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt,
     &                  tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref,
     &                  tgetv0, tseigt, tsgets, tsapps, tsconv
 1000    format (//,
     &      5x, '==========================================',/
     &      5x, '= Symmetric implicit Arnoldi update code =',/
     &      5x, '= Version Number:', ' 2.4' , 19x, ' =',/
     &      5x, '= Version Date:  ', ' 07/31/96' , 14x, ' =',/
     &      5x, '==========================================',/
     &      5x, '= Summary of timing statistics           =',/
     &      5x, '==========================================',//)
 1100    format (
     &      5x, 'Total number update iterations             = ', i5,/
     &      5x, 'Total number of OP*x operations            = ', i5,/
     &      5x, 'Total number of B*x operations             = ', i5,/
     &      5x, 'Total number of reorthogonalization steps  = ', i5,/
     &      5x, 'Total number of iterative refinement steps = ', i5,/
     &      5x, 'Total number of restart steps              = ', i5,/
     &      5x, 'Total time in user OP*x operation          = ', f12.6,/
     &      5x, 'Total time in user B*x operation           = ', f12.6,/
     &      5x, 'Total time in Arnoldi update routine       = ', f12.6,/
     &      5x, 'Total time in saup2 routine                = ', f12.6,/
     &      5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/
     &      5x, 'Total time in reorthogonalization phase    = ', f12.6,/
     &      5x, 'Total time in (re)start vector generation  = ', f12.6,/
     &      5x, 'Total time in trid eigenvalue subproblem   = ', f12.6,/
     &      5x, 'Total time in getting the shifts           = ', f12.6,/
     &      5x, 'Total time in applying the shifts          = ', f12.6,/
     &      5x, 'Total time in convergence testing          = ', f12.6)
      end if
c
 9000 continue
c
      return
c
c     %---------------%
c     | End of ssaupd |
c     %---------------%
c
      end


C$Procedure DPGRDR ( Derivative of planetographic w.r.t. rectangular )

      SUBROUTINE DPGRDR ( BODY, X, Y, Z, RE, F, JACOBI )

C$ Abstract
C
C     This routine computes the Jacobian matrix of the transformation
C     from rectangular to planetographic coordinates.
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     None.
C
C$ Keywords
C
C     COORDINATES
C     DERIVATIVES
C     MATRIX
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'zzctr.inc'

      CHARACTER*(*)         BODY
      DOUBLE PRECISION      X
      DOUBLE PRECISION      Y
      DOUBLE PRECISION      Z
      DOUBLE PRECISION      RE
      DOUBLE PRECISION      F
      DOUBLE PRECISION      JACOBI ( 3, 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     BODY       I   Body with which coordinate system is associated.
C     X          I   X-coordinate of point.
C     Y          I   Y-coordinate of point.
C     Z          I   Z-coordinate of point.
C     RE         I   Equatorial radius of the reference spheroid.
C     F          I   Flattening coefficient.
C     JACOBI     O   Matrix of partial derivatives.
C
C$ Detailed_Input
C
C     BODY       Name of the body with which the planetographic
C                coordinate system is associated.
C
C                BODY is used by this routine to look up from the
C                kernel pool the prime meridian rate coefficient giving
C                the body's spin sense.  See the Files and Particulars
C                header sections below for details.
C
C     X,
C     Y,
C     Z          are the rectangular coordinates of the point at
C                which the Jacobian of the map from rectangular
C                to planetographic coordinates is desired.
C
C     RE         Equatorial radius of the reference spheroid.
C
C     F          Flattening coefficient = (RE-RP) / RE,  where RP is
C                the polar radius of the spheroid.  (More importantly
C                RP = RE*(1-F).)
C
C$ Detailed_Output
C
C     JACOBI     is the matrix of partial derivatives of the conversion
C                from rectangular to planetographic coordinates.  It
C                has the form
C
C                    .-                               -.
C                    |  DLON/DX    DLON/DY   DLON/DZ   |
C                    |  DLAT/DX    DLAT/DY   DLAT/DZ   |
C                    |  DALT/DX    DALT/DY   DALT/DZ   |
C                    `-                               -'
C
C               evaluated at the input values of X, Y, and Z.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the body name BODY cannot be mapped to a NAIF ID code,
C        and if BODY is not a string representation of an integer,
C        the error SPICE(IDCODENOTFOUND) will be signaled.
C
C     2) If the kernel variable
C
C           BODY<ID code>_PGR_POSITIVE_LON
C
C        is present in the kernel pool but has a value other
C        than one of
C
C            'EAST'
C            'WEST'
C
C        the error SPICE(INVALIDOPTION) will be signaled.  Case
C        and blanks are ignored when these values are interpreted.
C
C     3) If polynomial coefficients for the prime meridian of BODY
C        are not available in the kernel pool, and if the kernel
C        variable BODY<ID code>_PGR_POSITIVE_LON is not present in
C        the kernel pool, the error SPICE(MISSINGDATA) will be signaled.
C
C     4) If the equatorial radius is non-positive, the error
C        SPICE(VALUEOUTOFRANGE) is signaled.
C
C     5) If the flattening coefficient is greater than or equal to one,
C        the error SPICE(VALUEOUTOFRANGE) is signaled.
C
C     6) If the input point is on the Z-axis (X = 0 and Y = 0), the
C        Jacobian matrix is undefined.  The error will be diagnosed
C        by routines in the call tree of this routine.
C
C$ Files
C
C     This routine expects a kernel variable giving BODY's prime
C     meridian angle as a function of time to be available in the
C     kernel pool.  Normally this item is provided by loading a PCK
C     file.  The required kernel variable is named
C
C        BODY<body ID>_PM
C
C     where <body ID> represents a string containing the NAIF integer
C     ID code for BODY.  For example, if BODY is 'JUPITER', then
C     the name of the kernel variable containing the prime meridian
C     angle coefficients is
C
C        BODY599_PM
C
C     See the PCK Required Reading for details concerning the prime
C     meridian kernel variable.
C
C     The optional kernel variable
C
C        BODY<body ID>_PGR_POSITIVE_LON
C
C     also is normally defined via loading a text kernel. When this
C     variable is present in the kernel pool, the prime meridian
C     coefficients for BODY are not required by this routine. See the
C     Particulars section below for details.
C
C$ Particulars
C
C     When performing vector calculations with velocities it is usually
C     most convenient to work in rectangular coordinates. However, once
C     the vector manipulations have been performed, it is often
C     desirable to convert the rectangular representations into
C     planetographic coordinates to gain insights about phenomena in
C     this coordinate frame.
C
C     To transform rectangular velocities to derivatives of coordinates
C     in a planetographic system, one uses the Jacobian of the
C     transformation between the two systems.
C
C     Given a state in rectangular coordinates
C
C        ( x, y, z, dx, dy, dz )
C
C     the velocity in planetographic coordinates is given by the matrix
C     equation:
C                          t          |                     t
C        (dlon, dlat, dalt)   = JACOBI|       * (dx, dy, dz)
C                                     |(x,y,z)
C
C     This routine computes the matrix
C
C              |
C        JACOBI|
C              |(x, y, z)
C
C
C     The planetographic definition of latitude is identical to the
C     planetodetic (also called "geodetic" in SPICE documentation)
C     definition. In the planetographic coordinate system, latitude is
C     defined using a reference spheroid.  The spheroid is
C     characterized by an equatorial radius and a polar radius. For a
C     point P on the spheroid, latitude is defined as the angle between
C     the X-Y plane and the outward surface normal at P.  For a point P
C     off the spheroid, latitude is defined as the latitude of the
C     nearest point to P on the spheroid.  Note if P is an interior
C     point, for example, if P is at the center of the spheroid, there
C     may not be a unique nearest point to P.
C
C     In the planetographic coordinate system, longitude is defined
C     using the spin sense of the body.  Longitude is positive to the
C     west if the spin is prograde and positive to the east if the spin
C     is retrograde.  The spin sense is given by the sign of the first
C     degree term of the time-dependent polynomial for the body's prime
C     meridian Euler angle "W":  the spin is retrograde if this term is
C     negative and prograde otherwise.  For the sun, planets, most
C     natural satellites, and selected asteroids, the polynomial
C     expression for W may be found in a SPICE PCK kernel.
C
C     The earth, moon, and sun are exceptions: planetographic longitude
C     is measured positive east for these bodies.
C
C     If you wish to override the default sense of positive longitude
C     for a particular body, you can do so by defining the kernel
C     variable
C
C        BODY<body ID>_PGR_POSITIVE_LON
C
C     where <body ID> represents the NAIF ID code of the body. This
C     variable may be assigned either of the values
C
C        'WEST'
C        'EAST'
C
C     For example, you can have this routine treat the longitude
C     of the earth as increasing to the west using the kernel
C     variable assignment
C
C        BODY399_PGR_POSITIVE_LON = 'WEST'
C
C     Normally such assignments are made by placing them in a text
C     kernel and loading that kernel via FURNSH.
C
C     The definition of this kernel variable controls the behavior of
C     the SPICELIB planetographic routines
C
C        PGRREC
C        RECPGR
C        DPGRDR
C        DRDPGR
C
C     It does not affect the other SPICELIB coordinate conversion
C     routines.
C
C$ Examples
C
C     Numerical results shown for this example may differ between
C     platforms as the results depend on the SPICE kernels used as
C     input and the machine specific arithmetic implementation.
C
C
C         Find the planetographic state of the earth as seen from
C         Mars in the J2000 reference frame at January 1, 2005 TDB.
C         Map this state back to rectangular coordinates as a check.
C
C
C              PROGRAM EX1
C              IMPLICIT NONE
C        C
C        C     SPICELIB functions
C        C
C              DOUBLE PRECISION      RPD
C        C
C        C     Local variables
C        C
C              DOUBLE PRECISION      ALT
C              DOUBLE PRECISION      DRECTN ( 3 )
C              DOUBLE PRECISION      ET
C              DOUBLE PRECISION      F
C              DOUBLE PRECISION      JACOBI ( 3, 3 )
C              DOUBLE PRECISION      LAT
C              DOUBLE PRECISION      LON
C              DOUBLE PRECISION      LT
C              DOUBLE PRECISION      PGRVEL ( 3 )
C              DOUBLE PRECISION      RADII  ( 3 )
C              DOUBLE PRECISION      RE
C              DOUBLE PRECISION      RECTAN ( 3 )
C              DOUBLE PRECISION      RP
C              DOUBLE PRECISION      STATE  ( 6 )
C
C              INTEGER               N
C        C
C        C     Load a PCK file containing a triaxial
C        C     ellipsoidal shape model and orientation
C        C     data for Mars.
C        C
C              CALL FURNSH ( 'pck00008.tpc' )
C
C        C
C        C     Load an SPK file giving ephemerides of earth and Mars.
C        C
C              CALL FURNSH ( 'de405.bsp' )
C
C        C
C        C     Load a leapseconds kernel to support time conversion.
C        C
C              CALL FURNSH ( 'naif0007.tls' )
C
C        C
C        C     Look up the radii for Mars.  Although we
C        C     omit it here, we could first call BADKPV
C        C     to make sure the variable BODY499_RADII
C        C     has three elements and numeric data type.
C        C     If the variable is not present in the kernel
C        C     pool, BODVRD will signal an error.
C        C
C              CALL BODVRD ( 'MARS', 'RADII', 3, N, RADII )
C
C        C
C        C     Compute flattening coefficient.
C        C
C              RE  =  RADII(1)
C              RP  =  RADII(3)
C              F   =  ( RE - RP ) / RE
C
C        C
C        C     Look up the geometric state of earth as seen from Mars at
C        C     January 1, 2005 TDB, relative to the J2000 reference
C        C     frame.
C        C
C              CALL STR2ET ( 'January 1, 2005 TDB', ET )
C
C              CALL SPKEZR ( 'Earth', ET,    'J2000', 'LT+S',
C             .              'Mars',  STATE, LT               )
C
C        C
C        C     Convert position to planetographic coordinates.
C        C
C              CALL RECPGR ( 'MARS', STATE, RE, F, LON, LAT, ALT )
C
C        C
C        C     Convert velocity to planetographic coordinates.
C        C
C
C              CALL DPGRDR ( 'MARS', STATE(1), STATE(2), STATE(3),
C             .               RE,    F,        JACOBI             )
C
C              CALL MXV ( JACOBI, STATE(4), PGRVEL )
C
C        C
C        C     As a check, convert the planetographic state back to
C        C     rectangular coordinates.
C        C
C              CALL PGRREC ( 'MARS', LON, LAT, ALT, RE, F, RECTAN )
C
C              CALL DRDPGR ( 'MARS', LON, LAT, ALT, RE, F, JACOBI )
C
C              CALL MXV ( JACOBI, PGRVEL, DRECTN )
C
C
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Rectangular coordinates:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  X (km)                 = ', STATE(1)
C              WRITE(*,*) '  Y (km)                 = ', STATE(2)
C              WRITE(*,*) '  Z (km)                 = ', STATE(3)
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Rectangular velocity:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  dX/dt (km/s)           = ', STATE(4)
C              WRITE(*,*) '  dY/dt (km/s)           = ', STATE(5)
C              WRITE(*,*) '  dZ/dt (km/s)           = ', STATE(6)
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Ellipsoid shape parameters: '
C              WRITE(*,*) ' '
C              WRITE(*,*) '  Equatorial radius (km) = ', RE
C              WRITE(*,*) '  Polar radius      (km) = ', RP
C              WRITE(*,*) '  Flattening coefficient = ', F
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Planetographic coordinates:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  Longitude (deg)        = ', LON / RPD()
C              WRITE(*,*) '  Latitude  (deg)        = ', LAT / RPD()
C              WRITE(*,*) '  Altitude  (km)         = ', ALT
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Planetographic velocity:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  d Longitude/dt (deg/s) = ', PGRVEL(1)/RPD()
C              WRITE(*,*) '  d Latitude/dt  (deg/s) = ', PGRVEL(2)/RPD()
C              WRITE(*,*) '  d Altitude/dt  (km/s)  = ', PGRVEL(3)
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Rectangular coordinates from inverse ' //
C             .           'mapping:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  X (km)                 = ', RECTAN(1)
C              WRITE(*,*) '  Y (km)                 = ', RECTAN(2)
C              WRITE(*,*) '  Z (km)                 = ', RECTAN(3)
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Rectangular velocity from inverse mapping:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  dX/dt (km/s)           = ', DRECTN(1)
C              WRITE(*,*) '  dY/dt (km/s)           = ', DRECTN(2)
C              WRITE(*,*) '  dZ/dt (km/s)           = ', DRECTN(3)
C              WRITE(*,*) ' '
C              END
C
C
C        Output from this program should be similar to the following
C        (rounding and formatting differ across platforms):
C
C
C           Rectangular coordinates:
C
C             X (km)                 =   146039732.
C             Y (km)                 =   278546607.
C             Z (km)                 =   119750315.
C
C           Rectangular velocity:
C
C             dX/dt (km/s)           =  -47.0428824
C             dY/dt (km/s)           =   9.07021778
C             dZ/dt (km/s)           =   4.75656274
C
C           Ellipsoid shape parameters:
C
C             Equatorial radius (km) =   3396.19
C             Polar radius      (km) =   3376.2
C             Flattening coefficient =   0.00588600756
C
C           Planetographic coordinates:
C
C             Longitude (deg)        =   297.667659
C             Latitude  (deg)        =   20.844504
C             Altitude  (km)         =   336531825.
C
C           Planetographic velocity:
C
C             d Longitude/dt (deg/s) =  -8.35738632E-06
C             d Latitude/dt  (deg/s) =   1.59349355E-06
C             d Altitude/dt  (km/s)  =  -11.2144327
C
C           Rectangular coordinates from inverse mapping:
C
C             X (km)                 =   146039732.
C             Y (km)                 =   278546607.
C             Z (km)                 =   119750315.
C
C           Rectangular velocity from inverse mapping:
C
C             dX/dt (km/s)           =  -47.0428824
C             dY/dt (km/s)           =   9.07021778
C             dZ/dt (km/s)           =   4.75656274
C
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     B.V. Semenov   (JPL)
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 21-SEP-2013 (BVS)
C
C        Updated to save the input body name and ZZBODTRN state counter
C        and to do name-ID conversion only if the counter has changed.
C
C        Updated to call LJUCRS instead of CMPRSS/UCASE.
C
C-    SPICELIB Version 1.0.0, 26-DEC-2004 (NJB) (WLT)
C
C-&

C$ Index_Entries
C
C     Jacobian of planetographic  w.r.t. rectangular coordinates
C
C-&

C$ Revisions
C
C     None.
C
C-&

C
C     SPICELIB functions
C
      INTEGER               PLNSNS

      LOGICAL               RETURN

C
C     Local parameters
C
      CHARACTER*(*)         PMTMP
      PARAMETER           ( PMTMP  = 'BODY#_PM' )

      CHARACTER*(*)         OVRTMP
      PARAMETER           ( OVRTMP = 'BODY#_PGR_POSITIVE_LON' )

      INTEGER               EARTH
      PARAMETER           ( EARTH  = 399 )

      INTEGER               KVNMLN
      PARAMETER           ( KVNMLN = 32  )

      INTEGER               LNSIZE
      PARAMETER           ( LNSIZE = 80  )

      INTEGER               MOON
      PARAMETER           ( MOON   = 301 )

      INTEGER               SENSLN
      PARAMETER           ( SENSLN = 4 )

      INTEGER               SUN
      PARAMETER           ( SUN    = 10  )

C
C     Saved body name length.
C
      INTEGER               MAXL
      PARAMETER           ( MAXL  = 36 )

C
C     Local variables
C
      CHARACTER*(LNSIZE)    KVALUE
      CHARACTER*(KVNMLN)    PMKVAR
      CHARACTER*(SENSLN)    PGRLON

      INTEGER               BODYID
      INTEGER               I
      INTEGER               N
      INTEGER               SENSE

      LOGICAL               FOUND

C
C     Saved name/ID item declarations.
C
      INTEGER               SVCTR1 ( CTRSIZ )
      CHARACTER*(MAXL)      SVBODY
      INTEGER               SVBDID
      LOGICAL               SVFND1

      LOGICAL               FIRST

C
C     Saved name/ID items.
C
      SAVE                  SVCTR1
      SAVE                  SVBODY
      SAVE                  SVBDID
      SAVE                  SVFND1

      SAVE                  FIRST

C
C     Initial values.
C
      DATA                  FIRST   / .TRUE. /

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

C
C     Initialization.
C
      IF ( FIRST ) THEN

C
C        Initialize counter.
C
         CALL ZZCTRUIN( SVCTR1 )

         FIRST = .FALSE.

      END IF

C
C     Convert the body name to an ID code.
C
      CALL ZZBODS2C ( SVCTR1, SVBODY, SVBDID, SVFND1,
     .                BODY, BODYID, FOUND    )

      IF ( .NOT. FOUND ) THEN

         CALL SETMSG ( 'The value of the input argument BODY is #, '
     .   //            'this is not a recognized name of an '
     .   //            'ephemeris object. The cause of this '
     .   //            'problem may be that you need an updated '
     .   //            'version of the SPICE Toolkit. '           )
         CALL ERRCH  ( '#', BODY                                  )
         CALL SIGERR ( 'SPICE(IDCODENOTFOUND)'                    )
         CALL CHKOUT ( 'DPGRDR'                                   )
         RETURN

      END IF

C
C     The equatorial radius must be positive. If not, signal an error
C     and check out.
C
      IF ( RE .LE. 0.0D0 ) THEN

         CALL SETMSG ( 'Equatorial radius was #.' )
         CALL ERRDP  ( '#', RE                    )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'   )
         CALL CHKOUT ( 'DPGRDR'                   )
         RETURN

      END IF

C
C     If the flattening coefficient is greater than 1, the polar radius
C     is negative. If F is equal to 1, the polar radius is zero. Either
C     case is a problem, so signal an error and check out.
C
      IF ( F .GE. 1.D0 ) THEN

         CALL SETMSG ( 'Flattening coefficient was #.'  )
         CALL ERRDP  ( '#', F                           )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'         )
         CALL CHKOUT ( 'DPGRDR'                         )
         RETURN

      END IF

C
C     Look up the longitude sense override variable from the
C     kernel pool.
C
      CALL REPMI  ( OVRTMP, '#',     BODYID, PMKVAR )
      CALL GCPOOL ( PMKVAR, 1, 1, N, KVALUE, FOUND  )

      IF ( FOUND ) THEN
C
C        Make sure we recognize the value of PGRLON.
C
         CALL LJUCRS ( 0, KVALUE, PGRLON )

         IF ( PGRLON .EQ. 'EAST' ) THEN

            SENSE =  1

         ELSE IF ( PGRLON .EQ. 'WEST' ) THEN

            SENSE = -1

         ELSE

            CALL SETMSG ( 'Kernel variable # may have the values ' //
     .                    'EAST or WEST.  Actual value was #.'    )
            CALL ERRCH  ( '#', PMKVAR                             )
            CALL ERRCH  ( '#', KVALUE                             )
            CALL SIGERR ( 'SPICE(INVALIDOPTION)'                  )
            CALL CHKOUT ( 'DPGRDR'                                )
            RETURN

         END IF

      ELSE
C
C        Look up the spin sense of the body's prime meridian.
C
         SENSE = PLNSNS ( BODYID )

C
C        If the required prime meridian rate was not available,
C        PLNSNS returns the code 0.  Here we consider this situation
C        to be an error.
C
         IF ( SENSE .EQ. 0 ) THEN

            CALL REPMI  ( PMTMP, '#', BODYID, PMKVAR )

            CALL SETMSG ( 'Prime meridian rate coefficient defined ' //
     .                    'by kernel variable # is required but '    //
     .                    'not available for body #. '               )
            CALL ERRCH  ( '#', PMKVAR                                )
            CALL ERRCH  ( '#', BODY                                  )
            CALL SIGERR ( 'SPICE(MISSINGDATA)'                       )
            CALL CHKOUT ( 'DPGRDR'                                   )
            RETURN

         END IF

C
C        Handle the special cases:  earth, moon, and sun.
C
         IF (      ( BODYID .EQ. EARTH )
     .        .OR. ( BODYID .EQ. MOON  )
     .        .OR. ( BODYID .EQ. SUN   )  ) THEN

            SENSE = 1

         END IF

      END IF

C
C     At this point, SENSE is set to +/- 1.
C
C     To obtain the Jacobian matrix we want, first find the Jacobian
C     matrix of rectangular coordinates with respect to geodetic
C     coordinates.
C
      CALL DGEODR ( X, Y, Z, RE, F, JACOBI )

C
C     Letting GLON represent geodetic longitude, the matrix JACOBI is
C
C        .-                             -.
C        |  DGLON/DX  DGLON/DY  DGLON/DZ |
C        |  DLAT/DX   DLAT/DY   DLAT/DZ  |
C        |  DALT/DX   DALT/DY   DALT/DZ  |
C        `-                             -'
C
C     evaluated at the input values of X, Y, and Z.
C
C     Since planetographic longitude LON satisfies
C
C        LON = SENSE * GLON
C
C     applying the chain rule to D(*)/DGLON, the above is equivalent to
C
C        .-                                                         -.
C        |  (1/SENSE)*DLON/DX  (1/SENSE)*DLON/DY  (1/SENSE)*DLON/DZ  |
C        |            DLAT/DX            DLAT/DY            DLAT/DZ  |
C        |            DALT/DX            DALT/DY            DALT/DZ  |
C        `-                                                         -'
C
C     So, multiplying the first row of JACOBI by SENSE gives us the
C     matrix we actually want to compute:  the Jacobian matrix of
C     rectangular coordinates with respect to planetographic
C     coordinates.
C
      DO I = 1, 3

         JACOBI(1,I) = SENSE * JACOBI(1,I)

      END DO

      CALL CHKOUT ( 'DPGRDR' )
      RETURN
      END


! test of fft*g.f
!
!
      program main
      integer nmax, nmaxsqrt
      parameter (nmax = 32768)
      parameter (nmaxsqrt = 128)
      integer n, ip(0 : nmaxsqrt + 1)
      real*8 a(0 : nmax), w(0 : nmax * 5 / 4 - 1), t(0 : nmax / 2),
     &    err, errorcheck
!
      write (*, *) 'data length n=? (must be 2**m)'
      read (*, *) n
      ip(0) = 0
!
!   check of CDFT
      call putdata(0, n - 1, a)
      call cdft(n, 1, a, ip, w)
      call cdft(n, -1, a, ip, w)
      err = errorcheck(0, n - 1, 2.0d0 / n, a)
      write (*, *) 'cdft err= ', err
!
!   check of RDFT
      call putdata(0, n - 1, a)
      call rdft(n, 1, a, ip, w)
      call rdft(n, -1, a, ip, w)
      err = errorcheck(0, n - 1, 2.0d0 / n, a)
      write (*, *) 'rdft err= ', err
!
!   check of DDCT
      call putdata(0, n - 1, a)
      call ddct(n, 1, a, ip, w)
      call ddct(n, -1, a, ip, w)
      a(0) = a(0) * 0.5d0
      err = errorcheck(0, n - 1, 2.0d0 / n, a)
      write (*, *) 'ddct err= ', err
!
!   check of DDST
      call putdata(0, n - 1, a)
      call ddst(n, 1, a, ip, w)
      call ddst(n, -1, a, ip, w)
      a(0) = a(0) * 0.5d0
      err = errorcheck(0, n - 1, 2.0d0 / n, a)
      write (*, *) 'ddst err= ', err
!
!   check of DFCT
      call putdata(0, n, a)
      a(0) = a(0) * 0.5d0
      a(n) = a(n) * 0.5d0
      call dfct(n, a, t, ip, w)
      a(0) = a(0) * 0.5d0
      a(n) = a(n) * 0.5d0
      call dfct(n, a, t, ip, w)
      err = errorcheck(0, n, 2.0d0 / n, a)
      write (*, *) 'dfct err= ', err
!
!   check of DFST
      call putdata(1, n - 1, a)
      call dfst(n, a, t, ip, w)
      call dfst(n, a, t, ip, w)
      err = errorcheck(1, n - 1, 2.0d0 / n, a)
      write (*, *) 'dfst err= ', err
!
      end
!
!
      subroutine putdata(nini, nend, a)
      integer nini, nend, j, seed
      real*8 a(0 : *), drnd
      seed = 0
      do j = nini, nend
          a(j) = drnd(seed)
      end do
      end
!
!
      function errorcheck(nini, nend, scale, a)
      integer nini, nend, j, seed
      real*8 scale, a(0 : *), drnd, err, e, errorcheck
      err = 0
      seed = 0
      do j = nini, nend
          e = drnd(seed) - a(j) * scale
          err = max(err, abs(e))
      end do
      errorcheck = err
      end
!
!
! random number generator, 0 <= drnd < 1
      real*8 function drnd(seed)
      integer seed
      seed = mod(seed * 7141 + 54773, 259200)
      drnd = seed * (1.0d0 / 259200.0d0)
      end
!


!     bar 2nd piola-kichhoff
!
subroutine r_spiola_viscous(xot,vel)
  use r_common
  use fluid_variables, only: mu => vis_liq
  use solid_variables, only: nen_solid,nsd => nsd_solid
  implicit none

  real(8),intent(in) :: xot(1:nsd,1:nsd)
  real(8),intent(in) :: vel(1:nsd,1:nen_solid)

  integer :: nos,isd,jsd,ksd
  real(8) :: sigma(1:nsd,1:nsd),ui_j(1:nsd,1:nsd) !,press

  sigma(:,:) = 0.0
  ui_j(:,:) = 0.0
  do nos = 1,nen_solid
     do isd = 1,nsd
        do jsd = 1,nsd
           ui_j(isd,jsd) = ui_j(isd,jsd) + bd_curr(jsd,nos)*vel(isd,nos)
        end do
     end do
  end do
  do isd = 1,nsd
     do jsd = 1,nsd
        sigma(isd,jsd) = mu*(ui_j(isd,jsd)+ui_j(jsd,isd))
     end do
  end do

  do isd = 1,nsd
     do jsd = 1,nsd
        do ksd = 1,nsd
           PK1str_tens(isd,jsd) = PK1str_tens(isd,jsd) - xot(isd,ksd)*sigma(ksd,jsd)
        enddo
     enddo
  enddo

  return
end subroutine r_spiola_viscous


      subroutine runCY_i1i2i3i4i5(i,j,i1,i2,i3,i4,i5,f,Xtwiddle,
     . Gtt,Gtwiddle,Shat6,Bzero5,N0)
      implicit none
C---  Expression for Eq. 5.61
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,i,j,i1,i2,i3,i4,i5,n,m,np
      parameter(np=2)
      double precision
     . Xtwiddle(0:np,0:np),Gtwiddle(np,np),f(np),Gtt(np,np,np,np)
      double complex Shat6(np,z5max,-2:0),Bzero5(z5max,-2:0),
     . bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gtt(i,n,j,m)*f(n)
     . *(Shat6(m,z5(i1,i2,i3,i4,i5),ep)
     . -2d0*delta(m,i1)*Cv(czziiii(z4(i2,i3,i4,i5))+N0,ep)
     . -2d0*delta(m,i2)*Cv(czziiii(z4(i1,i3,i4,i5))+N0,ep)
     . -2d0*delta(m,i3)*Cv(czziiii(z4(i1,i2,i4,i5))+N0,ep)
     . -2d0*delta(m,i4)*Cv(czziiii(z4(i1,i2,i3,i5))+N0,ep)
     . -2d0*delta(m,i5)*Cv(czziiii(z4(i1,i2,i3,i4))+N0,ep))
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=-4d0*Cv(czziiiii(z5(i1,i2,i3,i4,i5))+N0,ep-1)
      Cv(ciiiii(z5(i1,i2,i3,i4,i5))+N0,ep)=
     .  (Gtwiddle(i,j)
     . *(14d0*Cv(czziiiii(z5(i1,i2,i3,i4,i5))+N0,ep)
     .  +pole-Bzero5(z5(i1,i2,i3,i4,i5),ep))
     .  +bit+Xtwiddle(0,j)*Cv(ciiiiii(z6(i,i1,i2,i3,i4,i5))+N0,ep)
     .   )/Xtwiddle(i,j)

      enddo
      return
      end


!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err
      integer x,y
      integer r
      integer i,j,k

      integer ne,elemsize,nb,blksize
      parameter(ne=8,elemsize=2,nb=2,blksize=5)
      integer ind(elemsize*ne)
      integer layout(3)
      integer blk,elem,indx

      real*8 a(ne+1)
      real*8 yy(nb*blksize*elemsize)
      real*8 xx(ne+1)
      real*8 diff
      integer*8 aoffset,xoffset,yoffset

      character arg*32

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

      call ceedvectorcreate(ceed,ne+1,x,err)

      do i=1,ne+1
        a(i)=10+i-1
      enddo

      aoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,a,aoffset,err)

      do i=1,ne
        ind(2*i-1)=i-1
        ind(2*i  )=i
      enddo
      call ceedelemrestrictioncreateblocked(ceed,ne,elemsize,blksize,1,1,ne+1,&
     & ceed_mem_host,ceed_use_pointer,ind,r,err)

      call ceedvectorcreate(ceed,blksize*elemsize,y,err);
      call ceedvectorsetvalue(y,0.d0,err)

!     NoTranspose
      call ceedelemrestrictionapplyblock(r,1,ceed_notranspose,x,y,&
     & ceed_request_immediate,err)
      call ceedvectorgetarrayread(y,ceed_mem_host,yy,yoffset,err)
      call ceedelemrestrictiongetelayout(r,layout,err)
      do i=0,elemsize-1
        do j=0,0
          do k=blksize,ne-1
            blk = k/blksize
            elem = mod(k,blksize)
            indx = (i*blksize+elem)*layout(1)+j*layout(2)*blksize+blk*layout(3)*blksize-&
     & blksize*elemsize
            diff=yy(yoffset+indx+1)
            diff=diff-a(ind(k*elemsize+i+1)+1)
            if (abs(diff) > 1.0D-15) then
! LCOV_EXCL_START
             write(*,*) 'Error in restricted array y(',i,')(',j,')(',k,')=',&
     &         yy(yoffset+indx+1)
! LCOV_EXCL_STOP
            endif
          enddo
        enddo
      enddo
      call ceedvectorrestorearrayread(y,yy,yoffset,err)

!     Transpose
      call ceedvectorsetvalue(x,0.d0,err)
      call ceedelemrestrictionapplyblock(r,1,ceed_transpose,y,x,&
     & ceed_request_immediate,err)
      call ceedvectorgetarrayread(x,ceed_mem_host,xx,xoffset,err)
      do i=blksize+1,ne+1
        diff=xx(xoffset+i)
        if (i > blksize+1 .and. i < ne+1) then
          diff=diff-2*(10+i-1)
        else
          diff=diff-(10+i-1)
        endif
        if (abs(diff) > 1.0D-15) then
! LCOV_EXCL_START
         write(*,*) 'Error in restricted array x(',i,')=',&
     &         xx(xoffset+i)
! LCOV_EXCL_STOP
        endif
      enddo
      call ceedvectorrestorearrayread(x,xx,xoffset,err)

      call ceedvectordestroy(x,err)
      call ceedvectordestroy(y,err)
      call ceedelemrestrictiondestroy(r,err)
      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


program test_quad
    use, intrinsic :: iso_fortran_env, only : error_unit
    use :: quad_mod
    use :: quad_gauss_mod
    use :: quad_gauss5_mod
    use :: quad_gauss10_mod
    use :: quad_simpson_mod
    implicit none
    real, parameter :: PI = acos(-1.0)
    class(quad_t), allocatable :: quad
    character(len=20) :: method

    call get_arguments(method)

    select case (method)
    case ('quad5')
        allocate(quad, source=quad_gauss5_t())
    case ('quad10')
        allocate(quad, source=quad_gauss10_t())
    case ('simpson')
        allocate(quad, source=quad_simpson_t())
    case default
        write (unit=error_unit, fmt='(3A)') 'error: method ', trim(method), &
            ' is not implemented'
        stop 11
    end select
    print '(F10.7)', quad%compute(func, 0.0, PI)

contains

    function func(x) result(res)
        implicit none
        real, value :: x
        real :: res

        res = sin(x)
    end function func

    subroutine get_arguments(method)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        character(len=*), intent(out) :: method

        if (command_argument_count() /= 1) then
            write (unit=error_unit, fmt='(A)') 'error: expect method as argument'
            stop 10
        end if
        call get_command_argument(1, method)
    end subroutine get_arguments

end program test_quad