! Check how pips handle select with different kind of range in case
! Note also that the default isn't the last case
program main

    integer :: a, b
    a = 99;
    select case (a)
        case (:-10, 10:)
            b = 1
        case (-5:-3, 6:9)
            b = 2
        case default
            b = 6
        case (-2:2)
            b = 3
        case (3, 5)
            b = 4
        case (4)
            b = 5
    end select

end program main


! This gives incorrect results when compiled with
! the intel and pgf90 compilers
Program Strange

 Implicit None

 Type Link
 Integer, Dimension(2) :: Next
 End Type Link

 Integer, Parameter :: N = 2
 Integer, dimension (2, 4) :: results
 Integer :: i, j

 Type(Link), Dimension(:,:), Pointer :: Perm
 Integer, Dimension(2) :: Current

 Allocate (Perm(N,N))

! Print*, 'Spanned by indices'
 Do i = 1, N**2
    Perm(mod(i-1,N)+1, (i-1)/N+1)%Next = (/ Mod(i,N) + 1, Mod(i/N+1,N)+1/)
!    Write(*,100) mod(i-1,N)+1, (i-1)/N+1, Perm(mod(i-1,N)+1, (i-1)/N+1)%Next
! Expected output:
!  Spanned by indices
!  1 1---> 2 2
!  2 1---> 1 1
!  1 2---> 2 1
!  2 2---> 1 2
 End Do

! Print*, 'Spanned as a cycle'
 Current = (/1,1/)
 Do i = 1, n**2
   results (:, i) = Perm(Current(1), Current(2))%Next
!    Write(*,100) Current, Perm(Current(1), Current(2))%Next
! Expected output:
!  1 1---> 2 2
!  2 2---> 1 2
!  1 2---> 2 1
!  2 1---> 1 1
   Current = Perm(Current(1), Current(2))%Next
 End Do

 if (any(results .ne. reshape ((/2,2,1,2,2,1,1,1/), (/2, 4/)))) call abort

! 100 Format( 2I3, '--->', 2I3)
 DeAllocate (Perm)

End Program Strange


MODULE USR_SMlib_GMRES
  !
  !!  This module is part of SMLIB v. 1.1.  It contains procedures needed
  !!  to perform GMRES iterations to solve equations S x = b.  Currently
  !!  implemented is the CSR and the MSR sparse matrix storage.  Thanks to
  !!  prof. Y. Saad for granting access to his SPARSKIT FORTRAN77 code, making
  !!  me able to study details of his GMRES method.
  !
  !! ------------------------------------------------------------------------
  !
  !!  Copyright (C) 1996 Ernst A. Meese
  !!    Refer to the file copyright.doc for details and important disclaimer.
  !
  !!  Created: January 1996
  !!  Development version
  !
  !! ------------------------------------------------------------------------
  !!  Module contents
  !
  !!   Interfaces:
  !!      GMRES - Generic procedure for the GMRES algorithm.
  !
  !!   Procedures:
  !!      GMRES_P_MSR - Preconditioned GMRES for the MSR datastructure.
  !
  !! -----------------------------------------------------------------------
  !
  !!  We use the modules defining abstract datatypes for the matrices and
  !!  the module for features common for all iterative methods.
  !
  use USR_SMlib_Matrix_Arithmetic  !!((19-B-USR_SMlib_Matrix_Arithmetic.f90))
  use USR_SMlib_Iteration_Defaults !!((17-B-USR_SMlib_Iteration_Defaults.f90))

  IMPLICIT NONE

  INTERFACE GMRES
     MODULE PROCEDURE GMRES_MSR
  END INTERFACE

CONTAINS

  SUBROUTINE GMRES_MSR &
       (m, x, A, B, PC, init, tol, reduction_factor, min_it, max_it, INFO, no_of_its, &
       residual_norm, history)
    TYPE(MSR),        INTENT (IN) :: A
    TYPE(LU_CSR_MSR), INTENT (IN) :: PC
    INCLUDE "20-B-USR_SMlib_GMRES.f90.bdy"
  END SUBROUTINE GMRES_MSR

END MODULE USR_SMlib_GMRES


C
C
*+nearest_pt

      subroutine nearest_pt( x, y, a, n_pts, nearest, status )

C     Finds the nearest point in a given array.

C     Given:
C         Coordinates of given point
              integer     x, y
C         An array of cartesian positions and its size
              integer     n_pts, a(2,n_pts)

C     Returned:
C         Index in array of point nearest to the given one.
              integer     nearest
C     Error flag
              integer     status

C     If n_pts is less than 1 then nearest is returned as zero.
C-

      integer     i, distance, temp

      if (n_pts .le. 0) then
          nearest = 0
      else
          nearest  = 1
          distance = (x-a(1,1))*(x-a(1,1)) + (y-a(2,1))*(y-a(2,1))

          do i = 2, n_pts
              temp = (x-a(1,i))*(x-a(1,i))+(y-a(2,i))*(y-a(2,i))
              if (temp .lt. distance) then
                  distance = temp
                  nearest  = i
              end if
          end do
      end if

      return
      end


!Write by Liao Yuanda
!
!###############################################################

    subroutine calcu_H( L, N, M, H, t )

        implicit none
        integer :: L, N, M, i, j
        integer :: p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl
        complex*16  :: H(M, M)
		real*8 :: t

        H = 0.0

        do i = 0, L-1, 1
            do j = 0, L-1, 1
                p = i*L+j+1
                call triangular_nearest( p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L )

                H(p, p_i_pl) = -t
                H(p, p_i_mi) = -t
                H(p, p_j_pl) = -t
                H(p, p_j_mi) = -t
                H(p, p_i_pl_j_mi) = -t
                H(p, p_i_mi_j_pl) = -t

                H(p+N, p_i_pl+N) = -t
                H(p+N, p_i_mi+N) = -t
                H(p+N, p_j_pl+N) = -t
                H(p+N, p_j_mi+N) = -t
                H(p+N, p_i_pl_j_mi+N) = -t
                H(p+N, p_i_mi_j_pl+N) = -t
            end do
        end do
    end subroutine calcu_H

program skyrmionlattice
  	use globle_vab
    implicit none
    !#########################################
    !L, size of lattice
    !N = L*L, num of lattice
    !##########################################
    integer, parameter :: L = 60, N = L*L, M = 2*N, nonzeros = 7*M, cutoff = 100, num_x = 100
    real*8, parameter :: t = 1.0
    integer, dimension(nonzeros) :: colind
    integer, dimension(M+1) :: rowptr
    complex*16, dimension(nonzeros) :: values
    complex*16, allocatable :: H(:,:)
	real*8, dimension(cutoff) :: miun_pem
	!real*8, dimension(num_x) :: stateden_pem_integral
    !real*8, dimension(cutoff) :: miun_tpem, miun_pem, miun_ev
    !real*8, dimension(M) :: eigv
    !real*8, dimension(num_x) :: stateden_ev, stateden_pem
    integer :: i, j, interval
    real*8 :: weight, t1, t2

    Emax = 3*t
    Emin = -6*t
    a = (Emax-Emin)/2.0
    b = (Emax+Emin)/2.0
    !##########################
    call cpu_time(t1)
    write(*,*) 'Begin at:', t1
    !######################
	!interval = 100

	!open(unit = 15, file = 'eigv.in')
    open(unit = 14, file = 'miun_pem.out')
	!open(unit = 13, file = 'dos_ev.out')
	!open(unit = 17, file = 'dos_pem.out')
	!open(unit = 18, file = 'dos_pem_integral.out')
	!do i = 1, M
	!	read(15,*) eigv(i)
	!end do
	!close(15)
    allocate(H(M,M))
    call calcu_H( L, N, M, H, t )
    call pem_sparse( H, values, colind, rowptr, M, nonzeros)
    deallocate(H)
	!write(*,*) 1
	!call pem_statedensity( num_x, cutoff, M, nonzeros, val1, val2, colind, rowptr, stateden_pem )
	!call pem_statedensity_integral( num_x, interval, cutoff, M, nonzeros, val1, val2, colind, rowptr, stateden_pem_integral)
	!call pem_particle_density( cutoff, M, nonzeros, val1, val2, colind, rowptr, beta, miu, a, b, weight )
	call pem_calculate_moments(cutoff, M, nonzeros, values, colind, rowptr, miun_pem)
	!call pem_logweight( cutoff, M, nonzeros, val1, val2, colind, rowptr, 0.0, 0.0, a, b, weight )
	!call pem_test( cutoff, M, nonzeros, val1, val2, colind, rowptr, miun_tpem, miun_pem, miun_ev, eigv)
	!call pem_ev_dos( cutoff, num_x, M, eigv, stateden_ev)
	!write(*,*) weight
    !do i = 1, num_x
		!write(13,*) stateden_ev(i)
		!write(17,*) stateden_pem(i)
		!write(18,*) stateden_pem_integral(i)
    !end do
	!write(*,*) weight
    do i = 1, cutoff
		!write(14,*) miun_tpem(i),miun_pem(i),miun_ev(i)
		write(14,*) miun_pem(i)
    end do
    !close(14)
    !close(13)
    !close(17)
    !close(18)
    !##########################
    call cpu_time(t2)
    write(*,*) 'End at:', t2
    !######################
    write(*,*) 'Timecost:', t2-t1
end program skyrmionlattice


      subroutine difequ ( mode, xx, v )
c  from  * a practical guide to splines *  by c. de boor
calls  ppvalu(interv)
c  to be called by   c o l l o c ,  p u t i t
c  information about the differential equation is dispensed from here
c
c******  i n p u t  ******
c  mode  an integer indicating the task to be performed.
c	 = 1   initialization
c	 = 2   evaluate  de  at  xx
c	 = 3   specify the next side condition
c	 = 4   analyze the approximation
c  xx a point at which information is wanted
c
c******  o u t p u t  ******
c  v  depends on the  mode  . see comments below
c
c     parameter npiece=100,ncoef=2000
      integer mode,   i,iside,itermx,k,kpm,l,m
      real v(20),xx,   break,coef,eps,ep1,ep2,error,factor,rho,solutn
     *		      ,s2ovep,un,x,xside
      real ppvalu
c     common /approx/ break(npiece),coef(ncoef),l,kpm
      common /approx/ break(100),coef(2000),l,kpm
      common /side/ m,iside,xside(10)
      common /other/ itermx,k,rho(19)
c
c  this sample of  difequ  is for the example in chapter xv. it is a
c  nonlinear second order two point boundary value problem.
c
					go to (10,20,30,40),mode
c  initialize everything
c  i.e. set the order  m  of the dif.equ., the nondecreasing sequence
c  xside(i),i=1,...,m, of points at which side cond.s are given and
c  anything else necessary.
   10 m = 2
      xside(1) = 0.
      xside(2) = 1.
c  *** print out heading
      print 499
  499 format(37h carrier,s nonlinear perturb. problem)
      eps = .5e-2
      print 610, eps
  610 format(5h eps ,e20.10)
c  *** set constants used in formula for solution below.
      factor = (sqrt(2.) + sqrt(3.))**2
      s2ovep = sqrt(2./eps)
c  *** initial guess for newton iteration. un(x) = x*x - 1.
      l = 1
      break(1) = 0.
      do 16 i=1,kpm
   16	 coef(i) = 0.
      coef(1) = -1.
      coef(3) = 2.
      itermx = 10
					return
c
c  provide value of left side coeff.s and right side at  xx .
c  specifically, at  xx  the dif.equ. reads
c	 v(m+1)d**m + v(m)d**(m-1) + ... + v(1)d**0  =	v(m+2)
c  in terms of the quantities v(i),i=1,...,m+2, to be computed here.
   20 continue
      v(3) = eps
      v(2) = 0.
      un = ppvalu(break,coef,l,kpm,xx,0)
      v(1) = 2.*un
      v(4) = un**2 + 1.
					return
