subroutine Curve2Mask(dhgrid, n, sampling, profile, nprofile, NP)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Given a list of coordinates of a SINGLE CLOSED CURVE, this routine
!	will fill the interior and exterior with 0s and 1s. The value at the
!	north pole (either 0 or 1) is specified by the input parameter NP.
!
!	Calling Parameters
!		IN
!			profile		Latitude (:,1) and longitude (:,2) coordinates of a
!					single close curve having dimension (nprofile, 2).
!			nprofile 	Number of coordinates in the vector profile.
!			np		Value of the output function at the North Pole, which can
!					be either 0 or 1.
!			n		Number of latitude bands in the output Driscoll and Healy sampled
!					grid.
!			sampling	1 sets the number of longitude bands equal to 1, whereas 2
!					sets the number to twice that of n.
!		OUT
!			dhgrid		A Driscoll and Healy sampled grid specifiying whether the point
!					is in the curve (1), or outside of it (0).
!
!
!	Written by Mark Wieczorek (August 2009)
!
!	Copyright (c) 2009, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(out) ::		dhgrid(:,:)
	real*8, intent(in) ::		profile(:,:)
	integer, intent(in) ::		n, sampling, nprofile, np
	integer, parameter ::		maxcross = 1000
	integer ::			i, j, k, k_loc, nlat, nlong, numcross, next, ind1, ind2
	real*8 ::			lat_int, long_int, lon, cross(maxcross), cross_sort(maxcross)

	nlat = n
	lat_int = 180.0d0 / dble(nlat)
	dhgrid = 0

	if (sampling == 1) then
		nlong = nlat
		long_int = 2.0d0 * lat_int
	elseif(sampling == 2) then
		nlong = 2 * nlat
		long_int = lat_int
	else
		print*, "Error --- Curve2Mask"
		print*, "SAMPLING of DHGRID must be 1 (equally sampled) or 2 (equally spaced)."
		print*, "SAMPLING = ", sampling
		stop
	endif

	if (NP /=1 .and. NP /= 0) then
		print*, "Error --- Curve2Mask"
		print*, "NP must be 0 if the North pole is outside of curve,"
		print*, "or 1 if the North pole is inside of the curve."
		print*, "NP = ", np
		stop
	endif

	if (size(dhgrid(1,:)) < nlong .or. size(dhgrid(:,1)) < nlat ) then
		print*, "Error --- Curve2Mask"
		print*, "DHGRID must be dimensioned as (NLAT, NLONG)."
		print*, "NLAT = ", nlat
		print*, "NLONG = ", nlong
		print*, "Size of GRID = ", size(dhgrid(:,1)), size(dhgrid(1,:))
	endif

	if (size(profile(:,1)) < nprofile .or. size(profile(1,:)) < 2) then
		print*, "Error --- Curve2Mask"
		print*, "PROFILE must be dimensioned as (NPROFILE, 2)."
		print*, "Dimension of NPROFILE = ", size(profile(:,1)), size(profile(1,:))
		stop
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Start at 90N and 0E. Determine where the curve crosses this longitude band,
	!	sort the values, and then set the pixels between zero crossings to either 0
	!	or 1.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do j=1, nlong
		lon = dble(j-1)*long_int

		numcross = 0
		do i=1, nprofile-1
			if (profile(i,2) <= lon .and. profile(i+1,2) > lon) then
				numcross = numcross + 1
				if (numcross > maxcross) then
					print*, "Error --- Curve2Mask"
					print*, "Internal variable MAXCROSS needs to be increased."
					print*, "MAXCROSS = ", maxcross
					stop
				endif
				cross(numcross) = profile(i,1) + (profile(i+1,1)-profile(i,1)) / &
						(profile(i+1,2)-profile(i,2)) * (lon - profile(i,2))
			elseif (profile(i,2) >= lon .and. profile(i+1,2) < lon) then
				numcross = numcross + 1
				if (numcross > maxcross) then
					print*, "Error --- Curve2Mask"
					print*, "Internal variable MAXCROSS needs to be increased."
					print*, "MAXCROSS = ", maxcross
					stop
				endif
				cross(numcross) = profile(i+1,1) + (profile(i,1)-profile(i+1,1)) / &
						(profile(i,2)-profile(i+1,2)) * (lon - profile(i+1,2))
			endif
		enddo

		! do first and last points

		if (profile(nprofile,2) <= lon .and. profile(1,2) > lon) then
			numcross = numcross + 1
			if (numcross > maxcross) then
				print*, "Error --- Curve2Mask"
				print*, "Internal variable MAXCROSS needs to be increased."
				print*, "MAXCROSS = ", maxcross
				stop
			endif
			cross(numcross) = profile(nprofile,1) + (profile(1,1)-profile(nprofile,1)) / &
					(profile(1,2)-profile(nprofile,2)) * (lon - profile(nprofile,2))
		elseif (profile(nprofile,2) >= lon .and. profile(1,2) < lon) then
			numcross = numcross + 1
			if (numcross > maxcross) then
				print*, "Error --- Curve2Mask"
				print*, "Internal variable MAXCROSS needs to be increased."
				print*, "MAXCROSS = ", maxcross
				stop
			endif
			cross(numcross) = profile(1,1) + (profile(nprofile,1)-profile(1,1)) / &
					(profile(nprofile,2)-profile(1,2)) * (lon - profile(1,2))
		endif

		if (numcross > 0) then	! sort crossings by decreasing latitude
			do k=1, numcross
				k_loc = maxloc(cross(1:numcross), 1)
				cross_sort(k) = cross(k_loc)
				cross(k_loc) = -999.0d0
			enddo
		endif

		if (numcross == 0) then
			dhgrid(1:nlat, j) = np

		elseif (numcross == 1) then
			ind1 = int( (90.0d0 - cross_sort(1)) / lat_int) + 1
			dhgrid(1:ind1, j) = np
			if (ind1 == nlat) then
				cycle
			elseif (np == 0) then
				dhgrid(ind1+1:nlat, j) = 1
			else
				dhgrid(ind1+1:nlat, j) = 0
			endif

		else
			ind1 = 1
			next = np
			do k=1, numcross
				ind2 = int( (90.0d0 - cross_sort(k)) / lat_int) + 1
				if (ind2 >= ind1) dhgrid(ind1:ind2, j) = next
				if (next == 0) then
					next = 1
				else
					next = 0
				endif
				ind1 = ind2 + 1
			enddo

			if (ind1 <= nlat) dhgrid(ind1:nlat, j) = next

		endif

	enddo

end subroutine Curve2Mask


      FUNCTION FNORM(X)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION X(3)
C
C********FUNCTION FNORM COMPUTES THE MAGNITUDE OF VECTOR X
C
      FNORM=DSQRT(X(1)**2+X(2)**2+X(3)**2)
      RETURN
      END


!##############################################
!##########Compile Instructions###############
!"chmod +x config.sh"
!"./config.sh"
!
!###########Execution######################
!"./cpflow_1D.exe"
!
!##############################################

program cpflow1D

use module_parameters
use module_grid
use module_solver
use module_triSolve

