module interp

    use eqdsk_dlg
    use fitpack

    implicit none

    !   interpolation initialisation arrays

    real, allocatable :: &
        zp_bR(:), zp_bPhi(:), zp_bz(:), zp_psi(:), zp_rho(:)
    real :: SplineSigma = 0.0
    real, allocatable :: yp_br(:), yp_bt(:), yp_bz(:)

contains

    subroutine init_interp ()

        use aorsaNameList, only: useEqdsk, useAr2Input
        use AR2Input, &
            only:nR_ar2=>nR,nZ_ar2=>nZ, &
            br_ar2=>bR,bt_ar2=>bt,bz_ar2=>bz, &
            r_ar2=>r,z_ar2=>z

        implicit none

        integer :: islpsw, iErr
        real, allocatable :: temp(:)
        real, allocatable :: zx1(:), zxm(:), zy1(:), zyn(:)
        real, allocatable :: slp1, slpn
        real :: zxy11, zxym1, zxy1n, zxymn

        islpsw  = 255

        ar2Input_: &
        if(useAr2Input)then

            if(nZ_ar2.gt.1)then

                allocate ( &
                    temp(nZ_ar2+nZ_ar2+nR_ar2), &
                    zp_bR(3*nR_ar2*nZ_ar2), zp_bPhi(3*nR_ar2*nZ_ar2), zp_bz(3*nR_ar2*nZ_ar2), &
                    zp_psi(3*nR_ar2*nZ_ar2),zp_rho(3*nR_ar2*nZ_ar2) )

                allocate (zx1(nZ_ar2), zxm(nZ_ar2), zy1(nR_ar2), zyn(nR_ar2))

                call surf1 ( nR_ar2, nZ_ar2, r_ar2, z_ar2, br_ar2, nR_ar2, zx1, zxm, &
                    zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
                    zp_bR, temp, SplineSigma, iErr)
                call surf1 ( nR_ar2, nZ_ar2, r_ar2, z_ar2, bt_ar2, nR_ar2, zx1, zxm, &
                    zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
                    zp_bPhi, temp, SplineSigma, iErr)
                call surf1 ( nR_ar2, nZ_ar2, r_ar2, z_ar2, bz_ar2, nR_ar2, zx1, zxm, &
                    zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
                    zp_bz, temp, SplineSigma, iErr)

            else

                islpsw = 3

                allocate(yp_br(nR_ar2),yp_bt(nR_ar2),yp_bz(nR_ar2))
                allocate(temp(nR_ar2))

                call curv1 (nR_ar2,r_ar2,br_ar2,slp1,slpn,islpsw,yp_br,temp,SplineSigma,iErr)
                call curv1 (nR_ar2,r_ar2,bt_ar2,slp1,slpn,islpsw,yp_bt,temp,SplineSigma,iErr)
                call curv1 (nR_ar2,r_ar2,bz_ar2,slp1,slpn,islpsw,yp_bz,temp,SplineSigma,iErr)

            endif

        endif ar2Input_

    end subroutine init_interp

    function dlg_interpB ( pos, bMagHere, psiHere, rhoHere )

        use aorsaNameList, only: useEqdsk, useAr2Input
        use AR2Input, &
            only:nR_ar2=>nR,nZ_ar2=>nZ, &
            br_ar2=>bR,bt_ar2=>bt,bz_ar2=>bz,r_ar2=>r,z_ar2=>z

        implicit none

        real :: bR_here, bPhi_here, bz_here, psi_here, rho_here
        real, intent(IN) :: pos(3)
        real :: dlg_interpB(3)
        real, optional, intent(OUT) :: bMagHere, psiHere, rhoHere

        if(useAR2Input)then
            if(nZ_ar2.gt.1)then

                bR_here = surf2 ( pos(1), pos(3), nR_ar2, nZ_ar2, r_ar2, z_ar2, &
                    br_ar2, nR_ar2, zp_bR, SplineSigma )
                bPhi_here = surf2 ( pos(1), pos(3), nR_ar2, nZ_ar2, r_ar2, z_ar2, &
                    bt_ar2, nR_ar2, zp_bPhi, SplineSigma )
                bz_here = surf2 ( pos(1), pos(3), nR_ar2, nZ_ar2, r_ar2, z_ar2, &
                    bz_ar2, nR_ar2, zp_bz, SplineSigma )

            else

                bR_here = curv2 (pos(1),nR_ar2,r_ar2,br_ar2,yp_br,SplineSigma)
                bPhi_here = curv2 (pos(1),nR_ar2,r_ar2,bt_ar2,yp_bt,SplineSigma)
                bZ_here = curv2 (pos(1),nR_ar2,r_ar2,bz_ar2,yp_bz,SplineSigma)

            endif
        endif

        if ( present (bMagHere) ) &
            bMagHere    = sqrt ( bR_here**2 + bPhi_here**2 + bz_here**2 )

        if ( present(psiHere).and.useEqdsk) &
            psiHere    = psi_here

        if ( present (rhoHere).and.useEqdsk ) &
            rhoHere    = rho_here

    end function dlg_interpB

