cc Copyright (C) 2009-2012: Leslie Greengard, Travis Askham, and Zydrunas Gimbutas
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a modified FreeBSD license
cc (see licenses folder in home directory).
c
c
c      This file contains some basic subroutines for
c      forming and evaluating multipole (partial wave) expansions
c      in two dimensions.
c
c-----------------------------------------------------------------------
c
C***********************************************************************
      subroutine l2dformmp_add(ier,rscale,source,charge,ns,center,
     1     nterms,mpole)
      implicit real *8 (a-h,o-z)
C***********************************************************************
c
c     This subroutine constructs a multipole expansion about CENTER due
c     to NS sources located at SOURCES(2,*).
c
c     mpole_0  =  sum charge_j
c                  j
c
c     mpole_n  = -sum charge_j 1/n (z)^n /rscale^n
c                  j
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     rscale          : the scaling factor.
c     source(2,ns)    : coordinates of sources
c     charge(ns)      : source strengths
c     ns              : number of sources
c     center(2)       : expansion center
c     nterms          : order of multipole expansion
c
c     OUTPUT:
c
c     ier       : error return code
c                 ier=0 returned successfully;
c
c     mpole     : coeffs for the multipole-expansion
c
        complex *16 mpole(0:nterms),charge(ns)
        real *8 center(2),source(2,ns),zdiff(2)

        complex *16 zmul,zinv,ztemp1,ztemp2
c
        complex *16 ima,z,z0
        data ima/(0.0d0,1.0d0)/
c
c

        do j=1,ns
c
        zdiff(1)=source(1,j)-center(1)
        zdiff(2)=source(2,j)-center(2)
ccc        call h2cart2polar(zdiff,r,theta)
        z0=dcmplx(zdiff(1),zdiff(2))
c
        mpole(0)=mpole(0)+charge(j)
c
        ztemp1=z0/rscale
        ztemp2=ztemp1
        do n=1,nterms
        mpole(n)=mpole(n)-charge(j)*ztemp1/n
        ztemp1=ztemp1*ztemp2
        enddo

        enddo

        return
        end
c
c
c
      subroutine l2dformmp_dp_add(ier,rscale,source,dipstr,ns,center,
     1     nterms,mpole)
      implicit real *8 (a-h,o-z)
C***********************************************************************
c
c     This subroutine constructs a multipole expansion about CENTER due
c     to NS sources located at SOURCES(2,*).
c
c     mpole_0  =  0
c
c
c     mpole_n  =  sum dipstr_j (z_0)^(n-1)/z^n /rscale^n
c                  j
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     rscale          : the scaling factor.
c     source(2,ns)    : coordinates of sources
c     dipstr(ns)      : source strengths
c     ns              : number of sources
c     center(2)       : expansion center
c     nterms          : order of multipole expansion
c
c     OUTPUT:
c
c     ier       : error return code
c                 ier=0 returned successfully;
c
c     mpole     : coeffs for the multipole-expansion
c
      complex *16 mpole(0:nterms),dipstr(ns)
      real *8 center(2),source(2,ns),zdiff(2)

      complex *16 zmul,zinv,ztemp1,ztemp2
c
      complex *16 ima,z,z0
      data ima/(0.0d0,1.0d0)/
c
c
      do j=1,ns
c
         zdiff(1)=source(1,j)-center(1)
         zdiff(2)=source(2,j)-center(2)
ccc   call h2cart2polar(zdiff,r,theta)
         z0=dcmplx(zdiff(1),zdiff(2))
c
c
         zmul=z0/rscale
         ztemp1=1/rscale
         do n=1,nterms
            mpole(n)=mpole(n)+dipstr(j)*ztemp1
            ztemp1=ztemp1*zmul
         enddo

      enddo

      return
      end
c
c
C***********************************************************************
      subroutine l2dformmp_qp(ier,rscale,source,quadstr,quadvec,
     $     ns,center,nterms,mpole)
      implicit none
C***********************************************************************
c
c     This subroutine constructs a multipole expansion about
c     CENTER due to NS quadrupole sources located at SOURCES(2,*).
c
c     When evaluated at the point p (assumed to be well separated),
c     the multipole expansion approximates the function
c
c     sum quadstr(j)*( quadvec(1,j)* (S_0)_xx (||p-source_j||)
c                    + quadvec(2,j)* (S_0)_xy (||p-source_j||)
c                    + quadvec(3,j)* (S_0)_yy (||p-source_j||))
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     rscale          : the scaling factor.
c     source(2,ns)    : coordinates of sources
c     quadstr(ns)     : quadrupole strengths
c     quadvec(3,ns)   : quadrupole ``orientation''
c                     quadvec(1,i) - (S_0)_xx term
c                     quadvec(2,i) - (S_0)_xy term
c                     quadvec(3,i) - (S_0)_yy term
c     ns              : number of sources
c     center(2)       : expansion center
c     nterms          : order of multipole expansion
c
c     OUTPUT:
c
c     ier       : error return code
c     ier=0 returned successfully;
c
c     mpole     : coeffs for the multipole expansion
c

c     global variables
      complex *16 quadstr(*),mpole(0:nterms)
      integer ns, nterms, ier
      real *8 center(2),source(2,*),quadvec(3,*), rscale
c     local variables
      complex *16 z0,ima, zmul,zinv,ztemp1,ztemp2,hexp(0:2)
      real *8 zdiff(2), rinv2
      integer iii, i, j, nmax, m, l
      complex *16, allocatable :: z0pow(:)
      real *8, allocatable :: carray(:,:)
      integer, allocatable :: iscale(:)
c
      data ima/(0.0d0,1.0d0)/
c
      ier = 0

      nmax = max(nterms,2)
      allocate( carray(0:nmax,0:2) )
      allocate( z0pow(0:nmax) )

      do l = 0,nmax
         carray(l,0) = 1.0d0
      enddo
      do m=1,2
         carray(m,m) = 1.0d0
         do l=m+1,nmax
            carray(l,m)=carray(l-1,m)+carray(l-1,m-1)
         enddo
      enddo

      do i = 0,nterms
         mpole(i) = 0
      enddo

      rinv2 = 1.0d0/(rscale**2)

      do iii = 1,ns

c     set-up quadrupole as if centered at source

         zdiff(1) = center(1)-source(1,iii)
         zdiff(2) = center(2)-source(2,iii)
         z0 = dcmplx(-zdiff(1),-zdiff(2))

         hexp(0) = 0.0d0
         hexp(1) = 0.0d0
         hexp(2) = quadstr(iii)*
     1        (quadvec(1,iii)+ima*quadvec(2,iii)-quadvec(3,iii))*rinv2

c     shift expansion to center

         ztemp1=z0/rscale
         ztemp2=ztemp1
         z0pow(0)=1
         do i=1,nmax
            z0pow(i)=ztemp1
            ztemp1=ztemp1*ztemp2
         enddo
c
         do i = 1,nterms
            do j = 2,min(i,2)
               mpole(i) = mpole(i) +
     1              hexp(j)*z0pow(i)/z0pow(j)*carray(i-1,j-1)
            enddo
         enddo

      enddo

      return
      end
c
c
c
c
C***********************************************************************
      subroutine l2dformmp_qp_add(ier,rscale,source,quadstr,
     1     quadvec,ns,center,nterms,mpole)
      implicit none
C***********************************************************************
c
c     This subroutine constructs a multipole expansion about
c     CENTER due to NS quadrupole sources located at SOURCES(2,*).
c
c     When evaluated at the point p (assumed to be well separated),
c     the multipole expansion approximates the function
c
c     sum quadstr(j)*( quadvec(1,j)* (S_0)_xx (||p-source_j||)
c                    + quadvec(2,j)* (S_0)_xy (||p-source_j||)
c                    + quadvec(3,j)* (S_0)_yy (||p-source_j||))
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     rscale          : the scaling factor.
c     source(2,ns)    : coordinates of sources
c     quadstr(ns)     : quadrupole strengths
c     quadvec(3,ns)   : quadrupole ``orientation''
c                     quadvec(1,i) - (S_0)_xx term
c                     quadvec(2,i) - (S_0)_xy term
c                     quadvec(3,i) - (S_0)_yy term
c     ns              : number of sources
c     center(2)       : expansion center
c     nterms          : order of multipole expansion
c
c     OUTPUT:
c
c     ier       : error return code
c     ier=0 returned successfully;
c
c     mpole     : coeffs for the multipole expansion
c

c     global variables
      complex *16 quadstr(*),mpole(0:nterms)
      integer ns, nterms, ier
      real *8 center(2),source(2,*),quadvec(3,*), rscale
c     local variables
      complex *16 z0,ima, zmul,zinv,ztemp1,ztemp2,hexp(0:2)
      real *8 zdiff(2), rinv2
      integer iii, i, j, nmax, m, l
      complex *16, allocatable :: z0pow(:)
      real *8, allocatable :: carray(:,:)
      integer, allocatable :: iscale(:)
c
      data ima/(0.0d0,1.0d0)/
c
      ier = 0

      nmax = max(nterms,2)
      allocate( carray(0:nmax,0:2) )
      allocate( z0pow(0:nmax) )

      do l = 0,nmax
         carray(l,0) = 1.0d0
      enddo
      do m=1,2
         carray(m,m) = 1.0d0
         do l=m+1,nmax
            carray(l,m)=carray(l-1,m)+carray(l-1,m-1)
         enddo
      enddo

      rinv2 = 1.0d0/(rscale**2)

      do iii = 1,ns

c     set-up quadrupole as if centered at source

         zdiff(1) = center(1)-source(1,iii)
         zdiff(2) = center(2)-source(2,iii)
         z0 = dcmplx(-zdiff(1),-zdiff(2))

         hexp(0) = 0.0d0
         hexp(1) = 0.0d0
         hexp(2) = quadstr(iii)*
     1        (quadvec(1,iii)+ima*quadvec(2,iii)-quadvec(3,iii))*rinv2

c     shift expansion to center

         ztemp1=z0/rscale
         ztemp2=ztemp1
         z0pow(0)=1
         do i=1,nmax
            z0pow(i)=ztemp1
            ztemp1=ztemp1*ztemp2
         enddo
c
         do i = 1,nterms
            do j = 2,min(i,2)
               mpole(i) = mpole(i) +
     1              hexp(j)*z0pow(i)/z0pow(j)*carray(i-1,j-1)
            enddo
         enddo

      enddo

      return
      end
c
c
C***********************************************************************
      subroutine l2dformta_qp(ier,rscale,source,quadstr,quadvec,
     $     ns,center,nterms,loc)
      implicit none
C***********************************************************************
c
c     This subroutine constructs a multipole expansion about
c     CENTER due to NS quadrupole sources located at SOURCES(2,*).
c
c     When evaluated at the point p (assumed to be well separated),
c     the multipole expansion approximates the function
c
c     sum quadstr(j)*( quadvec(1,j)* (S_0)_xx (||p-source_j||)
c                    + quadvec(2,j)* (S_0)_xy (||p-source_j||)
c                    + quadvec(3,j)* (S_0)_yy (||p-source_j||))
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     rscale          : the scaling factor.
c     source(2,ns)    : coordinates of sources
c     quadstr(ns)     : quadrupole strengths
c     quadvec(3,ns)   : quadrupole ``orientation''
c                     quadvec(1,i) - (S_0)_xx term
c                     quadvec(2,i) - (S_0)_xy term
c                     quadvec(3,i) - (S_0)_yy term
c     ns              : number of sources
c     center(2)       : expansion center
c     nterms          : order of multipole expansion
c
c     OUTPUT:
c
c     ier       : error return code
c     ier=0 returned successfully;
c
c     mpole     : coeffs for the multipole expansion
c

c     global variables
      complex *16 quadstr(*),loc(0:nterms)
      integer ns, nterms, ier
      real *8 center(2),source(2,*),quadvec(3,*), rscale
c     local variables
      complex *16 z0,ima, zmul,zinv,ztemp1,ztemp2,hexp(0:2)
      real *8 zdiff(2), rinv2
      integer iii, i, j, nmax, m, l
      complex *16, allocatable :: z0pow(:), z0powm(:)
      real *8, allocatable :: carray(:,:)
      integer, allocatable :: iscale(:)
