c
c  Subroutine for BBBrem, https://doi.org/10.1016/0010-4655(94)90085-X
c  R. Kleiss and H. Burkhardt, Comput.Phys.Commun. 81 (1994) 372-380   DOI 10.1016/0010-4655(94)90085-X
c  based on bbbrem.f sent by H. Burkhardt on Jul 1, 2019.
c
c  modified for SAD: K. Oide 20 Jul 2019.
c
      module bbbrem
      use macmath
      use macphys
      type labmom
      real*8 p2(4),q2(4),qk(4),weight
      end type
      real*8, parameter::alpha=finest,rme=elmass/1e9,
     $     tomb=(plankr*cveloc/elemch)**2/1.d18/1.d-31,
     $     twopi=m_2pi,rme2=rme**2
c     use SAD's tran()
      integer*4 :: nran=3

      contains
      subroutine bcube1(roots,rk0,mom,sigapp)
      implicit none
      type (labmom) mom
      real*8 roots,rk0
      real*8
c      double precision
c     ,p1,p2,q1,q2,qk,alpha,rme,tomb,pi,twopi,rme2,d1,d2,t,weight
     . p1(4),q1(4),d1,d2,t,
     $     s,rme2s,rls,z0,a1,a2,ac,sigapp,eb,pb,rin2pb,
     . z,y,q0,temp1,tmin,tmax,sy,w2,rlamx,b,rlam,eps,rl,vgam,
     . cgam,sgam,phi,phig,ql,qt,q(4),r0,w,rin2w,rinr0w,eta,phat1,
     . phat2,phat3,phatt,phatl,sfhat,cfhat,sthat,vthat,cthat,sfg,
     . cfg,temp2,veg,qkhat(4),c1,vnumx,vdenx,vnumn,vdenn,c2,rlabl,
     . rhat4,etar,rhat1,rhat2,rhat3,zz,s1,rind1,rind12,
     . rind2,rind22,aa0,aa1,aa2,aa3,aa4,rmex,rmap
c     always do init when called from SAD
c      integer*4, save:: init=0

c* experimental constants
c      common / experc / roots,rk0
c* momenta in the lab frame
c      common / labmom / p1(4),p2(4),q1(4),q2(4),qk(4),d1,d2,t,weight

c      data init/0/
* start of initialization
c      if(init.eq.0) then
c        init = 1
c        write(*,901)
c  901   format(' ******************************************'/,
c     .         ' *** bbbrem : beam-beam bremsstrahlung  ***'/,
c     .         ' *** authors r. kleiss and h. burkhardt ***'/,
c     .         ' ******************************************')

* physical constants
c        alpha = 1d0/137.036d0
c        rme = 0.51099906d-03
c        tomb = 3.8937966d05 /1d6

* mathematical constants
c        pi = 4*datan(1d0)
c        twopi = 2*pi

* derived constants
c        write(*,902) roots,rk0
c  902   format(' total energy              ',f15.6,' gev'/,
c     .         ' minimum photon energy     ',f15.6,' * beam energy')
c        if(rk0.le.0d0.or.rk0.ge.1d0) then
c          write(*,*) 'wrong value for rk0'
c          stop
c        endif
        s = roots**2
c        rme2 = rme**2
        rme2s = rme2/s
        rls = -dlog(rme2s)
        z0 = rk0/(1-rk0)

* approximate total cross section
        a1 = dlog((1+z0)/z0)
        a2 = (dlog(1+z0))/z0
        ac = a1/(a1+a2)
        sigapp = 8*alpha**3/rme2*(-dlog(rme2s))*(a1+a2)*tomb
c        write(*,903) sigapp
c  903   format(' approximate cross section ',d15.6,' millibarn')

* the initial-state momenta
        eb = roots*0.5d0
        pb = dsqrt(eb*eb-rme2)
        rin2pb = 0.5d0/pb
        p1(1) = 0
        p1(2) = 0
        p1(3) = -pb
        p1(4) = eb
        q1(1) = 0
        q1(2) = 0
        q1(3) = pb
        q1(4) = eb

* end of initialization
c      endif

* generate z
      if(random(1.d0).lt.ac) then
         temp1=random(2.d0)
         z = 1d0/(temp1*(dexp(a1*random(3.d0))-1))
      else
        z = z0/random(4.d0)
      endif

* bounds on t
      y = rme2s*z
      q0 = eb*y
      temp1 = pb*pb-eb*q0
c    correction by hbu sent by email on Jul. 19, 2019
c      temp2 = temp1*temp1-rme2-q0*q0
      temp2 = temp1*temp1-rme2*q0*q0