end module interp


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      LOGICAL FUNCTION MPPERS(FOVY,ASPECT,NEAR,FAR)
      CHARACTER*6 SUBNAM
      PARAMETER (SUBNAM='MPPERS')
      PARAMETER (DPR=57.2958)
      REAL NEAR
      COMMON /MAP/MODEL(4,4),VIEW(4,4),PROJ(4,4),CPNEAR,CPFAR,VWPORT(4),
     *       MVP(4,4),VP(4,4),CPLINE(2,2,10),CPPLAN(2,3,10),PEYE(3),
     *       PLOOK(3),ETWIST,NCPLIN,NCPLAN,TMAT1(4,4),TMAT2(4,4),
     *       TMAT3(4,4),TVEC1(4),TVEC2(4),TVEC3(4),TVEC4(4),TARR1(32),
     *       TARR2(32),TARR3(32),TARR4(32),TARR5(32),TARR6(32),
     *       TARR7(32),TARR8(32)
      REAL MODEL,MVP

      MPPERS = .FALSE.
      IF (NEAR.LT.0.) THEN
         CALL PLTFLU
         CALL SIORPT(SUBNAM,
     *         'You cannot specify the near clipping plane less than 0.'
     *               ,2)
         RETURN

      END IF

      IF (NEAR.GE.FAR) THEN
         CALL PLTFLU
         CALL SIORPT(SUBNAM,
     *'You cannot specify the near clipping plane >= to the far clipping
     * plane',2)
         RETURN

      END IF

      MPPERS = .TRUE.
      CALL MXZERO(4,PROJ)
      PROJ(2,2) = 1./TAN((FOVY/DPR)/2.)
      PROJ(1,1) = PROJ(2,2)/ASPECT
      PROJ(3,3) = - (FAR+NEAR)/ (FAR-NEAR)
      PROJ(4,3) = - (2.*FAR*NEAR)/ (FAR-NEAR)
      PROJ(3,4) = -1.
      CPNEAR = NEAR
      CPFAR = FAR
      CALL MXMULT(4,VIEW,PROJ,VP)
      CALL MXMULT(4,MODEL,VP,MVP)
      RETURN

      END


      SUBROUTINE DBLTRAP(DINTGL)
C*********************************************************************
C  PARAMETERS:
C     DINTGL  -  INTEGRATION RESULT CALCULATED IN DBLTRAP
C     THETA STEP SIZE = 1  DEGREE
C     PHI   STEP SIZE = 1  DEGREE
C     THETA LOWER LIMIT OF INTEGRATION = 0. DEGREES
C     PHI   LOWER LIMIT OF INTEGRATION = -90. DEGREES
C     THETA UPPER LIMIT OF INTEGRATION = 90. DEGREES
C     PHI   UPPER LIMIT OF INTEGRATION = 90. DEGREES
C*********************************************************************
      DATA D2R/.01745329251/
      PHIZ = -90. * D2R
      PHIF =  90. * D2R
      TINT = 0.0
      T = 0.
      DO 80 IP1 = 1,91
        P = PHIZ + D2R
        PINT = 0.0
        DO 90 J = 1,179
          PINT = PINT + F2(T,P)
          P = P + D2R
   90   CONTINUE
        PINT = PINT * D2R
        PINT = PINT + (D2R/2.) * (F2(T,PHIF) + F2(T,PHIZ))
        IF (IP1.EQ.1 .OR. IP1.EQ.91) GO TO 91
        TINT = TINT + D2R * PINT *COS(T)
        GO TO 92
   91   TINT = TINT + D2R * PINT * COS(T) / 2.0
   92   CONTINUE
        T = T + D2R
   80 CONTINUE
      DINTGL =  TINT
      RETURN
      END
C------------------------------------------------------------------


      subroutine DCDPOI (N, LAMDA, P, Q, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DCDPOI Krogh  Changes to use M77CON
c>> 1994-08-05 DCDPOI WV Snyder
c
c     Compute Q = exp(-lamda) sum (lamda**j/j!,j=0..n-1) and
c             P = exp(-lamda) sum (lamda**j/j!,j=n..infinity).
c
c     These functions are given by the incomplete gamma ratios
c     P(n,lamda) and Q(n,lamda).
c
      double precision LAMDA, P, Q
      integer N, IERR
c--D replaces "?": ?CDPOI, ?gami
c
      call dgami (DBLE(n),lamda,p,q,ierr)
      return
      end


subroutine SHExpandDH(grid, py_m, py_n, lmax_calc, py_lmax, cilm, lmax, norm, sampling, csphase)
	!                 in     in    in   in    in        in      out   out   in    in         in
	use FFTW3
	use SHTOOLS, only: DHaj

	implicit none

	integer, intent(in)  ::	py_m, py_n, py_lmax, lmax_calc
	real*8, intent(in)   ::	grid(py_m, py_n)
	real*8, intent(out)  ::	cilm(2, py_lmax+1, py_lmax+1)
	integer, intent(out) ::	lmax
	integer, intent(in), optional :: norm, sampling, csphase

	complex*16           ::	cc(py_m+1)
	integer              ::	l, m, n, i, l1, m1, i_eq, i_s, astat(4), lmax_comp, nlong
	integer*8            ::	plan
	real*8               ::	pi, gridl(2*py_m), aj(py_m), fcoef1(2, py_m/2+1), fcoef2(2, py_m/2+1)
	real*8               ::	theta, prod, scalef, rescalem, u, p, pmm, pm1, pm2, z, ffc(1:2,-1:1)

	real*8,    save, allocatable ::	sqr(:), ff1(:,:), ff2(:,:)
	integer*1, save, allocatable ::	fsymsign(:,:)
	integer, save                ::	lmax_old=0, norm_old = 0

	n     = py_m
	lmax  = py_m/2 - 1
	nlong = py_n

	lmax_comp = min(lmax, lmax_calc)

	pi = acos(-1.0d0)

	cilm = 0.0d0

	scalef = 1.0d-280

	call DHaj(n, aj)
	aj(1:n) = aj(1:n)*sqrt(4.0d0*pi) 	! Driscoll and Heally use unity normalized spherical harmonics

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate recursion constants used in computing the Legendre polynomials
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (lmax_comp /= lmax_old .or. norm /= norm_old) then

		if (allocated(sqr)) deallocate(sqr)
		if (allocated(ff1)) deallocate(ff1)
		if (allocated(ff2)) deallocate(ff2)
		if (allocated(fsymsign)) deallocate(fsymsign)

		allocate(sqr(2*lmax_comp+1), stat=astat(1))
		allocate(ff1(lmax_comp+1,lmax_comp+1), stat=astat(2))
		allocate(ff2(lmax_comp+1,lmax_comp+1), stat=astat(3))
		allocate(fsymsign(lmax_comp+1,lmax_comp+1), stat=astat(4))

		if (sum(astat(1:4)) /= 0) then
			print*, "Error --- SHExpandDH"
			print*, "Problem allocating arrays SQR, FF1, FF2, or FSYMSIGN", &
				astat(1), astat(2), astat(3), astat(4)
			stop
		endif

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		! 	Calculate signs used for symmetry of Legendre functions about equator
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		do l = 0, lmax_comp, 1
			do m = 0, l, 1
				if (mod(l-m,2) == 0) then
					fsymsign(l+1,m+1) = 1
				else
					fsymsign(l+1,m+1) = -1
				endif
			enddo
		enddo

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		!	Precompute square roots of integers that are used several times.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		do l=1, 2*lmax_comp+1
			sqr(l) = sqrt(dble(l))
		enddo

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		! 	Precompute multiplicative factors used in recursion relationships
		! 		P(l,m) = x*f1(l,m)*P(l-1,m) - P(l-2,m)*f2(l,m)
		!		k = l*(l+1)/2 + m + 1
		!	Note that prefactors are not used for the case when m=l as a different
		!	recursion is used. Furthermore, for m=l-1, Plmbar(l-2,m) is assumed to be zero.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		select case(norm)

			case(1,4)

				if (lmax_comp /= 0) then
					ff1(2,1) = sqr(3)
					ff2(2,1) = 0.0d0
				endif

				do l=2, lmax_comp, 1
					ff1(l+1,1) = sqr(2*l-1) * sqr(2*l+1) / dble(l)
					ff2(l+1,1) = dble(l-1) * sqr(2*l+1) / sqr(2*l-3) / dble(l)
					do m=1, l-2, 1
						ff1(l+1,m+1) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                				ff2(l+1,m+1) = sqr(2*l+1) * sqr(l-m-1) * sqr(l+m-1) &
                  				 	/ sqr(2*l-3) / sqr(l+m) / sqr(l-m)
					enddo
					ff1(l+1,l) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                			ff2(l+1,l) = 0.0d0
				enddo

			case(2)

				if (lmax_comp /= 0) then
					ff1(2,1) = 1.0d0
					ff2(2,1) = 0.0d0
				endif

				do l=2, lmax_comp, 1
					ff1(l+1,1) = dble(2*l-1) /dble(l)
					ff2(l+1,1) = dble(l-1) /dble(l)
					do m=1, l-2, 1
						ff1(l+1,m+1) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                  				ff2(l+1,m+1) = sqr(l-m-1) * sqr(l+m-1) / sqr(l+m) / sqr(l-m)
					enddo
					ff1(l+1,l)= dble(2*l-1) / sqr(l+m) / sqr(l-m)
                  			ff2(l+1,l) = 0.0d0
				enddo

			case(3)

				do l=1, lmax_comp, 1
					ff1(l+1,1) = dble(2*l-1) /dble(l)
					ff2(l+1,1) = dble(l-1) /dble(l)
					do m=1, l-1, 1
						ff1(l+1,m+1) = dble(2*l-1) / dble(l-m)
                  				ff2(l+1,m+1) = dble(l+m-1) / dble(l-m)
					enddo
				enddo

		end select

		lmax_old = lmax_comp
		norm_old = norm

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Create generic plan for gridl
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call dfftw_plan_dft_r2c_1d(plan, nlong, gridl(1:nlong), cc, FFTW_MEASURE)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Integrate over all latitudes. Take into account symmetry of the
	!	Plms about the equator.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	i_eq = n/2 + 1	! Index correspondong to the equator

	do i=2, i_eq - 1, 1

		theta = (i-1) * pi / dble(n)
		z = cos(theta)
		u = sqrt( (1.0d0-z) * (1.0d0+z) )

		gridl(1:nlong) = grid(i,1:nlong)
		call dfftw_execute(plan)	! take fourier transform
		fcoef1(1,1:n/2) = sqrt(2*pi) * aj(i) * dble(cc(1:n/2)) / dble(nlong)
		fcoef1(2,1:n/2) = -sqrt(2*pi) * aj(i) * dimag(cc(1:n/2)) / dble(nlong)

		i_s = 2*i_eq -i

		gridl(1:nlong) = grid(i_s,1:nlong)
		call dfftw_execute(plan)	! take fourier transform
		fcoef2(1,1:n/2) = sqrt(2*pi) * aj(i_s) * dble(cc(1:n/2)) / dble(nlong)
		fcoef2(2,1:n/2) = -sqrt(2*pi) * aj(i_s) * dimag(cc(1:n/2)) / dble(nlong)

		select case(norm)
			case(1,2,3);	pm2 = 1.0d0
			case(4);	pm2 = 1.0d0 / sqrt(4*pi)
		end select

		cilm(1,1,1) = cilm(1,1,1) + pm2 * (fcoef1(1,1) + fcoef2(1,1) )
		! fsymsign = 1

		if (lmax_comp == 0) cycle

		pm1 =  ff1(2,1) * z * pm2
		cilm(1,2,1) = cilm(1,2,1) + pm1 * ( fcoef1(1,1) - fcoef2(1,1) )
		! fsymsign = -1

		ffc(1,-1) = fcoef1(1,1) - fcoef2(1,1)
		ffc(1, 1) = fcoef1(1,1) + fcoef2(1,1)
		do l=2, lmax_comp, 1
			l1 = l+1
			p = ff1(l1,1) * z * pm1 - ff2(l1,1) * pm2
			pm2 = pm1
			pm1 = p
			cilm(1,l1,1) = cilm(1,l1,1) + p * ffc(1,fsymsign(l1,1))
		enddo

		select case(norm)
			case(1,2);	pmm = sqr(2) * scalef
			case(3);	pmm = scalef
			case(4);	pmm = sqr(2) * scalef / sqrt(4*pi)
		end select

		rescalem = 1.0d0/scalef

		do m = 1, lmax_comp-1, 1

			m1 = m+1
			rescalem = rescalem * u

			select case(norm)
				case(1,4)
					pmm = csphase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm
				case(2)
					pmm = csphase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm / sqr(2*m+1)
				case(3)
					pmm = csphase * pmm * (2*m-1)
					pm2 = pmm
			end select

			fcoef1(1:2,m1) = fcoef1(1:2,m1) * rescalem
			fcoef2(1:2,m1) = fcoef2(1:2,m1) * rescalem

			cilm(1:2,m1,m1) = cilm(1:2,m1,m1) + pm2 * &
					( fcoef1(1:2,m1) + fcoef2(1:2,m1) )
			! fsymsign = 1

	   		pm1 = z * ff1(m1+1,m1) * pm2

	   		cilm(1:2,m1+1,m1) = cilm(1:2,m1+1,m1) + pm1 * &
               				( fcoef1(1:2,m1) - fcoef2(1:2,m1) )
               		! fsymsign = -1

			ffc(1:2,-1) = fcoef1(1:2,m1) - fcoef2(1:2,m1)
			ffc(1:2, 1) = fcoef1(1:2,m1) + fcoef2(1:2,m1)
			do l = m+2, lmax_comp, 1
				l1 = l+1
                  		p = z * ff1(l1,m1) * pm1-ff2(l1,m1) * pm2
                  		pm2 = pm1
                  		pm1 = p
				cilm(1:2,l1,m1) = cilm(1:2,l1,m1) + p * ffc(1:2,fsymsign(l1,m1))
			enddo

		enddo

		rescalem = rescalem * u

            	select case(norm)
            		case(1,4);	pmm = csphase * pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem
            		case(2);	pmm = csphase * pmm / sqr(2*lmax_comp) * rescalem
            		case(3);	pmm = csphase * pmm * (2*lmax_comp-1) * rescalem
        	end select

        	cilm(1:2,lmax_comp+1,lmax_comp+1) = cilm(1:2,lmax_comp+1,lmax_comp+1) + pmm * &
        				( fcoef1(1:2,lmax_comp+1) + fcoef2(1:2,lmax_comp+1) )
        				! fsymsign = 1
	enddo

	! Finally, do equator

	i = i_eq

	z = 0.0d0
	u = 1.0d0

	gridl(1:nlong) = grid(i,1:nlong)
	call dfftw_execute(plan)	! take fourier transform
	fcoef1(1,1:n/2) = sqrt(2*pi) * aj(i) * dble(cc(1:n/2)) / dble(nlong)
	fcoef1(2,1:n/2) = -sqrt(2*pi) * aj(i) * dimag(cc(1:n/2)) / dble(nlong)

	select case(norm)
		case(1,2,3);	pm2 = 1.0d0
		case(4);	pm2 = 1.0d0 / sqrt(4*pi)
	end select

	cilm(1,1,1) = cilm(1,1,1) + pm2 * fcoef1(1,1)

	if (lmax_comp /= 0) then

		do l=2, lmax_comp, 2
			l1 = l+1
			p = - ff2(l1,1) * pm2
			pm2 = p
			cilm(1,l1,1) = cilm(1,l1,1) + p * fcoef1(1,1)
		enddo

		select case(norm)
			case(1,2);	pmm = sqr(2) * scalef
			case(3);	pmm = scalef
			case(4);	pmm = sqr(2) * scalef / sqrt(4*pi)
		end select

		rescalem = 1.0d0/scalef

		do m = 1, lmax_comp-1, 1

			m1 = m+1

			select case(norm)
				case(1,4)
					pmm = csphase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm
				case(2)
					pmm = csphase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm / sqr(2*m+1)
				case(3)
					pmm = csphase * pmm * (2*m-1)
					pm2 = pmm
			end select

			fcoef1(1:2,m1) = fcoef1(1:2,m1) * rescalem

			cilm(1:2,m1,m1) = cilm(1:2,m1,m1) + pm2 * fcoef1(1:2,m1)

			do l = m+2, lmax_comp, 2
				l1 = l+1
                	  	p = - ff2(l1,m1) * pm2
                  		pm2 = p
				cilm(1:2,l1,m1) = cilm(1:2,l1,m1) + p * fcoef1(1:2,m1)
			enddo

		enddo

       		select case(norm)
            		case(1,4);	pmm = csphase * pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem
            		case(2);	pmm = csphase * pmm / sqr(2*lmax_comp) * rescalem
            		case(3);	pmm = csphase * pmm * (2*lmax_comp-1) * rescalem
       		end select

       		cilm(1:2,lmax_comp+1,lmax_comp+1) = cilm(1:2,lmax_comp+1,lmax_comp+1) + pmm * fcoef1(1:2,lmax_comp+1)

       	endif

	call dfftw_destroy_plan(plan)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Divide by integral of Ylm*Ylm
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	select case(norm)

		case(1)

			do l=0, lmax_comp, 1
				cilm(1:2,l+1, 1:l+1) = cilm(1:2,l+1, 1:l+1) / (4*pi)
			enddo

		case(2)

			do l=0, lmax_comp, 1
				cilm(1:2,l+1, 1:l+1) = cilm(1:2,l+1, 1:l+1) * (2*l+1) / (4*pi)
			enddo

		case(3)

			do l=0, lmax_comp, 1
				prod = 4 * pi / dble(2*l+1)
				cilm(1,l+1,1) = cilm(1,l+1,1) / prod
				prod = prod / 2.0d0
				do m=1, l-1, 1
					prod = prod * (l+m) * (l-m+1)
					cilm(1:2,l+1,m+1) = cilm(1:2,l+1,m+1) / prod
				enddo
				!do m=l case
				if (l /= 0) cilm(1:2,l+1,l+1) = cilm(1:2,l+1, l+1)/(prod*2*l)
			enddo

	end select

end subroutine SHExpandDH


!*==dlasq2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLASQ2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLASQ2( N, Z, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   Z( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLASQ2 computes all the eigenvalues of the symmetric positive
!> definite tridiagonal matrix associated with the qd array Z to high
!> relative accuracy are computed to high relative accuracy, in the
!> absence of denormalization, underflow and overflow.
!>
!> To see the relation of Z to the tridiagonal matrix, let L be a
!> unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
!> let U be an upper bidiagonal matrix with 1's above and diagonal
!> Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
!> symmetric tridiagonal to which it is similar.
!>
!> Note : DLASQ2 defines a logical variable, IEEE, which is true
!> on machines which follow ieee-754 floating-point standard in their
!> handling of infinities and NaNs, and false otherwise. This variable
!> is passed to DLASQ3.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>        The number of rows and columns in the matrix. N >= 0.
!> \endverbatim
!>
!> \param[in,out] Z
!> \verbatim
!>          Z is DOUBLE PRECISION array, dimension ( 4*N )
!>        On entry Z holds the qd array. On exit, entries 1 to N hold
!>        the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
!>        trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
!>        N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
!>        holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
!>        shifts that failed.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>        = 0: successful exit
!>        < 0: if the i-th argument is a scalar and had an illegal
!>             value, then INFO = -i, if the i-th argument is an
!>             array and the j-entry had an illegal value, then
!>             INFO = -(i*100+j)
!>        > 0: the algorithm failed
!>              = 1, a split was marked by a positive value in E
!>              = 2, current block of Z not diagonalized after 100*N
!>                   iterations (in inner while loop).  On exit Z holds
!>                   a qd array with the same eigenvalues as the given Z.
!>              = 3, termination criterion of outer while loop not met
!>                   (program created more than N unreduced blocks)
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup auxOTHERcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Local Variables: I0:N0 defines a current unreduced segment of Z.
!>  The shifts are accumulated in SIGMA. Iteration count is in ITER.
!>  Ping-pong is controlled by PP (alternates between 0 and 1).
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DLASQ2(N,Z,Info)
      IMPLICIT NONE
!*--DLASQ2116
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION Z(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION CBIAS
      PARAMETER (CBIAS=1.50D0)
      DOUBLE PRECISION ZERO , HALF , ONE , TWO , FOUR , HUNDRD
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0,FOUR=4.0D0,  &
     &           HUNDRD=100.0D0)
!     ..
!     .. Local Scalars ..
      LOGICAL ieee
      INTEGER i0 , i1 , i4 , iinfo , ipn4 , iter , iwhila , iwhilb , k ,&
     &        kmin , n0 , n1 , nbig , ndiv , nfail , pp , splt , ttype
      DOUBLE PRECISION d , dee , deemin , desig , dmin , dmin1 , dmin2 ,&
     &                 dn , dn1 , dn2 , e , emax , emin , eps , g ,     &
     &                 oldemn , qmax , qmin , s , safmin , sigma , t ,  &
     &                 tau , temp , tol , tol2 , trace , zmax , tempe , &
     &                 tempq
!     ..
!     .. External Subroutines ..
      EXTERNAL DLASQ3 , DLASRT , XERBLA
!     ..
!     .. External Functions ..
      INTEGER ILAENV
      DOUBLE PRECISION DLAMCH
      EXTERNAL DLAMCH , ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , MAX , MIN , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments.
!     (in case DLASQ2 is not called by DLASQ1)
!
      Info = 0
      eps = DLAMCH('Precision')
      safmin = DLAMCH('Safe minimum')
      tol = eps*HUNDRD
      tol2 = tol**2
!
      IF ( N<0 ) THEN
         Info = -1
         CALL XERBLA('DLASQ2',1)
         RETURN
      ELSEIF ( N==0 ) THEN
         RETURN
      ELSEIF ( N==1 ) THEN
!
!        1-by-1 case.
!
         IF ( Z(1)<ZERO ) THEN
            Info = -201
            CALL XERBLA('DLASQ2',2)
         ENDIF
         RETURN
      ELSEIF ( N==2 ) THEN
!
!        2-by-2 case.
!
         IF ( Z(1)<ZERO ) THEN
            Info = -201
            CALL XERBLA('DLASQ2',2)
            RETURN
         ELSEIF ( Z(2)<ZERO ) THEN
            Info = -202
            CALL XERBLA('DLASQ2',2)
            RETURN
         ELSEIF ( Z(3)<ZERO ) THEN
            Info = -203
            CALL XERBLA('DLASQ2',2)
            RETURN
         ELSEIF ( Z(3)>Z(1) ) THEN
            d = Z(3)
            Z(3) = Z(1)
            Z(1) = d
         ENDIF
         Z(5) = Z(1) + Z(2) + Z(3)
         IF ( Z(2)>Z(3)*tol2 ) THEN
            t = HALF*((Z(1)-Z(3))+Z(2))
            s = Z(3)*(Z(2)/t)
            IF ( s<=t ) THEN
               s = Z(3)*(Z(2)/(t*(ONE+SQRT(ONE+s/t))))
            ELSE
               s = Z(3)*(Z(2)/(t+SQRT(t)*SQRT(t+s)))
            ENDIF
            t = Z(1) + (s+Z(2))
            Z(3) = Z(3)*(Z(1)/t)
            Z(1) = t
         ENDIF
         Z(2) = Z(3)
         Z(6) = Z(2) + Z(1)
         RETURN
      ENDIF
!
!     Check for negative data and compute sums of q's and e's.
!
      Z(2*N) = ZERO
      emin = Z(2)
      qmax = ZERO
      zmax = ZERO
      d = ZERO
      e = ZERO
!
      DO k = 1 , 2*(N-1) , 2
         IF ( Z(k)<ZERO ) THEN
            Info = -(200+k)
            CALL XERBLA('DLASQ2',2)
            RETURN
         ELSEIF ( Z(k+1)<ZERO ) THEN
            Info = -(200+k+1)
            CALL XERBLA('DLASQ2',2)
            RETURN
         ENDIF
         d = d + Z(k)
         e = e + Z(k+1)
         qmax = MAX(qmax,Z(k))
         emin = MIN(emin,Z(k+1))
         zmax = MAX(qmax,zmax,Z(k+1))
      ENDDO
      IF ( Z(2*N-1)<ZERO ) THEN
         Info = -(200+2*N-1)
         CALL XERBLA('DLASQ2',2)
         RETURN
      ENDIF
      d = d + Z(2*N-1)
      qmax = MAX(qmax,Z(2*N-1))
      zmax = MAX(qmax,zmax)
!
!     Check for diagonality.
!
      IF ( e==ZERO ) THEN
         DO k = 2 , N
            Z(k) = Z(2*k-1)
         ENDDO
         CALL DLASRT('D',N,Z,iinfo)
         Z(2*N-1) = d
         RETURN
      ENDIF
!
      trace = d + e
!
!     Check for zero data.
!
      IF ( trace==ZERO ) THEN
         Z(2*N-1) = ZERO
         RETURN
      ENDIF
!
!     Check whether the machine is IEEE conformable.
!
      ieee = (ILAENV(10,'DLASQ2','N',1,2,3,4)==1)
!
!     Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
!
      DO k = 2*N , 2 , -2
         Z(2*k) = ZERO
         Z(2*k-1) = Z(k)
         Z(2*k-2) = ZERO
         Z(2*k-3) = Z(k-1)
      ENDDO
!
      i0 = 1
      n0 = N
!
!     Reverse the qd-array, if warranted.
!
      IF ( CBIAS*Z(4*i0-3)<Z(4*n0-3) ) THEN
         ipn4 = 4*(i0+n0)
         DO i4 = 4*i0 , 2*(i0+n0-1) , 4
            temp = Z(i4-3)
            Z(i4-3) = Z(ipn4-i4-3)
            Z(ipn4-i4-3) = temp
            temp = Z(i4-1)
            Z(i4-1) = Z(ipn4-i4-5)
            Z(ipn4-i4-5) = temp
         ENDDO
      ENDIF
!
!     Initial split checking via dqd and Li's test.
!
      pp = 0
!
      DO k = 1 , 2
!
         d = Z(4*n0+pp-3)
         DO i4 = 4*(n0-1) + pp , 4*i0 + pp , -4
            IF ( Z(i4-1)<=tol2*d ) THEN
               Z(i4-1) = -ZERO
               d = Z(i4-3)
            ELSE
               d = Z(i4-3)*(d/(d+Z(i4-1)))
            ENDIF
         ENDDO
!
!        dqd maps Z to ZZ plus Li's test.
!
         emin = Z(4*i0+pp+1)
         d = Z(4*i0+pp-3)
         DO i4 = 4*i0 + pp , 4*(n0-1) + pp , 4
            Z(i4-2*pp-2) = d + Z(i4-1)
            IF ( Z(i4-1)<=tol2*d ) THEN
               Z(i4-1) = -ZERO
               Z(i4-2*pp-2) = d
               Z(i4-2*pp) = ZERO
               d = Z(i4+1)
            ELSEIF ( safmin*Z(i4+1)<Z(i4-2*pp-2) .AND.                  &
     &               safmin*Z(i4-2*pp-2)<Z(i4+1) ) THEN
               temp = Z(i4+1)/Z(i4-2*pp-2)
               Z(i4-2*pp) = Z(i4-1)*temp
               d = d*temp
            ELSE
               Z(i4-2*pp) = Z(i4+1)*(Z(i4-1)/Z(i4-2*pp-2))
               d = Z(i4+1)*(d/Z(i4-2*pp-2))
            ENDIF
            emin = MIN(emin,Z(i4-2*pp))
         ENDDO
         Z(4*n0-pp-2) = d
!
!        Now find qmax.
!
         qmax = Z(4*i0-pp-2)
         DO i4 = 4*i0 - pp + 2 , 4*n0 - pp - 2 , 4
            qmax = MAX(qmax,Z(i4))
         ENDDO
!
!        Prepare for the next iteration on K.
!
         pp = 1 - pp
      ENDDO
!
!     Initialise variables to pass to DLASQ3.
!
      ttype = 0
      dmin1 = ZERO
      dmin2 = ZERO
      dn = ZERO
      dn1 = ZERO
      dn2 = ZERO
      g = ZERO
      tau = ZERO
!
      iter = 2
      nfail = 0
      ndiv = 2*(n0-i0)
!
      DO iwhila = 1 , N + 1
         IF ( n0<1 ) GOTO 200
!
!        While array unfinished do
!
!        E(N0) holds the value of SIGMA when submatrix in I0:N0
!        splits from the rest of the array, but is negated.
!
         desig = ZERO
         IF ( n0==N ) THEN
            sigma = ZERO
         ELSE
            sigma = -Z(4*n0-1)
         ENDIF
         IF ( sigma<ZERO ) THEN
            Info = 1
            RETURN
         ENDIF
!
!        Find last unreduced submatrix's top index I0, find QMAX and
!        EMIN. Find Gershgorin-type bound if Q's much greater than E's.
!
         emax = ZERO
         IF ( n0>i0 ) THEN
            emin = ABS(Z(4*n0-5))
         ELSE
            emin = ZERO
         ENDIF
         qmin = Z(4*n0-3)
         qmax = qmin
         DO i4 = 4*n0 , 8 , -4
            IF ( Z(i4-5)<=ZERO ) GOTO 50
            IF ( qmin>=FOUR*emax ) THEN
               qmin = MIN(qmin,Z(i4-3))
               emax = MAX(emax,Z(i4-5))
            ENDIF
            qmax = MAX(qmax,Z(i4-7)+Z(i4-5))
            emin = MIN(emin,Z(i4-5))
         ENDDO
         i4 = 4
!
 50      i0 = i4/4
         pp = 0
!
         IF ( n0-i0>1 ) THEN
            dee = Z(4*i0-3)
            deemin = dee
            kmin = i0
            DO i4 = 4*i0 + 1 , 4*n0 - 3 , 4
               dee = Z(i4)*(dee/(dee+Z(i4-2)))
               IF ( dee<=deemin ) THEN
                  deemin = dee
                  kmin = (i4+3)/4
               ENDIF
            ENDDO
            IF ( (kmin-i0)*2<n0-kmin .AND. deemin<=HALF*Z(4*n0-3) ) THEN
               ipn4 = 4*(i0+n0)
               pp = 2
               DO i4 = 4*i0 , 2*(i0+n0-1) , 4
                  temp = Z(i4-3)
                  Z(i4-3) = Z(ipn4-i4-3)
                  Z(ipn4-i4-3) = temp
                  temp = Z(i4-2)
                  Z(i4-2) = Z(ipn4-i4-2)
                  Z(ipn4-i4-2) = temp
                  temp = Z(i4-1)
                  Z(i4-1) = Z(ipn4-i4-5)
                  Z(ipn4-i4-5) = temp
                  temp = Z(i4)
                  Z(i4) = Z(ipn4-i4-4)
                  Z(ipn4-i4-4) = temp
               ENDDO
            ENDIF
         ENDIF
!
!        Put -(initial shift) into DMIN.
!
         dmin = -MAX(ZERO,qmin-TWO*SQRT(qmin)*SQRT(emax))
!
!        Now I0:N0 is unreduced.
!        PP = 0 for ping, PP = 1 for pong.
!        PP = 2 indicates that flipping was applied to the Z array and
!               and that the tests for deflation upon entry in DLASQ3
!               should not be performed.
!
         nbig = 100*(n0-i0+1)
         DO iwhilb = 1 , nbig
            IF ( i0>n0 ) GOTO 100
!
!           While submatrix unfinished take a good dqds step.
!
            CALL DLASQ3(i0,n0,Z,pp,dmin,sigma,desig,qmax,nfail,iter,    &
     &                  ndiv,ieee,ttype,dmin1,dmin2,dn,dn1,dn2,g,tau)
!
            pp = 1 - pp
!
!           When EMIN is very small check for splits.
!
            IF ( pp==0 .AND. n0-i0>=3 ) THEN
               IF ( Z(4*n0)<=tol2*qmax .OR. Z(4*n0-1)<=tol2*sigma ) THEN
                  splt = i0 - 1
                  qmax = Z(4*i0-3)
                  emin = Z(4*i0-1)
                  oldemn = Z(4*i0)
                  DO i4 = 4*i0 , 4*(n0-3) , 4
                     IF ( Z(i4)<=tol2*Z(i4-3) .OR. Z(i4-1)<=tol2*sigma )&
     &                    THEN
                        Z(i4-1) = -sigma
                        splt = i4/4
                        qmax = ZERO
                        emin = Z(i4+3)
                        oldemn = Z(i4+4)
                     ELSE
                        qmax = MAX(qmax,Z(i4+1))
                        emin = MIN(emin,Z(i4-1))
                        oldemn = MIN(oldemn,Z(i4))
                     ENDIF
                  ENDDO
                  Z(4*n0-1) = emin
                  Z(4*n0) = oldemn
                  i0 = splt + 1
               ENDIF
            ENDIF
!
         ENDDO
!
         Info = 2
!
!        Maximum number of iterations exceeded, restore the shift
!        SIGMA and place the new d's and e's in a qd array.
!        This might need to be done for several blocks
!
         i1 = i0
         n1 = n0
         DO
            tempq = Z(4*i0-3)
            Z(4*i0-3) = Z(4*i0-3) + sigma
            DO k = i0 + 1 , n0
               tempe = Z(4*k-5)
               Z(4*k-5) = Z(4*k-5)*(tempq/Z(4*k-7))
               tempq = Z(4*k-3)
               Z(4*k-3) = Z(4*k-3) + sigma + tempe - Z(4*k-5)
            ENDDO
!
!        Prepare to do this on the previous block if there is one
!
            IF ( i1>1 ) THEN
               n1 = i1 - 1
               DO WHILE ( (i1>=2) .AND. (Z(4*i1-5)>=ZERO) )
                  i1 = i1 - 1
               ENDDO
               sigma = -Z(4*n1-1)
               CYCLE
            ENDIF

            DO k = 1 , N
               Z(2*k-1) = Z(4*k-3)
!
!        Only the block 1..N0 is unfinished.  The rest of the e's
!        must be essentially zero, although sometimes other data
!        has been stored in them.
!
               IF ( k<n0 ) THEN
                  Z(2*k) = Z(4*k-1)
               ELSE
                  Z(2*k) = 0
               ENDIF
            ENDDO
            RETURN
         ENDDO
!
!        end IWHILB
!
!
 100  ENDDO
!
      Info = 3
      RETURN
!
!     end IWHILA
!
!
!     Move q's to the front.
!
 200  DO k = 2 , N
         Z(k) = Z(4*k-3)
      ENDDO
!
!     Sort and compute sum of eigenvalues.
!
      CALL DLASRT('D',N,Z,iinfo)
!
      e = ZERO
      DO k = N , 1 , -1
         e = e + Z(k)
      ENDDO
!
!     Store trace, sum(eigenvalues) and information on performance.
!
      Z(2*N+1) = trace
      Z(2*N+2) = e
      Z(2*N+3) = DBLE(iter)
      Z(2*N+4) = DBLE(ndiv)/DBLE(N**2)
      Z(2*N+5) = HUNDRD*nfail/DBLE(iter)
!
!     End of DLASQ2
!
      END SUBROUTINE DLASQ2


C     NOTE:   gridk() array does not have the on-shell point as a first point,
C             this is done in a calling routine.
C
C     The following routine sets up quadrature points with weights (gridk and
C     weightk) for int dk f(k)/(k-x0). There are three intervals: [0,a], [a,b],
C     and [b,oo). The number of points in the intervals are Na, Nb, and Np.
C     The function f(k) is assumed to fall-off as k**(-p).
      subroutine kgrid_igor(posfac,x0,a,Na,b,Nb,p,Np,nk,gridk,weightk)

      implicit real*8 (a-h,o-z)
      dimension gridk(nk),weightk(nk),xx(nk),ww(nk),sk(0:10),nnk(10),
     >     wf(2*nk),iwf(2*nk)

      myid=0
      npoints = Na
      endk = a
      npoints2 = Nb
      endk2 = b
      nendk = Np
      endp = p
      midnp = -10  ! -ve means not used
      width = 0.1  ! not used when midnp < 0
      e = x0*x0 !/posfac  ! on-shell energy in Ry
      if(x0 .lt. 0) then
         Wp = -x0*x0/2.0 !/posfac  ! on-shell energy in au
      else
         Wp = x0*x0/2.0 !/posfac ! on-shell energy in au
      endif
      rk = x0

C  Define the intervals and the number of points in each interval
      call makeints(mint,sk,nnk,rk,npoints,width,midnp,enk,nendk,endp,
     >   npoints2,endk2)
      if (myid == 0 ) then
         print '(''interval   points    start       stop          '//
     >        'test'')'
      end if
      enk = endk
 30   sumi=0.0
      sumip = 0.0
      nqk=0
C  Define the intervals and the number of points in each interval
      call makeints(mint,sk,nnk,rk,npoints,width,midnp,enk,nendk,endp,
     >   npoints2,endk2)
      if (midnp.lt.0 .and. rk.gt.0d0) then
         dstop = 0d0
         do j=1,mint-1
            nt=nnk(j)
            nwf=2*nt
            niwf=2*nt
            dstart = dstop
            dstop  = dble(sk(j))
            if (dstart.lt.rk.and.rk.lt.dstop) then
               if (rk.gt.dstop*0.9) then
                  if (myid == 0 ) then
                     print*,'Increasing dstop:', dstop, dstop * 1.1
                  end if
                  dstop = dstop * 1.1d0
               endif
               if (rk.lt.dstart*1.1) then
                  if (myid == 0 ) then
                     print*,'Decreasing dstart:', dstart, dstart * 0.9
                  end if
                  dstart = dstart * 0.9d0
               endif
               call cgqf(nt,xx,ww,1,0d0,0d0,dstart,dstop,
     >            0,nwf,wf,niwf,iwf,ier)
               test = 1.0d0
               startk = dstart
               stopk = dstop
               if(startk.eq.0.0.or.(stopk-rk)/(rk-startk).lt.4.0) then
                  dk = (stopk-startk)/nt/10
                  call getstopk(e,rk,startk,stopk,dk,test,xx,ww,nt)
                  dstop = stopk
                  sk(j) = stopk
               else
                  dk = startk/nt/10
                  call getstartk(e,rk,startk,stopk,dk,test,xx,ww,nt)
                  dstart = startk
                  sk(j-1) = startk
               endif
            endif
         enddo
      endif
      dstop = 0d0
C  Obtain Gaussian knots and weights within each interval
      do j=1,mint-1
         nqk=nqk+nnk(j)
         nt=nnk(j)
         nwf=2*nt
         niwf=2*nt
         if (nt.gt.0) then
            dstart = dstop
            dstop  = dble(sk(j))
            call cgqf(nt,xx,ww,1,0d0,0d0,dstart,dstop,
     >         0,nwf,wf,niwf,iwf,ier)
            do i=nqk-nnk(j)+1,nqk
               gridk(i)=xx(i-nqk+nnk(j))
               weightk(i)=ww(i-nqk+nnk(j))
               if (gridk(i).eq.0.0) weightk(i) = 0.0
            end do
            if (dstart.lt.rk.and.rk.lt.dstop) then
               if (myid == 0 ) then
                  print '(i5,i10,f14.8,'' *'',f12.8,f13.5)', j,nnk(j),
     >                 dstart, dstop, sumi - sumip
               end if
            else
               if (myid == 0 ) then
                  print '(i5,i10,2f14.8,f13.5)', j,nnk(j),dstart,dstop,
     >                 sumi - sumip
               endif
            end if
            sumip = sumi
         end if
      end do
C  Here we have the last interval
      nt=nnk(mint)
      if (nt.gt.0) then
         if (dstop.lt.rk) then
            if (myid == 0 ) then
               print*,'The last interval must start > than RK'
            end if
            stop 'The last interval must start > than RK'
         end if
         nqk=nqk+nt
         p=dble(sk(mint))
         dstart=0d0
         dstopp = dstop
         print*, '---', dstop, p
         dstop=dstop**(1d0-p)
         nwf=2*nt
         niwf=2*nt
         call cgqf(nt,xx,ww,1,0d0,0d0,dstart,dstop,0,nwf,wf,niwf,iwf,
     >      ier)
         if (myid == 0 ) then
            if (ier.ne.0) print*,'KGRID IER:',ier
         end if
         do j=nt,1,-1
            jj=nqk-j+1
            gridk(jj)=xx(j)**(1d0/(1d0-p))
            weightk(jj)=ww(j)/(p-1d0)*dble(gridk(jj))**p
            ecmn = gridk(jj) ** 2
         end do
         if (myid == 0 ) then
            print '(i5,i10,f14.8,''       oo'',f16.5)', mint,nnk(mint),
     >           dstopp, sumi - sumip
            print'(''fall off power:'',f5.1,23x,''= '',f7.5)',sk(mint),
     >           sumi
         end if
c$$$  if (abs(sumi - 1.0).gt.1e-2.and.la.eq.li) nbad = nbad + 1

      end if
C  Check that the integration rule will handle the principle value singularity
      j=1
      if (rk.gt.0.0) then
         if (nqk.gt.0) then
            sum=0.0
            nt=0
            do while (sk(j).lt.rk-0.01.and.j.lt.mint)
 !              sum = 2.0 * atanh(sk(j)/rk)/rk
               nt=nt+nnk(j)
               startk = sk(j)
               j=j+1
            end do
            j=mint-1
            tsum=0.0
            do while (sk(j).gt.rk+0.01.and.j.ge.1)
!               tsum = - 2.0 * acoth(sk(j)/rk) / rk
               stopk = sk(j)
               j=j-1
            end do
!            sum=sum+tsum
!            print*,'startk,stopk,rk:',startk,stopk,rk
            sum = -getint_sing(rk,startk,stopk)
            tmp = -sum
            im=nt+1
            do while (gridk(im).le.(sk(j+1)).and.im.lt.nk)
               sum=sum + 2d0*weightk(im)/(e-gridk(im)*gridk(im)) !/posfac
               im=im+1
            end do

         else
            sum = 0d0
         endif
         if (myid == 0 ) then
            print*,'integral test of singularity:',
     >           sum ,rk        !,startk,stopk,tmp
c$$$  print '(''State, NCH, NST, NA, LA, L, K, EA:'',a4,3i3,
c$$$  >      2i2,1p,2e13.4)',chan(ntmp),nch,ntmp,na,la,li,rk,ea
         end if

      else                      ! closed channel
         sum = 0d0
         sumt = 0d0
         do i = 1, nnk(1) + nnk(2)
            Wk = gridk(i)*gridk(i)/2.0             !/posfac
            sum = sum + 2d0*weightk(i)/(Wp-Wk)
            sumt = sumt + weightk(i)
         enddo
         startk = 0d0
         stopk = sk(2)

!         print*,'Test of closed channel integral:', sum, stopk,
!     >        nnk(1)+nnk(2), rk, sumt

c$$$  print'(''State, NCH, NST, NA, LA, L, E:    '',a4,3i3,2i2,
c$$$  >      1p,e13.4,''    closed'')',chan(ntmp),nch,ntmp,na,la,li,e
      end if
      if (nqk.ne.nk) stop 'inconsistency in kgrid'
      return
      end

      subroutine getstartk(e,rk,startk,stopk,dk,test,xx,ww,nt)
      implicit real*8 (a-h,o-z)
      dimension  xx(nt),ww(nt)

      do while (dk/startk.gt.1d-14)
         startkold = startk
         if (test.gt.0.0) then
            startk = startk - dk
         else
            startk = startk + dk
         endif
!         print*,test,dk,startk,stopk,nmin
         do n = 1, nt
            xx(n) = (xx(n)-startkold)*(stopk-startk)/
     >         (stopk-startkold) + startk
            ww(n) = ww(n) * (stopk-startk)/(stopk-startkold)
            if (xx(n).lt.rk) nmin = n
         enddo
         testold = test
!         test = 2.0/rk*
!     >      (atanh(startk/rk)-acoth(stopk/rk))
         test = -getint_sing(rk,startk,stopk)

         do n = 1, nt
            test = 2d0 * ww(n)/(e - xx(n)**2) + test
         enddo

         if (test*testold.lt.0.0) dk = dk / 2d0
      enddo
      return
      end

      subroutine getstopk(e,rk,startk,stopk,dk,test,xx,ww,nt)
      implicit real*8 (a-h,o-z)
      dimension xx(nt),ww(nt)

      do while (dk/stopk.gt.1d-14)
         stopkold = stopk
         if (test.gt.0.0) then
            stopk = stopk - dk
         else
            stopk = stopk + dk
         endif
         tmp = -getint_sing(rk,startk,stopk)
!         print*,test,dk,startk,stopk,nmin,tmp
         do n = 1, nt
            xx(n) = (xx(n)-startk)*(stopk-startk)/
     >         (stopkold-startk) + startk
            ww(n) = ww(n) * (stopk-startk)/(stopkold-startk)
            if (xx(n).lt.rk) nmin = n
         enddo
         testold = test
!         test = 2.0/rk*
!     >      (atanh(startk/rk)-acoth(stopk/rk))
         test = -getint_sing(rk,startk,stopk)

         do n = 1, nt
            test = 2.0 * ww(n)/(e - xx(n)**2) + test
         enddo

         if (test*testold.lt.0.0) dk = dk / 2d0
      enddo

!      tmp = getint_sing(rk,startk,stopk)
!      print*,'!!!',test,rk,startk,stopk,tmp

      return
      end

C  Define the k-grid integration intervals and the number of points in
C  each interval
C 1,3,   20,   0.8,    16,     2.5,    6,    6.0,   12,   0.09
C     npoints, endk, npoints2, endk2, nendk, endp, midnp, width
      subroutine makeints(mint,sk,nk,rk,np,width,midnp,endk,nendk,endp,
     >   np2,endk2)
      implicit real*8 (a-h,o-z)
      dimension sk(0:10), nk(10)
      nmin(npoints) = min(npoints/2,4)

      if (midnp.lt.0) then
         if (rk.gt.endk2) then
            print*, 'rk:', rk
            print*, 'endk2:', endk2
            stop 'On shell point in third interval'
         endif
         nk(1) = np
         sk(1) = endk
         nk(2) = np2
         sk(2) = endk2
         mint = 3
         nk(mint) = nendk
         sk(mint) = endp
         return
      endif

      sk(0) = 0.0
      if (abs(width).lt.0.01) then
         if (myid == 0 ) then
            print*,'Width must be greater than 0.01'
         end if
         stop 'Width must be greater than 0.01'
      end if
      if (endk+2.0*width.ge.endk2) then
         if (myid == 0 ) then
            print*,'ENDK2 must be >= ENDK + 2 * WIDTH',
     > endk2,endk+2.*width
         end if
         stop 'ENDK2 must be >= ENDK + 2 * WIDTH'
      endif
      if (rk.lt.0.0.or.(width.lt.0.0.and.rk.lt.2.0*abs(width))) then
C  Here for closed channels
c$$$         nk(1) = midnp
c$$$         sk(1) = 2.0 * abs(width)
c$$$         nk(2) = np
         nk(1) = np
         sk(1) = endk
         nk(2) = np2
         sk(2) = endk2
         mint = 3
      else if (rk.lt.width) then
C  Here if singularity is going to be in the first interval
         sk(1) = rk * 2.0
         nk(1) = midnp
         sk(2) = endk
         nk(2) = np
         sk(3) = endk2
         nk(3) = np2
         mint = 4
      else if (rk. lt. endk + 1.0 * width) then
C  Here if singularity is going to be in the second interval
         sk(1) = rk - width
         sk(2) = rk + width

C  Use the following to make the k grid symmetric about rk**2
c$$$            sk(1) = sqrt(rk**2 - 2.0 * rk * width)
c$$$            sk(2) = sqrt(rk**2 + 2.0 * rk * width)

         nk(2) = midnp
         if (rk .lt. endk - 1.0 * width ) then
            nk(1) = max(nmin(np),int(np * rk / (endk - 1.0 * width)))
            nk(1) = min(nk(1), np - nmin(np))
            npleft = np - nk(1)
            sk(3) = endk
            nk(3) = npleft
            sk(4) = endk2
            nk(4) = np2
            mint = 5
         else
            nk(1) = np
            sk(3) = endk2
            nk(3) = np2
            mint = 4
         endif
      else if (rk. lt. endk2) then
C  Here the singularity is in the third interval
         sk(1) = endk
         nk(1) = np
         sk(2) = rk - width
         sk(3) = rk + width
         nk(3) = midnp
C  The two factors of 4.0 below put extra points in the first interval
         nk(2) = max(nmin(np2),int(np2 * (sk(2)-sk(1)) * 4.0 /
     >      (4.0 * (sk(2) - sk(1)) + (endk2-endk))))
c$$$         nk(2) = max(nmin(np2),int(np2 * (rk - endk) / (endk2-endk)))
         nk(2) = min(nk(2), np2 - nmin(np2))
         npleft = np2 - nk(2)
         if (rk .lt. endk2 - width) then
            sk(4) = endk2
            nk(4) = npleft
            mint = 5
         else
            nk(2) = np2
            mint = 4
         endif
      else
C  This is for very large incident energies
         sk(1) = endk
         nk(1) = np
         sk(2) = rk - width
         nk(2) = np2
         sk(3) = rk + width
         nk(3) = midnp
         mint = 4
      endif
      nk(mint) = nendk
      sk(mint) = endp
      return
      end

      function acoth(x)
      implicit real*8 (a-h,o-z)
      if (abs(x).le.1.0) stop 'ACOTH defined for |ARG| > 1 only'
      acoth=log((1.0+x)/(x-1.0))/2.0
      end

      function atanh(x)
      implicit real*8 (a-h,o-z)
      if (abs(x).ge.1.0) stop 'ATANH defined for |ARG| < 1 only'
      atanh=log((1.0+x)/(1.0-x))/2.0
      end

C$$   Integrate over singularity:
C$$   int dx 1/(C*sqrt(x0**2 + C**2) -C*sqrt(x**2 + C**2) )
C$$   result from Maple analytical integration.
      function  getint_sing(x0,x1,x2)
      implicit real*8 (a-h,o-z)

      getint_sing = -2d0*(atanh(x1/x0) - acoth(x2/x0)) / x0

      return
      end


      SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z)                            00000010
      INTEGER LDA,N,IPVT(1)                                             00000020
      DOUBLE PRECISION A(LDA,1),Z(1)                                    00000030
      DOUBLE PRECISION RCOND                                            00000040
C                                                                       00000050
C     DGECO FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION   00000060
C     AND ESTIMATES THE CONDITION OF THE MATRIX.                        00000070
C                                                                       00000080
C     IF  RCOND  IS NOT NEEDED, DGEFA IS SLIGHTLY FASTER.               00000090
C     TO SOLVE  A*X = B , FOLLOW DGECO BY DGESL.                        00000100
C     TO COMPUTE  INVERSE(A)*C , FOLLOW DGECO BY DGESL.                 00000110
C     TO COMPUTE  DETERMINANT(A) , FOLLOW DGECO BY DGEDI.               00000120
C     TO COMPUTE  INVERSE(A) , FOLLOW DGECO BY DGEDI.                   00000130
C                                                                       00000140
C     ON ENTRY                                                          00000150
C                                                                       00000160
C        A       DOUBLE PRECISION(LDA, N)                               00000170
C                THE MATRIX TO BE FACTORED.                             00000180
C                                                                       00000190
C        LDA     INTEGER                                                00000200
C                THE LEADING DIMENSION OF THE ARRAY  A .                00000210
C                                                                       00000220
C        N       INTEGER                                                00000230
C                THE ORDER OF THE MATRIX  A .                           00000240
C                                                                       00000250
C     ON RETURN                                                         00000260
C                                                                       00000270
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS         00000280
C                WHICH WERE USED TO OBTAIN IT.                          00000290
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE       00000300
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER          00000310
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.       00000320
C                                                                       00000330
C        IPVT    INTEGER(N)                                             00000340
C                AN INTEGER VECTOR OF PIVOT INDICES.                    00000350
C                                                                       00000360
C        RCOND   DOUBLE PRECISION                                       00000370
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .        00000380
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS       00000390
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE             00000400
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND . 00000410
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION     00000420
C                           1.0 + RCOND .EQ. 1.0                        00000430
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING           00000440
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF         00000450
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE          00000460
C                UNDERFLOWS.                                            00000470
C                                                                       00000480
C        Z       DOUBLE PRECISION(N)                                    00000490
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.  00000500
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS      00000510
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT           00000520
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .                    00000530
C                                                                       00000540
C     LINPACK. THIS VERSION DATED 08/14/78 .                            00000550
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.      00000560
C                                                                       00000570
C     SUBROUTINES AND FUNCTIONS                                         00000580
C                                                                       00000590
C     LINPACK DGEFA                                                     00000600
C     BLAS DAXPY,DDOT,DSCAL,DASUM                                       00000610
C     FORTRAN DABS,DMAX1,DSIGN                                          00000620
C                                                                       00000630
C     INTERNAL VARIABLES                                                00000640
C                                                                       00000650
      DOUBLE PRECISION DDOT,EK,T,WK,WKM                                 00000660
      DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM                           00000670
      INTEGER INFO,J,K,KB,KP1,L                                         00000680
C                                                                       00000690
C                                                                       00000700
C     COMPUTE 1-NORM OF A                                               00000710
C                                                                       00000720
      ANORM = 0.0D0                                                     00000730
      DO 10 J = 1, N                                                    00000740
         ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1))                         00000750
   10 CONTINUE                                                          00000760