c
c  provide the	m  side conditions. these conditions are of the form
c	 v(m+1)d**m + v(m)d**(m-1) + ... + v(1)d**0  =	v(m+2)
c  in terms of the quantities v(i),i=1,...,m+2, to be specified here.
c  note that v(m+1) = 0  for customary side conditions.
   30 v(m+1) = 0.
					go to (31,32,39),iside
   31 v(2) = 1.
      v(1) = 0.
      v(4) = 0.
					go to 38
   32 v(2) = 0.
      v(1) = 1.
      v(4) = 0.
   38 iside = iside + 1
   39					return
c
c  calculate the error near the boundary layer at  1.
   40 continue
      print 640
  640 format(44h x, g(x)  and  g(x)-f(x)  at selected points)
      x = .75
      do 41 i=1,9
	 ep1 = exp(s2ovep*(1.-x))*factor
	 ep2 = exp(s2ovep*(1.+x))*factor
	 solutn = 12./(1.+ep1)**2*ep1 + 12./(1.+ep2)**2*ep2 - 1.
	 error = solutn - ppvalu(break,coef,l,kpm,x,0)
	 print 641,x,solutn,error
  641	 format(3e20.10)
   41	 x = x + .03125
					return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

        subroutine verify(no_time_steps, class, verified)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c  verification routine
c---------------------------------------------------------------------

        include 'header.h'
        include 'mpinpb.h'

        double precision xcrref(5),xceref(5),xcrdif(5),xcedif(5),
     >                   epsilon, xce(5), xcr(5), dtref
        integer m, no_time_steps
        character class
        logical verified

c---------------------------------------------------------------------
c   tolerance level
c---------------------------------------------------------------------
        epsilon = 1.0d-08

c---------------------------------------------------------------------
c   compute the error norm and the residual norm, and exit if not printing
c---------------------------------------------------------------------
        call error_norm(xce)
        call copy_faces

        call rhs_norm(xcr)

        do m = 1, 5
           xcr(m) = xcr(m) / dt
        enddo

        if (node .ne. 0) return

        class = 'U'
        verified = .true.

        do m = 1,5
           xcrref(m) = 1.0
           xceref(m) = 1.0
        end do

c---------------------------------------------------------------------
c    reference data for 12X12X12 grids after 100 time steps, with DT = 1.50d-02
c---------------------------------------------------------------------
        if ( (grid_points(1)  .eq. 12     ) .and.
     >       (grid_points(2)  .eq. 12     ) .and.
     >       (grid_points(3)  .eq. 12     ) .and.
     >       (no_time_steps   .eq. 100    ))  then

           class = 'S'
           dtref = 1.5d-2

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 2.7470315451339479d-02
           xcrref(2) = 1.0360746705285417d-02
           xcrref(3) = 1.6235745065095532d-02
           xcrref(4) = 1.5840557224455615d-02
           xcrref(5) = 3.4849040609362460d-02

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 2.7289258557377227d-05
           xceref(2) = 1.0364446640837285d-05
           xceref(3) = 1.6154798287166471d-05
           xceref(4) = 1.5750704994480102d-05
           xceref(5) = 3.4177666183390531d-05

c---------------------------------------------------------------------
c    reference data for 36X36X36 grids after 400 time steps, with DT = 1.5d-03
c---------------------------------------------------------------------
        elseif ( (grid_points(1) .eq. 36) .and.
     >           (grid_points(2) .eq. 36) .and.
     >           (grid_points(3) .eq. 36) .and.
     >           (no_time_steps . eq. 400) ) then

           class = 'W'
           dtref = 1.5d-3

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.1893253733584d-02
           xcrref(2) = 0.1717075447775d-03
           xcrref(3) = 0.2778153350936d-03
           xcrref(4) = 0.2887475409984d-03
           xcrref(5) = 0.3143611161242d-02

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.7542088599534d-04
           xceref(2) = 0.6512852253086d-05
           xceref(3) = 0.1049092285688d-04
           xceref(4) = 0.1128838671535d-04
           xceref(5) = 0.1212845639773d-03

c---------------------------------------------------------------------
c    reference data for 64X64X64 grids after 400 time steps, with DT = 1.5d-03
c---------------------------------------------------------------------
        elseif ( (grid_points(1) .eq. 64) .and.
     >           (grid_points(2) .eq. 64) .and.
     >           (grid_points(3) .eq. 64) .and.
     >           (no_time_steps . eq. 400) ) then

           class = 'A'
           dtref = 1.5d-3

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 2.4799822399300195d0
           xcrref(2) = 1.1276337964368832d0
           xcrref(3) = 1.5028977888770491d0
           xcrref(4) = 1.4217816211695179d0
           xcrref(5) = 2.1292113035138280d0

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 1.0900140297820550d-04
           xceref(2) = 3.7343951769282091d-05
           xceref(3) = 5.0092785406541633d-05
           xceref(4) = 4.7671093939528255d-05
           xceref(5) = 1.3621613399213001d-04

c---------------------------------------------------------------------
c    reference data for 102X102X102 grids after 400 time steps,
c    with DT = 1.0d-03
c---------------------------------------------------------------------
        elseif ( (grid_points(1) .eq. 102) .and.
     >           (grid_points(2) .eq. 102) .and.
     >           (grid_points(3) .eq. 102) .and.
     >           (no_time_steps . eq. 400) ) then

           class = 'B'
           dtref = 1.0d-3

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.6903293579998d+02
           xcrref(2) = 0.3095134488084d+02
           xcrref(3) = 0.4103336647017d+02
           xcrref(4) = 0.3864769009604d+02
           xcrref(5) = 0.5643482272596d+02

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.9810006190188d-02
           xceref(2) = 0.1022827905670d-02
           xceref(3) = 0.1720597911692d-02
           xceref(4) = 0.1694479428231d-02
           xceref(5) = 0.1847456263981d-01

c---------------------------------------------------------------------
c    reference data for 162X162X162 grids after 400 time steps,
c    with DT = 0.67d-03
c---------------------------------------------------------------------
        elseif ( (grid_points(1) .eq. 162) .and.
     >           (grid_points(2) .eq. 162) .and.
     >           (grid_points(3) .eq. 162) .and.
     >           (no_time_steps . eq. 400) ) then

           class = 'C'
           dtref = 0.67d-3

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.5881691581829d+03
           xcrref(2) = 0.2454417603569d+03
           xcrref(3) = 0.3293829191851d+03
           xcrref(4) = 0.3081924971891d+03
           xcrref(5) = 0.4597223799176d+03

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.2598120500183d+00
           xceref(2) = 0.2590888922315d-01
           xceref(3) = 0.5132886416320d-01
           xceref(4) = 0.4806073419454d-01
           xceref(5) = 0.5483377491301d+00
c---------------------------------------------------------------------
c    reference data for 408X408X408 grids after 400 time steps,
c    with DT = 0.3d-03
c---------------------------------------------------------------------
        elseif ( (grid_points(1) .eq. 408) .and.
     >           (grid_points(2) .eq. 408) .and.
     >           (grid_points(3) .eq. 408) .and.
     >           (no_time_steps . eq. 500) ) then

           class = 'D'
           dtref = 0.30d-3

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.1044696216887d+05
           xcrref(2) = 0.3204427762578d+04
           xcrref(3) = 0.4648680733032d+04
           xcrref(4) = 0.4238923283697d+04
           xcrref(5) = 0.7588412036136d+04

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.5089471423669d+01
           xceref(2) = 0.5323514855894d+00
           xceref(3) = 0.1187051008971d+01
           xceref(4) = 0.1083734951938d+01
           xceref(5) = 0.1164108338568d+02

        else
           verified = .false.
        endif

c---------------------------------------------------------------------
c    verification test for residuals if gridsize is either 12X12X12 or
c    64X64X64 or 102X102X102 or 162X162X162 or 408X408X408
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c    Compute the difference of solution values and the known reference values.
c---------------------------------------------------------------------
        do m = 1, 5

           xcrdif(m) = dabs((xcr(m)-xcrref(m))/xcrref(m))
           xcedif(m) = dabs((xce(m)-xceref(m))/xceref(m))

        enddo

c---------------------------------------------------------------------
c    Output the comparison of computed results to known cases.
c---------------------------------------------------------------------

        if (class .ne. 'U') then
           write(*, 1990) class
 1990      format(' Verification being performed for class ', a)
           write (*,2000) epsilon
 2000      format(' accuracy setting for epsilon = ', E20.13)
           if (dabs(dt-dtref) .gt. epsilon) then
              verified = .false.
              class = 'U'
              write (*,1000) dtref
 1000         format(' DT does not match the reference value of ',
     >                 E15.8)
           endif
        else
           write(*, 1995)
 1995      format(' Unknown class')
        endif

        if (class .ne. 'U') then
           write (*,2001)
        else
           write (*, 2005)
        endif

 2001   format(' Comparison of RMS-norms of residual')
 2005   format(' RMS-norms of residual')
        do m = 1, 5
           if (class .eq. 'U') then
              write(*, 2015) m, xcr(m)
           else if (xcrdif(m) .le. epsilon) then
              write (*,2011) m,xcr(m),xcrref(m),xcrdif(m)
           else
              verified = .false.
              write (*,2010) m,xcr(m),xcrref(m),xcrdif(m)
           endif
        enddo

        if (class .ne. 'U') then
           write (*,2002)
        else
           write (*,2006)
        endif
 2002   format(' Comparison of RMS-norms of solution error')
 2006   format(' RMS-norms of solution error')

        do m = 1, 5
           if (class .eq. 'U') then
              write(*, 2015) m, xce(m)
           else if (xcedif(m) .le. epsilon) then
              write (*,2011) m,xce(m),xceref(m),xcedif(m)
           else
              verified = .false.
              write (*,2010) m,xce(m),xceref(m),xcedif(m)
           endif
        enddo

 2010   format(' FAILURE: ', i2, E20.13, E20.13, E20.13)
 2011   format('          ', i2, E20.13, E20.13, E20.13)
 2015   format('          ', i2, E20.13)

        if (class .eq. 'U') then
           write(*, 2022)
           write(*, 2023)
 2022      format(' No reference values provided')
 2023      format(' No verification performed')
        else if (verified) then
           write(*, 2020)
 2020      format(' Verification Successful')
        else
           write(*, 2021)
 2021      format(' Verification failed')
        endif

        return

        end


      SUBROUTINE PROD (ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,Y,M,A,B,C,D,W,U)
C
C PROD APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN Y
C BD,BM1,BM2 ARE ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS
C ND,NM1,NM2 ARE THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY
C AA   ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X
C NA IS THE LENGTH OF THE ARRAY AA
C X,Y  THE MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS Y
C A,B,C  ARE ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX
C M  IS THE ORDER OF THE MATRIX
C D,W,U ARE WORKING ARRAYS
C IS  DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE
C
      DIMENSION       A(1)       ,B(1)       ,C(1)       ,X(1)       ,
     1                Y(1)       ,D(1)       ,W(1)       ,BD(1)      ,
     2                BM1(1)     ,BM2(1)     ,AA(1)      ,U(1)
      DO 101 J=1,M
         W(J) = X(J)
         Y(J) = W(J)
  101 CONTINUE
      MM = M-1
      ID = ND
      IBR = 0
      M1 = NM1
      M2 = NM2
      IA = NA
  102 IF (IA) 105,105,103
  103 RT = AA(IA)
      IF (ND .EQ. 0) RT = -RT
      IA = IA-1
C
C SCALAR MULTIPLICATION
C
      DO 104 J=1,M
         Y(J) = RT*W(J)
  104 CONTINUE
  105 IF (ID) 125,125,106
  106 RT = BD(ID)
      ID = ID-1
      IF (ID .EQ. 0) IBR = 1