c
      data ima/(0.0d0,1.0d0)/
c
      ier = 0

      nmax = nterms+2
      allocate( carray(0:nmax,0:2) )
      allocate( z0pow(0:nmax) )
      allocate( z0powm(0:nmax) )

      do l = 0,nmax
         carray(l,0) = 1.0d0
      enddo
      do m=1,2
         carray(m,m) = 1.0d0
         do l=m+1,nmax
            carray(l,m)=carray(l-1,m)+carray(l-1,m-1)
         enddo
      enddo

      do i = 0,nterms
         loc(i) = 0
      enddo

      rinv2 = 1.0d0/(rscale**2)

      do iii = 1,ns

c     set-up quadrupole as if centered at source

         zdiff(1) = center(1)-source(1,iii)
         zdiff(2) = center(2)-source(2,iii)
         z0 = dcmplx(-zdiff(1),-zdiff(2))

         hexp(0) = 0.0d0
         hexp(1) = 0.0d0
         hexp(2) = quadstr(iii)*
     1        (quadvec(1,iii)+ima*quadvec(2,iii)-quadvec(3,iii))*rinv2

c     shift expansion to center

         ztemp1=rscale/z0
         ztemp2=ztemp1
         z0pow(0)=1
         do i=1,nmax
            z0pow(i)=ztemp1
            ztemp1=ztemp1*ztemp2
         enddo

         ztemp1=-rscale/z0
         ztemp2=ztemp1
         z0powm(0)=1
         do i=1,2
            z0powm(i)=ztemp1
            ztemp1=ztemp1*ztemp2
         enddo
c
         loc(0) = loc(0) + hexp(2)*z0powm(2)

         do i = 1,nterms
            loc(i) = loc(i) + hexp(2)*z0powm(2)*z0pow(i)*
     1           carray(i+2-1,2-1)
         enddo

      enddo

      return
      end
c
c
c
C***********************************************************************
      subroutine l2dformta_qp_add(ier,rscale,source,quadstr,
     1     quadvec,ns,center,nterms,loc)
      implicit none
C***********************************************************************
c
c     This subroutine constructs a multipole expansion about
c     CENTER due to NS quadrupole sources located at SOURCES(2,*).
c
c     When evaluated at the point p (assumed to be well separated),
c     the multipole expansion approximates the function
c
c     sum quadstr(j)*( quadvec(1,j)* (S_0)_xx (||p-source_j||)
c                    + quadvec(2,j)* (S_0)_xy (||p-source_j||)
c                    + quadvec(3,j)* (S_0)_yy (||p-source_j||))
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     rscale          : the scaling factor.
c     source(2,ns)    : coordinates of sources
c     quadstr(ns)     : quadrupole strengths
c     quadvec(3,ns)   : quadrupole ``orientation''
c                     quadvec(1,i) - (S_0)_xx term
c                     quadvec(2,i) - (S_0)_xy term
c                     quadvec(3,i) - (S_0)_yy term
c     ns              : number of sources
c     center(2)       : expansion center
c     nterms          : order of multipole expansion
c
c     OUTPUT:
c
c     ier       : error return code
c     ier=0 returned successfully;
c
c     mpole     : coeffs for the multipole expansion
c

c     global variables
      complex *16 quadstr(*),loc(0:nterms)
      integer ns, nterms, ier
      real *8 center(2),source(2,*),quadvec(3,*), rscale
c     local variables
      complex *16 z0,ima, zmul,zinv,ztemp1,ztemp2,hexp(0:2)
      real *8 zdiff(2), rinv2
      integer iii, i, j, nmax, m, l
      complex *16, allocatable :: z0pow(:), z0powm(:)
      real *8, allocatable :: carray(:,:)
      integer, allocatable :: iscale(:)
c
      data ima/(0.0d0,1.0d0)/
c
      ier = 0

      nmax = nterms+2
      allocate( carray(0:nmax,0:2) )
      allocate( z0pow(0:nmax) )
      allocate( z0powm(0:nmax) )

      do l = 0,nmax
         carray(l,0) = 1.0d0
      enddo
      do m=1,2
         carray(m,m) = 1.0d0
         do l=m+1,nmax
            carray(l,m)=carray(l-1,m)+carray(l-1,m-1)
         enddo
      enddo

      rinv2 = 1.0d0/(rscale**2)

      do iii = 1,ns

c     set-up quadrupole as if centered at source

         zdiff(1) = center(1)-source(1,iii)
         zdiff(2) = center(2)-source(2,iii)
         z0 = dcmplx(-zdiff(1),-zdiff(2))

         hexp(0) = 0.0d0
         hexp(1) = 0.0d0
         hexp(2) = quadstr(iii)*
     1        (quadvec(1,iii)+ima*quadvec(2,iii)-quadvec(3,iii))*rinv2

c     shift expansion to center

         ztemp1=rscale/z0
         ztemp2=ztemp1
         z0pow(0)=1
         do i=1,nmax
            z0pow(i)=ztemp1
            ztemp1=ztemp1*ztemp2
         enddo

         ztemp1=-rscale/z0
         ztemp2=ztemp1
         z0powm(0)=1
         do i=1,2
            z0powm(i)=ztemp1
            ztemp1=ztemp1*ztemp2
         enddo
c
         loc(0) = loc(0) + hexp(2)*z0powm(2)

         do i = 1,nterms
            loc(i) = loc(i) + hexp(2)*z0powm(2)*z0pow(i)*
     1           carray(i+2-1,2-1)
         enddo

      enddo

      return
      end
c


module forcec
    use parameters
    use cudafor

    implicit none

    ! Intrinsic pseudohs potential arguments that need to be computed
    ! only once
    real, parameter :: dlr = 50.0
    real, parameter :: dT = 1.4737
    real, parameter :: dla = 49.0
    real, parameter :: a2 = (dlr/(dlr-dla))*(dlr/dla)**(dla/(dlr-dla))
    real, parameter :: rchs = (dlr/dla)**(1.0/(dlr-dla))

    public force

contains

    attributes(global) subroutine force(x, y, z, fx, fy, fz, ener, zfac)
        real, intent(in) :: x(:), y(:), z(:)
        real, intent(inout) :: fx(:), fy(:), fz(:)
        real, intent(inout) :: ener(:), zfac(:)

        ! Local variables
        integer :: i, j, s, idx
        real :: xij, yij, zij, uij, fij
        real :: potential
        real :: fxij, fyij, fzij, rij
        real :: fxx, fyy, fzz, virial, vtmp, rinv

        ! Inicialización de variables de CUDA
        idx = blockDim%x * (blockIdx%x - 1) + threadIdx%x
        s = blockDim%x * gridDim%x

        do i = idx, np, s
            potential = 0.0
            virial = 0.0
            fxx = 0.0
            fyy = 0.0
            fzz = 0.0

            do j = 1, np
                if ( i == j ) cycle

                xij = x(i) - x(j)
                yij = y(i) - y(j)
                zij = z(i) - z(j)

                xij = xij - boxl*nint(xij / boxl)
                yij = yij - boxl*nint(yij / boxl)
                zij = zij - boxl*nint(zij / boxl)

                rij = sqrt(xij*xij + yij*yij + zij*zij)

                if ( (rij > 0.1) .and. (rij < rc) ) then
                    rinv = 1.0 / rij
                    if ( rij < rchs ) then
                        uij = a2 * ((rinv**dlr)-(rinv**dla))
                        uij = uij + 1.0
                        fij = (dlr*(rinv**(dlr+1.0))) - (dla * (rinv**dlr))
                        fij = fij * a2
                    else
                        uij = 0.0
                        fij = 0.0
                    end if

                    fxij = fij * xij * rinv
                    fyij = fij * yij * rinv
                    fzij = fij * zij * rinv

                    ! Accumulate energy and virial
                    potential = potential + uij
                    vtmp = (fxij * xij) + (fyij * yij) + (fzij * zij)
                    virial = virial + vtmp

                    fxx = fxx + fxij
                    fyy = fyy + fyij
                    fzz = fzz + fzij
                end if
            end do

            fx(i) = fxx
            fy(i) = fyy
            fz(i) = fzz

            ener(i) = potential / 2.0
            zfac(i) = virial / 2.0
        end do
    end subroutine force
end module


module model_ideal_gas_regularized
#include <messenger.h>
    use mod_kinds,          only: rk
    use mod_constants,      only: HALF, ONE, ZERO
    use mod_fluid,          only: Rgas, gam
    use type_model,         only: model_t
    use type_chidg_worker,  only: chidg_worker_t
    use DNAD_D
    implicit none

    !> Regularized ideal gas model that enforces positivity of pressure and temperature.
    !!
    !!
    !! @author  Eric M. Wolf
    !! @date    08/05/2019
    !!
    !--------------------------------------------------------------------------------
    type, extends(model_t)  :: ideal_gas_regularized_t

        real(rk)    :: window_size_pressure      = 1.0e-2_rk
        real(rk)    :: minimum_value_pressure    = 1.0e-11_rk
        logical     :: regularize_pressure       = .true.

    contains

        procedure   :: init
        procedure   :: compute

    end type ideal_gas_regularized_t
    !***************************************************************************************

contains

    !>
    !!
    !!
    !! @author  Eric M. Wolf
    !! @date    08/05/2019
    !!
    !--------------------------------------------------------------------------------
    subroutine init(self)
        class(ideal_gas_regularized_t), intent(inout)   :: self

        integer             :: unit, msg
        logical             :: file_exists
        real(rk)    :: window_size_pressure, minimum_value_pressure
        logical     :: regularize_pressure

        namelist /regularize_ideal_gas/ window_size_pressure, minimum_value_pressure, regularize_pressure

        call self%set_name('Regularized Ideal Gas')
        call self%set_dependency('f(Q-)')

        call self%add_model_field('Pressure')
        call self%add_model_field('Temperature')

        inquire(file='regularize_ideal_gas.nml', exist=file_exists)
        if (file_exists) then
            open(newunit=unit,form='formatted',file='regularize_ideal_gas.nml')
            read(unit,nml=regularize_ideal_gas,iostat=msg)
            if (msg == 0) self%window_size_pressure = window_size_pressure
            if (msg == 0) self%minimum_value_pressure = minimum_value_pressure
            if (msg == 0) self%regularize_pressure = regularize_pressure
            close(unit)
        end if

    end subroutine init
    !***************************************************************************************

    !>
    !!
    !!
    !! @author  Eric M. Wolf
    !! @date    08/05/2019
    !!
    !--------------------------------------------------------------------------------
    subroutine compute(self,worker)
        class(ideal_gas_regularized_t),     intent(in)      :: self
        type(chidg_worker_t),   intent(inout)   :: worker

        type(AD_D), dimension(:),   allocatable :: &
            density, mom1, mom2, mom3, energy, pressure, temperature

        !
        ! Interpolate solution to quadrature nodes
        !
        density = worker%get_field('Density',    'value')
        mom1    = worker%get_field('Momentum-1', 'value')
        mom2    = worker%get_field('Momentum-2', 'value')
        mom3    = worker%get_field('Momentum-3', 'value')
        energy  = worker%get_field('Energy',     'value')

        !
        ! Account for cylindrical. Get tangential momentum from angular momentum.
        !
        if (worker%coordinate_system() == 'Cylindrical') then
            mom2 = mom2 / worker%coordinate('1')
        end if

        pressure = (gam-ONE)*(energy - HALF*( (mom1*mom1) + (mom2*mom2) + (mom3*mom3) )/density)
        if (self%regularize_pressure) pressure = pressure*sin_ramp(pressure, ZERO, self%window_size_pressure) + self%minimum_value_pressure
        temperature = pressure/(density*Rgas)

        call worker%store_model_field('Pressure',    'value', pressure)
        call worker%store_model_field('Temperature', 'value', temperature)

    end subroutine compute
    !***************************************************************************************

end module model_ideal_gas_regularized


      subroutine qlbox5(Y,musq,Ires)
      implicit none
C     $I_4^{D=4-2 \epsilon}(0,\pd^2,\pt^2,\pq^2;s_{12},s_{23};0,0,0,0)$}