C                                                                       00000770
C     FACTOR                                                            00000780
C                                                                       00000790
      CALL DGEFA(A,LDA,N,IPVT,INFO)                                     00000800
C                                                                       00000810
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .              00000820
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .  00000830
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE      00000840
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE  00000850
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID    00000860
C     OVERFLOW.                                                         00000870
C                                                                       00000880
C     SOLVE TRANS(U)*W = E                                              00000890
C                                                                       00000900
      EK = 1.0D0                                                        00000910
      DO 20 J = 1, N                                                    00000920
         Z(J) = 0.0D0                                                   00000930
   20 CONTINUE                                                          00000940
      DO 100 K = 1, N                                                   00000950
         IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K))                      00000960
         IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30                  00000970
            S = DABS(A(K,K))/DABS(EK-Z(K))                              00000980
            CALL DSCAL(N,S,Z,1)                                         00000990
            EK = S*EK                                                   00001000
   30    CONTINUE                                                       00001010
         WK = EK - Z(K)                                                 00001020
         WKM = -EK - Z(K)                                               00001030
         S = DABS(WK)                                                   00001040
         SM = DABS(WKM)                                                 00001050
         IF (A(K,K) .EQ. 0.0D0) GO TO 40                                00001060
            WK = WK/A(K,K)                                              00001070
            WKM = WKM/A(K,K)                                            00001080
         GO TO 50                                                       00001090
   40    CONTINUE                                                       00001100
            WK = 1.0D0                                                  00001110
            WKM = 1.0D0                                                 00001120
   50    CONTINUE                                                       00001130
         KP1 = K + 1                                                    00001140
         IF (KP1 .GT. N) GO TO 90                                       00001150
            DO 60 J = KP1, N                                            00001160
               SM = SM + DABS(Z(J)+WKM*A(K,J))                          00001170
               Z(J) = Z(J) + WK*A(K,J)                                  00001180
               S = S + DABS(Z(J))                                       00001190
   60       CONTINUE                                                    00001200
            IF (S .GE. SM) GO TO 80                                     00001210
               T = WKM - WK                                             00001220
               WK = WKM                                                 00001230
               DO 70 J = KP1, N                                         00001240
                  Z(J) = Z(J) + T*A(K,J)                                00001250
   70          CONTINUE                                                 00001260
   80       CONTINUE                                                    00001270
   90    CONTINUE                                                       00001280
         Z(K) = WK                                                      00001290
  100 CONTINUE                                                          00001300
      S = 1.0D0/DASUM(N,Z,1)                                            00001310
      CALL DSCAL(N,S,Z,1)                                               00001320