C
C BEGIN SOLUTION TO SYSTEM
C
      D(M) = A(M)/(B(M)-RT)
      W(M) = Y(M)/(B(M)-RT)
      DO 107 J=2,MM
         K = M-J
         DEN = B(K+1)-RT-C(K+1)*D(K+2)
         D(K+1) = A(K+1)/DEN
         W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN
  107 CONTINUE
      DEN = B(1)-RT-C(1)*D(2)
      W(1) = 1.
      IF (DEN) 108,109,108
  108 W(1) = (Y(1)-C(1)*W(2))/DEN
  109 DO 110 J=2,M
         W(J) = W(J)-D(J)*W(J-1)
  110 CONTINUE
      IF (NA) 113,113,102
  111 DO 112 J=1,M
         Y(J) = W(J)
  112 CONTINUE
      IBR = 1
      GO TO 102
  113 IF (M1) 114,114,115
  114 IF (M2) 111,111,120
  115 IF (M2) 117,117,116
  116 IF (ABS(BM1(M1))-ABS(BM2(M2))) 120,120,117
  117 IF (IBR) 118,118,119
  118 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 111,119,119
  119 RT = RT-BM1(M1)
      M1 = M1-1
      GO TO 123
  120 IF (IBR) 121,121,122
  121 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 111,122,122
  122 RT = RT-BM2(M2)
      M2 = M2-1
  123 DO 124 J=1,M
         Y(J) = Y(J)+RT*W(J)
  124 CONTINUE
      GO TO 102
  125 RETURN
      END


      subroutine pderhs(t)
************************************************************************
*
*   PDERHS -- RHS inner products on elements.
*
*   RHS inner products for the single carrier semiconductor equations
*   where the hole density is given by p = exp(SCF*U) and the voltage
*   is v = VSCF*V.  The equations for U and V are
*
*      dU/dt = Grad(U)*(VSCF*Grad(V) + LAMBDA*USCF*Grad(U))
*
*               + (1 - exp(USCF*U))/USCF + LAMBDA*Lapl(U)
*
*      dV/dt = (1/EPS)*(Lapl(V) - (1 - exp(USCF*U))/VSCF)
*
*   LAMBDA and EPS are parameters and USCF and VSCF are scaling factors.
*
************************************************************************
      include "parameters.h"

      double precision wpde
      integer nnod,nelt
      common /mfe010/ nnod,nelt /mfe020/ wpde(npde)

      double precision lambda0,eps,uscf,vscf,usera
      common /mfe100/ lambda0,eps,uscf,vscf,usera(21)

      double precision u0,x0,u1,x1
      common /loc10/ u0(mnod,npde),x0(mnod),u1(mnod,npde),x1(mnod)

      double precision gu0,gx0,gu1,gx1
      common /loc12/ gu0(mnod,npde),gx0(mnod),gu1(mnod,npde),gx1(mnod)

      double precision l,n1,n2,du,dx
      common /loc30/ l(mnod,npde),n1(mnod,npde),n2(mnod,npde)
      common /loc31/ du(mnod,npde),dx(mnod)

      double precision g3w,g3a0,g3a1
      common /g1d3/ g3w(3),g3a0(3),g3a1(3)

      integer j
      double precision t,c1,c2,c3,c4,pa0,pa1,term1,term2,lambda

      if(t .le. 40.d0) then
       lambda = lambda0
      else
       lambda = lambda0 / 10.**((t-40.)/100.)
      end if

      c1 = .5*wpde(1)*vscf
      c2 = .5*wpde(1)*uscf*lambda
      c3 = wpde(1)/uscf
      c4 = -wpde(2)/(eps*vscf)

      do 10 j=1,nelt
*      =================================================================
*       Average of p*alphas by 3 pt Gauss quadrature.
*      =================================================================
       pa0 = g3w(1)*g3a0(1)*exp(uscf*(g3a0(1)*u0(j,1)+g3a1(1)*u1(j,1)))
     +     + g3w(2)*g3a0(2)*exp(uscf*(g3a0(2)*u0(j,1)+g3a1(2)*u1(j,1)))
     +     + g3w(3)*g3a0(3)*exp(uscf*(g3a0(3)*u0(j,1)+g3a1(3)*u1(j,1)))

       pa1 = g3w(1)*g3a1(1)*exp(uscf*(g3a0(1)*u0(j,1)+g3a1(1)*u1(j,1)))
     +     + g3w(2)*g3a1(2)*exp(uscf*(g3a0(2)*u0(j,1)+g3a1(2)*u1(j,1)))
     +     + g3w(3)*g3a1(3)*exp(uscf*(g3a0(3)*u0(j,1)+g3a1(3)*u1(j,1)))
*      =================================================================
*       Load the inner products.
*      =================================================================
       term1 = du(j,1)*(c1*du(j,2) + c2*du(j,1))/dx(j)
       term2 = dx(j)*(.5 - pa0)
       gx0(j) = (term1 + c3*term2)*n1(j,1) + (c4*term2)*n1(j,2)
       gu0(j,1) = (term1 + c3*term2)*n2(j,1)
       gu0(j,2) = (c4*term2)*n2(j,2)

       term2 = dx(j)*(.5 - pa1)
       gx1(j) = (term1 + c3*term2)*n1(j,1) + (c4*term2)*n1(j,2)
       gu1(j,1) = (term1 + c3*term2)*n2(j,1)
       gu1(j,2) = (c4*term2)*n2(j,2)
   10 continue

      call lapl(1,lambda)
      call lapl(2,1.d0/eps)

      return
      end
      block data
************************************************************************
*
*   Quadrature formula:
*
*   G1D3 -- 3 point 1D Gaussian quadrature formula.  Fifth order
*   accurate.  The weights are g3w(.) and the corresponding quadrature
*   points are (g3a0(.), g3a1(.)) given as the isoparametric coordinates
*   (alpha_0, alpha_1) of the interval.
*
************************************************************************
      double precision g3w,g3a0,g3a1
      common /g1d3/ g3w(3),g3a0(3),g3a1(3)

      integer k

      data g3w/
     + 2.77777777777778d-1,4.44444444444444d-1,2.77777777777778d-1/
      data (g3a0(k),g3a1(k),k=1,3)/
     + 1.12701665379259d-1, 8.87298334620741d-1,
     + 5.00000000000000d-1, 5.00000000000000d-1,
     + 8.87298334620741d-1, 1.12701665379259d-1/

      end


C
C $Id: tdprpt.f,v 1.5 2008-07-27 00:17:33 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE TDPRPT (XI3D,YI3D,ZI3D,XI2D,YI2D)
C
C This routine finds the image of the point (XI3D,YI3D,ZI3D) in the
C image plane and returns in XI2D and YI2D the distances of that point
C from each of two planes perpendicular to the image plane, which are
C the desired X and Y coordinates in the image plane.
C
C The variables in the following common block define the mapping from
C 3-space to 2-space.
C
        COMMON /TDCOM1/ IH,IT,XM,YM,ZM,XO,YO,ZO,XT,YT,ZT,OE,XE,YE,ZE
        COMMON /TDCOM1/ A1,B1,C1,D1,E1,A2,B2,C2,D2,E2,A3,B3,C3,D3,E3
        COMMON /TDCOM1/ IS,FV,VL,VR,VB,VT,WL,WR,WB,WT
        SAVE   /TDCOM1/
C
C Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
        CALL TDBLDA