IMPLICIT NONE

        INTEGER		    ::I,K
	REAL(8)	            ::UMAX,UAVG,UTAU1,UTAU2
	REAL(8),ALLOCATABLE ::YHAD(:),YPAD(:),A(:),B(:)
	REAL(8),ALLOCATABLE ::U(:),U1(:),DYN_VIS_TUR(:),MIX_LEN(:),LEN_ZERO(:),TKIN_VIS(:),TKIN_VISN(:),TKIN_VISS(:),LD(:),MD(:),UD(:),D(:)
	REAL(8)	::A1,A2,ERROR
        CHARACTER(len=100)::excommand

        !CASE SELECTION
        CHARACTER(len=15):: OUTPUTFILE
        !CHARACTER(len=20):: OUTPUTFILE  !DELETE LATER

        REAL(8)          ::VW, H, DPDX
        INTEGER:: NUM_CASE

        DO NUM_CASE=1,18
        !NUM_CASE=2

        PRINT*, "####### 1D Couette_Poiseuille-FlowCode ###"

        !managing filenames
        if (NUM_CASE < 10) then
                  write (OUTPUTFILE, "(A6,I1,A8)") "Case_0",NUM_CASE,"_sim.dat"
                  !write (CHARA,*) ALPHA
                  !write (OUTPUTFILE, "(A6,I1,A1)") "Case_0",NUM_CASE,"_"
                  !write (OUTPUTFILE,*) OUTPUTFILE//CHARA//"_sim.dat"
        else
                  write (OUTPUTFILE, "(A5,I2,A8)") "Case_",NUM_CASE,"_sim.dat"
        endif
        CALL case_select(NUM_CASE,VW, H, DPDX)

        print *, "The case selected is CASE NUMBER ",NUM_CASE
        print *, "Here, the values of VW, H, DPDX are ",VW, H, DPDX, "respectively."
        print *, "The data generated will be saved to file ", OUTPUTFILE

	ALLOCATE(YPAD(N),YHAD(N),U(N),U1(N),DYN_VIS_TUR(N),MIX_LEN(N),LEN_ZERO(N),A(N),B(N))
	ALLOCATE(TKIN_VIS(N),TKIN_VISN(N),TKIN_VISS(N),LD(N),MD(N),UD(N),D(N))
	U=0.0d0
	!TKIN_VIS is the turbulent kinematic viscosity
	!YPAD is the y coordinates of the mesh
	!YHAD(n) is the distance between YPAD(n) & YPAD(n-1)
	!UMAX= MAX VEL IN THE FLOW
	!UAVG= AVG VEL IN THE FLOW

	CALL sGrid_Generator(H,N,ALPHA,YPAD,YHAD)		!Stretched grid generator

	CALL SOLVE_CP(U,ERROR,U1,VW,H,N,LD,MD,UD,D,YPAD,YHAD,ALPHA,DPDX,DYN_VIS,KIN_VIS,RHO,CONV_CRIT,MAX_ITER,OUTPUTFILE,NUM_CASE)
!CALL SOLVE_CP(U,ERROR,U1,VW,H,N,LD,MD,UD,D,YPAD,YHAD,ALPHA,DPDX,DYN_VIS,KIN_VIS,RHO,CONV_CRIT,OUTPUTFILE,NUM_CASE)

        !Data Management
        print *, "Copying Generated GRID.dat to the directory Simulated_Data  . . . . "
        call system('cp GRID.dat ../Simulated_Data/GRID.dat')
        print *, "Copied Successfully "

        print *, "Copying Generated simulation data to the directory Simulated_Data . . . ."
        excommand="cp "//OUTPUTFILE//" ../Simulated_Data/"//OUTPUTFILE
        !print *, trim(excommand)
        call system(trim(excommand))
        print *, "Copied Successfully "

        !Plotting
        excommand="python plot_case.py --file "//OUTPUTFILE
        if (PLOT=='Y') then
        print *, "Creating Plots . . . ."
        !print *, trim(excommand)
        call system(trim(excommand))
        else
        print *, "Auto Plotting Disabled"
        end if

        DEALLOCATE(YPAD,YHAD,U,U1,DYN_VIS_TUR,MIX_LEN,LEN_ZERO,A,B)
	DEALLOCATE(TKIN_VIS,TKIN_VISN,TKIN_VISS,LD,MD,UD,D)

       END DO

end program


	SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func)
	USE nrtype; USE nrutil, ONLY : swap
	IMPLICIT NONE
	REAL(SP), INTENT(INOUT) :: ax,bx
	REAL(SP), INTENT(OUT) :: cx,fa,fb,fc
	INTERFACE
		FUNCTION func(x)
		USE nrtype
		IMPLICIT NONE
		REAL(SP), INTENT(IN) :: x
		REAL(SP) :: func
		END FUNCTION func
	END INTERFACE
	REAL(SP), PARAMETER :: GOLD=1.618034_sp,GLIMIT=100.0_sp,TINY=1.0e-20_sp
	REAL(SP) :: fu,q,r,u,ulim
	fa=func(ax)
	fb=func(bx)
	if (fb > fa) then
		call swap(ax,bx)
		call swap(fa,fb)
	end if
	cx=bx+GOLD*(bx-ax)
	fc=func(cx)
	do
		if (fb < fc) RETURN
		r=(bx-ax)*(fb-fc)
		q=(bx-cx)*(fb-fa)
		u=bx-((bx-cx)*q-(bx-ax)*r)/(2.0_sp*sign(max(abs(q-r),TINY),q-r))
		ulim=bx+GLIMIT*(cx-bx)
		if ((bx-u)*(u-cx) > 0.0) then
			fu=func(u)
			if (fu < fc) then
				ax=bx
				fa=fb
				bx=u
				fb=fu
				RETURN
			else if (fu > fb) then
				cx=u
				fc=fu
				RETURN
			end if
			u=cx+GOLD*(cx-bx)
			fu=func(u)
		else if ((cx-u)*(u-ulim) > 0.0) then
			fu=func(u)
			if (fu < fc) then
				bx=cx
				cx=u
				u=cx+GOLD*(cx-bx)
				call shft(fb,fc,fu,func(u))
			end if
		else if ((u-ulim)*(ulim-cx) >= 0.0) then
			u=ulim
			fu=func(u)
		else
			u=cx+GOLD*(cx-bx)
			fu=func(u)
		end if
		call shft(ax,bx,cx,u)
		call shft(fa,fb,fc,fu)
	end do
	CONTAINS
!BL
	SUBROUTINE shft(a,b,c,d)
	REAL(SP), INTENT(OUT) :: a
	REAL(SP), INTENT(INOUT) :: b,c
	REAL(SP), INTENT(IN) :: d
	a=b
	b=c
	c=d
	END SUBROUTINE shft
	END SUBROUTINE mnbrak


      recursive subroutine fpinst(iopt,t,n,c,k,x,l,tt,nn,cc,nest)
      implicit none
