PROGRAM rectangular_prism_test
    USE Precision,      ONLY : i4k, r8k
    USE vtk_datasets,   ONLY : struct_pts
    USE vtk_attributes, ONLY : scalar, attributes
    USE vtk,            ONLY : vtk_serial_write
    IMPLICIT NONE
    !! author: Ian Porter
    !! date: 12/28/2017
    !!
    !! This is a test of a rectangular_prism geometry using structured points
    !!
    INTEGER(i4k), PARAMETER     :: n_params_to_write = 3
    TYPE (struct_pts)           :: rectangular_prism
    TYPE (attributes), DIMENSION(n_params_to_write) :: vals_to_write
    INTEGER(i4k)                :: i = 0_i4k
    INTEGER(i4k),     PARAMETER :: n_x = 11, n_y = 6, n_z = 3, unit = 20
    REAL(r8k)                   :: j = 0.0_r8k
    REAL(r8k),        PARAMETER :: temp_val = 555.0_r8k
    CHARACTER(LEN=*), PARAMETER :: filename = 'rectangular_prism'
    CHARACTER(LEN=*), PARAMETER :: title    = 'Testing of rectangular_prism geometry'
    INTEGER(i4k), DIMENSION(3)  :: dims
    REAL(r8k), DIMENSION(3), PARAMETER :: origin  = &
      & [ 0.0_r8k, 0.0_r8k, 0.0_r8k ]
    REAL(r8k), DIMENSION(3), PARAMETER :: spacing = &
      & [ 0.3_r8k, 0.2_r8k, 0.1_r8k ]
    REAL(r8k), DIMENSION(n_x*n_y*n_z,1:n_params_to_write) :: vals
    CHARACTER(LEN=20), DIMENSION(n_params_to_write), PARAMETER :: dataname = &
      & [ 'Temperature_(K)     ', 'Pressure_(Pa)       ', 'Stress_(Pa)         ' ]

    vals(1,:) = temp_val
    DO i = 2, SIZE(vals,DIM=1)
        IF (i <= SIZE(vals) / 2) THEN
            vals(i,1) = vals(i-1,1) + 2.0_r8k          !! Temperature
        ELSE
            vals(i,1) = vals(i-1,1) - 2.0_r8k          !! Temperature
        END IF
        j = j + 1.0_r8k
        vals(i,2) = vals(i-1,2) + MAX(50.0_r8k, j)     !! Pressure
        vals(i,3) = vals(i-1,3) + SQRT(REAL(i))        !! Stress
    END DO
    dims = [ n_x, n_y, n_z ]
    CALL rectangular_prism%init (dims=dims, origin=origin, spacing=spacing)
    DO i = 1, n_params_to_write
        IF (.NOT. ALLOCATED(vals_to_write(i)%attribute))THEN
            ALLOCATE(scalar::vals_to_write(i)%attribute)
        END IF
        CALL vals_to_write(i)%attribute%init (TRIM(dataname(i)), numcomp=1, real1d=vals(:,i))
    END DO

    CALL vtk_serial_write (rectangular_prism, pointdatasets=vals_to_write, unit=unit, filename=filename, title=title)

    WRITE(*,*) 'Finished'

END PROGRAM rectangular_prism_test


! { dg-do run }
! PR 17074
! Verifies that FORALL and WHERE after a simple if work.
DIMENSION ia(4,4)
logical,dimension(4,4) :: index

if (.true.) forall (i = 1:4, j = 1:4) ia(i,j) = 1
if (any (ia.ne.1)) CALL abort()

index(:,:)=.false.
index(2,3) = .true.

if (.true.) where (index) ia = 2
if (ia(2,3).ne.2) call abort()

end


module rotation_module

  use math_module, only: cross_product
  use rotation_frequency_module, only: get_omega, get_domegadt
  use meth_params_module, only: rotation_include_centrifugal, rotation_include_coriolis, &
                                rotation_include_domegadt

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  private

  public inertial_to_rotational_velocity, rotational_acceleration, rotational_potential

contains

  ! Given a velocity vector in the inertial frame, transform it to a
  ! velocity vector in the rotating frame.

  subroutine inertial_to_rotational_velocity(idx, time, v, idir)

    use prob_params_module, only: center
    use castro_util_module, only: position

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer, intent(in) :: idx(3)
    real(rt)        , intent(in   ) :: time
    real(rt)        , intent(inout) :: v(3)
    integer, intent(in), optional :: idir

    real(rt)         :: loc(3), omega(3)

    if (present(idir)) then
       if (idir .eq. 1) then
          loc = position(idx(1),idx(2),idx(3),ccx=.false.) - center
       else if (idir .eq. 2) then
          loc = position(idx(1),idx(2),idx(3),ccy=.false.) - center
       else if (idir .eq. 3) then
          loc = position(idx(1),idx(2),idx(3),ccz=.false.) - center
       else
          call bl_error("Error: unknown direction in inertial_to_rotational_velocity.")
       endif
    else
       loc = position(idx(1),idx(2),idx(3)) - center
    endif

    omega = get_omega(time)

    v = v - cross_product(omega, loc)

  end subroutine inertial_to_rotational_velocity

  ! Given a position and velocity, calculate
  ! the rotational acceleration. This is the sum of:
  ! the Coriolis force (-2 omega x v),
  ! the centrifugal force (- omega x ( omega x r)),
  ! and a changing rotation rate (-d(omega)/dt x r).

  function rotational_acceleration(r, v, time, centrifugal, coriolis, domegadt) result(Sr)

    use bl_constants_module, only: ZERO, TWO
    use meth_params_module, only: state_in_rotating_frame

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    real(rt)         :: r(3), v(3), time
    real(rt)         :: Sr(3)

    real(rt)         :: omega(3), domega_dt(3), omegacrossr(3), omegacrossv(3)

    logical, optional :: centrifugal, coriolis, domegadt
    logical :: c1, c2, c3

    omega = get_omega(time)

    if (state_in_rotating_frame .eq. 1) then

       ! Allow the various terms to be turned off.
       ! This is often used for diagnostic purposes,
       ! but there are genuine science cases for
       ! disabling certain terms in some cases (in
       ! particular, when obtaining a system in
       ! rotational equilibrium through a relaxation
       ! process involving damping or sponging, one
       ! may want to turn off the Coriolis force
       ! during the relaxation process, on the
       ! basis that the true equilibrium state
       ! will have zero velocity anyway).

       if (rotation_include_centrifugal == 1) then
          c1 = .true.
       else
          c1 = .false.
       endif

       if (present(centrifugal)) then
          if (.not. centrifugal) c1 = .false.
       endif

       if (rotation_include_coriolis == 1) then
          c2 = .true.
       else
          c2 = .false.
       endif

       if (present(coriolis)) then
          if (.not. coriolis) c2 = .false.
       endif

       if (rotation_include_domegadt == 1) then
          c3 = .true.
       else
          c3 = .false.
       endif

       if (present(domegadt)) then
          if (.not. domegadt) c3 = .false.
       endif

       domega_dt = get_domegadt(time)

       omegacrossr = cross_product(omega,r)
       omegacrossv = cross_product(omega,v)

       Sr = ZERO

       if (c1) then
          Sr = Sr - cross_product(omega, omegacrossr)
       endif

       if (c2) then
          Sr = Sr - TWO * omegacrossv
       endif

       if (c3) then
          Sr = Sr - cross_product(domega_dt, r)
       endif

    else

       ! The source term for the momenta when we're not measuring
       ! state variables in the rotating frame is not strictly the
       ! traditional Coriolis force, but we'll still allow it to
       ! be disabled with the same parameter.

       if (rotation_include_coriolis == 1) then
          c2 = .true.
       else
          c2 = .false.
       endif

       if (present(coriolis)) then
          if (.not. coriolis) c2 = .false.
       endif

       Sr = ZERO

       if (c2) then
          Sr = Sr - cross_product(omega, v)
       endif

    endif

  end function rotational_acceleration

  ! Construct rotational potential, phi_R = -1/2 | omega x r |**2

  function rotational_potential(r, time) result(phi)

    use bl_constants_module, only: ZERO, HALF
    use meth_params_module, only: state_in_rotating_frame, rotation_include_centrifugal

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    real(rt)         :: r(3), time
    real(rt)         :: phi

    real(rt)         :: omega(3), omegacrossr(3)

    if (state_in_rotating_frame .eq. 1) then

       omega = get_omega(time)

       phi = ZERO

       if (rotation_include_centrifugal == 1) then

          omegacrossr = cross_product(omega, r)

          phi = phi - HALF * dot_product(omegacrossr,omegacrossr)

       endif

    else

       phi = ZERO

    endif

  end function rotational_potential

  subroutine ca_fill_rotational_potential(lo,hi,phi,phi_lo,phi_hi,dx,time) &
       bind(C, name="ca_fill_rotational_potential")

    use prob_params_module, only: problo, center
    use bl_constants_module, only: HALF

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer         , intent(in   ) :: lo(3), hi(3)
    integer         , intent(in   ) :: phi_lo(3), phi_hi(3)

    real(rt)        , intent(inout) :: phi(phi_lo(1):phi_hi(1),phi_lo(2):phi_hi(2),phi_lo(3):phi_hi(3))
    real(rt)        , intent(in   ) :: dx(3), time

    integer          :: i, j, k
    real(rt)         :: r(3)

    do k = lo(3), hi(3)
       r(3) = problo(3) + dx(3)*(dble(k)+HALF) - center(3)

       do j = lo(2), hi(2)
          r(2) = problo(2) + dx(2)*(dble(j)+HALF) - center(2)

          do i = lo(1), hi(1)
             r(1) = problo(1) + dx(1)*(dble(i)+HALF) - center(1)

             phi(i,j,k) = rotational_potential(r,time)

          enddo
       enddo
    enddo

  end subroutine ca_fill_rotational_potential

  subroutine ca_fill_rotational_acceleration(lo,hi,rot,rot_lo,rot_hi,state,state_lo,state_hi,dx,time) &
       bind(C, name="ca_fill_rotational_acceleration")

    use meth_params_module, only: NVAR, URHO, UMX, UMZ
    use prob_params_module, only: problo, center
    use bl_constants_module, only: HALF

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer         , intent(in   ) :: lo(3), hi(3)
    integer         , intent(in   ) :: rot_lo(3), rot_hi(3)
    integer         , intent(in   ) :: state_lo(3), state_hi(3)

    real(rt)        , intent(inout) :: rot(rot_lo(1):rot_hi(1),rot_lo(2):rot_hi(2),rot_lo(3):rot_hi(3),3)
    real(rt)        , intent(in   ) :: state(state_lo(1):state_hi(1),state_lo(2):state_hi(2),state_lo(3):state_hi(3),NVAR)
    real(rt)        , intent(in   ) :: dx(3), time

    integer          :: i, j, k
    real(rt)         :: r(3)

    do k = lo(3), hi(3)
       r(3) = problo(3) + dx(3)*(dble(k)+HALF) - center(3)

       do j = lo(2), hi(2)
          r(2) = problo(2) + dx(2)*(dble(j)+HALF) - center(2)

          do i = lo(1), hi(1)
             r(1) = problo(1) + dx(1)*(dble(i)+HALF) - center(1)

             rot(i,j,k,:) = rotational_acceleration(r, state(i,j,k,UMX:UMZ) / state(i,j,k,URHO), time)

          enddo
       enddo
    enddo

  end subroutine ca_fill_rotational_acceleration

end module rotation_module