C
C Check for an uncleared prior error.
C
        IF (ICFELL('TDPRPT - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C What's involved is just algebra.
C
        DX=XI3D-XE
        DY=YI3D-YE
        DZ=ZI3D-ZE
C
        TT=-E1/(A1*DX+B1*DY+C1*DZ)
C
        XP=XE+DX*TT
        YP=YE+DY*TT
        ZP=ZE+DZ*TT
C
        XI2D=A2*XP+B2*YP+C2*ZP+D2
        YI2D=A3*XP+B3*YP+C3*ZP+D3
C
C Done.
C
        RETURN
C
      END


module scalar_advance_module

  use bl_types
  use bl_constants_module
  use multifab_module
  use ml_layout_module
  use define_bc_module

  implicit none

  private

  public :: scalar_advance

contains

  subroutine scalar_advance(mla,sold,snew,umac, &
                            ext_scal_force,dx,dt,the_bc_tower)

    use explicit_diffusive_module, only : get_explicit_diffusive_term
    use viscous_module           , only : diff_scalar_solve
    use update_module            , only : update
    use mkflux_module            , only : mkflux
    use mkforce_module           , only : mkscalforce
    use probin_module            , only : nscal, diff_coef, diffusion_type, &
                                          stencil_order, verbose, mg_verbose, cg_verbose

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(in   ) :: sold(:)
    type(multifab) , intent(inout) :: snew(:)
    type(multifab) , intent(in   ) :: umac(:,:)
    type(multifab) , intent(in   ) :: ext_scal_force(:)
    real(kind=dp_t), intent(in   ) :: dx(:,:),dt
    type(bc_tower) , intent(in   ) :: the_bc_tower

    ! local variables
    type(multifab) :: scal_force(mla%nlevel)
    type(multifab) :: divu(mla%nlevel)
    type(multifab) :: laps(mla%nlevel)
    type(multifab) :: sflux(mla%nlevel,mla%dim)
    type(multifab) :: sedge(mla%nlevel,mla%dim)

    logical :: is_conservative(nscal)

    integer         :: i,n
    integer         :: comp,bc_comp,nlevs,dm
    logical         :: is_vel
    real(kind=dp_t) :: diff_fac,visc_mu
    real(kind=dp_t) :: smin,smax

    nlevs = mla%nlevel
    dm    = mla%dim

    is_conservative(1) = .true.
    do comp = 2, nscal
      is_conservative(comp) = .false.
    end do

    is_vel  = .false.

    do n = 1, nlevs
       call multifab_build( scal_force(n),ext_scal_force(n)%la,nscal,1)
       call multifab_build( divu(n),mla%la(n),    1,1)
       call multifab_build( laps(n),mla%la(n),nscal,0)
       do i = 1,dm
         call multifab_build_edge(sflux(n,i),scal_force(n)%la,nscal,0,i)
         call multifab_build_edge(sedge(n,i),scal_force(n)%la,nscal,0,i)
         call setval(sflux(n,i),ZERO,all=.true.)
         call setval(sedge(n,i),ZERO,all=.true.)
       end do

       call setval(scal_force(n),0.0_dp_t,all=.true.)
       call setval(divu(n),0.0_dp_t,all=.true.)
       call setval(laps(n),0.0_dp_t,all=.true.)
    enddo

    !***********************************
    ! Compute laps for passive scalar only
    !***********************************
    if (diff_coef .gt. ZERO) then
       do comp = 2, nscal
          bc_comp = dm+comp
          call get_explicit_diffusive_term(mla,laps,sold,comp,bc_comp,dx,the_bc_tower)
       end do
    else
      do n = 1, nlevs
         call setval(laps(n),ZERO,all=.true.)
      enddo
    endif

    !***********************************
    ! Create scalar force at time n.
    !***********************************

    diff_fac = ONE
    call mkscalforce(mla,scal_force,ext_scal_force,laps,diff_fac,the_bc_tower)

    !***********************************
    ! Create edge state scalars/fluxes
    !***********************************

    call mkflux(mla,sold,sedge,sflux,umac,scal_force,divu,dx,dt, &
                the_bc_tower%bc_tower_array,is_vel,is_conservative)

    !***********************************
    ! Create scalar force at time n+1/2.
    !***********************************

    ! The laps term will be added to the rhs in diff_scalar_solve
    ! for Crank-Nicolson
    diff_fac = ZERO
    call mkscalforce(mla,scal_force,ext_scal_force,laps,diff_fac,the_bc_tower)

    !***********************************
    ! Update the scalars with conservative or convective differencing.
    !***********************************

    call update(mla,sold,umac,sedge,sflux,scal_force,snew,dx,dt,is_vel, &
                is_conservative,the_bc_tower%bc_tower_array)

    if (verbose .ge. 1) then
       do n = 1, nlevs
          do comp = 1, nscal
             smin = multifab_min_c(snew(n),comp)
             smax = multifab_max_c(snew(n),comp)
             if (comp .eq. 1) then
                if (parallel_IOProcessor()) write(6,2000) n,smin,smax
             else if (comp .eq. 2) then
                if (parallel_IOProcessor()) write(6,2001) n,smin,smax
             end if
          end do
       end do
    end if

    do n = 1,nlevs
       call multifab_destroy(scal_force(n))
       call multifab_destroy(divu(n))
       do i = 1,dm
         call multifab_destroy(sflux(n,i))
         call multifab_destroy(sedge(n,i))
       end do
    enddo

    if (diff_coef > ZERO) then
       do comp = 2, nscal
          bc_comp = dm+comp

          ! Crank-Nicolson
          if (diffusion_type .eq. 1) then
             visc_mu = HALF*dt*diff_coef

          ! backward Euler
          else if (diffusion_type .eq. 2) then
             visc_mu = dt*diff_coef

          else
             call bl_error('BAD DIFFUSION TYPE ')
          end if

          call diff_scalar_solve(mla,snew,laps,dx,visc_mu,the_bc_tower,comp,bc_comp)
       end do
    end if

    do n = 1,nlevs
       call multifab_destroy(laps(n))
    end do

2000 format('... level ', i2,' new min/max : density           ',e17.10,2x,e17.10)
2001 format('... level ', i2,' new min/max :  tracer           ',e17.10,2x,e17.10)

  end subroutine scalar_advance

end module scalar_advance_module


!==============================================================================!
  module Solvers_Mod
!------------------------------------------------------------------------------!
!   Module used for native linear solvers.                                     !
!------------------------------------------------------------------------------!
  use Matrix_Mod
!------------------------------------------------------------------------------!
  implicit none
!==============================================================================!

  ! Preconditioning "matrix" (D)
  type(Matrix_Type) :: D  ! preconditioning "matrix"

  contains

  include 'Solvers_Mod/Bicg.f90'
  include 'Solvers_Mod/Cg.f90'
  include 'Solvers_Mod/Cgs.f90'
  include 'Solvers_Mod/Prec_Form.f90'
  include 'Solvers_Mod/Prec_Solve.f90'
  include 'Solvers_Mod/Residual_Vector.f90'
  include 'Solvers_Mod/Normalized_Residual.f90'

  end module


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
module global_variables

! parameter
  integer,parameter :: dp = kind(0d0), zp = kind((1d0,1d0))
  complex(zp),parameter :: zI = (0d0,1d0)
  real(dp),parameter :: pi=3.14159265359d0

  real(8),parameter :: mass_H = 1836.15267389d0
  real(8),parameter :: mu_e = 2d0*mass_H/(2d0*mass_H+1d0)
  real(8),parameter :: mu_n = 0.5d0*mass_H
  real(8),parameter :: r_dist = 2.59d0

! mesh
  integer :: Nx,NR
  real(dp) :: length_x,dx,length_r,dr
  real(dp),allocatable :: xn(:),Rn(:),xRn(:,:)

! GS: wave-function, density, potential and so on
  integer :: Ncg
  real(dp),allocatable :: wfn(:,:), rho(:), v_ext(:), v_int(:,:), v_all(:,:), rho_n(:)
  real(dp),allocatable :: wfn_e(:), wfn_n(:), v_e(:), v_n(:), v0_n(:)
  real(dp),allocatable :: v_ne(:,:), v_en(:,:)
  real(dp),allocatable :: twfn_e(:), twfn_n(:), hwfn_e(:), hwfn_n(:)
  real(dp),allocatable :: twfn_e_b(:), twfn_n_b(:)

! TD
  character(4) :: RT_mode
  integer :: Nt_iter
  real(dp) :: T_calc,dt,kick_mom
  complex(zp),allocatable :: zwfn(:,:)
  real(dp),allocatable :: dipole_t(:),norm_t(:)
  real(dp) :: field_max,field_duration,field_omega
  real(dp) :: field_max_eV_per_AA,field_duration_fs,field_omega_eV
  real(dp),allocatable :: field_t(:)

! temporary
  real(dp),allocatable :: tmp_wfn(:,:),tmp_hwfn(:,:),tmp_wfn_b(:,:)
  complex(zp),allocatable :: ztmp_wfn(:,:),ztmp_hwfn(:,:),ztmp_wfn_b(:,:)

end module global_variables


      SUBROUTINE POLCOF(XA,YA,N,COF)
      PARAMETER (NMAX=15)
      DIMENSION XA(N),YA(N),COF(N),X(NMAX),Y(NMAX)
      DO 11 J=1,N
        X(J)=XA(J)
        Y(J)=YA(J)
11    CONTINUE
      DO 14 J=1,N
        CALL POLINT(X,Y,N+1-J,0.,COF(J),DY)
        XMIN=1.E38
        K=0
        DO 12 I=1,N+1-J
          IF (ABS(X(I)).LT.XMIN)THEN
            XMIN=ABS(X(I))
            K=I
          ENDIF
          IF(X(I).NE.0.)Y(I)=(Y(I)-COF(J))/X(I)
12      CONTINUE
        IF (K.LT.N+1-J) THEN
          DO 13 I=K+1,N+1-J
            Y(I-1)=Y(I)
            X(I-1)=X(I)
13        CONTINUE
        ENDIF
14    CONTINUE
      RETURN
      END


      SUBROUTINE MB01XY( UPLO, N, A, LDA, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrix product U' * U or L * L', where U and L are
C     upper and lower triangular matrices, respectively, stored in the
C     corresponding upper or lower triangular part of the array A.
C
C     If UPLO = 'U' then the upper triangle of the result is stored,
C     overwriting the matrix U in A.
C     If UPLO = 'L' then the lower triangle of the result is stored,
C     overwriting the matrix L in A.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which triangle (U or L) is given in the array A,
C             as follows:
C             = 'U':  the upper triangular part U is given;
C             = 'L':  the lower triangular part L is given.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the triangular matrices U or L.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular matrix U.
C             On entry, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular matrix L.
C             On exit, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array contains the upper
C             triangular part of the product U' * U. The strictly lower
C             triangular part is not referenced.
C             On exit, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array contains the lower
C             triangular part of the product L * L'. The strictly upper
C             triangular part is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= max(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix product U' * U or L * L' is computed using BLAS 2 and
C     BLAS 1 operations (an unblocked algorithm).
C
C     FURTHER COMMENTS
C
C     This routine is a counterpart of LAPACK Library routine DLAUU2,
C     which computes the matrix product U * U' or L' * L.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I
      DOUBLE PRECISION   AII
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           DDOT, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMV, DSCAL, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO  = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01XY', -INFO )
         RETURN
      END IF
C
C     Quick return, if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      IF( UPPER ) THEN
C
C        Compute the product U' * U.
C
         A( N, N ) = DDOT( N, A( 1, N ), 1, A( 1, N ), 1 )
C
         DO 10 I = N-1, 2, -1
            AII = A( I, I )
            A( I, I ) = DDOT( I, A( 1, I ), 1, A( 1, I ), 1 )
            CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), LDA,
     $                  A( 1, I ), 1, AII, A( I, I+1 ), LDA )
   10    CONTINUE
C
         IF( N.GT.1 ) THEN
            AII = A( 1, 1 )
            CALL DSCAL( N, AII, A( 1, 1 ), LDA )
         END IF
C
      ELSE
C
C        Compute the product L * L'.
C
         A( N, N ) = DDOT( N, A( N, 1 ), LDA, A( N, 1 ), LDA )
C
         DO 20 I = N-1, 2, -1
            AII = A( I, I )
            A( I, I ) = DDOT( I, A( I, 1 ), LDA, A( I, 1 ), LDA )
            CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A( I+1, 1 ),
     $                  LDA, A( I, 1 ), LDA, AII, A( I+1, I ), 1 )
   20    CONTINUE
C
         IF( N.GT.1 ) THEN
            AII = A( 1, 1 )
            CALL DSCAL( N, AII, A( 1, 1 ), 1 )
         END IF
      END IF
C
      RETURN
C
C *** Last line of MB01XY ***
      END


      subroutine disp_ono(yplot)

      use size_mod

      implicit none

      integer nmax, npoints, nline, i, nsum, n, kmax, kn, jmid
      integer pgopen, pgbeg, ier, nlevmax, iflag, numb
      integer nxmx, nymx, nnodex, nnodey, j, jplot

      parameter (nxmx = nmodesmax)
      parameter (nymx = mmodesmax)
      parameter (nmax = nmodesmax)

      parameter (nlevmax = 101)

      real xgrid(nmax), ygrid(nmax), f(nmax), dx, xmin, xmax, capf(nmax)
      real capr(nmax), ff(101), rhoplasm, dy, yplot, ybottom, yprime
      complex xkperp2_slow(nxmx, nymx), xkperp2_fast(nxmx, nymx)
      complex xkperp_slow(nxmx, nymx), xkperp_fast(nxmx, nymx)
      complex P(nxmx, nymx)
      real xkprl(nxmx, nymx)

      complex xkperp2_slow_plot(nxmx), xkperp2_fast_plot(nxmx)
      complex xkperp_slow_plot(nxmx), xkperp_fast_plot(nxmx)

      real rho(nxmx, nymx)

      real f3(nmax)
      real y(nmax), k, capk, c, xdeg, yh, L, kr, nr
      real factrl, xn, an, diff1, diff2

      real ans_simpson, ans_trapezoidal, ans_analytic, ymax, ymin
      real dummy, time, t1, t2, second1, pi, x, a, e, dydx, sum

      character*32 title
      character*32 titlx
      character*32 tityl
      character*32 tityr

      character*32 titx
      character*32 tity
      character*32 titz

      integer nblack, nred, nyellow, ngreen, nblue, ncyan, nmagenta,
     .   nwhite, norange

      common/boundcom/rhoplasm

      open(unit=130, file='Ono_disp', status='unknown',
     .      form='formatted')

      nwhite = 0
      nblack = 1
      nred = 2
      ngreen = 3
      nblue = 4
      ncyan = 5
      nmagenta = 6
      nyellow = 7
      norange = 8

      numb = 100

      pi = 3.14159
      e =  2.71828
      a = 3.0
      k = .0015
      capk = 6000.
      f3 = 0.

      read(130, 309) nnodex, nnodey, jmid
      read(130, 310) rhoplasm
      read(130, 310) (capr(i), i = 1, nnodex)
      read(130, 310) (y(j), j = 1, nnodey)
      read(130, 310) ((xkperp2_slow(i, j), i = 1, nnodex),
     .      j = 1, nnodey)
      read(130, 310) ((xkperp2_fast(i, j), i = 1, nnodex),
     .      j = 1, nnodey)
      read(130, 310) ((rho(i, j), i = 1, nnodex), j = 1, nnodey)
      read(130, 310) ((xkprl(i,j), i = 1, nnodex), j = 1, nnodey)
      read(130, 310) ((P(i, j), i = 1, nnodex), j = 1, nnodey)

      xgrid = capr
      ygrid = y
      npoints = nnodex

      xmin = xgrid(1)
      xmax = xgrid(nnodex)

      jplot = jmid

      dy = y(2) - y(1)
      ybottom = y(1)
c      yplot = 0.05
      yprime = yplot - ybottom
      jplot = yprime / dy + 1
      write(6, *) "jplot = ", jplot
      write(6, *) "yplot = ", yplot

!     -------------------------------
!     Open the pgplot graphics device
!     -------------------------------
      IER = PGBEG(0, 'disper.ps/vcps', 1, 1)
      IF (IER.NE.1) STOP

      call PGSCH (1.5)

!     -------------------------------------------
!     Plot contours of k**2 - slow root
!     -------------------------------------------
      titx = 'R (m)'
      tity = 'Z (m)'
      title = 'Re(k**2) - slow root'
      call ezconc(capr, y, real(xkperp2_slow), ff, nnodex, nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity, iflag)
      if (iflag .eq. 0) call boundary(capr, y, rho, ff, nnodex,
     .   nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity)

      title = 'k_parallel'
      call ezconc(capr, y, xkprl, ff, nnodex, nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity, iflag)
      if (iflag .eq. 0) call boundary(capr, y, rho, ff, nnodex,
     .   nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity)

      title = 'Re(P)'
      call ezconc(capr, y, real(P), ff, nnodex, nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity, iflag)
      if (iflag .eq. 0) call boundary(capr, y, rho, ff, nnodex,
     .   nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity)

      title = 'Im(P)'
      call ezconc(capr, y, aimag(P), ff, nnodex, nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity, iflag)
      if (iflag .eq. 0) call boundary(capr, y, rho, ff, nnodex,
     .   nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity)

      title = 'Im(k**2) - slow root'
      call ezconc(capr, y, aimag(xkperp2_slow), ff, nnodex, nnodey,numb,
     .   nxmx, nymx, nlevmax, title, titx, tity, iflag)
      if (iflag .eq. 0) call boundary(capr, y, rho, ff, nnodex,
     .   nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity)

!     ------------------------
!     Plot cut in y at yplot
!     ------------------------
      do i = 1, nnodex
         xkperp2_slow_plot(i) = xkperp2_slow(i, jplot)
         xkperp2_fast_plot(i) = xkperp2_fast(i, jplot)
      end do

      xkperp_slow_plot = csqrt(xkperp2_slow_plot)
      xkperp_fast_plot = csqrt(xkperp2_fast_plot)

      titlx  = 'R (m)'
      tityl = 'kperp2 (m-2)'
      tityr = ' '
      title = 'fast and slow roots'

      call ezplot2_s(title, titlx, tityl, tityr, xgrid,
     .   real(xkperp2_slow_plot), real(xkperp2_fast_plot), f3,
     .   npoints, nmax, ymax, ymin, xmin, xmax)

      tityl = 'kperp (m-1)'

      call ezplot2_b(title, titlx, tityl, tityr, xgrid,
     .   real(xkperp_slow_plot), real(xkperp_fast_plot), f3,
     .   npoints, nmax, ymax, ymin, xmin, xmax)

c      title = 'slow root'
c     call ezplot1_s(title, titlx, tityl, tityr, xgrid,
c     .   real(xkperp2_slow_plot), f3,
c     .   npoints, nmax, ymax, ymin, xmin, xmax, nred)

      tityl = 'kperp2 (m-2)'
      title = 'fast root'
      call ezplot1_s(title, titlx, tityl, tityr, xgrid,
     .   real(xkperp2_fast_plot), f3,
     .   npoints, nmax, ymax, ymin, xmin, xmax, nblue)

!     -------------------------------------------
!     Plot contours of k**2 - fast root
!     -------------------------------------------

      title = 'Re(k**2) - fast root'
      call ezconc(capr, y, real(xkperp2_fast), ff, nnodex, nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity, iflag)
      if (iflag .eq. 0) call boundary(capr, y, rho, ff, nnodex,
     .   nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity)

      title = 'Im(k**2) - fast root'
      call ezconc(capr, y, aimag(xkperp2_fast), ff, nnodex, nnodey,numb,
     .   nxmx, nymx, nlevmax, title, titx, tity, iflag)
      if (iflag .eq. 0) call boundary(capr, y, rho, ff, nnodex,
     .   nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity)

      xkperp_slow = csqrt(xkperp2_slow)
      xkperp_fast = csqrt(xkperp2_fast)

      do i = 1, nnodex
         xkperp_slow_plot(i) = xkperp_slow(i, jplot)
         xkperp_fast_plot(i) = xkperp_fast(i, jplot)
      end do

!     -------------------------------------------------
!     write the function xkperp_fast_plot(i) to screen
!     -------------------------------------------------
      do i = 1, npoints
	 write(6, '(i10, 1p5e15.5)') i, xgrid(i), xkperp_fast_plot(i)
      end do

      title = 'Re(k) - fast and slow roots'
      titlx  = 'R (m)'
      tityl = 'Re(k) (m-1)'
      tityr = ' '

      call ezplot2_sym(title, titlx, tityl, tityr, xgrid,
     .   real(xkperp_slow_plot), real(xkperp_fast_plot), f3,
     .   npoints, nmax, 0.0, 0.0, xmin, xmax)

      title = 'Re(k) - fast and slow (blowup)'
      titlx  = 'R (m)'
      tityl = 'Re(k) (m-1)'
      tityr = ' '

      call ezplot2_sym(title, titlx, tityl, tityr, xgrid,
     .   real(xkperp_slow_plot), real(xkperp_fast_plot), f3,
     .   npoints, nmax, 2000., -2000., xmin, xmax)

      title = 'Re(k) - slow root'
      call ezconc(capr, y, real(xkperp_slow), ff, nnodex, nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity, iflag)
      if (iflag .eq. 0) call boundary(capr, y, rho, ff, nnodex,
     .   nnodey, numb,
     .   nxmx, nymx, nlevmax, title, titx, tity)

!     -------------------------
!     Close the graphics device
!     -------------------------
      call pgclos

      close (130)

  310 format(1p6e12.4)
 3310 format(1p6e18.10)
 8310 format(1p6e14.6)
  309 format(10i10)

      return
      end
!
!*******************************************************************************
!

      subroutine ezplot1_s(title, titx, titll, titlr, x1, y1, y3,
     .   nr, nrmax,
     .   ymax, ymin, xmin, xmax, ncolor)

      implicit none

      real xzmax,xzmin,xnmin,xnmax,rhomin,rhomax
      real x1(nrmax), y1(nrmax), y3(nrmax)
      real y1max,y2max,y3max,y1min,y2min,y3min
      real ymin, ymax, xmin, xmax

      character*32 title
      character*32 titx
      character*32 titll
      character*32 titlr

      integer nr, nrmax

      integer nplot1,ncollab, ncolion,ncolbox, ncyan, ncolelec,
     .   ncolln2, ncollin, ncolbrd

      integer nblack, nred, nyellow, ngreen, naqua, npink, nwheat,
     .   ngrey, nbrown, nblue, nblueviolet, ncyan1, ncolor
      integer nturquoise, nmagenta, nsalmon, nwhite, norange, ncolln3

      nwhite = 0
      nblack = 1
      nred = 2
      ngreen = 3
      nblue = 4
      ncyan = 5
      nmagenta = 6
      nyellow = 7
      norange = 8

      ncolln3 = ngreen

      call a1mnmx(y1, nrmax, nr, y1min, y1max)
      if(y1max .eq. 0.0 .and. y1min .eq. 0.0)return

      ymax = y1max
      ymin = y1min

      rhomax = xmax
      rhomin = xmin

! Advance plotter to a new page, define coordinate range of graph and draw axes

      CALL PGPAGE
      CALL PGSVP (0.15,0.85,0.15,0.85)
      CALL PGSWIN (rhomin, rhomax, ymin, ymax)
      CALL PGBOX   ('BCNST', 0.0, 0,  'BCNST', 0.0, 0)

      CALL PGSCI(nblack)

! Label the axes (note use of \u and \d for raising exponent).

      call pglab(titx, titll, title)

! Plot the line graph.

      CALL PGSCI(ncolor)
      call pgline(nr, x1, y1)

  300 format (1p9e11.3)

      CALL PGSCI(nblack)
      call pgline(nr, x1, y3)

      return
      end

!
!********************************************************************
!
      subroutine ezplot2_s(title, titlb, titll, titlr, x1, y1, y2, y3,
     .   nr, nrmax, ymax, ymin, xmin, xmax)

      implicit none

      real xzmax,xzmin,xnmin,xnmax,rhomin,rhomax
      real x1(nrmax),y1(nrmax), y2(nrmax), y3(nrmax)
      real y1max,y2max,y3max,y1min,y2min,y3min
      real ymin,ymax, xmin, xmax

      character*32 title
      character*32 titll
      character*32 titlr
      character*32 titlb

      integer nr, nrmax, n

      integer nplot1,ncollab, ncolion,ncolbox, ncyan, ncolelec,
     .   ncolln2, ncollin, ncolbrd
      integer nblack,nred,nyellow, ngreen,naqua,npink, nwheat,
     .   ngrey,nbrown,nblue,nblueviolet,ncyan1
      integer nturquoise,nmagenta,nsalmon,nwhite,ncolln3, norange

      nwhite = 0
      nblack = 1
      nred = 2
      ngreen = 3
      nblue = 4
      ncyan = 5
      nmagenta = 6
      nyellow = 7
      norange = 8

      call a1mnmx(y1, nrmax, nr, y1min, y1max)

      if(y1max .eq. 0.0 .and. y1min .eq. 0.0)return

      ymax = y1max
      ymin = y1min

      rhomax = xmax
      rhomin = xmin

      CALL PGPAGE
      CALL PGSVP (0.15,0.85,0.15,0.85)
      CALL PGSWIN (rhomin, rhomax, ymin, ymax)
      CALL PGBOX  ('BCNST', 0.0, 0, 'BCNST', 0.0, 0)

      CALL PGSCI(nblack)

! Label the axes (note use of \u and \d for raising exponent).

      call pglab(titlb, titll, title)

      CALL PGSCI(nred)
      call pgline(nr, x1, y1)

      CALL PGSCI(nblue)
      call pgline(nr, x1, y2)

      CALL PGSCI(nblack)
      call pgline(nr, x1, y3)

  300 format (1p9e11.3)
      return
      end

!
!********************************************************************
!
      subroutine ezplot2_b(title, titlb, titll, titlr, x1, y1, y2, y3,
     .   nr, nrmax, ymax, ymin, xmin, xmax)

      implicit none

      real xzmax,xzmin,xnmin,xnmax,rhomin,rhomax
      real x1(nrmax),y1(nrmax), y2(nrmax), y3(nrmax)
      real y1max,y2max,y3max,y1min,y2min,y3min
      real ymin,ymax, xmin, xmax

      character*32 title
      character*32 titll
      character*32 titlr
      character*32 titlb

      integer nr, nrmax, n

      integer nplot1,ncollab, ncolion,ncolbox, ncyan, ncolelec,
     .   ncolln2, ncollin, ncolbrd
      integer nblack,nred,nyellow, ngreen,naqua,npink, nwheat,
     .   ngrey,nbrown,nblue,nblueviolet,ncyan1
      integer nturquoise,nmagenta,nsalmon,nwhite,ncolln3, norange

      nwhite = 0
      nblack = 1
      nred = 2
      ngreen = 3
      nblue = 4
      ncyan = 5
      nmagenta = 6
      nyellow = 7
      norange = 8

      call a1mnmx(y2, nrmax, nr, y2min, y2max)

      if(y1max .eq. 0.0 .and. y1min .eq. 0.0)return

      ymax = y2max * 2.0
      ymin = y2min

      rhomax = xmax
      rhomin = xmin

      CALL PGPAGE
      CALL PGSVP (0.15,0.85,0.15,0.85)
      CALL PGSWIN (rhomin, rhomax, ymin, ymax)
      CALL PGBOX  ('BCNST', 0.0, 0, 'BCNST', 0.0, 0)

      CALL PGSCI(nblack)

! Label the axes (note use of \u and \d for raising exponent).

      call pglab(titlb, titll, title)

      CALL PGSCI(nred)
      call pgline(nr, x1, y1)

      CALL PGSCI(nblue)
      call pgline(nr, x1, y2)

      CALL PGSCI(nblack)
      call pgline(nr, x1, y3)

  300 format (1p9e11.3)
      return
      end

!
!*****************************************************************
!
      subroutine ezplot2_sym(title, titlb, titll, titlr, x1, y1, y2, y3,
     .   nr, nrmax, ymax_giv, ymin_giv, xmin, xmax)

      implicit none

      real xzmax,xzmin,xnmin,xnmax,rhomin,rhomax
      real x1(nrmax),y1(nrmax), y2(nrmax), y3(nrmax)
      real y1max,y2max,y3max,y1min,y2min,y3min
      real ymin,ymax, xmin, xmax, ymax_giv, ymin_giv

      character*32 title
      character*32 titll
      character*32 titlr
      character*32 titlb

      integer nr, nrmax, n

      integer nplot1,ncollab, ncolion,ncolbox, ncyan, ncolelec,
     .   ncolln2, ncollin, ncolbrd
      integer nblack,nred,nyellow, ngreen,naqua,npink, nwheat,
     .   ngrey,nbrown,nblue,nblueviolet,ncyan1
      integer nturquoise,nmagenta,nsalmon,nwhite,ncolln3, norange

      nwhite = 0
      nblack = 1
      nred = 2
      ngreen = 3
      nblue = 4
      ncyan = 5
      nmagenta = 6
      nyellow = 7
      norange = 8

      call a1mnmx(y1, nrmax, nr, y1min, y1max)

!      write(6, 300) y2min, y2max
      if(y1max .eq. 0.0 .and. y1min .eq. 0.0)return

      ymax = y1max * 1.1
      ymin = y1min

      if(ymax_giv .ne. 0.0)ymax = ymax_giv
      ymin = -ymax

      rhomax = xmax
      rhomin = xmin

      CALL PGPAGE
      CALL PGSVP (0.15,0.85,0.15,0.85)
      CALL PGSWIN (rhomin, rhomax, ymin, ymax)
      CALL PGBOX  ('BCNST', 0.0, 0, 'BCNST', 0.0, 0)

      CALL PGSCI(nblack)

! Label the axes (note use of \u and \d for raising exponent).

      call pglab(titlb, titll, title)

      CALL PGSCI(nred)
      call pgline(nr, x1, y1)
      call pgline(nr, x1, -y1)

      CALL PGSCI(nblue)
      call pgline(nr, x1, y2)
      call pgline(nr, x1, -y2)

      CALL PGSCI(nblack)
      call pgline(nr, x1, y3)

  300 format (1p9e11.3)
      return
      end

!
!********************************************************************
!


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE CALC_KRRcb

! Calculates the R-set row and col matrix KRRcb in the CB transformation matrix:

!                                  KRRcb = KRR + KRL*DLR

! For a description of Craig-Bamptom analyses, see Appendix D to the MYSTRAN User's Referance Manual

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FACTORED_MATRIX, FATAL_ERR, KRRcb_SDIA,                                     &
                                         NDOFL, NDOFR, NTERM_DLR, NTERM_KRL, NTERM_KRR, NTERM_KRRcb, NTERM_KRRcbs
      USE TIMDAT, ONLY                :  TSEC
      USE CONSTANTS_1, ONLY           :  ONE
      USE DEBUG_PARAMETERS, ONLY      :  DEBUG
      USE PARAMS, ONLY                :  SPARSTOR, SUPINFO
      USE SPARSE_MATRICES , ONLY      :  SYM_DLR, SYM_KRL, SYM_KRR
      USE SPARSE_MATRICES , ONLY      :  I_KRL, J_KRL, KRL, I_KRR, J_KRR, KRR, I_DLR, J_DLR, DLR,                                  &
                                         I_KRRcb, J_KRRcb, KRRcb, I_KRRcbs, J_KRRcbs, KRRcbs
      USE SCRATCH_MATRICES
      USE LAPACK_DPB_MATRICES, ONLY   :  ABAND
      USE SUBR_BEGEND_LEVELS, ONLY    :  CALC_KRRcb_BEGEND

      USE CALC_KRRcb_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'CALC_KRRcb'
      CHARACTER(  1*BYTE)             :: EQUED             ! 'Y' if KRRcb stiff matrix was equilibrated in subr EQUILIBRATE
      CHARACTER(  1*BYTE)             :: SYM_CRS3          ! Storage format for matrix CRS3 (either 'Y' for sym storage or
!                                                            'N' for nonsymmetric storage)

      INTEGER(LONG)                   :: AROW_MAX_TERMS    ! Output from MATMULT_SFS_NTERM and input to MATMULT_SFS
      INTEGER(LONG)                   :: DEB_PRT(2)        ! Debug numbers to say whether to write ABAND and/or its decomp to output
!                                                            file in called subr SYM_MAT_DECOMP_LAPACK
      INTEGER(LONG)                   :: I,J               ! DO loop indices
      INTEGER(LONG)                   :: INFO        = -1  ! Input value for subr SYM_MAT_DECOMP_LAPACK (don't quit on sing KRRCB)

      INTEGER(LONG)                   :: NTERM_CRS1        ! Number of terms in matrix CRS1
      INTEGER(LONG)                   :: NTERM_CRS3        ! Number of terms in matrix CRS3
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = CALC_KRRcb_BEGEND

      REAL(DOUBLE)                    :: EQUIL_SCALE_FACS(NDOFR)
                                                           ! LAPACK_S values returned from subr SYM_MAT_DECOMP_LAPACK
      REAL(DOUBLE)                    :: K_INORM           ! Inf norm of KRRcb matrix (det in  subr COND_NUM)
      REAL(DOUBLE)                    :: RCOND             ! Recrip of cond no. of the KLL. Det in  subr COND_NUM

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Calc KRRcb = KRR + KRL*DLR
                                                           ! CCS1 will be sparse CCS format version of sparse CRS matrix DLR
      IF (NTERM_KRL > 0) THEN                              ! Part I of KRRcb: calc KRL*DLR add it to KRR

         CALL ALLOCATE_SCR_CCS_MAT ( 'CCS1', NDOFR, NTERM_DLR, SUBR_NAME )
         CALL SPARSE_CRS_SPARSE_CCS ( NDOFL, NDOFR, NTERM_DLR, 'DLR', I_DLR, J_DLR, DLR, 'CCS1', J_CCS1, I_CCS1, CCS1, 'Y' )

                                                           ! I-1 , sparse multiply to get CRS1 = KRL*DLR. Use CCS1 for DLR CCS
         CALL MATMULT_SSS_NTERM ( 'KRL' , NDOFR, NTERM_KRL , SYM_KRL, I_KRL , J_KRL ,                                              &
                                  'DLR' , NDOFR, NTERM_DLR , SYM_DLR, J_CCS1, I_CCS1, AROW_MAX_TERMS,                              &
                                  'CRS1',        NTERM_CRS1 )

         CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFR, NTERM_CRS1, SUBR_NAME )

         CALL MATMULT_SSS ( 'KRL' , NDOFR, NTERM_KRL, SYM_KRL, I_KRL , J_KRL , KRL ,                                               &
                            'DLR' , NDOFR, NTERM_DLR, SYM_DLR, J_CCS1, I_CCS1, CCS1, AROW_MAX_TERMS,                               &
                            'CRS1', ONE  , NTERM_CRS1,         I_CRS1, J_CRS1, CRS1 )

         CALL DEALLOCATE_SCR_MAT ( 'CCS1')

         IF      (SPARSTOR == 'SYM   ') THEN               !      If SPARSTOR == 'SYM   ', rewrite CRS1 (= KRL*DLR) as sym in CRS3

            CALL SPARSE_CRS_TERM_COUNT ( NDOFR, NTERM_CRS1, 'CRS1 = KRL*DLR', I_CRS1, J_CRS1, NTERM_CRS3 )
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFR, NTERM_CRS3, SUBR_NAME )
            CALL CRS_NONSYM_TO_CRS_SYM ( 'CRS1 = KRL*DLR all nonzeros', NDOFR, NTERM_CRS1, I_CRS1, J_CRS1, CRS1,                   &
                                         'CRS3 = KRL*DLR stored sym'  ,        NTERM_CRS3, I_CRS3, J_CRS3, CRS3 )
            SYM_CRS3 = 'Y'

         ELSE IF (SPARSTOR == 'NONSYM') THEN               ! If SPARSTOR == 'NONSYM', rewrite CRS3 in CRS1 with NTERM_CRS3

            NTERM_CRS3 = NTERM_CRS1
            CALL ALLOCATE_SCR_CRS_MAT ( 'CRS3', NDOFR, NTERM_CRS3, SUBR_NAME )
            DO I=1,NDOFR+1
               I_CRS3(I) = I_CRS1(I)
            ENDDO
            DO I=1,NTERM_CRS3
               J_CRS3(I) = J_CRS1(I)
                 CRS3(I) =   CRS1(I)
            ENDDO
            SYM_CRS3 = 'N'

         ELSE                                              ! Error - incorrect SPARSTOR

            WRITE(ERR,932) SUBR_NAME, SPARSTOR
            WRITE(F06,932) SUBR_NAME, SPARSTOR
            FATAL_ERR = FATAL_ERR + 1
            CALL OUTA_HERE ( 'Y' )

         ENDIF
                                                           ! I-8 , sparse add to get KRRcb = KRR + CRS3 = KRR + KRL*DLR
         CALL MATADD_SSS_NTERM ( NDOFR, 'KRR', NTERM_KRR, I_KRR, J_KRR, SYM_KRR, 'KRL*DLR', NTERM_CRS3, I_CRS3, J_CRS3, SYM_CRS3,  &
                                      'KRRcb', NTERM_KRRcb )
         CALL ALLOCATE_SPARSE_MAT ( 'KRRcb', NDOFR, NTERM_KRRcb, SUBR_NAME )
         CALL MATADD_SSS ( NDOFR, 'KRR', NTERM_KRR, I_KRR, J_KRR, KRR, ONE, 'KRL*DLR', NTERM_CRS3, I_CRS3, J_CRS3, CRS3, ONE,      &
                                  'KRRcb', NTERM_KRRcb, I_KRRcb, J_KRRcb, KRRcb )

         CALL DEALLOCATE_SCR_MAT ( 'CRS1' )                ! I-9 , deallocate CRS1

         CALL DEALLOCATE_SCR_MAT ( 'CRS3' )                ! I-12, deallocate CRS3

      ELSE

      NTERM_KRRcb = NTERM_KRR                              ! Allocate KRRcb and equate to KRR since there is no KRL term
      CALL ALLOCATE_SPARSE_MAT ( 'KRRcb', NDOFR, NTERM_KRRcb, SUBR_NAME )

      DO I=1,NDOFR+1
         I_KRRcb(I) = I_KRR(I)
      ENDDO
      DO J=1,NTERM_KRRcb
         J_KRRcb(J) = J_KRR(J)
           KRRcb(J) =   KRR(J)
      ENDDO

      ENDIF

