module advance_module

  use amrex_base_module

  implicit none

  private

  public :: advance

contains

  subroutine advance (old_phi, new_phi, geom, dt)
    type(amrex_multifab), intent(inout) :: old_phi, new_phi
    type(amrex_geometry), intent(in) :: geom
    real(amrex_real), intent(in) :: dt

    integer :: plo(4), phi(4)
    real(amrex_real) :: dx
    type(amrex_box) :: bx
    type(amrex_mfiter) :: mfi
    real(amrex_real), contiguous, dimension(:,:,:,:), pointer :: po, pn

    ! For simplicity, we assume dx(1) == dx(2) == dx(3)
    dx = geom%dx(1)

    ! This fills periodic ghost cells and ghost cells from neighboring grids
    call old_phi%fill_boundary(geom)

    !$omp parallel private(mfi,bx,po,pn,plo,phi)
    call amrex_mfiter_build(mfi, old_phi, tiling=.true.)

    do while (mfi%next())

       bx = mfi%tilebox()

       po => old_phi%dataptr(mfi)
       pn => new_phi%dataptr(mfi)

       plo = lbound(po)
       phi = ubound(po)

       select case (amrex_spacedim)
       case (2)
          call update_phi_2d(bx%lo, bx%hi, po, pn, plo, phi, dx, dt)
       case (3)
          call update_phi_3d(bx%lo, bx%hi, po, pn, plo, phi, dx, dt)
       end select
    end do

    call amrex_mfiter_destroy(mfi)
    !$omp end parallel

  end subroutine advance

  subroutine update_phi_2d (lo, hi, pold, pnew, plo, phi, dx, dt)
    integer, intent(in) :: lo(2), hi(2), plo(2), phi(2)
    real(amrex_real), intent(in   ) :: pold(plo(1):phi(1), plo(2):phi(2))
    real(amrex_real), intent(inout) :: pnew(plo(1):phi(1), plo(2):phi(2))
    real(amrex_real), intent(in) :: dx, dt

    integer :: i,j
    real(amrex_real) :: dxinv, dtdx
    real(amrex_real) :: fx(lo(1):hi(1)+1,lo(2):hi(2)  )
    real(amrex_real) :: fy(lo(1):hi(1)  ,lo(2):hi(2)+1)

    dxinv = 1.d0/dx
    dtdx = dt*dxinv

    ! x-fluxes
    do j=lo(2),hi(2)
       do i=lo(1),hi(1)+1
          fx(i,j) = ( pold(i-1,j) - pold(i,j) ) * dxinv
       end do
    end do

    ! y-fluxes
    do j=lo(2),hi(2)+1
       do i=lo(1),hi(1)
          fy(i,j) = ( pold(i,j-1) - pold(i,j) ) * dxinv
       end do
    end do

    do j=lo(2),hi(2)
       do i=lo(1),hi(1)

          pnew(i,j) = pold(i,j) - dtdx * &
               ( fx(i+1,j)-fx(i,j) &
               + fy(i,j+1)-fy(i,j) )

       end do
    end do

  end subroutine update_phi_2d

  subroutine update_phi_3d (lo, hi, pold, pnew, plo, phi, dx, dt)
    integer, intent(in) :: lo(3), hi(3), plo(3), phi(3)
    real(amrex_real), intent(in   ) :: pold(plo(1):phi(1), plo(2):phi(2), plo(3):phi(3))
    real(amrex_real), intent(inout) :: pnew(plo(1):phi(1), plo(2):phi(2), plo(3):phi(3))
    real(amrex_real), intent(in) :: dx, dt

    integer :: i,j,k
    real(amrex_real) :: dxinv, dtdx
    real(amrex_real) :: fx(lo(1):hi(1)+1,lo(2):hi(2)  ,lo(3):hi(3))
    real(amrex_real) :: fy(lo(1):hi(1)  ,lo(2):hi(2)+1,lo(3):hi(3))
    real(amrex_real) :: fz(lo(1):hi(1)  ,lo(2):hi(2)  ,lo(3):hi(3)+1)

    dxinv = 1.d0/dx
    dtdx = dt*dxinv

    ! x-fluxes
    do k=lo(3),hi(3)
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)+1
             fx(i,j,k) = ( pold(i-1,j,k) - pold(i,j,k) ) * dxinv
          end do
       end do
    end do

    ! y-fluxes
    do k=lo(3),hi(3)
       do j=lo(2),hi(2)+1
          do i=lo(1),hi(1)
             fy(i,j,k) = ( pold(i,j-1,k) - pold(i,j,k) ) * dxinv
          end do
       end do
    end do

    ! z-fluxes
    do k=lo(3),hi(3)+1
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)
             fz(i,j,k) = ( pold(i,j,k-1) - pold(i,j,k) ) * dxinv
          end do
       end do
    end do

    do k=lo(3),hi(3)
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)

             pnew(i,j,k) = pold(i,j,k) - dtdx * &
                  ( fx(i+1,j,k)-fx(i,j,k) &
                  + fy(i,j+1,k)-fy(i,j,k) &
                  + fz(i,j,k+1)-fz(i,j,k) )

          end do
       end do
    end do

  end subroutine update_phi_3d

end module advance_module


MODULE linsolution_module
!
!
!Purpose: To declare functions that we use to solve linearized version of the New Keynesian model.
!
!
!
!
!
!
!   Record of Revisions:
!
!       Date                 Description of Change                                                 Programmer
!     ========              =======================                                               ============
!     5-30-13                Original Code                                                            cjg
USE solution_module
IMPLICIT NONE

INTEGER, PARAMETER :: Nlin = 8  !number of variables in linear state space
INTEGER, PARAMETER :: Nklin = 6   !number of linear state variables (including shocks)

CONTAINS

!-------------------------------------------------------------------------------------------------------------------------

SUBROUTINE linunconstrained(param,dlin,retco)
!
!
!
!  Purpose: Uses linear equations to get unconstrained decision rule to NK model.
!
!
!
!                   Date                     Description of Change                                  Programmer
!                  ======                 =================================                        ===========
!                   11-21-12                  original code                                            cjg
!                   3-26-13                 exponential filter                                         cjg
!                   5-30-13                 removed exponential filter                                 cjg
USE solab
IMPLICIT NONE

!Input/output variables
DOUBLE PRECISION, INTENT(IN)     :: param(Nparam)
DOUBLE PRECISION, INTENT(OUT)    :: dlin(Nlin,Nklin)
INTEGER, INTENT(OUT)             :: retco

!local variables
DOUBLE PRECISION :: beta,gamma,phi,ep,gampi,gamg,rhor,rhoe,sigmath,sigmar,sigmae,gr,pibar
DOUBLE PRECISION :: wss,gdpss,nomrss,gamtil
DOUBLE PRECISION :: flin(Nlin-Nklin,Nklin),plin(Nklin,Nklin)
DOUBLE PRECISION :: alin(Nlin,Nlin),blin(Nlin,Nlin)

beta = param(1); gamma = param(2); phi = param(3); ep = param(4)
gampi = param(5); gamg = param(6); rhor = param(7); rhoe = param(8)
sigmath = param(9); sigmar = param(10); sigmae = param(11); gr = param(12)-1
pibar = param(13)

!steady state
wss = (ep-1)/ep
gdpss = ((ep-1)/ep)/(1-gamma/exp(gr))
nomrss = log(exp(gr)*pibar/beta)
gamtil = gamma/exp(gr)

!!Our hope is to replace the
!!following section with the parser
!!we'd call the code that the
!!parser generates here

alin = 0.0d0
blin = 0.0d0

!tech shock
alin(1,1) = 1.0d0

!demand shock
alin(2,2) = 1.0d0
blin(2,2) = rhoe

!monetary shock
alin(3,3) = 1.0d0

!marginal utility of consumption
blin(4,8) = -1.0d0
alin(4,5) = 1.0d0/(1.0d0-gamtil)
blin(4,5) = gamtil/(1.0d0-gamtil)
blin(4,1) = -gamtil/(1.0d0-gamtil)

!consumption euler
blin(5,8) = -1.0d0
alin(5,8) = -1.0d0
alin(5,4) = -1.0d0
alin(5,7) = 1.0d0
blin(5,2) = -1.0d0
alin(5,1) = 1.0d0

!pricing equation
blin(6,7) = -1.0d0
alin(6,7) = -beta
blin(6,8) = -(ep-1)/phi

!interest rate rule for national rate
alin(7,4) = 1.0d0
blin(7,4) = rhor
blin(7,7) = gampi

alin(7,5) = -gamg
blin(7,5) = -gamg
blin(7,1) = gamg
blin(7,3) = 1.0d0

alin(8,6) = 1.0d0

!!in lieu of zsolab
!!we'd call sparseAMA here

CALL zsolab(flin,plin,alin,blin,Nlin,Nklin,retco)
dlin(1:Nklin,:) = plin
dlin(Nklin+1:Nlin,:) = flin

!!convert sparse c matrix
!!to dense matrix in fortran

END SUBROUTINE linunconstrained

!--------------------------------------------------------------------------------------------------------------

SUBROUTINE decrlin(endogvarm1,currentshocks,polysolution,dlin,endogvar)
!
!Purpose:  Linear decision rule for GLSS (2012) NK model without capital and sticky wages.
!
!
!   Record of Revisions:
!
!       Date                  Description of Change                                     Programmer
!     =========              =======================                                   ==============
!      5-25-13                original program                                              cjg
IMPLICIT NONE
!Declare inputs/outputs
TYPE(polydetails), INTENT(IN)   :: polysolution
INTEGER,           INTENT(IN)   :: currentshocks(Nexog)
DOUBLE PRECISION, INTENT(IN)    :: endogvarm1(Nmsv+Ncontrol),dlin(Nlin,Nklin)
DOUBLE PRECISION, INTENT(OUT)   :: endogvar(Nmsv+Ncontrol)

!Declare local variables
INTEGER          :: Nr,Nth,Ne
DOUBLE PRECISION :: xlinstate(Nklin),xlinstatep(Nlin)
DOUBLE PRECISION :: rshock(Nshock(3))
DOUBLE PRECISION :: thshock(Nshock(2))
DOUBLE PRECISION :: eshock(Nshock(1))

Ne = Nshock(1)
Nth = Nshock(2)
Nr = Nshock(3)
eshock = polysolution%shockvalues(1:Ne)
thshock = polysolution%shockvalues(Ne+1:Ne+Nth)
rshock = polysolution%shockvalues(Ne+Nth+1:Ne+Nth+Nr)

xlinstate = 0.0d0
xlinstate(1) = thshock(currentshocks(2))
xlinstate(2) = -eshock(currentshocks(1))  !make discount factor shock a discount rate shock as expected by linear solution).
xlinstate(3) = rshock(currentshocks(3))
xlinstate(4) = endogvarm1(1)
xlinstate(5) = endogvarm1(3)

CALL dgemv('N',Nlin,Nklin,1.0d0,dlin,Nlin,xlinstate,1,0.0d0,xlinstatep,1)

endogvar = 0.0d0
endogvar(1) = xlinstatep(4)
endogvar(2) = xlinstatep(7)
endogvar(3) = xlinstatep(5)
endogvar(4) = xlinstatep(8)
endogvar(5) = xlinstatep(4)

END SUBROUTINE decrlin

!----------------------------------------------------------------------------------------------------------------------

SUBROUTINE get_linearstate(currentshocks,currentgrid,polysolution,dlin,solcoeff0)
!
!Uses linear model to construct initial guess at polynomial coefficients for a given state.
!
!
!
!   Record of Revisions:
!
!       Date                  Description of Change                                Programmer
!     =========              =======================                              ==============
!      12-21-12                original program                                        cjg
!      3-12-13                 updated for ygap model                                  cjg
!      3-26-13                 updated for exp filter                                  cjg
!      4-16-13                 regression constant rewrite                             cjg
!      5-26-13                 derived data types                                      cjg

IMPLICIT NONE
!Declare inputs/outputs
INTEGER,          INTENT(IN)  :: currentshocks(Nexog)
DOUBLE PRECISION, INTENT(IN)  :: currentgrid(Nmsv,Ngrid),dlin(Nlin,Nklin)
TYPE(polydetails), INTENT(IN)  :: polysolution
DOUBLE PRECISION, INTENT(OUT) :: solcoeff0(Nfunc*Npoly)

!Declare local parameters and variables
INTEGER          :: rr,ind,ipoly,order(Nmsv),indvar
DOUBLE PRECISION :: llam_new(Ngrid),ldp_new(Ngrid)
DOUBLE PRECISION :: y1(Ngrid),y2(Ngrid)
DOUBLE PRECISION :: xreg(Ngrid,Npoly-1),xx(Nmsv),xreg_dev(Ngrid,Npoly-1)
DOUBLE PRECISION :: resid(Ngrid),endogvar(Nmsv+Ncontrol),endogvarm1(Nmsv+Ncontrol)
DOUBLE PRECISION :: ldp_new_m,llam_new_m,xreg_m(Npoly-1)
DOUBLE PRECISION :: vpc(Npoly-1,Npoly-1)
DOUBLE PRECISION :: solcoeftilde(Nfunc*(Npoly-1))
DOUBLE PRECISION :: zreg_dev(Ngrid,Npoly-1),solcoeftemp(Nfunc*(Npoly-1))