!  *******************************************************************
!  *                                                                 *
!  *                       subroutine daxpy                          *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 03/11/78 1.01
!  Written by Jack Dongarra, Linpack
!  Modified by Gordon A. Fenton, Aug. 1993
!  Latest Update: Jun 9, 1999
!
!  PURPOSE    forms the dot product of two vectors.
!
!
!  REVISION HISTORY:
!  1.01	replaced dummy dimensions with a (*) for GNU's compiler (Jun 9/99)
!-------------------------------------------------------------------------
      real*8 function ddot(n,dx,dy)
      real*8 dx(*),dy(*), zero
      integer i, n
      data zero/0.d0/

      ddot = zero
      if( n .le. 0 ) return

      do 10 i = 1, n
         ddot = ddot + dx(i)*dy(i)
  10  continue

      return
      end


      double precision function vddot (n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      vddot = 0.0d0
      dtemp = 0.0d0
      if (n.le.0) return
      if (incx.eq.1.and.incy.eq.1) goto 20
c
c     code for unequal increments or equal increments not equal to 1
c
      ix = 1
      iy = 1
      if (incx.lt.0) ix = (-n+1)*incx + 1
      if (incy.lt.0) iy = (-n+1)*incy + 1
      do i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
      enddo
      vddot = dtemp
      return
c
c     code for both increments equal to 1
c
c
c     clean-up loop
c
   20 m = mod(n,5)
      if ( m .eq. 0 ) goto 40
      do i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
      enddo
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
      enddo
   60 vddot = dtemp
      end

      subroutine dgesl (a,lda,n,ipvt,b,job)
      integer lda,n,ipvt(*),job
      double precision a(lda,n),b(*)
c
c     dgesl solves the double precision system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgeco or dgefa.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output from dgeco or dgefa.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        ipvt    integer(n)
c                the pivot vector from dgeco or dgefa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b  where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgeco has set rcond .gt. 0.0
c        or dgefa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgeco(a,lda,n,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgesl(a,lda,n,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas vdaxpy,vddot
c
c     internal variables
c
      double precision vddot,t
      integer k,kb,l,nm1
c
      nm1 = n - 1
      if (job .ne. 0) goto 50
c
c        job = 0 , solve  a * x = b
c        first solve  l*y = b
c
         if (nm1 .lt. 1) goto 30
         do k = 1, nm1
            l = ipvt(k)
            t = b(l)
            if (l .eq. k) goto 10
               b(l) = b(k)
               b(k) = t
   10       continue
c            call vdaxpy(n-k,t,a(k+1,k),1,b(k+1),1)
            call ccse_daxpy(n-k,t,a(k+1,k),b(k+1))
         enddo
   30    continue
c
c        now solve  u*x = y
c
         do kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
c            call vdaxpy(k-1,t,a(1,k),1,b(1),1)
            call ccse_daxpy(k-1,t,a(1,k),b(1))
         enddo
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do k = 1, n
            t = vddot(k-1,a(1,k),1,b(1),1)
            b(k) = (b(k) - t)/a(k,k)
         enddo
c
c        now solve trans(l)*x = y
c
         if (nm1 .lt. 1) goto 90
         do kb = 1, nm1
            k = n - kb
            b(k) = b(k) + vddot(n-k,a(k+1,k),1,b(k+1),1)
            l = ipvt(k)
            if (l .eq. k) go to 70
               t = b(l)
               b(l) = b(k)
               b(k) = t
   70       continue
         enddo
   90    continue
  100 continue
      end

      subroutine dgbsl (abd,lda,n,ml,mu,ipvt,b,job)
      integer lda,n,ml,mu,ipvt(*),job
      double precision abd(lda,*),b(*)
c
c     dgbsl solves the double precision band system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgbco or dgbfa.
c
c     on entry
c
c        abd     double precision(lda, n)
c                the output from dgbco or dgbfa.
c
c        lda     integer
c                the leading dimension of the array  abd .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c
c        mu      integer
c                number of diagonals above the main diagonal.
c
c        ipvt    integer(n)
c                the pivot vector from dgbco or dgbfa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b , where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgbco has set rcond .gt. 0.0
c        or dgbfa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas vdaxpy,vddot
c     fortran min0
c
c     internal variables
c
      double precision vddot,t
      integer k,kb,l,la,lb,lm,m,nm1
c
      m = mu + ml + 1
      nm1 = n - 1
      if (job .ne. 0) goto 50
c
c        job = 0 , solve  a * x = b
c        first solve l*y = b
c
         if (ml .eq. 0) goto 30
         if (nm1 .lt. 1) goto 30
            do k = 1, nm1
               lm = min0(ml,n-k)
               l = ipvt(k)
               t = b(l)
               if (l .eq. k) goto 10
                  b(l) = b(k)
                  b(k) = t
   10          continue
c               call vdaxpy(lm,t,abd(m+1,k),1,b(k+1),1)
               call ccse_daxpy(lm,t,abd(m+1,k),b(k+1))
            enddo
   30    continue
c
c        now solve  u*x = y
c
         do kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/abd(m,k)
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = -b(k)
c            call vdaxpy(lm,t,abd(la,k),1,b(lb),1)
            call ccse_daxpy(lm,t,abd(la,k),b(lb))
         enddo
      goto 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do k = 1, n
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = vddot(lm,abd(la,k),1,b(lb),1)
            b(k) = (b(k) - t)/abd(m,k)
         enddo
c
c        now solve trans(l)*x = y
c
         if (ml .eq. 0) goto 90
         if (nm1 .lt. 1) goto 90
            do kb = 1, nm1
               k = n - kb
               lm = min0(ml,n-k)
               b(k) = b(k) + vddot(lm,abd(m+1,k),1,b(k+1),1)
               l = ipvt(k)
               if (l .eq. k) goto 70
                  t = b(l)
                  b(l) = b(k)
                  b(k) = t
   70          continue
            enddo
   90    continue
  100 continue
      end

      subroutine dgbfa (abd,lda,n,ml,mu,ipvt,info)
      integer lda,n,ml,mu,ipvt(*),info
      double precision abd(lda,*)
c
c     dgbfa factors a double precision band matrix by elimination.
c
c     dgbfa is usually called by dgbco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c
c     on entry
c
c        abd     double precision(lda, n)
c                contains the matrix in band storage.  the columns
c                of the matrix are stored in the columns of  abd  and
c                the diagonals of the matrix are stored in rows
c                ml+1 through 2*ml+mu+1 of  abd .
c                see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. 2*ml + mu + 1 .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c                0 .le. ml .lt. n .
c
c        mu      integer
c                number of diagonals above the main diagonal.
c                0 .le. mu .lt. n .
c                more efficient if  ml .le. mu .
c     on return
c
c        abd     an upper triangular matrix in band storage and
c                the multipliers which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgbsl will divide by zero if
c                     called.  use  rcond  in dgbco for a reliable
c                     indication of singularity.
c
c     band storage
c
c           if  a  is a band matrix, the following program segment
c           will set up the input.
c
c                   ml = (band width below the diagonal)
c                   mu = (band width above the diagonal)
c                   m = ml + mu + 1
c                   do 20 j = 1, n
c                      i1 = max0(1, j-mu)
c                      i2 = min0(n, j+ml)
c                      do 10 i = i1, i2
c                         k = i - j + m
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
c           in addition, the first  ml  rows in  abd  are used for
c           elements generated during the triangularization.
c           the total number of rows needed in  abd  is  2*ml+mu+1 .
c           the  ml+mu by ml+mu  upper left triangle and the
c           ml by ml  lower right triangle are not referenced.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas vdaxpy,dscal,idamax
c     fortran max0,min0
c
c     internal variables
c
      double precision t
      integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1
c
c
      m = ml + mu + 1
      info = 0
c
c     zero initial fill-in columns
c
      j0 = mu + 2
      j1 = min0(n,m) - 1
      if (j1 .lt. j0) goto 30
      do jz = j0, j1
         i0 = m + 1 - jz
         do i = i0, ml
            abd(i,jz) = 0.0d0
         enddo
      enddo
   30 continue
      jz = j1
      ju = 0
c
c     gaussian elimination with partial pivoting
c
      nm1 = n - 1
      if (nm1 .lt. 1) goto 130
      do k = 1, nm1
         kp1 = k + 1
c
c        zero next fill-in column
c
         jz = jz + 1
         if (jz .gt. n) goto 50
         if (ml .lt. 1) goto 50
            do i = 1, ml
               abd(i,jz) = 0.0d0
            enddo
   50    continue
c
c        find l = pivot index
c
         lm = min0(ml,n-k)
         l = idamax(lm+1,abd(m,k),1) + m - 1
         ipvt(k) = l + k - m
c
c        zero pivot implies this column already triangularized
c
         if (abd(l,k) .eq. 0.0d0) goto 100
c
c           interchange if necessary
c
            if (l .eq. m) goto 60
               t = abd(l,k)
               abd(l,k) = abd(m,k)
               abd(m,k) = t
   60       continue
c
c           compute multipliers
c
            t = -1.0d0/abd(m,k)
            call dscal(lm,t,abd(m+1,k),1)
c
c           row elimination with column indexing
c
            ju = min0(max0(ju,mu+ipvt(k)),n)
            mm = m
            if (ju .lt. kp1) goto 90
            do j = kp1, ju
               l = l - 1
               mm = mm - 1
               t = abd(l,j)
               if (l .eq. mm) goto 70
                  abd(l,j) = abd(mm,j)
                  abd(mm,j) = t
   70          continue
c               call vdaxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1)
               call ccse_daxpy(lm,t,abd(m+1,k),abd(mm+1,j))
            enddo
   90       continue
         goto 110
  100    continue
            info = k
  110    continue
      enddo
  130 continue
      ipvt(n) = n
      if (abd(m,n) .eq. 0.0d0) info = n
      end

      subroutine dgefa (a,lda,n,ipvt,info)
      integer lda,n,ipvt(*),info
      double precision a(lda,*)
c
c     dgefa factors a double precision matrix by gaussian elimination.
c
c     dgefa is usually called by dgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgesl or dgedi will divide by zero
c                     if called.  use  rcond  in dgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas vdaxpy,dscal,idamax
c
c     internal variables
c
      double precision t
      integer idamax,j,k,kp1,l,nm1
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) goto 70
      do k = 1, nm1
         kp1 = k + 1
c
c        find l = pivot index
c
         l = idamax(n-k+1,a(k,k),1) + k - 1
         ipvt(k) = l
c
c        zero pivot implies this column already triangularized
c
         if (a(l,k) .eq. 0.0d0) goto 40
c
c           interchange if necessary
c
            if (l .eq. k) goto 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
c
c           compute multipliers
c
            t = -1.0d0/a(k,k)
            call dscal(n-k,t,a(k+1,k),1)
c
c           row elimination with column indexing
c
            do j = kp1, n
               t = a(l,j)
               if (l .eq. k) goto 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
c               call vdaxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
               call ccse_daxpy(n-k,t,a(k+1,k),a(k+1,j))
            enddo
         goto 50
   40    continue
            info = k
   50    continue
      enddo
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0d0) info = n
      end

      subroutine ccse_daxpy (n,da,dx,dy)
      double precision dx(*),dy(*),da
      integer n, i
      do i=1,n
         dy(i) = dy(i) + da*dx(i)
      enddo
      end


C     ----------------------------------------------------------------
C     $Revision: 4298 $
C     $Date: 2014-12-17 13:34:18 -0800 (Wed, 17 Dec 2014) $
C     ----------------------------------------------------------------
C     FCVODE Example Problem: 2D kinetics-transport, precond. Krylov
C     solver.
C
C     An ODE system is generated from the following 2-species diurnal
C     kinetics advection-diffusion PDE system in 2 space dimensions:
C
C     dc(i)/dt = Kh*(d/dx)**2 c(i) + V*dc(i)/dx + (d/dy)(Kv(y)*dc(i)/dy)
C                           + Ri(c1,c2,t)      for i = 1,2,   where
C     R1(c1,c2,t) = -q1*c1*c3 - q2*c1*c2 + 2*q3(t)*c3 + q4(t)*c2 ,
C     R2(c1,c2,t) =  q1*c1*c3 - q2*c1*c2 - q4(t)*c2 ,
C     Kv(y) = Kv0*exp(y/5) ,
C     Kh, V, Kv0, q1, q2, and c3 are constants, and q3(t) and q4(t)
C     vary diurnally.
C
C     The problem is posed on the square
C     0 .le. x .le. 20,    30 .le. y .le. 50   (all in km),
C     with homogeneous Neumann boundary conditions, and for time t
C     in 0 .le. t .le. 86400 sec (1 day).
C     The PDE system is treated by central differences on a uniform
C     10 x 10 mesh, with simple polynomial initial profiles.
C     The problem is solved with CVODE, with the BDF/GMRES method and
C     the block-diagonal part of the Jacobian as a left
C     preconditioner.
C
C     Note: this program requires the dense linear solver routines
C     DGEFA and DGESL from LINPACK, and BLAS routines DCOPY and DSCAL.
C
C     The second and third dimensions of U here must match the values
C     of MX and MY, for consistency with the output statements
C     below.
C     ----------------------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER MX, MY
      PARAMETER (MX=10, MY=10)
      INTEGER LENIPAR, LENRPAR
      PARAMETER (LENIPAR=6+2*MX*MY, LENRPAR=12+8*MX*MY)