! If DEBUG(104) > 0, check if KRRcb is singular. It should be singular regardless of the number of boundary DOF's.
! (KRR is singular if NDOFR = 6 and is a determinant set of supports. KRRcb should be singular always)
! (CODE ONLY IMPLEMENTED FOR SOLLIB == 'BANDED  ')

      IF (DEBUG(104) > 0) THEN

         CALL DEALLOCATE_LAPACK_MAT ( 'ABAND' )
         DEB_PRT(1) = 66
         DEB_PRT(2) = 67

         INFO = -1                                      ! Set INFO, on input, -1 so that SYM_MAT_DECOMP_LAPACK will not abort
         CALL SYM_MAT_DECOMP_LAPACK ( SUBR_NAME, 'KRRcb', 'R ', NDOFR, NTERM_KRRcb, I_KRRcb, J_KRRcb, KRRcb, 'N', 'N', 'N', 'N',&
                                      DEB_PRT, EQUED, KRRcb_SDIA, K_INORM, RCOND, EQUIL_SCALE_FACS, INFO )
         IF (INFO > 0) THEN                             ! KRRcb was singular as it should be
            WRITE(ERR,9971)
            WRITE(ERR,*)
            IF (SUPINFO == 'N') THEN
               WRITE(F06,9971)
               WRITE(F06,*)
            ENDIF
         ELSE                                           ! KRRcb was not singular. Model must be constrained from RB motion
            WRITE(ERR,9972)
            WRITE(ERR,*)
            IF (SUPINFO == 'N') THEN
               WRITE(F06,9972)
               WRITE(F06,*)
            ENDIF
         ENDIF

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
  932 FORMAT(' *ERROR   932: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' PARAMETER SPARSTOR MUST BE EITHER "SYM" OR "NONSYM" BUT VALUE IS ',A)

 9971 FORMAT(' *INFORMATION: MATRIX KRRcb WAS FOUND TO BE SINGULAR AS IT SHOULD BE. ANY ERRORS REGARDING SINGULARITY OF KRRcb',    &
                           ' SHOULD BE IGNORED')

 9972 FORMAT(' *INFORMATION: MATRIX KRRcb WAS CHECKED FOR SINGULARITY BUT WAS FOUND TO BE NONSINGULAR.',                           &
                           ' USER SHOULD CHECK MODEL TO MAKE SURE IT IS NOT RESTRAINED FROM RIGID BODY MOTION')

! **********************************************************************************************************************************

      END SUBROUTINE CALC_KRRcb


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_PRESOLVE_EXAMPLE
   USE GALAHAD_QPT_double                           ! Double precision
   USE GALAHAD_PRESOLVE_double                      ! Double precision
   USE GALAHAD_SYMBOLS                              ! The GALAHAD symbols
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D0 )         ! Set precision
   REAL ( KIND = wp ), PARAMETER  :: infinity = 10._wp ** 20
   REAL ( KIND = wp ), PARAMETER  :: r0 = 0.0_wp, r1 = 1.0_wp
   REAL ( KIND = wp ), PARAMETER  :: r2 = 2.0_wp, r3 = 3.0_wp
   TYPE ( QPT_problem_type )      :: problem
   TYPE ( PRESOLVE_control_type ) :: control
   TYPE ( PRESOLVE_inform_type )  :: inform
   TYPE ( PRESOLVE_data_type )    :: data
   INTEGER :: j, n, m, h_ne, a_ne, s