c----%\cite{Bern:1993kr}
c----\bibitem{Bern:1993kr}
c----  Z.~Bern, L.~J.~Dixon and D.~A.~Kosower,
c----  %``Dimensionally regulated pentagon integrals,''
c----  Nucl.\ Phys.\ B {\bf 412}, 751 (1994)
c----  [arXiv:hep-ph/9306240].
c----  %%CITATION = HEP-PH 9306240;%%
c----  Eqs. (I.15)
C-----or from /hep-ph/0508308 v3 Eqn (A27)
C-----v3 corrects previous versions.
c                         [                   s12     p4sq ]
c                         [   0       0     - ---   - ---- ]
c                         [                    2       2   ]
c                         [                                ]
c                         [                   p2sq    s23  ]
c                         [   0       0     - ----  - ---  ]
c                         [                    2       2   ]
c                    y5 = [                                ]
c                         [   s12     p2sq            p3sq ]
c                         [ - ---   - ----    0     - ---- ]
c                         [    2       2               2   ]
c                         [                                ]
c                         [   p4sq    s23     p3sq         ]
c                         [ - ----  - ---   - ----    0    ]
c                         [    2       2       2           ]
      include 'qlconstants.f'
      integer iep
      double precision r,musq,Y(4,4),si,ta,mp2sq,mp3sq,mp4sq
      double complex Ires(-2:0),qllnrat,qlL0,qlL1,fac,Li2(6),
     . qlLi2omrat,qlLi2omx2
      logical landau
      si=2d0*Y(1,3)
      ta=2d0*Y(2,4)
      mp2sq=2d0*Y(2,3)
      mp3sq=2d0*Y(3,4)
      mp4sq=2d0*Y(1,4)

      r=1d0-mp2sq*mp4sq/(si*ta)

C     Use expansion only in cases where signs (si,ta,mp2sq,mp4sq) are not
C     ++-- or --++
      landau=((sign(1d0,si) .eq. sign(1d0,ta))
     . .and. (sign(1d0,mp2sq) .eq. sign(1d0,mp4sq))
     . .and. (sign(1d0,si) .ne. sign(1d0,mp2sq)))
      if ((abs(r) .lt. 1d-6) .and. (landau .eqv. .false.)) then
C---expanded case
      Ires(-2)=czip
      Ires(-1)=-dcmplx((1d0+0.5d0*r)/(si*ta))
      Ires(0)=Ires(-1)*(qllnrat(musq,si)+qllnrat(mp3sq,ta)-dcmplx(2d0)
     . -dcmplx(1d0+mp4sq/ta)*qlL0(mp4sq,ta))
     . +dcmplx(r/(si*ta))*(qlL1(mp4sq,ta)-qlL0(mp4sq,ta)-cone)
      else
C---General case
      fac=dcmplx(1d0/(si*ta-mp2sq*mp4sq))
      Ires(-2)=czip
      Ires(-1)=qllnrat(mp2sq,ta)+qllnrat(mp4sq,si)

      Li2(1)=qlLi2omrat(mp2sq,si)
      Li2(2)=qlLi2omrat(mp4sq,ta)
      Li2(3)=qlLi2omx2(mp2sq,mp4sq,si,ta)
      Ires(0)=
     . -chalf*(qllnrat(ta,mp2sq)**2+qllnrat(si,mp4sq)**2)
     .  +(qllnrat(mp3sq,ta)+qllnrat(musq,ta))*qllnrat(mp2sq,ta)
     .  +(qllnrat(mp3sq,si)+qllnrat(musq,si))*qllnrat(mp4sq,si)
     . -ctwo*(Li2(1)+Li2(2)-Li2(3))-qllnrat(si,ta)**2
      do iep=-1,0
      Ires(iep)=fac*Ires(iep)
      enddo

      endif

      return
      end


c Given Q(z) longitudinal development of excess charge
c computes vector potential at observer position (Fresnel)
c in time domain.
c
c Calculates x,y,z components of vector potential
c Accounts for polarization dependence on shower depth
c
c 2D-model i.e. the lateral distribution is accounted for
c by a parameterisation of the vector potential.
c
c S.I. units
c Based on "Practical and accurate calculations of Askaryan radiation" PRD in press (2012).
c J. Alvarez-Muniz, A. Romero-Wolf, E. Zas
c
c Uses ZHAireS input
      program model
      implicit double precision (a-h,o-z)
      parameter(pi=3.1415926)
      parameter(c=2.99792458e8)    ! speed of light m^s-1
      parameter(xmu=12.566370e-7)  ! magnetic permeability N A^-2
      parameter(e=1.602177e-19)    ! electron charge C

c Separated files for electron and positron longitudinal profiles
      character*80 fileine,fileinp

      common/filename/fileine,fileinp

      common/antennae/xa(100),ya(100),za(100),rhoa(100),Ra(100)
      common/antenna_index/iant

      common/depthmax/zend
      common/ice/xn,x0,rho
      common/cherenkov/cher
      common/const/factor
      common/time/tobs_sec
      common/charge/xntot
      common/shower/E_TeV
      common/units/s_to_ns,xns_to_s

c Vegas routine commons
      CHARACTER NAMEOU*12
      COMMON/BVEG1/NCALL,ITMX,NPRN,NDEV,XL(18),XU(18),ACC
      COMMON/NAME/NAMEOU
      external vegas,xintegrand_x,xintegrand_y,xintegrand_z

      ncall=10000
      itmx=30

c Vegasd
      nameou='vegas.out'

c Output file containing waveforms of vector potential vs observer's time
      open (unit=22,status='unknown',file='output.dat')

      write(*,*) 'File containing long shower profile (electrons)'
      read(*,*) fileine
      write(*,*) fileine
      write(*,*) 'File containing long shower profile (electrons)'
      read(*,*) fileinp
      write(*,*) fileinp

      write(*,*) 'Shower energy [TeV]'
      read(*,*) E_TeV
      write(*,*) E_TeV

c ICE
      xn=1.78   ! refractive index
      x0=36.08  ! radiation length g cm^-2
      rho=0.924 ! density g cm^-3

      write(*,*) 'Number of antennas'
      read(*,*) nant
      write(*,*) nant

c Position of shower maximum in g cm^-2 if antenna
c needs to be referred to zmax
      zmax=0.
      zmax=zmax/rho/100.               ! m

      write(*,*) 'Position of antenna i'
      write(*,*) '(x,y,z) in m'
      write(*,*) 'Primary injected at (0,0,0)'
      do ia=1,nant
        read(*,*) xa(ia),ya(ia),za(ia)
        write(*,*) xa(ia),ya(ia),za(ia)