C
      INTEGER METH,ITMETH,IATOL,ITASK,IER,LNCFL,LNPS
      INTEGER LNST,LNFE,LNSETUP,LNNI,LNCF,LQ,LH,LNPE,LNLI,LNETF
      INTEGER JOUT,JPRETYPE,IGSTYPE,MAXL
C The following declaration specification should match C type long int.
      INTEGER*8 NEQ, IOUT(25), IPAR(LENIPAR)
      INTEGER NST,NFE,NPSET,NPE,NPS,NNI,NETF
      INTEGER NLI,NCFN,NCFL
      DOUBLE PRECISION ATOL,AVDIM,T,TOUT,TWOHR,RTOL,FLOOR,DELT
      DOUBLE PRECISION U(2,MX,MY),ROUT(10),RPAR(LENRPAR)
C
      DATA TWOHR/7200.0D0/, RTOL/1.0D-5/, FLOOR/100.0D0/,
     &     JPRETYPE/1/, IGSTYPE/1/, MAXL/0/, DELT/0.0D0/
      DATA LNST/3/, LNFE/4/, LNETF/5/,  LNCF/6/, LNNI/7/, LNSETUP/8/,
     &     LQ/9/, LNPE/18/, LNLI/20/, LNPS/19/, LNCFL/21/
      DATA LH/2/
C
C     Load problem constants into IPAR, RPAR, and set initial values
      CALL INITKX(MX, MY, U, IPAR, RPAR)
C
C     Set other input arguments.
      NEQ = 2*MX*MY
      T = 0.0D0
      METH = 2
      ITMETH = 2
      IATOL = 1
      ATOL = RTOL * FLOOR
      ITASK = 1
C
      WRITE(6,10) NEQ
 10   FORMAT('Krylov example problem:'//
     &       ' Kinetics-transport, NEQ = ', I4/)