!
!                                                +-----------------------------+
   INTEGER :: data_storage_type =  0             ! change this to -2 for dense !
                                                 ! or to -1 for row-wise sparse!
!                                                +-----------------------------+
! start problem data
   n = 6; m = 5; h_ne = 1; a_ne = 8
   problem%new_problem_structure = .TRUE.
   problem%n   = n; problem%m = m; problem%f = r1
   ALLOCATE( problem%G( n )  , problem%X_l( n ), problem%X_u( n ) )
   ALLOCATE( problem%C_l( m ), problem%C_u( m ) )
   problem%gradient_kind = 1
   problem%C_l = (/  r0, r0, r2, r1, r3  /)
   problem%C_u = (/  r1, r1, r3, r3, r3  /)
   problem%X_l = (/ -r3, r0, r0, r0, r0, r0 /)
   problem%X_u = (/  r3, r1, r1, r1, r1, r1 /)
! sparse coordinate format
   IF ( data_storage_type == 0 ) THEN
     CALL SMT_put( problem%H%type, 'COORDINATE', s )
     CALL SMT_put( problem%A%type, 'COORDINATE', s )
     ALLOCATE( problem%H%val( h_ne ) )
     ALLOCATE( problem%H%col( h_ne ), problem%H%row( h_ne ) )
     ALLOCATE( problem%A%val( a_ne ) )
     ALLOCATE( problem%A%col( a_ne ), problem%A%row( a_ne ) )
     problem%H%val = (/ r1  /)
     problem%H%row = (/ 1   /)
     problem%H%col = (/ 1   /)
     problem%A%val = (/ r1, r1, r1, r1, r1, r1, r1, r1 /)
     problem%A%row = (/  3,  3,  3,  4,  4,  5,  5,  5 /)
     problem%A%col = (/  3,  4,  5,  3,  6,  4,  5,  6 /)
     problem%A%ne  = a_ne; problem%H%ne = h_ne