c  given the b-spline representation (knots t(j),j=1,2,...,n, b-spline
c  coefficients c(j),j=1,2,...,n-k-1) of a spline of degree k, fpinst
c  calculates the b-spline representation (knots tt(j),j=1,2,...,nn,
c  b-spline coefficients cc(j),j=1,2,...,nn-k-1) of the same spline if
c  an additional knot is inserted at the point x situated in the inter-
c  val t(l)<=x<t(l+1). iopt denotes whether (iopt.ne.0) or not (iopt=0)
c  the given spline is periodic. in case of a periodic spline at least
c  one of the following conditions must be fulfilled: l>2*k or l<n-2*k.
c
c  ..scalar arguments..
      integer k,n,l,nn,iopt,nest
      real*8 x
c  ..array arguments..
      real*8 t(nest),c(nest),tt(nest),cc(nest)
c  ..local scalars..
      real*8 fac,per,one
      integer i,i1,j,k1,m,mk,nk,nk1,nl,ll
c  ..
      one = 0.1e+01
      k1 = k+1
      nk1 = n-k1
c  the new knots
      ll = l+1
      i = n
      do 10 j=ll,n
         tt(i+1) = t(i)
         i = i-1
  10  continue
      tt(ll) = x
      do 20 j=1,l
         tt(j) = t(j)
  20  continue
c  the new b-spline coefficients
      i = nk1
      do 30 j=l,nk1
         cc(i+1) = c(i)
         i = i-1
  30  continue
      i = l
      do 40 j=1,k
         m = i+k1
         fac = (x-tt(i))/(tt(m)-tt(i))
         i1 = i-1
         cc(i) = fac*c(i)+(one-fac)*c(i1)
         i = i1
  40  continue
      do 50 j=1,i
         cc(j) = c(j)
  50  continue
      nn = n+1
      if(iopt.eq.0) return
c   incorporate the boundary conditions for a periodic spline.
      nk = nn-k
      nl = nk-k1
      per = tt(nk)-tt(k1)
      i = k1
      j = nk
      if(ll.le.nl) go to 70
      do 60 m=1,k
         mk = m+nl
         cc(m) = cc(mk)
         i = i-1
         j = j-1
         tt(i) = tt(j)-per
  60  continue
      return
  70  if(ll.gt.(k1+k)) return
      do 80 m=1,k
         mk = m+nl
         cc(mk) = cc(m)
         i = i+1
         j = j+1
         tt(j) = tt(i)+per
  80  continue
      return
      end


      program dndrv3