C
      CALL FNVINITS(1, NEQ, IER)
      IF (IER .NE. 0) THEN
        WRITE(6,20) IER
 20     FORMAT(///' SUNDIALS_ERROR: FNVINITS returned IER = ', I5)
        STOP
      ENDIF
C
C     Initialize CVODE
      CALL FCVMALLOC(T, U, METH, ITMETH, IATOL, RTOL, ATOL,
     &     IOUT, ROUT, IPAR, RPAR, IER)
      IF (IER .NE. 0) THEN
        WRITE(6,30) IER
 30     FORMAT(///' SUNDIALS_ERROR: FCVMALLOC returned IER = ', I5)
        STOP
        ENDIF
C
      CALL FCVSPGMR(JPRETYPE, IGSTYPE, MAXL, DELT, IER)
      IF (IER .NE. 0) THEN
        WRITE(6,40) IER
 40     FORMAT(///' SUNDIALS_ERROR: FCVSPGMR returned IER = ', I5)
        CALL FCVFREE
        STOP
      ENDIF
C
      CALL FCVSPILSSETPREC(1, IER)
C
C Loop over output points, call FCVODE, print sample solution values.
      TOUT = TWOHR
      DO JOUT = 1, 12
C
         CALL FCVODE(TOUT, T, U, ITASK, IER)
C
         WRITE(6,50) T, IOUT(LNST), IOUT(LQ), ROUT(LH)
 50      FORMAT(/' t = ', E11.3, 3X, 'nst = ', I5,
     &           '  q = ', I2, '  h = ', E14.6)
         WRITE(6,55) U(1,1,1), U(1,5,5), U(1,10,10),
     &               U(2,1,1), U(2,5,5), U(2,10,10)
 55      FORMAT('  c1 (bot.left/middle/top rt.) = ', 3E14.6/
     &          '  c2 (bot.left/middle/top rt.) = ', 3E14.6)
C
         IF (IER .NE. 0) THEN
            WRITE(6,60) IER, IOUT(15)
 60         FORMAT(///' SUNDIALS_ERROR: FCVODE returned IER = ', I5, /,
     &           '                 Linear Solver returned IER = ', I5)
            CALL FCVFREE
            STOP
         ENDIF
C
         TOUT = TOUT + TWOHR
C
      ENDDO

C     Print final statistics.
      NST = IOUT(LNST)
      NFE = IOUT(LNFE)
      NPSET = IOUT(LNSETUP)
      NPE = IOUT(LNPE)
      NPS = IOUT(LNPS)
      NNI = IOUT(LNNI)
      NLI = IOUT(LNLI)
      AVDIM = DBLE(NLI) / DBLE(NNI)
      NCFN = IOUT(LNCF)
      NCFL = IOUT(LNCFL)
      NETF = IOUT(LNETF)
      WRITE(6,80) NST, NFE, NPSET, NPE, NPS, NNI, NLI, AVDIM, NCFN,
     &     NCFL, NETF
  80  FORMAT(//'Final statistics:'//
     &     ' number of steps        = ', I5, 5X,
     &     ' number of f evals.     =', I5/
     &     ' number of prec. setups = ', I5/
     &     ' number of prec. evals. = ', I5, 5X,
     &     ' number of prec. solves = ', I5/
     &     ' number of nonl. iters. = ', I5, 5X,
     &     ' number of lin. iters.  = ', I5/
     &     ' average Krylov subspace dimension (NLI/NNI)  = ', E14.6/
     &     ' number of conv. failures.. nonlinear = ', I3,
     &     ' linear = ', I3/
     &     ' number of error test failures = ', I3)
C
      CALL FCVFREE
C
      STOP
      END

C     ----------------------------------------------------------------

      SUBROUTINE INITKX(MX, MY, U0, IPAR, RPAR)
C     Routine to set problem constants and initial values
C
      IMPLICIT NONE
C
      INTEGER MX, MY
C The following declaration specification should match C type long int.
      INTEGER*8 IPAR(*)
      DOUBLE PRECISION RPAR(*)
C
      INTEGER MM, JY, JX, P_IPP, P_BD, P_P
      DOUBLE PRECISION U0
      DIMENSION U0(2,MX,MY)
      DOUBLE PRECISION Q1, Q2, Q3, Q4, A3, A4, OM, C3, DY, HDCO
      DOUBLE PRECISION VDCO, HACO, X, Y
      DOUBLE PRECISION CX, CY, DKH, DKV0, DX, HALFDA, PI, VEL
C
      DATA DKH/4.0D-6/, VEL/0.001D0/, DKV0/1.0D-8/, HALFDA/4.32D4/,
     1     PI/3.1415926535898D0/
C
C     Problem constants
      MM = MX * MY
      Q1 = 1.63D-16
      Q2 = 4.66D-16
      Q3 = 0.0D0
      Q4 = 0.0D0
      A3 = 22.62D0
      A4 = 7.601D0
      OM = PI / HALFDA
      C3 = 3.7D16
      DX = 20.0D0 / (MX - 1.0D0)
      DY = 20.0D0 / (MY - 1.0D0)
      HDCO = DKH / DX**2
      HACO = VEL / (2.0D0 * DX)
      VDCO = (1.0D0 / DY**2) * DKV0
C
C     Load constants in IPAR and RPAR
      IPAR(1) = MX
      IPAR(2) = MY
      IPAR(3) = MM
C
      RPAR(1)  = Q1
      RPAR(2)  = Q2
      RPAR(3)  = Q3
      RPAR(4)  = Q4
      RPAR(5)  = A3
      RPAR(6)  = A4
      RPAR(7)  = OM
      RPAR(8)  = C3
      RPAR(9)  = DY
      RPAR(10) = HDCO
      RPAR(11) = VDCO
      RPAR(12) = HACO
C
C     Pointers into IPAR and RPAR
      P_IPP = 7
      P_BD  = 13
      P_P   = P_BD + 4*MM
C
      IPAR(4) = P_IPP
      IPAR(5) = P_BD
      IPAR(6) = P_P
C
C     Set initial profiles.
      DO JY = 1, MY
         Y = 30.0D0 + (JY - 1.0D0) * DY
         CY = (0.1D0 * (Y - 40.0D0))**2
         CY = 1.0D0 - CY + 0.5D0 * CY**2
         DO JX = 1, MX
            X = (JX - 1.0D0) * DX
            CX = (0.1D0 * (X - 10.0D0))**2
            CX = 1.0D0 - CX + 0.5D0 * CX**2
            U0(1,JX,JY) = 1.0D6 * CX * CY
            U0(2,JX,JY) = 1.0D12 * CX * CY
         ENDDO
      ENDDO
C
      RETURN
      END

C     ----------------------------------------------------------------

      SUBROUTINE FCVFUN(T, U, UDOT, IPAR, RPAR, IER)
C     Routine for right-hand side function f
C
      IMPLICIT NONE
C
      DOUBLE PRECISION T, U(2,*), UDOT(2,*), RPAR(*)
C The following declaration specification should match C type long int.
      INTEGER*8 IPAR(*)
      INTEGER IER
C
      INTEGER ILEFT, IRIGHT
      INTEGER JX, JY, MX, MY, MM, IBLOK0, IBLOK, IDN, IUP
      DOUBLE PRECISION Q1, Q2, Q3, Q4, A3, A4, OM, C3, DY, HDCO
      DOUBLE PRECISION VDCO, HACO
      DOUBLE PRECISION C1, C2, C1DN, C2DN, C1UP, C2UP, C1LT, C2LT
      DOUBLE PRECISION C1RT, C2RT, CYDN, CYUP, HORD1, HORD2, HORAD1
      DOUBLE PRECISION HORAD2, QQ1, QQ2, QQ3, QQ4, RKIN1, RKIN2, S
      DOUBLE PRECISION VERTD1, VERTD2, YDN, YUP
C
C     Extract constants from IPAR and RPAR
      MX = IPAR(1)
      MY = IPAR(2)
      MM = IPAR(3)
C
      Q1 = RPAR(1)
      Q2 = RPAR(2)
      Q3 = RPAR(3)
      Q4 = RPAR(4)
      A3 = RPAR(5)
      A4 = RPAR(6)
      OM = RPAR(7)
      C3 = RPAR(8)
      DY = RPAR(9)
      HDCO = RPAR(10)
      VDCO = RPAR(11)
      HACO = RPAR(12)
C
C     Set diurnal rate coefficients.
      S = SIN(OM * T)
      IF (S .GT. 0.0D0) THEN
         Q3 = EXP(-A3 / S)
         Q4 = EXP(-A4 / S)
      ELSE
         Q3 = 0.0D0
         Q4 = 0.0D0
      ENDIF
      RPAR(3) = Q3
      RPAR(4) = Q4
C
C     Loop over all grid points.
      DO JY = 1, MY
         YDN = 30.0D0 + (JY - 1.5D0) * DY
         YUP = YDN + DY
         CYDN = VDCO * EXP(0.2D0 * YDN)
         CYUP = VDCO * EXP(0.2D0 * YUP)
         IBLOK0 = (JY - 1) * MX
         IDN = -MX
         IF (JY .EQ. 1) IDN = MX
         IUP = MX
         IF (JY .EQ. MY) IUP = -MX
         DO JX = 1, MX
            IBLOK = IBLOK0 + JX
            C1 = U(1,IBLOK)
            C2 = U(2,IBLOK)
C     Set kinetic rate terms.
            QQ1 = Q1 * C1 * C3
            QQ2 = Q2 * C1 * C2
            QQ3 = Q3 * C3
            QQ4 = Q4 * C2
            RKIN1 = -QQ1 - QQ2 + 2.0D0 * QQ3 + QQ4
            RKIN2 = QQ1 - QQ2 - QQ4
C     Set vertical diffusion terms.
            C1DN = U(1,IBLOK + IDN)
            C2DN = U(2,IBLOK + IDN)
            C1UP = U(1,IBLOK + IUP)
            C2UP = U(2,IBLOK + IUP)
            VERTD1 = CYUP * (C1UP - C1) - CYDN * (C1 - C1DN)
            VERTD2 = CYUP * (C2UP - C2) - CYDN * (C2 - C2DN)
C     Set horizontal diffusion and advection terms.
            ILEFT = -1
            IF (JX .EQ. 1) ILEFT = 1
            IRIGHT = 1
            IF (JX .EQ. MX) IRIGHT = -1
            C1LT = U(1,IBLOK + ILEFT)
            C2LT = U(2,IBLOK + ILEFT)
            C1RT = U(1,IBLOK + IRIGHT)
            C2RT = U(2,IBLOK + IRIGHT)
            HORD1 = HDCO * (C1RT - 2.0D0 * C1 + C1LT)
            HORD2 = HDCO * (C2RT - 2.0D0 * C2 + C2LT)
            HORAD1 = HACO * (C1RT - C1LT)
            HORAD2 = HACO * (C2RT - C2LT)
C     Load all terms into UDOT.
            UDOT(1,IBLOK) = VERTD1 + HORD1 + HORAD1 + RKIN1
            UDOT(2,IBLOK) = VERTD2 + HORD2 + HORAD2 + RKIN2
         ENDDO
      ENDDO
C
      IER = 0
C
      RETURN
      END

C     ----------------------------------------------------------------

      SUBROUTINE FCVPSET(T, U, FU, JOK, JCUR, GAMMA, H,
     &                   IPAR, RPAR, V1, V2, V3, IER)
C     Routine to set and preprocess block-diagonal preconditioner.
C     Note: The dimensions in /BDJ/ below assume at most 100 mesh points.
C
      IMPLICIT NONE
C
      INTEGER IER, JOK, JCUR
      DOUBLE PRECISION T, U(2,*), FU(*), GAMMA, H
C The following declaration specification should match C type long int.
      INTEGER*8 IPAR(*)
      DOUBLE PRECISION RPAR(*), V1(*), V2(*), V3(*)
C
      INTEGER MX, MY, MM, P_IPP, P_BD, P_P
      DOUBLE PRECISION Q1, Q2, Q3, Q4, C3, DY, HDCO, VDCO
C
      IER = 0
C
C     Extract constants from IPAR and RPAR
      MX = IPAR(1)
      MY = IPAR(2)
      MM = IPAR(3)
C
      Q1 = RPAR(1)
      Q2 = RPAR(2)
      Q3 = RPAR(3)
      Q4 = RPAR(4)
      C3 = RPAR(8)
      DY = RPAR(9)
      HDCO = RPAR(10)
      VDCO = RPAR(11)
C
C     Extract pointers into IPAR and RPAR
      P_IPP = IPAR(4)
      P_BD  = IPAR(5)
      P_P   = IPAR(6)
C
C     If needed, recompute BD
C
      IF (JOK .EQ. 1) THEN
C     JOK = 1. Reuse saved BD
        JCUR = 0
      ELSE
C     JOK = 0. Compute diagonal Jacobian blocks.
C     (using q4 value computed on last FCVFUN call).
         CALL PREC_JAC(MX, MY, MM, U, RPAR(P_BD),
     &        Q1, Q2, Q3, Q4, C3, DY, HDCO, VDCO)
         JCUR = 1
      ENDIF
C
C     Copy BD to P
      CALL DCOPY(4*MM, RPAR(P_BD), 1, RPAR(P_P), 1)
C
C     Scale P by -GAMMA
      CALL DSCAL(4*MM, -GAMMA, RPAR(P_P), 1)
C
C     Perform LU decomposition
      CALL PREC_LU(MM, RPAR(P_P), IPAR(P_IPP), IER)
C
      RETURN
      END

C     ----------------------------------------------------------------

      SUBROUTINE FCVPSOL(T, U, FU, R, Z, GAMMA, DELTA, LR,
     &                   IPAR, RPAR, VTEMP, IER)
C     Routine to solve preconditioner linear system.
C
      IMPLICIT NONE
C
      INTEGER IER, LR
C The following declaration specification should match C type long int.
      INTEGER*8 IPAR(*)
      DOUBLE PRECISION T, U(*), FU(*), R(*), Z(2,*)
      DOUBLE PRECISION GAMMA, DELTA, RPAR(*)
      DOUBLE PRECISION VTEMP(*)
C
      INTEGER MM, P_IPP, P_P
C
      IER = 0
C
C     Extract constants from IPAR and RPAR
      MM  = IPAR(3)
C
C     Extract pointers into IPAR and RPAR
      P_IPP = IPAR(4)
      P_P   = IPAR(6)
C
C     Copy RHS into Z
      CALL DCOPY(2*MM, R, 1, Z, 1)
C
C     Solve the block-diagonal system Px = r using LU factors stored in P
C     and pivot data in IPP, and return the solution in Z.
      CALL PREC_SOL(MM, RPAR(P_P), IPAR(P_IPP), Z)

      RETURN
      END

C     ----------------------------------------------------------------

      SUBROUTINE PREC_JAC(MX, MY, MM, U, BD,
     &     Q1, Q2, Q3, Q4, C3, DY, HDCO, VDCO)
C     Routine to compute diagonal Jacobian blocks
C
      IMPLICIT NONE
C
      INTEGER MX, MY, MM
      DOUBLE PRECISION U(2,*), BD(2,2,MM)
      DOUBLE PRECISION Q1, Q2, Q3, Q4, C3, DY, HDCO, VDCO
C
      INTEGER JY, JX, IBLOK, IBLOK0
      DOUBLE PRECISION C1, C2, CYDN, CYUP, DIAG, YDN, YUP
C
      DO JY = 1, MY
         YDN = 30.0D0 + (JY - 1.5D0) * DY
         YUP = YDN + DY
         CYDN = VDCO * EXP(0.2D0 * YDN)
         CYUP = VDCO * EXP(0.2D0 * YUP)
         DIAG = -(CYDN + CYUP + 2.0D0 * HDCO)
         IBLOK0 = (JY - 1) * MX
         DO JX = 1, MX
            IBLOK = IBLOK0 + JX
            C1 = U(1,IBLOK)
            C2 = U(2,IBLOK)
            BD(1,1,IBLOK) = (-Q1 * C3 - Q2 * C2) + DIAG
            BD(1,2,IBLOK) = -Q2 * C1 + Q4
            BD(2,1,IBLOK) =  Q1 * C3 - Q2 * C2
            BD(2,2,IBLOK) = (-Q2 * C1 - Q4) + DIAG
         ENDDO
      ENDDO

      RETURN
      END

C     ----------------------------------------------------------------

      SUBROUTINE PREC_LU(MM, P, IPP, IER)
C     Routine to perform LU decomposition on (P+I)
C
      IMPLICIT NONE
C
      INTEGER IER
      INTEGER MM, IPP(2,MM)
      DOUBLE PRECISION P(2,2,MM)
C
      INTEGER I
C
C     Add identity matrix and do LU decompositions on blocks, in place.
      DO I = 1, MM
         P(1,1,I) = P(1,1,I) + 1.0D0
         P(2,2,I) = P(2,2,I) + 1.0D0
         CALL DGEFA(P(1,1,I), 2, 2, IPP(1,I), IER)
         IF (IER .NE. 0) RETURN
      ENDDO
C
      RETURN
      END

C     ----------------------------------------------------------------

      SUBROUTINE PREC_SOL(MM, P, IPP, Z)
C     Routine for backsolve
C
      IMPLICIT NONE
C
      INTEGER MM, IPP(2,MM)
      DOUBLE PRECISION P(2,2,MM), Z(2,MM)
C
      INTEGER I
C
      DO I = 1, MM
         CALL DGESL(P(1,1,I), 2, 2, IPP(1,I), Z(1,I), 0)
      ENDDO

      RETURN
      END

C     ----------------------------------------------------------------

      subroutine dgefa(a, lda, n, ipvt, info)
c
      implicit none
c
      integer info, idamax, j, k, kp1, l, nm1, n
      integer*4 lda, ipvt(1)
      double precision a(lda,1), t
c
c     dgefa factors a double precision matrix by gaussian elimination.
c
c     dgefa is usually called by dgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgesl or dgedi will divide by zero
c                     if called.  employ  rcond  in dgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
c
c     internal variables
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) go to 70
      do 60 k = 1, nm1
         kp1 = k + 1
c
c        find l = pivot index
c
         l = idamax(n - k + 1, a(k,k), 1) + k - 1
         ipvt(k) = l
c
c        zero pivot implies this column already triangularized
c
         if (a(l,k) .eq. 0.0d0) go to 40
c
c           interchange if necessary
c
            if (l .eq. k) go to 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
c
c           compute multipliers
c
            t = -1.0d0 / a(k,k)
            call dscal(n - k, t, a(k + 1,k), 1)
c
c           row elimination with column indexing
c
            do 30 j = kp1, n
               t = a(l,j)
               if (l .eq. k) go to 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
               call daxpy(n - k, t, a(k + 1,k), 1, a(k + 1,j), 1)
   30       continue
         go to 50
   40    continue
            info = k
   50    continue
   60 continue
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0d0) info = n
      return
      end

C     ----------------------------------------------------------------

      subroutine dgesl(a, lda, n, ipvt, b, job)
c
      implicit none
c
      integer lda, n, job, k, kb, l, nm1
      integer*4 ipvt(1)
      double precision a(lda,1), b(1), ddot, t
c
c     dgesl solves the double precision system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgeco or dgefa.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output from dgeco or dgefa.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        ipvt    integer(n)
c                the pivot vector from dgeco or dgefa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b  where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgeco has set rcond .gt. 0.0
c        or dgefa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgeco(a,lda,n,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgesl(a,lda,n,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c
c     internal variables
c
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve  l*y = b
c
         if (nm1 .lt. 1) go to 30
         do 20 k = 1, nm1
            l = ipvt(k)
            t = b(l)
            if (l .eq. k) go to 10
               b(l) = b(k)
               b(k) = t
   10       continue
            call daxpy(n - k, t, a(k + 1,k), 1, b(k + 1), 1)
   20    continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k) / a(k,k)
            t = -b(k)
            call daxpy(k - 1, t, a(1,k), 1, b(1), 1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            t = ddot(k - 1, a(1,k), 1, b(1), 1)
            b(k) = (b(k) - t) / a(k,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (nm1 .lt. 1) go to 90
         do 80 kb = 1, nm1
            k = n - kb
            b(k) = b(k) + ddot(n - k, a(k + 1,k), 1, b(k + 1), 1)
            l = ipvt(k)
            if (l .eq. k) go to 70
               t = b(l)
               b(l) = b(k)
               b(k) = t
   70       continue
   80    continue
   90    continue
  100 continue
      return
      end

C     ----------------------------------------------------------------

      subroutine daxpy(n, da, dx, incx, dy, incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      implicit none
c
      integer i, incx, incy, ix, iy, m, mp1
      integer*4 n
      double precision dx(1), dy(1), da
c
      if (n .le. 0) return
      if (da .eq. 0.0d0) return
      if (incx .eq. 1 .and. incy .eq. 1) go to 20
c
c        code for unequal increments or equal increments
c        not equal to 1
c
      ix = 1
      iy = 1
      if (incx .lt. 0) ix = (-n + 1) * incx + 1
      if (incy .lt. 0) iy = (-n + 1) * incy + 1
      do 10 i = 1, n
        dy(iy) = dy(iy) + da * dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n, 4)
      if ( m .eq. 0 ) go to 40
      do 30 i = 1, m
        dy(i) = dy(i) + da * dx(i)
   30 continue
      if ( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1, n, 4
        dy(i) = dy(i) + da * dx(i)
        dy(i + 1) = dy(i + 1) + da * dx(i + 1)
        dy(i + 2) = dy(i + 2) + da * dx(i + 2)
        dy(i + 3) = dy(i + 3) + da * dx(i + 3)
   50 continue
      return
      end
C     ----------------------------------------------------------------

      subroutine dscal(n, da, dx, incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      implicit none
c
      integer i, incx, m, mp1, nincx
      integer*4 n
      double precision da, dx(1)
c
      if (n.le.0) return
      if (incx .eq. 1) go to 20
c
c        code for increment not equal to 1
c
      nincx = n * incx
      do 10 i = 1, nincx, incx
        dx(i) = da * dx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n, 5)
      if ( m .eq. 0 ) go to 40
      do 30 i = 1, m
        dx(i) = da * dx(i)
   30 continue
      if ( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1, n, 5
        dx(i) = da * dx(i)
        dx(i + 1) = da * dx(i + 1)
        dx(i + 2) = da * dx(i + 2)
        dx(i + 3) = da * dx(i + 3)
        dx(i + 4) = da * dx(i + 4)
   50 continue
      return
      end

C     ----------------------------------------------------------------

      double precision function ddot(n, dx, incx, dy, incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      implicit none
c
      integer i, incx, incy, ix, iy, m, mp1
      integer*4 n
      double precision dx(1), dy(1), dtemp
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if (n .le. 0) return
      if (incx .eq. 1 .and. incy .eq. 1) go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if (incx .lt. 0) ix = (-n + 1) * incx + 1
      if (incy .lt. 0) iy = (-n + 1) * incy + 1
      do 10 i = 1, n
        dtemp = dtemp + dx(ix) * dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n, 5)
      if ( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i) * dy(i)
   30 continue
      if ( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1, n, 5
        dtemp = dtemp + dx(i) * dy(i) + dx(i + 1) * dy(i + 1) +
     *          dx(i + 2) * dy(i + 2) + dx(i + 3) * dy(i + 3) +
     *          dx(i + 4) * dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end

C     ----------------------------------------------------------------

      integer function idamax(n, dx, incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c
      implicit none
c
      integer i, incx, ix
      integer*4 n
      double precision dx(1), dmax
c
      idamax = 0
      if (n .lt. 1) return
      idamax = 1
      if (n .eq. 1) return
      if (incx .eq. 1) go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      dmax = abs(dx(1))
      ix = ix + incx
      do 10 i = 2, n
         if (abs(dx(ix)) .le. dmax) go to 5
         idamax = i
         dmax = abs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = abs(dx(1))
      do 30 i = 2, n
         if (abs(dx(i)) .le. dmax) go to 30
         idamax = i
         dmax = abs(dx(i))
   30 continue
      return
      end

C     ----------------------------------------------------------------

      subroutine  dcopy(n, dx, incx, dy, incy)
c
c     copies a vector, x, to a vector, y.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      implicit none
c
      integer i, incx, incy, ix, iy, m, mp1
      integer*4 n
      double precision dx(1), dy(1)
c
      if (n .le. 0) return
      if (incx .eq. 1 .and. incy .eq. 1) go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if (incx .lt. 0) ix = (-n + 1) * incx + 1
      if (incy .lt. 0) iy = (-n + 1) * incy + 1
      do 10 i = 1, n
        dy(iy) = dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n, 7)
      if ( m .eq. 0 ) go to 40
      do 30 i = 1, m
        dy(i) = dx(i)
   30 continue
      if ( n .lt. 7 ) return
   40 mp1 = m + 1
      do 50 i = mp1, n, 7
        dy(i) = dx(i)
        dy(i + 1) = dx(i + 1)
        dy(i + 2) = dx(i + 2)
        dy(i + 3) = dx(i + 3)
        dy(i + 4) = dx(i + 4)
        dy(i + 5) = dx(i + 5)
        dy(i + 6) = dx(i + 6)
   50 continue
      return
      end


!******************************************************************
! Program in Fortran 90
!
!  spdiv => Direct spectral division
!  wiene => Wiener filter
!  tikho => Tikhonov regularisation
!  maxen => Maximum Entropy method
!
! JLP
! Version 03/04/2001
!******************************************************************
program dcv_deconv_2D
 use dcv_2D_data
 use dcv_2D_mod
 implicit none
 real			:: rms_err,ss,L_phi,L_y,snr
 integer		:: nx0,ny0,iter,pntr
 character(len=1)	:: ans
 character(len=20)	:: prefix
 character(len=60)	:: filename
 character(len=80)	:: comments

call jlp_begin
call jlp_inquifmt

print *,' Program to deconvolve 2D signals'
print *,' JLP version 28/03/2001'

!!!! idim = 128*128 = 16384
!  prefix='s3'
  prefix='s5'

if(simulation)then
  print *,' Simulation: *_psf,*_yy0 are needed (prefix: s3, s5, ...)'
else
  print *,' Real data: *_psf,*_raw are needed'
endif
  print *,' Prefix for filenames: '
  read(5,*) prefix
  print *,'OK: prefix:',prefix

! Read a file first to determine the size:
if(simulation)then
  filename=trim(prefix)//'_yy0'
else
  filename=trim(prefix)//'_raw'
endif
call jlp_vm_readimag(pntr,nx,ny,filename,comments);
!
! nn = number of pixels of an image (used by frprmn)
nn = nx*ny;
if(nn /= idim)then
  print *,' Fatal error: size of images is not equal to idim=',idim
  stop
endif
! To prepare FFT's:
if(nn > idim)then
  print *,' Fatal error: size of images larger than idim=',idim
  stop
endif
! To prepare FFT's:
print *,' fft_setup with ',nx,ny
call fft_setup(nx,ny)

! Then allocate memory space:
allocate(yy0(nn)); allocate(yy(nn)); allocate(hh(nn));
allocate(yyd(nn)); allocate(w0(nn)); allocate(w1(nn));
allocate(w_re(nn)); allocate(w_im(nn));
allocate(hh_re(nn)); allocate(hh_im(nn));
allocate(hht_re(nn)); allocate(hht_im(nn));
allocate(yy_re(nn)); allocate(yy_im(nn));

! Read input files:
!----------------------
if(simulation)then
! Original signal:
  filename=trim(prefix)//'_yy0'
  call jlp_readimag(yy0,nx,ny,nx,filename,comments);
else
! Image to deconvolve
  filename=trim(prefix)//'_raw'
  call jlp_readimag(yy,nx,ny,nx,filename,comments);
endif

!----------------------
! PSF:
filename=trim(prefix)//'_psf'
call jlp_readimag(hh,nx0,ny0,nx,filename,comments);
! Normalize PSF (to avoid numerical pb...)
hh = hh / maxval(hh)
if(nx /= nx0 .or. ny /= ny0)then
   print *,' Fatal error: wrong size for psf : nx=',nx0,' ny=',ny0; stop;
endif
! Compute transfer function:
  hh_re = hh; hh_im =0.;
  call fft_float(hh_re,hh_im,nx,ny,1)

!----------------------
! Signal to deconvolve:
if(simulation)then
! Either input it from a file
  if(.false.)then
! Original signal:
    filename=trim(prefix)//'_yyb'
    call jlp_readimag(yy,nx0,ny0,nx,filename,comments);
    if(nx /= nx0 .or. ny /= ny0)then
       print *,' Fatal error: wrong size for yyb : nx=',nx0,' ny=',ny0; stop;
    endif
  else
! Or create it:
! snr is in dB
! snr=20 or 13dB
! snr=100 or 20dB : simu 3: with disk
! snr=1000 or 30dB: simu 4: with disk
! snr=20 or 13dB: simu 5: without disk
    snr = 13
    call noisy_signal(snr)
    filename =trim(prefix)//'_yyb'
    write(comments,55) trim(prefix)//': convolution of yy0 with psf, SNR=',snr
55  format(A,F6.2,' dB')
    call jlp_writeimag(yy,nx,ny,nx,filename,comments);
  endif
! End simulation case
endif

! Set to zero all arrays:
w0 = 0.; w1 = 0.; w_re = 0.; w_im = 0.;

!--------------------------------
! Deconvolution
!--------------------------------

write(6,18);
18 format(/,&
' ==================== Options: ================',/,&
' - spdiv: spectral division',/,&
' - wiene: Wiener filter',/,&
' Regularisation on x_i only: ',/,&
' - tikho: Tikhonov''s regularisation',/,&
' - ggaus: Generalized Gauss''s regularisation (p=1.1)',/,&
' - maxen: regularisation with maximum entropy',/,&
' - sqrtr: convex sqrt(s2+x2) regularisation',/,&
' Regularisation on (x_i+1 - x_i): ',/,&
' - gmark: Gauss-Markov''s regularisation (p=2)',/,&
' ======== Enter the option you want: ===========')
read(5,*) option
print *,' OK: option=',option
L_phi = 0.;

positivity = .false.
if(option(1:5) .ne. 'spdiv' .and. option(1:5) .ne. 'wiene'&
   .and. option(1:5) .ne. 'maxen')then
   print *,' Positivity constraint? [y/n]'; read(5,*)ans
   if((ans(1:1) .eq. 'y') .or. (ans(1:1) .eq. 'Y')) positivity=.true.
endif
if(option(1:5) .ne. 'spdiv' .and. option(1:5) .ne. 'wiene')then
   print *,' Enter alpha value: '; read(5,*)alpha
endif

select case(option)

!--------------------------------
! Deconvolution by spectral division:
case('spdiv')
   call dcv_spdiv
   write(comments,10)
10 format('Spectral division:')

!--------------------------------
! Deconvolution by Wiener filter:
case('wiene')
! alpha is the ratio variance of noise / variance noise of signal
   if(simulation)then
     alpha=10**(-snr/10.)
     print *,'Theoretical value is (sigma_noise/sigma_signal)**2 :',alpha
   endif
   print *,' Enter alpha value: '; read(5,*)alpha
   call dcv_wiener
   write(comments,11) alpha
11 format('Wiener: alpha=',F4.1)

!--------------------------------
! Deconvolution with Tikhonov's regularisation
! Generalized Gauss with p=2
case('tikho')
   call dcv_tikhonov(iter)
   write(comments,12) alpha,iter
12 format('Tikhonov: alpha=',F4.1,' iter=',I3)
   L_phi = phi_tikho(yyd)

!--------------------------------
! Deconvolution with generalized Gauss' regularisation
! with p=1.1
case('ggaus')
   call dcv_ggauss(iter)
   write(comments,13) alpha,iter
13 format('Gen. Gauss: alpha=',F4.1,' it=',I3)
   L_phi = phi_ggauss(yyd)

!--------------------------------
! Deconvolution with convex sqrt(s2+x2) regularisation
case('sqrtr')
   print *,' sqrt(s^2+x^2)/Enter s value: '; read(5,*)ss
   call dcv_sqrtrf(ss,iter)
   write(comments,14) ss,alpha,iter
14 format('sqrt: s=',F5.3,' alpha=',F4.1,' it=',I3)
   L_phi = phi_sqrtrf(yyd)

!--------------------------------
! Deconvolution with Maximum Entropy method
case('maxen')
   call dcv_mem(iter)
   write(comments,15) alpha,iter
15 format('MEM: alpha=',F4.1,' iter=',I3)
   L_phi = phi_mem(yyd)

!--------------------------------
! Deconvolution with Gauss Markov regularisation (on x_i+1 - x_i)
case('gmark')
   call dcv_gmark(iter)
   write(comments,16) alpha,iter
16 format('Gauss-Markov alpha=',F4.1,' it=',I3)
   L_phi = phi_gmark(yyd)

!---------------------------------
! Test with Banana function:
case default
   print *,' Fatal: invalid option'
   stop
end select

if(simulation)then
   rms_err=sqrt(sum((yyd-yy0)**2))/float(nn)
   write(comments,22) trim(comments),rms_err
22 format(a,' rms=',e10.3)
endif

!----------------- L Curve:
! L_phi = phi(x)
! L_y = || y - H x ||^2
    if(L_phi /= 0.)then
!      alpha = 0.;
      L_y = func(yyd)
      write(6,33) L_phi,L_y
33    format('L curve: L_phi=',G10.4,' L_y=',G10.4)
    endif

filename =trim(prefix)//'_yyd'
call recent_fft(yyd,yyd,nx,ny,nx)
call jlp_writeimag(yyd,nx,ny,nx,filename,comments);

call jlp_end

end program dcv_deconv_2D
!----------------------------------------------------------------
! Generates a noisy signal with a given SNR
! snr: in dB
!----------------------------------------------------------------
subroutine noisy_signal(snr)
 use dcv_2D_data
 use dcv_2D_mod
 implicit none
real			:: snr,noise_level
!
! dcv_conv_hh returns: yy = conv(hh,yy0)
  call dcv_conv_hh(yy0,hh_re,hh_im,yy)
  call recent_fft(yy,yy,nx,ny,nx)
! Generate noisy signal with SNR in dB:
! Multiply by 12, since variance of uniform random function is 1/12.
  noise_level = 12. * (sum(yy**2) * 10**(-snr/10.)) / float(nn)
  noise_level = sqrt(noise_level)
  write(6,'("Simulated signal with SNR=",f8.2,"dB => noise level:",f8.3)') snr,noise_level
  call random_seed; call random_number(w0);
! Center noise:
  w0 = w0 - 0.5;
!
  yy = yy + w0 * noise_level;
return
end


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

!--------------------------------------------------------------------------
! EMsoft:EMeqvrot.f90
!--------------------------------------------------------------------------
!
! PROGRAM: EMeqvrot
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief For a given crystal symmetry (point group number), compute equivalent orientations
!
!> @date 09/24/16 MDG 1.0 original
!> @date 12/22/16 MDG 1.1 added indication of orientation that lies inside the Rodrigues FZ
!> @date 02/10/17 MDG 1.2 added option for output representation selection
!--------------------------------------------------------------------------
program EMeqvrot

use local
use constants
use dictmod
use rotations
use quaternions
use io
use so3

IMPLICIT NONE

integer(kind=irg)           :: pgnum, Rtype, Otype, io_int(1), num, k, FZtype, FZorder
real(kind=dbl)              :: ro(4), rod(3), ax(4), qu(4), io_dbl(4), qus(4), io_dbl3(3), dtor, eu(3)
type(dicttype),pointer      :: dict
logical                     :: next
character(fnlen)            :: progname, progdesc
type(orientationtyped)      :: res, saveres

progname = 'EMeqvrot.f90'
progdesc = 'List equivalent rotations'

! print some information
call EMsoft(progname, progdesc)

dtor = cPi/180.D0

! ask for point group number
call ReadValue('Enter the point group number ',io_int)
pgnum = io_int(1)

! what format are we using for the input?
call ReadValue('Input representation: Rodrigues (1), axis-angle (2), quaternion (3), or Euler (4) ',io_int)
Rtype = io_int(1)
call ReadValue('Output representation: Rodrigues (1), axis-angle (2), quaternion (3), or Euler (4) ',io_int)
Otype = io_int(1)
! allocate the symmetry operations, among other things.
allocate(dict)
dict%Num_of_init = 1
dict%Num_of_iterations = 1
dict%pgnum = pgnum
call DI_Init(dict,'VMF')
num = dict%Nqsym

FZtype = FZtarray(dict%pgnum)
FZorder = FZoarray(dict%pgnum)

! then in a loop ask for an orientation in Rodrigues form or axis angle
! and list all the equivalent orientations as axis angle pairs
next = .TRUE.
do while (next)
  select case (Rtype)
    case (1)
      call ReadValue('Rodrigues vector (nx, ny, nz, |R|) :', io_dbl,4)
      ro = io_dbl
      qu = ro2qu(ro)
    case (2)
      call ReadValue('Axis-angle pair (nx, ny, nz, omega°) :', io_dbl,4)
      ax = io_dbl
      ax(4) = ax(4) * cPi/180.D0
      qu = ax2qu(ax)
    case (3)
      call ReadValue('Quaternion (q0, q1, q2, q3) :', io_dbl,4)
      qu = io_dbl
    case (4)
      call ReadValue('Euler (phi1°, Phi°, phi2°) :', io_dbl3,3)
      qu = eu2qu(io_dbl3*dtor)
    case default
  end select
  call Message(' ')

  do k=1,num
    qus = quat_mult( dict%Pm(1:4,k), qu )
    res = init_orientation(qus,'qu')
    ro = res%rodrigues
    ax = res%axang
    ax(4) = ax(4) *180.D0/cPi
    if (IsinsideFZ(ro,FZtype,FZorder).eqv..TRUE.) then
      saveres = res
      select case(Otype)
        case(1)
          call WriteValue('FZ  ', ro, num=4)
        case(2)
          call WriteValue('FZ  ', ax, num=4)
        case(3)
          call WriteValue('FZ  ', qus, num=4)
        case(4)
          eu = res%eulang/dtor
          call WriteValue('FZ  ', eu, num=3)
        case default
      end select
    else
      select case(Otype)
        case(1)
          call WriteValue('    ', ro, num=4)
        case(2)
          call WriteValue('    ', ax, num=4)
        case(3)
          call WriteValue('    ', qus, num=4)
        case(4)
          eu = res%eulang/dtor
          call WriteValue('    ', eu, num=3)
        case default
      end select
    end if
  end do

! write all the equivalent representations for the one in the FZ
  call Message(' ')
  call Message('Equivalent representations for the rotation inside the FZ:')
  call print_orientation(saveres)
  call Message(' ')
  call ReadValue('---> Another one ? (1/0) ',io_int)
  if (io_int(1).eq.0) next=.FALSE.
end do

end program EMeqvrot


C Copyright (C) 2000, International Business Machines
C Corporation and others.  All Rights Reserved.
       SUBROUTINE NEXTNP(IPOLY , POLY , PNTINT, NIND, N, LPOLY,
     .                   LPTINT)

C
C  *******************************************************************
C  THIS SUBROUTINE UPDATES THE IPOLY-TH  NEWTON POLYNOMIAL SO THAT
C  IT HAS ZERO VALUE AT ALL POINTS IN THE SAME BLOCK AND BELLOW
C
C  PARAMETERS
C
C    IPOLY  (INPUT) INDEX OF THE POLYNOMIAL WHICH IS UPDATED
C
C    POLY   (INPUT/OUTPUT) THE ARRAY (LPOLY) OF NEWTON POLYNOMIALS
C
C    PNTINT (INPUT) THE ARRAY (LPTINT) OF CURRENT INTERPOLATION POINTS
C
C    NIND   (INPUT) THE NUMBER OF POINTS IN THE INTERPOLATION
C
C    N      (INPUT) PROBLEM DIMENSION
C  *******************************************************************
C

C
C  PARAMETERS
C

       DOUBLE PRECISION  POLY(LPOLY), PNTINT(LPTINT)

       INTEGER           IPOLY, NIND ,N, LPOLY, LPTINT

C
C  PROCESS CONTROL PARAMETERS
C
      INTEGER          IOUT  , IPRINT
      DOUBLE PRECISION MCHEPS, CNSTOL
      COMMON / DFOCM / IOUT  , IPRINT, MCHEPS, CNSTOL

C
C  LOCAL VARIABLES
C
       DOUBLE PRECISION VAL

       INTEGER          NP1, DD, Q, BLOCK, NPBEG, NPEND, I, J

       INTRINSIC        MAX
C
C  SUBROUTINES AND FUNCTIONS CALLED:
C
C    APPLICATION     :       EVALNP
C    FORTRAN SUPPLIED:       MAX
C

       NP1 = N + 1
       DD  = NP1*(N+2)/2
       Q   = MAX(IPOLY, NIND)
C
C  CHECK IN WHICH BLOCK WE ARE DOING THE UPDATES
C

       IF ( IPOLY .LE. NP1 ) THEN
         BLOCK=1
         IF ( NIND .GT. NP1 ) THEN
           IF ( IPRINT .GT. 0 ) WRITE( IOUT, 1000 )
           STOP
         ENDIF
       ELSE
         BLOCK=2
       ENDIF

       IF (BLOCK.EQ.1) THEN

C
C  IF A POLYNOMIAL IN THE LINEAR BLOCK IS UPDATED
C
         NPBEG =(IPOLY-2)*NP1 + 2
         NPEND = NPBEG + N
         CALL EVALNP(VAL, PNTINT, 1, POLY, IPOLY, N, LPTINT, LPOLY)
         POLY(NPBEG)=POLY(NPBEG)-VAL*POLY(1)

         DO 20 J=2,NIND
           IF ( J .NE. IPOLY ) THEN
             CALL EVALNP(VAL, PNTINT, J, POLY, IPOLY, N, LPTINT, LPOLY)
             DO 10 I=NPBEG,NPEND
               POLY(I)=POLY(I)-VAL*POLY(I-NPBEG+2+(J-2)*NP1)
 10          CONTINUE
           ENDIF
 20      CONTINUE

C
C  IF A POLYNOMIAL IN THE QUADRATIC BLOCK IS UPDATED
C

       ELSE
         NPBEG = (IPOLY-N-2)*DD + N*NP1 + 2
         CALL EVALNP(VAL, PNTINT, 1, POLY, IPOLY, N, LPTINT, LPOLY)
         POLY(NPBEG) = POLY(NPBEG) - VAL*POLY(1)

C
C  "ORTHOGONALIZE" THE IPOLY-TH POLYNOMIAL WITH THE LINEAR BLOCK
C

         DO 40 J=2, NP1
            CALL EVALNP(VAL, PNTINT, J, POLY, IPOLY, N, LPTINT,
     +                  LPOLY)
            NPEND = NPBEG + N
            DO 30 I = NPBEG, NPEND
              POLY(I) = POLY(I) - VAL*POLY(I-NPBEG+2+(J-2)*NP1)
 30         CONTINUE
 40      CONTINUE

C
C  "ORTHOGONALIZE" THE IPOLY-TH POLYNOMIAL WITH THE QUADRATIC BLOCK
C
         DO 60 J = N+2, NIND
           IF ( J .NE. IPOLY ) THEN
             CALL EVALNP(VAL, PNTINT, J, POLY, IPOLY, N,
     +                   LPTINT, LPOLY)
             NPEND = NPBEG + DD - 1
             DO 50 I = NPBEG,NPEND
               POLY(I) = POLY(I) - VAL*POLY(I-NPBEG+2+N*NP1+(J-N-2)*DD)
 50          CONTINUE
           ENDIF
 60      CONTINUE
       ENDIF

       RETURN
 1000  FORMAT(' NEXTNP: ERROR! UPDATING POLYNOMIAL IN LINEAR BLOCK',/
     +        '         WHEN QUADRATIC BLOCK IS PRESENT',/)
       END


cc Copyright (C) 2010: Vladimir Rokhlin
cc Copyright (C) 2009-2012: Leslie Greengard and Zydrunas Gimbutas
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a modified FreeBSD license
cc (see COPYING in home directory).
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    $Date: 2011-02-22 17:34:23 -0500 (Tue, 22 Feb 2011) $
c    $Revision: 1670 $
c
c
c-----------------------------------------------------------------------------
c
c      h2dterms - determine number of terms in mpole expansions for box
c           of size "size" with Helmholtz parameter zk.
c
c      h2dterms_list2 - build the number of terms table for all boxes
c           in list 2
c
c      h2dterms_list2e - build the number of terms table for all boxes
c           in extended list 2
c
c-----------------------------------------------------------------------------
c
c
c
      subroutine h2dterms(size, zk, eps, nterms, ier)
      implicit real *8 (a-h,o-z)
c
c     Determine number of terms in mpole expansions for box of size
c     "size" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of H_n * J_n.
c
c     Maximum number of terms is 10000, which
c     works for boxes up to 1000 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      integer iscale(0:20000)
      complex *16  zk, z1, z2, z3, jfun(0:20000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:20000), fhder(0:1)
c
      ier = 0
c
      z1 = (zk*size)*1.5d0
c
c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc        if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 10000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*size) .lt. 1.0d0) rscale = cdabs(zk*size)
      call h2dall(ntmax,z1,rscale,hfun,ifder,fhder)
c
      z2 = (zk*size) * dsqrt(2d0)/2.d0
c
      ier1 = 0
c
      call jfuns2d(ier1, ntmax, z2, rscale, jfun, ifder, fjder,
     1                 20000, iscale, ntop)
c
c     set error flag if jfuns runs out of memory
c
      if (ier1.eq.8) then
        ier = 11
        return
      endif
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          return
        endif
c
      enddo
c
c       ... computational box is too big, set nterms to 10001
c
        ier = 13
        nterms=10001
c
      return
      end
c
c
c
c
c
      subroutine h2dterms_far(size, zk, eps, nterms, ier)
      implicit real *8 (a-h,o-z)
c
c
c     Determine number of terms in mpole expansions for box of size
c     "size" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of H_n * J_n.
c
c     This routine aasumes slightly larger separation of boxes: the
c     first unit box is located at the origin and the second box is
c     located at (3,0,0).
c
c     Maximum number of terms is 10000, which
c     works for boxes up to 1000 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      integer iscale(0:20000)
      complex *16  zk, z1, z2, z3, jfun(0:20000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:20000), fhder(0:1)
c
      ier = 0
c
      z1 = (zk*size)*2.5d0
c
c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc        if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 10000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*size) .lt. 1.0d0) rscale = cdabs(zk*size)
      call h2dall(ntmax,z1,rscale,hfun,ifder,fhder)
c
      z2 = (zk*size) * dsqrt(2d0)/2.d0
c
      ier1 = 0
c
      call jfuns2d(ier1, ntmax, z2, rscale, jfun, ifder, fjder,
     1                 20000, iscale, ntop)
ccc      call prin2(' jfun is *',jfun,2*ntmax+2)
c
c     set error flag if jfuns runs out of memory
c
      if (ier1.eq.8) then
        ier = 11
        return
      endif
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          return
        endif
      enddo
c
c       ... computational box is too big, set nterms to 10001
c
        ier = 13
        nterms=10001
c
      return
      end
c
c
c
c
c
      subroutine h2dterms_list2(size, zk, eps, itable, ier)
      implicit real *8 (a-h,o-z)
c
c
c     Determine number of terms in mpole expansions for box of size
c     "size" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of h_n * j_n.
c
c     Build nterms table for all boxes in list 2
c
c     Maximum number of terms is 1000, which
c     works for boxes up to 160 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      integer iscale(0:20000)
      complex *16  zk, z1, z2, z3, jfun(0:20000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:20000), fhder(0:1)
c
      integer nterms_table(2:3,0:3)
      integer itable(-3:3,-3:3)
c
      ier = 0
c
c
c       first box in x direction
c
ccc      z1 = (zk*size)*1.5d0
c
c       second box in x direction
c
ccc      z1 = (zk*size)*2.5d0
c
c       on the diagonal
c
c      z1 = (zk*size)*dsqrt(2d0)/2.d0*3
c      z1 = (zk*size)*dsqrt(2d0)/2.d0*5
c
        do 1800 ii=2,3
        do 1800 jj=0,3
c
        dx=ii
        dy=jj
c
        if( dx .gt. 0 ) dx=dx-.5
        if( dy .gt. 0 ) dy=dy-.5
c
        rr=sqrt(dx*dx+dy*dy)
ccc        call prin2('rr=*',rr,1)
ccc        call prin2('rr=*',sqrt(2.0d0)/2*5,1)
c
        z1 = (zk*size)*rr

c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc      if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 10000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*size) .lt. 1.0d0) rscale = cdabs(zk*size)
      call h2dall(ntmax,z1,rscale,hfun,ifder,fhder)
c
      z2 = (zk*size) * dsqrt(2d0)/2.d0
c
      ier1 = 0
c
      call jfuns2d(ier1, ntmax, z2, rscale, jfun, ifder, fjder,
     1                 20000, iscale, ntop)
ccc      call prin2(' jfun is *',jfun,2*ntmax+2)
c
c     set error flag if jfuns runs out of memory
c
      if (ier1.eq.8) then
        ier = 11
        return
      endif
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          goto 1600
        endif
      enddo
c
c       ... computational box is too big, set nterms to 10001
c
        ier = 13
        nterms=10001
c
 1600   continue
c
        nterms_table(ii,jj)=nterms
c
 1800   continue
c
ccc        call prinf('nterms=*',nterms_table,2*4*4)
c
c       build the rank table for all boxes in list 2
c
        do i=-3,3
        do j=-3,3
        itable(i,j)=0
        enddo
        enddo
c
        do 2200 i=-3,3
        do 2200 j=-3,3
c
        if( abs(i) .gt. 1 ) then
        itable(i,j)=nterms_table(abs(i),abs(j))
        else if( abs(j) .gt. 1) then
        itable(i,j)=nterms_table(abs(j),abs(i))
        endif
c
 2200   continue
c
      return
      end
c
c
c
c
c
      subroutine h2dterms_list2e(size, zk, eps, itable, ier)
      implicit real *8 (a-h,o-z)
c
c
c     Determine number of terms in mpole expansions for box of size
c     "size" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of h_n * j_n.
c
c     Build nterms table for all boxes in extended list 2
c
c     Maximum number of terms is 10000, which
c     works for boxes up to 1000 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      integer iscale(0:20000)
      complex *16  zk, z1, z2, z3, jfun(0:20000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:20000), fhder(0:1)
c
      integer nterms_table(2:7,0:7)
      integer itable(-7:7,-7:7)
c
      ier = 0
c
c
c       first box in x direction
c
ccc      z1 = (zk*size)*1.5d0
c
c       second box in x direction
c
ccc      z1 = (zk*size)*2.5d0
c
c       on the diagonal
c
c      z1 = (zk*size)*dsqrt(2d0)/2.d0*3
c      z1 = (zk*size)*dsqrt(2d0)/2.d0*5
c
        do 1800 ii=2,7
        do 1800 jj=0,7
c
        dx=ii
        dy=jj
c
        if( dx .gt. 0 ) dx=dx-.5
        if( dy .gt. 0 ) dy=dy-.5
c
        rr=sqrt(dx*dx+dy*dy)
ccc        call prin2('rr=*',rr,1)
ccc        call prin2('rr=*',sqrt(2.0d0)/2*5,1)
c
        z1 = (zk*size)*rr

c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc      if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 10000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*size) .lt. 1.0d0) rscale = cdabs(zk*size)
      call h2dall(ntmax,z1,rscale,hfun,ifder,fhder)