C                                                                       00001330
C     SOLVE TRANS(L)*Y = W                                              00001340
C                                                                       00001350
      DO 120 KB = 1, N                                                  00001360
         K = N + 1 - KB                                                 00001370
         IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1)      00001380
         IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110                           00001390
            S = 1.0D0/DABS(Z(K))                                        00001400
            CALL DSCAL(N,S,Z,1)                                         00001410
  110    CONTINUE                                                       00001420
         L = IPVT(K)                                                    00001430
         T = Z(L)                                                       00001440
         Z(L) = Z(K)                                                    00001450
         Z(K) = T                                                       00001460
  120 CONTINUE                                                          00001470
      S = 1.0D0/DASUM(N,Z,1)                                            00001480
      CALL DSCAL(N,S,Z,1)                                               00001490
C                                                                       00001500
      YNORM = 1.0D0                                                     00001510
C                                                                       00001520
C     SOLVE L*V = Y                                                     00001530
C                                                                       00001540
      DO 140 K = 1, N                                                   00001550
         L = IPVT(K)                                                    00001560
         T = Z(L)                                                       00001570
         Z(L) = Z(K)                                                    00001580
         Z(K) = T                                                       00001590
         IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)            00001600
         IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130                           00001610
            S = 1.0D0/DABS(Z(K))                                        00001620
            CALL DSCAL(N,S,Z,1)                                         00001630
            YNORM = S*YNORM                                             00001640
  130    CONTINUE                                                       00001650
  140 CONTINUE                                                          00001660
      S = 1.0D0/DASUM(N,Z,1)                                            00001670
      CALL DSCAL(N,S,Z,1)                                               00001680
      YNORM = S*YNORM                                                   00001690