llam_new = 0.0d0
ldp_new = 0.0d0
xreg = 0.0d0
DO ind = 1,Ngrid  !sum of regression points
   xx = currentgrid(:,ind)
   order = 0
   DO ipoly = 1,Npoly-1   !sum over regression coefficients
      order = nextpoly(order,Nmsv)
      xreg(ind,ipoly) = xx(1)**order(1)
      DO indvar = 2,Nmsv
         xreg(ind,ipoly) = xreg(ind,ipoly)*(xx(indvar)**order(indvar))
      END DO
   END DO

   endogvarm1(1:Nmsv) = xx
   CALL decrlin(endogvarm1,currentshocks,polysolution,dlin,endogvar)
   llam_new(ind) = endogvar(4)
   ldp_new(ind) = endogvar(2)
END DO

!run PC regression to determine polynomial coefficients
solcoeff0 = 0.0d0
llam_new_m = SUM(llam_new)/Ngrid
ldp_new_m = SUM(ldp_new)/Ngrid
xreg_m = SUM(xreg,DIM=1)/Ngrid
y1 = llam_new-llam_new_m
y2 = ldp_new-ldp_new_m

DO ind = 1,Ngrid
   xreg_dev(ind,:) = xreg(ind,:)-xreg_m
END DO

!principal component analysis and regression
CALL pcanalysis(xreg_dev,Ngrid,Npoly-1,vpc,rr)
solcoeftemp = 0.0d0
zreg_dev = 0.0d0
CALL dgemm('N','N',Ngrid,rr,Npoly-1,1.0d0,xreg_dev,Ngrid,vpc,Npoly-1,0.0d0,zreg_dev,Ngrid)
CALL ols_slope(y1,zreg_dev(:,1:rr),rr,Ngrid,solcoeftemp(1:rr),resid)
CALL ols_slope(y2,zreg_dev(:,1:rr),rr,Ngrid,solcoeftemp(Npoly:Npoly+rr-1),resid)
call DGEMV('N', Npoly-1, rr, 1.0d0, vpc, Npoly-1, solcoeftemp(1:rr), 1, 0.0d0, solcoeftilde(1:Npoly-1), 1)
call DGEMV('N', Npoly-1, rr, 1.0d0, vpc, Npoly-1, solcoeftemp(Npoly:Npoly+rr-1), 1, 0.0d0, solcoeftilde(Npoly:2*(Npoly-1)), 1)
solcoeff0(2:Npoly) = solcoeftilde(1:Npoly-1)
solcoeff0(Npoly+2:2*Npoly) = solcoeftilde(Npoly:2*(Npoly-1))
solcoeff0(1) = llam_new_m-DOT_PRODUCT(xreg_m,solcoeftilde(1:Npoly-1))
solcoeff0(1) = ldp_new_m-DOT_PRODUCT(xreg_m,solcoeftilde(Npoly:2*(Npoly-1)))

END SUBROUTINE get_linearstate

!----------------------------------------------------------------------------------------------------------------------

SUBROUTINE get_initialguess(polysolution,dlin)
!
!Purpose: Use linear model to construct starting guess for alphacoeff.
!
!   Record of Revisions:
!
!       Date                  Description of Change                                     Programmer
!     =========              =======================                                  ==============
!      5-31-13                original program                                             cjg
USE omp_lib
IMPLICIT NONE
!Declare inputs/outputs
TYPE(polydetails), INTENT(INOUT) :: polysolution
DOUBLE PRECISION, INTENT(IN)     :: dlin(Nlin,Nklin)

!Declare local variables
INTEGER          :: ss,polyss,jgrid
DOUBLE PRECISION :: solcoeff(Nfunc*Npoly,Ns*2)

call OMP_SET_NUM_THREADS(Nthreads)

!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(jgrid,polyss)
DO ss = 1,Ns
   IF (polysolution%statezlbinfo(ss) <= 2) THEN
      jgrid = 1
      polyss = ss
   ELSE
      jgrid = 2
      polyss = Ns+ss
   END IF

   CALL get_linearstate(polysolution%stateinfo(:,ss),polysolution%clustergrid(Nmsv*(jgrid-1)+1:Nmsv*jgrid,:),&
        polysolution,dlin,solcoeff(:,polyss))

   IF (polysolution%statezlbinfo(ss) .EQ. 2) THEN
      jgrid = 2
      polyss = Ns+ss

      CALL get_linearstate(polysolution%stateinfo(:,ss),polysolution%clustergrid(Nmsv*(jgrid-1)+1:Nmsv*jgrid,:),&
        polysolution,dlin,solcoeff(:,polyss))
   END IF
END DO
!$OMP END PARALLEL DO

polysolution%alphacoeff = solcoeff
CALL alphafill(polysolution)

END SUBROUTINE get_initialguess

!-----------------------------------------------------------------------------------------------------------------------------------------------------------------

END MODULE linsolution_module


*DECK SSIFA
      SUBROUTINE SSIFA (A, LDA, N, KPVT, INFO)