c
      z2 = (zk*size) * dsqrt(2d0)/2.d0
c
      ier1 = 0
c
      call jfuns2d(ier1, ntmax, z2, rscale, jfun, ifder, fjder,
     1                 20000, iscale, ntop)
ccc      call prin2(' jfun is *',jfun,2*ntmax+2)
c
c     set error flag if jfuns runs out of memory
c
      if (ier1.eq.8) then
        ier = 11
        return
      endif
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          goto 1600
        endif
      enddo
c
c       ... computational box is too big, set nterms to 10001
c
        ier = 13
        nterms=10001
c
 1600   continue
c
        nterms_table(ii,jj)=nterms
c
 1800   continue
c
ccc        call prinf('nterms=*',nterms_table,2*4*4)
c
c       build the rank table for all boxes in extended list 2
c
        do i=-7,7
        do j=-7,7
        itable(i,j)=0
        enddo
        enddo
c
        do 2200 i=-7,7
        do 2200 j=-7,7
c
        if( abs(i) .gt. 2 ) then
        itable(i,j)=nterms_table(abs(i),abs(j))
        else if( abs(j) .gt. 2) then
        itable(i,j)=nterms_table(abs(j),abs(i))
        endif
c
 2200   continue
c
      return
      end
c
c
c
c
c
      subroutine h2dterms_eval(itype, size, zk, eps, nterms, ier)
      implicit real *8 (a-h,o-z)