C                                                                       00001700
C     SOLVE  U*Z = V                                                    00001710
C                                                                       00001720
      DO 160 KB = 1, N                                                  00001730
         K = N + 1 - KB                                                 00001740
         IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150                    00001750
            S = DABS(A(K,K))/DABS(Z(K))                                 00001760
            CALL DSCAL(N,S,Z,1)                                         00001770
            YNORM = S*YNORM                                             00001780
  150    CONTINUE                                                       00001790
         IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K)                      00001800
         IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0                            00001810
         T = -Z(K)                                                      00001820
         CALL DAXPY(K-1,T,A(1,K),1,Z(1),1)                              00001830
  160 CONTINUE                                                          00001840
C     MAKE ZNORM = 1.0                                                  00001850
      S = 1.0D0/DASUM(N,Z,1)                                            00001860
      CALL DSCAL(N,S,Z,1)                                               00001870
      YNORM = S*YNORM                                                   00001880
C                                                                       00001890
      IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM                         00001900
      IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0                               00001910
      RETURN                                                            00001920
      END                                                               00001930


c=======================================================================
c
c     subroutine  CHECKSDLS
c
c     tests SDLS equalities constraints
c
c-----------------------------------------------------------------------
      SUBROUTINE checksdlseq ( n, cmat, mcte, acte, bcte,
     &                         dwork, info)