C***BEGIN PROLOGUE  SSIFA
C***PURPOSE  Factor a real symmetric matrix by elimination with
C            symmetric pivoting.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1A
C***TYPE      SINGLE PRECISION (SSIFA-S, DSIFA-D, CHIFA-C, CSIFA-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, SYMMETRIC
C***AUTHOR  Bunch, J., (UCSD)
C***DESCRIPTION
C
C     SSIFA factors a real symmetric matrix by elimination
C     with symmetric pivoting.
C
C     To solve  A*X = B , follow SSIFA by SSISL.
C     To compute  INVERSE(A)*C , follow SSIFA by SSISL.
C     To compute  DETERMINANT(A) , follow SSIFA by SSIDI.
C     To compute  INERTIA(A) , follow SSIFA by SSIDI.
C     To compute  INVERSE(A) , follow SSIFA by SSIDI.
C
C     On Entry
C
C        A       REAL(LDA,N)
C                the symmetric matrix to be factored.
C                Only the diagonal and upper triangle are used.
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       a block diagonal matrix and the multipliers which
C                were used to obtain it.
C                The factorization can be written  A = U*D*TRANS(U)
C                where  U  is a product of permutation and unit
C                upper triangular matrices , TRANS(U) is the
C                transpose of  U , and  D  is block diagonal
C                with 1 by 1 and 2 by 2 blocks.
C
C        KPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = K  if the K-th pivot block is singular.  This is
C                     not an error condition for this subroutine,
C                     but it does indicate that SSISL or SSIDI may
C                     divide by zero if called.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  ISAMAX, SAXPY, SSWAP
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891107  Modified routine equivalence list.  (WRB)
C   891107  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SSIFA
      INTEGER LDA,N,KPVT(*),INFO
      REAL A(LDA,*)
C
      REAL AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T
      REAL ABSAKK,ALPHA,COLMAX,ROWMAX
      INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,ISAMAX
      LOGICAL SWAP
C***FIRST EXECUTABLE STATEMENT  SSIFA
C
C     INITIALIZE
C
C     ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE.
C
      ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0
C
      INFO = 0
C
C     MAIN LOOP ON K, WHICH GOES FROM N TO 1.
C
      K = N
   10 CONTINUE
C
C        LEAVE THE LOOP IF K=0 OR K=1.
C
         IF (K .EQ. 0) GO TO 200
         IF (K .GT. 1) GO TO 20
            KPVT(1) = 1
            IF (A(1,1) .EQ. 0.0E0) INFO = 1
            GO TO 200
   20    CONTINUE
C
C        THIS SECTION OF CODE DETERMINES THE KIND OF
C        ELIMINATION TO BE PERFORMED.  WHEN IT IS COMPLETED,
C        KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND
C        SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS
C        REQUIRED.
C
         KM1 = K - 1
         ABSAKK = ABS(A(K,K))
C
C        DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
C        COLUMN K.
C
         IMAX = ISAMAX(K-1,A(1,K),1)
         COLMAX = ABS(A(IMAX,K))
         IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30
            KSTEP = 1
            SWAP = .FALSE.
         GO TO 90
   30    CONTINUE
C
C           DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
C           ROW IMAX.
C
            ROWMAX = 0.0E0
            IMAXP1 = IMAX + 1
            DO 40 J = IMAXP1, K
               ROWMAX = MAX(ROWMAX,ABS(A(IMAX,J)))
   40       CONTINUE
            IF (IMAX .EQ. 1) GO TO 50
               JMAX = ISAMAX(IMAX-1,A(1,IMAX),1)
               ROWMAX = MAX(ROWMAX,ABS(A(JMAX,IMAX)))
   50       CONTINUE
            IF (ABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60
               KSTEP = 1
               SWAP = .TRUE.
            GO TO 80
   60       CONTINUE
            IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70
               KSTEP = 1
               SWAP = .FALSE.
            GO TO 80
   70       CONTINUE
               KSTEP = 2
               SWAP = IMAX .NE. KM1
   80       CONTINUE
   90    CONTINUE
         IF (MAX(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100
C
C           COLUMN K IS ZERO.  SET INFO AND ITERATE THE LOOP.
C
            KPVT(K) = K
            INFO = K
         GO TO 190
  100    CONTINUE
         IF (KSTEP .EQ. 2) GO TO 140
C
C           1 X 1 PIVOT BLOCK.
C
            IF (.NOT.SWAP) GO TO 120
C
C              PERFORM AN INTERCHANGE.
C
               CALL SSWAP(IMAX,A(1,IMAX),1,A(1,K),1)
               DO 110 JJ = IMAX, K
                  J = K + IMAX - JJ
                  T = A(J,K)
                  A(J,K) = A(IMAX,J)
                  A(IMAX,J) = T
  110          CONTINUE
  120       CONTINUE
C
C           PERFORM THE ELIMINATION.
C
            DO 130 JJ = 1, KM1
               J = K - JJ
               MULK = -A(J,K)/A(K,K)
               T = MULK
               CALL SAXPY(J,T,A(1,K),1,A(1,J),1)
               A(J,K) = MULK
  130       CONTINUE
C
C           SET THE PIVOT ARRAY.
C
            KPVT(K) = K
            IF (SWAP) KPVT(K) = IMAX
         GO TO 190
  140    CONTINUE
C
C           2 X 2 PIVOT BLOCK.
C
            IF (.NOT.SWAP) GO TO 160
C
C              PERFORM AN INTERCHANGE.
C
               CALL SSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1)
               DO 150 JJ = IMAX, KM1
                  J = KM1 + IMAX - JJ
                  T = A(J,K-1)
                  A(J,K-1) = A(IMAX,J)
                  A(IMAX,J) = T
  150          CONTINUE
               T = A(K-1,K)
               A(K-1,K) = A(IMAX,K)
               A(IMAX,K) = T
  160       CONTINUE
C
C           PERFORM THE ELIMINATION.
C
            KM2 = K - 2
            IF (KM2 .EQ. 0) GO TO 180
               AK = A(K,K)/A(K-1,K)
               AKM1 = A(K-1,K-1)/A(K-1,K)
               DENOM = 1.0E0 - AK*AKM1
               DO 170 JJ = 1, KM2
                  J = KM1 - JJ
                  BK = A(J,K)/A(K-1,K)
                  BKM1 = A(J,K-1)/A(K-1,K)
                  MULK = (AKM1*BK - BKM1)/DENOM
                  MULKM1 = (AK*BKM1 - BK)/DENOM
                  T = MULK
                  CALL SAXPY(J,T,A(1,K),1,A(1,J),1)
                  T = MULKM1
                  CALL SAXPY(J,T,A(1,K-1),1,A(1,J),1)
                  A(J,K) = MULK
                  A(J,K-1) = MULKM1
  170          CONTINUE
  180       CONTINUE
C
C           SET THE PIVOT ARRAY.
C
            KPVT(K) = 1 - K
            IF (SWAP) KPVT(K) = -IMAX
            KPVT(K-1) = KPVT(K)
  190    CONTINUE
         K = K - KSTEP
      GO TO 10
  200 CONTINUE
      RETURN
      END


!=====================================================================!
! Main Program for testing the integrators on different test problems
!=====================================================================!

#include "scalar.fpp"

program main

  ! Import Integrators
  use runge_kutta_integrator        , only : DIRK
  use bdf_integrator                , only : BDF
  use abm_integrator                , only : ABM
  use nbg_integrator                , only : NBG

  ! Import Physics
!!$  use rigid_body_class              , only : rigid_body
!!$  use multibody_dynamics_class      , only : multibody_dynamics
  use spring_mass_damper_class      , only : smd1, smd2
  use dae_class      , only : dae
  use vanderpol_class      , only : vanderpol
!!$  use vanderpol_class               , only : vanderpol
  use aero_elastic_oscillator_class , only : aero_elastic_oscillator

  ! Import functions for derivative calculation
  use smd_functions_class           , only : kinetic_energy
  use oscillator_functions_class  , only : pitch

  implicit none

  ! Declare Integrators
  type(DIRK)                            :: dirkobj    ! DIRK Integrator object
  type(BDF)                             :: bdfobj     ! BDF Integrator object
  type(ABM)                             :: abmobj     ! ABM Integrator object
  type(NBG)                             :: nbgobj     ! NBM Integrator object

  ! Declare Physics for testing
  type(smd1)                   , target :: smd1obj    ! Spring-mass-damper test ODE (1 var)
  type(smd2)                   , target :: smd2obj    ! Spring-mass-damper test ODE (2 var)
  type(vanderpol)              , target :: vpl        ! Vanderpol equation (2 var)
!!$  type(multibody_dynamics)     , target :: freefall   ! Rigid body dynamics system (12 vars)
  type(aero_elastic_oscillator), target :: oscillator ! Aeroelastic oscillator (2 vars)

  ! Declare functions that are used
  type(kinetic_energy)         , target :: KE
  type(pitch)         , target :: pitch1

  ! Design variable array
  type(scalar), dimension(:), allocatable :: x, dfdx, dfdxtmp
  type(scalar)                            :: fval, ftmp
  real(dp)                                :: dh = 1.0d-8

  type(dae), target :: daeobj

  !===================================================================!
  !                       TEST NBG                                    !
  !===================================================================!

  !===================================================================!
  !                          TEST BDF                                 !
  !===================================================================!

  ! Initialize the system
  call daeobj % initialize(num_state_vars = 2, num_design_vars = 0)
  bdfobj = BDF(system = daeobj, tfinal = 1.0d0, h=1.0d-1, max_bdf_order = 2)
  call bdfobj % setPrintLevel(2)
  call bdfobj % integrate()
  call bdfobj % writeSolution("bdf.dat")
  call bdfobj % finalize()
  call daeobj % finalize()

stop "BDF"
  ! Initialize the system
  call daeobj % initialize(num_state_vars = 2, num_design_vars = 0)
  nbgobj = NBG(system = daeobj, tfinal = 1.0d0, h=1.0d-1)
  call nbgobj % setPrintLevel(2)
  call nbgobj % integrate()
  call nbgobj % writeSolution("nbg.dat")
  call nbgobj % finalize()
  call daeobj % finalize()

  stop"Execution complete"

  !===================================================================!
  !                       TEST ABM                                    !
  !===================================================================!

  ! Initialize the system
  call vpl % initialize(num_state_vars = 2, num_design_vars = 1)
  abmobj = ABM(system = vpl, tfinal = 25.0d0, h=1.0d-2, max_abm_order = 3, second_order=.false.)
  call abmobj % setPrintLevel(0)
  call abmobj % integrate()
  call abmobj % writeSolution("abm.dat")
  call abmobj % finalize()
  call vpl % finalize()

  !===================================================================!
  !                          TEST DIRK                                !
  !===================================================================!

  ! Initialize the system
  call smd1obj % initialize(num_state_vars = 1, num_design_vars = 3)
  dirkobj = DIRK(system = smd1obj, tfinal = 10.0d-0, h=1.0d-1, num_stages=2, second_order=.true.)
  call dirkobj % setPrintLevel(0)
  call dirkobj % integrate()
  call dirkobj % writeSolution("dirk.dat")
  call dirkobj % finalize()
  call smd1obj % finalize()

  stop "End of testing SMD"

  !===================================================================!
  !  Aeroelastic Oscillator
  !===================================================================!

  allocate(X(2), dfdx(2), dfdxtmp(2))

  dfdx    = 0.0d0
  dfdxtmp = 0.0d0

  x(1) = 9.0d0  ! dynamic pressure
  x(2) = 20.0d0 ! nonlinear stiffness coeff

  ! Initialize the system
  call oscillator % initialize(num_state_vars = 2, num_design_vars = 3)

  bdfobj = BDF(system = oscillator, tfinal = 1.0d0, h=1.0d-3, max_bdf_order = 3)

  call bdfobj % evalFuncGrad(num_func=1, func = pitch1,  num_dv = 2, x = x, &
       & fvals = fval, dfdx= dfdx)

!  call bdfobj % integrate()
  call bdfobj % writeSolution()

  call bdfobj % evalFDFuncGrad(num_func=1, func = pitch1,  num_dv = 2, x = x, &
       & fvals = fval, dfdx= dfdxtmp, dh=1.0d-6)

  call bdfobj % finalize()

  print*, "fval         =", fval
  print*, "Adjoint dfdx =", dfdx
  print*, "FD      dfdx =", dfdxtmp
  print*, "Error        =", abs(dfdxtmp-dfdx)

  ! Finalize the system
  call oscillator % finalize()

  dfdx = 0.0d0
  dfdxtmp = 0.0d0

  ! Initialize the system
  call oscillator % initialize(num_state_vars = 2, num_design_vars = 1)

  dirkobj = DIRK(system = oscillator, tfinal = 1.d0, h=1.0d-3, num_stages=3)

  call dirkobj % evalFuncGrad(num_func = 1, func = pitch1, num_dv = 2, x = x, &
       & fvals = fval, dfdx= dfdx)

  call dirkobj % writeSolution("dirksol.dat")

  call dirkobj % evalFDFuncGrad(num_func=1, func = pitch1, num_dv = 2, x = x, &
       & fvals = fval, dfdx= dfdxtmp, dh=dh)

  call dirkobj % finalize()

  print *, "fval         =", fval
  print *, "Adjoint dfdx =", dfdx
  print *, "FD      dfdx =", dfdxtmp
  print *, "Error        =", abs(dfdxtmp-dfdx)

  ! Finalize the system
  call oscillator % finalize()

  deallocate(X, dfdx, dfdxtmp)

end program


subroutine fclaw3dx_clawpatch46_fort_tag4refinement(mx,my,mz,mbc, &
    meqn, xlower,ylower,zlower, dx,dy,dz, blockno, &
    q, tag_threshold, init_flag, tag_patch)
    implicit none

    integer :: mx,my, mz, mbc, meqn, tag_patch, init_flag
    integer :: blockno
    double precision :: xlower, ylower, zlower, dx, dy, dz
    double precision :: tag_threshold
    double precision :: q(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,meqn)

    integer :: i,j,k, mq
    double precision :: qmin, qmax

    integer :: exceeds_th, fclaw3dx_clawpatch_exceeds_threshold
    integer :: ii,jj,kk
    double precision :: xc,yc,zc, quad(-1:1,-1:1,-1:1), qval

    logical(kind=4) :: is_ghost, clawpatch3_is_ghost

    !! # Assume that we won't refine
    tag_patch = 0

    !! # Default : Refinement based only on first variable in system.
    !! # Users can modify this by creating a local copy of this routine
    !! # and the corresponding tag4coarsening routine.

    mq = 1
    qmin = q(1,1,1,mq)
    qmax = q(1,1,1,mq)
    do k = 1-mbc,mz+mbc
        do j = 1-mbc,my+mbc
            do i = 1-mbc,mx+mbc
                xc = xlower + (i-0.5)*dx
                yc = ylower + (j-0.5)*dy
                zc = zlower + (k-0.5)*dz
                qmin = min(qmin,q(i,j,k,mq))
                qmax = max(qmax,q(i,j,k,mq))
                qval = q(i,j,k,mq)
                is_ghost = clawpatch3_is_ghost(i,j,mx,my)
                if (.not. is_ghost) then
                    do jj = -1,1
                        do ii = -1,1
                            do kk = -1,1
                                quad(ii,jj,kk) = q(i+ii,j+jj,k+kk,mq)
                            end do
                        end do
                    end do
                endif
                exceeds_th = fclaw3dx_clawpatch_exceeds_threshold( &
                      blockno, qval,qmin,qmax,quad, dx,dy,dz,xc,yc,zc, &
                      tag_threshold,init_flag, is_ghost)
                !! # -1 : Not conclusive (possibly ghost cell); don't tag for refinement
                !! # 0  : Does not pass threshold (don't tag for refinement)
                !! # 1  : Passes threshold (tag for refinement)
                if (exceeds_th .gt. 0) then
                    tag_patch = 1
                    return
                endif
            end do
        end do
    end do
end subroutine  fclaw3dx_clawpatch46_fort_tag4refinement

!! # We may want to check ghost cells for tagging.
logical(kind=4) function clawpatch3_is_ghost(i,j,mx,my)
    implicit none

    integer :: i, j, mx, my
    logical(kind=4) :: is_ghost

    is_ghost = .false.
    if (i .lt. 1 .or. j .lt. 1) then
        is_ghost = .true.
    elseif (i .gt. mx .or. j .gt. my) then
        is_ghost = .true.
    end if

    clawpatch3_is_ghost = is_ghost

    return

end function clawpatch3_is_ghost


program get_test
  use flips

  type(flips_s) :: h

  real(sp), dimension(6,6) :: amat, r, cov, ir, test
  real(sp), dimension(6,1) :: sol, m, x, y, error, test2
  real(sp), dimension(6) :: tvec
  integer :: n

  call random_number(amat)
  call random_number(x)
  call random_number(error)
  error = 1.0

  m = matmul(amat,x)

  call flips_init(h,6,1)

  do n = 1,6
     call flips_add(h,1,amat(n,:),m(n,:),error(n,:))
  end do

  call flips_solve(h)
  call flips_calc_cov(h,.TRUE.)

  call get_matrix_s('solu',h,sol)
  call get_matrix_s('cova',h,cov)
  call get_matrix_s('rmat',h,r)
  call get_matrix_s('invr',h,ir)
  call get_matrix_s('ymat',h,y)
  test = matmul(ir,transpose(ir))
  test2 = matmul(ir,y)

  call flips_calc_cov(h)

  write(*,*) 'sol'
  write(*,*) '-------------------------------------------'
  do n=1,6
     write(*,'(2f10.5)') sol(n,:), x(n,:)
  end do
  write(*,*) '-------------------------------------------'

  write(*,*) 'test sol'
  write(*,*) '-------------------------------------------'
  do n=1,6
     write(*,'(2f10.5)') test2(n,:), x(n,:)
  end do
  write(*,*) '-------------------------------------------'

  write(*,*) 'cov'
  write(*,*) '-------------------------------------------'
  do n=1,6
     write(*,'(6f10.5)') cov(n,:)
  end do
  write(*,*) '-------------------------------------------'

 ! read(h%cfileunit,POS=1) tvec
 ! write(*,*) tvec

  write(*,*) 'test'
  write(*,*) '-------------------------------------------'
  do n=1,6
     write(*,'(6f10.5)') test(n,:)
  end do
  write(*,*) '-------------------------------------------'

  write(*,*) 'R'
  write(*,*) '-------------------------------------------'
  do n=1,6
     write(*,'(6f10.5)') r(n,:)
  end do
  write(*,*) '-------------------------------------------'

  write(*,*) 'invR'
  write(*,*) '-------------------------------------------'
  do n=1,6
     write(*,'(6f10.5)') ir(n,:)
  end do
  write(*,*) '-------------------------------------------'

  write(*,*) 'Y'
  write(*,*) '-------------------------------------------'
  do n=1,6
     write(*,'(f10.5)') y(n,:)
  end do
  write(*,*) '-------------------------------------------'

  !call flips_calc_residual(h)
  write(*,*) h%residual

end program get_test


program vloc_nonrel_dft
use dftatom, only: dp, mesh_exp, mesh_exp_deriv, thomas_fermi_potential, E_nl
use dft_data, only: dft_data_t
use dft, only: KS_step
use mixings, only: mixing_anderson
use utils, only: assert, newunit
implicit none

! Mesh parameters:
real(dp), parameter :: r_min = 1e-7_dp, r_max = 50.0_dp, a = 2.7e6_dp
integer, parameter :: N = 5000
real(dp), target :: R(N+1), Rp(N+1)
real(dp) :: P(5)
integer :: Z
integer, parameter :: n_orb = 2
integer, target :: no(n_orb), lo(n_orb)
real(dp), target :: fo(n_orb)
real(dp), target :: ks_energies(n_orb)
real(dp), target :: Emin_init(n_orb), Emax_init(n_orb)
real(dp), target :: V_tot(N+1)
real(dp), target :: density(N+1)
real(dp), target :: orbitals(N+1, n_orb)
real(dp), parameter :: reigen_eps = 1e-10_dp
real(dp), parameter :: mixing_eps = 5e-9_dp
real(dp), parameter :: mixing_alpha = 0.5_dp
integer, parameter :: mixing_max_iter = 200, reigen_max_iter = 40
logical :: perturb = .true.
real(dp), dimension(size(R)), target :: V_h, V_xc, e_xc, V_coulomb, tmp
type(dft_data_t) :: d
integer :: i, u
character, parameter :: l_names(0:3) = (/ "s", "p", "d", "f" /)

Z = 5
no = [1, 2]
lo = [0, 1]
fo = [2, 3]

R = mesh_exp(r_min, r_max, a, N)
Rp = mesh_exp_deriv(r_min, r_max, a, N)

ks_energies = [-2, -1] ! Initial guess for energies
V_tot = thomas_fermi_potential(R, Z) ! Initial guess for the potential

!V_coulomb = -Z/R
P = [0.65435_dp, 2.45106_dp, -1.536643785333E-01_dp, 1.153664378533E+00_dp, &
    5.0000_dp]
V_coulomb = -P(5)/R * (P(3)*erf(sqrt(P(1)) * R) + P(4)*erf(sqrt(P(2)) * R))

! We allow a few unbounded states
Emax_init = 10
! Use Hydrogen Schroedinger energies for the lower limit:
do i = 1, size(no)
    Emin_init(i) = E_nl(0._dp, no(i), lo(i), Z, 0)
end do
! For robustness, decrease Emin by 10%:
Emin_init = 1.1_dp * Emin_init

d%Z = 0  ! The boundary condition for non-singular potential is Z=0.
d%R => R
d%Rp => Rp
d%rho => density
d%V_h => V_h
d%V_coulomb => V_coulomb
d%V_xc => V_xc
d%e_xc => e_xc
d%V_tot => V_tot
d%orbitals => orbitals
d%alpha = mixing_alpha
d%dirac = .false.
d%perturb = perturb
d%reigen_eps = reigen_eps
d%reigen_max_iter = reigen_max_iter
d%no => no
d%lo => lo
d%fo => fo
d%ks_energies => ks_energies
d%Emax_init => Emax_init
d%Emin_init => Emin_init
tmp = mixing_anderson(KS_step, d%V_tot - d%V_coulomb, mixing_max_iter, &
    .true., d, mixing_alpha, mixing_eps)
! Prints the energies:
print *, "Ekin: ", d%Ekin
print *, "Ecoul:", d%Ecoul
print *, "Eenuc:", d%Eenuc
print *, "Exc:  ", d%Exc
print *, "E_tot:", d%Etot
print *, "state    E            occupancy"
do i = 1, size(ks_energies)
    print "(I1, A, ' ', F18.6, '   ', F6.3)", no(i), l_names(lo(i)), &
        ks_energies(i), fo(i)
end do
print *
print *, "The first 10 values of the radial grid:"
print *, R(:10)
print *
print *, "The first 10 values of the 1st and 2nd orbitals:"
print *, orbitals(:10, 1)
print *, orbitals(:10, 2)
print *
print *, "The first 10 values of the radial charge density:"
print *, density(:10)

print *, "The first 10 values of the Hartree potential (V_h):"
print *, V_h(:10)

! Save the radial grid, density, V_h
open(newunit(u), file="density.txt", status="replace")
write(u, "((es23.16, ' ', es23.16, ' ', es23.16))") (R(i), density(i), V_h(i), &
        i=1, size(R))
close(u)

call assert(abs(ks_energies(1) - (-1.613029_dp)) < 1e-6_dp)
call assert(abs(ks_energies(2) - (-0.181696_dp)) < 1e-6_dp)
call assert(abs(d%Etot - (-10.682131_dp)) < 1e-6_dp)
end program


	SUBROUTINE GG_CTRD ( np, rlat, rlon, alat, alon, iret )
C************************************************************************
C* GG_CTRD								*
C*									*
C* This subroutine gets the centroid of a bounded area.  It assumes that*
C* the first and last points are identical.                             *
C*									*
C* GG_CTRD ( NP, RLAT, RLON, ALAT, ALON, IRET )                         *
C*									*
C* Input parameters:							*
C*	NP  		INTEGER		No. of points for bounded area  *
C*	RLAT (*)	REAL		Latitudes of area points        *
C*	RLON (*)	REAL		Longitudes of area points       *
C*									*
C* Output parameters:							*
C*	ALAT 		REAL		Latitude of centroid            *
C*	ALON 		REAL		Longitude of centroid           *
C*	IRET		INTEGER		Return code			*
C*									*
C**									*
C* Log:									*
C* D. Kidwell/NCEP	11/99	                                        *
C************************************************************************
	REAL		rlat (*), rlon (*)
C*
	LOGICAL		dateln
	REAL		xlon ( 50 )
C------------------------------------------------------------------------
	iret = 0
	npts = np
	IF ( npts .gt. 50 ) npts = 50
	npm1 = npts - 1
C
	DO k = 1, npts
	    xlon ( k ) = rlon ( k )
	END DO
C
C*	Determine whether the dateline has been crossed.
C
	dateln = .false.
	DO k = 1, npm1
	    IF ( ABS ( xlon ( k ) ) .gt. 150. ) dateln = .true.
	END DO
C
	IF ( dateln ) THEN
	    dateln = .false.
	    DO k = 1, npm1
		IF ( ( xlon (k) * xlon (k+1) ) .lt. 0. ) dateln = .true.
	    END DO
C
	    IF ( dateln ) THEN
		DO k = 1, npm1
		    IF ( xlon (k) .lt. 0. ) xlon (k) = xlon (k) + 360.
		END DO
	    END IF
	END IF
C
	alat = rlat ( 1 )
	alon = xlon ( 1 )
	DO k  = 2, npm1
	    alat = alat + rlat ( k )
	    alon = alon + xlon ( k )
	END DO
	alat = alat / npm1
	alon = alon / npm1
	IF ( alon .gt. 180. ) alon = alon - 360.
C*
	RETURN
	END


      double precision function GammaHbb1(Msq,mbsq)
      implicit none
      include 'constants.f'
      include 'qcdcouple.f'
      double precision Msq,mbsq,beta,besq,ddilog,GammaHbb0,BigL,omb,opb
c----Formula taken from Braaten and Leveille, PR D22, 715, 1980, Eq.(14)
      besq=1d0-4d0*mbsq/Msq
      beta=sqrt(besq)
      omb=0.5d0*(1d0-beta)
      opb=0.5d0*(1d0+beta)
      BigL=log(opb/omb)
      GammaHbb1=GammaHbb0(Msq,mbsq)
     & *(1d0+ason2pi*CF*(6d0-0.75d0*(1d0+besq)/besq+6d0*log(mbsq/Msq)
     & -8d0*log(beta)
     & +(5d0/beta-2d0*beta+0.375d0*(1d0-besq)**2/beta**3)*BigL
     & +(1d0+besq)/beta*(4d0*BigL*log(opb/beta))
     & -2d0*log(opb)*log(omb)+8d0*ddilog(omb/opb)-4d0*ddilog(omb)))
c--- This is the leading-log approximation
c      GammaHbb1=GammaHbb0(Msq,mbsq)*(
c     & 1d0+ason2pi*CF*(4.5d0-3d0*log(Msq/mbsq)))
      return
      end


C
C @(#)std.f	1.9 (BNP) 6/3/89
C
      PROGRAM STD
C
C.... The example program uses LANDR to solve the standard eigenvalue
C.... problem [A-lambda*I]x = 0.
C....
C.... For simplicity A here is the famous Wilkinson matrix W(N)+.
C.... (pp.308 Wilkinson AEP)  In this case, /OPSTIF/ SIMPLY stores
C.... M := N/2.
C
      INTEGER M
      COMMON/OPSTIF/M
C....
C.... OP(N,P,Q,R) takes an N-vector Q and should return A*Q in Y.
C.... OPM(N,X,Y)  takes an N-vector X and should return X in Y.
C
C.... The common block "GETPUT" is used solely by the user-supplied
C.... subroutine STORE and holds the Lanczos vectors.
C
      DOUBLE PRECISION A
      COMMON/GETPUT/A(125000)
C
C.... See write-up for details on memory allocation for W and RITZ.
C.... N <= LMTN, MAXPRS <= LMTPRS, LANMAX <= LMTLAN.
C
      INTEGER LMTN,LMTPRS,LMTLAN,LMTNW
      PARAMETER (LMTN = 500,LMTPRS = 250,LMTLAN = LMTPRS)
      PARAMETER (LMTNW = 6*LMTN+4*LMTLAN+1+LMTLAN*LMTLAN)
      INTEGER I,EV,NW,N,LANMAX,MAXPRS,J,NEIG,IERR,MSGLVL
      DOUBLE PRECISION CONDM,ENDL,ENDR,KAPPA,
     *   W(LMTNW),RITZ(LMTN),BND(LMTN)
      INTEGER NCELLS
      NCELLS(N,LANMAX,I) = 6*N+4*LANMAX+1+I*LANMAX*LANMAX
C
C.... NW is the size of the working array W
C
      NW = LMTNW
C
      READ(5,*)N,LANMAX,MAXPRS,ENDL,ENDR,EV,KAPPA,MSGLVL
C
C.... make N an odd number
C
      M = N/2
      N = M+M+1
      WRITE(11,2000)N,LANMAX,MAXPRS,ENDL,ENDR,EV.LE.0,KAPPA
      CONDM = 1.0D0
C
C.... Data validation
C
      IF (ENDL.GE.ENDR) THEN
         WRITE(11,*)'ENDL must be strictly less than ENDR'
         STOP
      ELSE IF (MAXPRS.GT.LANMAX) THEN
         WRITE(11,*)'MAXPRS cannot exceed LANMAX',
     *      '(MAXPRS =',MAXPRS,' LANMAX =',LANMAX,')'
         STOP
      ELSE IF (EV.LE.0.AND.NCELLS(N,LANMAX,0).GT.NW) THEN
         WRITE(11,*)'6*N+4*LANMAX+1 cannot exceed',
     *      NW,'(N =',N,' LANMAX =',LANMAX,')'
         STOP
      ELSE IF (EV.GT.0.AND.NCELLS(N,LANMAX,1).GT.NW) THEN
          WRITE(11,*)'6*N+4*LANMAX+1+LANMAX*LANMAX cannot exceed',
     *      NW,'(N =',N,' LANMAX =',LANMAX,')'
         STOP
      ENDIF
C
C.... To get a random starting vector, the first N cells
C.... must be initialized to zero.
C
      DO 17 I = 1,N
         W(I) = 0.0D0
17    CONTINUE
C
C.... Make a Lanczos run; see LANDR for meanings of parameters.
C
      CALL LANDR(N,LANMAX,MAXPRS,CONDM,ENDL,ENDR,EV,KAPPA,
C     CALL LANDR(...,J,NEIG,RITZ,BND,W,NW,IERR,MSGLVL)
     *   J,NEIG,RITZ,BND,W,NW,IERR,MSGLVL)
      IF (IERR.NE.0) WRITE(11,2999)IERR
C
C.... If you permute eigenvalues, don't forget to permute the
C.... eigenvectors with them.
C
      WRITE(11,9999)J,NEIG,(I,RITZ(I),BND(I),I = 1,J)
      STOP
9999  FORMAT(1X,'...... '
     *   /1X,'...... ',6X,' J =',I3,3X,' NEIG =',I3
     *   /1X,'...... '
     *   /1X,'...... ',3X,3X,'  Computed Ritz values',2X,
     *    '(','Error Bnds',')'
     *   /1X,'...... '
     *   /(1X,'...... ',I3,3X,1PD22.14,2X,'(',1PD10.2,')'))
2000  FORMAT(
     *    1X,'... '
     *   /1X,'... solve the standard eigenproblem'
     *   /1X,'... no. of equations          =',I4
     *   /1X,'... max. no. of Lanczos steps =',I4
     *   /1X,'... max. no. of eigenpairs    =',I4
     *   /1X,'... left  end of the interval =',1PD22.14
     *   /1X,'... right end of the interval =',1PD22.14
     *   /1X,'... eigenvalues only? [T/F]   =',L4
     *   /1X,'... kappa                     =',1PD22.14
     *   /1X,'... ')
2999  FORMAT(1X,'... return flag =',I9,4(' '),'...')
      END
C
      SUBROUTINE OP(N,P,Q,R)
      INTEGER N
      DOUBLE PRECISION P(N),Q(N),R(N)
C
      INTEGER M
      COMMON/OPSTIF/M
C
      INTEGER I
      DOUBLE PRECISION ALPHA
      ALPHA(I) = DBLE(IABS((M+1-I)))
C
      R(1) = ALPHA(1)*Q(1)+Q(1+1)
      DO 100 I = 2,N-1
         R(I) = Q(I-1)+ALPHA(I)*Q(I)+Q(I+1)
100   CONTINUE
      R(N) = Q(N-1)+ALPHA(N)*Q(N)
      RETURN
      END
C
      SUBROUTINE OPM(N,A,B)
      INTEGER N
      DOUBLE PRECISION A(N),B(N)
      INTEGER I
C
      DO 100 I = 1,N
         B(I) = A(I)
100   CONTINUE
      RETURN
      END


! { dg-do run }
! Test case prepared by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
! Test of decimal= feature

integer :: istat
character(80) :: msg
real, dimension(4) :: a, b, c
namelist /mynml/ a, b
msg = "yes"
a = 43.21
b = 3.131
c = 5.432
open(99, decimal="comma", status="scratch")
write(99,'(10f8.3)') a
a = 0.0
rewind(99)
read(99,'(10f8.3)') a
if (any(a.ne.43.21)) call abort

write(msg,'(dp,f8.3,dc,f8.2,dp,f8.3)', decimal="comma") a(1), b(1), c(1)
if (trim(msg).ne."  43.210    3,13   5.432") call abort

close(99)
open(99, decimal="comma", status="scratch")
write(99,nml=mynml)
a = 0.0
b = 0.0
rewind(99)
read(99,nml=mynml)
if (any(a.ne.43.21)) call abort
if (any(b.ne.3.131)) call abort
close(99)
end


module mod_arrays
  implicit none

contains

  subroutine test_vector(vec)
    real(8), intent(inout) :: vec(:)
    integer :: k, n

    n = size(vec)

    do k = 1, n
      vec(k) = vec(k)*k
    end do
  end subroutine test_vector

  subroutine test_array_2d(arr)
    real(8), intent(inout) :: arr(:,:)
    integer :: k, l, m, n

    m = size(arr, 1)
    n = size(arr, 2)

    do l = 1, n
      do k = 1, m
        arr(k,l) = arr(k,l)*k*l
      end do
    end do
  end subroutine test_array_2d

end module mod_arrays


*DECK IMTQLV
      SUBROUTINE IMTQLV (N, D, E, E2, W, IND, IERR, RV1)
C***BEGIN PROLOGUE  IMTQLV
C***PURPOSE  Compute the eigenvalues of a symmetric tridiagonal matrix
C            using the implicit QL method.  Eigenvectors may be computed
C            later.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5, D4C2A
C***TYPE      SINGLE PRECISION (IMTQLV-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a variant of  IMTQL1  which is a translation of
C     ALGOL procedure IMTQL1, NUM. MATH. 12, 377-383(1968) by Martin and
C     Wilkinson, as modified in NUM. MATH. 15, 450(1970) by Dubrulle.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C     This subroutine finds the eigenvalues of a SYMMETRIC TRIDIAGONAL
C     matrix by the implicit QL method and associates with them
C     their corresponding submatrix indices.
C
C     On INPUT
C
C        N is the order of the matrix.  N is an INTEGER variable.
C
C        D contains the diagonal elements of the symmetric tridiagonal
C          matrix.  D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the symmetric
C          tridiagonal matrix in its last N-1 positions.  E(1) is
C          arbitrary.  E is a one-dimensional REAL array, dimensioned
C          E(N).
C
C        E2 contains the squares of the corresponding elements of E in
C          its last N-1 positions.  E2(1) is arbitrary.  E2 is a one-
C          dimensional REAL array, dimensioned E2(N).
C
C     On OUTPUT
C
C        D and E are unaltered.
C
C        Elements of E2, corresponding to elements of E regarded as
C          negligible, have been replaced by zero causing the matrix to
C          split into a direct sum of submatrices.  E2(1) is also set
C          to zero.
C
C        W contains the eigenvalues in ascending order.  If an error
C          exit is made, the eigenvalues are correct and ordered for
C          indices 1, 2, ..., IERR-1, but may not be the smallest
C          eigenvalues.  W is a one-dimensional REAL array, dimensioned
C          W(N).
C
C        IND contains the submatrix indices associated with the
C          corresponding eigenvalues in W -- 1 for eigenvalues belonging
C          to the first submatrix from the top, 2 for those belonging to
C          the second submatrix, etc.  IND is a one-dimensional REAL
C          array, dimensioned IND(N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues should be correct for indices
C                     1, 2, ..., IERR-1.  These eigenvalues are
C                     ordered, but are not necessarily the smallest.
C
C        RV1 is a one-dimensional REAL array used for temporary storage,
C          dimensioned RV1(N).
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  IMTQLV
C
      INTEGER I,J,K,L,M,N,II,MML,TAG,IERR
      REAL D(*),E(*),E2(*),W(*),RV1(*)
      REAL B,C,F,G,P,R,S,S1,S2
      REAL PYTHAG
      INTEGER IND(*)
C
C***FIRST EXECUTABLE STATEMENT  IMTQLV
      IERR = 0
      K = 0
      TAG = 0
C
      DO 100 I = 1, N
         W(I) = D(I)
         IF (I .NE. 1) RV1(I-1) = E(I)
  100 CONTINUE
C
      E2(1) = 0.0E0
      RV1(N) = 0.0E0
C
      DO 290 L = 1, N
         J = 0
C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
  105    DO 110 M = L, N
            IF (M .EQ. N) GO TO 120
            S1 = ABS(W(M)) + ABS(W(M+1))
            S2 = S1 + ABS(RV1(M))
            IF (S2 .EQ. S1) GO TO 120
C     .......... GUARD AGAINST UNDERFLOWED ELEMENT OF E2 ..........
            IF (E2(M+1) .EQ. 0.0E0) GO TO 125
  110    CONTINUE
C
  120    IF (M .LE. K) GO TO 130
         IF (M .NE. N) E2(M+1) = 0.0E0
  125    K = M
         TAG = TAG + 1
  130    P = W(L)
         IF (M .EQ. L) GO TO 215
         IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     .......... FORM SHIFT ..........
         G = (W(L+1) - P) / (2.0E0 * RV1(L))
         R = PYTHAG(G,1.0E0)
         G = W(M) - P + RV1(L) / (G + SIGN(R,G))
         S = 1.0E0
         C = 1.0E0
         P = 0.0E0
         MML = M - L
C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
         DO 200 II = 1, MML
            I = M - II
            F = S * RV1(I)
            B = C * RV1(I)
            IF (ABS(F) .LT. ABS(G)) GO TO 150
            C = G / F
            R = SQRT(C*C+1.0E0)
            RV1(I+1) = F * R
            S = 1.0E0 / R
            C = C * S
            GO TO 160
  150       S = F / G
            R = SQRT(S*S+1.0E0)
            RV1(I+1) = G * R
            C = 1.0E0 / R
            S = S * C
  160       G = W(I+1) - P
            R = (W(I) - G) * S + 2.0E0 * C * B
            P = S * R
            W(I+1) = G + P
            G = C * R - B
  200    CONTINUE
C
         W(L) = W(L) - P
         RV1(L) = G
         RV1(M) = 0.0E0
         GO TO 105
C     .......... ORDER EIGENVALUES ..........
  215    IF (L .EQ. 1) GO TO 250
C     .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
         DO 230 II = 2, L
            I = L + 2 - II
            IF (P .GE. W(I-1)) GO TO 270
            W(I) = W(I-1)
            IND(I) = IND(I-1)
  230    CONTINUE
C
  250    I = 1
  270    W(I) = P
         IND(I) = TAG
  290 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END


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

	subroutine radar_to_xyz(elp,peg,ptm)

c****************************************************************
c**
c**	FILE NAME: radar_to_xyz.for
c**
c**     DATE WRITTEN:1/15/93
c**
c**     PROGRAMMER:Scott Hensley
c**
c** 	FUNCTIONAL DESCRIPTION:This routine computes the transformation
c**     matrix and translation vector needed to get between radar (s,c,h)
c**     coordinates and (x,y,z) WGS-84 coordinates.
c**
c**     ROUTINES CALLED:euler,
c**
c**     NOTES: none
c**
c**     UPDATE LOG:
c**
c*****************************************************************

       	implicit none

c	INPUT VARIABLES:

c	structure /ellipsoid/
c	   real*8 r_a
c	   real*8 r_e2
c	end structure
c	record /ellipsoid/ elp

c	structure /peg/
c	   real*8 r_lat
c	   real*8 r_lon
c	   real*8 r_hdg
c	end structure
c	record /peg/ peg

	type ellipsoid
           sequence
	   real (8) r_a
	   real (8) r_e2
	end type ellipsoid
	type (ellipsoid) elp

	type pegtype
           sequence
	   real (8) r_lat
	   real (8) r_lon
	   real (8) r_hdg
	end type pegtype
	type (pegtype) peg

c   	OUTPUT VARIABLES:

c	structure /pegtrans/
c	   real*8 r_mat(3,3)
c	   real*8 r_matinv(3,3)
c	   real*8 r_ov(3)
c	   real*8 r_radcur
c	end structure
c	record /pegtrans/ ptm

	type pegtrans
          sequence
	  real (8) r_mat(3,3)
	  real (8) r_matinv(3,3)
	  real (8) r_ov(3)
	  real (8) r_radcur
        end type pegtrans
	type (pegtrans) ptm

c	LOCAL VARIABLES:
        integer i,j,i_type
        real*8 pi,r_radcur,r_llh(3),r_p(3),r_slt,r_clt,r_clo,r_slo,r_up(3)
        real*8 r_chg,r_shg,rdir

c	DATA STATEMENTS:none

C	FUNCTION STATEMENTS:
        external rdir

c  	PROCESSING STEPS:

c       first determine the rotation matrix

        r_clt = cos(peg%r_lat)
        r_slt = sin(peg%r_lat)
        r_clo = cos(peg%r_lon)
        r_slo = sin(peg%r_lon)
        r_chg = cos(peg%r_hdg)
        r_shg = sin(peg%r_hdg)

	ptm%r_mat(1,1) = r_clt*r_clo
	ptm%r_mat(1,2) = -r_shg*r_slo - r_slt*r_clo*r_chg
	ptm%r_mat(1,3) = r_slo*r_chg - r_slt*r_clo*r_shg
	ptm%r_mat(2,1) = r_clt*r_slo
	ptm%r_mat(2,2) = r_clo*r_shg - r_slt*r_slo*r_chg
	ptm%r_mat(2,3) = -r_clo*r_chg - r_slt*r_slo*r_shg
	ptm%r_mat(3,1) = r_slt
	ptm%r_mat(3,2) = r_clt*r_chg
	ptm%r_mat(3,3) = r_clt*r_shg

	do i=1,3
	   do j=1,3
	      ptm%r_matinv(i,j) = ptm%r_mat(j,i)
	   enddo
	enddo

c       find the translation vector

        ptm%r_radcur = rdir(elp%r_a,elp%r_e2,peg%r_hdg,peg%r_lat)

        i_type = 1
	r_llh(1) = peg%r_lat
	r_llh(2) = peg%r_lon
	r_llh(3) = 0.0d0
        call latlon(elp,r_p,r_llh,i_type)

        r_clt = cos(peg%r_lat)
        r_slt = sin(peg%r_lat)
        r_clo = cos(peg%r_lon)
        r_slo = sin(peg%r_lon)
        r_up(1) = r_clt*r_clo
        r_up(2) = r_clt*r_slo
        r_up(3) = r_slt

        do i=1,3
	   ptm%r_ov(i) = r_p(i) - ptm%r_radcur*r_up(i)
	enddo

        end


c
c
c =========================================================
      subroutine src1(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux,t,dt)
c =========================================================
      implicit none

*     !i/o
      double precision q(1-mbc:maxmx+mbc, meqn)
      double precision aux(1-mbc:maxmx+mbc, *)

      integer maxmx,meqn,mbc,mx,maux
      double precision xlower,dx,t,dt

*     !local
      logical iflag(4)
      double precision psi(4)
      double precision p,u,m,h,hu,hm
      double precision g,t0,tf,kappa,theta,S,rho,tanpsi,D,tau,phi
      double precision sigbed,kperm,compress,pm
      double precision zeta,p_eq,p_hydro,p_litho,krate

      integer i

      include "digparamsdec.i"
      include "digparamscommon.i"

      if (p_initialized.eq.0) return
      g=grav
c     !recalculate aux due to hyperbolic step
      if (p_initialized.eq.0) return
      do i=1-mbc,mx+mbc
         call admissibleq(theta,q(i,1),q(i,2),q(i,3),q(i,4),u,m,iflag)
         h = q(i,1)
         if (h.le.2.d0*dry_tol) then
            cycle
         endif
         hu = q(i,2)
         hm = q(i,3)
         p = q(i,4)

         call auxeval(h,u,m,p,kappa,theta,
     &              S,rho,tanpsi,D,tau,phi,sigbed,kperm,compress,pm)

c        ============pressure=====================================
         zeta = 6.d0/(compress*h*(1.d0+kappa))  +
     &        1.5d0*(rho-rho_f)*rho_f*grav*sin(theta)/(6.d0*rho)
         krate = -zeta*kperm/(h*mu)

         p_hydro = h*rho_f*grav*cos(theta)
         p_litho = (rho_s*m + (1.d0-m)*rho_f)*grav*h*cos(theta)
         p_eq = p_hydro
     &      - 3.d0*mu*abs(u)*tanpsi/(zeta*kperm*compress*(1.d0+kappa))
         p_eq = max(p_eq,p_hydro)
         p_eq = min(p_eq,p_litho)

         p = p_eq + (p-p_eq)*exp(krate*dt)
         call admissibleq(theta,h,hu,hm,p,u,m,iflag)
         q(i,4) = p
c        ============velocity======================================
c         D = (2.d0*kperm/(h*mu))*(rho_f*g*h*cos(theta)-p)
c         krate = (1.d0/(rho*h**2))*(h*D*(rho-rho_s)-(1.d0-m)*mu)
c         hu = hu*exp(krate*dt)
c         q(i,2) = hu
      enddo

      call calcaux(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux)

      return
      end


*DECK DCHU
      DOUBLE PRECISION FUNCTION DCHU (A, B, X)
C***BEGIN PROLOGUE  DCHU
C***PURPOSE  Compute the logarithmic confluent hypergeometric function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C11
C***TYPE      DOUBLE PRECISION (CHU-S, DCHU-D)
C***KEYWORDS  FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DCHU(A,B,X) calculates the double precision logarithmic confluent
C hypergeometric function U(A,B,X) for double precision arguments
C A, B, and X.
C
C This routine is not valid when 1+A-B is close to zero if X is small.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9CHU, DEXPRL, DGAMMA, DGAMR, DPOCH,
C                    DPOCH1, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  DCHU
      DOUBLE PRECISION A, B, X, AINTB, ALNX, A0, BEPS, B0, C0, EPS,
     1  FACTOR, GAMRI1, GAMRNI, PCH1AI, PCH1I, PI, POCHAI, SUM, T,
     2  XEPS1, XI, XI1, XN, XTOEPS,  D1MACH, DPOCH, DGAMMA, DGAMR,
     3  DPOCH1, DEXPRL, D9CHU
      EXTERNAL DGAMMA
      SAVE PI, EPS
      DATA PI / 3.1415926535 8979323846 2643383279 503 D0 /
      DATA EPS / 0.0D0 /
C***FIRST EXECUTABLE STATEMENT  DCHU
      IF (EPS.EQ.0.0D0) EPS = D1MACH(3)
C
      IF (X .EQ. 0.0D0) CALL XERMSG ('SLATEC', 'DCHU',
     +   'X IS ZERO SO DCHU IS INFINITE', 1, 2)
      IF (X .LT. 0.0D0) CALL XERMSG ('SLATEC', 'DCHU',
     +   'X IS NEGATIVE, USE CCHU', 2, 2)
C
      IF (MAX(ABS(A),1.0D0)*MAX(ABS(1.0D0+A-B),1.0D0).LT.
     1  0.99D0*ABS(X)) GO TO 120
C
C THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL
C APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE.
C
      IF (ABS(1.0D0+A-B) .LT. SQRT(EPS)) CALL XERMSG ('SLATEC', 'DCHU',
     +   'ALGORITHMIS BAD WHEN 1+A-B IS NEAR ZERO FOR SMALL X', 10, 2)
C
      IF (B.GE.0.0D0) AINTB = AINT(B+0.5D0)
      IF (B.LT.0.0D0) AINTB = AINT(B-0.5D0)
      BEPS = B - AINTB
      N = AINTB
C
      ALNX = LOG(X)
      XTOEPS = EXP (-BEPS*ALNX)
C
C EVALUATE THE FINITE SUM.     -----------------------------------------
C
      IF (N.GE.1) GO TO 40
C
C CONSIDER THE CASE B .LT. 1.0 FIRST.
C
      SUM = 1.0D0
      IF (N.EQ.0) GO TO 30
C
      T = 1.0D0
      M = -N
      DO 20 I=1,M
        XI1 = I - 1
        T = T*(A+XI1)*X/((B+XI1)*(XI1+1.0D0))
        SUM = SUM + T
 20   CONTINUE
C
 30   SUM = DPOCH(1.0D0+A-B, -A)*SUM
      GO TO 70
C
C NOW CONSIDER THE CASE B .GE. 1.0.
C
 40   SUM = 0.0D0
      M = N - 2
      IF (M.LT.0) GO TO 70
      T = 1.0D0
      SUM = 1.0D0
      IF (M.EQ.0) GO TO 60
C
      DO 50 I=1,M
        XI = I
        T = T * (A-B+XI)*X/((1.0D0-B+XI)*XI)
        SUM = SUM + T
 50   CONTINUE
C
 60   SUM = DGAMMA(B-1.0D0) * DGAMR(A) * X**(1-N) * XTOEPS * SUM
C
C NEXT EVALUATE THE INFINITE SUM.     ----------------------------------
C
 70   ISTRT = 0
      IF (N.LT.1) ISTRT = 1 - N
      XI = ISTRT
C
      FACTOR = (-1.0D0)**N * DGAMR(1.0D0+A-B) * X**ISTRT
      IF (BEPS.NE.0.0D0) FACTOR = FACTOR * BEPS*PI/SIN(BEPS*PI)
C
      POCHAI = DPOCH (A, XI)
      GAMRI1 = DGAMR (XI+1.0D0)
      GAMRNI = DGAMR (AINTB+XI)
      B0 = FACTOR * DPOCH(A,XI-BEPS) * GAMRNI * DGAMR(XI+1.0D0-BEPS)
C
      IF (ABS(XTOEPS-1.0D0).GT.0.5D0) GO TO 90
C
C X**(-BEPS) IS CLOSE TO 1.0D0, SO WE MUST BE CAREFUL IN EVALUATING THE
C DIFFERENCES.
C
      PCH1AI = DPOCH1 (A+XI, -BEPS)
      PCH1I = DPOCH1 (XI+1.0D0-BEPS, BEPS)
      C0 = FACTOR * POCHAI * GAMRNI * GAMRI1 * (
     1  -DPOCH1(B+XI,-BEPS) + PCH1AI - PCH1I + BEPS*PCH1AI*PCH1I)
C
C XEPS1 = (1.0 - X**(-BEPS))/BEPS = (X**(-BEPS) - 1.0)/(-BEPS)
      XEPS1 = ALNX*DEXPRL(-BEPS*ALNX)
C
      DCHU = SUM + C0 + XEPS1*B0
      XN = N
      DO 80 I=1,1000
        XI = ISTRT + I
        XI1 = ISTRT + I - 1
        B0 = (A+XI1-BEPS)*B0*X/((XN+XI1)*(XI-BEPS))
        C0 = (A+XI1)*C0*X/((B+XI1)*XI)
     1    - ((A-1.0D0)*(XN+2.D0*XI-1.0D0) + XI*(XI-BEPS)) * B0
     2    / (XI*(B+XI1)*(A+XI1-BEPS))
        T = C0 + XEPS1*B0
        DCHU = DCHU + T
        IF (ABS(T).LT.EPS*ABS(DCHU)) GO TO 130
 80   CONTINUE
      CALL XERMSG ('SLATEC', 'DCHU',
     +   'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2)
C
C X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD
C FORMULATION IS STABLE.
C
 90   A0 = FACTOR * POCHAI * DGAMR(B+XI) * GAMRI1 / BEPS
      B0 = XTOEPS * B0 / BEPS
C
      DCHU = SUM + A0 - B0
      DO 100 I=1,1000
        XI = ISTRT + I
        XI1 = ISTRT + I - 1
        A0 = (A+XI1)*A0*X/((B+XI1)*XI)
        B0 = (A+XI1-BEPS)*B0*X/((AINTB+XI1)*(XI-BEPS))
        T = A0 - B0
        DCHU = DCHU + T
        IF (ABS(T).LT.EPS*ABS(DCHU)) GO TO 130
 100  CONTINUE
      CALL XERMSG ('SLATEC', 'DCHU',
     +   'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2)
C
C USE LUKE-S RATIONAL APPROXIMATION IN THE ASYMPTOTIC REGION.
C
 120  DCHU = X**(-A) * D9CHU(A,B,X)
C
 130  RETURN
      END


program tester
use blas_sparse
use mod_test_parameters
real(kind=dp), dimension(:), allocatable :: x,y,z
real(kind=dp), dimension(:,:), allocatable :: dense_C, dense_B
complex(kind=dp), dimension(:), allocatable :: xc,yc,zc
complex(kind=dp), dimension(:,:), allocatable :: densec_C, densec_B
integer, dimension(:), allocatable :: x_i,y_i,z_i

integer :: i, prpty, a,d,ierr,b,c,dt,istat
integer :: n, nnz
integer,parameter::conj=1
integer :: USE_MATRIX = T_MATRIX
integer, parameter :: INDEX_BASE = blas_one_base
integer, parameter :: BLOCK_INTERN = blas_col_major

 n = 5
 nnz = 14
  ! **********************************************************************
       print *,'*********************************************************'
       if(conj.eq.0) then
          d=usdot(x_dot,indx_dot,y_dot)
       else
          d=usdot(x_dot,indx_dot,y_dot,conj)
       end if
       write(*,*) 'Testing USDOT'
       write(*,*) 'Errors of computed solution: '
       write(*,*) 'Error : ',abs(d - res_usdot)
       print *,'*********************************************************'
       if(alpha.eq.0) then
          call usaxpy(x_axpy,indx_axpy,y_axpy)
       else
          call usaxpy(x_axpy,indx_axpy,y_axpy,alpha)
       end if
       write(*,*) 'Testing USAXPY'
       write(*,*) 'Errors of computed solution: '
       write(*,*) 'Error : ',abs(y_axpy - res_usaxpy)
       print *,'*********************************************************'
       call usga(y_ga,x_ga,indx_ga)
       write(*,*) 'Testing USGA'
       write(*,*) 'Errors of computed solution: '
       write(*,*) 'Error : ',abs(x_ga - res_usga)
       print *,'*********************************************************'
       call usgz(y_gz,x_gz,indx_gz)
       write(*,*) 'Testing USGZ'
       write(*,*) 'Errors of computed solution: '
       write(*,*) 'Error : ',abs(x_gz - res_usgz_x)
       write(*,*) 'Error : ',abs(y_gz - res_usgz_y)
       print *,'*********************************************************'
       call ussc(x_sc,y_sc,indx_sc)
       write(*,*) 'Testing USSC'
       write(*,*) 'Errors of computed solution: '
       write(*,*) 'Error : ',abs(y_sc - res_ussc)

  ! **********************************************************************
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX A'
         prpty = blas_general + INDEX_BASE
         allocate(x(5),y(5))
         y=0.
         call duscr_begin(A_m,A_n,a,istat)
         call ussp(a,prpty,istat)
         do i=1,size(A_val)
            call uscr_insert_entry(a,A_val(i),A_indx(i),A_jndx(i),istat)
         end do
         call uscr_end(a,istat )
         do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x,y,istat)
         write(*,*) 'Error : ',abs(y-Ax)
         write(*,*) '* Test of MM multiplication *'
         call usmm(a,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-Ax),i=1,3)
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if

        print *,'*********************************************************'
         print *,'TEST WITH MATRIX A_SU'

         prpty = blas_symmetric + INDEX_BASE + blas_upper
         allocate(x(5),y(5))
         y=0.
         call duscr_begin(A_SU_m,A_SU_n,c,istat)
         call ussp(c,prpty,istat)
         call uscr_insert_clique(c,A_SU,A_SU_indx,A_SU_jndx,istat)
         call uscr_end(c,istat )

         do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(c,x,y,istat)
         write(*,*) 'Error : ',abs(y-A_SUx)
         write(*,*) '* Test of MM multiplication *'
         call usmm(c,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-A_SUx),i=1,3)
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(c, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX A_SU'
         prpty = blas_symmetric + INDEX_BASE + blas_lower
         allocate(x(5),y(5))
         y=0.
         call duscr_begin(A_SL_m,A_SL_n,a,istat)
         call ussp(a,prpty,istat)
         call  uscr_insert_col(a,1,A_SL_1,A_SL_1_INDX,istat)
         call  uscr_insert_col(a,2,A_SL_2,A_SL_2_INDX,istat)
         call  uscr_insert_col(a,3,A_SL_3,A_SL_3_INDX,istat)
         call  uscr_insert_col(a,4,A_SL_4,A_SL_4_INDX,istat)
         call  uscr_insert_col(a,5,A_SL_5,A_SL_5_INDX,istat)
         call uscr_end(a,istat )
         do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x,y,istat)
         write(*,*) 'Error : ',abs(y-A_SLx)
         write(*,*) '* Test of MM multiplication *'
         call usmm(a,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-A_SLx),i=1,3)
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if

  ! **********************************************************************
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX B'
         prpty = blas_general + INDEX_BASE
         allocate(x(5),y(3))
         y=0.
         call duscr_begin(B_m,B_n,b,istat)
         call ussp(b,prpty,istat)
         call uscr_insert_row(b,1,B_1,B_1_JNDX,istat)
         call uscr_insert_row(b,2,B_2,B_2_JNDX,istat)
         call uscr_insert_row(b,3,B_3,B_3_JNDX,istat)
         call uscr_end(b,istat )
         !call print(b,istat)
         do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(b,x,y,istat)
         write(*,*) 'Error : ',abs(y-Bx)
         write(*,*) '* Test of MM multiplication *'
         call usmm(b,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-Bx),i=1,3)
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(b, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if
  ! **********************************************************************
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX C'
         USE_MATRIX = O_MATRIX
         prpty = blas_general + INDEX_BASE
         allocate(xc(3),yc(3))
         call zuscr_begin(C_m,C_n,a,istat)
         call ussp(a,prpty,istat)
         call  uscr_insert_entries(a,VAL_C,INDX_C,JNDX_C,istat)
         call uscr_end(a,istat )
         do i=1,size(xc)
            xc(i) = (1.,1.)
         end do
         allocate(zc(size(xc)))
         zc = xc
         yc = (0.,0.)
         allocate(densec_C(size(yc),3),densec_B(size(xc),3))

         do i = 1,3
            densec_B(:,i) = xc
            densec_C(:,i) = (0.,0.)
         end do
         write(*,*) '* Test of MV multiplication *'
         select case(USE_MATRIX)
         case (O_MATRIX)
            call usmv(a,xc,yc,istat)
         case (T_MATRIX)
            call usmv(a,xc,yc,istat, transa = TRANSP_MATRIX)
         case (H_MATRIX)
            call usmv(a,xc,yc,istat, transa = HERMIT_MATRIX)
         case default
            stop 'No valid choice'
         end select
         if (istat.ne.0) then
            write(*,*) 'Can''t  perform MV multiplication'
            stop
         end if
         write(*,*) 'Errors of computed solution: '
         if(USE_MATRIX.eq.O_MATRIX) then
            write(*,*) 'Error : ',abs(yc-Cx)
         else if(USE_MATRIX.eq.T_MATRIX) then
            write(*,*) 'Error : ',abs(yc-CTx)
         else if(USE_MATRIX.eq.H_MATRIX) then
            write(*,*) 'Error : ',abs(yc-CHx)
         end if
         write(*,*) '* Test of MM multiplication *'
         select case(USE_MATRIX)
         case (O_MATRIX)
            call usmm(a,densec_B,densec_C,istat)
         case (T_MATRIX)
            call usmm(a,densec_B,densec_C,istat, transa =&
                 & TRANSP_MATRIX)
         case (H_MATRIX)
            call usmm(a,densec_B,densec_C,istat, transa =&
                 & HERMIT_MATRIX)
         case default
            stop 'No valid choice'
         end select
         if (istat.ne.0) then
            write(*,*) 'Can''t  perform MM multiplication'
            stop
         end if
         write(*,*) 'Errors of computed solution: '
         if(USE_MATRIX.eq.O_MATRIX) then
            write(*,*) 'Error : ',(abs(densec_C(:,i)-Cx),i=1,3)
         else if(USE_MATRIX.eq.T_MATRIX) then
            write(*,*) 'Error : ',(abs(densec_C(:,i)-CTx),i=1,3)
         else if(USE_MATRIX.eq.H_MATRIX) then
            write(*,*) 'Error : ',(abs(densec_C(:,i)-CHx),i=1,3)
         end if

         write(*,*) '*****************************'
         write(*,*) '* Deleting matrix handle    *'
         call usds(a,istat)
         deallocate(xc,yc,zc,densec_C,densec_B)
  ! **********************************************************************
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX D'
         USE_MATRIX = O_MATRIX
         prpty = blas_general + INDEX_BASE
         allocate(xc(3),yc(3))
         call zuscr_begin(d_m,d_n,a,istat)
         call ussp(a,prpty,istat)
         call  uscr_insert_entries(a,VAL_d,INDX_d,JNDX_d,istat)
         call uscr_end(a,istat )
         do i=1,size(xc)
            xc(i) = (1.,1.)
         end do
      allocate(zc(size(xc)))
      zc = xc
      yc = (0.,0.)
    allocate(densec_C(size(yc),3),densec_B(size(xc),3))

      do i = 1,3
         densec_B(:,i) = xc
         densec_C(:,i) = (0.,0.)
      end do
      write(*,*) '* Test of MV multiplication *'
      select case(USE_MATRIX)
      case (O_MATRIX)
         call usmv(a,xc,yc,istat)
      case (T_MATRIX)
         call usmv(a,xc,yc,istat, transa = TRANSP_MATRIX)
      case (H_MATRIX)
         call usmv(a,xc,yc,istat, transa = HERMIT_MATRIX)
      case default
         stop 'No valid choice'
      end select
      if (istat.ne.0) then
         write(*,*) 'Can''t  perform MV multiplication'
         stop
      end if
      write(*,*) 'Errors of computed solution: '
      if(USE_MATRIX.eq.O_MATRIX) then
         write(*,*) 'Error : ',abs(yc-dx)
      else if(USE_MATRIX.eq.T_MATRIX) then
         write(*,*) 'Error : ',abs(yc-dTx)
      else if(USE_MATRIX.eq.H_MATRIX) then
         write(*,*) 'Error : ',abs(yc-dHx)
      end if
      write(*,*) '* Test of MM multiplication *'
      select case(USE_MATRIX)

      case (O_MATRIX)
         call usmm(a,densec_B,densec_C,istat)
      case (T_MATRIX)
         call usmm(a,densec_B,densec_C,istat, transa = TRANSP_MATRIX)
      case (H_MATRIX)
         call usmm(a,densec_B,densec_C,istat, transa = HERMIT_MATRIX)
      case default
         stop 'No valid choice'
      end select
      if (istat.ne.0) then
         write(*,*) 'Can''t  perform MM multiplication'
         stop
      end if
      write(*,*) 'Errors of computed solution: '
      if(USE_MATRIX.eq.O_MATRIX) then
         write(*,*) 'Error : ',(abs(densec_C(:,i)-dx),i=1,3)
      else if(USE_MATRIX.eq.T_MATRIX) then
         write(*,*) 'Error : ',(abs(densec_C(:,i)-dTx),i=1,3)
      else if(USE_MATRIX.eq.H_MATRIX) then
         write(*,*) 'Error : ',(abs(densec_C(:,i)-dHx),i=1,3)
      end if
      write(*,*) '*****************************'
      write(*,*) '* Deleting matrix handle    *'
      call usds(a,istat)
      deallocate(xc,yc,zc,densec_C,densec_B)

      print *,'*****************************************************&
           &****'
      print *,'TEST WITH MATRIX DT'
      USE_MATRIX = O_MATRIX
      prpty = blas_upper_triangular + INDEX_BASE
      allocate(xc(3),yc(3))
      call zuscr_begin(DT_m,DT_n,dt,istat)
      call ussp(dt,prpty,istat)
      call  uscr_insert_entries(dt,VAL_DT,INDX_DT,JNDX_DT,istat)
      call uscr_end(dt,istat )
      do i=1,size(xc)
         xc(i) = (1.,1.)
      end do
      allocate(zc(size(xc)))
      zc = xc
      yc = (0.,0.)
      allocate(densec_C(size(yc),3),densec_B(size(xc),3))

      do i = 1,3
         densec_B(:,i) = xc
         densec_C(:,i) = (0.,0.)
      end do
      write(*,*) '* Test of MV multiplication *'
      select case(USE_MATRIX)
      case (O_MATRIX)
         call usmv(dt,xc,yc,istat)
      case (T_MATRIX)
         call usmv(dt,xc,yc,istat, transa = TRANSP_MATRIX)
      case (H_MATRIX)
         call usmv(dt,xc,yc,istat, transa = HERMIT_MATRIX)
      case default
         stop 'No valid choice'
      end select
      if (istat.ne.0) then
         write(*,*) 'Can''t  perform MV multiplication'
         stop
      end if
      write(*,*) 'Errors of computed solution: '
      if(USE_MATRIX.eq.O_MATRIX) then
         write(*,*) 'Error : ',abs(yc-DTTx)
      else if(USE_MATRIX.eq.T_MATRIX) then
         write(*,*) 'Error : ',abs(yc-DTTx)
      else if(USE_MATRIX.eq.H_MATRIX) then
         write(*,*) 'Error : ',abs(yc-DTHx)
      end if
      write(*,*) '* Test of MM multiplication *'
      select case(USE_MATRIX)

      case (O_MATRIX)
         call usmm(dt,densec_B,densec_C,istat)
      case (T_MATRIX)
         call usmm(dt,densec_B,densec_C,istat, transa = TRANSP_MATRIX)
      case (H_MATRIX)
         call usmm(dt,densec_B,densec_C,istat, transa = HERMIT_MATRIX)
      case default
         stop 'No valid choice'
      end select
      if (istat.ne.0) then
         write(*,*) 'Can''t  perform MM multiplication'
         stop
      end if
      write(*,*) 'Errors of computed solution: '
      if(USE_MATRIX.eq.O_MATRIX) then
         write(*,*) 'Error : ',(abs(densec_C(:,i)-DTTx),i=1,3)
      else if(USE_MATRIX.eq.T_MATRIX) then
         write(*,*) 'Error : ',(abs(densec_C(:,i)-DTTx),i=1,3)
      else if(USE_MATRIX.eq.H_MATRIX) then
         write(*,*) 'Error : ',(abs(densec_C(:,i)-DTHx),i=1,3)
      end if

      write(*,*) '* Test of tri. vec. solver  *'
      select case(USE_MATRIX)
         case (O_MATRIX)
            call ussv(dt,yc,istat)
         case (T_MATRIX)
            call ussv(dt,yc,istat, transa = TRANSP_MATRIX)
         case (H_MATRIX)
            call ussv(dt,yc,istat, transa = HERMIT_MATRIX)
         case default
            stop 'No valid choice'
         end select
         if (istat.ne.0) then
            write(*,*) 'Can''t  perform triangular solve'
            stop
         else
            write(*,*) 'Errors of computed solution: '
            write(*,*) 'Error : ',abs(yc-xc)
         end if
         write(*,*) '* Testing tri. mat. solver  *'
         select case(USE_MATRIX)
         case (O_MATRIX)
            call ussm(dt,densec_C,istat)
         case (T_MATRIX)
            call ussm(dt,densec_C,istat, transa = TRANSP_MATRIX)
         case (H_MATRIX)
            call ussm(dt,densec_C,istat, transa = HERMIT_MATRIX)
         case default
            stop 'No valid choice'
         end select
         if (istat.ne.0) then
            write(*,*) 'Can''t  perform triangular solve'
            stop
         else
            write(*,*) 'Errors of computed solution: '
            write(*,*) 'Error : ',abs(densec_C-densec_B)
         end if

         write(*,*) '*****************************'
         write(*,*) '* Deleting matrix handle    *'
         call usds(dt,istat)
         deallocate(xc,yc,zc,densec_C,densec_B)

        print *,'*********************************************************'
         print *,'TEST WITH MATRIX DH'
         USE_MATRIX = O_MATRIX
         prpty = blas_hermitian + blas_upper + INDEX_BASE
         allocate(xc(3),yc(3))
         call zuscr_begin(DT_m,DT_n,dt,istat)
         call ussp(dt,prpty,istat)
         call  uscr_insert_entries(dt,VAL_DT,INDX_DT,JNDX_DT,istat)
         call uscr_end(dt,istat )
         do i=1,size(xc)
            xc(i) = (1.,1.)
         end do
         allocate(zc(size(xc)))
         zc = xc
         yc = (0.,0.)
         allocate(densec_C(size(yc),3),densec_B(size(xc),3))

         do i = 1,3
            densec_B(:,i) = xc
            densec_C(:,i) = (0.,0.)
         end do
         write(*,*) '* Test of MV multiplication *'
         select case(USE_MATRIX)
      case (O_MATRIX)
         call usmv(dt,xc,yc,istat)
      case (T_MATRIX)
         call usmv(dt,xc,yc,istat, transa = TRANSP_MATRIX)
      case (H_MATRIX)
         call usmv(dt,xc,yc,istat, transa = HERMIT_MATRIX)
      case default
         stop 'No valid choice'
      end select
      if (istat.ne.0) then
         write(*,*) 'Can''t  perform MV multiplication'
         stop
      end if
      write(*,*) 'Errors of computed solution: '
      if(USE_MATRIX.eq.O_MATRIX) then
         write(*,*) 'Error : ',abs(yc-dx)
      else if(USE_MATRIX.eq.T_MATRIX) then
         write(*,*) 'Error : ',abs(yc-DTHx)
      else if(USE_MATRIX.eq.H_MATRIX) then
         write(*,*) 'Error : ',abs(yc-DTHx)
      end if
      write(*,*) '* Test of MM multiplication *'
      select case(USE_MATRIX)
      case (O_MATRIX)
         call usmm(dt,densec_B,densec_C,istat)
      case (T_MATRIX)
         call usmm(dt,densec_B,densec_C,istat, transa = TRANSP_MATRIX)
      case (H_MATRIX)
         call usmm(dt,densec_B,densec_C,istat, transa = HERMIT_MATRIX)
      case default
         stop 'No valid choice'
      end select
      if (istat.ne.0) then
         write(*,*) 'Can''t  perform MM multiplication'
         stop
      end if
      write(*,*) 'Errors of computed solution: '
      if(USE_MATRIX.eq.O_MATRIX) then
         write(*,*) 'Error : ',(abs(densec_C(:,i)-dx),i=1,3)
      else if(USE_MATRIX.eq.T_MATRIX) then
         write(*,*) 'Error : ',(abs(densec_C(:,i)-DTHx),i=1,3)
      else if(USE_MATRIX.eq.H_MATRIX) then
         write(*,*) 'Error : ',(abs(densec_C(:,i)-DTHx),i=1,3)
      end if
  write(*,*) '*****************************'
      write(*,*) '* Deleting matrix handle    *'
      call usds(dt,istat)
 deallocate(xc,yc,zc,densec_C,densec_B)
  ! **********************************************************************

        print *,'*********************************************************'
         print *,'TEST WITH MATRIX I'
         prpty = blas_general + INDEX_BASE
         allocate(x_i(5),y_i(5))
         y_i=0
         call iuscr_begin(I_m,I_n,a,istat)
         call ussp(a,prpty,istat)
         do i=1,size(I_val)
            call uscr_insert_entry(a,I_val(i),I_indx(i),I_jndx(i),istat)
         end do
         call uscr_end(a,istat )
         do i=1,size(x_i)
            x_i(i) = int(i)
         end do
         allocate(z_i(size(x_i)))
         z_i = x_i
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x_i,y_i,istat)
         write(*,*) 'Error : ',abs(y_i-Ix)
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x_i,y_i,z_i)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if

  ! **********************************************************************
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX J'
         prpty = blas_upper_triangular + INDEX_BASE
         allocate(x_i(5),y_i(5))
         y_i=0
         call iuscr_begin(J_m,J_n,a,istat)
         call uscr_insert_entries(a,J_VAL,J_indx,J_jndx,istat)
         call ussp(a,prpty,istat)
         call uscr_end(a,istat )
         do i=1,size(x_i)
            x_i(i) = int(i)
         end do
         allocate(z_i(size(x_i)))
         z_i = x_i
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x_i,y_i,istat)
         write(*,*) 'Error : ',abs(y_i-Jx)
         write(*,*) '* Test of tri. vec. solver  *'
         call ussv(a,y_i,istat)
         if (istat.ne.0) then
            write(*,*) 'Can''t  perform triangular solve'
            stop
         else
            write(*,*) 'Errors of computed solution: '
            write(*,*) 'Error : ',abs(y_i-x_i)
         end if
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x_i,y_i,z_i)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if

  ! **********************************************************************
       print *,'*********************************************************'
        print *,'TEST WITH MATRIX M'
        prpty = blas_upper_triangular + INDEX_BASE + BLOCK_INTERN
        allocate(x(4),y(4))
         y=0.
        call duscr_block_begin(M_Mb,M_Nb,M_k,M_l,a,istat)
        call ussp(a,prpty,istat)
        call uscr_insert_block(a,M11,1,1,istat)
        call uscr_insert_block(a,M12,1,2,istat)
        call uscr_insert_block(a,M22,2,2,istat)
        call uscr_end(a,istat )
        do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x,y,istat)
         write(*,*) 'Error : ',abs(y-Mx)
         write(*,*) '* Test of MM multiplication *'
         call usmm(a,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-Mx),i=1,3)
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if
  ! **********************************************************************
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX N'
        prpty = blas_lower_triangular + INDEX_BASE + BLOCK_INTERN
        allocate(x(4),y(4))
        y=0.
        call duscr_block_begin(N_Mb,N_Nb,N_k,N_l,a,istat)
        call ussp(a,prpty,istat)
        call uscr_insert_block(a,N11,1,1,istat)
        call uscr_insert_block(a,N21,2,1,istat)
        call uscr_insert_block(a,N22,2,2,istat)
        call uscr_end(a,istat )
        do i=1,size(x)
           x(i) = dble(i)
        end do
        allocate(z(size(x)))
        z = x
        allocate(dense_C(size(y),3),dense_B(size(x),3))
        do i = 1,3
           dense_B(:,i) = x
           dense_C(:,i) = 0.
        end do
        write(*,*) '* Test of MV multiplication *'
        call usmv(a,x,y,istat)
        write(*,*) 'Error : ',abs(y-Nx)
        write(*,*) '* Test of MM multiplication *'
        call usmm(a,dense_B,dense_C,istat)
        write(*,*) 'Error : ',(abs(dense_C(:,i)-Nx),i=1,3)
        write(*,*) '* Deleting matrix handle    *'
        deallocate(x,y,dense_C,dense_B,z)
        call usds(a, istat)
        if (istat.ne.0) then
           write(*,*) 'Deallocation failure'
           stop
        end if
  ! **********************************************************************
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX T'
         prpty = blas_upper_triangular + INDEX_BASE
         allocate(x(5),y(5))
         y=0.
         call duscr_begin(T_m,T_n,a,istat)
         call uscr_insert_entries(a,T_VAL,T_indx,T_jndx,istat)
         call ussp(a,prpty,istat)
         call uscr_end(a,istat )
         do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x,y,istat)
         write(*,*) 'Error : ',abs(y-Tx)
         write(*,*) '* Test of MM multiplication *'
         call usmm(a,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-Tx),i=1,3)
         write(*,*) '* Test of tri. vec. solver  *'
         call ussv(a,y,istat)
         if (istat.ne.0) then
            write(*,*) 'Can''t  perform triangular solve'
            stop
         else
            write(*,*) 'Errors of computed solution: '
            write(*,*) 'Error : ',abs(y-x)
         end if
         write(*,*) '* Testing tri. mat. solver  *'
         call ussm(a,dense_C,istat)
         if (istat.ne.0) then
            write(*,*) 'Can''t  perform triangular solve'
            stop
         else
            write(*,*) 'Errors of computed solution: '
            write(*,*) 'Error : ',abs(dense_C-dense_B)
         end if
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if
  ! **********************************************************************
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX U'
         prpty = blas_lower_triangular + INDEX_BASE
         allocate(x(5),y(5))
         y=0.
         call duscr_begin(U_m,U_n,a,istat)
         call ussp(a,prpty,istat)
         call uscr_insert_entries(a,U_VAL,U_indx,U_jndx,istat)
         call uscr_end(a,istat )
         do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x,y,istat)
         write(*,*) 'Error : ',abs(y-Ux)
         write(*,*) '* Test of MM multiplication *'
         call usmm(a,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-Ux),i=1,3)
         write(*,*) '* Test of tri. vec. solver  *'
         call ussv(a,y,istat)
         if (istat.ne.0) then
            write(*,*) 'Can''t  perform triangular solve'
            stop
         else
            write(*,*) 'Errors of computed solution: '
            write(*,*) 'Error : ',abs(y-x)
         end if
         write(*,*) '* Testing tri. mat. solver  *'
         call ussm(a,dense_C,istat)
         if (istat.ne.0) then
            write(*,*) 'Can''t  perform triangular solve'
            stop
         else
            write(*,*) 'Errors of computed solution: '
            write(*,*) 'Error : ',abs(dense_C-dense_B)
         end if
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if
  ! **********************************************************************
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX X'
         prpty = blas_general + INDEX_BASE + BLOCK_INTERN
         allocate(x(8),y(6))
         y=0.
         call duscr_block_begin(X_Mb,X_Nb,X_k,X_l,a,istat)
         call ussp(a,prpty,istat)
         call uscr_insert_block(a,X11,1,1,istat)
         call uscr_insert_block(a,X31,3,1,istat)
         call uscr_insert_block(a,X22,2,2,istat)
         call uscr_insert_block(a,X13,1,3,istat)
         call uscr_insert_block(a,X23,2,3,istat)
         call uscr_end(a,istat )
         do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x,y,istat)
         write(*,*) 'Error : ',abs(y-Xx)
         write(*,*) '* Test of MM multiplication *'
         call usmm(a,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-Xx),i=1,3)
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if
  ! **********************************************************************
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX Y'
         prpty = blas_general + INDEX_BASE + BLOCK_INTERN
         allocate(x(6),y(6))
         y=0.
         call duscr_block_begin(Y_Mb,Y_Nb,Y_k,Y_l,a,istat)
         call ussp(a,prpty,istat)
         call uscr_insert_block(a,Y11,1,1,istat)
         call uscr_insert_block(a,Y12,1,2,istat)
         call uscr_insert_block(a,Y22,2,2,istat)
         call uscr_insert_block(a,Y21,2,1,istat)
         call uscr_end(a,istat )
         do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x,y,istat)
         write(*,*) 'Error : ',abs(y-Yx)
         write(*,*) '* Test of MM multiplication *'
         call usmm(a,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-Yx),i=1,3)
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX Y_SU'
         prpty = blas_symmetric + INDEX_BASE+blas_upper+BLOCK_INTERN
         allocate(x(6),y(6))
         y=0.
         call duscr_block_begin(Y_SU_Mb,Y_SU_Nb,Y_SU_k,Y_SU_l,a,istat)
         call ussp(a,prpty,istat)
         call uscr_insert_block(a,Y_SU11,1,1,istat)
         call uscr_insert_block(a,Y_SU12,1,2,istat)
         call uscr_insert_block(a,Y_SU22,2,2,istat)
         call uscr_insert_block(a,Y_SU21,2,1,istat)
         call uscr_end(a,istat )
         do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x,y,istat)
         write(*,*) 'Error : ',abs(y-Y_SUx)
         write(*,*) '* Test of MM multiplication *'
         call usmm(a,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-Y_SUx),i=1,3)
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX Y_SL'
         prpty = blas_symmetric + INDEX_BASE+blas_lower+BLOCK_INTERN
         allocate(x(6),y(6))
         y=0.
         call duscr_block_begin(Y_SL_Mb,Y_SL_Nb,Y_SL_k,Y_SL_l,a,istat)
         call ussp(a,prpty,istat)
         call uscr_insert_block(a,Y_SL11,1,1,istat)
         call uscr_insert_block(a,Y_SL12,1,2,istat)
         call uscr_insert_block(a,Y_SL22,2,2,istat)
         call uscr_insert_block(a,Y_SL21,2,1,istat)
         call uscr_end(a,istat )
         do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x,y,istat)
         write(*,*) 'Error : ',abs(y-Y_SLx)
         write(*,*) '* Test of MM multiplication *'
         call usmm(a,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-Y_SLx),i=1,3)
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if
  ! **********************************************************************
        print *,'*********************************************************'
         print *,'TEST WITH MATRIX Z'
         prpty = blas_general + INDEX_BASE + BLOCK_INTERN
         allocate(x(11),y(11))
         y=0.
         call duscr_variable_block_begin(Z_Mb,Z_Nb,Z_kk,Z_ll,a,istat)
         call ussp(a,prpty,istat)
         call uscr_insert_block(a,Z11,1,1,istat)
         call uscr_insert_block(a,Z13,1,3,istat)
         call uscr_insert_block(a,Z22,2,2,istat)
         call uscr_insert_block(a,Z32,3,2,istat)
         call uscr_insert_block(a,Z23,2,3,istat)
         call uscr_insert_block(a,Z31,3,1,istat)
         call uscr_insert_block(a,Z33,3,3,istat)
         call uscr_insert_block(a,Z55,5,5,istat)
         call uscr_insert_block(a,Z44,4,4,istat)
         call uscr_insert_block(a,Z51,5,1,istat)
         call uscr_insert_block(a,Z15,1,5,istat)
         call uscr_insert_block(a,Z34,3,4,istat)
         call uscr_insert_block(a,Z43,4,3,istat)
         call uscr_end(a,istat )
         do i=1,size(x)
            x(i) = dble(i)
         end do
         allocate(z(size(x)))
         z = x
         allocate(dense_C(size(y),3),dense_B(size(x),3))
         do i = 1,3
            dense_B(:,i) = x
            dense_C(:,i) = 0.
         end do
         write(*,*) '* Test of MV multiplication *'
         call usmv(a,x,y,istat)
         write(*,*) 'Error : ',abs(y-Zx)
         write(*,*) '* Test of MM multiplication *'
         call usmm(a,dense_B,dense_C,istat)
         write(*,*) 'Error : ',(abs(dense_C(:,i)-Zx),i=1,3)
         write(*,*) '* Deleting matrix handle    *'
         deallocate(x,y,dense_C,dense_B,z)
         call usds(a, istat)
         if (istat.ne.0) then
            write(*,*) 'Deallocation failure'
            stop
         end if
  ! **********************************************************************

      write(*,*) '*****************************'
      write(*,*) '* REGULAR END OF PROGRAM    *'
      write(*,*) '*****************************'
      ierr=0