! sparse row-wise storage format
   ELSE IF ( data_storage_type == - 1 ) THEN
     CALL SMT_put( problem%H%type, 'SPARSE_BY_ROWS', s )
     CALL SMT_put( problem%A%type, 'SPARSE_BY_ROWS', s )
     ALLOCATE( problem%H%val( h_ne ), problem%H%col( h_ne ) )
     ALLOCATE( problem%H%ptr( n+1 ) )
     ALLOCATE( problem%A%val( a_ne ), problem%A%col( a_ne ) )
     ALLOCATE( problem%A%ptr( m+1 ) )
     problem%H%val = (/ r1  /)
     problem%H%ptr = (/  1,  2,  2,  2,  2,  2,  2 /)
     problem%H%col = (/  1  /)
     problem%A%val = (/ r1, r1, r1, r1, r1, r1, r1, r1 /)
     problem%A%ptr = (/  1,  1,  1,  4,  6,  9 /)
     problem%A%col = (/  3,  4,  5,  3,  6,  4,  5,  6 /)
! dense storage format
   ELSE IF ( data_storage_type == - 2 ) THEN
     CALL SMT_put( problem%H%type, 'DENSE', s )
     CALL SMT_put( problem%A%type, 'DENSE', s )
     ALLOCATE( problem%H%val( n*(n+1)/2 ) )
     ALLOCATE( problem%A%val( n*m ) )
     problem%H%val = (/ r1,                           &
                        r0, r0,                       &
                        r0, r0, r0,                   &
                        r0, r0, r0, r0,               &
                        r0, r0, r0, r0, r0,           &
                        r0, r0, r0, r0, r0, r0  /)
     problem%A%val = (/ r0, r0, r0, r0, r0, r0,       &
                        r0, r0, r0, r0, r0, r0,       &
                        r0, r0, r1, r1, r1, r0,       &
                        r0, r0, r1, r0, r0, r1,       &
                        r0, r0, r0, r1, r1, r1  /)
   END IF
! problem data complete
! write the original formulation
   CALL QPT_write_problem( 6, problem )
! set the default PRESOLVE control parameters
   CALL PRESOLVE_initialize( control, inform, data )
   IF ( inform%status /= 0 ) STOP
   control%print_level = GALAHAD_TRACE              ! Ask for some output
! apply presolving to reduce the problem
   CALL PRESOLVE_apply( problem, control, inform, data )
   IF ( inform%status /= 0 ) STOP
! write the reduced problem
   CALL QPT_write_problem( 6, problem )
! solve the reduced problem
   ! CALL QPSOLVER (unnecessary here, because the reduced problem has a
   ! single feasible point in this example)
! restore the solved reduced problem to the original formulation
   CALL PRESOLVE_restore( problem, control, inform, data )
   IF ( inform%status /= 0 ) STOP
! write the final solution in the original variables
   WRITE( 6, * ) ' '
   WRITE( 6, * ) '  The problem solution X is'
   WRITE( 6, * ) ' '
   DO j = 1, n
      WRITE( 6, '(3x,''x('',I1,'') = '', ES12.4)' ) j, problem%X( j )
   END DO
! deallocate internal workspace
   CALL PRESOLVE_terminate( control, inform, data ) ! Delete internal workspace
   END PROGRAM GALAHAD_PRESOLVE_EXAMPLE


!! Convenient definitions of numerical constants.  This should not
!! be considered an exhaustive list of such constants.
module bl_constants_module

  use bl_types

  implicit none

  real(kind = dp_t), parameter :: ZERO    =  0.0_dp_t
  real(kind = dp_t), parameter :: ONE     =  1.0_dp_t
  real(kind = dp_t), parameter :: TWO     =  2.0_dp_t
  real(kind = dp_t), parameter :: THREE   =  3.0_dp_t
  real(kind = dp_t), parameter :: FOUR    =  4.0_dp_t
  real(kind = dp_t), parameter :: FIVE    =  5.0_dp_t
  real(kind = dp_t), parameter :: SIX     =  6.0_dp_t
  real(kind = dp_t), parameter :: SEVEN   =  7.0_dp_t
  real(kind = dp_t), parameter :: EIGHT   =  8.0_dp_t
  real(kind = dp_t), parameter :: NINE    =  9.0_dp_t
  real(kind = dp_t), parameter :: TEN     = 10.0_dp_t

  real(kind = dp_t), parameter :: ELEVEN  = 11.0_dp_t
  real(kind = dp_t), parameter :: TWELVE  = 12.0_dp_t
  real(kind = dp_t), parameter :: FIFTEEN = 15.0_dp_t
  real(kind = dp_t), parameter :: SIXTEEN = 16.0_dp_t

  real(kind = dp_t), parameter :: HALF    = 0.5_dp_t
  real(kind = dp_t), parameter :: THIRD   = ONE/THREE
  real(kind = dp_t), parameter :: FOURTH  = 0.25_dp_t
  real(kind = dp_t), parameter :: FIFTH   = ONE/FIVE
  real(kind = dp_t), parameter :: SIXTH   = ONE/SIX
  real(kind = dp_t), parameter :: SEVENTH = ONE/SEVEN
  real(kind = dp_t), parameter :: EIGHTH  = 0.125_dp_t
  real(kind = dp_t), parameter :: NINETH  = ONE/NINE
  real(kind = dp_t), parameter :: TENTH   = 0.10_dp_t
  real(kind = dp_t), parameter :: TWELFTH = ONE/TWELVE

  real(kind = dp_t), parameter :: TWO3RD    = TWO/THREE
  real(kind = dp_t), parameter :: FOUR3RD   = FOUR/THREE
  real(kind = dp_t), parameter :: FIVE3RD   = FIVE/THREE
  real(kind = dp_t), parameter :: FIVE6TH   = FIVE/SIX

  real(kind = dp_t), parameter :: THREE4TH  = 0.75_dp_t

  real(kind = dp_t), parameter :: FIVE12TH = FIVE/TWELVE
  real(kind = dp_t), parameter :: SEVEN12TH = SEVEN/TWELVE

  real(kind = dp_t), parameter :: FIVE32ND = FIVE/32.0_dp_t

  !! Pi
  real(kind = dp_t), parameter :: M_PI    = &
       3.141592653589793238462643383279502884197_dp_t
  real(kind = dp_t), parameter :: M_SQRT_PI  = &
       1.772453850905516027298167483341145182798_dp_t

  !! Roots
  real(kind = dp_t), parameter :: M_SQRT_2  = &
       1.414213562373095048801688724209698078570_dp_t

end module bl_constants_module


      SUBROUTINE VARANC(A,NA,G,NG,Q,NQ,W,NW,IDENT,DISC,IOP,DUMMY)