c
c
c     Determine number of terms in mpole expansions for box of size
c     "size" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of h_n * j_n.
c
c     Maximum number of terms is 10000, which
c     works for boxes up to 1000 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      integer iscale(0:20000)
      complex *16  zk, z1, z2, z3, jfun(0:20000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:20000), fhder(0:1)
c
      ier = 0
c
      z1 = (zk*size)*1.5d0
c
c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc      if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 1000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*size) .lt. 1.0d0) rscale = cdabs(zk*size)
      call h2dall(ntmax,z1,rscale,hfun,ifder,fhder)
c
        z2 = (zk*size) * dsqrt(2d0)/2.d0
c
c       corners included
        if( itype .eq. 1 ) z2 = (zk*size) * dsqrt(2d0)/2.d0
c       edges included, no corners
        if( itype .eq. 2 ) z2 = (zk*size) * dsqrt(1d0)/2.d0
c       center only
        if( itype .eq. 3 ) z2 = (zk*size) * 1.0d0/2.d0
c       center only, small interior sphere
        if( itype .eq. 4 ) z2 = (zk*size) * 0.8d0/2.d0
c
      ier1 = 0
c
      call jfuns2d(ier1, ntmax, z2, rscale, jfun, ifder, fjder,
     1                 2000, iscale, ntop)