c Convert antenna positions from g cm^-2 to meters
c        xa(ia)=xa(ia)/rho/100.               ! m
c        ya(ia)=ya(ia)/rho/100.               ! m
c        za(ia)=za(ia)/rho/100.               ! m
        rhoa(ia)=sqrt(xa(ia)*xa(ia)+ya(ia)*ya(ia))  ! m
        Ra(ia)=sqrt(rhoa(ia)*rhoa(ia)+
     #              (za(ia)-zmax)*(za(ia)-zmax))  ! m
c        write(55,*) ia-1,Ra(ia)
      end do

c First call to interpolation to initialize zend and xntot
      dum=xnep(10.)
      write(*,*) 'Integral[N(z)dz] ',xntot

c Limits in integration
c Vegasd
c Integration limits in shower depth z'
      xl(1)=0.
      xu(1)=zend

c Assumes shower travels at speed of light
      beta=1.
      cher=acos(1./xn)

c Factor in Eq.(22) PRD paper
      factor=-xmu/(4.*pi)

      s_to_ns=1.e9
      xns_to_s=1.e-9

      write(*,*) 'Time resolution [ns]'
      read(*,*) dtbin
      write(*,*) dtbin
      write(*,*) 'Time min. and max. [ns]'
      read(*,*) tmin,tmax
      itmax=int((tmax-tmin)/dtbin)

c Loop in observer's time
c Compute vector potential at each antenna position
c Electric field can be computed by a simple derivative w.r.t. time.
      do iant=1,nant

        write(*,*)
     #'# Time [ns] Vector potential [Vs] antenna position (x,y,z) m',
     #xa(iant),ya(iant),za(iant)
        write(22,*)
     #'# Time [ns] Vector potential [Vs] antenna position (x,y,z) m',
     #xa(iant),ya(iant),za(iant)

        vp_x=0.
        vp_y=0.
        vp_z=0.

c Calculate x,y,z components of vector potential
        do it=1,itmax
          tobs_plot=tmin+dtbin*(it-1)+dtbin/2.
          tobs=tobs_plot+(xn*Ra(iant)/c)*s_to_ns
          tobs_sec=tobs*xns_to_s

c x-component of Eq.(22) PRD paper
          if(xa(iant).eq.0.) then
            vp_x=0.
          else
            call vegas(1,xintegrand_x,vp_x,sal_x,schi_x)
          end if

c y-component of Eq.(22) PRD paper
          if(ya(iant).eq.0.) then
            vp_y=0.
          else
            call vegas(1,xintegrand_y,vp_y,sal_y,schi_y)
          end if

c z-component of Eq.(22) PRD paper
          call vegas(1,xintegrand_z,vp_z,sal_z,schi_z)

          vp_x=factor*vp_x
          vp_y=factor*vp_y
          vp_z=factor*vp_z

          write(*,*) tobs,vp_x,vp_y,vp_z
c          write(*,*) tobs_plot,vp_x,vp_y,vp_z
          write(22,*) tobs,vp_x,vp_y,vp_z
c          write(22,*) tobs_plot,vp_x,vp_y,vp_z
        end do
        write(*,*)
        write(22,*)

      end do

      end

c ----------------------------------------------------------------------------
c x-component of integral in Eq.(22) PRD paper
      function xintegrand_x(qww)
      implicit double precision (a-h,o-z)
      save
      common/x/x(1),xd(17)
      common/antennae/xa(100),ya(100),za(100),rhoa(100),Ra(100)
      common/antenna_index/iant
      common/cherenkov/cher
      common/time/tobs_sec
      common/dist/R

c Depth in m
      z=x(1)  ! m

c Argument of F_p function. Eq.(22) PRD.
      arg=argument(z,tobs_sec)

c Distance from position in shower depth z' to each antenna.
c Denominator in Eq. (22) PRD paper
      R = sqrt(rhoa(iant)*rhoa(iant)+
     #        (za(iant)-z)*(za(iant)-z))  ! m

c x-component of v_perp
c Account for polarization dependence on shower position
c Eq. (22) PRD paper
      u_x=xa(iant)/R
      u_z=(za(iant)-z)/R
      beta_z=1.
      vperp_x=u_x*u_z*beta_z

      xintegrand_x=-vperp_x*xnep(z)*F_p(arg)/R

      return
      end

c ----------------------------------------------------------------------------
c y-component of integral in Eq.(22) PRD paper
      function xintegrand_y(qww)
      implicit double precision (a-h,o-z)
      save
      common/x/x(1),xd(17)
      common/antennae/xa(100),ya(100),za(100),rhoa(100),Ra(100)
      common/antenna_index/iant
      common/cherenkov/cher
      common/time/tobs_sec
      common/dist/R

c Depth in m
      z=x(1)  ! m

c Argument of F_p function. Eq.(22) PRD.
      arg=argument(z,tobs_sec)

c Distance from position in shower depth z' to each antenna.
c Denominator in Eq. (22) PRD paper
      R = sqrt(rhoa(iant)*rhoa(iant)+
     #        (za(iant)-z)*(za(iant)-z))  ! m

c y-component of v_perp
c Account for polarization dependence on shower position
c Eq.(22) PRD
      u_y=ya(iant)/R
      u_z=(za(iant)-z)/R
      beta_z=1.
      vperp_y=u_y*u_z*beta_z

      xintegrand_y=-vperp_y*xnep(z)*F_p(arg)/R

      return
      end

c ----------------------------------------------------------------------------
c z-component of integral in Eq.(22) PRD paper
      function xintegrand_z(qww)
      implicit double precision (a-h,o-z)
      save
c Common for vegas routine
      common/x/x(1),xd(17)

      common/antennae/xa(100),ya(100),za(100),rhoa(100),Ra(100)
      common/antenna_index/iant
      common/cherenkov/cher
      common/time/tobs_sec
      common/dist/R

c Depth in m
c Specify first and only variable to be integrated by vegas
      z=x(1)  ! m

c Argument of F_p function. Eq.(22) PRD.
      arg=argument(z,tobs_sec)

c Distance from position in shower depth z' to each antenna
c Denominator in Eq. (22) PRD paper
      R = sqrt(rhoa(iant)*rhoa(iant)+
     #        (za(iant)-z)*(za(iant)-z))  ! m

c z-component of v_perp
c Eq.(22) PRD
      u_x=xa(iant)/R
      u_y=ya(iant)/R
      beta_z=1.
      vperp_z=-(u_x*u_x+u_y*u_y)*beta_z

      xintegrand_z=-vperp_z*xnep(z)*F_p(arg)/R

      return
      end

c -----------------------------------------------------------------------------
c Argument of F_p Eq.(22) PRD paper
c -----------------------------------------------------------------------------
      function argument(z,t)
      implicit double precision (a-h,o-z)
      save
      parameter(c=2.99792458e8)    ! speed of light m^s-1
      common/antennae/xa(100),ya(100),za(100),rhoa(100),Ra(100)
      common/antenna_index/iant
      common/cherenkov/cher
      common/ice/xn,x0,rho
      common/dist/R

c Assumes shower travels at speed of light
      beta=1.
      argument=z-(beta*c*t-xn*R)  ! m

      return
      end

c -----------------------------------------------------------------------------
c Function F_p Eq.(15) PRD paper.
c -----------------------------------------------------------------------------
      function F_p(arg)
      implicit double precision (a-h,o-z)
      save
      parameter(pi=3.1415926)
      parameter(c=2.99792458e8)    ! speed of light m^s-1
      parameter(xmu=12.566370e-7)  ! magnetic permeability N A^-2
      parameter(e=1.602177e-19)    ! electron charge C

      common/cherenkov/cher
      common/charge/xntot
      common/shower/E_TeV
      common/units/s_to_ns,xns_to_s
      common/ice/xn,x0,rho

c Factor accompanying the F_p in Eq.(15) in PRD paper
      fc=4.*pi/(xmu*sin(cher))

c Converts arg into time
      beta=1.
c Note that Acher peaks at tt=0 which corresponds to the observer time.
c The shift from tobs to tt=0 is done when defining argument
      tt=(-arg/(c*beta))*s_to_ns ! Parameterisation of A_Cherenkov with t in ns

c Parameterisation of vector potential at Cherenkov angle
c Eq.(16) PRD paper.
      Af=-4.5e-14  ! V s
      if (tt.ge.0.) then
       Acher=Af*E_TeV*(exp(-abs(tt)/0.057)+(1.+2.87*abs(tt))**(-3))
      else
       Acher=Af*E_TeV*(exp(-abs(tt)/0.03)+(1.+3.05*abs(tt))**(-3.5))
      end if

c Cut fit above +/-5 ns
c      if (abs(tt).gt.5.) Acher=1.e-30

c Obtain "shape" of Lambda-function from vp at Cherenkov angle
c xntot = LQ_tot in PRD paper
      F_p=Acher*fc/xntot

      return
      end

C-----------------------------------------------------------
c Simple interpolation in depth of longitudinal profile of excess charge.
C-----------------------------------------------------------
      function xnep(z)
      implicit double precision (a-h,o-z)
      save
      common/depthmax/zend
      dimension xx(1000),yexcess(1000),ylog(1000)
      dimension xxp(1000),ye(1000),yp(1000)
      character*80 fileine,fileinp
      logical firstgo
      data firstgo / .true. /
      common/filename/fileine,fileinp
      common/ice/xn,x0,rho
      common/charge/xntot
      nnint=1

      if (firstgo .eqv. .true.) then
      xntot=0.
c Read longitudinal profile
      npoints=0
      open (unit=11,status='old',file=fileine)
      open (unit=12,status='old',file=fileinp)

      open (unit=14,status='unknown',file='long.dat')

      do idum=1,34
        read(11,*)
        read(12,*)
      end do

      do j=1,1000
        read(11,*,err=11,end=11) dum1,xx(j),ye(j)
        npoints=npoints+1
      end do
11    close(unit=11)

      do j=1,1000
        read(12,*,err=12,end=12) dum1,xxp(j),yp(j)
      end do
12    close (unit=12)

      do j=1,npoints
        yexcess(j)=ye(j)-yp(j)
        write(14,*) xx(j),ye(j),yp(j),yexcess(j)
        xx0=1000. ! Showers in ZHAireS start at 1000 g cm^-2
        xx(j)=(xx(j)-xx0)/rho/100.   ! m
        xntot=xntot+yexcess(j)
      end do
      close (unit=14)

      xntot=xntot*(xx(2)-xx(1))   ! m
      npoints=j-1
      firstgo=.false.
      zend=xx(npoints)
      write(*,*) 'Depth max (m) ',zend

c      do j=1,npoints
c        if (yexcess(j).gt.0.) then
c          ylog(j)=log(yexcess(j))
c        else
c          ylog(j)=0.
c        end if
c      end do

      end if

c      xnep=ddivdif(ylog,xx,npoints,z,nnint)
      xnep=ddivdif(yexcess,xx,npoints,z,nnint)

c      xnep=-exp(xnep)    ! Excess negative charge => - sign

      RETURN
      END

C ******************************************************************
C ******************************************************************
C ******************************************************************
C ******************************************************************


!--------------------------------------------------------------------------------
!
! An example to call opacfractal.f90
!
!--------------------------------------------------------------------------------
program call_opacfractal
use omp_lib
implicit none
integer, parameter                      :: dp = selected_real_kind(P=15)
real(kind=dp),parameter                 :: pi = 3.1415926535897932384_dp
real(kind=dp),parameter                 :: k0_bpca=0.3_dp
real(kind=dp),parameter                 :: k0_bcca=1.04_dp
real(kind=dp),parameter                 :: df_bpca=3.0_dp
real(kind=dp),parameter                 :: df_bcca=1.9_dp
integer                                 :: iqsca,iqcor,iqgeo,iquiet,i,j,nang,unit
complex(kind=dp)                        :: ref
real(kind=dp)                           :: lmd,R0,Rv,PN,df_min,df_max
real(kind=dp)                           :: Cext,Csca,Cabsp,Gsca,dphi,rhod,mass
real(kind=dp)                           :: wlmin,wlmax,dwl
real(kind=dp),allocatable,dimension(:,:):: Smat
integer                                 :: iwl
integer,parameter                       :: nwl=100
integer,parameter                       :: ndf=7
real(kind=dp),dimension(1:ndf)          :: DF,k0
real(kind=dp),dimension(1:nwl)          :: wl,re,im
real(kind=dp),dimension(1:ndf,0:5,1:nwl):: Q

!--------------------------------------------------------------------------------
!       SET INPUT PARAMETERS
!--------------------------------------------------------------------------------
iqsca  = 3                           ! A method to solve light scattering
iqcor  = 1                           ! correlation function
iqgeo  = 3                           ! geometric cross section
iquiet = 1                           ! stdout
R0     = 1.e-1_dp                    ! Monomer radius                    [um]
Rv     = 1.e1_dp                     ! Volume equivalent radius (micron) [um]
rhod   = 3.3_dp                      ! material density                  [g/cm^3]
PN     = (Rv/R0)**3.0_dp             ! Number of monomer in an aggregate
nang   = 90*100+1                    ! Angle mesh

!--------------------------------------------------------------------------------
!        AGGREGATE STRUCTURE MODEL
!--------------------------------------------------------------------------------
df_min = 1.8_dp
df_max = 3.0_dp
do j=1,ndf
    DF(j) = df_min + real(j-1,kind=dp)*(df_max-df_min)/real(ndf-1,kind=dp)
    k0(j) = 0.716_dp * (1.0_dp - DF(j)) + sqrt(3.0_dp)
enddo
mass = 4.0_dp * pi * rv ** 3.0_dp * rhod / 3.0_dp

!--------------------------------------------------------------------------------
!        Wavelength mesh
!--------------------------------------------------------------------------------
open(16,file="astrosil.lnk",status="old")
do iwl=1,3
    read(16,'()')
enddo
do iwl=1,nwl
    read(16,*) wl(iwl),re(iwl),im(iwl)
enddo
close(16)

!--------------------------------------------------------------------------------
!        RUN OPACFRACTAL
!--------------------------------------------------------------------------------
call out_headerinfo(6,r0,rv,iqsca,iqcor,iqgeo)
allocate(Smat(1:4,1:2*nang-1))
do j=1,ndf
    !$OMP parallel do schedule (static,1)                     &
    !$OMP default(none)                                       &
    !$OMP shared(wl,re,im,mass,Q)                             &
    !$OMP shared(j,R0,PN,Df,k0,iqsca,iqcor,iqgeo,iquiet,nang) &
    !$OMP private(lmd,ref,Cext,Csca,Cabsp,Gsca,Smat,dphi)
    do iwl=1,nwl
        lmd=wl(iwl)
        ref=cmplx(re(iwl),im(iwl),kind=dp)
        write(*,'("df = ",f8.3," | k0 = ",f8.3," | wavelength (um) = ",1PE18.8)') df(j),k0(j),lmd
        call meanscatt(lmd,R0,PN,Df(j),k0(j),ref,iqsca,iqcor,iqgeo,iquiet,nang,&
                        Cext,Csca,Cabsp,Gsca,Smat,dphi)
        Q(j,1,iwl) = Cext  * 1.e4 / mass
        Q(j,2,iwl) = Csca  * 1.e4 / mass
        Q(j,3,iwl) = Cabsp * 1.e4 / mass
        Q(j,4,iwl) = gsca
        Q(j,5,iwl) = dphi
    enddo
    !$OMP end parallel do
enddo
deallocate(Smat)

!--------------------------------------------------------------------------------
!       OUTPUT
!--------------------------------------------------------------------------------
unit=10
open(unit,file="out_opc.dat",status="unknown")
call out_headerinfo(unit,r0,rv,iqsca,iqcor,iqgeo)
do j=1,ndf
write(10,'("#",A17,7A18)') "df","k0","lambda (um)",&
    "kext (cm^2/g)","ksca (cm^2/g)","kabs (cm^2/g)","<cos>","phase shift"
do iwl=1,nwl
    write(10,'(1P8E18.8)') df(j),k0(j),wl(iwl),(Q(j,i,iwl),i=1,5)
enddo
write(10,*)
enddo
close(unit)

print *, "finished!"
stop
end program call_opacfractal

!--------------------------------------------------------------------------------
!       output header information
!--------------------------------------------------------------------------------
subroutine out_headerinfo(unit,r0,rv,iqsca,iqcor,iqgeo)
use types
implicit none
integer::unit,iqsca,iqcor,iqgeo
real(kind=dp):: df,k0,r0,rv,p,rhod

write(unit,'("# ================================================")')
write(unit,'("#              OPACFRACTAL v3.0                  ")')
write(unit,'("# ================================================")')
write(unit,'("# iqsca = ",I1," iqcor = ",I1," iqgeo = ",I1)') iqsca,iqcor,iqgeo
write(unit,'("# monomer radius (um)                   = ",1PE15.5)') r0
write(unit,'("# volume-equivalent radius (um)         = ",1PE15.5)') rv

return
end subroutine out_headerinfo


  subroutine setALJ(calcVars, n, ip, p, exn)
!  subroutine setALJ(preeqObj, calcVars, n, ip, p, exn)

! ======================================================================
!
! This routine establishes the alj(:) array in the blalj common block.
! Written to simplifiy peqemt routine.
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use preequilibriumParams, only: one, two, thr, four
    use preequilibriumData, only: alj0, alj0D1Limit, alj0D2Limit

    implicit none
!    class(Preequilibrium), intent(inout) :: preeqObj   ! UNUSED!
    type(preequilibriumCalculation), intent(inout) :: calcVars
    integer(int32),        intent(in   ) :: n   ! Used for flags on alj
    integer(int32),        intent(in   ) :: ip  ! Used for flags on alj
    real(real64),          intent(in   ) :: p   ! Used to determine alj(:) values
    real(real64),          intent(in   ) :: exn ! Used to determine alj(:) values

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

    if (n <= alj0D2Limit .and. ip <= alj0D1Limit) then
       ! Use data
       calcVars%alj(1) = alj0(ip,n,1)
       calcVars%alj(2) = calcVars%alj(1)
       calcVars%alj(3) = alj0(ip,n,2)
       calcVars%alj(4) = alj0(ip,n,3)
       calcVars%alj(5) = calcVars%alj(4)
       calcVars%alj(6) = alj0(ip,n,4)
    else
       ! Outside data table
       calcVars%alj(1) = p*(exn - one)
       calcVars%alj(2) = calcVars%alj(1)
       calcVars%alj(3) = calcVars%alj(2)*(p - one)*(exn - two)/two
       calcVars%alj(4) = calcVars%alj(3)*(p - two)*(exn - thr)/6.d0
       calcVars%alj(5) = calcVars%alj(4)
       calcVars%alj(6) = calcVars%alj(5)*(p - thr)*(exn - four)/12.d0
    endif
! LMK 07/2012
    calcVars%alj(7) = calcVars%alj(6)*(p-4.d0)*(p-5.d0)*(exn-5.d0)*(exn-6.d0)/600.d0      ! He-6
    calcVars%alj(8) = calcVars%alj(7)*(p-6.d0)*(p-7.d0)*(exn-7.d0)*(exn-8.d0)/2352.d0     ! He-8
    calcVars%alj(9) = calcVars%alj(7)                                           ! Li-6
    calcVars%alj(10)= calcVars%alj(9)*(p-6.d0)*(exn-7.d0)/42.d0                       ! Li-7
    calcVars%alj(11)= calcVars%alj(8)                                           ! Li-8
    calcVars%alj(12)= calcVars%alj(11)*(p-8.d0)*(exn-9.d0)/72.d0                      ! Li-9
    calcVars%alj(13)= calcVars%alj(10)                                          ! Be-7
    calcVars%alj(14)= calcVars%alj(12)                                          ! Be-9
    calcVars%alj(15)= calcVars%alj(14)*(p-9.d0)*(exn-10.d0)/90.d0                     ! Be-10
    calcVars%alj(16)= calcVars%alj(15)*(p-10.d0)*(exn-11.d0)/110.d0                    ! Be-11
    calcVars%alj(17)= calcVars%alj(16)*(p-11.d0)*(exn-12.d0)/132.d0                   ! Be-12
    calcVars%alj(18)= calcVars%alj(11)                                          ! B-8
    calcVars%alj(19)= calcVars%alj(15)                                          ! B-10
    calcVars%alj(20)= calcVars%alj(16)                                          ! B-11
    calcVars%alj(21)= calcVars%alj(17)                                          ! B-12
    calcVars%alj(22)= calcVars%alj(21)*(p-12.d0)*(exn-13.d0)/156.d0                   ! B-13
    calcVars%alj(23)= calcVars%alj(19)                                          ! C-10
    calcVars%alj(24)= calcVars%alj(20)                                          ! C-11
    calcVars%alj(25)= calcVars%alj(21)                                          ! C-12
    calcVars%alj(26)= calcVars%alj(22)                                          ! C-13
    calcVars%alj(27)= calcVars%alj(26)*(p-13.d0)*(exn-14.d0)/182.d0                   ! C-14
    calcVars%alj(28)= calcVars%alj(27)*(p-14.d0)*(exn-15.d0)/210.d0                   ! C-15
    calcVars%alj(29)= calcVars%alj(28)*(p-15.d0)*(exn-16.d0)/240.d0                   ! C-16
! LMK 12/2012
    calcVars%alj(30)= calcVars%alj(17)                                        ! N-12
    calcVars%alj(31)= calcVars%alj(22)                                        ! N-13
    calcVars%alj(32)= calcVars%alj(27)                                        ! N-14
    calcVars%alj(33)= calcVars%alj(28)                                        ! N-15
    calcVars%alj(34)= calcVars%alj(29)                                        ! N-16
    calcVars%alj(35)= calcVars%alj(34)*(p-16.d0)*(exn-17.d0)/272.d0           ! N-17
    calcVars%alj(36)= calcVars%alj(27)                                        ! O-14
    calcVars%alj(37)= calcVars%alj(28)                                        ! O-15
    calcVars%alj(38)= calcVars%alj(29)                                        ! O-16
    calcVars%alj(39)= calcVars%alj(35)                                        ! O-17
    calcVars%alj(40)= calcVars%alj(39)*(p-17.d0)*(exn-18.d0)/306.d0           ! O-18
    calcVars%alj(41)= calcVars%alj(40)*(p-18.d0)*(exn-19.d0)/342.d0           ! O-19
    calcVars%alj(42)= calcVars%alj(41)*(p-19.d0)*(exn-20.d0)/380.d0           ! O-20
    calcVars%alj(43)= calcVars%alj(35)                                        ! F-17
    calcVars%alj(44)= calcVars%alj(40)                                        ! F-18
    calcVars%alj(45)= calcVars%alj(41)                                        ! F-19
    calcVars%alj(46)= calcVars%alj(42)                                        ! F-20
    calcVars%alj(47)= calcVars%alj(46)*(p-20.d0)*(exn-21.d0)/420.d0           ! F-21
    calcVars%alj(48)= calcVars%alj(40)                                        ! Ne-18
    calcVars%alj(49)= calcVars%alj(41)                                        ! Ne-19
    calcVars%alj(50)= calcVars%alj(42)                                        ! Ne-20
    calcVars%alj(51)= calcVars%alj(47)                                        ! Ne-21
    calcVars%alj(52)= calcVars%alj(51)*(p-21.d0)*(exn-22.d0)/462.d0           ! Ne-22
    calcVars%alj(53)= calcVars%alj(52)*(p-22.d0)*(exn-23.d0)/506.d0           ! Ne-23
    calcVars%alj(54)= calcVars%alj(53)*(p-23.d0)*(exn-24.d0)/552.d0           ! Ne-24
    calcVars%alj(55)= calcVars%alj(47)                                        ! Na-21
    calcVars%alj(56)= calcVars%alj(52)                                        ! Na-22
    calcVars%alj(57)= calcVars%alj(53)                                        ! Na-23
    calcVars%alj(58)= calcVars%alj(54)                                        ! Na-24
    calcVars%alj(59)= calcVars%alj(58)*(p-24.d0)*(exn-25.d0)/600.d0           ! Na-25
    calcVars%alj(60)= calcVars%alj(52)                                        ! Mg-22
    calcVars%alj(61)= calcVars%alj(53)                                        ! Mg-23
    calcVars%alj(62)= calcVars%alj(54)                                        ! Mg-24
    calcVars%alj(63)= calcVars%alj(59)                                        ! Mg-25
    calcVars%alj(64)= calcVars%alj(63)*(p-25.d0)*(exn-26.d0)/650.d0           ! Mg-26
    calcVars%alj(65)= calcVars%alj(64)*(p-26.d0)*(exn-27.d0)/702.d0           ! Mg-27
    calcVars%alj(66)= calcVars%alj(65)*(p-27.d0)*(exn-28.d0)/756.d0           ! Mg-28

    return
! ======================================================================
  end subroutine setALJ


c=======================================================================
c
c     subroutine ALLOCMV
c
c     Markowitz Mean-Variance strategy
c
c     Min[ w*Q*w ]
c      s.t.
c     rho*w >= delta           (target return)
c     C*w <= b                 (linear constraints)
c     Cinf <= w <= Csup        (lower/upper bounds)
c
c        w   : portfolio weights
c        Q   : covariance matrix
c        rho : assets performance
c
c-----------------------------------------------------------------------
      SUBROUTINE allocmv ( n, cov, rho,
     &                     neq, nin, ccst, bcst, cinf, csup, mu,
     &                     iwork, dwork, wopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n       : number of assets                               integer
c       cov     : covariance matrix (n*n)                         double
c       rho     : expected returns (n)                            double
c       neq     : number equality constraints                    integer
c       nin     : number inequality constraints                  integer
c       ccst    : matrix of constraints (n*(neq+nin))             double
c       bcst    : vector initial of constraints (neq+nin)         double
c       cinf    : lower bound (n)                                 double
c       csup    : upper bound (n)                                 double
c       mu      : performance target                              double
c
c     WORKSPACE
c       iwork   : 3*n+2*nin+neq+6                                integer
c       dwork   : 2*n*(neq+nin+n+9)+4*neq+6*nin+2*n+15            double
c
c     OUTPUT
c       wopt    : optimal portfolio (n)                           double
c       info    : diagnostic argument                            integer
c
c     CALL
c       OPMV    : computing optimization for ALLOCMV
c       TESTSDP : test if covariance matrix is SDP
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION mu
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*),
     &                 ccst(n,*), bcst(*), wopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piwo, pdwo, pisdp, pdsdp
c
c     external subroutines
      EXTERNAL opmv, testsdp
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      pisdp = 1
c     pisdp : pointer for TESTSDP (n)
      piwo  = 1
c     piwo  : pointer for OPMV 3*n+2*nin+neq+6
c
c     Total size of iwork array = ( 3*n + 2*nin + neq + 6 )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdsdp = 1
c     pdsdp : pointer for TESTSDP (n*(2*n + 7))
      pdwo  = 1
c     pdwo  : pointer for OPMV
c            2*n*(neq+nin+n+9)+4*neq+6*nin+2*n+15
c
c     Total size of dwork array = n*(2*n + 2*nin + 2*neq + 18) + 4*neq +
c                                                 6*nin + 15
c
c-----------------------------------------------------------------------
c
c     covariance matrix SDP ?
      CALL testsdp (n, cov, iwork(pisdp), dwork(pdsdp), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     optimization - Mean/Variance (cf. OPMV.F)
      CALL opmv ( n, cov, rho, mu,
     &            neq, nin, ccst, bcst, cinf, csup,
     &            iwork(piwo), dwork(pdwo), wopt, info )
      IF (info .EQ. 1001) THEN
        info = -101
      ENDIF
      RETURN
      END


      subroutine cohsrt(x,ncht,lrr,nfb,ns,ibtf,cohm,num,coht,cohp,nu
     &  ,coh,lpcoh,cfpcoh,xo,per,w,ntfmax)

c    takes wide coherence band array x,
c        computes coherences for each set, outputs only those
c        in the narrow TF band which achieve requisite minimum
c         coherence; nu is number of good sets which are output in xo;

      integer nchsmx
      parameter (nchmx = 20,nchsmx = (nchmx*(nchmx+1))/2)
      integer ibtf(2),ns,nfb,ncht,i,j,k,ii,num,
     &       nu,nchs,i1,ib,icohhist(0:100,3),nut
      real coh(3,ns),cohm,cohmin,cohp(2),w(nfb)
      complex s(nchsmx),xxinv(2,2),x(ncht,ns,nfb),xo(ncht,*),
     & xx(2,2),xy(2,2),b(2,2),det,yy(2,2)
      logical lrr,lpcoh,ltemp
      character*20 cfpcoh

c      num is minimum number of points desired for tf estiamtion
c      nut is target number of points for tf est.
c            this is determined from total available
      nbtf = ibtf(2) - ibtf(1) + 1
      nut = nint(cohp(1)*float(ns*nbtf)**cohp(2))
      nut = min(ns*nbtf,nut)
      nut = max(nut,num)

c............compute average power vs freq. to allow rough prewhitening
      call pwrvf(x,ncht,ns,nfb,w,xo)

      if(lpcoh) then
         open(unit=97,file=cfpcoh)
      end if
      nchs = (ncht*(ncht+1))/2
      do 100 i = 1,ns
c..........compute broad band sdm for each set
         do 5 j = 1,nchs
5        s(j) = (0.,0.)
         do 20 j = 1,nfb
20       call wstack(x(1,i,j),w(j),ncht,s)

c********************BLOCK FOR SINGLE STATION DATA ******************
       ltemp = .true.
       if(ltemp) then
c      if(.not.lrr) then
c................straight coherence between E and H
c       here we are finding (1,2) coherence of each channel and
c         (3) multivariate coherence of both together (i.e.,
c         fraction of total signal which is predicted

c........form full complex cross product matrices in a form
c        suitable for simple computation
         xx(1,1) = s(1)
         xx(2,1) = conjg(s(2))
         xx(1,2) = s(2)
         xx(2,2) = s(3)
         xy(1,1) = s(7)
         xy(1,2) = s(11)
         xy(2,1) = s(8)
         xy(2,2) = s(12)
         yy(1,1) = s(10)
         yy(1,2) = s(14)
         yy(2,1) = conjg(s(14))
         yy(2,2) = s(15)

c.......solve ls problem using Kramers rule to invert
c          x*x matrix
         det=xx(1,1)*xx(2,2)-xx(1,2)*xx(2,1)
         xxinv(1,1)=xx(2,2)/det
         xxinv(2,2)=xx(1,1)/det
         xxinv(1,2)=-xx(1,2)/det
         xxinv(2,1)=-xx(2,1)/det
         call matmultc(xxinv,xy,b,2,2,2)

c........find coherences
         call mcohc(yy(1,1),xx,xy(1,1),b(1,1),1,2,coh(1,i))
         call mcohc(yy(2,2),xx,xy(1,2),b(1,2),1,2,coh(2,i))
         call mcohc(yy,xx,xy,b,2,2,coh(3,i))
      else
c       for remote ref :
c.......coherence between R and H
c       here we are finding multivariate coherence of both
c       refeerence and local mag channels together (i.e.,
c         fraction of total signal which is predicted)

c..........form full complex cross product matrices in a form
c          suitable for simple computation
         xx(1,1) = s(1)
         xx(2,1) = conjg(s(2))
         xx(1,2) = s(2)
         xx(2,2) = s(3)
         xy(1,1) = s(16)
         xy(1,2) = s(22)
         xy(2,1) = s(17)
         xy(2,2) = s(23)
         yy(1,1) = s(21)
         yy(1,2) = s(27)
         yy(2,1) = conjg(s(27))
         yy(2,2) = s(28)

c..........solve ls problem using Kramers rule to invert
c          x*x matrix
         det=xx(1,1)*xx(2,2)-xx(1,2)*xx(2,1)
         xxinv(1,1)=xx(2,2)/det
         xxinv(2,2)=xx(1,1)/det
         xxinv(1,2)=-xx(1,2)/det
         xxinv(2,1)=-xx(2,1)/det
         call matmultc(xxinv,xy,b,2,2,2)

c............find multivariate coherence
         call mcohc(yy,xx,xy,b,2,2,coh(3,i))

      end if
100   continue

c*************** OUTPUT COHERENCE ETC TO FILE ************************
      if(lpcoh) then
c.........print out coherence vs. set #
         write(97,*) 'period =   ',per,ibtf(1),ibtf(2)
         write(97,'(i5,3f8.3)') (i,(coh(k,i),k=1,3),i=1,ns)
      end if

c************* FIND QUANTILES OF COHERENCE ***************************

         do 105 i = 0,100
         do 105 j = 1,3
105      icohhist(i,j) = 0

         do 110 i = 1,ns
            do 108 k = 1,3
            ii = int(coh(k,i)*100)
            if(( ii.lt.0).or.(ii.gt.100)) then
               print*,'!!!!!!!!! ii out of bounds !!!!!!!! coh= '
     &               ,coh(k,i),'  i= ',i,' k= ',k
               ii = 0
               stop
            end if
            icohhist(ii,k) = icohhist(ii,k) + 1
108         continue
110      continue

         do 115 j = 1,3
         do 115 i = 100,1,-1
115      icohhist(i-1,j) = icohhist(i-1,j) + icohhist(i,j)

      if(lpcoh) then
         write(97,'(i4,3i5)') (i,(icohhist(i,j),j=1,3),i=1,100)
      end if

c*********DETERMINE MINIMUM COHERENCE TO USE****************************
      i0 = 100*coht
         print*,'nbtf',nbtf
         print*,'i0,coht,icohhist(i0,3)',i0,coht,icohhist(i0,3)
      if(icohhist(i0,3)*nbtf.ge.nut) then
c........minimum coherence is target coherence
         cohmin = coht
      else
         i1 = 100*cohm
          print*,'i1,cohm,icohhist(i1,3)',i1,cohm,icohhist(i1,3)
         if(icohhist(i1,3)*nbtf.ge.nut) then
c...........determine minimum coherence from target number of points
               do 118 i = i0,i1,-1
               if(nbtf*(icohhist(i,3)).ge.nut) then
                  cohmin = float(i)/100.
                  go to 119
               end if
118            continue
119         continue
         else
            if(icohhist(i1,3)*nbtf.ge.num) then
c..............minimum coherence is input parameter cohm
               cohmin = cohm
            else
c..............determine minimum coherence from minimum number of data num
                  do 120 i = i1-1,1,-1
                  if(nbtf*icohhist(i,3).ge.num) then
                     cohmin = float(i)/100.
                     go to 121
                  end if
                  cohmin = 0.
120               continue
121            continue
            end if
         end if
      end if

      print*,'cohmin,ns,ibt ',cohmin,ns,ibtf

c************* PREPARE FC ARRAY XO FOR OUTPUT **********************
      nu = 0
         do 200 i = 1,ns
         if(coh(3,i).ge.cohmin) then
            do 150 ib =  ibtf(1),ibtf(2)
            nu = nu+1
               do 140 j = 1,ncht
               xo(j,nu) = x(j,i,ib)
140            continue
150         continue
         end if
         if(nu.eq.ntfmax) return
200      continue
         print*,'nu   ',nu
      return
      end


c
c ----------------------------------------------------------------------
c
      subroutine fvocxx(foc,vc,gc,fmass,fwidth , fvoc)
c
c this subroutine computes an off-shell antifermion wavefunction from a
c flowing-out external antifermion and a vector boson.
c
c input:
c       complex foc(6)         : flow-out antifermion              <foc|
c       complex vc(6)          : input    vector                      v
c       complex gc(2)          : coupling constants                  gvf
c       real    fmass          : mass  of output antifermion f'
c       real    fwidth         : width of output antifermion f'
c
c output:
c       complex fvoc(6)        : off-shell antifermion       <foc,v,fc'|
c
      implicit none
      double complex foc(6),vc(6),gc(2),fvoc(6),sl1,sl2,sr1,sr2,d
      double precision pf(0:3),fmass,fwidth,pf2

      double precision rOne
      parameter( rOne = 1.0d0 )
      double complex cImag, cZero
      parameter( cImag = ( 0.0d0, 1.0d0 ), cZero = ( 0.0d0, 0.0d0 ) )
c
      fvoc(5) = foc(5)+vc(5)
      fvoc(6) = foc(6)+vc(6)

      pf(0) = dble( fvoc(5))
      pf(1) = dble( fvoc(6))
      pf(2) = dimag(fvoc(6))
      pf(3) = dimag(fvoc(5))
      pf2 = pf(0)**2-(pf(1)**2+pf(2)**2+pf(3)**2)

      d = rOne/dcmplx( pf2-fmass**2, fmass*fwidth )
      sr1 =   (vc(1)-      vc(4))*foc(1)
     &      - (vc(2)+cImag*vc(3))*foc(2)
      sr2 = - (vc(2)-cImag*vc(3))*foc(1)
     &      + (vc(1)+      vc(4))*foc(2)

      if ( gc(2).ne.cZero ) then
         sl1 =   (vc(1)+      vc(4))*foc(3)
     &         + (vc(2)+cImag*vc(3))*foc(4)
         sl2 =   (vc(2)-cImag*vc(3))*foc(3)
     &         + (vc(1)-      vc(4))*foc(4)

         fvoc(1) = ( gc(1)*( (pf(0)+pf(3))*sr1   +       fvoc(6)*sr2)
     &              +gc(2)*fmass*sl1 )*d
         fvoc(2) = ( gc(1)*( dconjg(fvoc(6))*sr1 + (pf(0)-pf(3))*sr2)
     &              +gc(2)*fmass*sl2 )*d
         fvoc(3) = ( gc(2)*( (pf(0)-pf(3))*sl1   -       fvoc(6)*sl2)
     &              +gc(1)*fmass*sr1 )*d
         fvoc(4) = ( gc(2)*(-dconjg(fvoc(6))*sl1 + (pf(0)+pf(3))*sl2)
     &              +gc(1)*fmass*sr2 )*d
      else
         d = d * gc(1)
         fvoc(1) = ((pf(0)+pf(3))*sr1          +fvoc(6)*sr2)*d
         fvoc(2) = (dconjg(fvoc(6))*sr1 + (pf(0)-pf(3))*sr2)*d
         fvoc(3) = fmass*sr1*d
         fvoc(4) = fmass*sr2*d
      end if
c
      return
      end


subroutine psichi2uv_reg( psi, chi,  u, v)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    psichi2uv_reg
!     prgmmr:    barker, d   org:  np22              date:  2000-02-03
!
! abstract:  Calculate wind components u and v from psi and chi
!            (streamfunction and velocity potential, respectively)
!
! program history log:
!   2000/02/03   barker, dale - creation of F90 version
!   2001/10/30   barker       - parallel version
!   2003/09/05   parrish      - adapted to unified NCEP 3dvar
!   2003/10/17   wu, wanshu   - first index Y second X
!   2004-06-22   treadon      - update documentation
!   2008-04-23   safford      - rm unused vars
!   2009-04-19   derber       - modify to fit gsi
!
!   input argument list:
!     psi - streamfunction
!     chi - velocity potential
!
!   output argument list:
!     u - zonal wind component
!     v - meridional wind component
!
! remarks:
!    The method used is
!       u = ( -dpsi/dy + dchi/dx )
!       v = (  dpsi/dx + dchi/dy )
!
!    The assumptions made in this routine are:
!       - unstaggered grid,
!       - lateral boundary conditions - dpsi/dn, dchi/dn = 0 (FCT)
!       - dy=rearth*dph , dx=cos(ph)*rearth*dlm (dx,dy is rotated grid)
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$ end documentation block

  use kinds, only: r_kind,i_kind
  use constants, only: half
  use gridmod, only: coeffx,coeffy,nlat,nlon

  implicit none

  real(r_kind), intent(in   ) :: psi(nlat,nlon) ! Stream function
  real(r_kind), intent(in   ) :: chi(nlat,nlon) ! Velocity potential
  real(r_kind), intent(  out) :: u(nlat,nlon)   ! u wind comp (m/s)
  real(r_kind), intent(  out) :: v(nlat,nlon)   ! v wind comp (m/s)

  integer(i_kind)             :: i, j           ! Loop counters.

!------------------------------------------------------------------------------
!  [2.0] Compute u, v at interior points (2nd order central finite diffs):
!------------------------------------------------------------------------------

  do j = 2,nlon-1
     do i = 2,nlat-1
        u(i,j) = -( psi(i+1,j  ) - psi(i-1,j  ) )*coeffy(i,j) + &
                  ( chi(i  ,j+1) - chi(i  ,j-1) )*coeffx(i,j)

        v(i,j) =  ( psi(i  ,j+1) - psi(i  ,j-1) )*coeffx(i,j) + &
                  ( chi(i+1,j  ) - chi(i-1,j  ) )*coeffy(i,j)
     end do
  end do

!------------------------------------------------------------------------------
!  [3.0] Compute u, v at domain boundaries:
!------------------------------------------------------------------------------

!    [3.1] Western boundaries:

  j = 1
  do i = 2,nlat-1
     u(i,j) = -( psi(i+1,j  ) - psi(i-1,j  ) )*coeffy(i,j) + &
               ( chi(i  ,j+2) - chi(i  ,j  ) )*coeffx(i,j)
     v(i,j) =  ( psi(i  ,j+2) - psi(i  ,j  ) )*coeffx(i,j) + &
               ( chi(i+1,j  ) - chi(i-1,j  ) )*coeffy(i,j)
  end do

!    [3.2] Eastern boundaries:

  j = nlon
  do i = 2,nlat-1
     u(i,j) = -( psi(i+1,j  ) - psi(i-1,j  ) )*coeffy(i,j) + &
               ( chi(i  ,j  ) - chi(i  ,j-2) )*coeffx(i,j)
     v(i,j) =  ( psi(i  ,j  ) - psi(i  ,j-2) )*coeffx(i,j) + &
               ( chi(i+1,j  ) - chi(i-1,j  ) )*coeffy(i,j)
  end do

!    [3.3] Southern boundaries:

  i = 1
  do j = 2,nlon-1
     u(i,j) = -( psi(i+2,j  ) - psi(i  ,j  ) )*coeffy(i,j) + &
               ( chi(i  ,j+1) - chi(i  ,j-1) )*coeffx(i,j)

     v(i,j) =  ( psi(i  ,j+1) - psi(i  ,j-1) )*coeffx(i,j) + &
               ( chi(i+2,j  ) - chi(i  ,j  ) )*coeffy(i,j)

  end do

!    [3.4] Northern boundaries:

  i = nlat
  do j = 2,nlon-1
     u(i,j) = -( psi(i  ,j  ) - psi(i-2,j  ) )*coeffy(i,j) + &
               ( chi(i  ,j+1) - chi(i  ,j-1) )*coeffx(i,j)

     v(i,j) =  ( psi(i  ,j+1) - psi(i  ,j-1) )*coeffx(i,j) + &
               ( chi(i  ,j  ) - chi(i-2,j  ) )*coeffy(i,j)
  end do

!------------------------------------------------------------------------------
!    [4.0] Corner points (assume average of surrounding points - poor?):
!------------------------------------------------------------------------------

!    [4.1] Bottom-left point:

  u(1,1) = half * ( u(2,1) + u(1,2) )
  v(1,1) = half * ( v(2,1) + v(1,2) )

!    [4.2] Top-left point:

  u(nlat,1) = half * ( u(nlat-1,1) + u(nlat,2) )
  v(nlat,1) = half * ( v(nlat-1,1) + v(nlat,2) )

!    [4.3] Bottom-right point:

  u(1,nlon) = half * ( u(2,nlon) + u(1,nlon-1) )
  v(1,nlon) = half * ( v(2,nlon) + v(1,nlon-1) )

!    [4.4] Top-right point:

  u(nlat,nlon) = half * ( u(nlat-1,nlon) + u(nlat,nlon-1) )
  v(nlat,nlon) = half * ( v(nlat-1,nlon) + v(nlat,nlon-1) )

end subroutine psichi2uv_reg

subroutine delx_reg( chi,  u,vector)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    psichi2uv_reg
!     prgmmr:    barker, d   org:  np22              date:  2000-02-03
!
! abstract:  Calculate wind components u and v from psi and chi
!            (streamfunction and velocity potential, respectively)
!
! program history log:
!   2000/02/03   barker, dale - creation of F90 version
!   2001/10/30   barker       - parallel version
!   2003/09/05   parrish      - adapted to unified NCEP 3dvar
!   2003/10/17   wu, wanshu   - first index Y second X
!   2004-06-22   treadon      - update documentation
!   2009-04-19   derber       - modify to fit gsi
!
!   input argument list:
!     chi - velocity potential
!     vector
!
!   output argument list:
!     u
!
! remarks:
!    The method used is
!       u = ( -dpsi/dy + dchi/dx )
!
!    The assumptions made in this routine are:
!       - unstaggered grid,
!       - lateral boundary conditions - dpsi/dn, dchi/dn = 0 (FCT)
!       - dy=rearth*dph , dx=cos(ph)*rearth*dlm (dx,dy is rotated grid)
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: half
  use gridmod, only: coeffx,nlat,nlon,region_dy,region_dyi

  implicit none

  logical     , intent(in   ) :: vector
  real(r_kind), intent(in   ) :: chi(nlat,nlon) ! Velocity potential
  real(r_kind), intent(  out) :: u(nlat,nlon)   ! v wind comp (m/s)

  integer(i_kind)             :: i, j           ! Loop counters.
  real(r_kind)                :: ch2(nlat,nlon)

  if(vector) then
     do j=1,nlon
        do i=1,nlat
           ch2(i,j)=chi(i,j)*region_dy(i,j)
        end do
     end do

!------------------------------------------------------------------------------
!  [2.0] Compute u, v at interior points (2nd order central finite diffs):
!------------------------------------------------------------------------------

     do j = 2,nlon-1
        do i = 1,nlat
           u(i,j) =  ( ch2(i  ,j+1) - ch2(i  ,j-1) )*coeffx(i,j)

        end do
     end do

!------------------------------------------------------------------------------
!  [3.0] Compute u, v at domain boundaries:
!------------------------------------------------------------------------------

!    [3.1] Western boundaries:

     j = 1
     do i = 1,nlat
        u(i,j) = ( ch2(i  ,j+2) - ch2(i  ,j         ) )*coeffx(i,j)
     end do

!    [3.2] Eastern boundaries:

     j = nlon
     do i = 1,nlat
        u(i,j) = ( ch2(i  ,j  ) - ch2(i  ,j-2) )*coeffx(i,j)
     end do

  else

!------------------------------------------------------------------------------
!  [2.0] Compute u, v at interior points (2nd order central finite diffs):
!------------------------------------------------------------------------------

     do j = 2,nlon-1
        do i = 1,nlat
           u(i,j) =  ( chi(i  ,j+1) - chi(i  ,j-1) )*coeffx(i,j)

        end do
     end do

!------------------------------------------------------------------------------
!  [3.0] Compute u, v at domain boundaries:
!------------------------------------------------------------------------------

!    [3.1] Western boundaries:

     j = 1
     do i = 1,nlat
        u(i,j) = ( chi(i  ,j+2) - chi(i  ,j  ) )*coeffx(i,j)
     end do

!    [3.2] Eastern boundaries:

     j = nlon
     do i = 1,nlat
        u(i,j) = ( chi(i  ,j  ) - chi(i  ,j-2) )*coeffx(i,j)
     end do

  end if

!------------------------------------------------------------------------------
!    [4.0] Corner points (assume average of surrounding points - poor?):
!------------------------------------------------------------------------------

!    [4.1] Bottom-left point:

  u(1   ,1   ) = half * ( u(2     ,1   ) + u(1   ,2  ) )

!    [4.2] Top-left point:

  u(nlat,1   ) = half * ( u(nlat-1,1   ) + u(nlat,2  ) )

!    [4.3] Bottom-right point:

  u(1,nlon   ) = half * ( u(2     ,nlon) + u(1   ,nlon-1) )

!    [4.4] Top-right point:

  u(nlat,nlon) = half * ( u(nlat-1,nlon) + u(nlat,nlon-1) )

  if(vector) then
     do j=1,nlon
        do i=1,nlat
           u(i,j)=u(i,j)*region_dyi(i,j)
        end do
     end do
  end if

end subroutine delx_reg

subroutine dely_reg( chi,  v,vector)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    psichi2uv_reg
!     prgmmr:    barker, d   org:  np22              date:  2000-02-03
!
! abstract:  Calculate wind components u and v from psi and chi
!            (streamfunction and velocity potential, respectively)
!
! program history log:
!   2000/02/03   barker, dale - creation of F90 version
!   2001/10/30   barker       - parallel version
!   2003/09/05   parrish      - adapted to unified NCEP 3dvar
!   2003/10/17   wu, wanshu   - first index Y second X
!   2004-06-22   treadon      - update documentation
!   2009-04-19   derber       - modify to fit gsi
!
!   input argument list:
!     chi - velocity potential
!     vector
!
!   output argument list:
!     v - meridional wind component
!
! remarks:
!    The method used is
!       u = ( dchi/dx )
!
!    The assumptions made in this routine are:
!       - unstaggered grid,
!       - lateral boundary conditions - dpsi/dn, dchi/dn = 0 (FCT)
!       - dy=rearth*dph , dx=cos(ph)*rearth*dlm (dx,dy is rotated grid)
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: half
  use gridmod, only: coeffy,nlat,nlon,region_dx,region_dxi

  implicit none

  logical     , intent(in   ) :: vector
  real(r_kind), intent(in   ) :: chi(nlat,nlon) ! Velocity potential
  real(r_kind), intent(  out) :: v(nlat,nlon)   ! v wind comp (m/s)

  integer(i_kind)             :: i, j           ! Loop counters.
  real(r_kind)                :: ch2(nlat,nlon)

  if(vector) then
     do j=1,nlon
        do i=1,nlat
           ch2(i,j)=chi(i,j)*region_dx(i,j)
        end do
     end do

!------------------------------------------------------------------------------
!  [2.0] Compute u, v at interior points (2nd order central finite diffs):
!------------------------------------------------------------------------------

     do j = 1,nlon
        do i = 2,nlat-1

           v(i,j) =  ( ch2(i+1,j  ) - ch2(i-1,j  ) ) * coeffy(i,j)
        end do
     end do

!------------------------------------------------------------------------------
!  [3.0] Compute u, v at domain boundaries:
!------------------------------------------------------------------------------

!    [3.3] Southern boundaries:

     i = 1
     do j = 1,nlon

        v(i,j) = ( ch2(i+2,j  ) - ch2(i  ,j  ) ) * coeffy(i,j)

     end do

!    [3.4] Northern boundaries:

     i = nlat
     do j = 1,nlon

        v(i,j) = ( ch2(i  ,j  ) - ch2(i-2,j  ) ) * coeffy(i,j)
     end do

  else

!------------------------------------------------------------------------------
!  [2.0] Compute u, v at interior points (2nd order central finite diffs):
!------------------------------------------------------------------------------

     do j = 1,nlon
        do i = 2,nlat-1

           v(i,j) =  ( chi(i+1,j  ) - chi(i-1,j  ) ) * coeffy(i,j)
        end do
     end do

!------------------------------------------------------------------------------
!  [3.0] Compute u, v at domain boundaries:
!------------------------------------------------------------------------------

!    [3.3] Southern boundaries:

     i = 1
     do j = 1,nlon

        v(i,j) = ( chi(i+2,j  ) - chi(i  ,j  ) ) * coeffy(i,j)

     end do

!    [3.4] Northern boundaries:

     i = nlat
     do j = 1,nlon

        v(i,j) = ( chi(i  ,j  ) - chi(i-2,j  ) ) * coeffy(i,j)
     end do

  end if

!------------------------------------------------------------------------------
!    [4.0] Corner points (assume average of surrounding points - poor?):
!------------------------------------------------------------------------------

!    [4.1] Bottom-left point:

  v(1   ,1   ) = half * ( v(2     ,1   ) + v(1   ,2  ) )

!    [4.2] Top-left point:

  v(nlat,1   ) = half * ( v(nlat-1,1   ) + v(nlat,2  ) )

!    [4.3] Bottom-right point:

  v(1   ,nlon) = half * ( v(2     ,nlon) + v(1   ,nlon-1) )

!    [4.4] Top-right point:

  v(nlat,nlon) = half * ( v(nlat-1,nlon) + v(nlat,nlon-1) )

  if(vector) then
     do j=1,nlon
        do i=1,nlat
           v(i,j)=v(i,j)*region_dxi(i,j)
        end do
     end do
  end if

end subroutine dely_reg


      MODULE MOD_DERIV

      CONTAINS

      SUBROUTINE DERIV(DLOWUP,I,NUP,LOW,IND,
     $                 NPLUS1,EN,CRATE,RRATE,EXPFAC,NFEDGE,
     $                 WCHARM,ND,L,TL,ENLTE,PHI,PWEIGHT,NFL,DELTAX,XMAX,
     $                 DETAL,DOPAL,SLNEW,OPAL,XJLAPP,XJCAPP,
     $                 FWEIGHT,DOPA,DETA,OPAC,SCNEW,XLAMBDA,NF,
     $                 N,NCHARG,WEIGHT,ELEVEL,NOM,EINST,SIGMAKI,LASTIND,
     $                 XJL, AccFact, SLOLD)

C*******************************************************************************
C***  DERIVATIVE OF RATE EQ. COEFFICIENTS :
C***  D(I,M,J):= N(M) * D(RATCO(M,J))/DN(I) - N(J) * D(RATCO(J,M))/DN(I)
C*******************************************************************************

      USE COMMON_BLOCK

      IMPLICIT REAL*8(A - H, O - Z)

      REAL*8, INTENT(IN), DIMENSION(N, N) :: CRATE ! Collision Rate

      REAL*8, dimension(N)      :: ENLTE  ! population number in LTE
      REAL*8, dimension(NPLUS1) :: EN     ! population number in NLTE
      REAL*8, dimension(ND, NF) :: WCHARM

      DIMENSION NCHARG(N),RRATE(N,N)
      DIMENSION EINST(N,N),ELEVEL(N)
      DIMENSION WEIGHT(N),NFEDGE(N)
      DIMENSION NOM(N)
      DIMENSION DOPA(NF),DETA(NF),OPAC(NF),SCNEW(NF)
      DIMENSION FWEIGHT(NF),XLAMBDA(NF),XJCAPP(NF),EXPFAC(NF)
      DIMENSION DOPAL(LASTIND),SLNEW(LASTIND),OPAL(LASTIND),DETAL(LASTIND)
      DIMENSION XJLAPP(LASTIND)
      DIMENSION PHI(NFL),PWEIGHT(NFL)
      DIMENSION SIGMAKI(NF,N)

      REAL*8, DIMENSION(LASTIND), INTENT(IN) :: XJL, AccFact, SLOLD

C***  C2 = 2 * H * C    ( H AND C IN CGS UNITS )
      DATA C2 / 3.9724d-16 /
C***  C3 = 4 * PI / H / C
      DATA C3 / 0.06327d18 /
C***  PI8 = 8 * PI

      DATA PI8 / 25.13274123d0 /

      DLOWUP = 0.0D0

      IF (NOM(NUP) .NE. NOM(LOW)) RETURN

      NDCH = NCHARG(NUP) - NCHARG(LOW)

      IF (NDCH .GT. 1) RETURN

      IF (NDCH .EQ. 0) GOTO 1

C***  M - J IS BOUND-FREE TRANSITION  ******************************************
C***  UPPER LEVEL MUST BE A GROUND STATE

      IF (NCHARG(NUP) .EQ. NCHARG(NUP - 1)) RETURN

C***  DERIVATIVE WITH RESPECT TO ELECTRON DENSITY
      IF (I .EQ. NPLUS1) THEN

         DLOWUP = - (EN(LOW) * CRATE(LOW, NUP) - EN(NUP) * (2.d0 * CRATE(NUP, LOW) + RRATE(NUP, LOW))) / EN(NPLUS1)

         IF (CONST_ELEC) DLOWUP = 0.0D0 ! PRE-SET ELECTRON CONCENTRATION

      ENDIF

      if (isnan(dlowup)) stop 'deriv bf elec is NaN'

C***  RATE INTEGRAL (DERIVATIVE OF NET RADIATIVE BRACKET)

      SUM = 0.0D0

C***  PREFACTOR FOR THE DERIVATIVE OF 1/S-BOUND-FREE WITH RESPECT TO N(I)

      IF (I .EQ. LOW) THEN

         PREFAC = -1.0D0 / C2 / EN(NUP)

      ELSEIF (I .EQ. NUP) THEN

         PREFAC = EN(LOW) / EN(NUP) / EN(NUP) / C2

      ELSEIF (I .EQ. NPLUS1) THEN

         PREFAC = EN(LOW) / EN(NUP) / EN(NPLUS1) / C2

      ELSE

         PREFAC = 0.0D0

      ENDIF

      NFLOW = NFEDGE(LOW)

      DO K = 1, NFLOW

         WAVENUM = 1.0D8 / XLAMBDA(K)

         W2 = WAVENUM * WAVENUM

         W3 = W2 * WAVENUM

C***  CALCULATE BOUND-FREE SOURCE FUNCTION FOR TRANSITION LOW-UP ONLY

         EXFAC = EXPFAC(K)

         G = EXFAC * ENLTE(LOW) / ENLTE(NUP)

         SBF = C2 * W3 / (EN(LOW) / (EN(NUP) * G) - 1.0D0)

         DSUM = XJCAPP(K) * PREFAC / W3 / G + WCHARM(L, K) * (DOPA(K) * SCNEW(K) - DETA(K)) / (OPAC(K) * SBF)

C***  MAKE USE OF SIGMAKI, THE TABULATED PHOTOCROSSECTIONS IN CM**2

         SUM = SUM + DSUM * SIGMAKI(K, LOW) * EXFAC * W2 * FWEIGHT(K)

      ENDDO

      DLOWUP = DLOWUP + SUM * PI8 * EN(NUP) * ENLTE(LOW) / ENLTE(NUP)

      if (isnan(dlowup)) then

         print*, 'deriv bf dlowup is NaN'

         stop

      endif

      RETURN

C***  M - J IS BOUND-BOUND TRANSITION   ****************************************
    1 CONTINUE

C***  DERIVATIVE WITH RESPECT TO ELECTRON DENSITY
      IF (I .EQ. NPLUS1) THEN

          CRRatio = EN(LOW) * CRATE(LOW, NUP) / EN(NUP) / CRATE(NUP, LOW)

          DLOWUP = EN(NUP) * CRATE(NUP, LOW) * (1.0D0 - CRRatio) / EN(NPLUS1)
!         DLOWUP = (EN(NUP) * CRATE(NUP, LOW) - EN(LOW) * CRATE(LOW, NUP)) / EN(NPLUS1)

         IF (CONST_ELEC) DLOWUP = 0.0D0 ! PRE-SET ELECTRON CONCENTRATION

          RETURN

      ENDIF

      if (isnan(dlowup)) stop 'deriv bb elec dlowup is NaN'

!     DERIVATIVES WITH RESPECT TO POPNUMBER EN(I)

!     RINAT TAGIROV:
!     These two processes are not taken into account in the Jacobian calculations:
!     H- + e- <-> H + e- + e-
!     H- + p+ <-> H + H
!     Since the convergence was attained we decided not to bother with including them in this procedure.

!     ESTIMATE OF CURRENT LINE INDEX IND
      IND = IND + 1

!     THE DERIVATIVES OF THE CONT. BACKGROUND-OPACITY AND EMISSIVITY
!     ARE NEGLECTED. HENCE:
      IF (I .NE. NUP .AND. I .NE. LOW) RETURN

!     RUDIMENTAL LINES: ZERO CORE ASSUMED
      IF (EINST(LOW, NUP) .EQ. -2.d0) RETURN

!     TERM FOR NET RADIATIVE BRACKETS

      IF (SLNEW(IND) .NE. 0.0D0) THEN

         ETAL = SLNEW(IND) * OPAL(IND)

         DLOWUP_RB = XJL(IND) * (OPAL(IND) * DETAL(IND) - DOPAL(IND) * ETAL) / ETAL**2.0D0

         DLOWUP_RB = EINST(NUP, LOW) * DLOWUP_RB

!     RINAT TAGIROV:
!     Taking the local operator acceleration into account in the Jacobian calculations
!-------------------------------------------------------------------------------------
         DLOWUP_RB = (1.0D0 - AccFact(IND) * SLOLD(IND) / XJL(IND)) * DLOWUP_RB
!-------------------------------------------------------------------------------------

      ELSE

         DLOWUP_RB = 0.0D0

      ENDIF

      DLOWUP = EN(NUP) * DLOWUP_RB

      if (isnan(dlowup)) stop 'deriv bb dlowup is NaN'

      RETURN

      END SUBROUTINE

      END MODULE


!******************************************************************************************************
!>
!  Test of a small, square (`n=m`) problem.

    program nlesolver_test_1

    use nlesolver_module, wp => nlesolver_rk

    implicit none

    integer,parameter :: n = 2
    integer,parameter :: m = 2
    integer,parameter :: max_iter = 100
    real(wp),parameter :: tol = 1.0e-8_wp
    logical,parameter :: verbose = .false.

    type(nlesolver_type) :: solver
    real(wp) :: alpha
    logical :: use_broyden
    integer :: step_mode
    integer :: n_intervals
    integer :: istat !! Integer status code.
    character(len=:),allocatable :: message  !! Text status message
    real(wp),dimension(n) :: x
    integer :: f_evals
    integer :: i
    character(len=:),allocatable :: description
    real(wp) :: fmin_tol

    fmin_tol = 1.0e-2_wp ! don't need a tight tol for this
    n_intervals = 2
    alpha = 1.0_wp

    write(*,*) ''
    do i = 1, 8

        select case (i)
        case(1)
            step_mode = 1
            use_broyden = .false.
            f_evals = 0
            description = 'Constant alpha'
        case(2)
            step_mode = 1
            use_broyden = .true.
            f_evals = 0
            description = 'Constant alpha + broyden'
        case(3)
            step_mode = 2
            use_broyden = .false.
            f_evals = 0
            description = 'Backtracking line search'
        case(4)
            step_mode = 2
            use_broyden = .true.
            f_evals = 0
            description = 'Backtracking line search + broyden'
        case(5)
            step_mode = 3
            use_broyden = .false.
            f_evals = 0
            description = 'Exact line search'
        case(6)
            step_mode = 3
            use_broyden = .true.
            f_evals = 0
            description = 'Exact line search + broyden'
        case(7)
            step_mode = 4
            use_broyden = .false.
            f_evals = 0
            description = 'Fixed point search'
        case(8)
            step_mode = 4
            use_broyden = .true.
            f_evals = 0
            description = 'Fixed point search + broyden'
        case default
            error stop 'invalid case'
        end select

        write(*,*) '-------------------------------------------------------'
        write(*,'(A,I3,A,A)') 'Case ', i, ' : ', description
        write(*,*) ''

        call solver%initialize( n = n, &
                                m = m, &
                                max_iter = max_iter, &
                                tol = tol, &
                                func = func, &
                                grad = grad, &
                                step_mode = step_mode,&
                                use_broyden = use_broyden,&
                                export_iteration = export,&
                                n_intervals = n_intervals, &
                                fmin_tol = fmin_tol, &
                                verbose = verbose)
        call solver%status(istat, message)
        write(*,'(I3,1X,A)') istat, message
        if (istat /= 0) error stop

        x = [1.0_wp, 2.0_wp]
        call solver%solve(x)

        call solver%status(istat, message)
        write(*,'(I3,1X,A)') istat, message
        write(*,*) ''

    end do

    contains

    subroutine func(me,x,f)
        !! compute the function
        implicit none
        class(nlesolver_type),intent(inout) :: me
        real(wp),dimension(:),intent(in)    :: x
        real(wp),dimension(:),intent(out)   :: f

        f_evals = f_evals + 1

        f(1) = x(1)**2 + x(2) - 0.1_wp
        f(2) = x(2) + 0.2_wp

        ! root is 5.477226E-01  -2.000000E-01

    end subroutine func

    subroutine grad(me,x,g)
        !! compute the gradient of the function (Jacobian):
        implicit none
        class(nlesolver_type),intent(inout) :: me
        real(wp),dimension(:),intent(in)    :: x
        real(wp),dimension(:,:),intent(out) :: g

        f_evals = f_evals + 2   ! to approximate forward diff derivatives

        g(1,1) = 2.0_wp * x(1)  !df(1)/dx
        g(2,1) = 0.0_wp         !df(2)/dx

        g(1,2) = 1.0_wp         !df(1)/dy
        g(2,2) = 1.0_wp         !df(2)/dy

    end subroutine grad

    subroutine export(me,x,f,iter)
        !! export an iteration:
        implicit none
        class(nlesolver_type),intent(inout) :: me
        real(wp),dimension(:),intent(in)    :: x
        real(wp),dimension(:),intent(in)    :: f
        integer,intent(in)                  :: iter !! iteration number

        write(*,'(1P,I3,1X,A,I3,A,*(E15.6))') iter, '(',f_evals,')', x, norm2(f)

    end subroutine export

!******************************************************************************************************
    end program nlesolver_test_1
!******************************************************************************************************