c
c     Simple program to illustrate the idea of reverse communication
c     in inverse mode for a generalized nonsymmetric eigenvalue problem.
c
c     We implement example three of ex-nonsym.doc in DOCUMENTS directory
c
c\Example-3
c     ... Suppose we want to solve A*x = lambda*B*x in inverse mode,
c         where A and B are derived from the finite element discretization
c         of the 1-dimensional convection-diffusion operator
c                           (d^2u / dx^2) + rho*(du/dx)
c         on the interval [0,1] with zero Dirichlet boundary condition
c         using linear elements.
c
c     ... So OP = inv[M]*A  and  B = M.
c
c     ... Use mode 2 of DNAUPD.
c
c\BeginLib
c
c\Routines called:
c     dnaupd  ARPACK reverse communication interface routine.
c     dneupd  ARPACK routine that returns Ritz values and (optionally)
c             Ritz vectors.
c     dpttrf  LAPACK symmetric positive definite tridiagonal factorization
c             routine.
c     dpttrs  LAPACK symmetric positive definite tridiagonal solve routine.
c     dlapy2  LAPACK routine to compute sqrt(x**2+y**2) carefully.
c     daxpy   Level 1 BLAS that computes y <- alpha*x+y.
c     dnrm2   Level 1 BLAS that computes the norm of a vector.
c     av      Matrix vector multiplication routine that computes A*x.
c     mv      Matrix vector multiplication routine that computes M*x.
c
c\Author
c     Richard Lehoucq
c     Danny Sorensen
c     Chao Yang
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\SCCS Information: @(#)
c FILE: ndrv3.F   SID: 2.5   DATE OF SID: 10/17/00   RELEASE: 2
c
c\Remarks
c     1. None
c
c\EndLib
c--------------------------------------------------------------------------
c
c     %-----------------------------%
c     | Define leading dimensions   |
c     | for all arrays.             |
c     | MAXN:   Maximum dimension   |
c     |         of the A allowed.   |
c     | MAXNEV: Maximum NEV allowed |
c     | MAXNCV: Maximum NCV allowed |
c     %-----------------------------%
c
      integer           maxn, maxnev, maxncv, ldv
      parameter         (maxn=256, maxnev=10, maxncv=25,
     &                   ldv=maxn )
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      integer           iparam(11), ipntr(14)
      logical           select(maxncv)
      Double precision
     &                  ax(maxn), mx(maxn), d(maxncv, 3), resid(maxn),
     &                  v(ldv,maxncv), workd(3*maxn),
     &                  workev(3*maxncv),
     &                  workl(3*maxncv*maxncv+6*maxncv),
     &                  md(maxn), me(maxn-1)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      character         bmat*1, which*2
      integer           ido, n, nev, ncv, lworkl, info, ierr, j,
     &                  nconv, maxitr, ishfts, mode
      Double precision
     &                  tol, sigmar, sigmai, h
      logical           first, rvec
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Double precision
     &                  zero, one
      parameter         (zero = 0.0D+0, one = 1.0D+0)
c
c     %-----------------------------%
c     | BLAS & LAPACK routines used |
c     %-----------------------------%
      Double precision
     &                  dnrm2, dlapy2
      external          daxpy, dnrm2, dpttrf, dpttrs, dlapy2
c
c     %--------------------%
c     | Intrinsic function |
c     %--------------------%
c
      intrinsic         abs
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
c     %----------------------------------------------------%
c     | The number N is the dimension of the matrix.  A    |
c     | generalized eigenvalue problem is solved (BMAT =   |
c     | 'G').  NEV is the number of eigenvalues to be      |
c     | approximated.  The user can modify NEV, NCV, WHICH |
c     | to solve problems of different sizes, and to get   |
c     | different parts of the spectrum.  However, The     |
c     | following conditions must be satisfied:            |
c     |                    N <= MAXN,                      |
c     |                  NEV <= MAXNEV,                    |
c     |              NEV + 2 <= NCV <= MAXNCV              |
c     %----------------------------------------------------%
c
      n     = 100
      nev   = 4
      ncv   = 20
      if ( n .gt. maxn ) then
         print *, ' ERROR with _NDRV3: N is greater than MAXN '
         go to 9000
      else if ( nev .gt. maxnev ) then
         print *, ' ERROR with _NDRV3: NEV is greater than MAXNEV '
         go to 9000
      else if ( ncv .gt. maxncv ) then
         print *, ' ERROR with _NDRV3: NCV is greater than MAXNCV '
         go to 9000
      end if
      bmat  = 'G'
      which = 'LM'
c
c     %------------------------------------------------%
c     | M is the mass matrix formed by using piecewise |
c     | linear elements on [0,1].                      |
c     %------------------------------------------------%
c
      h = one / dble(n+1)
      do 20 j = 1, n-1
         md(j) = 4.0D+0*h
         me(j) = one*h
  20  continue
      md(n) = 4.0D+0*h
c
      call dpttrf(n, md, me, ierr)
      if ( ierr .ne. 0 ) then
         print*, ' '
         print*, ' ERROR with _pttrf. '
         print*, ' '
         go to 9000
      end if
c
c     %-----------------------------------------------------%
c     | The work array WORKL is used in DNAUPD as           |
c     | workspace.  Its dimension LWORKL is set as          |
c     | illustrated below.  The parameter TOL determines    |
c     | the stopping criterion. If TOL<=0, machine          |
c     | precision is used.  The variable IDO is used for    |
c     | reverse communication, and is initially set to 0.   |
c     | Setting INFO=0 indicates that a random vector is    |
c     | generated in DNAUPD to start the Arnoldi iteration. |
c     %-----------------------------------------------------%
c
      lworkl = 3*ncv**2+6*ncv
      tol    = 0.0
      ido    = 0
      info   = 0
c
c     %---------------------------------------------------%
c     | This program uses exact shifts with respect to    |
c     | the current Hessenberg matrix (IPARAM(1) = 1).    |
c     | IPARAM(3) specifies the maximum number of Arnoldi |
c     | iterations allowed.  Mode 2 of DNAUPD is used     |
c     | (IPARAM(7) = 2).  All these options can be        |
c     | changed by the user. For details, see the         |
c     | documentation in DNAUPD.                          |
c     %---------------------------------------------------%
c
      ishfts = 1
      maxitr = 300
      mode   = 2
c
      iparam(1) = ishfts
      iparam(3) = maxitr
      iparam(7) = mode
c
c     %-------------------------------------------%
c     | M A I N   L O O P (Reverse communication) |
c     %-------------------------------------------%
c
 10   continue
c
c        %---------------------------------------------%
c        | Repeatedly call the routine DNAUPD and take |
c        | actions indicated by parameter IDO until    |
c        | either convergence is indicated or maxitr   |
c        | has been exceeded.                          |
c        %---------------------------------------------%
c
         call dnaupd ( ido, bmat, n, which, nev, tol, resid,
     &                 ncv, v, ldv, iparam, ipntr, workd,
     &                 workl, lworkl, info )
c
         if (ido .eq. -1 .or. ido .eq. 1) then
c
c           %----------------------------------------%
c           | Perform  y <--- OP*x = inv[M]*A*x      |
c           | The user should supply his/her own     |
c           | matrix vector routine and a linear     |
c           | system solver.  The matrix-vector      |
c           | subroutine should take workd(ipntr(1)) |
c           | as input, and the final result should  |
c           | be returned to workd(ipntr(2)).        |
c           %----------------------------------------%
c
            call av (n, workd(ipntr(1)), workd(ipntr(2)))
            call dpttrs(n, 1, md, me, workd(ipntr(2)), n,
     &                  ierr)
            if ( ierr .ne. 0 ) then
               print*, ' '
               print*, ' ERROR with _pttrs. '
               print*, ' '
               go to 9000
            end if
c
c           %-----------------------------------------%
c           | L O O P   B A C K to call DNAUPD again. |
c           %-----------------------------------------%
c
            go to 10
c
         else if ( ido .eq. 2) then
c
c           %-------------------------------------%
c           |        Perform  y <--- M*x          |
c           | The matrix vector multiplication    |
c           | routine should take workd(ipntr(1)) |
c           | as input and return the result to   |
c           | workd(ipntr(2)).                    |
c           %-------------------------------------%
c
            call mv (n, workd(ipntr(1)), workd(ipntr(2)))
c
c           %-----------------------------------------%
c           | L O O P   B A C K to call DNAUPD again. |
c           %-----------------------------------------%
c
            go to 10
c
         end if
c
c
c     %-----------------------------------------%
c     | Either we have convergence, or there is |
c     | an error.                               |
c     %-----------------------------------------%
c
      if ( info .lt. 0 ) then
c
c        %--------------------------%
c        | Error message. Check the |
c        | documentation in DNAUPD. |
c        %--------------------------%
c
         print *, ' '
         print *, ' Error with _naupd, info = ', info
         print *, ' Check the documentation of _naupd.'
         print *, ' '
c
      else
c
c        %-------------------------------------------%
c        | No fatal errors occurred.                 |
c        | Post-Process using DNEUPD.                |
c        |                                           |
c        | Computed eigenvalues may be extracted.    |
c        |                                           |
c        | Eigenvectors may also be computed now if  |
c        | desired.  (indicated by rvec = .true.)    |
c        %-------------------------------------------%
c
         rvec = .true.
         call dneupd ( rvec, 'A', select, d, d(1,2), v, ldv,
     &        sigmar, sigmai, workev, bmat, n, which, nev, tol,
     &        resid, ncv, v, ldv, iparam, ipntr, workd,
     &        workl, lworkl, ierr )
c
c        %-----------------------------------------------%
c        | The real part of the eigenvalue is returned   |
c        | in the first column of the two dimensional    |
c        | array D, and the IMAGINARY part is returned   |
c        | in the second column of D.  The corresponding |
c        | eigenvectors are returned in the first NEV    |
c        | columns of the two dimensional array V if     |
c        | requested.  Otherwise, an orthogonal basis    |
c        | for the invariant subspace corresponding to   |
c        | the eigenvalues in D is returned in V.        |
c        %-----------------------------------------------%
c
         if ( ierr .ne. 0 ) then
c
c           %------------------------------------%
c           | Error condition:                   |
c           | Check the documentation of DNEUPD. |
c           %------------------------------------%
c
            print *, ' '
            print *, ' Error with _neupd, info = ', ierr
            print *, ' Check the documentation of _neupd'
            print *, ' '
c
         else
c
            first = .true.
            nconv = iparam(5)
            do 30 j=1, iparam(5)
c
c              %---------------------------%
c              | Compute the residual norm |
c              |                           |
c              |  ||  A*x - lambda*M*x ||  |
c              |                           |
c              | for the NCONV accurately  |
c              | computed eigenvalues and  |
c              | eigenvectors.  (iparam(5) |
c              | indicates how many are    |
c              | accurate to the requested |
c              | tolerance)                |
c              %---------------------------%
c
               if (d(j,2) .eq. zero)  then
c
c                 %--------------------%
c                 | Ritz value is real |
c                 %--------------------%
c
                  call av(n, v(1,j), ax)
                  call mv(n, v(1,j), mx)
                  call daxpy(n, -d(j,1), mx, 1, ax, 1)
                  d(j,3) = dnrm2(n, ax, 1)
                  d(j,3) = d(j,3) / abs(d(j,1))
c
               else if (first) then
c
c                 %------------------------%
c                 | Ritz value is complex  |
c                 | Residual of one Ritz   |
c                 | value of the conjugate |
c                 | pair is computed.      |
c                 %------------------------%
c
                  call av(n, v(1,j), ax)
                  call mv(n, v(1,j), mx)
                  call daxpy(n, -d(j,1), mx, 1, ax, 1)
                  call mv(n, v(1,j+1), mx)
                  call daxpy(n, d(j,2), mx, 1, ax, 1)
                  d(j,3) = dnrm2(n, ax, 1)**2
                  call av(n, v(1,j+1), ax)
                  call mv(n, v(1,j+1), mx)
                  call daxpy(n, -d(j,1), mx, 1, ax, 1)
                  call mv(n, v(1,j), mx)
                  call daxpy(n, -d(j,2), mx, 1, ax, 1)
                  d(j,3) = dlapy2( d(j,3), dnrm2(n, ax, 1) )
                  d(j,3) = d(j,3) / dlapy2(d(j,1),d(j,2))
                  d(j+1,3) = d(j,3)
                  first = .false.
               else
                  first = .true.
               end if
c
  30        continue
c
c           %-----------------------------%
c           | Display computed residuals. |
c           %-----------------------------%
c
            call dmout(6, nconv, 3, d, maxncv, -6,
     &           'Ritz values (Real,Imag) and relative residuals')
c
         end if
c
c        %------------------------------------------%
c        | Print additional convergence information |
c        %------------------------------------------%
c
         if ( info .eq. 1) then
            print *, ' '
            print *, ' Maximum number of iterations reached.'
            print *, ' '
         else if ( info .eq. 3) then
            print *, ' '
            print *, ' No shifts could be applied during implicit',
     &               ' Arnoldi update, try increasing NCV.'
            print *, ' '
         end if
c
         print *, ' '
         print *, ' _NDRV3 '
         print *, ' ====== '
         print *, ' '
         print *, ' Size of the matrix is ', n
         print *, ' The number of Ritz values requested is ', nev
         print *, ' The number of Arnoldi vectors generated',
     &            ' (NCV) is ', ncv
         print *, ' What portion of the spectrum: ', which
         print *, ' The number of converged Ritz values is ',
     &              nconv
         print *, ' The number of Implicit Arnoldi update',
     &            ' iterations taken is ', iparam(3)
         print *, ' The number of OP*x is ', iparam(9)
         print *, ' The convergence criterion is ', tol
         print *, ' '
c
      end if
c
c     %---------------------------%
c     | Done with program dndrv3. |
c     %---------------------------%
c
 9000 continue
c
      end
c
c==========================================================================
c
c     matrix vector multiplication subroutine
c
      subroutine av (n, v, w)
      integer           n, j
      Double precision
     &                  v(n), w(n), one, two, dd, dl, du, s, h, rho
      parameter         ( rho = 1.0D+1, one = 1.0D+0,
     &                    two = 2.0D+0)
c
c     Compute the matrix vector multiplication y<---A*x
c     where A is stiffness matrix obtained from the finite element
c     discretization of the 1-dimensional convection diffusion operator
c                           d^2u/dx^2 + rho*(du/dx)
c     on the interval [0,1] with zero Dirichlet boundary condition using
c     linear elements.
c
      h = one / dble(n+1)
      s = rho / two
      dd = two / h
      dl = -one/h - s
      du = -one/h + s
c
      w(1) =  dd*v(1) + du*v(2)
      do 10 j = 2,n-1
         w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1)
 10   continue
      w(n) =  dl*v(n-1) + dd*v(n)
      return
      end