ccc      call prin2(' jfun is *',jfun,2*ntmax+2)
c
c     set error flag if jfuns runs out of memory
c
      if (ier1.eq.8) then
        ier = 11
        return
      endif
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          return
        endif
c
      enddo
c
c       ... computational box is too big, set nterms to 10001
c
        ier = 13
        nterms=10001
c
      return
      end
c
c
c
c
c


!===============================================================================
program CIJ_thom_list
!===============================================================================
!  Program form of the CIJ_thom routine in anisotropy_ajn module which reads!
!  parameters from stdin and outputs the results in a list

   use anisotropy_ajn

   implicit none

   real(8) :: ecs(6,6)
   real(8) :: vp,vs,rho,del,eps,gam
   integer :: iostatus

   if (command_argument_count() /= 0) then
      write(0,'(a)') 'Usage:  CIJ_thom < [vp] [vs] [rho] [delta] [epsilon] [gamma]',&
                     '  Rotationally symmetric about 3-axis (vertical)',&
                     '  Reads parameters from stdin',&
                     '  Sends 36 elastic constants to stdout (density-normalised).'
      stop
   endif

   iostatus = 0
   do while (iostatus == 0)
      read(*,*,iostat=iostatus) vp,vs,rho,del,eps,gam
      if (iostatus < 0) exit ! End of file
      if (iostatus > 0) then ! Error in reading
         write(0,'(a)') 'CIJ_thom_list: problem reading vp,vs,rho,del,eps,gam from stdin'
         stop
      endif

      ! Calculate ecs
      ecs = CIJ_thom(vp,vs,rho,eps,gam,del)

      write(*,*) ecs/rho

   enddo

end program CIJ_thom_list
!-------------------------------------------------------------------------------


      subroutine ginvrt(aimatr,delvec,gmmatr,ipivot,kdim,kmax)
c
c     This subroutine inverts the matrix aamatr. The inverted matrix
c     is returned in aimatr. Thus
c
c       [aamatr][aimatr] = I
c
c     where I is the unit matrix (1's on the diagonal, 0's elsewhere).
c
c     This subroutine assumes that aamatr has already been factored
c     into its L-U decomposition, gmmatr. The inverse matrix aimatr
c     is obtained by solving a series of matrix equations, each using
c     the same decomposed matrix but with a different unit vector as
c     the right hand side. The original aamatr matrix itself is not
c     used here.
c
c     A companion subroutine minvrt.f has the same function as the
c     present routine. However, it does its own factoring of aamatr
c     to obtain gmmatr.
c
c     This subroutine uses the following subroutines, which are
c     adaptations of 1979 Linpack subroutines of the same names:
c
c       EQLIBU/dgesl.f
c
c     The calling sequences have been preserved to facilitate
c     substituting equivalents optimized for specific platforms,
c     for anyone desiring to do so.
c
c     This subroutine is called by:
c
c       EQ6/garmat.f
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       gmmatr = the L-U decomposition of the matrix to be inverted
c       kdim   = the actual dimention of the matrix
c       kmax   = the maximum dimension of the matrix
c
c     Workspace:
c
c       delvec = at one point, the right-hand-side vector; at another,
c                  the solution vector
c       ipivot = the pivot vector
c
c     Output:
c
c       aimatr = the inverted matrix
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer kmax
c
      integer ipivot(kmax)
      integer kdim
c
      real*8 aimatr(kmax,kmax),gmmatr(kmax,kmax),delvec(kmax)
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer j,k
c
c-----------------------------------------------------------------------
c
c     Invert the matrix aamatr by looping over columns for the inverted
c     matrix (aimatr).
c
      do k = 1,kdim
c
c       Put the corresponding unit vector in delvec. This serves to
c       set the right-hand-side vector.
c
        do j = 1,kdim
          delvec(j) = 0.
        enddo
        delvec(k) = 1.
c
c       Solve for the unknown vector (delvec). Note that delvec
c       initially contains the right-hand-side vector. Normally
c       separate arrays would be used for the two vectors. This
c       example of bad programming is made here to retain consistency
c       with the original Linpack routine.
c
        call dgesl(gmmatr,kmax,kdim,ipivot,delvec)
c
c       Load the result in the inverted matrix.
c
        do j = 1,kdim
          aimatr(j,k) = delvec(j)
        enddo
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  999 continue
      end


      SUBROUTINE OBJFCN(N,X,F,NPROB)                                    00000010
      INTEGER N,NPROB
      DOUBLE PRECISION F
      DOUBLE PRECISION X(N)