c-----------------------------------------------------------------------
c
c     INPUT
c       n     : matrix size                                      integer
c       cmat  : optimized matrix (n*n)                            double
c       mcte  : number of equal constraints                      integer
c       acte  : mcte Ai symmetric matrices(n*n) of
c               equal constraints (mcte*n*n)                      double
c       bcte  : vector value of equal constraints (mcte)          double
c
c     WORKSPACE
c       dwork : n*n                                               double
c
c     OUTPUT
c       info  : diagnostic argument                              integer
c
c     CALL
c       PMC :
c       TM  :
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n, mcte, info
      DOUBLE PRECISION cmat(n,*), acte(*), bcte(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, sm, ksae, pdmac
      DOUBLE PRECISION trace, diff, EPS
      PARAMETER (EPS =1.E-5 )
c
c-----------------------------------------------------------------------
c
      pdmac = 1
c     Total size of dwork array = n*n
c
      sm = n*n
      ksae = 1
      DO i = 1,mcte
        CALL PMC (n, acte(ksae), cmat, dwork(pdmac))
        CALL TM(n, dwork(pdmac), trace)
        diff = trace - bcte(i)
        diff = ABS(diff)
        IF (diff .GT. EPS) THEN
            info = -1109
            RETURN
        ENDIF
        ksae = ksae + sm
      ENDDO
      RETURN
      END


!> \file buffesm2.f90
!! \BRIEF
!> Module with buffesm subroutine - compute carbonate system vars from DIC,Alk,T,S,P,nuts
MODULE mbuffesm
CONTAINS
!>    Computes buffer factors of the seawater carbonate system as defined by Egleston et al. (2010)
!!    (corrected for sign error & modified to account for effects of total dissolved inorganic P and Si acid systems)
!!    as 1D arrays FROM
!!    temperature, salinity, pressure,
!!    total alkalinity (ALK), dissolved inorganic carbon (DIC),
!!    silica and phosphate concentrations (all 1-D arrays)
SUBROUTINE buffesm(gammaDIC, betaDIC, omegaDIC, gammaALK, betaALK, omegaALK, Rf, &
                temp, sal, alk, dic, sil, phos, Patm, depth, lat, N,             &
                optCON, optT, optP, optB, optK1K2, optKf, optGAS, optS, lon      )

  !   Purpose:
  !     Computes buffer factors for seawater carbonate system as defined by Egleston et al. (2010), corrected & modified,
  !     as 1D arrays
  !     FROM:
  !     temperature, salinity, pressure,
  !     total alkalinity (ALK), dissolved inorganic carbon (DIC),
  !     silica and phosphate concentrations (also, all 1-D arrays)

  !     INPUT variables:
  !     ================
  !     Patm    = atmospheric pressure [atm]
  !     depth   = depth [m]     (with optP='m', i.e., for a z-coordinate model vertical grid is depth, not pressure)
  !             = pressure [db] (with optP='db')
  !     lat     = latitude [degrees] (needed to convert depth to pressure, i.e., when optP='m')
  !             = dummy array (unused when optP='db')
  !     temp    = potential temperature [degrees C] (with optT='Tpot', i.e., models carry tempot, not in situ temp)
  !             = in situ   temperature [degrees C] (with optT='Tinsitu', e.g., for data)
  !     sal     = practical [psu] or absolute [g/kg] salinity
  !     alk     = total alkalinity in [eq/m^3] with optCON = 'mol/m3'
  !             =               [eq/kg]  with optCON = 'mol/kg'
  !     dic     = dissolved inorganic carbon [mol/m^3] with optCON = 'mol/m3'
  !             =                            [mol/kg]  with optCON = 'mol/kg'
  !     sil     = silica    [mol/m^3] with optCON = 'mol/m3'
  !             =           [mol/kg]  with optCON = 'mol/kg'
  !     phos    = phosphate [mol/m^3] with optCON = 'mol/m3'
  !             =           [mol/kg]  with optCON = 'mol/kg'
  !     INPUT options:
  !     ==============
  !     -----------
  !     optCON: choose input & output concentration units - mol/kg (data) vs. mol/m^3 (models)
  !     -----------
  !       -> 'mol/kg' for DIC, ALK, sil, & phos given on mokal scale, i.e., in mol/kg  (std DATA units)
  !       -> 'mol/m3' for DIC, ALK, sil, & phos given in mol/m^3 (std MODEL units)
  !     -----------
  !     optT: choose in situ vs. potential temperature as input
  !     ---------
  !     NOTE: Carbonate chem calculations require IN-SITU temperature (not potential Temperature)
  !       -> 'Tpot' means input is pot. Temperature (in situ Temp "tempis" is computed)
  !       -> 'Tcsv' means input is Conservative Temperature (in situ Temp "tempis" is computed)
  !       -> 'Tinsitu' means input is already in-situ Temperature, not pot. Temp ("tempis" not computed)
  !     ---------
  !     optP: choose depth (m) vs pressure (db) as input
  !     ---------
  !       -> 'm'  means "depth" input is in "m" (thus in situ Pressure "p" [db] is computed)
  !       -> 'db' means "depth" input is already in situ pressure [db], not m (thus p = depth)
  !     ---------
  !     optB: choose total boron formulation - Uppström (1974) vs. Lee et al. (2010)
  !     ---------
  !       -> 'u74' means use classic formulation of Uppström (1974) for total Boron
  !       -> 'l10' means use newer   formulation of Lee et al. (2010) for total Boron
  !     ---------
  !     optK1K2:
  !     ---------
  !       -> 'l'   means use Lueker et al. (2000) formulations for K1 & K2 (recommended by Dickson et al. 2007)
  !                **** BUT this should only be used when 2 < T < 35 and 19 < S < 43
  !       -> 'm10' means use Millero (2010) formulation for K1 & K2 (see Dickson et al., 2007)
  !                **** Valid for 0 < T < 50°C and 1 < S < 50 psu
  !     ----------
  !     optKf:
  !     ----------
  !       -> 'pf' means use Perez & Fraga (1987) formulation for Kf (recommended by Dickson et al., 2007)
  !               **** BUT Valid for  9 < T < 33°C and 10 < S < 40.
  !       -> 'dg' means use Dickson & Riley (1979) formulation for Kf (recommended by Dickson & Goyet, 1994)
  !     -----------
  !     optGAS: choose in situ vs. potential fCO2 and pCO2
  !     ---------
  !       PRESSURE corrections for K0 and the fugacity coefficient (Cf)
  !       -> 'Pzero'   = 'zero order' fCO2 and pCO2 (typical approach, which is flawed)
  !                      considers in situ T & only atm pressure (hydrostatic=0)
  !       -> 'Ppot'    = 'potential' fCO2 and pCO2 (water parcel brought adiabatically to the surface)
  !                      considers potential T & only atm pressure (hydrostatic press = 0)
  !       -> 'Pinsitu' = 'in situ' fCO2 and pCO2 (accounts for huge effects of pressure)
  !                      considers in situ T & total pressure (atm + hydrostatic)
  !     ----------
  !     optS: choose practical [psu] or absolute [g/kg] salinity as input
  !     ----------
  !       -> 'Sprc' means input is practical salinity according to EOS-80 convention
  !       -> 'Sabs' means input is absolute salinity according to TEOS-10 convention (practical sal. will be computed)
  !     ---------
  !     lon:  longitude in degrees East
  !     ----------
  !        Optional, it may be used along with latitude when optS is "Sabs".
  !        Then, they are parameters for conversion from Absolute to Practical Salinity.
  !
  !        When seawater is not of standard composition, Practical Salinity alone is not sufficient
  !        to compute Absolute Salinity and vice-versa. One needs to know the chemical composition,
  !        mainly silicate and nitrate concentration. When those concentrations are unknown and 'lon' and 'lat'
  !        are given, absolute salinity conversion is based on WOA silicate concentration at given location.
  !
  !        Alternative when optS is 'Sabs' :
  !        -------------------------------
  !        When silicate and phosphate concentrations are known, nitrate concentration is inferred from phosphate
  !        (using Redfield ratio), then practical salinity is computed from absolute salinity,
  !        total alcalinity (alk), DIC (dic), silicate (sil) and phosphate (phos).
  !        In that case, do not pass optional parameter 'lon'.
  !
  !        When neither chemical composition nor location are known, an arbitrary geographic point is chosen:
  !        mid equatorial Atlantic. Note that this implies an error on computed practical salinity up to 0.02 psu.
  !        In that case, do pass parameter 'lon' and set each of its elements to 1.e20.
  !     ---------

  !     OUTPUT variables:
  !     =================
  !     gammaDIC = (d ln CO2 / dDIC)^-1
  !                in units of [mol/kg] or [mol/m^3] depending on optCON
  !     betaDIC =  (d ln H+ / dDIC)^-1
  !                in units of [mol/kg] or [mol/m^3] depending on optCON
  !     omegaDIC = (d ln Omega / dDIC)^-1
  !                in units of [mol/kg] or [mol/m^3] depending on optCON
  !     gammaALK = (d ln CO2 / dAlk)^-1
  !                in units of [mol/kg] or [mol/m^3] depending on optCON
  !     betaALK  = (d ln H+ / dAlk)^-1
  !                in units of [mol/kg] or [mol/m^3] depending on optCON
  !     omegaALK = (d ln Omega / dAlk)^-1
  !     Rf =   dpCO2/pCO2 / dDIC/DIC    (i.e., the Revelle factor, unitless)

  USE msingledouble
  USE mconstants
  USE mvars

  IMPLICIT NONE

! Input variables
  !>     number of records
!f2py intent(hide) n
  INTEGER, INTENT(in) :: N
  !> either in situ temperature (when optT='Tinsitu', typical data)
  !! OR potential temperature (when optT='Tpot', typical models) [degree C]
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: temp
  !> salinity [psu]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: sal
  !> total alkalinity in [eq/m^3] (when optCON = 'mol/m3') OR in [eq/kg]  (when optCON = 'mol/kg')
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: alk
  !> dissolved inorganic carbon in [mol/m^3] (when optCON = 'mol/m3') OR in [mol/kg] (when optCON = 'mol/kg')
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: dic
  !> SiO2 concentration in [mol/m^3] (when optCON = 'mol/m3') OR in [mol/kg] (when optCON = 'mol/kg')
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: sil
  !> phosphate concentration in [mol/m^3] (when optCON = 'mol/m3') OR in [mol/kg] (when optCON = 'mol/kg')
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: phos
  !> atmospheric pressure [atm]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: Patm
  !> depth in \b meters (when optP='m') or \b decibars (when optP='db')
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: depth
  !> latitude [degrees north]
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: lat

  !> choose either \b 'mol/kg' (std DATA units) or \b 'mol/m3' (std MODEL units) to select
  !! concentration units for input (for alk, dic, sil, phos) & output (co2, hco3, co3)
  CHARACTER(6), INTENT(in) :: optCON
  !> choose \b 'Tinsitu' for in situ temperature or \b 'Tpot' for potential temperature
  !>  \b 'Tcsv" for conservative temperature (in two last cases, in-situ Temp is computed, needed for models)
  CHARACTER(7), INTENT(in) :: optT
  !> for depth input, choose \b "db" for decibars (in situ pressure) or \b "m" for meters (pressure is computed, needed for models)
  CHARACTER(2), INTENT(in) :: optP
  !> for total boron, choose either \b 'u74' (Uppstrom, 1974) or \b 'l10' (Lee et al., 2010).
  !! The 'l10' formulation is based on 139 measurements (instead of 20),
  !! uses a more accurate method, and
  !! generally increases total boron in seawater by 4%
!f2py character*3 optional, intent(in) :: optB='u74'
  CHARACTER(3), OPTIONAL, INTENT(in) :: optB
  !> for Kf, choose either \b 'pf' (Perez & Fraga, 1987) or \b 'dg' (Dickson & Riley, 1979)
!f2py character*2 optional, intent(in) :: optKf='pf'
  CHARACTER(2), OPTIONAL, INTENT(in) :: optKf
  !> for K1,K2 choose either \b 'l' (Lueker et al., 2000) or \b 'm10' (Millero, 2010)
!f2py character*3 optional, intent(in) :: optK1K2='l'
  CHARACTER(3), OPTIONAL, INTENT(in) :: optK1K2
  !> for K0,fugacity coefficient choose either \b 'Ppot' (no pressure correction) or \b 'Pinsitu' (with pressure correction)
  !! 'Ppot'    - for 'potential' fCO2 and pCO2 (water parcel brought adiabatically to the surface)
  !! 'Pinsitu' - for 'in situ' values of fCO2 and pCO2, accounting for pressure on K0 and Cf
  !! with 'Pinsitu' the fCO2 and pCO2 will be many times higher in the deep ocean
!f2py character*7 optional, intent(in) :: optGAS='Pinsitu'
  CHARACTER(7), OPTIONAL, INTENT(in) :: optGAS
  !> choose \b 'Sprc' for practical sal. (EOS-80, default) or \b 'Sabs' for absolute salinity (TEOS-10)
!f2py character*4 optional, intent(in) :: optS='Sprc'
  CHARACTER(4), OPTIONAL, INTENT(in) :: optS
  !> longitude [degrees east]
!!!f2py real(8) optional, intent(in), dimension(n) :: lon = -25.
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: lon
!f2py optional :: lon = -25.

! Output variables:
! -----------------
  !> (d ln CO2 / dDIC)^-1
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: gammaDIC
  !> (d ln H+ / dDIC)^-1
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: betaDIC
  !> (d ln Omega / dDIC)^-1
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: omegaDIC
  !> aqueous CO2* concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
  !> (d ln CO2 / dAlk)^-1
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: gammaALK
  !> (d ln H+ / dAlk)^-1
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: betaALK
  !> (d ln Omega / dAlk)^-1
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: omegaALK
  !> Revelle factor, i.e., dpCO2/pCO2 / dDIC/DIC
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: Rf

! Local variables
! -----------------
  ! 1) Output from constants.f90:
  REAL(kind=r8), DIMENSION(N) :: K0
  REAL(kind=r8), DIMENSION(N) :: K1
  REAL(kind=r8), DIMENSION(N) :: K2
  REAL(kind=r8), DIMENSION(N) :: Kb
  REAL(kind=r8), DIMENSION(N) :: Kw
  REAL(kind=r8), DIMENSION(N) :: Ks
  REAL(kind=r8), DIMENSION(N) :: Kf
  REAL(kind=r8), DIMENSION(N) :: Kspc
  REAL(kind=r8), DIMENSION(N) :: Kspa
  REAL(kind=r8), DIMENSION(N) :: K1p
  REAL(kind=r8), DIMENSION(N) :: K2p
  REAL(kind=r8), DIMENSION(N) :: K3p
  REAL(kind=r8), DIMENSION(N) :: Ksi
  REAL(kind=r8), DIMENSION(N) :: St
  REAL(kind=r8), DIMENSION(N) :: Ft
  REAL(kind=r8), DIMENSION(N) :: Bt

  ! 2) Output from vars.f90:
  REAL(kind=rx), DIMENSION(N) :: ph
  REAL(kind=rx), DIMENSION(N) :: pco2
  REAL(kind=rx), DIMENSION(N) :: fco2
  REAL(kind=rx), DIMENSION(N) :: co2
  REAL(kind=rx), DIMENSION(N) :: hco3
  REAL(kind=rx), DIMENSION(N) :: co3
  REAL(kind=rx), DIMENSION(N) :: OmegaA
  REAL(kind=rx), DIMENSION(N) :: OmegaC
  REAL(kind=rx), DIMENSION(N) :: BetaD
  REAL(kind=rx), DIMENSION(N) :: rhoSW
  REAL(kind=rx), DIMENSION(N) :: p
  REAL(kind=rx), DIMENSION(N) :: tempis
  ! practical salinity [psu] computed when absolute saliniry is given
  REAL(kind=rx), DIMENSION(N) :: salprac

  ! 3) Other Local variables (needed to compute buffer factors)
  REAL(kind=r8) :: Alkc, Borate, h, oh
  REAL(kind=r8) :: h3po4, h2po4, hpo4, po4
  REAL(kind=r8) :: sioh4, sioh3
  REAL(kind=r8) :: Pt, Sit
  REAL(kind=r8) :: Pegle, Segle, Qegle
  REAL(kind=r8) :: SegleCBW, SeglePt, SegleSit

  INTEGER :: i