* exit if temp2<0 (very very rare): put weight to 0
* the `else' clause extends to the end of the routine
      if(temp2.lt.0d0) then
        write(*,904) temp2
  904   format(' y too large: delta_t^2 = ',d15.6)
        mom%weight = 0d0
      else
        tmin = -2*(temp1+dsqrt(temp2))
        tmax = rme2*s*y*y/tmin

* generate t
        sy = s*y
        w2 = sy+rme2
        temp1 = sy+tmax
        rlamx = dsqrt(temp1*temp1-4*w2*tmax)
        if(temp1.le.0d0) then
          temp1 = rlamx-temp1
        else
          temp1 = -4*w2*tmax/(rlamx+temp1)
        endif
    1   continue
          b = dexp(random(5.d0)*dlog(1+2*sy/temp1))
          t = -b*z*z*rme2/((b-1)*(b*z+b-1))
          if(t.lt.tmin) then
            write(*,905) t,tmin
  905       format(' t = ',d15.6,'   < t_min =',d15.6)
            goto 1
          endif
        continue

* generate cgam
        rlam = dsqrt((sy-t)*(sy-t)-4*rme2*t)
        eps = 4*rme2*w2/(rlam*(rlam+w2+rme2-t))
        rl = dlog((2+eps)/eps)
        vgam = eps*(dexp(random(6.d0)*rl)-1)
        cgam = 1-vgam
        sgam = dsqrt(vgam*(2-vgam))

* generate azimuthal angles
        phi = twopi*random(7.d0)
        phig = twopi*random(8.d0)
c centralize phi : 3 Aug 2019 K. Oide
c        phi=twopi*(random(7.d0)-0.5d0)
c        phig=twopi*(random(8.d0)-0.5d0)

* construct momentum transfer q(mu)
        ql = (2*eb*q0-t)*rin2pb
        qt = dsqrt((tmax-t)*(t-tmin))*rin2pb
        q(1) = qt*dsin(phi)
        q(2) = qt*dcos(phi)
        q(3) = ql
        q(4) = q0

* construct momentum of outgoing positron in lab frame
        mom%q2(1) = q1(1)-q(1)
        mom%q2(2) = q1(2)-q(2)
        mom%q2(3) = q1(3)-q(3)
        mom%q2(4) = q1(4)-q(4)

* find euler angles of p1(mu) in cm frame
        r0 = eb+q0
        w = dsqrt(w2)
        rin2w = 0.5d0/w
        rinr0w = 1d0/(r0+w)
        eta = -(sy+2*w*q0+t)*rin2w*rinr0w
        phat1 = -q(1)*(1+eta)
        phat2 = -q(2)*(1+eta)
        phat3 = pb*eta-ql*(1+eta)
        phatl = rlam*rin2w
        phatt = dsqrt(phat1*phat1+phat2*phat2)
        sfhat = phat1/phatt
        cfhat = phat2/phatt
        sthat = phatt/phatl
        if(phat3.gt.0d0) then
          vthat = sthat*sthat/(1-dsqrt(1-sthat*sthat))
        else
          vthat = sthat*sthat/(1+dsqrt(1-sthat*sthat))
        endif
        cthat = vthat-1

* rotate using these euler angles to get the qk direction in the cm
        sfg = dsin(phig)
        cfg = dcos(phig)
        temp1 = sgam*sfg
        temp2 = cthat*sgam*cfg+sthat*cgam
        veg = vthat+vgam-vthat*vgam-sthat*sgam*cfg
        qkhat(4) = sy*rin2w
        qkhat(1) = qkhat(4)*( cfhat*temp1+sfhat*temp2)
        qkhat(2) = qkhat(4)*(-sfhat*temp1+cfhat*temp2)
        qkhat(3) = qkhat(4)*(veg-1)

* boost the photon momentum to the lab frame
        temp1 = pb*qkhat(3)
        if(temp1.gt.0d0) then
          temp2 = (rme2*qkhat(4)*qkhat(4)
     .            +pb*pb*(qkhat(1)*qkhat(1)+qkhat(2)*qkhat(2)))
     .            /(eb*qkhat(4)+temp1)
        else
          temp2 = eb*qkhat(4)-temp1
        endif
        mom%qk(4) = (temp2+qkhat(4)*q(4)+qkhat(1)*q(1)
     .                +qkhat(2)*q(2)+qkhat(3)*q(3))/w
        temp1 = (mom%qk(4)+qkhat(4))*rinr0w
        mom%qk(1) = qkhat(1)+temp1*q(1)
        mom%qk(2) = qkhat(2)+temp1*q(2)
        mom%qk(3) = qkhat(3)+temp1*(-pb+ql)

* construct p2 by momentum conservation
        mom%p2(1) = -mom%q2(1)-mom%qk(1)
        mom%p2(2) = -mom%q2(2)-mom%qk(2)
        mom%p2(3) = -mom%q2(3)-mom%qk(3)
        mom%p2(4) = -mom%q2(4)-mom%qk(4)+roots

* impose cut on the photon energy: qk(4)>eb*rk0
        if(mom%qk(4).lt.eb*rk0) then
          mom%weight = 0d0
        else

* the event is now accepted: compute matrix element and weight
* compute fudge factor c1
          c1 = dlog(1+z)/dlog((2+eps)/eps)

* compute fudge factor c2
          temp1 = sy-tmax
          vnumx = dsqrt(temp1*temp1-4*rme2*tmax)+temp1
          temp1 = sy+tmax
          if(temp1.lt.0d0) then
            vdenx = dsqrt(temp1*temp1-4*w2*tmax)-temp1
          else
            vdenx = -4*w2*tmax/(dsqrt(temp1*temp1-4*w2*tmax)+temp1)
          endif
          temp1 = sy-tmin
          vnumn = dsqrt(temp1*temp1-4*rme2*tmin)+temp1
          temp1 = sy+tmin
          if(temp1.lt.0d0) then
            vdenn = dsqrt(temp1*temp1-4*w2*tmin)-temp1
          else
            vdenn = -4*w2*tmin/(dsqrt(temp1*temp1-4*w2*tmin)+temp1)
          endif
          c2 = 2*rls/dlog((vnumx*vdenn)/(vdenx*vnumn))

* compute vector (small) r in cm frame, and (big) z
          rlabl = (t-2*rme2*y)*rin2pb
          rhat4 = -(2*rme2*y+(1-y)*t)*rin2w
          etar = rhat4*rinr0w
          rhat1 = -q(1)*(1+etar)
          rhat2 = -q(2)*(1+etar)
          rhat3 = rlabl+(pb-ql)*etar
          zz = s*(rhat4*qkhat(4)-rhat1*qkhat(1)
     .         -rhat2*qkhat(2)-rhat3*qkhat(3))

* the other invariants
          s1 = 4*eb*(eb-mom%qk(4))
          d1 = sy*rlam*(eps+vgam)*rin2w*rin2w
          d2 = 0.5d0*sy

* the exact matrix element
          rind1 = 1d0/d1
          rind12 = rind1*rind1
          rind2 = 1d0/d2
          rind22 = rind2*rind2
c* kleiss-burkhardt cross section multiplied by t**2
          temp1 = s+t-2*d2
          temp2 = s1+t+2*d1
          aa0 = (s*s+s1*s1+temp1*temp1+temp2*temp2)*rind1*rind2*(-t)
          aa1 = -4*rme2*zz*zz*rind12*rind22
          aa2 = -8*rme2*(d1*d1+d2*d2)*rind1*rind2
          aa3 = 16*rme2*rme2*(d1-d2)*zz*rind12*rind22
          aa4 = -16*rme2*rme2*rme2*(d1-d2)**2*rind12*rind22
          rmex = aa0+aa1+aa2+aa3+aa4

* the approximate matrix element without c1,2, multiplied by t**2
          rmap = 4*s*s*rind1*rind2*(-t)*c1*c2

* the weight
          mom%weight = rmex/rmap*sigapp
CHBU      IF(T.GT.-3.56D-21) weight=0.D0  ! CHBU cutoff

* the weight is now defined for both accepted and rejected events
        endif
      endif
c 1001 format(3(a10,d15.6))
      return
      end subroutine

      real*8 function random(r)
      implicit none
      real*8 r,tran
c      common / ranchn / nran
c      save
c      data init/0/
c      if(init.eq.0) then
c        init = 1
c        if(nran.eq.1) then
c          write(*,*) ' random: very crude random numbers chosen'
c        elseif(nran.eq.2) then
c          write(*,*) ' random: quasi-random numbers chosen'
c        else
c          write(*,*) ' random: error: nran = ',nran,' not allowed'
c          stop
c        endif
c      endif
      if(nran.eq.1) then
        random = rando1(r)
      elseif(nran.eq.2) then
        random = rando2(r)
      elseif(nran .eq. 3)then
c   use SAD's tran()
        random=tran()
      endif
      return
      end function

      real*8 function rando1(r)
      implicit none
      save
      real*8 r,rm
      integer*4 :: init=0
      integer*4 m,ia,ic,iseed
      if(init.eq.0) then
        init = 1
        m = 2**20
        rm = 1d0/(1d0*m)
        ia = 2**9+5
        ic = 1
        iseed = 100461
      endif
    1 iseed = mod(ia*iseed+ic,m)
      if(iseed.eq.0) goto 1
      rando1 = iseed*rm
      return
      end function

      real*8 function rando2(r)
      use macmath, nprime=>smallprime
      implicit none
      save
      integer*4 , parameter::n = 3
      integer*4  init,k,j
      real*8 s(10),ss,r
      data init/0/
      if(init.eq.0) then
        init = 1
        do 1 k = 1,n
          s(k) = dsqrt(nprime(k)*1d0)
    1   continue
      endif
      do 3 k = 1,n
        ss = 0
        do 2 j=1,n
          ss = ss+s(j)
    2   continue
        s(k) = dmod(ss,1d0)
    3 continue
      rando2 = s(1)
      return
      end function

      end module

      subroutine tbcube1(isp1,kx,irtc)
c  interface to function BBBrem1
      use tfstk
      use bbbrem
      implicit none
      integer*4 isp1,irtc,itfmessage
      type (sad_descriptor) kx
      type (labmom) mom
      type (sad_dlist), pointer:: kl
      type (sad_rlist), pointer:: klp
      real*8 ars,drs,sigapp
      real*8 , parameter :: gev=1.d9,mbarn=1.d-31
      if(isp .ne. isp1+2)then
        irtc=itfmessage(9,'General::narg','"2"')
        return
      endif
      if(.not. ktfrealq(dtastk(isp1+1),ars))then
        irtc=itfmessage(9,'General::wrongtype','"Sqrt[s] (eV) for #1"')
        return
      endif
      if(.not. ktfrealq(dtastk(isp1+2),drs))then
        irtc=itfmessage(9,'General::wrongtype','"Min. ds/s for #2"')
        return
      endif
      if(drs .le. 0.d0 .or. drs .ge. 1.d0)then
        irtc=itfmessage(9,'General::wrongval','"0 < #2 <1","ds/s"')
        return
      endif
      call bcube1(ars/gev,drs,mom,sigapp)
      kx=kxaaloc(-1,2,kl)
      kl%dbody(1)=kxraaloc(0,4,klp)
      klp%rbody(1:4)=(/-1.d0,-1.d0,-1.d0,1.d0/)*mom%p2*gev
      kl%dbody(2)=dfromr(sigapp*mbarn)
      irtc=0
      return
      end


module atomic_functions
use math_functions
use vars
implicit none
contains

!-----------------------------------------------------------------
! Return the profiles weighted by the strength of the components for a given frequency
! It returns zeeman_profile(q,n_depths) with
!  q=1  Mlow=Mup-1  (sigma blue)
!  q=2  Mlow=Mup    (sigma pi)
!  q=3  Mlow=Mup+1  (sigma red)
!-----------------------------------------------------------------
	subroutine zeeman_profile(Stokes_Syn,model,linea,zeeman_voigt,zeeman_faraday)
	type(stokes_type) :: Stokes_Syn
	type(modelo_type) :: model
	type(line_type) :: linea
	real(kind=8) :: zeeman_voigt(:,:), zeeman_faraday(:,:)
	integer :: n, nlow, nup, iup, ilow, i_pi, i_blue, i_red, cual
	real(kind=8) :: Mup, Mlow, strength, va, vb, splitting

		nup = 2*linea%Jup+1
		nlow = 2*linea%Jlow+1

		zeeman_voigt = 0.d0
		zeeman_faraday = 0.d0

		i_red = 0
		i_pi = 0
		i_blue = 0

		v = (Stokes_Syn%lambda-linea%wave0) / model%doppler
		va = 1.d5 * linea%wave0 * model%vmac / (PC*model%doppler)
		vb = linea%wave0**2 * model%Bfield * 4.6686d-13 / model%doppler

		do iup = 1, nup
			Mup = linea%Jup + 1 - iup  ! Mup=J...-J
			do ilow = 1, 3
				Mlow = Mup-2+ilow			! Mlow=Mup-1,Mup,Mup+1 (the allowed transitions)
				if (abs(Mlow) <= linea%Jlow) then

					strength = strength_zeeman(linea%Jup,linea%Jlow,Mup,Mlow)
					splitting = linea%gup*Mup - linea%glow*Mlow

					profile = fvoigt_zeeman(model%damping,v-va+vb*splitting)
					zeeman_voigt(ilow,:) = zeeman_voigt(ilow,:) + strength * profile(1,:) / sqrt(PI)
					zeeman_faraday(ilow,:) = zeeman_faraday(ilow,:) + strength * profile(2,:) / sqrt(PI)

				endif
			enddo
		enddo

	end subroutine zeeman_profile

!-----------------------------------------------------------------
! Return the seven independent elements of the absorption matrix
! Remember that, zeeman_voigt(q,:) and zeeman_faraday(q,:) have
!  q=1  Mlow=Mup-1  (sigma blue)
!  q=2  Mlow=Mup    (sigma pi)
!  q=3  Mlow=Mup+1  (sigma red)
!-----------------------------------------------------------------
	subroutine zeeman_opacity(model,zeeman_voigt,zeeman_faraday,ki,kq,ku,kv,fq,fu,fv)
	type(modelo_type) :: model
	integer :: line
	real(kind=8) :: zeeman_voigt(:,:), zeeman_faraday(:,:)
	real(kind=8) :: ki(:), kq(:), ku(:), kv(:), fq(:), fu(:), fv(:)
	real(kind=8) :: sin_theta, cos_theta, sin_2chi, cos_2chi

		sin_theta = sin(model%theta * PI / 180.d0)
		cos_theta = cos(model%theta * PI / 180.d0)

		sin_2chi = sin(2.d0 * model%chi * PI / 180.d0)
		cos_2chi = cos(2.d0 * model%chi * PI / 180.d0)

! Classical absorption coefficients
		ki = ki + model%kl * 0.5d0 * (zeeman_voigt(2,:)*sin_theta**2 + 0.5d0*(zeeman_voigt(1,:)+zeeman_voigt(3,:))*(1.d0+cos_theta**2))  ! eta_I
		kq = kq + model%kl * 0.5d0 * (zeeman_voigt(2,:) - 0.5d0*(zeeman_voigt(1,:)+zeeman_voigt(3,:))) * sin_theta**2*cos_2chi  ! eta_Q
		ku = ku + model%kl * 0.5d0 * (zeeman_voigt(2,:) - 0.5d0*(zeeman_voigt(1,:)+zeeman_voigt(3,:))) * sin_theta**2*sin_2chi  ! eta_U
		kv = kv + model%kl * 0.5d0 * (zeeman_voigt(3,:)-zeeman_voigt(1,:)) * cos_theta  ! eta_V

! Magneto-optical coefficients
		fq = fq + model%kl * 0.5d0 * (zeeman_faraday(2,:) - 0.5d0*(zeeman_faraday(1,:)+zeeman_faraday(3,:))) * sin_theta**2*cos_2chi  ! rho_Q
		fu = fu + model%kl * 0.5d0 * (zeeman_faraday(2,:) - 0.5d0*(zeeman_faraday(1,:)+zeeman_faraday(3,:))) * sin_theta**2*sin_2chi  ! rho_U
		fv = fv + model%kl * 0.5d0 * (zeeman_faraday(3,:)-zeeman_faraday(1,:)) * cos_theta  ! rho_V

	end subroutine zeeman_opacity

!-----------------------------------------------------------------
! Add the atomic opacity to the opacity including the effect of a magnetic field
!-----------------------------------------------------------------
	subroutine synthesize(model,linea,Stokes_Syn)
	type(modelo_type) :: model
	type(stokes_type) :: Stokes_Syn
	type(line_type) :: linea(:)
	integer :: i, j, k, n, n_lineas
	real(kind=8) :: factor1 ,factor2, lmax, lmin, lstep
	character(len=1) :: str

		ki = 0.d0
		kq = 0.d0
		ku = 0.d0
		kv = 0.d0
		fq = 0.d0
		fu = 0.d0
		fv = 0.d0

		do i = 1, nLines
			call zeeman_profile(Stokes_Syn,model,linea(i),zeeman_voigt,zeeman_faraday)

			call zeeman_opacity(model,zeeman_voigt,zeeman_faraday,ki,kq,ku,kv,fq,fu,fv)
		enddo

		delta = (1.d0+ki)**4 + (1.d0+ki)**2 * (fq**2+fu**2+fv**2-kq**2-ku**2-kv**2) - &
			(kq*fq+ku*fu+kv*fv)**2

		stokes(1,:) = model%B0 * (1.d0+model%B1/model%B0*model%mu*(1.d0+ki) / delta * &
			((1.d0+ki)**2 + fq**2 + fu**2 + fv**2))
		stokes(2,:) = -model%B1*model%mu / delta * ((1.d0+ki)**2*kq - (1.d0+ki)*(ku*fv-kv*fu) + &
			fq*(kq*fq+ku*fu+kv*fv))
		stokes(3,:) = -model%B1*model%mu / delta * ((1.d0+ki)**2*ku - (1.d0+ki)*(kv*fq-kq*fv) + &
			fu*(kq*fq+ku*fu+kv*fv))
		stokes(4,:) = -model%B1*model%mu / delta * ((1.d0+ki)**2*kv - (1.d0+ki)*(kq*fu-ku*fq) + &
			fv*(kq*fq+ku*fu+kv*fv))

		Stokes_Syn%stokes = stokes

	end subroutine synthesize

end module atomic_functions


c
c
      subroutine exccor( rho, pol, exc, vxc, vpol, ixctyp, imvex )
c
c     input
c
c     rho    the number density in inverse bohr radii cubed
c     pol    the difference of density (majority less minority)
c            divided by the sum majority plus minority
c     ixctyp the parameterization of the exchange correlation energy
c
c     ixctyp= 1 von Barth - Hedin polarization applied to
c               Wigner interpolation
c               Phys. Rev. 46, 1002 (1934)
c     ixctyp= 2 Hedin - Lundqvist
c               J. Phys. C, 4, 2064 (1971)
c     ixctyp= 3 Perdew - Zunger
c               Phys. Rev. B 23, 5048 (1981)
c     ixctyp= 4 Vosko - Wilk - Nusair
c               Can. J.  Phys. 58, 1200 (1980)
c               Phys. Rev. B 22, 3812 (1980)
c     ixctyp= 5 Perdew-Yang 92
c               Phys. Rev. B 45 13244 (1992)
c
c     imvex  inclusion of the Macdonald-Vosko correction for
c            the high density limit in the exchange
c            J. Phys. C, 12, 2977 (1979)
c
c            Not implemented for wigner exchange correlation
c
c     imvex= non-zero include it
c     imvex= 0 do not include
c
c     output
c
c     exc    the exchange correlation energy density in hartrees
c     vxc    the exchange correlation potential in hartrees
c            average over spins for polarized calculations
c     vpol   the difference in exchange correlation potentials
c
c (Note: majority spins sit in the potential vxc+vpol;
c        minority spins sit in the potential vxc-vpol.)
c
c     p refers to the paramagnetic or unpolarized limit
c     f refers to the ferromagnetic or polarized limit
c
      implicit double precision (a-h,o-z)
      parameter (zero= 0.0d0)
      parameter (one= 1.0d0)
      parameter (two= 2.0d0)
      parameter (three= 3.0d0)
      parameter (four= 4.0d0)
      parameter (half= 0.5d0)
      parameter (third= one/three)
      parameter (fthird= four*third)
      parameter (two4o3= 2.51984209978975d0)
      parameter (conrs= .6203504908993999d0)

      parameter (tiny = 1.d-12)
c
      if( rho .eq. zero ) then
         exc= zero
         vxc= zero
         vpol= zero
         return
      else if (rho .lt. zero) then
         print *, 'exccor:  rho ', rho, ' must be non-negative'
         stop 999
      endif
c
      if ( dabs(pol) .gt. one ) then
c Allow for pol to be very slightly greater than one, e.g., rounding problem.
         if (dabs(pol) .gt. one+tiny) then
             print *, 'exccor:  pol ', pol, ' must be <= 1 in abs value'
             print *, 'exccor:  dabs(pol)-1 ', dabs(pol)-one
             stop 999
         else if (pol .gt. zero) then
             pol = one
         else
             pol = -one
         endif
      endif
c
c     ------------------------
      if( ixctyp .eq. 1 ) then
c
c     wigner interpolation with rpa scaling for polarization
c     as in von barth - hedin
c
c     paramagentic limit
c
         x= rho**third
         call wigcor( x , ep, vp )
c
         if( pol .eq. zero ) then
c
c     unpolarized (paramagnetic)
c
            exc= ep
            vxc= vp
            vpol= zero
c
         else
c
c     ferromagentic limit
c
            xf= x * two4o3
            call wigcor( xf, ef, vf )
            ef= half * ef
            vf= half * vf
c
c     mix the paramagnetic and ferromagnetic limits
c
            call vbhmix(pol,ep,ef,vp,vf,exc,vxc,vpol)
c
         endif
c
c     -----------------------------
      else if( ixctyp .eq. 2 ) then
c
c     hedin - lundquist parameterization
c
         rs= conrs / rho**third
         rsin= one / rs
c
         if( pol .eq. zero ) then
c
c     unpolarized (paramagnetic) exchange
c
            call rpaexp(rsin,exp,vxp,imvex)
c
c     correlation in paramagnetic limit
c
            call hlcor( rsin, ecp, vcp )
c
            exc= exp + ecp
            vxc= vxp + vcp
            vpol= zero
c
         else
c
c     find the exchange energy and potential
c
            call rpaexf(rsin,pol,ex,vx,vxpol,imvex)
c
c     correlation in paramagnetic limit
c
            call hlcor( rsin, ecp, vcp )
c
c     correlation in ferromagnetic limit
c
            rsinf= rsin * two4o3
            call hlcor( rsinf, ecf, vcf )
c
c     scale by a factor of a half
c
            ecf= half * ecf
            vcf= half * vcf
c
c     mix the paramagnetic and ferromagnetic limits
c
            call vbhmix(pol,ecp,ecf,vcp,vcf,ec,vc,vcpol)
c
c     exchange and correlation
c
            exc= ex + ec
            vxc= vx + vc
            vpol= vxpol + vcpol
c
         endif
c
c     -----------------------------
      else if( ixctyp .eq. 3 ) then
c
c     perdew-zunger exchange and correlation
c
         rs= conrs / rho**third
         rsin= one / rs
c
         if( pol .eq. zero ) then
c
c     unpolarized (paramagnetic) exchange
c
            call rpaexp(rsin,exp,vxp,imvex)
c
c     correlation in paramagnetic limit
c
            call pzcop(rs,ecp,vcp)
c
            exc= exp + ecp
            vxc= vxp + vcp
            vpol= zero
c
         else
c
c     find the exchange energy and potential
c
            call rpaexf(rsin,pol,ex,vx,vxpol,imvex)
c
c     correlation in paramagnetic limit
c
            call pzcop(rs,ecp,vcp)
c
c     find the ferromagentic limit of the correlation
c
            call pzcof(rs,ecf,vcf)
c
c     interpolation between polarized and unpolarized
c
            call vbhmix(pol,ecp,ecf,vcp,vcf,ec,vc,vcpol)
c
c     exchange and correlation
c
            exc= ex + ec
            vxc= vx + vc
            vpol= vxpol + vcpol
c
         endif
c
c     -----------------------------
      else if( ixctyp .eq. 4 ) then
c
c     vosko - wilk - nusair correlation plus exchange
c
         rs= conrs / rho**third
         rsin= one / rs
         x= dsqrt( rs )
c
         if( pol .eq. zero ) then
c
c     unpolarized (paramagnetic) exchange
c
            call rpaexp(rsin,exp,vxp,imvex)
c
c     correlation in paramagnetic limit
c
            call vwncop(x,ecp,vcp)
c
            exc= exp + ecp
            vxc= vxp + vcp
            vpol= zero
c
         else
c
c     find the exchange energy and potential
c
            call rpaexf(rsin,pol,ex,vx,vxpol,imvex)
c
c     correlation in paramagnetic limit
c
            call vwncop(x,ecp,vcp)
c
c     correlation in ferromagnetic limit
c
            call vwncof(x,ecf,vcf)
            call vwncoa(x,eca,vca)
c
c     interpolation between the paramagnetic and ferromagnetic limits
c     for the correlation - not simple exchange scaling
c
            call vwnmix(pol,ecp,ecf,eca,vcp,vcf,vca,ec,vc,vcpol)
c
c     exchange and correlation
c
            exc= ex + ec
            vxc= vx + vc
            vpol= vxpol + vcpol
c
         endif

c     -----------------------------
      else if( ixctyp .eq. 5 ) then
         rs= conrs / rho**third
         rsin= one / rs

c     find the exchange energy and potential
         if( pol .eq. zero ) then
            call rpaexp(rsin,ex,vx,imvex)
            vxpol = 0.d0
         else
            call rpaexf(rsin,pol,ex,vx,vxpol,imvex)
         endif
c
c     Perdew-Wang 92 correlation
c
         call pwlsd (rs, pol, ec, vc, vcpol)

         exc = ex + ec
         vxc = vx + vc
         vpol= vxpol + vcpol

c     -----------------------------
      else
	  print *, 'exccor:  ixctyp ', ixctyp, ' out of range (1-5)'
          stop 999
      endif
c
      return
      end
c
c
c
      subroutine rpaexf(rsin,pol,ex,vx,vxpol,imvex)
c
c     rpa exchange energy for a spin polarized (ferromagnetic) electron density
c
      implicit double precision (a-h,o-z)
      parameter (zero= 0.0d0)
      parameter (one= 1.0d0)
      parameter (two= 2.0d0)
      parameter (three= 3.0d0)
      parameter (third= one/three)
      parameter (half= 0.5d0)
      parameter (tthird= two*third)
      parameter (cexrs= 0.4581652932831428d0)
      parameter (twotrd= 1.25992104989487d0)
      parameter (cmacv= 1.400477567739614E-02)
      parameter (thhalf= 1.5d0)
c
      fup= half * ( one + pol )
      fdn= half * ( one - pol )
      tmpup= fup**third
      tmpdn= fdn**third
c
c     exchange energy density is up plus down exchange energies
c     divided by the total charge density
c
      exup= -          twotrd * cexrs * fup * tmpup * rsin
      exdn= -          twotrd * cexrs * fdn * tmpdn * rsin
      vxup= - tthird * twotrd * cexrs *       tmpup * rsin
      vxdn= - tthird * twotrd * cexrs *       tmpdn * rsin
c
      if( imvex .ne. 0 ) then
c
c     macdonald-vosko correction for spin up
c
         beta= cmacv * twotrd * tmpup * rsin
         eta= dsqrt( one + beta**2 )
         xi= dlog( beta + eta )
         if( beta .gt. zero ) then
            scex= one - thhalf * ( ( beta*eta - xi ) / beta**2 )**2
            scvx= ( three * xi / ( two * beta * eta ) ) - half
         else
            scex= one
            scvx= one
         endif
         exup= exup * scex
         vxup= vxup * scvx
c
c     macdonald-vosko correction for spin down
c
         beta= cmacv * twotrd * tmpdn * rsin
         eta= dsqrt( one + beta**2 )
         xi= dlog( beta + eta )
         if( beta .gt. zero ) then
            scex= one - thhalf * ( ( beta*eta - xi ) / beta**2 )**2
            scvx= ( three * xi / ( two * beta * eta ) ) - half
         else
            scex= one
            scvx= one
         endif
         exdn= exdn * scex
         vxdn= vxdn * scvx
c
      endif
c
c     combined
c
      ex=    exup + exdn
      vx=    vxup + vxdn
      vxpol= vxup - vxdn
c
      return
      end
c
c
c
      subroutine rpaexp(rsin,ex,vx,imvex)
c
c     rpa exchange energy for a unpolarized (paramagnetic) electron density
c
      implicit double precision (a-h,o-z)
      parameter (one= 1.0d0)
      parameter (two= 2.0d0)
      parameter (three= 3.0d0)
      parameter (third= one/three)
      parameter (half= 0.5d0)
      parameter (tthird= two*third)
      parameter (cexrs= 0.4581652932831428d0)
      parameter (twotrd= 1.25992104989487d0)
      parameter (hlftrd= 0.7937005259840997d0)
      parameter (cmacv= 1.400477567739614E-02)
      parameter (thhalf= 1.5d0)
c
c     exchange energy density is up plus down exchange energies
c     divided by the total charge density
c
      ex= -                cexrs * rsin
      vx= - two * tthird * cexrs * rsin
c
      if( imvex .ne. 0 ) then
c
c     macdonald-vosko correction
c
         beta= cmacv * rsin
         eta= dsqrt( one + beta**2 )
         xi= dlog( beta + eta )
         scex= one - thhalf * ( ( beta*eta - xi ) / beta**2 )**2
         scvx= ( three * xi / ( two * beta * eta ) ) - half
         ex= ex * scex
         vx= vx * scvx
c
      endif
c
      return
      end
c
c
c
      subroutine vwncop(x,ec,vc)
c
c     Vosko - Wilk - Nusair parameterization of Ceperly - Alder
c     correlation energy for the paramagnetic limit
c     Can. J.  Phys. 58, 1200 (1980)
c     Phys. Rev. B 22, 3812 (1980)
c     on input x is the square root of rs
c
      implicit double precision (a-h,o-z)
      parameter (one= 1.0d0)
      parameter (two= 2.0d0)
      parameter (three= 3.0d0)
      parameter (third= one/three)
      parameter (a= 0.0310907d0)
      parameter (b= 3.72744d0)
      parameter (c= 12.9352d0)
      parameter (q= 6.15199081975908d0)
      parameter (x0= -0.10498d0)
      parameter (c1= two * b / q )
      parameter (c2= two * ( b + two * x0 ) / q )
      parameter (c3= b * x0 / ( c + b * x0 + x0**2 ) )
c
      x2= x*x
      xox= x2 + b * x + c
      taninq= datan( q / ( two * x + b ) )
      xxb= ( x2 + b*x ) / xox
      ec= dlog( x2 / xox )
     $     + c1 * taninq
     $     - c3 * ( dlog( (x-x0)**2 / xox )
     $            + c2 * taninq )
      ec= a * ec
      vc= one - xxb - c3 * ( x / (x-x0) - xxb - x*x0 / xox )
      vc= ec -third * a * vc
c
      return
      end
c
c
c
      subroutine vwncof(x,ec,vc)
c
c     Vosko - Wilk - Nusair parameterization of Ceperly - Alder
c     correlation energy for the ferromagnetic limit
c     Can. J.  Phys. 58, 1200 (1980)
c     Phys. Rev. B 22, 3812 (1980)
c     on input x is the square root of rs
c
      implicit double precision (a-h,o-z)
      parameter (one= 1.0d0)
      parameter (two= 2.0d0)
      parameter (three= 3.0d0)
      parameter (third= one/three)
      parameter (a= .01554535d0)
      parameter (b= 7.06042d0)
      parameter (c= 18.0578d0)
      parameter (q= 4.73092690956011d0)
      parameter (x0= -.325d0)
      parameter (c1= two * b / q )
      parameter (c2= two * ( b + two * x0 ) / q )
      parameter (c3= b * x0 / ( c + b * x0 + x0**2 ) )
c
      x2= x*x
      xox= x2 + b * x + c
      taninq= datan( q / ( two * x + b ) )
      xxb= ( x2 + b*x ) / xox
      ec= dlog( x2 / xox )
     $     + c1 * taninq
     $     - c3 * ( dlog( (x-x0)**2 / xox )
     $            + c2 * taninq )
      ec= a * ec
      vc= one - xxb - c3 * ( x / (x-x0) - xxb - x*x0 / xox )
      vc= ec -third * a * vc
c
      return
      end
c
c
c
      subroutine vwncoa(x,ec,vc)
c
c     Vosko - Wilk - Nusair parameterization of Ceperly - Alder
c     correlation contribution to the spin stiffness in the paramagnetic limit
c     Can. J.  Phys. 58, 1200 (1980)
c     Phys. Rev. B 22, 3812 (1980)
c     on input x is the square root of rs
c
      implicit double precision (a-h,o-z)
      parameter (one= 1.0d0)
      parameter (two= 2.0d0)
      parameter (three= 3.0d0)
      parameter (third= one/three)
      parameter (a= -.01688685d0)
      parameter (b= 1.13107d0)
      parameter (c= 13.0045d0)
      parameter (q= 7.12310891781812d0)
      parameter (x0= -.0047584d0)
      parameter (c1= two * b / q )
      parameter (c2= two * ( b + two * x0 ) / q )
      parameter (c3= b * x0 / ( c + b * x0 + x0**2 ) )
c
      x2= x*x
      xox= x2 + b * x + c
      taninq= datan( q / ( two * x + b ) )
      xxb= ( x2 + b*x ) / xox
      ec= dlog( x2 / xox )
     $     + c1 * taninq
     $     - c3 * ( dlog( (x-x0)**2 / xox )
     $            + c2 * taninq )
      ec= a * ec
      vc= one - xxb - c3 * ( x / (x-x0) - xxb - x*x0 / xox )
      vc= ec -third * a * vc
c
      return
      end
c
c
c
      subroutine pzcop(rs,ec,vc)
c
c     Perdew - Zunger  parameterization of Ceperly - Alder
c     correlation energy for the paramagnetic (unpolarized) limit
c     Phys. Rev. B 23, 5048 (1981)
c
      implicit double precision (a-h,o-z)
      parameter (one= 1.0d0)
      parameter ( b= 0.0480d0 )
      parameter ( a= 0.0311d0 )
      parameter ( d= 0.0116d0 )
      parameter ( c= 0.0020d0 )
      parameter ( ao3= a / 3.0d0 )
      parameter ( do3= d / 3.0d0 )
      parameter ( co3= c / 3.0d0 )
      parameter ( gamma= 0.1423d0 )
      parameter ( beta1= 1.0529d0 )
      parameter ( beta2= 0.3334d0 )
      parameter ( gb1o6= gamma * beta1 / 6.0d0 )
      parameter ( gb2o3= gamma * beta2 / 3.0d0 )
c
      if( rs .lt. one ) then
c
c     high density correlation
c
         alrs= dlog( rs )
         ec=  - b
     $        + a * alrs
     $        - d * rs
     $        + c * rs * alrs
         vc=  - rs * ( ao3 / rs
     $        - do3
     $        + co3 * ( one + alrs ) )
c
      else
c
c     low density correlation
c
         srrs= dsqrt( rs )
         denom= one + beta1 * srrs + beta2 * rs
         ec= - gamma / denom
         vc=  - rs * ( ( gb1o6 / srrs
     $                 + gb2o3 ) / denom**2 )
c
      endif
c
      vc= vc + ec
c
      return
      end
c
c
c
      subroutine pzcof(rs,ec,vc)
c
c     Perdew - Zunger  parameterization of Ceperly - Alder
c     correlation energy for the ferromagnetic (polarized) limit
c     Phys. Rev. B 23, 5048 (1981)
c
      implicit double precision (a-h,o-z)
      parameter (one= 1.0d0)
      parameter ( b= 0.0269d0 )
      parameter ( a= 0.01555d0 )
      parameter ( d= 0.0048d0 )
      parameter ( c= 0.0007d0 )
      parameter ( ao3= a / 3.0d0 )
      parameter ( do3= d / 3.0d0 )
      parameter ( co3= c / 3.0d0 )
      parameter ( gamma= 0.0843d0 )
      parameter ( beta1= 1.3981d0 )
      parameter ( beta2= 0.2611d0 )
      parameter ( gb1o6= gamma * beta1 / 6.0d0 )
      parameter ( gb2o3= gamma * beta2 / 3.0d0 )
c
      if( rs .lt. one ) then
c
c     high density correlation
c
         alrs= dlog( rs )
         ec=  - b
     $        + a * alrs
     $        - d * rs
     $        + c * rs * alrs
         vc=  - rs * ( ao3 / rs
     $        - do3
     $        + co3 * ( one + alrs ) )
c
      else
c
c     low density correlation
c
         srrs= dsqrt( rs )
         denom= one + beta1 * srrs + beta2 * rs
         ec= - gamma / denom
         vc=  - rs * ( ( gb1o6 / srrs
     $                 + gb2o3 ) / denom**2 )
c
      endif
c
      vc= vc + ec
c
      return
      end
c
c
c
      subroutine vbhmix(pol,ep,ef,vp,vf,e,v,vpol)
c
c     mixing between paramagnetic limits and ferromagnetic limits
c     based on rpa scaling for exchange
c     von Barth - Hedin
c     J. Phys. C 5, 1629 (1972)
c
      implicit double precision (a-h,o-z)
      parameter (one= 1.0d0)
      parameter (two= 2.0d0)
      parameter (three= 3.0d0)
      parameter (four= 4.0d0)
      parameter (third= one/three)
      parameter (fthird= four*third)
      parameter (cmix1= 1.92366105093154d0)
c
      fup= one + pol
      fdn= one - pol
      fupth= fup**third
      fdnth= fdn**third
      fmix= ( fup*fupth + fdn*fdnth - two ) * cmix1
      dfmix= fthird * ( fupth - fdnth ) * cmix1
c
      e=                ep * ( one - fmix ) + ef * fmix
      vpol= dfmix * ( ef - ep )
      v= - pol * vpol + vp * ( one - fmix ) + vf * fmix
c
      return
      end
c
c
c
      subroutine wigcor( x, exc, vxc )
c
c     wigner interpolation
c     Phys. Rev. 46, 1002 (1934)
c
      implicit double precision (a-h,o-z)
      parameter (one= 1.0d0)
c
      exc= -0.738d0 * x * ( one + 0.959d0 / ( one + 12.57d0 * x ) )
      vxc= -x * ( 0.984d0 + ( 0.943656d0 + 8.8963d0 * x ) /
     $     ( one + 12.57d0 * x)**2 )
c
      return
      end
c
c
c
      subroutine hlcor( rsin, ec, vc )
c
c     Hedin - Lundqvist parameterization of Singwi et al correlation
c     J. Phys. C, 4, 2064 (1971)
c
      implicit double precision (a-h,o-z)
      parameter (rscut= 0.01d0)
      parameter (rp= 21.0d0)
      parameter (cp= 0.0225d0)
      parameter (fiotw= 2.5d0)
      parameter (tquart= 0.75d0)
      parameter (one= 1.0d0)
      parameter (three= 3.0d0)
      parameter (four= 4.0d0)
      parameter (half= 0.5d0)
      parameter (third= one/three)
c
      x= rp * rsin
      x2= x * x
      x3= x2 * x
c
      temp= dlog( one + x )
      vc= -cp * temp
c
      if( x .lt. rscut ) then
         ec= tquart * x * ( one
     $                     - x  * ( four  - x3 ) / 10.d0
     $                     + x2 * ( three - x3 ) / 13.5d0
     $                     - x3 * ( fiotw - x3 ) / 17.5d0 )
      else
         ec= temp + ( temp
     $               - ( x - half * x2 + third * x3 ) ) / x3
      endif
c
      ec= -cp * ec
c
      return
      end
c
c
c
      subroutine vwnmix(pol,ecp,ecf,eca,vcp,vcf,vca,ec,vc,vcpol)
c
c     mixing between paramagnetic limits and ferromagnetic limits
c     Vosko - Wilk - Nusair
c     Can. J.  Phys. 58, 1200 (1980)
c     Phys. Rev. B 22, 3812 (1980)
c
      implicit double precision (a-h,o-z)
      parameter (one= 1.0d0)
      parameter (two= 2.0d0)
      parameter (three= 3.0d0)
      parameter (four= 4.0d0)
      parameter (third= one/three)
      parameter (fthird= four*third)
      parameter (cmix1= 1.92366105093154d0)
      parameter (cfppin= 0.5848223622634647d0)
c
      fup= one + pol
      fdn= one - pol
      fupth= fup**third
      fdnth= fdn**third
      fmix= ( fup*fupth + fdn*fdnth - two ) * cmix1
      dfmix= fthird * ( fupth - fdnth ) * cmix1
c
      pol3= pol**3
      pol4= pol3 * pol
      fmpol4= fmix * pol4
      dfmp4= four * pol3 * fmix + pol4 * dfmix
c
      ec=    ecp * (  one - fmpol4 )
     $     + ecf *          fmpol4
     $     + eca * ( fmix - fmpol4 ) * cfppin
      vcpol=
     $     - ecp * dfmp4
     $     + ecf * dfmp4
     $     + eca * ( dfmix - dfmp4 ) * cfppin
      vc=  - pol * vcpol
     $     + vcp * (  one - fmpol4 )
     $     + vcf *          fmpol4
     $     + vca * ( fmix - fmpol4 ) * cfppin
c
      return
      end

c Implementation of Perdew-Wang Phys. Rev. B 45, 13244 (1992) correlation
c simplified version of the subroutine CORLSD distributed by J. P. Perdew
c This version runs about twice as fast and gives almost exactly the same
c results.

c
c input
c  rs: electron gas parameter
c  zet: spin polarization   (rhoUp-rhoDn)/(rhoUp+rhoDn)
c
c output
c  ec: correlation energy per electron in hartree
c  vc: average correlation potential (called COMM in CORLSD)
c  eczet: difference potential, also d ec / d zet
c      vcUp = vc + ecZet
c      vcDn = vc - ecZet
c
c internal: (reported by CORLSD)
c  ALFC = -ALFM is the correlation contribution to the spin stiffness
c  ecrs: d ec / d rs

      subroutine pwlsd (rs, zet, ec, vc, eczet)
      double precision alfm, alfrsm, ec, ecrs, eczet, ep, eprs,
     $                 eu, eurs, f, fz, fzCon, fzzInv, gamInv,
     $                 rs, rs12, thrd, vc,
     $                 z3, z4, zet, zet1m, zet3m, zet1p, zet3p
      double precision a, a1, b1, b2, b3, b4, q0, q1, q2, q3

      parameter (thrd=1.d0/3.d0)
      parameter (gamInv=1.d0/0.5198421D0, fzzInv=1.d0/1.709921D0)
      parameter (fzCon = 4.d0*thrd*gamInv)

      zet1p = 1.d0 + zet
      zet1m = 1.d0 - zet
      zet3p = zet1p**thrd
      zet3m = zet1m**thrd
      f = ( zet1p*zet3p + zet1m*zet3m - 2.d0 ) * gamInv
      rs12 = dsqrt(rs)

      a  = 0.0310907D0
      a1 = 0.21370D0
      b1 = 7.5957D0
      b2 = 3.5876D0
      b3 = 1.6382D0
      b4 = 0.49294D0

      Q0 = -2.D0*A*(1.D0+A1*rs)
      q1 = 2.d0*a* rs12* (b1+ rs12* (b2+ rs12*(b3 + rs12* b4)))
      Q2 = DLOG(1.D0+1.D0/Q1)
      eu = Q0*Q2
      Q3 = A*(B1/RS12+2.D0*B2+ rs12* (3.d0*b3 + rs12* 4.d0*b4))
      eurs = -2.D0*A*A1*Q2-Q0*Q3/(Q1**2+Q1)

      a  =  0.01554535D0
      a1 =  0.20548D0
      b1 = 14.1189D0
      b2 =  6.1977D0
      b3 =  3.3662D0
      b4 =  0.62517D0

      Q0 = -2.D0*A*(1.D0+A1*rs)
      q1 = 2.d0*a* rs12* (b1+ rs12* (b2+ rs12*(b3 + rs12* b4)))
      Q2 = DLOG(1.D0+1.D0/Q1)
      ep = Q0*Q2
      Q3 = A*(B1/RS12+2.D0*B2+ rs12* (3.d0*b3 + rs12* 4.d0*b4))
      eprs = -2.D0*A*A1*Q2-Q0*Q3/(Q1**2+Q1)

      a  =  0.0168869D0
      a1 =  0.11125D0
      b1 = 10.357D0
      b2 =  3.6231D0
      b3 =  0.88026D0
      b4 =  0.49671D0

      Q0 = -2.D0*A*(1.D0+A1*rs)
      q1 = 2.d0*a* rs12* (b1+ rs12* (b2+ rs12*(b3 + rs12* b4)))
      Q2 = DLOG(1.D0+1.D0/Q1)
      alfm = Q0*Q2
      Q3 = A*(B1/RS12+2.D0*B2+ rs12* (3.d0*b3 + rs12* 4.d0*b4))
      alfrsm = -2.D0*A*A1*Q2-Q0*Q3/(Q1**2+Q1)

      z3 = zet * zet * zet
      z4 = z3 * zet
      EC = EU*(1.D0-F*Z4)+EP*F*Z4-ALFM*F*(1.D0-Z4) * fzzInv

C  ENERGY DONE. NOW THE POTENTIAL:
      ECRS = EURS*(1.D0-F*Z4)+EPRS*F*Z4-ALFRSM*F*(1.D0-Z4) * fzzInv
      FZ = fzCon * ( zet3p - zet3m )
      ecZet = 4.D0*z3*F*(EP-EU+ALFM*fzzInv)+FZ*(Z4*(EP-EU)
     $        -(1.D0-Z4)*ALFM*fzzInv)
      vc = ec - thrd * rs * ecRs - zet * ecZet

      return
      end


      real*8 function partnew (atom,k,level)
c******************************************************************************
c     This routine computes partition functions for those species that have
c     been updated from those that are in ATLAS9.  The polynomial
c     representations are in the form used by Irwin (1981, ApJS, 45, 621):
c            log10(U) = SUM{C_j*log10(T)**(j-1)}    for j = 1-->6
c     where T = temperature and C_j are the six polynomial coefficients.
c     Information on the updated partition functions are given by
c     Lawler & Sneden (2002, in preparation).  This routine will be
c     increasingly invoked as new new data are added to the *newpartdata*
c     array,  until a full replacement for the older partition functions
c     is implemented.
c******************************************************************************

      implicit real*8 (a-h,o-z)
      include 'Atmos.com'
      include 'Quants.com'

      iatom = int(atom+0.01)
      iarray = partflag(iatom,k)

      if (level .gt. 500) then
         temp = dlog(dble(level))
      else
         temp = tlog(level)
      endif

      ulog = 0.
      do j=1,6
         ulog = ulog + newpartdata(iarray,j)*temp**(j-1)
      enddo
      partnew = dexp(ulog)

      return
      end


      subroutine l2knts ( break, l, k, t, n )
c  from  * a practical guide to splines *  by c. de boor
c  to be called in main program  l 2 m a i n .
converts the breakpoint sequence  b r e a k   into a corresponding knot
c  sequence  t	to allow the repr. of a pp function of order  k  with
c  k-2 continuous derivatives as a spline of order  k  with knot
c  sequence  t . this means that
c  t(1), ..., t(n+k) =	break(1) k times, then break(i), i=2,...,l, each
c			once, then break(l+1) k times .
c  therefore,  n = k-1 + l.
c
c******  i n p u t  ******
c  k	 the order
c  l	 the number of polynomial pieces
c  break(1), ...,break(l+1)  the breakpoint sequence
c
c******  o u t p u t  ******
c  t(1),...,t(n+k)   the knot sequence
c  n	 the dimension of the corresp. spline space of order  k .
c
      integer k,l,n,   i,km1
      real break(1),t(1)
c     dimension break(l+1),t(n+k)
      km1 = k - 1
      do 5 i=1,km1
    5	 t(i) = break(1)
      do 6 i=1,l
    6	 t(km1+i) = break(i)
      n = km1 + l
      do 7 i=1,k
    7	 t(n+i) = break(l+1)
					return
      end


program bin_op_complex_dp

    complex(4) :: zero
    complex(8) :: v, u
    complex :: x
    zero = 1.0_4/7
    u = 1.0_4/7
    v = 1.0_8/7
    x = 1.0_4/7
    print *, zero, v, x, u

end program


program abs_02
use iso_fortran_env, only: dp=>real64
implicit none
real(dp) :: x
x = abs(1.5_dp)
if (x < 0) error stop
x = abs(-1.5_dp)
if (x < 0) error stop
end program


module subroutines
  implicit real*8 (a-h,o-z)
  complex*16:: cima = (0d0,1d0)

contains

  subroutine update(N,iconfig,params,rng)
    implicit real*8 (a-h,o-z)
    integer*1::iconfig(0:N-1)
    real*8   ::params(2)
    real     ::rng

    current_probability = 0d0
    do k = 0 , N-1
       current_probability = current_probability+iconfig(k)*params(1)
       if (rng <  current_probability) then
          iconfig(k) = 0
          return
       end if
    end do

    do k = 0,N-1
       local_iconfig = iconfig(k)
       !
       ! complete graph
       !
       do j = 0,N-1
          current_probability = current_probability + local_iconfig*(1-iconfig(j))*params(2)
          if (rng < current_probability) then
             iconfig(j) = 1
             return
          end if
       end do
    end do
  end subroutine update

!!$--------------------------------------------------

  subroutine initialize(iconfig)
    integer*1,intent(out)::iconfig(:)
    iconfig = 0
    do i = 1,size(iconfig),4
       iconfig(i) = 1
    end do
  end subroutine initialize

!!$--------------------------------------------------

  subroutine read_args(N,isteps,isamples, params,ifilename)
    character(len=32)::arg
    real*8 ::fargs(5)
    real*8 ,intent(out)::params(2)
    integer,intent(out)::N,isteps,isamples
    character(len=*),intent(out)::ifilename
    ! default values
    ! N = 10 , steps = 100 , samples =100 , gamma = 0.3, alpha = 1.0
    fargs = (/ 1d1, 1d2 , 1d2 , 0.3d0 , 1d0 /)

    ifilename =  "data"

    ntotal = command_argument_count()
    do i = 1,ntotal,2
       call get_command_argument(i,arg)
       select case(trim(arg))
       case ('-n','-N')
          call get_command_argument(i+1,arg)
          read(arg,*) fargs(1)
          ifilename = trim(ifilename)//'_N'//trim(arg)
       case ('--steps','-s')
          call get_command_argument(i+1,arg)
          read(arg,*) fargs(2)
          ifilename = trim(ifilename)//'_steps'//trim(arg)
       case ('--samples','-mc')
          call get_command_argument(i+1,arg)
          read(arg,*) fargs(3)
          ifilename = trim(ifilename)//'_samples'//trim(arg)
       case ('--gamma','-g')
          call get_command_argument(i+1,arg)
          read(arg,*) fargs(4)
          ifilename = trim(ifilename)//'_gamma'//trim(arg)
       case ('--alpha','-a')
          call get_command_argument(i+1,arg)
          read(arg,*) fargs(5)
          ifilename = trim(ifilename)//'_alpha'//trim(arg)
       case('-h','--help')
          print *,'example usage'
          print *,'      main -n 10 --samples 100 --steps 100 --alpha 1.0 --gamma 0.3'
          call exit(0)
       end select
    end do
    ifilename = trim(ifilename)//'.dat'
    print *,ifilename

    N = int(fargs(1))
    isteps   = int(fargs(2))
    isamples = int(fargs(3))
    params(1)= fargs(4)/N
    params(2)= fargs(5)/(N*N)
  end subroutine read_args

!!$--------------------------------------------------

  subroutine save(ifilename,data)
    implicit real*8 (a-h,o-z)
    real*8::data(:,:)
    character(len=128)::ifilename
    character(len=32) ::fmts

    m = size(data,2)
    write(fmts,"(I0)") m+1
    fmts ="(I8,A,"//trim(fmts)//"ES20.12E2)"

    open(10,file=trim(ifilename))
    do k =1,size(data,1)
       write(10,fmts) k,' ',(data(k,j),j=1,m)
    end do
    close(10)
  end subroutine save

end module subroutines


SUBROUTINE rigid_jointed(km,prop,gamma,etype,iel,coord)
!
! This subroutine forms the stiffness matrix of a
! general beam/column element (1-, 2- or 3-d).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::gamma(:),coord(:,:),prop(:,:)
 INTEGER,INTENT(IN)::etype(:),iel
 REAL(iwp),INTENT(OUT)::km(:,:)
 INTEGER::ndim,i,j,k
 REAL(iwp)::ell,x1,x2,y1,y2,z1,z2,c,s,e1,e2,e3,e4,pi,xl,yl,zl,cg,sg,den,  &
   ea,ei,eiy,eiz,gj,a1,a2,a3,a4,a5,a6,a7,a8,sum,gamrad,x,t(12,12),        &
   tt(12,12),cc(12,12),r0(3,3),zero=0.0_iwp,pt5=0.5_iwp,one=1.0_iwp,      &
   two=2.0_iwp,d4=4.0_iwp,d6=6.0_iwp,d12=12.0_iwp,d180=180.0_iwp
 ndim=UBOUND(coord,2)
 SELECT CASE(ndim)
 CASE(1)
   ei=prop(1,etype(iel))
   ell=coord(2,1)-coord(1,1)
   km(1,1)=d12*ei/(ell*ell*ell)
   km(3,3)=km(1,1)
   km(1,2)=d6*ei/(ell*ell)
   km(2,1)=km(1,2)
   km(1,4)=km(1,2)
   km(4,1)=km(1,4)
   km(1,3)=-km(1,1)
   km(3,1)=km(1,3)
   km(3,4)=-km(1,2)
   km(4,3)=km(3,4)
   km(2,3)=km(3,4)
   km(3,2)=km(2,3)
   km(2,2)=d4*ei/ell
   km(4,4)=km(2,2)
   km(2,4)=two*ei/ell
   km(4,2)=km(2,4)
 CASE(2)
   ea=prop(1,etype(iel))
   ei=prop(2,etype(iel))
   x1=coord(1,1)
   y1=coord(1,2)
   x2=coord(2,1)
   y2=coord(2,2)
   ell=SQRT((y2-y1)**2+(x2-x1)**2)
   c=(x2-x1)/ell
   s=(y2-y1)/ell
   e1=ea/ell
   e2=d12*ei/(ell*ell*ell)
   e3=ei/ell
   e4=d6*ei/(ell*ell)
   km(1,1)=c*c*e1+s*s*e2
   km(4,4)=km(1,1)
   km(1,2)=s*c*(e1-e2)
   km(2,1)=km(1,2)
   km(4,5)=km(1,2)
   km(5,4)=km(4,5)
   km(1,3)=-s*e4
   km(3,1)=km(1,3)
   km(1,6)=km(1,3)
   km(6,1)=km(1,6)
   km(3,4)=s*e4
   km(4,3)=km(3,4)
   km(4,6)=km(3,4)
   km(6,4)=km(4,6)
   km(1,4)=-km(1,1)
   km(4,1)=km(1,4)
   km(1,5)=s*c*(-e1+e2)
   km(5,1)=km(1,5)
   km(2,4)=km(1,5)
   km(4,2)=km(2,4)
   km(2,2)=s*s*e1+c*c*e2
   km(5,5)=km(2,2)
   km(2,5)=-km(2,2)
   km(5,2)=km(2,5)
   km(2,3)=c*e4
   km(3,2)=km(2,3)
   km(2,6)=km(2,3)
   km(6,2)=km(2,6)
   km(3,3)=d4*e3
   km(6,6)=km(3,3)
   km(3,5)=-c*e4
   km(5,3)=km(3,5)
   km(5,6)=km(3,5)
   km(6,5)=km(5,6)
   km(3,6)=two*e3
   km(6,3)=km(3,6)
 CASE(3)
   ea=prop(1,etype(iel))
   eiy=prop(2,etype(iel))
   eiz=prop(3,etype(iel))
   gj=prop(4,etype(iel))
   x1=coord(1,1)
   y1=coord(1,2)
   z1=coord(1,3)
   x2=coord(2,1)
   y2=coord(2,2)
   z2=coord(2,3)
   xl=x2-x1
   yl=y2-y1
   zl=z2-z1
   ell=SQRT(xl*xl+yl*yl+zl*zl)
   km=zero
   t=zero
   tt=zero
   a1=ea/ell
   a2=d12*eiz/(ell*ell*ell)
   a3=d12*eiy/(ell*ell*ell)
   a4=d6*eiz/(ell*ell)
   a5=d6*eiy/(ell*ell)
   a6=d4*eiz/ell
   a7=d4*eiy/ell
   a8=gj/ell
   km(1,1)=a1
   km(7,7)=a1
   km(1,7)=-a1
   km(7,1)=-a1
   km(2,2)=a2
   km(8,8)=a2
   km(2,8)=-a2
   km(8,2)=-a2
   km(3,3)=a3
   km(9,9)=a3
   km(3,9)=-a3
   km(9,3)=-a3
   km(4,4)=a8
   km(10,10)=a8
   km(4,10)=-a8
   km(10,4)=-a8
   km(5,5)=a7
   km(11,11)=a7
   km(5,11)=pt5*a7
   km(11,5)=pt5*a7
   km(6,6)=a6
   km(12,12)=a6
   km(6,12)=pt5*a6
   km(12,6)=pt5*a6
   km(2,6)=a4
   km(6,2)=a4
   km(2,12)=a4
   km(12,2)=a4
   km(6,8)=-a4
   km(8,6)=-a4
   km(8,12)=-a4
   km(12,8)=-a4
   km(5,9)=a5
   km(9,5)=a5
   km(9,11)=a5
   km(11,9)=a5
   km(3,5)=-a5
   km(5,3)=-a5
   km(3,11)=-a5
   km(11,3)=-a5
   pi=ACOS(-one)
   gamrad=gamma(iel)*pi/d180
   cg=COS(gamrad)
   sg=SIN(gamrad)
   den=ell*SQRT(xl*xl+zl*zl)
   IF(den/=zero)THEN
     r0(1,1)=xl/ell
     r0(1,2)=yl/ell
     r0(1,3)=zl/ell
     r0(2,1)=(-xl*yl*cg-ell*zl*sg)/den
     r0(2,2)=den*cg/(ell*ell)
     r0(2,3)=(-yl*zl*cg+ell*xl*sg)/den
     r0(3,1)=(xl*yl*sg-ell*zl*cg)/den
     r0(3,2)=-den*sg/(ell*ell)
     r0(3,3)=(yl*zl*sg+ell*xl*cg)/den
   ELSE
     r0(1,1)=zero
     r0(1,3)=zero
     r0(2,2)=zero
     r0(3,2)=zero
     r0(1,2)=one
     r0(2,1)=-cg
     r0(3,3)=cg
     r0(2,3)=sg
     r0(3,1)=sg
   END IF
     DO i=1,3
       DO j=1,3
       x=r0(i,j)
       DO k=0,9,3
         t(i+k,j+k)=x
         tt(j+k,i+k)=x
       END DO
     END DO
   END DO
   DO i=1,12
     DO j=1,12
       sum=zero
       DO k=1,12
         sum=sum+km(i,k)*t(k,j)
       END DO
       cc(i,j)=sum
     END DO
   END DO
   DO i=1,12
     DO j=1,12
       sum=zero
       DO k=1,12
         sum=sum+tt(i,k)*cc(k,j)
       END DO
       km(i,j)=sum
     END DO
   END DO
 END SELECT
RETURN
END SUBROUTINE rigid_jointed


!==========================================================================
elemental function gsw_specvol (sa, ct, p)
!==========================================================================
!
!  Calculates specific volume from Absolute Salinity, Conservative
!  Temperature and pressure, using the computationally-efficient
!  polynomial expression for specific volume (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  specvol  =  specific volume                                   [ m^3/kg ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_sfac, offset

use gsw_mod_specvol_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p

real (r8) :: gsw_specvol

real (r8) :: xs, ys, z

xs = sqrt(gsw_sfac*sa + offset)
ys = ct*0.025_r8
z = p*1e-4_r8

gsw_specvol = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 &
    + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 &
    + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) &
    + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 &
    + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 &
    + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 &
    + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 &
    + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs &
    + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) &
    + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 &
    + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 &
    + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys &
    + z*(v005 + v006*z)))))

return
end function

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


!-------------------------------------------------------------------------------
!
!+  Module of Updating UVW for Tracer Advection Test
!
!-------------------------------------------------------------------------------
module mod_af_trcadv
  !-----------------------------------------------------------------------------
  !
  !++ Description:
  !       This module is for the Dyn Core Test Initialization.
  !
  !
  !++ Current Corresponding Author : R.Yoshida
  !
  !++ History:
  !      Version   Date       Comment
  !      -----------------------------------------------------------------------
  !      0.00      12-10-19   artificial updating  R.Yoshida
  !
  !      -----------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  !
  !++ Used modules
  !
!  use mod_adm, only: &
!     ADM_LOG_FID,  &
!     ADM_NSYS
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public parameters
  !
  ! physical parameters configurations
    real(8), parameter :: &
         a	= 6371220.0d0,	& ! Earth's Radius (m)
         Rd 	= 287.0d0,	& ! Ideal gas const dry air (J kg^-1 K^1)
         g	= 9.80616d0,	& ! Gravity (m s^2)
         cp	= 1004.5d0,	& ! Specific heat capacity (J kg^-1 K^1)
         pi	= 4.d0*atan(1.d0) ! pi

  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: test11_velocity
  public :: test12_velocity
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedures
  !
  private :: Sp_Unit_East
  private :: Sp_Unit_North
  !-----------------------------------------------------------------------------
contains
  !
  !-----------------------------------------------------------------------------
  subroutine test11_velocity (time,lon,lat,zf,zh,vx,vy,vz,w)
    !----- [add; original by H.Miura] 20130612 R.Yoshida
    implicit none
    !
    real(8),intent(in) :: time
    real(8),intent(in) :: zf,zh    ! height (real altitude)
    real(8),intent(in) :: lon
    real(8),intent(in) :: lat
    real(8),intent(out) :: vx
    real(8),intent(out) :: vy
    real(8),intent(out) :: vz
    real(8),intent(out) :: w
    !
    ! <constant>
    real(8), parameter :: 	&
         tau     = 12.d0 * 86400.d0,	& ! period of motion 12 days
         u0      = (2.d0*pi*a)/tau,	& ! 2 pi a / 12 days
         k0	   = (10.d0*a)/tau,	& ! Velocity Magnitude
         omega0  = (23000.d0*pi)/tau,	& ! Velocity Magnitude
         T0      = 300.d0,		& ! temperature
         H       = Rd * T0 / g,	& ! scale height
         RR      = 1.d0/2.d0,		& ! horizontal half width divided by 'a'
         ZZ      = 1000.d0,		& ! vertical half width
         z0      = 5000.d0,		& ! center point in z
         lambda0 = 5.d0*pi/6.d0,	& ! center point in longitudes
         lambda1 = 7.d0*pi/6.d0,	& ! center point in longitudes
         phi0    = 0.d0,		& ! center point in latitudes
         phi1    = 0.d0
    real(8), parameter ::   p0 = 100000.d0 ! reference pressure (Pa)
    ! <work>
    real(8) :: &
         u, &	! Zonal wind (m s^-1)
         v    ! Meridional wind (m s^-1)
    real(8) :: lonp,height,p,ptop,bs,s,ud,east(3),nrth(3)
    !-----

      ! full level
      height = zf
      p = p0 * exp(-zf/H)

      ptop    = p0*exp(-12000.d0/H)

      lonp = lon - 2.d0*pi*time/tau

      bs = 0.2
      s = 1.0 + exp( (ptop-p0)/(bs*ptop) ) &
              - exp( (p-p0)/(bs*ptop)) &
              - exp( (ptop-p)/(bs*ptop))

      ud = (omega0*a)/(bs*ptop) * cos(lonp) * (cos(lat)**2.0) * cos(2.0*pi*time/tau) * &
           ( - exp( (p-p0)/(bs*ptop)) + exp( (ptop-p)/(bs*ptop))  )

      u = k0*sin(lonp)*sin(lonp)*sin(2.d0*lat)*cos(pi*time/tau) + u0*cos(lat) + ud
      v = k0*sin(2.d0*lonp)*cos(lat)*cos(pi*time/tau)

      east=Sp_Unit_East (lon)
      nrth=Sp_Unit_North (lon,lat)

      vx=east(1)*u+nrth(1)*v
      vy=east(2)*u+nrth(2)*v
      vz=east(3)*u+nrth(3)*v

      ! half level
      height = zh
      p = p0 * exp(-zh/H)

      ptop    = p0*exp(-12000.d0/H)

      lonp = lon - 2.d0*pi*time/tau

      bs = 0.2
      s = 1.0 + exp( (ptop-p0)/(bs*ptop) ) &
              - exp( (p-p0)/(bs*ptop)) &
              - exp( (ptop-p)/(bs*ptop))

      w = -((Rd*T0)/(g*p))*omega0*sin(lonp)*cos(lat)*cos(2.0*pi*time/tau)*s

      return
  end subroutine test11_velocity
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  subroutine test12_velocity (time,lon,lat,zf,zh,vx,vy,vz,w)
    !----- [add; original by H.Miura] 20130612 R.Yoshida
    implicit none
    !
    real(8),intent(in) :: time
    real(8),intent(in) :: zf,zh    ! height (real altitude)
    real(8),intent(in) :: lon
    real(8),intent(in) :: lat
    real(8),intent(out) :: vx
    real(8),intent(out) :: vy
    real(8),intent(out) :: vz
    real(8),intent(out) :: w
    !
    ! <constant>
    real(8), parameter :: &
         tau     = 1.d0 * 86400.d0, &	! period of motion 1 day (in s)
         u0      = 40.d0,           &	! Zonal velocity magnitude (m/s)
         w0	   = 0.15d0,          &	! Vertical velocity magnitude (m/s), changed in v5
         T0      = 300.d0,          &	! temperature (K)
         H       = Rd * T0 / g,     &	! scale height
         K       = 5.d0,            &	! number of Hadley-like cells
         z1      = 2000.d0,    & ! position of lower tracer bound (m), changed in v5
         z2      = 5000.d0,    & ! position of upper tracer bound (m), changed in v5
         z0      = 0.5d0*(z1+z2),   &	! midpoint (m)
         ztop    = 12000.d0		! model top (m)
    real(8), parameter ::   p0 = 100000.d0 ! reference pressure (Pa)
    ! <work>
    real(8) :: &
         u, &	! Zonal wind (m s^-1)
         v    ! Meridional wind (m s^-1)
    real(8) :: lonp,height,p,ptop,bs,s,ud,east(3),nrth(3),rho,rho0,t,phis
    !-----

      ! full level
      height = zf
      p = p0 * exp(-zf/H)

      t = T0
      phis = 0.d0

      rho = p/(Rd*t)
      rho0 = p0/(Rd*t)

      u = u0*cos(lat)
      v = -(rho0/rho) * (a*w0*pi)/(K*ztop) *cos(lat)*sin(K*lat)&
                         *cos(pi*height/ztop)*cos(pi*time/tau)

      east=Sp_Unit_East (lon)
      nrth=Sp_Unit_North (lon,lat)

      vx=east(1)*u+nrth(1)*v
      vy=east(2)*u+nrth(2)*v
      vz=east(3)*u+nrth(3)*v

      ! half level
      height = zh
      p = p0 * exp(-zf/H)

      t = T0
      phis = 0.d0

      rho = p/(Rd*t)
      rho0 = p0/(Rd*t)

      w = (rho0/rho) *(w0/K)*(-2.d0*sin(K*lat)*sin(lat) + K*cos(lat)*cos(K*lat)) &
		*sin(pi*height/ztop)*cos(pi*time/tau)

      return
  end subroutine test12_velocity
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  function Sp_Unit_East( lon ) result( unit_east )
    ! imported from prg_mkinit_ncep.f90 (original written by H.Miura)
    ! ------
    ! Compute local eastward unit vector (unit_east)
    ! in the Cartesian coordinate system
    ! given longitude (lon) of a position.
    !
    implicit none
    real(8), intent(in) :: lon  ! [ rad ]
    real(8) :: unit_east(3)
    !
    unit_east(1) = - sin( lon )    ! --- x-direction
    unit_east(2) =   cos( lon )    ! --- y-direction
    unit_east(3) = 0.0_8           ! --- z-direction
    return
  end function Sp_Unit_East
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  function Sp_Unit_North( lon, lat ) result( unit_north )
    ! imported from prg_mkinit_ncep.f90 (original written by H.Miura)
    ! ------
    ! Compute local northward unit vector (unit_north)
    ! in the Cartesian coordinate system
    ! given longitude (lon) and latitude (lat) of a position.
    !
    implicit none
    real(8), intent(in) :: lon, lat  ! [ rad ]
    real(8) :: unit_north(3)
    !
    unit_north(1) = - sin( lat ) * cos( lon )    ! --- x-direction
    unit_north(2) = - sin( lat ) * sin( lon )    ! --- y-direction
    unit_north(3) =   cos( lat )                 ! --- z-direction
    return
  end function Sp_Unit_North
  !-----------------------------------------------------------------------------
  !
end module mod_af_trcadv
!-------------------------------------------------------------------------------


      subroutine Ampsq_AQaq_nonid(p1,p2,p3,p4,ampsq)
c--- this routine is a wrapper to the leading order amplitudes
c--- of D.&S. 0906.0008; it performs the squaring and sum over
c--- helicities and returns the ME in the same fashion as h4qn
      implicit none
      include 'constants.f'
      include 'zprods_com.f'
      integer p1,p2,p3,p4,j1,j2,j3,j4,h1,h2
      double precision ampsq
      double complex amp(2,2),
     . A0Hqarbmppm,A0Hqarbmpmp

c--- the routine expects momenta to be labelled:
c---                                 q(p1)+Q(p2) --> q(p3)+Q(p4)
c---   and in this routine we use:   0 --> A(j1)+Q(j2)+a(j3)+q(j4)
c---
c--- so we permute appropriately
      j1=p2
      j2=p4
      j3=p1
      j4=p3

c--- coded amplitudes
      amp(1,2)=A0Hqarbmppm(j1,j2,j3,j4,za,zb)
      amp(1,1)=A0Hqarbmpmp(j1,j2,j3,j4,za,zb)
c--- charge conjugation
      amp(2,1)=A0Hqarbmppm(j2,j1,j4,j3,za,zb)
      amp(2,2)=A0Hqarbmpmp(j2,j1,j4,j3,za,zb)

c--- square, with appropriate overall factor
c--- (in D.&S. notation, overall 4*C^2*gs^4 is applied in gg_hgg.f)

      ampsq=zip
      do h1=1,2
      do h2=1,2
      ampsq=ampsq+cdabs(amp(h1,h2))**2
      enddo
      enddo

      ampsq=ampsq*V/4d0

      return
      end

      subroutine Ampsq_AQaq_ident(p1,p2,p3,p4,
     .                            ampsq,ampsq_a,ampsq_b,ampsq_i)
c--- this routine is a wrapper to the leading order amplitudes
c--- of D.&S. 0906.0008; it performs the squaring and sum over
c--- helicities and returns the ME in the same fashion as h4qn
      implicit none
      include 'constants.f'
      include 'zprods_com.f'
      integer p1,p2,p3,p4,j1,j2,j3,j4,h1,h2
      double precision ampsq,ampsq_a,ampsq_b,ampsq_i
      double complex amp_a(2,2),amp_b(2,2),
     . A0Hqarbmppm,A0Hqarbmpmp

c--- the routine expects momenta to be labelled:
c---                                 q(p1)+Q(p2) --> q(p3)+Q(p4)
c---   and in this routine we use:   0 --> A(j1)+Q(j2)+a(j3)+q(j4)
c---
c--- so we permute appropriately
      j1=p2
      j2=p4
      j3=p1
      j4=p3

c--- First calculate with the normal ordering, (1,2,3,4)
c--- coded amplitudes
      amp_a(1,2)=A0Hqarbmppm(j1,j2,j3,j4,za,zb)
      amp_a(1,1)=A0Hqarbmpmp(j1,j2,j3,j4,za,zb)
c--- charge conjugation
      amp_a(2,1)=A0Hqarbmppm(j2,j1,j4,j3,za,zb)
      amp_a(2,2)=A0Hqarbmpmp(j2,j1,j4,j3,za,zb)

c--- Now calculate with the exhanged order,    (1,4,3,2)
c--- coded amplitudes
      amp_b(1,2)=A0Hqarbmppm(j1,j4,j3,j2,za,zb)
      amp_b(1,1)=A0Hqarbmpmp(j1,j4,j3,j2,za,zb)
c--- charge conjugation
      amp_b(2,1)=A0Hqarbmppm(j4,j1,j2,j3,za,zb)
      amp_b(2,2)=A0Hqarbmpmp(j4,j1,j2,j3,za,zb)

c--- square, with appropriate overall factor
c--- (in D.&S. notation, overall 4*C^2*gs^4 is applied in gg_hgg.f)

      ampsq_a=zip
      ampsq_b=zip
      ampsq_i=zip
      do h1=1,2
      do h2=1,2
      ampsq_a=ampsq_a+cdabs(amp_a(h1,h2))**2
      ampsq_b=ampsq_b+cdabs(amp_b(h1,h2))**2
      if (h1 .eq. h2) then
        ampsq_i=ampsq_i+2d0/xn*dble(amp_a(h1,h2)*dconjg(amp_b(h1,h2)))
      endif
      enddo
      enddo

      ampsq_a=ampsq_a*V/4d0
      ampsq_b=ampsq_b*V/4d0
      ampsq_i=ampsq_i*V/4d0

      ampsq=ampsq_a+ampsq_b+ampsq_i

      return
      end


!
!     --------------------------------------------------------------
!     R E C O U P L S 2
!     --------------------------------------------------------------
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vanderbilt University,  Nashville            February 1994   *
!
      SUBROUTINE RECOUPLS2(K, JA1, JA2, KA, IRE, IAT, REC)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
      USE MEDEFN_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  11:00:59  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE dlsa2_I
      USE dlsa1_I
      USE dlsa3_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: K
      INTEGER  :: JA1
      INTEGER  :: JA2
      INTEGER  :: KA
      INTEGER  :: IRE
      INTEGER  :: IAT
      REAL(DOUBLE) , INTENT(OUT) :: REC
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IA1, IB1, IA2, IB2, ISKR
      REAL(DOUBLE) :: S, SS, RE
!-----------------------------------------------
      IAT = 0
      S = DBLE(J1QN1(JA1,K))
      SS = DBLE(J1QN1(JA2,K))
      REC = ONE/DSQRT(S*SS)
      IF (IRE/=0 .AND. KA==0) THEN
         IAT = 1
      ELSE
         IA1 = J1QN1(JA1,K) - 1
         IB1 = J1QN2(JA1,K) - 1
         IA2 = J1QN1(JA2,K) - 1
         IB2 = J1QN2(JA2,K) - 1
         IAT = 0
         CALL DLSA2 (K, JA1, JA2, KA, IRE, IAT, RE)
         IF (IAT == 0) RETURN
         REC = RE*REC*DSQRT(DBLE(IA2 + 1))/DSQRT(DBLE((KA + 1)*(IB2 + 1)))
         IF (JA1==1 .AND. JA2==2) RETURN
         IAT = 0
         CALL DLSA1 (K, JA1, KA, IRE, IAT, RE)
         IF (IAT == 0) RETURN
         REC = RE*REC
         ISKR = JA2 - JA1
         IF (JA1 == 1) ISKR = JA2 - 1 - JA1
         IF (ISKR <= 1) RETURN
         IAT = 0
         CALL DLSA3 (K, JA1, JA2, KA, IRE, IAT, RE)
         REC = RE*REC
      ENDIF
      RETURN
      END SUBROUTINE RECOUPLS2


!#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!#
!# Author: Piyush Agram
!# Copyright 2013, by the California Institute of Technology. ALL RIGHTS RESERVED.
!# United States Government Sponsorship acknowledged.
!# Any commercial use must be negotiated with the Office of Technology Transfer at
!# the California Institute of Technology.
!# This software may be subject to U.S. export control laws.
!# By accepting this software, the user agrees to comply with all applicable U.S.
!# export laws and regulations. User has the responsibility to obtain export licenses,
!# or other export authority as may be required before exporting such information to
!# foreign countries or providing access to foreign persons.
!#
!#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

            module topozeroMethods
                use uniform_interp
                use akimaLib
                implicit none

                real*8, dimension(:), allocatable :: r_filter
                real*4, dimension(:), allocatable :: fintp
                real*4 :: f_delay, BADVALUE

                integer :: sinc_len,sinc_sub
                integer :: SINC_METHOD, BILINEAR_METHOD
                integer :: BICUBIC_METHOD, NEAREST_METHOD
                integer :: AKIMA_METHOD, BIQUINTIC_METHOD
                parameter(SINC_METHOD=0,BILINEAR_METHOD=1)
                parameter(BICUBIC_METHOD=2,NEAREST_METHOD=3)
                parameter(AKIMA_METHOD=4, BIQUINTIC_METHOD=5)
                parameter(BADVALUE=-1000.0)
                parameter(sinc_sub=8192,sinc_len=8)

                interface
                    real*4 function intpTemplate(dem,i_x,i_y,f_x,f_y,nx,ny)
                        real*4, dimension(:,:) :: dem
                        integer :: i_x,i_y,nx,ny
                        real*8:: f_x,f_y
                    end function intpTemplate
               end interface

                contains
                    subroutine prepareMethods(method)
                        implicit none
                        integer method
                        integer i_intplength,i_filtercoef
                        integer i,j
                        real*8 ONE,ZERO
                        parameter(ONE=1.0,ZERO=0.0)

                        if (method.eq.SINC_METHOD) then
                            print *, 'Initializing Sinc interpolator'
                            allocate(r_filter(0:(sinc_sub*sinc_len)))
                            allocate(fintp(0:(sinc_sub*sinc_len-1)))

                            call sinc_coef(ONE,ONE*sinc_len,sinc_sub,ZERO,1,i_intplength,i_filtercoef,r_filter)

                            do i=0,sinc_len-1
                                do j=0, sinc_sub-1
                                   fintp(i+j*sinc_len) = r_filter(j+i*sinc_sub)
                                enddo
                            enddo

                            f_delay = sinc_len/2.0

                        else if (method.eq.BILINEAR_METHOD) then
                            print *, 'Initializing Bilinear interpolator'
                            f_delay = 2.0
                        else if (method.eq.BICUBIC_METHOD) then
                            print *, 'Initializing Bicubic interpolator'
                            f_delay=3.0
                        else if (method.eq.NEAREST_METHOD) then
                            print *, 'Initializing Nearest Neighbor interpolator'
                            f_delay=2.0
                        else if (method.eq.AKIMA_METHOD) then
                            print *, 'Initializing Akima interpolator'
                            f_delay=2.0
                        else if (method.eq.BIQUINTIC_METHOD) then
                            print *, 'Initializing biquintic interpolator'
                            f_delay=3.0
                        else
                            print *, 'Unknown method type.'
                            stop
                        endif

                    end subroutine prepareMethods

                    subroutine unprepareMethods(method)
                        implicit none
                        integer method

                        if (method.eq.SINC_METHOD) then
                            deallocate(r_filter)
                            deallocate(fintp)
                        endif
                    end subroutine unprepareMethods

                    real*4 function intp_sinc(dem,i_x,i_y,f_x,f_y,nx,ny)
                        implicit none
                        real*4, dimension(:,:) :: dem
                        integer:: i_x,i_y,nx,ny
                        real*8 :: f_x,f_y

                        integer :: i_xx, i_yy

                        if ((i_x.lt.4) .or. (i_x.gt.(nx-3))) then
                            intp_sinc = BADVALUE
                            return
                        endif

                        if ((i_y.lt.4) .or. (i_y.gt.(ny-3))) then
                            intp_sinc = BADVALUE
                            return
                        endif

                        i_xx = i_x + sinc_len/2
                        i_yy = i_y + sinc_len/2

                        intp_sinc=sinc_eval_2d_f(dem,fintp,sinc_sub,sinc_len,i_xx,i_yy,f_x,f_y,nx,ny)
                    end function intp_sinc

                    real*4 function intp_bilinear(dem,i_x,i_y,f_x,f_y,nx,ny)
                        implicit none
                        real*4,dimension(:,:) :: dem
                        integer :: i_x,i_y,nx,ny
                        real*8 :: f_x,f_y,temp

                        real*8 :: dx,dy

                        dx = i_x + f_x
                        dy = i_y + f_y

                        if ((i_x.lt.1).or.(i_x.ge.nx)) then
                            intp_bilinear=BADVALUE
                            return
                        endif

                        if ((i_y.lt.1).or.(i_y.ge.ny)) then
                            intp_bilinear=BADVALUE
                            return
                        endif

                        temp = bilinear(dy,dx,dem)
                        intp_bilinear = sngl(temp)

                    end function intp_bilinear

                    real*4 function intp_bicubic(dem,i_x,i_y,f_x,f_y,nx,ny)
                        implicit none
                        real*4,dimension(:,:) :: dem
                        integer :: i_x,i_y,nx,ny
                        real*8 :: f_x,f_y

                        real*8 :: dx,dy,temp

                        dx = i_x + f_x
                        dy = i_y + f_y

                        if ((i_x.lt.2).or.(i_x.ge.(nx-1))) then
                            intp_bicubic = BADVALUE
                            return
                        endif

                        if ((i_y.lt.2).or.(i_y.ge.(ny-1))) then
                            intp_bicubic = BADVALUE
                            return
                        endif

                        temp = bicubic(dy,dx,dem)
                        intp_bicubic = sngl(temp)
                    end function intp_bicubic

                    real*4 function intp_biquintic(dem,i_x,i_y,f_x,f_y,nx,ny)
                        implicit none
                        real*4,dimension(:,:) :: dem
                        integer :: i_x,i_y,nx,ny
                        real*8 :: f_x,f_y

                        real*8 :: dx,dy
                        real*4 :: interp2Dspline

                        dx = i_x + f_x
                        dy = i_y + f_y

                        if ((i_x.lt.3).or.(i_x.ge.(nx-2))) then
                            intp_biquintic = BADVALUE
                            return
                        endif

                        if ((i_y.lt.3).or.(i_y.ge.(ny-2))) then
                            intp_biquintic = BADVALUE
                            return
                        endif

                        intp_biquintic = interp2DSpline(6,ny,nx,dem,dy,dx)
                    end function intp_biquintic

                    real*4 function intp_nearest(dem,i_x,i_y,f_x,f_y,nx,ny)
                        implicit none
                        real*4,dimension(:,:) :: dem
                        integer :: i_x,i_y,nx,ny
                        real*8 :: f_x,f_y
                        integer :: dx,dy

                        dx = nint(i_x+f_x)
                        dy = nint(i_y+f_y)

                        if ((dx.lt.1) .or. (dx.gt.nx)) then
                            intp_nearest = BADVALUE
                            return
                        endif

                        if ((dy.lt.1) .or. (dy.gt.ny)) then
                            intp_nearest = BADVALUE
                            return
                        endif

                        intp_nearest = dem(dx,dy)
                    end function intp_nearest

                    real*4 function intp_akima(dem,i_x,i_y,f_x,f_y,nx,ny)
                        implicit none
                        real*4, dimension(:,:) :: dem
                        integer :: i_x,i_y,nx,ny
                        real*8 :: f_x, f_y
                        real*8 :: dx, dy, temp
                        double precision, dimension(aki_nsys) :: poly

                        dx = i_x + f_x
                        dy = i_y + f_y

                        if ((i_x.lt.1).or.(i_x.ge.(nx-1))) then
                            intp_akima = BADVALUE
                            return
                        endif

                        if ((i_y.lt.1).or.(i_y.ge.(ny-1))) then
                            intp_akima = BADVALUE
                            return
                        endif

                        call polyfitAkima(nx,ny,dem,i_x,i_y,poly)
                        temp = polyvalAkima(i_x,i_y,dx,dy,poly)
!!                        temp = akima_intp(ny,nx,dem,dy,dx)
                        intp_akima = sngl(temp)
                    end function intp_akima

            end module topozeroMethods


      SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB)                              00000010
      INTEGER LDA,N,IPVT(1),JOB                                         00000020
      DOUBLE PRECISION A(LDA,1),B(1)                                    00000030
C                                                                       00000040
C     DGESL SOLVES THE DOUBLE PRECISION SYSTEM                          00000050
C     A * X = B  OR  TRANS(A) * X = B                                   00000060
C     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.                     00000070
C                                                                       00000080
C     ON ENTRY                                                          00000090
C                                                                       00000100
C        A       DOUBLE PRECISION(LDA, N)                               00000110
C                THE OUTPUT FROM DGECO OR DGEFA.                        00000120
C                                                                       00000130
C        LDA     INTEGER                                                00000140
C                THE LEADING DIMENSION OF THE ARRAY  A .                00000150
C                                                                       00000160
C        N       INTEGER                                                00000170
C                THE ORDER OF THE MATRIX  A .                           00000180
C                                                                       00000190
C        IPVT    INTEGER(N)                                             00000200
C                THE PIVOT VECTOR FROM DGECO OR DGEFA.                  00000210
C                                                                       00000220
C        B       DOUBLE PRECISION(N)                                    00000230
C                THE RIGHT HAND SIDE VECTOR.                            00000240
C                                                                       00000250
C        JOB     INTEGER                                                00000260
C                = 0         TO SOLVE  A*X = B ,                        00000270
C                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE            00000280
C                            TRANS(A)  IS THE TRANSPOSE.                00000290
C                                                                       00000300
C     ON RETURN                                                         00000310
C                                                                       00000320
C        B       THE SOLUTION VECTOR  X .                               00000330
C                                                                       00000340
C     ERROR CONDITION                                                   00000350
C                                                                       00000360
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A   00000370
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY  00000380
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER       00000390
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE     00000400
C        CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0           00000410
C        OR DGEFA HAS SET INFO .EQ. 0 .                                 00000420
C                                                                       00000430
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX                 00000440
C     WITH  P  COLUMNS                                                  00000450
C           CALL DGECO(A,LDA,N,IPVT,RCOND,Z)                            00000460
C           IF (RCOND IS TOO SMALL) GO TO ...                           00000470
C           DO 10 J = 1, P                                              00000480
C              CALL DGESL(A,LDA,N,IPVT,C(1,J),0)                        00000490
C        10 CONTINUE                                                    00000500
C                                                                       00000510
C     LINPACK. THIS VERSION DATED 08/14/78 .                            00000520
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.      00000530
C                                                                       00000540
C     SUBROUTINES AND FUNCTIONS                                         00000550
C                                                                       00000560
C     BLAS DAXPY,DDOT                                                   00000570
C                                                                       00000580
C     INTERNAL VARIABLES                                                00000590
C                                                                       00000600
      DOUBLE PRECISION DDOT,T                                           00000610
      INTEGER K,KB,L,NM1                                                00000620
C                                                                       00000630
      NM1 = N - 1                                                       00000640
      IF (JOB .NE. 0) GO TO 50                                          00000650
C                                                                       00000660
C        JOB = 0 , SOLVE  A * X = B                                     00000670
C        FIRST SOLVE  L*Y = B                                           00000680
C                                                                       00000690
         IF (NM1 .LT. 1) GO TO 30                                       00000700
         DO 20 K = 1, NM1                                               00000710
            L = IPVT(K)                                                 00000720
            T = B(L)                                                    00000730
            IF (L .EQ. K) GO TO 10                                      00000740
               B(L) = B(K)                                              00000750
               B(K) = T                                                 00000760
   10       CONTINUE                                                    00000770
            CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1)                       00000780
   20    CONTINUE                                                       00000790
   30    CONTINUE                                                       00000800
C                                                                       00000810
C        NOW SOLVE  U*X = Y                                             00000820
C                                                                       00000830
         DO 40 KB = 1, N                                                00000840
            K = N + 1 - KB                                              00000850
            B(K) = B(K)/A(K,K)                                          00000860
            T = -B(K)                                                   00000870
            CALL DAXPY(K-1,T,A(1,K),1,B(1),1)                           00000880
   40    CONTINUE                                                       00000890
      GO TO 100                                                         00000900
   50 CONTINUE                                                          00000910
C                                                                       00000920
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B                         00000930
C        FIRST SOLVE  TRANS(U)*Y = B                                    00000940
C                                                                       00000950
         DO 60 K = 1, N                                                 00000960
            T = DDOT(K-1,A(1,K),1,B(1),1)                               00000970
            B(K) = (B(K) - T)/A(K,K)                                    00000980
   60    CONTINUE                                                       00000990
C                                                                       00001000
C        NOW SOLVE TRANS(L)*X = Y                                       00001010
C                                                                       00001020
         IF (NM1 .LT. 1) GO TO 90                                       00001030
         DO 80 KB = 1, NM1                                              00001040
            K = N - KB                                                  00001050
            B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1)                 00001060
            L = IPVT(K)                                                 00001070
            IF (L .EQ. K) GO TO 70                                      00001080
               T = B(L)                                                 00001090
               B(L) = B(K)                                              00001100
               B(K) = T                                                 00001110
   70       CONTINUE                                                    00001120
   80    CONTINUE                                                       00001130
   90    CONTINUE                                                       00001140
  100 CONTINUE                                                          00001150
      RETURN                                                            00001160
      END                                                               00001170