C
C   PURPOSE:
C      Compute the steady-state variance matrix of the state of the con-
C      tinuous or discrete linear time-invariant system.
C
C   REFERENCES:
C      Kwakernaak, Huibert; and Sivan, Raphael: Linear Optimal Control
C        Systems.  John Wiley & Sons, Inc., c.1972.
C
C   Subroutines employed by VARANC: BARSTW, BILIN, EQUATE, LNCNT, MULT,
C      PRNT, SCALE, SUM, TRANP
C   Subroutines employing VARANC: None
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),G(1),Q(1),W(1),DUMMY(1)
      DIMENSION NA(2),NG(2),NQ(2),NW(2),NDUM1(2),IOP(3),IOPT(2)
      LOGICAL IDENT,DISC,SYM
      COMMON/TOL/EPSAM,EPSBM,IACM
C
      IF( IOP(1) .EQ. 0 ) GO TO 100
      CALL LNCNT(5)
      IF( DISC ) WRITE(6,25)
      IF( .NOT. DISC ) WRITE(6,35)
   25 FORMAT(//' PROGRAM TO SOLVE FOR THE STEADY-STATE VARIANCE MATRIX'/
     /' FOR A LINEAR DISCRETE SYSTEM'/)
   35 FORMAT(//' PROGRAM TO SOLVE FOR THE STEADY-STATE VARIANCE MATRIX'/
     1' FOR A LINEAR CONTINUOUS SYSTEM'/)
      CALL PRNT(A,NA,' A  ',1)
      IF( .NOT. IDENT ) GO TO 55
      CALL LNCNT(3)
      WRITE(6,45)
   45 FORMAT(/' G IS AN IDENTITY MATRIX '/)
      GO TO 65
   55 CONTINUE
      CALL PRNT(G,NG,' G  ',1)
   65 CONTINUE
      IF ( .NOT. IDENT ) GO TO 85
      CALL LNCNT(3)
      WRITE(6,75)
   75 FORMAT(/' INTENSITY MATRIX FOR COVARIANCE OF PROCESS NOISE '/)
C
   85 CONTINUE
      CALL PRNT(Q,NQ,' Q  ',1)
C
  100 CONTINUE
      IF( IDENT ) GO TO 200
      CALL MULT(G,NG,Q,NQ,DUMMY,NG)
      N1 = NG(1)*NG(2) + 1
      CALL TRANP(G,NG,DUMMY(N1),NDUM1)
      CALL MULT(DUMMY,NG,DUMMY(N1),NDUM1,Q,NQ)
C
      IF( IOP(1) .EQ. 0 ) GO TO 200
      CALL LNCNT(3)
      WRITE(6,75)
      CALL PRNT(Q,NQ,'GQGT',1)
C
  200 CONTINUE
      CALL EQUATE(Q,NQ,W,NW)
      IF(.NOT. DISC) CALL SCALE(W,NW,W,NW,-1.0D0)
      IOPT(1) = IOP(2)
      IOPT(2) = 1
      SYM = .TRUE.
      IF( DISC ) GO TO 300
      IF( IOP(3) .EQ. 0 ) GO TO 250
      CALL BILIN(A,NA,A,NA,W,NW,IOPT,BETA,SYM,DUMMY)
      GO TO 400
C
  250 CONTINUE
      EPSA=EPSAM
      CALL BARSTW(A,NA,A,NA,W,NW,IOPT,SYM,EPSA,EPSA,DUMMY)
      GO TO 400
C
  300 CONTINUE
      CALL EQUATE(A,NA,DUMMY,NA)
      N = NA(1)**2
      N1 = N + 1
      CALL TRANP(A,NA,DUMMY(N1),NA)
      N2 = N1 + N
      CALL SUM(DUMMY,NA,W,NW,DUMMY(N1),NA,IOPT,SYM,DUMMY(N2))
C
  400 CONTINUE
      IF( IOP(1) .EQ. 0 ) RETURN
      CALL LNCNT(3)
      WRITE(6,450)
  450 FORMAT(/ ' VARIANCE MATRIX '/)
      CALL PRNT(W,NW,' W  ',1)
C
      RETURN
      END


c
c program remray
c
      include 'VICMAIN_FOR'
      subroutine main44

      parameter(npix=10000)
      integer*4 ounit,def,count,count1,count2,status
      real*4 buf1(npix),buf2(npix),buf3(npix),obuf(npix)
      real*4 med1(npix),med2(npix),med3(npix)
      integer*4 hist(-32768:32767)

c set constants
      nreset=0       ! # pixels changed

c parameters
      call xvparm('GAIN1',gain1,count1,def,1)
      call xvparm('GAIN2',gain2,count2,def,1)
      call xvparm('TOL',tolerance,count,def,1)

c open input 1
      call xvunit(inunit,'INP',1,status,' ')
      call xvopen(inunit,status,'U_FORMAT','REAL',' ')
      call xvget(inunit,status,'NL',nl,'NS',ns,'FORMAT',format,' ')
      if(ns.gt.npix)then
        write(*,*)'Max number of pixels/line=',npix
        call abend
      endif

c open input 2
      call xvunit(inunit2,'INP',2,status,' ')
      call xvopen(inunit2,status,'U_FORMAT','REAL',' ')
      call xvget(inunit2,status,'NL',nl2,'NS',ns2,' ')
      if((ns2.ne.ns).or.(nl2.ne.nl))then
        write(*,*)'Input images are of unequal size'
        call abend
      endif

c compute histogram of medians & GAIN1 if defaulted.
      if(count1.eq.0)then
        do i=-32768,32767
          hist(i)=0
        enddo
        do j=1,nl
          call xvread(inunit2,med1,status,'LINE',j,' ')
          do i=1,ns
            k=nint(med1(i))
            hist(k)=hist(k)+1
          enddo
        enddo
        k=0
        n=nl*ns*0.02
        do i=32767,-32768,-1
          k=k+hist(i)
          if(k.ge.n)then
            upper_dn=i
            goto 10
          endif
        enddo
10      continue
        write(*,*)'Upper DN range is about ',upper_dn
        if(upper_dn.eq.0.)upper_dn=1.
        gain1=tolerance/upper_dn
        write(*,*)'GAIN1 reset to ',gain1
      endif

c compute histogram of activity & GAIN2 if defaulted.
      if(count2.eq.0)then
        do i=0,32767
          hist(i)=0
        enddo
        do j=1,nl

c         read picture data
          call getlines(j,nl,ns,inunit,inunit2,
     +      buf1,buf2,buf3,med1,med2,med3)

c         pixel loop
          do i=2,ns+1
            dn_sum=med1(i-1)+med1(i)+med1(i+1)+
     +             med2(i-1)+        med2(i+1)+
     +             med3(i-1)+med3(i)+med3(i+1)
            deviation=abs(8.0*med2(i)-dn_sum)/8.0
            k=nint(deviation*1000.)
            if(k.gt.32767)k=32767
            if(k.lt.-32768)k=-32768
            hist(k)=hist(k)+1
          enddo
        enddo
        k=0
        n=nl*ns*0.02
        do i=32767,0,-1
          k=k+hist(i)
          if(k.ge.n)then
            upper_dn=i/1000.
            goto 11
          endif
        enddo
11      continue
        write(*,*)'Upper activity range is about ',upper_dn
        if(upper_dn.eq.0.)upper_dn=1.
        gain2=tolerance/upper_dn
        write(*,*)'GAIN2 reset to ',gain2
      endif

c open output
      call xvunit(ounit,'OUT',1,status,' ')
      call xvopen(ounit,status,'U_FORMAT','REAL','OP','WRITE',' ')

c Process data.
      do j=1,nl

c       read picture data
        call getlines(j,nl,ns,inunit,inunit2,
     +    buf1,buf2,buf3,med1,med2,med3)

c       pixel loop
        do i=2,ns+1

          dn_sum=med1(i-1)+med1(i)+med1(i+1)+
     +           med2(i-1)+        med2(i+1)+
     +           med3(i-1)+med3(i)+med3(i+1)
          deviation=abs(8.0*med2(i)-dn_sum)/8.0
          tol=gain1*med2(i)+gain2*deviation

c         determine if pixel is changed.
          if(buf2(i)-med2(i).gt.tol)then
            dn_mean=(dn_sum+med2(i))/9.0
            obuf(i)=dn_mean   ! reset to mean
            nreset=nreset+1
          else
            obuf(i)=buf2(i)   ! no change
          endif

        enddo
        call xvwrit(ounit,obuf(2),status,' ')

      enddo

c statistics
      write(*,*)nreset,' pixels reset'
      return
      end

c********************************************************************
      subroutine getlines(j,nl,ns,inunit,inunit2,
     +    buf1,buf2,buf3,med1,med2,med3)
      real*4 buf1(*),buf2(*),buf3(*),med1(*),med2(*),med3(*)
      integer*4 status
c j=picture line
c buf1,2,3 are 3 consecutive lines top down centered on line j
c med1,2,3 are the same but medians.

        if(j.eq.1)then
c         picture
          call xvread(inunit,buf2(2),status,'LINE',1,' ')
          buf2(1)=buf2(2)
          buf2(ns+2)=buf2(ns+1)
          call xvread(inunit,buf3(2),status,'LINE',2,' ')
          buf3(1)=buf3(2)
          buf3(ns+2)=buf3(ns+1)
          call mve(7,ns+2,buf2,buf1,1,1)
c         median
          call xvread(inunit2,med2(2),status,'LINE',1,' ')
          med2(1)=med2(2)
          med2(ns+2)=med2(ns+1)
          call xvread(inunit2,med3(2),status,'LINE',2,' ')
          med3(1)=med3(2)
          med3(ns+2)=med3(ns+1)
          call mve(7,ns+2,med2,med1,1,1)

        else if(j.eq.nl)then
c         picture
          call mve(7,ns+2,buf2,buf1,1,1)
          call mve(7,ns+2,buf3,buf2,1,1)
c         median
          call mve(7,ns+2,med2,med1,1,1)
          call mve(7,ns+2,med3,med2,1,1)

        else
c         picture
          call mve(7,ns+2,buf2,buf1,1,1)
          call mve(7,ns+2,buf3,buf2,1,1)
          call xvread(inunit,buf3(2),status,'LINE',j+1,' ')
          buf3(1)=buf3(2)
          buf3(ns+2)=buf3(ns+1)
c         median
          call mve(7,ns+2,med2,med1,1,1)
          call mve(7,ns+2,med3,med2,1,1)
          call xvread(inunit2,med3(2),status,'LINE',j+1,' ')
          med3(1)=med3(2)
          med3(ns+2)=med3(ns+1)

        endif
        return
        end


program navier_stokes
    ! Solves the incompressible Navier-Stokes equations on a rectangular grid with even spacing and velocity boundary conditions

    use boundary_condition_m
    use ns_case_m

    character(100) :: input_file
    type(ns_case_t) :: case

    ! Print welcome message
    write(*,*) ""
    write(*,*) "-------------------------------------------------"
    write(*,*) "|                                               |"
    write(*,*) "|  Welcome to the Flow81 Navier-Stokes Solver!  |"
    write(*,*) "|                                               |"
    write(*,*) "|      Created by Cory Goates, (c) 2021         |"
    write(*,*) "|                                               |"
    write(*,*) "-------------------------------------------------"
    write(*,*) ""

    ! Load input
    call getarg(1, input_file)
    write(*,*) "Got input file: ", input_file
    write(*,*) "Loading input..."
    call ns_case_load_input(case, input_file)

    ! Run case
    write(*,*) ""
    write(*,*) "Running case..."
    call ns_case_run_simple(case)

    ! Output

    ! Print quit message
    write(*,*) ""
    write(*,*) "-------------------------------------------------"
    write(*,*) "|                                               |"
    write(*,*) "|         Flow81 finished successfully          |"
    write(*,*) "|                                               |"
    write(*,*) "-------------------------------------------------"
    write(*,*) ""

end program navier_stokes