C     **********
C
C     SUBROUTINE OBJFCN
C
C     THIS SUBROUTINE DEFINES THE OBJECTIVE FUNCTIONS OF EIGHTEEN
C     NONLINEAR UNCONSTRAINED MINIMIZATION PROBLEMS. THE VALUES
C     OF N FOR FUNCTIONS 1,2,3,4,5,10,11,12,16 AND 17 ARE
C     3,6,3,2,3,2,4,3,2 AND 4, RESPECTIVELY.
C     FOR FUNCTION 7, N MAY BE 2 OR GREATER BUT IS USUALLY 6 OR 9.
C     FOR FUNCTIONS 6,8,9,13,14,15 AND 18 N MAY BE VARIABLE,
C     HOWEVER IT MUST BE EVEN FOR FUNCTION 14, A MULTIPLE OF 4 FOR
C     FUNCTION 15, AND NOT GREATER THAN 50 FOR FUNCTION 18.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE OBJFCN(N,X,F,NPROB)
C
C     WHERE
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE.
C
C       X IS AN INPUT ARRAY OF LENGTH N.
C
C       F IS AN OUTPUT VARIABLE WHICH CONTAINS THE VALUE OF
C         THE NPROB OBJECTIVE FUNCTION EVALUATED AT X.
C
C       NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
C         NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
C
C     SUBPROGRAMS CALLED
C
C       FORTRAN-SUPPLIED ... DABS,DATAN,DCOS,DEXP,DLOG,DSIGN,DSIN,
C                            DSQRT
C
C     MINPACK. VERSION OF JULY 1978.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I,IEV,IVAR,J
      DOUBLE PRECISION AP,ARG,BP,C2PDM6,CP0001,CP1,CP2,CP25,CP5,C1P5,
     1                 C2P25,C2P625,C3P5,C25,C29,C90,C100,C10000,
     2                 C1PD6,D1,D2,EIGHT,FIFTY,FIVE,FOUR,ONE,R,S1,S2,
     3                 S3,T,T1,T2,T3,TEN,TH,THREE,TPI,TWO,ZERO
      DOUBLE PRECISION FVEC(50),Y(15)
      DOUBLE PRECISION DFLOAT
      DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,FIFTY
     1     /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,8.0D0,1.0D1,5.0D1/
      DATA C2PDM6,CP0001,CP1,CP2,CP25,CP5,C1P5,C2P25,C2P625,C3P5,C25,
     1     C29,C90,C100,C10000,C1PD6
     2     /2.0D-6,1.0D-4,1.0D-1,2.0D-1,2.5D-1,5.0D-1,1.5D0,2.25D0,
     3      2.625D0,3.5D0,2.5D1,2.9D1,9.0D1,1.0D2,1.0D4,1.0D6/
      DATA AP,BP /1.0D-5,1.0D0/
      DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),Y(9),Y(10),Y(11),
     1     Y(12),Y(13),Y(14),Y(15)
     2     /9.0D-4,4.4D-3,1.75D-2,5.4D-2,1.295D-1,2.42D-1,3.521D-1,
     3      3.989D-1,3.521D-1,2.42D-1,1.295D-1,5.4D-2,1.75D-2,4.4D-3,
     4      9.0D-4/
      DFLOAT(IVAR) = IVAR
C
C     FUNCTION ROUTINE SELECTOR.
C
      GO TO (10,20,40,60,70,90,110,150,170,200,210,230,250,280,300,
     1       320,330,340), NPROB
C
C     HELICAL VALLEY FUNCTION.
C
   10 CONTINUE
      TPI = EIGHT*DATAN(ONE)
      TH = DSIGN(CP25,X(2))
      IF (X(1) .GT. ZERO) TH = DATAN(X(2)/X(1))/TPI
      IF (X(1) .LT. ZERO) TH = DATAN(X(2)/X(1))/TPI + CP5
      ARG = X(1)**2 + X(2)**2
      R = DSQRT(ARG)
      T = X(3) - TEN*TH
      F = C100*(T**2 + (R - ONE)**2) + X(3)**2
      GO TO 390
C
C     BIGGS EXP6 FUNCTION.
C
   20 CONTINUE
      F = ZERO
      DO 30 I = 1, 13
         D1 = DFLOAT(I)/TEN
         D2 = DEXP(-D1) - FIVE*DEXP(-TEN*D1) + THREE*DEXP(-FOUR*D1)
         S1 = DEXP(-D1*X(1))
         S2 = DEXP(-D1*X(2))
         S3 = DEXP(-D1*X(5))
         T = X(3)*S1 - X(4)*S2 + X(6)*S3 - D2
         F = F + T**2
   30    CONTINUE
      GO TO 390
C
C     GAUSSIAN FUNCTION.
C
   40 CONTINUE
      F = ZERO
      DO 50 I = 1, 15
         D1 = CP5*DFLOAT(I-1)
         D2 = C3P5 - D1 - X(3)
         ARG = -CP5*X(2)*D2**2
         R = DEXP(ARG)
         T = X(1)*R - Y(I)
         F = F + T**2
   50    CONTINUE
      GO TO 390
C
C     POWELL BADLY SCALED FUNCTION.
C
   60 CONTINUE
      T1 = C10000*X(1)*X(2) - ONE
      S1 = DEXP(-X(1))
      S2 = DEXP(-X(2))
      T2 = S1 + S2 - ONE - CP0001
      F = T1**2 + T2**2
      GO TO 390
C
C     BOX 3-DIMENSIONAL FUNCTION.
C
   70 CONTINUE
      F = ZERO
      DO 80 I = 1, 10
         D1 = DFLOAT(I)
         D2 = D1/TEN
         S1 = DEXP(-D2*X(1))
         S2 = DEXP(-D2*X(2))
         S3 = DEXP(-D2) - DEXP(-D1)
         T = S1 - S2 - S3*X(3)
         F = F + T**2
   80    CONTINUE
      GO TO 390
C
C     VARIABLY DIMENSIONED FUNCTION.
C
   90 CONTINUE
      T1 = ZERO
      T2 = ZERO
      DO 100 J = 1, N
         T1 = T1 + DFLOAT(J)*(X(J) - ONE)
         T2 = T2 + (X(J) - ONE)**2
  100    CONTINUE
      F = T2 + T1**2*(ONE + T1**2)
      GO TO 390
C
C     WATSON FUNCTION.
C
  110 CONTINUE
      F = ZERO
      DO 140 I = 1, 29
         D1 = DFLOAT(I)/C29
         S1 = ZERO
         D2 = ONE
         DO 120 J = 2, N
            S1 = S1 + DFLOAT(J-1)*D2*X(J)
            D2 = D1*D2
  120       CONTINUE
         S2 = ZERO
         D2 = ONE
         DO 130 J = 1, N
            S2 = S2 + D2*X(J)
            D2 = D1*D2
  130       CONTINUE
         T = S1 - S2**2 - ONE
         F = F + T**2
  140    CONTINUE
      T1 = X(2) - X(1)**2 - ONE
      F = F + X(1)**2 + T1**2
      GO TO 390
C
C     PENALTY FUNCTION I.
C
  150 CONTINUE
      T1 = -CP25
      T2 = ZERO
      DO 160 J = 1, N
         T1 = T1 + X(J)**2
         T2 = T2 + (X(J) - ONE)**2
  160    CONTINUE
      F = AP*T2 + BP*T1**2
      GO TO 390
C
C     PENALTY FUNCTION II.
C
  170 CONTINUE
      T1 = -ONE
      T2 = ZERO
      T3 = ZERO
      D1 = DEXP(CP1)
      D2 = ONE
      DO 190 J = 1, N
         T1 = T1 + DFLOAT(N-J+1)*X(J)**2
         S1 = DEXP(X(J)/TEN)
         IF (J .EQ. 1) GO TO 180
         S3 = S1 + S2 - D2*(D1 + ONE)
         T2 = T2 + S3**2
         T3 = T3 + (S1 - ONE/D1)**2
  180    CONTINUE
         S2 = S1
         D2 = D1*D2
  190    CONTINUE
      F = AP*(T2 + T3) + BP*(T1**2 + (X(1) - CP2)**2)
      GO TO 390
C
C     BROWN BADLY SCALED FUNCTION.
C
  200 CONTINUE
      T1 = X(1) - C1PD6
      T2 = X(2) - C2PDM6
      T3 = X(1)*X(2) - TWO
      F = T1**2 + T2**2 + T3**2
      GO TO 390
C
C     BROWN AND DENNIS FUNCTION.
C
  210 CONTINUE
      F = ZERO
      DO 220 I = 1, 20
         D1 = DFLOAT(I)/FIVE
         D2 = DSIN(D1)
         T1 = X(1) + D1*X(2) - DEXP(D1)
         T2 = X(3) + D2*X(4) - DCOS(D1)
         T = T1**2 + T2**2
         F = F + T**2
  220    CONTINUE
      GO TO 390
C
C     GULF RESEARCH AND DEVELOPMENT FUNCTION.
C
  230 CONTINUE
      F = ZERO
      D1 = TWO/THREE
      DO 240 I = 1, 99
         ARG = DFLOAT(I)/C100
         R = DABS((-FIFTY*DLOG(ARG))**D1+C25-X(2))
         T1 = R**X(3)/X(1)
         T2 = DEXP(-T1)
         T = T2 - ARG
         F = F + T**2
  240    CONTINUE
      GO TO 390
C
C     TRIGONOMETRIC FUNCTION.
C
  250 CONTINUE
      S1 = ZERO
      DO 260 J = 1, N
         S1 = S1 + DCOS(X(J))
  260    CONTINUE
      F = ZERO
      DO 270 J = 1, N
         T = DFLOAT(N+J) - DSIN(X(J)) - S1 - DFLOAT(J)*DCOS(X(J))
         F = F + T**2
  270    CONTINUE
      GO TO 390
C
C     EXTENDED ROSENBROCK FUNCTION.
C
  280 CONTINUE
      F = ZERO
      DO 290 J = 1, N, 2
         T1 = ONE - X(J)
         T2 = TEN*(X(J+1) - X(J)**2)
         F = F + T1**2 + T2**2
  290    CONTINUE
      GO TO 390
C
C     EXTENDED POWELL FUNCTION.
C
  300 CONTINUE
      F = ZERO
      DO 310 J = 1, N, 4
         T = X(J) + TEN*X(J+1)
         T1 = X(J+2) - X(J+3)
         S1 = FIVE*T1
         T2 = X(J+1) - TWO*X(J+2)
         S2 = T2**3
         T3 = X(J) - X(J+3)
         S3 = TEN*T3**3
         F = F + T**2 + S1*T1 + S2*T2 + S3*T3
  310    CONTINUE
      GO TO 390
C
C     BEALE FUNCTION.
C
  320 CONTINUE
      S1 = ONE - X(2)
      T1 = C1P5 - X(1)*S1
      S2 = ONE - X(2)**2
      T2 = C2P25 - X(1)*S2
      S3 = ONE - X(2)**3
      T3 = C2P625 - X(1)*S3
      F = T1**2 + T2**2 + T3**2
      GO TO 390
C
C     WOOD FUNCTION.
C
  330 CONTINUE
      S1 = X(2) - X(1)**2
      S2 = ONE - X(1)
      S3 = X(2) - ONE
      T1 = X(4) - X(3)**2
      T2 = ONE - X(3)
      T3 = X(4) - ONE
      F = C100*S1**2 + S2**2 + C90*T1**2 + T2**2 + TEN*(S3 + T3)**2
     1    + (S3 - T3)**2/TEN
      GO TO 390
C
C     CHEBYQUAD FUNCTION.
C
  340 CONTINUE
      DO 350 I = 1, N
         FVEC(I) = ZERO
  350    CONTINUE
      DO 370 J = 1, N
         T1 = ONE
         T2 = TWO*X(J) - ONE
         T = TWO*T2
         DO 360 I = 1, N
            FVEC(I) = FVEC(I) + T2
            TH = T*T2 - T1
            T1 = T2
            T2 = TH
  360       CONTINUE
  370    CONTINUE
      F = ZERO
      D1 = ONE/DFLOAT(N)
      IEV = -1
      DO 380 I = 1, N
         T = D1*FVEC(I)
         IF (IEV .GT. 0) T = T + ONE/(DFLOAT(I)**2 - ONE)
         F = F + T**2
         IEV = -IEV
  380    CONTINUE
  390 CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE OBJFCN.
C
      END