c------------------------------------------------------------------------
      subroutine mv (n, v, w)
      integer           n, j
      Double precision
     &                  v(n), w(n), one, four, h
      parameter         ( one = 1.0D+0, four = 4.0D+0)
c
c     Compute the matrix vector multiplication y<---M*x
c     where M is the mass matrix formed by using piecewise linear
c     elements on [0,1].
c
      w(1) =  four*v(1) + one*v(2)
      do 10 j = 2,n-1
         w(j) = one*v(j-1) + four*v(j) + one*v(j+1)
 10   continue
      w(n) =  one*v(n-1) + four*v(n)
c
      h = one / dble(n+1)
      call dscal(n, h, w, 1)
      return
      end


************************************************************************
*
*     Function DLSVMN                                 Called by: DGQTST
*
*     returns a good over-estimate of the smallest singular value of
*     the packed lower triangular matrix L.
*
C  NP (IN)  = THE ORDER OF L -1.  L IS A  NP+1 X NP+1  LOWER TRIANGULAR MATRIX.
C  L (IN)  = ARRAY HOLDING THE ELEMENTS OF  L  IN ROW ORDER, I.E.
C             L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC.
C  X (OUT) IF DLSVMN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED
C             APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE
C             SMALLEST SINGULAR VALUE.  THIS APPROXIMATION MAY BE VERY
C             CRUDE.  IF DLSVMN RETURNS ZERO, THEN SOME COMPONENTS OF X
C             ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES.
C  Y (OUT) IF DLSVMN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN
C             UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND-
C             ING TO THE SMALLEST SINGULAR VALUE.  THIS APPROXIMATION
C             MAY BE CRUDE.  IF DLSVMN RETURNS ZERO, THEN Y RETAINS ITS
C             INPUT VALUE.  THE CALLER MAY PASS THE SAME VECTOR FOR X
C             AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER-
C             WRITES X (FOR NONZERO DLSVMN RETURNS).
C
C     THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT
C     DLSVMN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L
C     (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE
C     LARGEST.  THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED
C     IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE
C     (2) AND (3).
C
C
C     (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977),
C         AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT
C         TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY.
C
C     (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL
C         RANDOM-NUMBER GENERATORS --  AN EMPIRICAL VIEW,
C         MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV.
C
C     (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2
C         (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS.
C
C     (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER
C         GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18,
C         PP. 586-593.
C
C
C     DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978).
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
*
************************************************************************
      DOUBLE PRECISION FUNCTION DLSVMN(NP,L,X,Y)
*
*     subroutine arguments
*
      INTEGER*4 NP
      DOUBLE PRECISION L(*),X(*),Y(*)
*
*     local variables
*
      INTEGER*4 I,II,IX,J,JJ,JJJ,JM1,J0
      DOUBLE PRECISION B,SMINUS,SPLUS,T,XMINUS,XPLUS
*
*     function declarations
*
      DOUBLE PRECISION DDOT,DNRM2
*
*     check whether to return DLSVMN = 0 and initialize X
*
      IX = 2
      II = 0
      J0 = (NP+1)*NP/2
      JJ = J0 + NP + 1
      IF (L(JJ) .EQ. 0.D0) THEN
         DLSVMN = 0.D0
         RETURN
      ENDIF
      IX = MOD(3432*IX, 9973)
      B = 0.5D0*(1.D0 + FLOAT(IX)/9973.D0)
      XPLUS = B / L(JJ)
      X(NP+1) = XPLUS

      DO 10 I=1,NP
         II = II + I
         IF (L(II) .EQ. 0.D0) THEN
            DLSVMN = 0.D0
            RETURN
         ENDIF
         X(I) = XPLUS * L(J0+I)
 10   CONTINUE
*
*     solve (L**T)*X = B, where the components of B have randomly
*     chosen magnitudes in (.5,1) with signs chosen to make X large
*
      DO 50 JJJ=1,NP
         J = NP + 1 - JJJ
*
*        determine X(J) in this iteration; for I = 1,2,...,J, X(I)
*        holds the current partial sum for row I
*
         IX = MOD(3432*IX, 9973)
         B = 0.5D0*(1.D0 + FLOAT(IX)/9973.D0)
         XPLUS = (B - X(J))
         XMINUS = (-B - X(J))
         SPLUS = DABS(XPLUS)
         SMINUS = DABS(XMINUS)
         JM1 = J - 1
         J0 = J*JM1/2
         JJ = J0 + J
         XPLUS = XPLUS/L(JJ)
         XMINUS = XMINUS/L(JJ)

         DO 20 I = 1,JM1
            SPLUS = SPLUS + DABS(X(I) + L(J0+I)*XPLUS)
            SMINUS = SMINUS + DABS(X(I) + L(J0+I)*XMINUS)
 20      CONTINUE

         IF (SMINUS .GT. SPLUS) XPLUS = XMINUS
         X(J) = XPLUS
*
*        update partial sums
*
         DO 30 I=1,JM1
            X(I) = XPLUS*L(J0+I) + X(I)
 30      CONTINUE

 50   CONTINUE
*
*     normalize X
*
      T = 1.D0/DNRM2(NP+1,X)
      DO 70 I = 1,NP+1
         X(I) = T*X(I)
 70   CONTINUE
*
*     solve L*Y = X and return DLSVMN = 1/TWONORM(Y)
*
      DO 100 J = 1,NP+1
         JM1 = J - 1
         J0 = J*JM1/2
         JJ = J0 + J
         T=0.D0
         IF(JM1.GT.0)T = DDOT(JM1,L(J0+1),Y)
         Y(J)=(X(J)-T)/L(JJ)
 100  CONTINUE

      DLSVMN = 1.D0/DNRM2(NP+1,Y)

      RETURN
      END


	SUBROUTINE GQGRAF ( ixtyp, iytyp, yszxsz, xlm, ybm, xrm, ytm,
     +	                    iret )
C************************************************************************
C* GQGRAF								*
C*									*
C* This subroutine returns the current coordinate system definition 	*
C* for the graph plotting mode of the map/graph coordinate system.	*
C*									*
C* GQGRAF  ( IXTYP, IYTYP, YSZXSZ, XLM, YBM, XRM, YTM, IRET )		*
C* 									*
C* Output parameters:							*
C* 	IXTYP		INTEGER		X coordinate type number	*
C*					   1 = linear			*
C*					   2 = logarithmic		*
C*					   3 = ** KAPPA (2/7)		*
C*					   4 = skew			*
C* 	IYTYP		INTEGER		Y coordinate type number	*
C*					   1 = linear			*
C*					   2 = logarithmic		*
C*					   3 = ** KAPPA (2/7)		*
C* 	YSZXSZ		REAL		Height to width ratio of plot	*
C* 	XLM		REAL		Left limit of X axis 		*
C* 	YBM		REAL		Bottom limit of Y axis 		*
C* 	XRM		REAL		Right limit of X axis 		*
C* 	YTM		REAL		Top limit of Y axis 		*
C* 	IRET 		INTEGER		Return code			*
C**									*
C* Log:									*
C* I. Graffman/RDS	 5/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 9/88	Cleaned up				*
C* L. Williams/EAi       3/94   Removed blank comments from header      *
C* A. Hardy/GSC          6/98   Cleaned up prolog                       *
C************************************************************************
	INCLUDE 	'FUNCCODE.PRM'
	INCLUDE 	'ERROR.PRM'
C*
	INTEGER 	isend (2), ircv (3)
	REAL 		rrcv (5)
C------------------------------------------------------------------------
C*	Load input parameters into buffer and write them to the mailbox.
C
	isend (1) = 2
	isend (2) = FQGRAF
	CALL GPUT  ( isend, 2, iret )
	IF  ( iret .ne. NORMAL )  RETURN
C
	CALL GGET  ( ircv, 3, iret )
	IF  ( iret .eq. NORMAL )  THEN
	    iret   = ircv (1)
	    ixtyp  = ircv (2)
	    iytyp  = ircv (3)
	END IF
C
	CALL GGETR  ( rrcv, 5, ierr )
	IF  ( ierr .ne. NORMAL )  iret = ierr
	yszxsz = rrcv (1)
	xlm    = rrcv (2)
	ybm    = rrcv (3)
	xrm    = rrcv (4)
	ytm    = rrcv (5)
C*
	RETURN
	END


C                                                                       LOV06850
C     LOVE WAVE MATRIX METHOD INTEGRATION                               LOV06860
C                                                                       LOV06870
      SUBROUTINE  LOVMRX(H,RHO,VS,AX,L,W,C,                             LOV06880
     *                   IA,IG,U,EK,Y0,IER)                             LOV06890
C                                                                       LOV06900
C     INPUT                                                             LOV06910
C       H    : LAYER THICKNESS.  H(L) IS ARBITRARY                      LOV06920
C       RHO  : DENSITY                                                  LOV06930
C       VS   : SHEAR WAVE VELOCITY                                      LOV06940
C       AX   : ANISOTROPY FACTOR XI                                     LOV06950
C       L    : NUMBER OF LAYERS INCLUDING THE BOTTOM                    LOV06960
C              HALF-SPACE                                               LOV06970
C       W    : ANGULAR FREQUENCY                                        LOV06980
C       C    : PHASE VELOCITY                                           LOV06990
C       IA   : = 0 ;   ISOTROPIC MODEL                                  LOV07000
C              = 1 ; ANISOTROPIC MODEL                                  LOV07010
C       IG   : = 1 ; TO COMPUTE Y ONLY                                  LOV07020
C              = 2 ; TO COMPUTE Y AND C*DY/DC                           LOV07030
C              = 3 ; TO COMPUTE Y, C*DY/DC AND W*DY/DW                  LOV07040
C     OUTPUT                                                            LOV07050
C       U    : GROUP VELOCITY BY DIFFERENTIATION (IG=3)                 LOV07060
C       EK   : ENERGY INTEGRAL 2*K**2*I3 BY                             LOV07070
C              DIFFERENTIATION  (IG>=2)                                 LOV07080
C       Y0   : SURFACE VALUE OF Y                                       LOV07090
C              SURFACE VALUE OF C*DY/DC (WHEN IG>=2)                    LOV07100
C              SURFACE VALUE OF W*DY/DW (WHEN IG=3)                     LOV07110
C              Y0(1) ; Y1                                               LOV07120
C              Y0(2) ; Y2/ABS(Y1), DISPERSION FUNCTION                  LOV07130
C                 Y2 HERE IS Y2/K IN THE CONVENTIONAL                   LOV07140
C                 DEFINITION                                            LOV07150
C       IER  : RETURN CODE                                              LOV07160
C              < 0 ; INPUT ERROR                                        LOV07170
C              = 0 ; NO ERROR                                           LOV07180
C                                                                       LOV07190
C     DISPER-80,  VER-86                                                LOV07200
C                                                                       LOV07210
C     M. SAITO  23/VI/79                                                LOV07220
C     REVISED    3/XII/86                                               LOV07230
C                                                                       LOV07240
      DIMENSION  H(L),RHO(L),VS(L),AX(L),Y0(6)                          LOV07250
      DATA  EPS/1.E-10/,BIG/1.E+10/                                     LOV07260
C                                                                       LOV07270
C     DEFINE  SH0(X**2)= SINH(X)/X AND                                  LOV07280
C             SH1(X**2)=(COSH(X)-SINH(X)/X)/X**2                        LOV07290
C                                                                       LOV07300
      SH0(X) = 0.9999997 + X*(0.1666667                                 LOV07310
     *       + X*(0.0083361 + X*0.0001984))                             LOV07320
      SH1(X) = 0.3333333 + X*(0.0333333                                 LOV07330
     *       + X*(0.0011907 + X*0.0000220))                             LOV07340
C                                                                       LOV07350
C     FOR DOUBLE PRECISION USE                                          LOV07360
C                                                                       LOV07370
C     SH0(X) = 1.0D0 + X*(1.6666 66666 66666 7D-1                       LOV07380
C    *       + X*(8.33 33333 33334 0D-3                                 LOV07390
C    1       + X*( 1.9 84126 98412 7D-4                                 LOV07400
C    2       + X*(2.7557 31918 9D-6 + X*(2.50 12108 4D-8                LOV07410
C    3       + X*(1.60596 1D-10 + X*7.64 7D-13))))))                    LOV07420
C     SH1(X) = 3.3333 33333 33333 3D-1                                  LOV07430
C    *       + X*(3.333 33333 33333 3D-2                                LOV07440
C    1       + X*(1.19 04761 90476 2D-3                                 LOV07450
C    2       + X*(2.20458 55379 2D-5                                    LOV07460
C    3       + X*(2.505 21083 7D-7 + X*(1.9 27085 3D-9                  LOV07470
C    4       + X*(1.0706 3D-11 + X*4.50D-14))))))                       LOV07480
C                                                                       LOV07490
C     INITIAL VALUE                                                     LOV07500
C                                                                       LOV07510
      IF( L.LE.1 .OR. W.LE.0 .OR. C.LE.0 )  GO TO  90                   LOV07520
      I   = L                                                           LOV07530
      RO  = RHO(I)                                                      LOV07540
      IF( RO.LE.0 )  GO TO  92                                          LOV07550
      DO  1  J=2,L                                                      LOV07560
        IF( VS(I-1).GT.0 )  GO TO  2                                    LOV07570
        I = I - 1                                                       LOV07580
    1 CONTINUE                                                          LOV07590
      GO TO  92                                                         LOV07600
C                                                                       LOV07610
    2 IER = 0                                                           LOV07620
      IGG = MAX(1,MIN(3,IG))                                            LOV07630
      WN  = W/C                                                         LOV07640
      CC  = C*C                                                         LOV07650
      ROC = RO*CC                                                       LOV07660
      Y1 = EPS                                                          LOV07670
      Y2 = 0                                                            LOV07680
      Y3 = 0                                                            LOV07690
      Y4 = 0                                                            LOV07700
      Y5 = 0                                                            LOV07710
      Y6 = 0                                                            LOV07720
      EL  = RO*VS(I)**2                                                 LOV07730
      IF( EL.GT.0 )  THEN                                               LOV07740
        XI  = 1                                                         LOV07750
        IF( IA.GT.0 )  XI = AX(I)                                       LOV07760
        RBB = XI - (C/VS(I))**2                                         LOV07770
C       WRITE (*,*),"XI C VS(I) RBB= ",RBB,XI,C,VS(I)                   LOV07775
        IF( RBB.LE.0 )  GO TO  92                                       LOV07780
        RB  = SQRT(RBB)                                                 LOV07790
        Y2  = Y1*EL*RB                                                  LOV07800
        IF( IGG.GE.2 )  Y4 =-Y1*ROC/RB                                  LOV07810
      ENDIF                                                             LOV07820
C                                                                       LOV07830
C     INTEGRATE UPWARD                                                  LOV07840
C                                                                       LOV07850
      DO  3  II=2,L                                                     LOV07860
        I   = I - 1                                                     LOV07870
        RO  = RHO(I)                                                    LOV07880
        ROC = RO*CC                                                     LOV07890
        XI  = 1                                                         LOV07900
        IF( IA.GT.0 )  XI = AX(I)                                       LOV07910
        EL  = RO*VS(I)**2                                               LOV07920
        IF( EL.LE.0 .OR. H(I).LE.0 )  GO TO  92                         LOV07930
        RBB = XI - (C/VS(I))**2                                         LOV07940
        HK  = H(I)*WN                                                   LOV07950
        X   = RBB*HK**2                                                 LOV07960
C                                                                       LOV07970
C       SINH(X)/X                                                       LOV07980
C                                                                       LOV07990
        AA = ABS(X)                                                     LOV08000
        IF( AA.LE.1 )  THEN                                             LOV08010
          SHB = SH0(X)                                                  LOV08020
          CHB = 1 + X*SH0(X/4)**2/2                                     LOV08030
          IF( IGG.GE.2 )  DHB = HK**2*SH1(X)                            LOV08040
        ELSE                                                            LOV08050
          AA = SQRT(AA)                                                 LOV08060
          IF( X.GE.0 )  THEN                                            LOV08070
            CHB = 1                                                     LOV08080
            SHB = TANH(AA)/AA                                           LOV08090
          ELSE                                                          LOV08100
            SHB = SIN(AA)/AA                                            LOV08110
            CHB = COS(AA)                                               LOV08120
          ENDIF                                                         LOV08130
          IF( IGG.GE.2 )  DHB = HK**2*(CHB - SHB)/X                     LOV08140
        ENDIF                                                           LOV08150
        SHB = HK*SHB                                                    LOV08160
C                                                                       LOV08170
C       LAYER MATRIX                                                    LOV08180
C                                                                       LOV08190
        B11 = CHB                                                       LOV08200
        B12 = SHB/EL                                                    LOV08210
        B21 = EL*RBB*SHB                                                LOV08220
C                                                                       LOV08230
        Z1  = Y1                                                        LOV08240
        Z2  = Y2                                                        LOV08250
        Y1  = B11*Z1 + B12*Z2                                           LOV08260
        Y2  = B21*Z1 + B11*Z2                                           LOV08270
C                                                                       LOV08280
        IF( IGG.GE.2 )  THEN                                            LOV08290
          C11 =-HK*SHB                                                  LOV08300
          C12 =-(HK*DHB + SHB)/EL                                       LOV08310
          C21 =-EL*HK*CHB - ROC*SHB                                     LOV08320
C                                                                       LOV08330
          Z3  = Y3                                                      LOV08340
          Z4  = Y4                                                      LOV08350
          Y3  = B11*Z3 + B12*Z4 + C11*Z1 + C12*Z2                       LOV08360
          Y4  = B21*Z3 + B11*Z4 + C21*Z1 + C11*Z2                       LOV08370
C                                                                       LOV08380
          IF( IGG.GT.2 )  THEN                                          LOV08390
            W11 = HK*RBB*SHB                                            LOV08400
            W12 = HK*CHB/EL                                             LOV08410
            W21 = HK*EL*RBB*CHB                                         LOV08420
C                                                                       LOV08430
            Z5  = Y5                                                    LOV08440
            Z6  = Y6                                                    LOV08450
            Y5  = B11*Z5 + B12*Z6 + W11*Z1 + W12*Z2                     LOV08460
            Y6  = B21*Z5 + B11*Z6 + W21*Z1 + W11*Z2                     LOV08470
          ENDIF                                                         LOV08480
        ENDIF                                                           LOV08490
C                                                                       LOV08500
C     NORMALIZATION                                                     LOV08510
C                                                                       LOV08520
        Z1 = MAX(ABS(Y1), ABS(Y2))                                      LOV08530
        IF( Z1.GT.BIG )  THEN                                           LOV08540
          Y1 = EPS*Y1                                                   LOV08550
          Y2 = EPS*Y2                                                   LOV08560
          IF( IGG.GE.2 )  THEN                                          LOV08570
            Y3 = EPS*Y3                                                 LOV08580
            Y4 = EPS*Y4                                                 LOV08590
            IF( IGG.GT.2 )  THEN                                        LOV08600
              Y5 = EPS*Y5                                               LOV08610
              Y6 = EPS*Y6                                               LOV08620
            ENDIF                                                       LOV08630
          ENDIF                                                         LOV08640
        ENDIF                                                           LOV08650
C                                                                       LOV08660
    3 CONTINUE                                                          LOV08670
C                                                                       LOV08680
C     NORMAL EXIT                                                       LOV08690
C                                                                       LOV08700
      Y0(1) = Y1                                                        LOV08710
      IF( ABS(Y2)*EPS.LE.ABS(Y1) )  THEN                                LOV08720
        Y0(2) = Y2/ABS(Y1)                                              LOV08730
      ELSE                                                              LOV08740
        Y0(2) = SIGN(BIG,Y2)                                            LOV08750
      ENDIF                                                             LOV08760
      IF( IGG.GE.2 )  THEN                                              LOV08770
        Y0(3) = Y3                                                      LOV08780
        Y0(4) = Y4                                                      LOV08790
        EK =-WN*Y4/Y1                                                   LOV08800
        IF( IGG.GT.2 )  THEN                                            LOV08810
          U =C*Y4/(Y4 + Y6)                                             LOV08820
          Y0(5) = Y5                                                    LOV08830
          Y0(6) = Y6                                                    LOV08840
        ENDIF                                                           LOV08850
      ENDIF                                                             LOV08860
C                                                                       LOV08870
      RETURN                                                            LOV08880
C                                                                       LOV08890
C     INPUT ERROR                                                       LOV08900
C                                                                       LOV08910
   90 WRITE(6,91)  L,W,C                                                LOV08920
   91   FORMAT(20X,5('?'),3X,'(LOVMRX)   INPUT ERROR',3X,               LOV08930
     *         'L  =',I5,3X,'W  =',1PE13.6,3X,                          LOV08940
     1         'C  =',E13.6,3X,5('?'))                                  LOV08950
      IER =-1                                                           LOV08960
      RETURN                                                            LOV08970
C                                                                       LOV08980
   92 WRITE(6,93)  I                                                    LOV08990
   93   FORMAT(20X,5('?'),3X,'(LOVMRX)   INPUT ERROR',3X,               LOV09000
     *         'AT LAYER',I5,3X,5('?'))                                 LOV09010
      IER =-MAX(1,I)                                                    LOV09020
      RETURN                                                            LOV09030
      END                                                               LOV09040


C--- Implementation of arXiv:0906.0008v1, Eqs. (A.8), (A.9) and (A.10)
c--- with factor of i removed

      double complex function A0phiAgQgmppm(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.8) first line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phiAgQgmppm=-za(j1,j4)**2/(za(j1,j2)*za(j2,j3))

      return
      end

      double complex function A0phiAgQgmmpp(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.8) second line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phiAgQgmmpp=-za(j1,j2)**2/(za(j3,j4)*za(j4,j1))

      return
      end

      double complex function A0phidAgQgmppm(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.8) third line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phidAgQgmppm=zb(j2,j3)**2/(zb(j3,j4)*zb(j4,j1))

      return
      end

      double complex function A0phidAgQgmmpp(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.8) fourth line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phidAgQgmmpp=zb(j3,j4)**2/(zb(j1,j2)*zb(j2,j3))

      return
      end

      double complex function A0phiAgQgmmpm(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.9)
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4
      double complex zab2
      double precision s3
      s3(j1,j2,j3)=s(j1,j2)+s(j2,j3)+s(j3,j1)
      zab2(j1,j2,j3,j4)=za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)

      A0phiAgQgmmpm=-zab2(j4,j1,j2,j3)**2
     .               /(zb(j1,j2)*zb(j2,j3)*s3(j1,j2,j3))
     .              -zab2(j2,j1,j4,j3)**2
     .               /(zb(j3,j4)*zb(j4,j1)*s3(j3,j4,j1))

      return
      end

      double complex function A0phidAgQgmppp(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.9)
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4
      double complex zab2
      double precision s3
      s3(j1,j2,j3)=s(j1,j2)+s(j2,j3)+s(j3,j1)
      zab2(j1,j2,j3,j4)=za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)

      A0phidAgQgmppp=+zab2(j1,j2,j3,j4)**2
     .                /(za(j1,j2)*za(j2,j3)*s3(j1,j2,j3))
     .               +zab2(j1,j3,j4,j2)**2
     .                /(za(j3,j4)*za(j4,j1)*s3(j3,j4,j1))

      return
      end


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine current(it,jav)
  use global_variables
  implicit none
  integer,intent(in) :: it
  real(8),intent(out) :: jav
  real(8) :: jav1,jav2,jz_intra,jz_inter,jav_l
  real(8) :: mass_v_i,mass_c_i
  integer :: ik,ikr,ikz

  kz(:) = kz0(:) + Act(it)
  mass_v_i = 1d0/mass_v
  mass_c_i = 1d0/mass_c
  jav_l = 0d0
  do ik = NKrz_s,NKrz_e
    ikr = ikr_table(ik); ikz = ikz_table(ik)

! state 1
    jz_intra = kz(ikz)*( &
      (1d0-abs(zCt(2,1,ik))**2-abs(zCt(2,2,ik))**2)*mass_v_i &
      +(abs(zCt(3,1,ik))**2+abs(zCt(3,2,ik))**2)*mass_c_i )

    jz_inter = 2d0*real( &
      piz_dv*conjg(zCt(1,1,ik))*zCt(2,1,ik) &
     +piz_dc*conjg(zCt(1,1,ik))*zCt(3,1,ik) &
     +piz_vc*conjg(zCt(2,1,ik))*zCt(3,1,ik) &
     +piz_dv*conjg(zCt(1,2,ik))*zCt(2,2,ik) &
     +piz_dc*conjg(zCt(1,2,ik))*zCt(3,2,ik) &
     +piz_vc*conjg(zCt(2,2,ik))*zCt(3,2,ik) &
      )

    jav_l = jav_l + (jz_intra+jz_inter)*kr(ikr)
  end do
  jav_l=jav_l*2d0/((2d0*pi)**3)*(2d0*pi*dkr*dkz)

  call MPI_ALLREDUCE(jav_l,jav,1,MPI_REAL8,MPI_SUM,MPI_COMM_WORLD,ierr)

  return
end subroutine current