end program tester


subroutine system_setup
    use systemparams
    implicit none
    open(3,file = parameter_path, status='unknown')
    read(3,*) nx
    read(3,*) star_mass
    read(3,*) star_lum
    read(3,*) a
    read(3,*) e
    read(3,*) phi_peri
    read(3,*) angular_position
    read(3,*) period
    read(3,*) spin_obliquity
    read(3,*) azim_obliquity
    read(3,*) ocean_fraction
    read(3,*) initial_temp
    read(3,*) sim_time
    read(3,*) freq
    read(3,*) p
    close(3)
    allocate(T_old(nx+1))
    allocate(T(nx+1))
    allocate(tt(nx+1))
    allocate(x(nx+1))
    allocate(lat(nx+1))
    allocate(latdeg(nx+1))
    allocate(cos_H(nx+1))
    allocate(f_ice(nx+1))
    allocate(C_tot(nx+1))
    allocate(albedo(nx+1))
    allocate(insol(nx+1))
    allocate(tau_ir(nx+1))
    allocate(tau_ir_1(nx+1))
    allocate(tau_0(nx+1))
    allocate(infrared(nx+1))
    allocate(Q(nx+1))
    allocate(deltax(nx+1))
    allocate(hab(nx+1))
    dlat = pi/(1.0*nx)
    T(:) = initial_temp
    T_old(:) = T(:)
    time = 0.0
     do i=1,nx+1
        lat(i) = -pi/2.0 + (i-1)*dlat
        x(i) = sin(lat(i))
     end do
    latdeg(:) = lat(:)*180.0/pi
    deltax(:) = cos(lat(:))*dlat
    tt(:) = 0.0
    if(star_lum <= 0.0) star_lum = star_mass**4.0
    orb_period = sqrt(a*a*a/star_mass)
    orb_freq = 2.0*pi/(orb_period*year)
    h_ang = sqrt(star_mass*a*(1.0-e*e))
    phi_peri = phi_peri*pi/180.0
    spin_obliquity = spin_obliquity*pi/180.0
    azim_obliquity = azim_obliquity*pi/180.0
    angular_position = angular_position*pi/180.0
    r = a*(1.0-e*e)/(1.0+e*cos(angular_position-phi_peri))
    diff = D*period*period*(p/p0)
    if(ocean_fraction>1.0) ocean_fraction = 1.0
    if(ocean_fraction<0.0) ocean_fraction = 0.0
    f_land = 1.0-ocean_fraction
end subroutine system_setup