! Arrays to pass optional arguments into or use defaults (Dickson et al., 2007)
  CHARACTER(3) :: opB
  CHARACTER(2) :: opKf
  CHARACTER(3) :: opK1K2
  CHARACTER(7) :: opGAS
  CHARACTER(4) :: opS
  LOGICAL      :: verbosity

! Set defaults for optional arguments (in Fortran 90)
! Note:  Optional arguments with f2py (python) are set above with
!        the !f2py statements that precede each type declaraion
  IF (PRESENT(optB)) THEN
    opB = optB
  ELSE
!   Default is Uppstrom (1974) for total boron
    opB = 'u74'
  ENDIF
  IF (PRESENT(optKf)) THEN
    opKf = optKf
  ELSE
!   Default is Perez & Fraga (1987) for Kf
    opKf = 'pf'
  ENDIF
  IF (PRESENT(optK1K2)) THEN
    opK1K2 = optK1K2
  ELSE
!   Default is Lueker et al. (2000) for K1 & K2
    opK1K2 = 'l'
  ENDIF
  IF (PRESENT(optGAS)) THEN
    opGAS = optGAS
  ELSE
    opGAS = 'Pinsitu'
  ENDIF
  IF (PRESENT(optS)) THEN
    opS = optS
  ELSE
    opS = 'Sprc'
  ENDIF

  print *, 'Calling vars_sprac'
!  Compute carbonate system variables from DIC, ALK, T, S, nutrients, etc
!  -------------------------------------------------------------------------------------
  CALL vars_sprac(ph, pco2, fco2, co2, hco3, co3, OmegaA, OmegaC, BetaD, rhoSW, p, tempis,  &
             temp, sal, alk, dic, sil, phos, Patm, depth, lat, N,                      &
             optCON, optT, optP, opB, opK1K2, opKf, opGAS, opS, lon, salprac      )

  IF (trim(opS) == 'Sprc') THEN
     salprac = sal
  ENDIF

! Get equilibrium constants and total concentrations of SO4, F, B
! ------------------------------------------------------------------
  CALL constants(K0, K1, K2, Kb, Kw, Ks, Kf, Kspc, Kspa,           &
                 K1p, K2p, K3p, Ksi,                               &
                 St, Ft, Bt,                                       &
                 temp, salprac, Patm,                              &
                 depth, lat, N,                                    &
                 optT, optP, opB, opK1K2, opKf, opGAS, opS, lon    )

!  Compute buffer factors
!  ----------------------
   DO i=1,N
      IF (ph(i) .EQ. 1.e20_rx) THEN
         ! Missing input data, thus mask values
         gammaDIC(i)   = 1.e20_rx
         betaDIC(i)    = 1.e20_rx
         omegaDIC(i)   = 1.e20_rx
         gammaALK(i)   = 1.e20_rx
         betaALK(i)    = 1.e20_rx
         omegaALK(i)   = 1.e20_rx
         Rf(i)         = 1.e20_rx
      ELSE
         ! Compute buffer factors

         ! Total concentrations
         Pt = phos(i)
         Sit = sil(i)

         ! Carbonate alkalinity & concentrations of H+, OH-, Borate
         h = 10**(-ph(i))          !Total scale
         Alkc = 2*co3(i) + hco3(i)
         Borate  = Bt(i) / (1 + h/Kb(i) )
         oh = Kw(i) / h

         ! Phosphate species
         ! [h2po4-] = K1p * [h3po4] / [H+]
         ! [hpo4--] = K1p * K2p * [h3po4] / [H+]²
         ! [po4---] = K1p * K2p * K3p * [h3po4] / [H+]³
         ! Pt       = [h3po4] * (1 + K1p/[H+] + K1p*K2p/[H+]² + K1p*K2p*K3p/[H+]³)

         h3po4 = Pt / (1 + K1p(i)/h + K1p(i)*K2p(i)/h**2 + K1p(i)*K2p(i)*K3p(i)/h**3)
         h2po4 = K1p(i) * h3po4 / h
         hpo4  = K2p(i) * h2po4 / h
         po4   = K3p(i) * hpo4  / h

         ! Silicate
         ! [SiO(OH)3-] = Ksi * [Si(OH)4] / [H+]
         ! Sit = [Si(OH)4] * (1 + Ksi / [H+])

         sioh4 = Sit /(1 + Ksi(i)/h)
         sioh3 = Ksi(i) * Sit/(h+Ksi(i))

        !Segle: (1) corrected from sign error in Egleston et al., and (2) modified to account for P & Si acid systems
        !------------------------------------------------------------------------------------------------------------
         !Segle  =   hco3(i) + 4*co3(i) + (h*Borate/(Kb(i) + h)) + h + oh   !Formula from Egleston et al (2010) with corrected sign error
                                                                            !Egleston et al ignore P & Si acid systems!
        !REMEDY:
        !Separate Segle into 3 parts:
        ! SegleCBW: contribution of C, B, and water systems (only part accounted for by Egleston et al.)
        ! SeglePt:  contribution of total phosphate     (from J.-M. Epitalon)
        ! SegleSit: contribution of total silicon       (from J.-M. Epitalon)

!         Segle  = hco3(i) + 4*co3(i) + (h*Borate/(Kb(i) + h)) + h + oh     &
!                    + (- h3po4 * (-h2po4 - 2*hpo4 - 3*po4)                 &
!                       + hpo4  * (2*h3po4 + h2po4 - po4)                   &
!                       + 2*po4 * (3*h3po4 + 2*h2po4 + hpo4)                &
!                      ) / Pt                                               &
!                    + h * sioh3/(Ksi(i) + h)                               &
!                  )

         ! Part 1: Carbon, Boron, Water
         SegleCBW = hco3(i) + 4*co3(i) + (h*Borate/(Kb(i) + h)) + h + oh

         ! Part 2: Phosphorus
         IF (Pt .eq. 0.0d0) THEN
            SeglePt = 0.0
         ELSE
            SeglePt = (- h3po4 * (-h2po4 - 2*hpo4 - 3*po4)                 &
                       + hpo4  * (2*h3po4 + h2po4 - po4)                   &
                       + 2*po4 * (3*h3po4 + 2*h2po4 + hpo4)                &
                      ) / Pt
         ENDIF

         ! Part 3: Silicon
         IF (Sit .EQ. 0.0d0) THEN
            SegleSit = 0.0
         ELSE
            SegleSit = h * sioh3/(Ksi(i) + h)
         ENDIF

!        Add the 3 parts of Segle
         Segle  = SegleCBW + SeglePt + SegleSit

         !print *, 'hco3, co3, h, Borate, Kb, oh = ', hco3(i), co3(i), h, Borate, Kb(i), oh
         !print *, 'h3po4, h2po4, hpo4, po4 =', h3po4, h2po4, hpo4, po4
         !print *, 'Pt = ', Pt
         !print *, 'sioh3, Ksi =', sioh3, Ksi(i)

         Pegle  = 2*co2(i) + hco3(i)
         Qegle  = 2*Alkc - Segle

         ! Compute 6 buffer factors:
         !*** NOTE - units of buffer factors depend on optCON (mol/m3 OR mol/kg)
         !         - to compare with Egleston, must convert to mmol/kg, e.g., multiply factor in mol/kg by 1000

         gammaDIC(i) = dic(i) - (Alkc*Alkc)/Segle
         gammaALK(i) = (Alkc*Alkc - dic(i)*Segle) / Alkc
         betaDIC(i)  = (dic(i)*Segle - Alkc*Alkc) / Alkc
         betaALK(i)  = Alkc*Alkc/dic(i) - Segle
         omegaDIC(i) = dic(i) - (Alkc * Pegle/Qegle)
         omegaALK(i) = Alkc - dic(i) * Qegle/Pegle

         Rf = dic(i) / gammaDIC
         !print *, 'Segle, Pegle, Qegle = ', Segle, Pegle, Qegle
         !print *, 'i, gammaDIC(i) = ', i, gammaDIC(i)
      ENDIF
   END DO

  RETURN
END SUBROUTINE buffesm
END MODULE mbuffesm


submodule (PDEelliptic) elliptic3d

implicit none (type, external)

contains

module procedure elliptic3D_cart

!------------------------------------------------------------
!-------SOLVE IONOSPHERIC POTENTIAL EQUATION IN 3D USING MUMPS
!-------ASSUME THAT WE ARE RESOLVING THE POTENTIAL ALONG THE FIELD
!-------LINE.  THIS IS MOSTLY INEFFICIENT/UNWORKABLE FOR MORE THAN 1M
!-------GRID POINTS.  This version requires that one compute the
!-------Coefficients of the problem beforehand and solves the equation:
!-------
!-------A d^2V/dx1^2 + B d^2V/dx2^2 + C d^2V/dx3^2 + D dV/dx1 + E dV/dx2 + F dV/dx3 = srcterm
!------------------------------------------------------------

integer :: ix1,ix2,ix3,lx1,lx2,lx3
integer :: lPhi,lent
integer :: iPhi,ient
integer, dimension(:), allocatable :: ir,ic
real(wp), dimension(:), allocatable :: M
real(wp), dimension(:), allocatable :: b
real(wp) :: tstart,tfin

type (MUMPS_STRUC) :: mumps_par

!ONLY ROOT NEEDS TO ASSEMBLE THE MATRIX
!if (myid==0) then
lx1=size(Ac,1)
lx2=size(Ac,2)
lx3=size(Ac,3)
lPhi=lx1*lx2*lx3

lent=7*(lx1-2)*(lx2-2)*(lx3-2)                                                 !interior entries
lent=lent+2*(lx1-2)*(lx2-2)+2*(lx2-2)*(lx3-2)+2*(lx1-2)*(lx3-2)                !6 faces of cube
lent=lent+4*(lx1-2)+4*(lx2-2)+4*(lx3-2)                                        !12 edges
lent=lent+8                                                                    !8 corners, now we have total nonzero entries
lent=lent+lx2*lx3                                                              !entries to deal with Neumann conditions on bottom

if (flagdirich==0) lent=lent+lx2*lx3
!! more entries if Neumann on top

allocate(ir(lent),ic(lent),M(lent),b(lPhi))

if (debug) print *, 'MUMPS will attempt a solve of size:  ',lx1,lx2,lx3
if (debug) print *, 'Total unknowns and nonzero entries in matrix:  ',lPhi,lent

!! DEFINE A MATRIX USING SPARSE STORAGE (CENTRALIZED ASSEMBLED MATRIX INPUT
!! SEE SECTION 4.5 OF MUMPS USER GUIDE).

!> LOAD UP MATRIX ELEMENTS
M(:)=0d0
b=pack(srcterm,.true.)           !boundaries overwritten later
ient=1
do ix3=1,lx3
  do ix2=1,lx2
    do ix1=1,lx1
      iPhi=lx1*lx2*(ix3-1)+lx1*(ix2-1)+ix1
      !! linear index referencing Phi(ix1,ix3) as a column vector.  Also row of big matrix

      if (ix1==1) then
        !! BOTTOM GRID POINTS + CORNER, USE NEUMANN HERE, PRESUMABLY ZERO
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=-1d0
        ient=ient+1
        ir(ient)=iPhi
        ic(ient)=iPhi+1
        M(ient) = 1
        !            b(iPhi)=Vminx1(ix3)
        b(iPhi) = 0
        !! force bottom current to zero
        ient = ient+1
      elseif (ix1==lx1) then
        !! TOP GRID POINTS + CORNER
        if (flagdirich/=0) then
          ir(ient)=iPhi
          ic(ient)=iPhi
          M(ient)=1d0
          b(iPhi)=Vmaxx1(ix2,ix3)
          ient=ient+1
        else
          ir(ient)=iPhi
          ic(ient)=iPhi-1
          M(ient)=-1d0/dx1(lx1)
          ient=ient+1
          ir(ient)=iPhi
          ic(ient)=iPhi
          M(ient)=1d0/dx1(lx1)
          b(iPhi)=Vmaxx1(ix2,ix3)
          ient=ient+1
        end if
      elseif (ix2==1) then
        !! LEFT BOUNDARY
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=1
        b(iPhi)=Vminx2(ix1,ix3)
        ient=ient+1
      elseif (ix2==lx2) then
        !! RIGHT BOUNDARY
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=1
        b(iPhi)=Vmaxx2(ix1,ix3)
        ient=ient+1
      elseif (ix3==1) then
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=1
        b(iPhi)=Vminx3(ix1,ix2)
        ient=ient+1
      elseif (ix3==lx3) then
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=1
        b(iPhi)=Vmaxx3(ix1,ix2)
        ient=ient+1
      else
        !! INTERIOR
        !> ix1,ix2,ix3-1 grid point in ix1,ix2,ix3 equation
        ir(ient)=iPhi
        ic(ient)=iPhi-lx1*lx2
        M(ient)=Bc(ix1,ix2,ix3)/dx3all(ix3)/dx3iall(ix3)-Ec(ix1,ix2,ix3)/(dx3all(ix3+1)+dx3all(ix3))
        ient=ient+1

        !> ix1,ix2-1,ix3
        ir(ient)=iPhi
        ic(ient)=iPhi-lx1
        M(ient)=Ac(ix1,ix2,ix3)/dx2all(ix2)/dx2iall(ix2)-Dc(ix1,ix2,ix3)/(dx2all(ix2+1)+dx2all(ix2))
        ient=ient+1

        !> ix1-1,ix2,ix3
        ir(ient)=iPhi
        ic(ient)=iPhi-1
        M(ient)=Cc(ix1,ix2,ix3)/dx1(ix1)/dx1i(ix1)-Fc(ix1,ix2,ix3)/(dx1(ix1+1)+dx1(ix1))
        ient=ient+1

        !> ix1,ix2,ix3
        ir(ient)=iPhi
        ic(ient)=iPhi
        M(ient)=-1d0*Ac(ix1,ix2,ix3)*(1d0/dx2all(ix2+1)/dx2iall(ix2)+1d0/dx2all(ix2)/dx2iall(ix2))- &
              Bc(ix1,ix2,ix3)*(1d0/dx3all(ix3+1)/dx3iall(ix3)+1d0/dx3all(ix3)/dx3iall(ix3))- &
              Cc(ix1,ix2,ix3)*(1d0/dx1(ix1+1)/dx1i(ix1)+1d0/dx1(ix1)/dx1i(ix1))
        ient=ient+1

        !> ix1+1,ix2,ix3
        ir(ient)=iPhi
        ic(ient)=iPhi+1
        M(ient)=Cc(ix1,ix2,ix3)/dx1(ix1+1)/dx1i(ix1)+Fc(ix1,ix2,ix3)/(dx1(ix1+1)+dx1(ix1))
        ient=ient+1

        !> ix1,ix2+1,ix3
        ir(ient)=iPhi
        ic(ient)=iPhi+lx1
        M(ient)=Ac(ix1,ix2,ix3)/dx2all(ix2+1)/dx2iall(ix2)+Dc(ix1,ix2,ix3)/(dx2all(ix2+1)+dx2all(ix2))
        ient=ient+1

        !> ix1,ix2,ix3+1
        ir(ient)=iPhi
        ic(ient)=iPhi+lx1*lx2
        M(ient)=Bc(ix1,ix2,ix3)/dx3all(ix3+1)/dx3iall(ix3)+Ec(ix1,ix2,ix3)/(dx3all(ix3+1)+dx3all(ix3))
        ient=ient+1
      end if
    end do
  end do
end do

if (debug) print *, 'Number of entries used:  ',ient-1

!> INIT MUMPS

mumps_par%COMM = MPI_COMM_WORLD
mumps_par%JOB = -1
mumps_par%SYM = 0
mumps_par%PAR = 1

call MUMPS_exec(mumps_par)

call quiet_mumps(mumps_par)

!LOAD OUR PROBLEM
if (debug) print*, 'Loading mumps problem...'
!if ( myid==0 ) then
mumps_par%N=lPhi
mumps_par%NZ=lent
allocate( mumps_par%IRN ( mumps_par%NZ ) )
allocate( mumps_par%JCN ( mumps_par%NZ ) )
allocate( mumps_par%A( mumps_par%NZ ) )
allocate( mumps_par%RHS ( mumps_par%N  ) )
mumps_par%IRN=ir
mumps_par%JCN=ic
mumps_par%A=M
mumps_par%RHS=b
deallocate(ir,ic,M,b)     !clear memory before solve begins!!!

if (debug) print*, 'Dealing with permutation',perflag,it
if (perflag .and. it/=1) then       !used cached permutation, but only gets tested on first time step
  allocate(mumps_par%PERM_IN(mumps_par%N))
  mumps_par%PERM_IN=mumps_perm
  mumps_par%ICNTL(7)=1
end if

if (debug) print*, 'Setting memory relaxation...'
!3D solves very often need better memory relaxation
mumps_par%ICNTL(14)=500
!end if

!SOLVE (ALL WORKERS NEED TO SEE THIS CALL)
if (debug) print*, 'Executing solve...'
mumps_par%JOB = 6

call MUMPS_exec(mumps_par)

call check_mumps_status(mumps_par, 'elliptic3D_cart')

!STORE PERMUTATION USED, SAVE RESULTS, CLEAN UP MUMPS ARRAYS
!(can save ~25% execution time and improves scaling with openmpi
! ~25% more going from 1-2 processors)
!if ( myid==0 ) then
if (debug) print *, 'Now organizing results...'

if (perflag .and. it==1) then
  allocate(mumps_perm(mumps_par%N))     !we don't have a corresponding deallocate statement
  mumps_perm=mumps_par%SYM_PERM
end if

elliptic3D_cart=reshape(mumps_par%RHS,[lx1,lx2,lx3])

if (debug) print *, 'Now attempting deallocations...'

deallocate( mumps_par%IRN )
deallocate( mumps_par%JCN )
deallocate( mumps_par%A   )
deallocate( mumps_par%RHS )
!end if

mumps_par%JOB = -2

call MUMPS_exec(mumps_par)

end procedure elliptic3D_cart

end submodule elliptic3d


  subroutine opandist (gsmObj, event, fisevent, nn)

! ======================================================================
!
!      Accumulate distribution of fission fragments' opening angles.
!      nn is total number of produced neutrons.
!      bf12 contains the fragment velocity vectors.
!
!   Written by K. K. Gudima, December, 2004.
!   Edited by A. J. Sierk, LANL T-16, January, 2005.
!   Converted to separate SR by A. J. Sierk, LANL T-16, March, 2006.
!   Edited by LMK, XCP-3, July 2013 (included error protection)
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use gsm_params, only: one, radiantodegree

    implicit none
    class(GSM),       intent(inout) :: gsmObj
    class(EventData), intent(in   ) :: event
    logical,          intent(in   ) :: fisevent
    integer(int32),   intent(in   ) :: nn

    integer(int32) :: it12, jk
    real(real64)   :: b1, b2, ct12, st12, t12, temp

! ======================================================================

    real(real64) :: opan, dth12
    common /fisopa/ opan(7,185), dth12

! ======================================================================

    if (.not.fisevent) return
    b1 = sqrt(event%fissFrag(1)%linearMomFrac(1)**2 + &
         &    event%fissFrag(1)%linearMomFrac(2)**2 + &
         &    event%fissFrag(1)%linearMomFrac(3)**2)
    b2 = sqrt(event%fissFrag(2)%linearMomFrac(1)**2 + &
         &    event%fissFrag(2)%linearMomFrac(2)**2 + &
         &    event%fissFrag(2)%linearMomFrac(3)**2)
    temp = b1*b2
    if ( temp < div0Lim .and.temp > -div0Lim ) then
       temp = div0Lim
       write(gsmObj%io%message,1000) "44"
       call gsmObj%io%print(4, 3, gsmObj%io%message)
    end if
    ! Angle between the two fission fragments?
    ct12 = (event%fissFrag(1)%linearMomFrac(1) * &
         &    event%fissFrag(2)%linearMomFrac(1) + &
         & event%fissFrag(1)%linearMomFrac(2) * &
         &    event%fissFrag(2)%linearMomFrac(2) + &
         & event%fissFrag(1)%linearMomFrac(3) * &
         &    event%fissFrag(2)%linearMomFrac(3)) / (temp)
    st12 = sqrt(abs(one - ct12**2))
    t12 = atan2(st12,ct12)*radiantodegree
    if ( dth12 < div0Lim .and.dth12 > -div0Lim ) then
       dth12 = div0Lim
       write(gsmObj%io%message,1000) "52"
       call gsmObj%io%print(4, 3, gsmObj%io%message)
    end if
    it12 = int(t12/dth12) + 1
    opan(1,it12) = opan(1,it12) + one
    opan(1,183)  = opan(1,183)  + t12
    opan(1,184)  = opan(1,184)  + t12*t12
    opan(1,185)  = opan(1,185)  + one
    if (nn <= 5) then
!   n multiplictiy 0-5
       jk = 2
    elseif (nn <= 8) then
!   n multiplictiy 6-8
       jk = 3
    elseif (nn <= 12) then
!   n multiplictiy 9-12
       jk = 4
    elseif (nn <= 15) then
!   n multiplictiy 13-15
       jk = 5
    elseif (nn <= 19) then
!   n multiplictiy 16-19
       jk = 6
    elseif (nn >= 20) then
!   n multiplicity 20-.....
       jk = 7
    endif
    opan(jk,it12) = opan(jk,it12) + one
    opan(jk,183)  = opan(jk,183)  + t12
    opan(jk,184)  = opan(jk,184)  + t12*t12
    opan(jk,185)  = opan(jk,185)  + one
    return

! ======================================================================
1000 format("Divide by zero error prevented in 'opandist.f90', line(s) ", A)
! ======================================================================
  end subroutine opandist


      SUBROUTINE MFFTC5(C,FAC)
*
*   PURPOSE:
*       ELEMENTARY COOLEY-TUKEY RADIX 5 STEP APPLIED TO A VECTOR-OF
*       VECTORS-OF-COMPLEX C[IVS,NV [IES,NE]].
*       SEE REF.[1] FOR NOTATIONS.
*       THIS ROUTINE CAN BE USED ONLY BY ROUTINE MFFTIV, WHICH CONTROLS
*       ITS OPERATION THROUGH THE MFFTPA COMMON
*
*   DUMMY ARGUMENTS :
*
*   C   ARRAY BEING FOURIER  TRANSFORMED
*   FAC PHASE FACTORS, PREPARED BY MFFTP; NOT MODIFIED IN OUTPUT
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /MFFTPA/  IMS,IVS,IES,NM,NV,NE,MX,LX,MLIM,MSTEP,LLIM,LSTEP,
     $ NUSTEP,IVLIM,ILIM,MD2LIM,LD2LIM
      INTEGER NUSTEP
      DOUBLE COMPLEX C(0:NUSTEP-1,0:4),FAC(0:*)
      DOUBLE COMPLEX T1,T2,T3,T4,T5,F1,F2,F3,F4
      REAL *8 SIN72,RAD5D4,S36D72
      PARAMETER (
     $ SIN72 =  9.51056516295153572116439333E-1,
     $ RAD5D4 =  5.59016994374947424102293417E-1,
     $ S36D72 =  6.18033988749894848204586834E-1 )
*..  LAM > 0
          LAMF=MX
          DO 100 LAM=LSTEP,LLIM,LSTEP
            F1=FAC(LAMF)
            F2=FAC(2*LAMF)
            F3=FAC(3*LAMF)
            F4=FAC(4*LAMF)
            DO 90 MU=LAM,LAM+MLIM,MSTEP
              DO 80 I=MU,MU+ILIM,IES
                T1=C(I,1)*F1+C(I,4)*F4
                T2=C(I,2)*F2+C(I,3)*F3
                T3=(C(I,1)*F1-C(I,4)*F4)*SIN72
                T4=(C(I,2)*F2-C(I,3)*F3)*SIN72
                T5=T1+T2
                T1=RAD5D4*(T1-T2)
                T2=C(I,0)-0.25*T5
                C(I,0)=C(I,0)+T5
                T5=T2+T1
                T2=T2-T1
                T1=T3+S36D72*T4
                T3=S36D72*T3-T4
                C(I,1)=T5+DCMPLX(-DIMAG(T1),DREAL(T1))
                C(I,4)=T5-DCMPLX(-DIMAG(T1),DREAL(T1))
                C(I,2)=T2+DCMPLX(-DIMAG(T3),DREAL(T3))
                C(I,3)=T2-DCMPLX(-DIMAG(T3),DREAL(T3))
80            CONTINUE
90          CONTINUE
            LAMF=LAMF+MX
100       CONTINUE

*.. LAM=0
          DO 92 MU=0,MLIM,MSTEP
            DO 82 I=MU,MU+ILIM,IES
              T1=C(I,1)+C(I,4)
              T2=C(I,2)+C(I,3)
              T3=(C(I,1)-C(I,4))*SIN72
              T4=(C(I,2)-C(I,3))*SIN72
              T5=T1+T2
              T1=RAD5D4*(T1-T2)
              T2=C(I,0)-0.25*T5
              C(I,0)=C(I,0)+T5
              T5=T2+T1
              T2=T2-T1
              T1=T3+S36D72*T4
              T3=S36D72*T3-T4
              C(I,1)=T5+DCMPLX(-DIMAG(T1),DREAL(T1))
              C(I,4)=T5-DCMPLX(-DIMAG(T1),DREAL(T1))
              C(I,2)=T2+DCMPLX(-DIMAG(T3),DREAL(T3))
              C(I,3)=T2-DCMPLX(-DIMAG(T3),DREAL(T3))
82          CONTINUE
92        CONTINUE
      END