!******************************************************************************
!
!  File Name: apexsh.f90
!  Authors: John Emmert, Art Richmond
!  Date: 11/13/2009
!  Version: 1.0
!  Description: Converts geodetic coordinates to and from Quasi-Dipole and
!               Modified Apex Coordinates.
!
!  References: Richmond, A. D., Ionospheric Electrodynamics Using Magnetic Apex
!                Coordinates, J. Geomag. Geoelectr., 47, 191-212, 1995.
!              Emmert, J. T., A. D. Richmond, and D. P. Drob, A computationally
!                compact representation of Magnetic-Apex and Quasi-Dipole
!                coordinates with smooth base vectors, J. Geophys. Res., 115,
!                Axxxxx, doi:10.1029/2010JA015326, 2010.
!
!*******************************************************************************
!
!  LOADAPXSH
!  Loads spherical harmonic coefficients (created by MAKEAPXSH) for coordinate
!  conversions. Must be run before calling the conversion routines.
!
!  CALL LOADAPXSH (DATAFILE, EPOCH)
!
!  INPUT ARGUMENTS
!    DATAFILE  Name of data file, generated by MAKEAPXSH, containing the
!              conversion coefficients
!    EPOCH     Date for which coordinates are desired (decimal years, yyyy.y,
!              single precision)
!
!*******************************************************************************
!
!  APXG2Q
!  Converts geodetic to Quasi-Dipole coordinates
!  Must call LOADAPXSH first. All arguments are single precision, except for
!  VECFLAG, which is a 4-byte integers.
!
!  CALL APXG2Q (GLAT, GLON, ALT, VECFLAG, QLAT, QLON, F1, F2, F)
!
!  INPUT ARGUMENTS
!    GLAT     Geodetic latitude (degrees)
!    GLON     Geodetic longitude (degrees)
!    ALT      Altitude (km)
!    VECFLAG  Set this flag to zero to calculate coordinates only, without base
!             vectors. The base vector output arguments will be filled with
!             -9999.
!
!  OUTPUT ARGUMENTS
!    QLAT      Quasi-Dipole latitude (degrees)
!    QLON      Quasi-Dipole longitude (degrees)
!    F1,F2     Quasi-Dipole coordinates base vectors described in
!              Richmond (1995). The two elements of each vector contain the
!              geodetic east and north components. F1 points in the QD
!              east direction, and F2 points in the QD north direction.
!    F         F = |F1 x F2|, as described in Richmond (1995)
!
!*******************************************************************************
!
!  APXG2ALL
!  Converts geodetic to Quasi-Dipole and Modified Apex coordinates
!  Must call LOADAPXSH first. All arguments are single precision, except for
!  MAFLAG and VECFLAG, which are 4-byte integers.
!
!  CALL APXG2ALL (GLAT, GLON, ALT, HR, VECFLAG, &
!                 QLAT, QLON, MLAT, MLON, &
!                 F1,F2,F, D1,D2,D3,D, E1,E2,E3)
!
!  INPUT ARGUMENTS
!    GLAT     Geodetic latitude (degrees)
!    GLON     Geodetic longitude (degrees)
!    ALT      Altitude (km)
!    HR       Modified Apex coordinates reference altitude (km)
!    VECFLAG  Set this flag to zero to calculate coordinates only, without base
!             vectors. The base vector output arguments will be filled with
!             -9999.
!
!  OUTPUT ARGUMENTS
!    QLAT      Quasi-Dipole latitude (degrees)
!    QLON      Quasi-Dipole longitude (degrees)
!    MLAT      Modified Apex latitude (degrees)
!    MLON      Modified Apex longitude (degrees)
!    F1,F2     Quasi-Dipole coordinates base vectors described in
!              Richmond (1995). The two elements of each vector contain the
!              geodetic east and north components. F1 points in the QD east
!              direction, and F2 points in the QD north direction.
!    F         F = |F1 x F2|, as described in Richmond (1995)
!    D1,D2,D3  Modified Apex coordinates base vectors described in
!              Richmond (1995). The three elements of each vector contain the
!              geodetic east, north, and up components. D1 and D2 are generally
!              perpendicular to the magnetic field and point in the magnetic
!              east and downward/equatorward directions. D3 points along the
!              magnetic field.
!    D         D = |D1 x D2|, as described in Richmond (1995)
!    E1,E2,E3  Modified Apex coordinates base vectors described in
!              Richmond (1995). The three elements of each vector contain the
!              geodetic east, north, and up components. E1 and E2 are generally
!              perpendicular to the magnetic field and point in the magnetic
!              east and downward/equatorward directions. E3 points along the
!              magnetic field.
!
!*******************************************************************************
!
!  APXQ2G
!  Converts Quasi-Dipole to geodetic coordinates
!  All arguments are single precision.
!
!  CALL APXQ2G (QLAT, QLON, ALT, PREC, GLAT, GLON, ERROR)
!
!  INPUT ARGUMENTS
!    QLAT   Quasi-Dipole latitude (degrees)
!    QLON   Quasi-Dipole longitude (degrees)
!    ALT    Altitude (km)
!    PREC   Precision of output (degrees). A negative value of this argument
!           produces a low-precision calculation of geodetic lat and lon based
!           only on their spherical harmonic representation. A positive value
!           causes the routine to iterate until feeding the output glat and
!           glon coordinates into APXG2Q reproduces the input qlat and qlon to
!           within the specified precision.
!
!  OUTPUT ARGUMENTS
!    GLAT   Geodetic latitude (degrees)
!    GLON   Geodetic longitude (degrees)
!    ERROR  The angular difference (degrees) between the input qlat and qlon
!           coordinates and the qlat and qlon produced by feeding the output
!           glat and glon into APG2ALL.
!
!*******************************************************************************

module apxshmodule

    implicit none

    integer(4)               :: nterm, nmax, mmax, lmax, nepoch, ntermsh
    integer(4)               :: vecflag

    real(8), allocatable     :: coeff0(:,:,:)
    real(8), allocatable     :: qcoeff0(:,:), gcoeff0(:,:)
    real(8), allocatable     :: xqcoeff(:), yqcoeff(:), zqcoeff(:)
    real(8), allocatable     :: dxqdrhocoeff(:), dyqdrhocoeff(:), dzqdrhocoeff(:)
    real(8), allocatable     :: xgcoeff(:), ygcoeff(:), zgcoeff(:)
    real(8), allocatable     :: sh(:), shgradtheta(:), shgradphi(:)
    real(8), allocatable     :: polynomq(:), dpolynomq(:), polynomg(:)
    real(8), allocatable     :: pbar(:,:), vbar(:,:), wbar(:,:)
    real(4), allocatable     :: epochgrid(:)

    real(8)                  :: h, Reph, rho
    real(8)                  :: xq, yq, zq
    real(8)                  :: qlat, qlon
    real(8)                  :: sinqlat, cosqlat, cosqlon, sinqlon
    real(8)                  :: xqgrad(1:3), yqgrad(1:3), zqgrad(1:3)
    real(8)                  :: qlatgrad(1:3), qlongrad(1:3)

    real(8), parameter       :: pi=3.14159265358979323846D0
    real(8), parameter       :: dtor=pi/180D0, pid2=pi/2D0, twopi=2D0*pi
    real(8), parameter       :: Req=6378.1370D0, eps=1.D0/298.257223563D0
    real(8), parameter       :: Re=Req*(1-eps/3D0), ecc2=eps*(2-eps)
    real(4), parameter       :: missing=-9999E0

!   Req = Equatorial radius of Earth in km (WGS84 value)
!   eps = flatness of ellipsoidal Earth (WGS84 value)
!   Re = Mean radius of Earth in km
!   ecc2 = squared eccentricity of ellipsoidal Earth

    character(1000)          :: datafile
    real(4)                  :: epoch
    real(4)                  :: altlastq, altlastg
    logical                  :: loadflag = .true.

end module apxshmodule

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

subroutine loadapxsh(datafilenew,epochnew)

    use apxshmodule

    implicit none

    character(1000)             :: datafilenew, datafilelast=''
    real(4)                     :: epochnew, epochlast=-999.0
    real(8)                     :: we0, we1
    integer(4)                  :: iepoch0, iepoch1, iterm, icoord

    !CHECK FILE, GET DIMENSIONS, AND ALLOCATE ARRAYS
    if ((datafilenew .ne. datafilelast) .or. (loadflag)) then
      datafile = datafilenew
      open(unit=23,file=trim(datafile),status='old',form='unformatted')
      read(23) nepoch, nmax, mmax, lmax, nterm
      call allocatearrays
      read(23) epochgrid, coeff0
      close(23)
    endif

    !LOAD COEFFICIENTS AND INTEPOLATE TO SELECTED EPOCH
    if ((epochnew .ne. epochlast) .or. (datafilenew .ne. datafilelast) .or.(loadflag)) then
      epoch = epochnew
      if (epoch .lt. epochgrid(0)) epoch=epochgrid(0)
      if (epoch .gt. epochgrid(nepoch-1)) epoch=epochgrid(nepoch-1)
      if (nepoch .eq. 1) then
        iepoch0 = 0
        iepoch1 = 0
        we0 = 1D0
        we1 = 0D0
      else
        iepoch0 = nepoch - 1
        do while ((epochgrid(iepoch0) .ge. epoch) .and. (iepoch0 .gt. 0))
          iepoch0 = iepoch0 - 1
        enddo
        iepoch1 = iepoch0 + 1
        we0 = dble( (epochgrid(iepoch1) - epoch) / (epochgrid(iepoch1)-epochgrid(iepoch0)) )
        we1 = 1D0 - we0
      endif
      do icoord = 0, 2
      do iterm = 0, nterm-1
        qcoeff0(iterm,icoord)= we0*coeff0(iterm,iepoch0,icoord)  +we1*coeff0(iterm,iepoch1,icoord)
        gcoeff0(iterm,icoord)= we0*coeff0(iterm,iepoch0,icoord+3)+we1*coeff0(iterm,iepoch1,icoord+3)
      enddo
      enddo
      altlastq = -999.0
      altlastg = -999.0
    endif

    !UPDATE LOAD VARIABLES
    loadflag = .false.
    datafilelast = datafilenew
    epochlast = epochnew

    return

end subroutine loadapxsh

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

subroutine allocatearrays

    use apxshmodule

    implicit none

    external alfbasisinit

    !RESET ARRAYS
    if (allocated(epochgrid)) deallocate(epochgrid)
    if (allocated(coeff0)) deallocate(coeff0)
    if (allocated(gcoeff0)) deallocate(gcoeff0)
    if (allocated(qcoeff0)) deallocate(qcoeff0)
    if (allocated(xqcoeff)) deallocate(xqcoeff)
    if (allocated(yqcoeff)) deallocate(yqcoeff)
    if (allocated(zqcoeff)) deallocate(zqcoeff)
    if (allocated(dxqdrhocoeff)) deallocate(dxqdrhocoeff)
    if (allocated(dyqdrhocoeff)) deallocate(dyqdrhocoeff)
    if (allocated(dzqdrhocoeff)) deallocate(dzqdrhocoeff)
    if (allocated(xgcoeff)) deallocate(xgcoeff)
    if (allocated(ygcoeff)) deallocate(ygcoeff)
    if (allocated(zgcoeff)) deallocate(zgcoeff)
    if (allocated(sh)) deallocate(sh)
    if (allocated(shgradphi)) deallocate(shgradphi)
    if (allocated(shgradtheta)) deallocate(shgradtheta)
    if (allocated(polynomq)) deallocate(polynomq)
    if (allocated(dpolynomq)) deallocate(dpolynomq)
    if (allocated(polynomg)) deallocate(polynomg)
    if (allocated(pbar)) deallocate(pbar)
    if (allocated(vbar)) deallocate(vbar)
    if (allocated(wbar)) deallocate(wbar)

    !ALLOCATE ARRAYS
    ntermsh = mmax*(2*nmax - mmax + 1) + nmax + 1
    allocate(    epochgrid(0:nepoch-1) )
    allocate(       coeff0(0:nterm-1, 0:nepoch-1, 0:5) )
    allocate(      qcoeff0(0:nterm-1, 0:2) )
    allocate(      gcoeff0(0:nterm-1, 0:2) )
    allocate(      xqcoeff(0:ntermsh-1) )
    allocate(      yqcoeff(0:ntermsh-1) )
    allocate(      zqcoeff(0:ntermsh-1) )
    allocate( dxqdrhocoeff(0:ntermsh-1) )
    allocate( dyqdrhocoeff(0:ntermsh-1) )
    allocate( dzqdrhocoeff(0:ntermsh-1) )
    allocate(      xgcoeff(0:ntermsh-1) )
    allocate(      ygcoeff(0:ntermsh-1) )
    allocate(      zgcoeff(0:ntermsh-1) )
    allocate(           sh(0:ntermsh-1) )
    allocate(  shgradtheta(0:ntermsh-1) )
    allocate(    shgradphi(0:ntermsh-1) )
    allocate(     polynomq(0:lmax) )
    allocate(    dpolynomq(0:lmax) )
    allocate(     polynomg(0:lmax) )
    allocate(         pbar(0:nmax, 0:mmax) )
    allocate(         vbar(0:nmax, 0:mmax) )
    allocate(         wbar(0:nmax, 0:mmax) )
    polynomq(0) = 1D0
    dpolynomq(0) = 0D0
    polynomg(0) = 1D0
    pbar = 0
    vbar = 0
    wbar = 0
    call alfbasisinit(nmax,mmax)

    return

end subroutine allocatearrays

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

subroutine apxg2q(glat,glon,alt,vecflagin,qlatout,qlonout,f1,f2,f)

    use apxshmodule

    implicit none

    real(4), intent(in)         :: glat, glon, alt
    integer(4), intent(in)      :: vecflagin
    real(4), intent(out)        :: qlatout, qlonout
    real(4), intent(out)        :: f1(1:2), f2(1:2), f

    integer(4)               :: i, l, iterm, itermsh
    real(8)                  :: theta, phi
    real(8)                  :: costheta, Jtemp, J, r

    !INITIALIZE OUTPUT ARGUMENTS
    qlat = missing
    qlon = missing
    f1 = missing
    f2 = missing
    f = missing

    !CHECK THAT COEFFICIENTS ARE LOADED
    if (loadflag) then
      print *, 'No coefficients loaded. Call LOADAPXSH first.'
      return
    endif

    !COPY INPUT FLAG
    vecflag = vecflagin

    !COMPUTE SPATIAL COEFFICIENTS AND THEIR VERTICAL GRADIENTS FOR THE SPECIFIED HEIGHT
    if (alt .ne. altlastq) then
      h = dble(alt)
      Reph = Re + h
      rho = Re / Reph
      do l = 1, lmax
        polynomq(l) = polynomq(l-1)*rho
        dpolynomq(l) = dble(l)*polynomq(l-1)
      enddo
      xqcoeff = 0
      yqcoeff = 0
      zqcoeff = 0
      dxqdrhocoeff = 0
      dyqdrhocoeff = 0
      dzqdrhocoeff = 0
      do itermsh = 0, ntermsh-1
        do l = 0, lmax
          iterm = l*ntermsh + itermsh
          xqcoeff(itermsh) = xqcoeff(itermsh) + qcoeff0(iterm,0)*polynomq(l)
          yqcoeff(itermsh) = yqcoeff(itermsh) + qcoeff0(iterm,1)*polynomq(l)
          zqcoeff(itermsh) = zqcoeff(itermsh) + qcoeff0(iterm,2)*polynomq(l)
          dxqdrhocoeff(itermsh) = dxqdrhocoeff(itermsh) + qcoeff0(iterm,0)*dpolynomq(l)
          dyqdrhocoeff(itermsh) = dyqdrhocoeff(itermsh) + qcoeff0(iterm,1)*dpolynomq(l)
          dzqdrhocoeff(itermsh) = dzqdrhocoeff(itermsh) + qcoeff0(iterm,2)*dpolynomq(l)
        enddo
      enddo
      altlastq = alt
    endif

    !COMPUTE SPHERICAL HARMONICS
    theta = (90D0 - dble(glat)) * dtor
    phi = glon * dtor
    call shcalc(theta,phi)

    !COMPUTE AND RETURN QUASI-DIPOLE COORDINATES
    xq = dot_product(sh, xqcoeff)
    yq = dot_product(sh, yqcoeff)
    zq = dot_product(sh, zqcoeff)
    qlon = datan2(yq,xq)
    cosqlon = dcos(qlon)
    sinqlon = dsin(qlon)
    qlat = datan2(zq,dsqrt(xq*xq + yq*yq))
    cosqlat = dcos(qlat)
    sinqlat = dsin(qlat)
    qlonout = sngl(qlon / dtor)
    qlatout = sngl(qlat / dtor)

    !BASE VECTOR CALCULATIONS
    if (vecflag .ne. 0) then

      !COMPUTE HORIZONTAL GRADIENT KERNELS OF QUASI-DIPOLE CARTESIAN COORDINATES
      xqgrad(1) = dot_product(shgradphi, xqcoeff)
      yqgrad(1) = dot_product(shgradphi, yqcoeff)
      zqgrad(1) = dot_product(shgradphi, zqcoeff)
      xqgrad(2) = -dot_product(shgradtheta, xqcoeff)
      yqgrad(2) = -dot_product(shgradtheta, yqcoeff)
      zqgrad(2) = -dot_product(shgradtheta, zqcoeff)

      !COMPUTE ADJUSTMENTS TO GRADIENTS FOR ELLIPSOIDAL EARTH
      costheta = dcos(theta)
      Jtemp = 1D0 - ecc2*costheta*costheta
      r = Req / dsqrt(Jtemp)
      J = (h + (1 - ecc2) * r / Jtemp) / Reph
      r = (h + r) / Reph

      !COMPUTE HORIZONTAL GEODETIC GRADIENTS OF QD LATITUDE AND LONGITUDE
      qlatgrad(1) = (-( cosqlon*xqgrad(1) + sinqlon*yqgrad(1))*sinqlat + cosqlat*zqgrad(1)) / r
      qlatgrad(2) = (-( cosqlon*xqgrad(2) + sinqlon*yqgrad(2))*sinqlat + cosqlat*zqgrad(2)) / J
      qlongrad(1) =   (-sinqlon*xqgrad(1) + cosqlon*yqgrad(1)) / r
      qlongrad(2) =   (-sinqlon*xqgrad(2) + cosqlon*yqgrad(2)) / J

      !RETURN QUASI-DIPOLE BASE VECTORS
      f1(1) = sngl( qlatgrad(2))
      f1(2) = sngl(-qlatgrad(1))
      f2(1) = sngl(-qlongrad(2))
      f2(2) = sngl(qlongrad(1))
      f = f1(1)*f2(2) - f1(2)*f2(1)

    endif

    return

end subroutine apxg2q

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

subroutine apxg2all(glat,glon,alt,hr,vecflagin, &
                    qlatout,qlonout, mlat,mlon, f1,f2,f, d1,d2,d3,d, e1,e2,e3)

    use apxshmodule

    implicit none

    real(4), intent(in)         :: glat, glon, alt, hr
    integer(4), intent(in)      :: vecflagin
    real(4), intent(out)        :: qlatout, qlonout, mlat, mlon
    real(4), intent(out)        :: f1(1:2), f2(1:2), f
    real(4), intent(out)        :: d1(1:3), d2(1:3), d3(1:3), d
    real(4), intent(out)        :: e1(1:3), e2(1:3), e3(1:3)

    integer(4)               :: i
    real(8)                  :: cosmlat, Rrat, denom

    if (loadflag) then
      print *, 'No coordinates loaded. Call LOADAPXSH first.'
      stop
    endif

    !INITIALIZE OUTPUT ARGUMENTS
    mlat = missing
    mlon = missing
    d1 = missing
    d2 = missing
    d3 = missing
    d = missing
    e1 = missing
    e2 = missing
    e3 = missing

    !COMPUTE QUASI-DIPOLE COORDINATES
    call apxg2q(glat,glon,alt,vecflagin,qlatout,qlonout,f1,f2,f)
    if (qlatout .eq. missing) return

    !COMPUTE AND RETURN MODIFIED APEX COORDINATES
    mlon = qlonout
    Rrat = (Re + dble(hr)) / Reph
    cosmlat = cosqlat * dsqrt(Rrat)
    if (cosmlat .le. 1D0) then
      mlat = sngl(dacos(cosmlat) / dtor)
      if (qlat .lt. 0D0) mlat = -mlat
    endif

    !MODIFIED APEX BASE VECTOR CALCULATIONS
    if (vecflag .ne. 0) then

      !COMPUTE VERTICAL GRADIENTS OF QUASI-DIPOLE COORDINATES
      xqgrad(3) = dot_product(sh, dxqdrhocoeff)
      yqgrad(3) = dot_product(sh, dyqdrhocoeff)
      zqgrad(3) = dot_product(sh, dzqdrhocoeff)
      qlatgrad(3) = rho*((cosqlon*xqgrad(3) + sinqlon*yqgrad(3))*sinqlat - cosqlat*zqgrad(3))
      qlongrad(3) = rho* (sinqlon*xqgrad(3) - cosqlon*yqgrad(3))

      !COMPUTE MA BASE VECTORS
      denom = 4D0/Rrat - 3D0*cosqlat*cosqlat
      if (denom .le. 0) return
      denom = dsqrt(denom)
      do i = 1, 3
        d1(i) = sngl(Rrat*dsqrt(Rrat)*qlongrad(i))
        d2(i) = sngl(-2D0*Rrat*sinqlat*qlatgrad(i)/denom)
      enddo
      d2(3) = d2(3) - sngl(Rrat*cosqlat/denom)
      e3(1) = d1(2)*d2(3) - d1(3)*d2(2)
      e3(2) = d1(3)*d2(1) - d1(1)*d2(3)
      e3(3) = d1(1)*d2(2) - d1(2)*d2(1)
      d = e3(1)**2 + e3(2)**2 + e3(3)**2
      do i=1,3
        d3(i) = e3(i)/d
      enddo
      d = sqrt(d)
      e1(1) = d2(2)*d3(3) - d2(3)*d3(2)
      e1(2) = d2(3)*d3(1) - d2(1)*d3(3)
      e1(3) = d2(1)*d3(2) - d2(2)*d3(1)
      e2(1) = d3(2)*d1(3) - d3(3)*d1(2)
      e2(2) = d3(3)*d1(1) - d3(1)*d1(3)
      e2(3) = d3(1)*d1(2) - d3(2)*d1(1)

    endif

    return

end subroutine apxg2all

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

subroutine apxq2g(qlat0,qlon0,alt,prec,glatout,glonout,error)

    use apxshmodule

    implicit none

    real(4), intent(in)         :: qlat0, qlon0, alt, prec
    real(4), intent(out)        :: glatout, glonout, error

    integer(4)               :: l, iterm, itermsh, vecflagin, niter
    real(4)                  :: qlatout, qlonout, errorlast
    real(4)                  :: mlon, f1(1:2), f2(1:2), f
    real(8)                  :: theta, phi
    real(8)                  :: sinqlon0, cosqlon0, sinqlat0, cosqlat0, cotqlat0, zfact
    real(8)                  :: glat, glon
    real(8)                  :: xg, yg, zg, cosglat
    real(8)                  :: xggrad(1:2), yggrad(1:2), zggrad(1:2)
    real(8)                  :: delqlon, delqlat, delxq, delyq, denom
    real(8)                  :: coserror

    if (loadflag) then
      print *, 'No coordinates loaded. Call LOADAPXSH first.'
      stop
    endif

    !COMPUTE SPATIAL COEFFICIENTS FOR THE SPECIFIED HEIGHT
    if (alt .ne. altlastg) then
      rho = Re / (Re + dble(alt))
      do l = 1, lmax
        polynomg(l) = polynomg(l-1)*rho
      enddo
      xgcoeff = 0
      ygcoeff = 0
      zgcoeff = 0
      do itermsh = 0, ntermsh-1
        do l = 0, lmax
          iterm = l*ntermsh + itermsh
          xgcoeff(itermsh) = xgcoeff(itermsh) + gcoeff0(iterm,0)*polynomg(l)
          ygcoeff(itermsh) = ygcoeff(itermsh) + gcoeff0(iterm,1)*polynomg(l)
          zgcoeff(itermsh) = zgcoeff(itermsh) + gcoeff0(iterm,2)*polynomg(l)
        enddo
      enddo
      altlastg = alt
    endif

    !COMPUTE SPHERICAL HARMONICS
    phi = dble(qlon0) * dtor
    theta = (90D0 - dble(qlat0)) * dtor
    vecflag = 1
    call shcalc(theta,phi)

    !COMPUTE INITIAL GEODETIC COORDINATES
    xg = dot_product(sh, xgcoeff)
    yg = dot_product(sh, ygcoeff)
    zg = dot_product(sh, zgcoeff)
    glon = datan2(yg,xg)
    glat = datan2(zg,dsqrt(xg*xg + yg*yg))
    glatout = sngl(glat / dtor)
    glonout = sngl(glon / dtor)
    error = missing

    !COMPUTE REFINED GEODETIC COORDINATES
    if (prec .ge. 0) then
      xggrad(1) = dot_product(shgradphi, xgcoeff)
      yggrad(1) = dot_product(shgradphi, ygcoeff)
      zggrad(1) = dot_product(shgradphi, zgcoeff)
      xggrad(2) = -dot_product(shgradtheta, xgcoeff)
      yggrad(2) = -dot_product(shgradtheta, ygcoeff)
      zggrad(2) = -dot_product(shgradtheta, zgcoeff)
      vecflagin = 1
      call apxg2q(glatout,glonout,alt,vecflagin,qlatout,qlonout,f1,f2,f)
      cosqlat0 = dsin(theta)
      sinqlat0 = dcos(theta)
      coserror = sinqlat0*sinqlat+cosqlat0*cosqlat*cos(phi-qlon)
      if (coserror .gt. 1) coserror = 1D0
      error = sngl(acos(coserror) / dtor)
      niter = 0
      errorlast = 9999.0
      !OUTSIDE OF QD POLES
      if ((abs(qlat0) .lt. 88.0) .and. (error .gt. prec)) then
        vecflagin = 0
        do while ((error .gt. prec) .and. (niter .lt. 10) .and. (error .lt. 1.3*errorlast))
          delqlon = phi - qlon
          if (abs(delqlon) .gt. pi) delqlon = -sign(twopi-abs(delqlon),delqlon)
          delqlon = cosqlat0 * delqlon
          delqlat = pid2 - theta - qlat
          xg = xg + xggrad(1)*delqlon + xggrad(2)*delqlat
          yg = yg + yggrad(1)*delqlon + yggrad(2)*delqlat
          zg = zg + zggrad(1)*delqlon + zggrad(2)*delqlat
          glonout = sngl(datan2(yg,xg) / dtor)
          glatout = sngl(datan2(zg,dsqrt(xg*xg + yg*yg)) / dtor)
          call apxg2q(glatout,glonout,alt,vecflagin,qlatout,qlonout,f1,f2,f)
          coserror = sinqlat0*sinqlat+cosqlat0*cosqlat*cos(phi-qlon)
          if (coserror .gt. 1) coserror = 1D0
          errorlast = error
          error = sngl(acos(coserror) / dtor)
          niter = niter + 1
        enddo
      !NEAR QD POLES
      else if (error .gt. prec) then
        cosqlon0 = dcos(phi)
        sinqlon0 = dsin(phi)
        cotqlat0 = cosqlat0 / sinqlat0
        cosglat = dcos(glat)
        vecflagin = 1
        do while ((error .gt. prec) .and. (niter .lt. 10) .and. (error .lt. 1.3*errorlast))
          zfact = zq * cotqlat0
          delxq = zfact * cosqlon0 - xq
          delyq = zfact * sinqlon0 - yq
          denom = xqgrad(1)*yqgrad(2) - xqgrad(2)*yqgrad(1)
          glon = glon + (delxq*yqgrad(2) - delyq*xqgrad(2)) / denom / cosglat
          glat = glat + (delyq*xqgrad(1) - delxq*yqgrad(1)) / denom
          glonout = sngl(glon / dtor)
          glatout = sngl(glat / dtor)
          call apxg2q(glatout,glonout,alt,vecflagin,qlatout,qlonout,f1,f2,f)
          coserror = sinqlat0*sinqlat+cosqlat0*cosqlat*cos(phi-qlon)
          if (coserror .gt. 1) coserror = 1D0
          errorlast = error
          error = sngl(acos(coserror) / dtor)
          niter = niter + 1
        enddo
      endif
    endif

    return

end subroutine apxq2g

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

subroutine shcalc(theta,phi)

    use apxshmodule

    implicit none

    real(8), intent(in)      :: theta, phi

    integer(4)               :: n, m, i, i1
    real(8)                  :: mphi, cosmphi, sinmphi

    call alfbasis(nmax,mmax,theta,pbar,vbar,wbar)
    i = 0
    i1 = 0
    do n = 0, nmax
      sh(i) = pbar(n,0)
      shgradtheta(i1) =  vbar(n,0)
      shgradphi(i1) = 0
      i = i + 1
      i1 = i1 + 1
    enddo
    do m = 1, mmax
      mphi = dble(m) * phi
      cosmphi = dcos(mphi)
      sinmphi = dsin(mphi)
      do n = m, nmax
        sh(i)   = pbar(n,m) * cosmphi
        sh(i+1) = pbar(n,m) * sinmphi
        i = i + 2
      enddo
      if (vecflag .ne. 0) then
        do n = m, nmax
          shgradtheta(i1)   =  vbar(n,m) * cosmphi
          shgradtheta(i1+1) =  vbar(n,m) * sinmphi
          shgradphi(i1)     = -wbar(n,m) * sinmphi
          shgradphi(i1+1)   =  wbar(n,m) * cosmphi
          i1 = i1 + 2
        enddo
      endif
    enddo

end subroutine shcalc

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

module alfbasismodule

    implicit none

    integer(4)           :: nmax0
    integer(4)           :: mmax0
    real(8), allocatable :: anm(:,:)
    real(8), allocatable :: cm(:)
    real(8), allocatable :: bnm(:,:)
    real(8), allocatable :: dnm(:,:)
    real(8), allocatable :: en(:)
    real(8), allocatable :: marr(:)
    real(8), allocatable :: narr(:)

end module alfbasismodule

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

subroutine alfbasisinit(nmax0in,mmax0in)

    use alfbasismodule

    implicit none

    integer(4), intent(in) :: nmax0in, mmax0in
    integer(8)             :: n, m

    nmax0 = nmax0in
    mmax0 = mmax0in
    if (allocated(anm)) deallocate(anm, bnm, cm, dnm, en, marr, narr)
    allocate( anm(0:nmax0, 0:mmax0) )
    allocate( bnm(0:nmax0, 0:mmax0) )
    allocate( cm(0:mmax0) )
    allocate( dnm(0:nmax0, 0:mmax0) )
    allocate( en(0:nmax0) )
    allocate( marr(0:mmax0) )
    allocate( narr(0:nmax0) )

    do n = 1, nmax0
      narr(n) = dble(n)
      en(n)    = dsqrt(dble(n*(n+1)))
      anm(n,0) = dsqrt( dble((2*n-1)*(2*n+1)) ) / narr(n)
      bnm(n,0) = dsqrt( dble((2*n+1)*(n-1)*(n-1)) / dble(2*n-3) ) / narr(n)
    enddo
    do m = 1, mmax0
      marr(m) = dble(m)
      cm(m)    = dsqrt(dble(2*m+1)/dble(2*m))
      do n = m+1, nmax0
        anm(n,m) = dsqrt( dble((2*n-1)*(2*n+1)) / dble((n-m)*(n+m)) )
        bnm(n,m) = dsqrt( dble((2*n+1)*(n+m-1)*(n-m-1)) / dble((n-m)*(n+m)*(2*n-3)) )
        dnm(n,m) = dsqrt( dble((n-m)*(n+m)*(2*n+1)) / dble(2*n-1) )
      enddo
    enddo

    return

end subroutine alfbasisinit

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

subroutine alfbasis(nmax,mmax,theta,P,V,W)

    use alfbasismodule

    implicit none

    integer(4), intent(in)  :: nmax, mmax
    real(8), intent(in)     :: theta
    real(8), intent(out)    :: P(0:nmax,0:mmax)
    real(8), intent(out)    :: V(0:nmax,0:mmax)
    real(8), intent(out)    :: W(0:nmax,0:mmax)

    integer(4)              :: n, m
    real(8)                 :: x, y
    real(8), parameter      :: p00=0.70710678118654746D0

    P(0,0) = p00
    x = dcos(theta)
    y = dsin(theta)
    do m = 1, mmax
      W(m,m) = cm(m) * P(m-1,m-1)
      P(m,m) = y * W(m,m)
      do n = m+1, nmax
        W(n,m) = anm(n,m) * x * W(n-1,m) - bnm(n,m) * W(n-2,m)
        P(n,m) = y * W(n,m)
        V(n,m) = narr(n) * x * W(n,m) - dnm(n,m) * W(n-1,m)
        W(n-2,m) = marr(m) * W(n-2,m)
      enddo
      W(nmax-1,m) = marr(m) * W(nmax-1,m)
      W(nmax,m) = marr(m) * W(nmax,m)
      V(m,m) = x * W(m,m)
    enddo
    P(1,0) = anm(1,0) * x * P(0,0)
    V(1,0) = -en(1) * P(1,1)
    do n = 2, nmax
      P(n,0) = anm(n,0) * x * P(n-1,0) - bnm(n,0) * P(n-2,0)
      V(n,0) = -en(n) * P(n,1)
    enddo

    return

end subroutine alfbasis

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


PROGRAM hello
use num_types
use vector_matrix_utilities
implicit none

real(dp) mat(1000000,3,3)
real(dp) ans(3,3)
integer i, n, nM
integer, allocatable :: state(:)
logical errflag
real(dp) start, stop

nM = 1000000
!nM = 10
call random_seed(size=n)
allocate(state(n))
state = 20210518
call random_seed(put=state)
call random_number(mat)
call cpu_time(start)
do i = 1,nM
    call matrix_inverse(mat(i,:,:),ans,err_=errflag,eps_=1e-8_dp)
    if (errflag) then
        print*,"epsilon triggered stop"
        print*, i
        print*,matmul(mat(i,:,:),ans)
        stop
    endif
enddo
call cpu_time(stop)
print*,"Time/inverse: ",(stop - start)/nM
end


      double precision function poster(nparm,parm)
c user-supplied function to evaluate logposterior
c first time: reads data and forms crude parameter estimates
      implicit integer (a-z)
      parameter(mxparm=200,mxn=500)
      double precision parm(mxparm), logpost
      double precision y1(mxn), y2(mxn), ddet(5), ldet(5), sigmat(5,3),
     1     delta1, delta2, phi, dev1, dev2, sig, sigphi, sigsquig
      integer inc1(mxn), inc2(mxn), incs(mxn)
      character cyear*4, file*13
      data ncalls, n /0, 0/

      ncalls = ncalls+1
      if (nparm.eq.-1) then
c     first time: read any data and starting values
c        read (5,*) cyear
c        file = "metrop" // cyear // ".inp"
         open (10, file="metrop1920.inp")
         read (10,*) year, n
         read (10,*) (y1(i), y2(i), inc1(i), inc2(i), i=1,n)
         do i=1,n
            incs(i) = 1 + abs(inc1(i)) + 2*abs(inc2(i))
            if (inc1(i)*inc2(i).eq.-1) incs(i) = 5
         end do
c     starting values
         parm(1) = .5
         parm(2) = .5
         parm(3) = .05
         parm(4) = log(.06)
         parm(5) = log(parm(3))
         parm(6) = log(.1)
         nparm = 6
      end if

      delta1 = parm(1)
      delta2 = parm(2)
      phi = parm(3)
      sig = dexp(2.*parm(4))
      sigphi = dexp(2.*parm(5))
      sigsquig = dexp(2.*parm(6))
c     1:  open, open
c     2:  inc, open
c     3:  open, inc
c     4:  inc, inc
c     5:  inc, inc (change of party; can only occur with special elections)
      do j=1,5
         sigmat(j,1) = sig + sigsquig
         sigmat(j,2) = sigsquig
         sigmat(j,3) = sig + sigsquig
      end do
      sigmat(2,1) = sigmat(2,1) + sigphi
      sigmat(4,1) = sigmat(4,1) + sigphi
      sigmat(5,1) = sigmat(5,1) + sigphi

      sigmat(3,3) = sigmat(3,3) + sigphi
      sigmat(4,3) = sigmat(4,3) + sigphi
      sigmat(5,3) = sigmat(5,3) + sigphi

      sigmat(4,2) = sigmat(4,2) + sigphi

      do j=1,5
         ddet(j) = sigmat(j,1)*sigmat(j,3) - sigmat(j,2)**2.
         ldet(j) = dlog(ddet(j))
      end do
      logpost = .5*(dlog(sigphi) + dlog(sigsquig))
      do i=1,n
         ii = incs(i)
         dev1 = y1(i) - delta1 - phi*inc1(i)
         dev2 = y2(i) - delta2 - phi*inc2(i)
         logpost = logpost -.5*ldet(ii) - .5*(sigmat(ii,3)*dev1**2. +
     1      sigmat(ii,1)*dev2**2. - 2*sigmat(ii,2)*dev1*dev2)/ddet(ii)
      end do
      write (6,200) ncalls, (parm(i),i=1,6), logpost
 200  format (i5, 6f9.3, f10.2)
      poster = logpost
      return
      end


       SUBROUTINE Atmosphere(alt, sigma, delta, theta)
!   -------------------------------------------------------------------------
! PURPOSE - Compute the properties of the 1976 standard atmosphere to 86 km.
! AUTHOR - Ralph Carmichael, Public Domain Aeronautical Software
! NOTE - If alt > 86, the values returned will not be correct, but they will
!   not be too far removed from the correct values for density.
!   The reference document does not use the terms pressure and temperature
!   above 86 km.
       IMPLICIT NONE
!============================================================================
!     A R G U M E N T S                                                     |
!============================================================================
       REAL,INTENT(IN)::  alt  ! geometric altitude, km.
       REAL,INTENT(OUT):: sigma! density/sea-level standard density
       REAL,INTENT(OUT):: delta! pressure/sea-level standard pressure
       REAL,INTENT(OUT):: theta! temperature/sea-level standard temperature
!============================================================================
!     L O C A L   C O N S T A N T S                                         |
!============================================================================
       REAL,PARAMETER:: REARTH = 6369.0 ! radius of the Earth (km)
       REAL,PARAMETER:: GMR = 34.163195 ! gas constant
       INTEGER,PARAMETER:: NTAB=8! number of entries in the defining tables
!============================================================================
!     L O C A L   V A R I A B L E S                                         |
!============================================================================
       INTEGER:: i,j,k    ! counters
       REAL:: h           ! geopotential altitude (km)
       REAL:: tgrad, tbase! temperature gradient and base temp of this layer
       REAL:: tlocal      ! local temperature
       REAL:: deltah      ! height above base of this layer
!============================================================================
!     L O C A L   A R R A Y S   ( 1 9 7 6   S T D.  A T M O S P H E R E )   |
!============================================================================
       REAL,DIMENSION(NTAB),PARAMETER:: htab= (/0.0, 11.0, 20.0, 32.0, 47.0, 51.0, 71.0,84.852/)
       REAL,DIMENSION(NTAB),PARAMETER:: ttab=  (/288.15, 216.65, 216.65, 228.65, 270.65, 270.65, 214.65, 186.946/)
       REAL,DIMENSION(NTAB),PARAMETER:: ptab=  (/1.0, 2.233611e-1, &
5.403295e-2, 8.5666784e-3, 1.0945601e-3, 6.6063531e-4, 3.9046834e-5, 3.68501e-6/)
       REAL,DIMENSION(NTAB),PARAMETER:: gtab=  (/-6.5, 0.0, 1.0, 2.8, 0.0, -2.8, -2.0, 0.0/)
!----------------------------------------------------------------------------
       h=alt*REARTH/(alt+REARTH)! convert geometric to geopotential altitude

       i=1
       j=NTAB                     ! setting up for=binary search
       DO
       k=(i+j)/2
       IF (h < htab(k)) THEN
        j=k
       ELSE
        i=k
       END IF
       IF (j <= i+1) EXIT
       END DO

       tgrad=gtab(i)              ! i will be in 1...NTAB-1
       tbase=ttab(i)
       deltah=h-htab(i)
       tlocal=tbase+tgrad*deltah
       theta=tlocal/ttab(1)            ! temperature ratio

       IF (tgrad == 0.0) THEN        ! pressure ratio
         delta=ptab(i)*EXP(-GMR*deltah/tbase)
       ELSE
         delta=ptab(i)*(tbase/tlocal)**(GMR/tgrad)
       END IF

       sigma=delta/theta            ! density ratio
       RETURN
       END Subroutine Atmosphere


*DECK DSINDG
      DOUBLE PRECISION FUNCTION DSINDG (X)
C***BEGIN PROLOGUE  DSINDG
C***PURPOSE  Compute the sine of an argument in degrees.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4A
C***TYPE      DOUBLE PRECISION (SINDG-S, DSINDG-D)
C***KEYWORDS  DEGREES, ELEMENTARY FUNCTIONS, FNLIB, SINE, TRIGONOMETRIC
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DSINDG(X) calculates the double precision sine for double
C precision argument X where X is in degrees.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DSINDG
      DOUBLE PRECISION X, RADDEG
      SAVE RADDEG
      DATA RADDEG / 0.0174532925 1994329576 9236907684 886 D0 /
C***FIRST EXECUTABLE STATEMENT  DSINDG
      DSINDG = SIN (RADDEG*X)
C
      IF (MOD(X,90.D0).NE.0.D0) RETURN
      N = ABS(X)/90.D0 + 0.5D0
      N = MOD (N, 2)
      IF (N.EQ.0) DSINDG = 0.D0
      IF (N.EQ.1) DSINDG = SIGN (1.0D0, DSINDG)
C
      RETURN
      END


      subroutine gaussj(a,n,np)
C-----------------------------------------------------------------------
C     Gauss-Jordan elimination routine taken from Numerical Recipes
C     online book: www.nr.com.
C     Slightly modified to deal with double precision values.
C-----------------------------------------------------------------------
      implicit none
      integer n,nmax,np
      real*8 a(np,np)
      parameter (nmax=600)
      integer i,icol,irow,j,k,l,l1,indxc(nmax),indxr(nmax),ipiv(nmax)
      real*8 big,dum,pivinv
      do j=1,n
         ipiv(j)=0
      enddo
      do i=1,n
         big=0.d0
         do j=1,n
            if(ipiv(j).ne.1)then
               do k=1,n
                  if(ipiv(k).eq.0)then
                     if(dabs(a(j,k)).ge.big)then
                        big=dabs(a(j,k))
                        irow=j
                        icol=k
                     endif
                  endif
               enddo
            endif
         enddo
         ipiv(icol)=ipiv(icol)+1
         if(irow.ne.icol)then
            do l=1,n
               dum=a(irow,l)
               a(irow,l)=a(icol,l)
               a(icol,l)=dum
            enddo
         endif
         indxr(i)=irow
         indxc(i)=icol
         if(a(icol,icol).eq.0.d0)then
            write(6,'(''Singular matrix in gaussj'')')
            stop
         endif
         pivinv=1.d0/a(icol,icol)
         a(icol,icol)=1.d0
         do l=1,n
            a(icol,l)=a(icol,l)*pivinv
         enddo
         do l1=1,n
            if(l1.ne.icol)then
               dum=a(l1,icol)
               a(l1,icol)=0.d0
               do l=1,n
                  a(l1,l)=a(l1,l)-a(icol,l)*dum
               enddo
            endif
         enddo
      enddo
      do l=n,1,-1
         if(indxr(l).ne.indxc(l))then
            do k=1,n
               dum=a(k,indxr(l))
               a(k,indxr(l))=a(k,indxc(l))
               a(k,indxc(l))=dum
            enddo
         endif
      enddo
      return
      end


	SUBROUTINE CLBBOX  ( xx1, yy1, xx2, yy2, x0, y0, xx, yy, iret )
C************************************************************************
C* CLBBOX								*
C*									*
C* This subroutine returns a point on the edge of a rectangle whose	*
C* vertices are given.  The point lies on the line from interior point  *
C* (x0, y0) to (xx, yy) outside the rectangle.  The point (xx, yy) is	*
C* effectively moved to the edge of the rectangle.			*
C*									*
C* Note:  It must be that xx1 < xx2 and yy1 < yy2.			*
C*									*
C* CLBBOX  ( XX1, YY1, XX2, YY2, X0, Y0, XX, YY, IRET )			*
C*									*
C* Input parameters:							*
C*	XX1		REAL		Lower left corner x coordinate  *
C*	YY1		REAL		Lower left corner y coordinate 	*
C*	XX2		REAL		Upper right corner x coordinate *
C*	YY2		REAL		Upper right corner y coordinate *
C*	X0		REAL		Interior point x coordinate	*
C*	Y0		REAL		Interior point y coordinate	*
C*									*
C* Input and Output parameters:						*
C*	XX		REAL		Input x coord. of exterior point*
C*					Output x coord. of edge point	*
C*	YY		REAL		Input y coord. of exterior point*
C*					Output y coord. of edge point	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* K. Brill/NMC       	01/92						*
C* K. Brill/NMC		03/93	Treat cases of zero slopes		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
C------------------------------------------------------------------------
	iret = 0
C
C*	Translate the origin to (x0, y0).
C
	x1 = xx1 - x0
	y1 = yy1 - y0
	x2 = xx2 - x0
	y2 = yy2 - y0
	x  = xx  - x0
	y  = yy  - y0
C
C*	Check special cases of zero slopes.
C
        IF ( x .eq. 0 ) THEN
            xx = x0
            IF ( y .ge. 0 ) THEN
                yy = yy2
            ELSE
                yy = yy1
            END IF
            RETURN
        END IF
        IF ( y .eq. 0 ) THEN
            yy = y0
            IF ( x .ge. 0 ) THEN
                xx = xx2
            ELSE
                xx = xx1
            END IF
            RETURN
        END IF
C
C*	Compute slopes of lines.
C
	ym = y / x
	xm = x / y
C
C*	Check each bounding edge for a crossing.
C
	IF ( x .lt. x1 ) THEN
	    yt = ym * x1
	    IF ( yt .ge. y1 .and. yt .le. y2 ) THEN
		xx = x1 + x0
		yy = yt + y0
		RETURN
	    END IF
	END IF
	IF ( x .gt. x2 ) THEN
	    yt = ym * x2
	    IF ( yt .ge. y1 .and. yt .le. y2 ) THEN
		xx = x2 + x0
		yy = yt + y0
		RETURN
	    END IF
	END IF
	IF ( y .lt. y1 ) THEN
	    xt = xm * y1
	    IF ( xt .ge. x1 .and. xt .le. x2 ) THEN
		xx = xt + x0
		yy = y1 + y0
		RETURN
	    END IF
	END IF
	IF ( y .gt. y2 ) THEN
	    xt = xm * y2
	    IF ( xt .ge. x1 .and. xt .le. x2 ) THEN
		xx = xt + x0
		yy = y2 + y0
	    END IF
	END IF
	RETURN
	END


c************************************************************************
c  THIS FILE CONTAINS THE DEFINITIONS OF USEFUL FUNCTIONS OF MOMENTA:
c
c  DOT(p1,p2)         : 4-Vector Dot product
c  R2(p1,p2)          : distance in eta,phi between two particles
c  SumDot(P1,P2,dsign): invariant mass of 2 particles
c  rap(p)             : rapidity of particle in the lab frame (p in CM frame)
C  RAP2(P)            : rapidity of particle in the lab frame (p in lab frame)
c  DELTA_PHI(P1, P2)  : separation in phi of two particles
c  ET(p)              : transverse energy of particle
c  PT(p)              : transverse momentum of particle
c  DJ(p1,p2)          : y*S (Durham) value for two partons
c  DJB(p1,p2)         : mT^2=m^2+pT^2 for one particle
c  PYJB(p1,p2)        : The Pythia ISR pT^2=(1-x)*Q^2
c  DJ2(p1,p2)         : scalar product squared
c  threedot(p1,p2)    : 3-vector Dot product (accept 4 vector in entry)
c  rho                : |p| in lab frame
c  eta                : pseudo-rapidity
c  phi                : phi
c  four_momentum      : (theta,phi,rho,mass)-> 4 vector
c  four_momentum_set2 : (pt,eta,phi,mass--> 4 vector
c
c************************************************************************

      DOUBLE PRECISION FUNCTION R2(P1,P2)
c************************************************************************
c     Distance in eta,phi between two particles.
c************************************************************************
      IMPLICIT NONE
c
c     Arguments
c
      double precision p1(0:3),p2(0:3)
c
c     External
c
      double precision eta,DELTA_PHI
      external eta,delta_phi
c-----
c  Begin Code
c-----
      R2 = (DELTA_PHI(P1,P2))**2+(eta(p1)-eta(p2))**2
      RETURN
      END

      DOUBLE PRECISION FUNCTION SumDot(P1,P2,dsign)
c************************************************************************
c     Invarient mass of 2 particles
c************************************************************************
      IMPLICIT NONE
c
c     Arguments
c
      double precision p1(0:3),p2(0:3),dsign
c
c     Local
c
      integer i
      double precision ptot(0:3)
c
c     External
c
      double precision dot
      external dot
c-----
c  Begin Code
c-----

      do i=0,3
         ptot(i)=p1(i)+dsign*p2(i)
      enddo
      SumDot = dot(ptot,ptot)
      RETURN
      END

      DOUBLE PRECISION FUNCTION PtDot(P1,P2)
c************************************************************************
c     Pt of 2 particles
c************************************************************************
      IMPLICIT NONE
c
c     Arguments
c
      double precision p1(0:3),p2(0:3),dsign

c      write (*,*)'Px of particle 1: ',P1(1)
c      write (*,*)'Px of particle 2: ',P2(1)
c      write (*,*)'Py of particle 1: ',P1(2)
c      write (*,*)'Py of particle 2: ',P2(2)
c
      PtDot = (P1(1)+P2(1))**2+(P1(2)+P2(2))**2
      RETURN
      END

      DOUBLE PRECISION  FUNCTION rap(p)
c************************************************************************
c     Returns rapidity of particle in the lab frame
c************************************************************************
      IMPLICIT NONE
c
c     Arguments
c
      double precision  p(0:3)
c
c     Local
c
      double precision pm
c
c     Global
c
      include 'run.inc'
c-----
c  Begin Code
c-----
c      pm=dsqrt(p(1)**2+p(2)**2+p(3)**2)
      pm = p(0)
      rap = .5d0*dlog((pm+p(3))/(pm-p(3)))+
     $     .5d0*dlog(xbk(1)*ebeam(1)/(xbk(2)*ebeam(2)))
      end
      DOUBLE PRECISION  FUNCTION rap2(p)
c************************************************************************
c     Returns rapidity of particle in the lab frame
c************************************************************************
      IMPLICIT NONE
c
c     Arguments
c
      double precision  p(0:3)
c
c     Local
c
      double precision pm
c
c     Global
c
      include 'run.inc'
c-----
c  Begin Code
c-----
c      pm=dsqrt(p(1)**2+p(2)**2+p(3)**2)
      pm = p(0)
      rap2 = .5d0*dlog((pm+p(3))/(pm-p(3)))
      end

      DOUBLE PRECISION FUNCTION DELTA_PHI(P1, P2)
c************************************************************************
c     Returns separation in phi of two particles p1,p2
c************************************************************************
      IMPLICIT NONE
c
c     Arguments
c
      double precision p1(0:3),p2(0:3)
c
c     Local
c
      REAL*8 DENOM, TEMP
c-----
c  Begin Code
c-----
      DENOM = SQRT(P1(1)**2 + P1(2)**2) * SQRT(P2(1)**2 + P2(2)**2)
      TEMP = MAX(-0.99999999D0, (P1(1)*P2(1) + P1(2)*P2(2)) / DENOM)
      TEMP = MIN( 0.99999999D0, TEMP)
      DELTA_PHI = ACOS(TEMP)
      END

      double precision function et(p)
c************************************************************************
c     Returns transverse energy of particle
c************************************************************************
      IMPLICIT NONE
c
c     Arguments
c
      double precision p(0:3)
c
c     Local
c
      double precision pt
c-----
c  Begin Code
c-----
      pt = dsqrt(p(1)**2+p(2)**2)
      if (pt .gt. 0d0) then
         et = p(0)*pt/dsqrt(pt**2+p(3)**2)
      else
         et = 0d0
      endif
      end

      double precision function pt(p)
c************************************************************************
c     Returns transverse momentum of particle
c************************************************************************
      IMPLICIT NONE
c
c     Arguments
c
      double precision p(0:3)
c-----
c  Begin Code
c-----

      pt = dsqrt(p(1)**2+p(2)**2)

      return
      end

      double precision function DJ(p1,p2)
c***************************************************************************
c     Uses Durham algorythm to calculate the y value for two partons
c     If collision type is hh, hadronic jet measure is used
c       y_{ij} = 2min[p_{i,\perp}^2,p_{j,\perp}^2]/S
c                  (cosh(\eta_i-\eta_j)-cos(\phi_1-\phi_2))
c***************************************************************************
      implicit none
c
c     Arguments
c
      double precision p1(0:4),p2(0:4) ! 4 is mass**2
c
c     Global
c
      double precision D
      common/to_dj/D
c
c     Local
c

      include 'run.inc'

      double precision pt1,pt2,ptm1,ptm2,eta1,eta2,phi1,phi2,p1a,p2a,costh,sumdot
      integer j
c-----
c  Begin Code
c-----
      if ((lpp(1).eq.0).and.(lpp(2).eq.0)) then
         p1a = dsqrt(p1(1)**2+p1(2)**2+p1(3)**2)
         p2a = dsqrt(p2(1)**2+p2(2)**2+p2(3)**2)
         if (p1a*p2a .ne. 0d0) then
            costh = (p1(1)*p2(1)+p1(2)*p2(2)+p1(3)*p2(3))/(p1a*p2a)
            dj = 2d0*min(p1(0)**2,p2(0)**2)*(1d0-costh) !Durham
c            dj = 2d0*p1(0)*p2(0)*(1d0-costh)    !JADE
         else
            dj = 0d0
         endif
      else
        pt1 = p1(1)**2+p1(2)**2
        pt2 = p2(1)**2+p2(2)**2
        if (pt1.eq.0d0 .or. pt2.eq.0d0) then
           dj=0d0
           return
        endif
        p1a = dsqrt(pt1+p1(3)**2)
        p2a = dsqrt(pt2+p2(3)**2)
        eta1 = 0.5d0*log((p1a+p1(3))/(p1a-p1(3)))
        eta2 = 0.5d0*log((p2a+p2(3))/(p2a-p2(3)))
c        ptm1 = max((p1(0)-p1(3))*(p1(0)+p1(3)),0d0)
c        ptm2 = max((p2(0)-p2(3))*(p2(0)+p2(3)),0d0)
        dj = max(p1(4),p2(4))+min(pt1,pt2)*2d0*(cosh(eta1-eta2)-
     &     (p1(1)*p2(1)+p1(2)*p2(2))/dsqrt(pt1*pt2))/D**2

c$$$        write(*,'(a,5e16.4)')'Mom(1): ',(p1(j),j=1,3),p1(0),p1(4)
c$$$        write(*,'(a,5e16.4)')'Mom(2): ',(p2(j),j=1,3),p2(0),p2(4)
c$$$       print *,'pT1: ',sqrt(pt1),' pT2: ',sqrt(pt2)
c$$$       print *,'deltaR: ',sqrt(2d0*(cosh(eta1-eta2)-
c$$$     &     (p1(1)*p2(1)+p1(2)*p2(2))/dsqrt(pt1*pt2))/D**2),
c$$$     $      ' m: ',sqrt(SumDot(p1,p2,1d0))
c$$$      write(*,*) 'p1  = ',p1(0),',',p1(1),',',p1(2),',',p1(3)
c$$$      write(*,*) 'p1a = ',p1a,'eta1 = ',eta1
c$$$      write(*,*) 'p2  = ',p2(0),',',p2(1),',',p2(2),',',p2(3)
c$$$      write(*,*) 'p2a = ',p2a,'eta2 = ',eta2
c$$$      write(*,*) 'dj = ',dj
      endif
      end

      double precision function PYDJ(p1,p2)
c***************************************************************************
c     Uses Durham algorythm to calculate the y value for two partons
c     If collision type is hh, hadronic jet measure is used
c       y_{ij} = 2min[p_{i,\perp}^2,p_{j,\perp}^2]/S
c                  (cosh(\eta_i-\eta_j)-cos(\phi_1-\phi_2))
c***************************************************************************
      implicit none
c
c     Arguments
c
      double precision p1(0:4),p2(0:4) ! 4 is mass**2
c
c     Global
c
      double precision D
      common/to_dj/D
c
c     Local
c

      double precision SumDot
      external SumDot
c-----
c  Begin Code
c-----

      pydj = p1(0)*p2(0)/(p1(0)+p2(0))**2*SumDot(p1,p2,1d0)

      end

      double precision function DJ1(p1,p2)
c***************************************************************************
c     Uses single-sided Durham algorythm to calculate the y value for
c     parton radiated off non-parton
c     If collision type is hh, hadronic jet measure is used
c       y_{ij} = 2min[p_{i,\perp}^2,p_{j,\perp}^2]/S
c                  (cosh(\eta_i-\eta_j)-cos(\phi_1-\phi_2))
c***************************************************************************
      implicit none
c
c     Arguments
c
      double precision p1(0:3),p2(0:3)
c
c     Local
c

      include 'run.inc'

      double precision pt1,pt2,ptm1,eta1,eta2,phi1,phi2,p1a,p2a,costh
      integer j
c-----
c  Begin Code
c-----
      if ((lpp(1).eq.0).and.(lpp(2).eq.0)) then
      p1a = dsqrt(p1(1)**2+p1(2)**2+p1(3)**2)
      p2a = dsqrt(p2(1)**2+p2(2)**2+p2(3)**2)
      if (p1a*p2a .ne. 0d0) then
         costh = (p1(1)*p2(1)+p1(2)*p2(2)+p1(3)*p2(3))/(p1a*p2a)
         dj1 = 2d0*p1(0)**2*(1d0-costh)   !Durham
c         dj = 2d0*p1(0)*p2(0)*(1d0-costh)    !JADE
      else
         dj1 = 0d0
      endif
      else
        pt1 = p1(1)**2+p1(2)**2
        pt2 = p2(1)**2+p2(2)**2
        p1a = dsqrt(pt1+p1(3)**2)
        p2a = dsqrt(pt2+p2(3)**2)
        eta1 = 0.5d0*log((p1a+p1(3))/(p1a-p1(3)))
        eta2 = 0.5d0*log((p2a+p2(3))/(p2a-p2(3)))
        ptm1 = max((p1(0)-p1(3))*(p1(0)+p1(3)),0d0)
        dj1 = 2d0*ptm1*(cosh(eta1-eta2)-
     &     (p1(1)*p2(1)+p1(2)*p2(2))/dsqrt(pt1*pt2))
c     write(*,*) 'p1  = ',p1(0),',',p1(1),',',p1(2),',',p1(3)
c     write(*,*) 'pm1 = ',pm1,', p1a = ',p1a,'eta1 = ',eta1
c     write(*,*) 'p2  = ',p2(0),',',p2(1),',',p2(2),',',p2(3)
c     write(*,*) 'pm2 = ',pm2,', p2a = ',p2a,'eta2 = ',eta2
c     write(*,*) 'dj = ',dj
      endif
      end

      double precision function DJB(p1)
c***************************************************************************
c     Uses kt algorythm to calculate the y value for one parton
c       y_i    = p_{i,\perp}^2/S
c***************************************************************************
      implicit none
c
c     Arguments
c
      double precision p1(0:4)  ! 4 is mass**2
c
c     Local
c
      double precision pm1
      include 'run.inc'

c-----
c  Begin Code
c-----
c      pm1=max(p1(0)**2-p1(1)**2-p1(2)**2-p1(3)**2,0d0)
      if ((lpp(1).eq.0).and.(lpp(2).eq.0)) then
c        write(*,*) 'kin_functions.f: Error. No jet measure w.r.t. beam.'
c        djb = 0d0
         djb=max(p1(0),0d0)**2
      else
        djb = (p1(0)-p1(3))*(p1(0)+p1(3)) ! p1(1)**2+p1(2)**2+pm1
c        djb = p1(1)**2+p1(2)**2+p1(4)
      endif
      end

      double precision function PYJB(p2,p1,ppart,z)
c***************************************************************************
c     Calculate the Pythia ISR evolution pT2
c       pTE2 = (1-z)(Q2+m2), Q2=-(p1-p2)**2, z=sred/sprev
c     Note! p1 and p2 must have mass**2 component!
c***************************************************************************
      implicit none
c
c     Arguments
c
      double precision p1(0:4),p2(0:4),ppart(0:3),z
c
c     Local
c
      double precision sred,sprev,Q2,pstar(0:3),pm2
      integer i
      double precision dot,SumDot,PT

c-----
c  Begin Code
c-----
      pm2=0

      if(p1(4).gt.0.or.p2(4).gt.0.and..not.
     $   (p1(4).gt.0.and.p2(4).gt.0)) pm2=max(p1(4),p2(4))
      do i=0,3
        pstar(i)=p1(i)-p2(i)
      enddo
      Q2=-dot(pstar,pstar)+pm2
      if(Q2.lt.0)then
c        print *,'Error in PYJB: Q2 = ',Q2
        PYJB=1d30
        return
      endif
      sprev=SumDot(p1,ppart,1d0)
      sred=SumDot(pstar,ppart,1d0)

      if(sred.lt.1d0)then
        PYJB=1d20
        z=0d0
        return
      endif

      z=sred/sprev
      if(z.gt.1.or.z.lt.0)then
        print *,'Error in PYJB: z = ',z,', sprev = ',sprev,
     $     ', sred = ',sred,', Q2 = ',Q2
        stop
      endif
      PYJB=(1d0-z)*Q2
      end

      double precision function zclus(p2,p1,ppart)
c***************************************************************************
c     Calculate the Pythia ISR evolution pT2
c     z=sred/sprev
c***************************************************************************
      implicit none
c
c     Arguments
c
      double precision p1(0:3),p2(0:3),ppart(0:3)
c
c     Local
c
      double precision sred,sprev,pstar(0:3)
      integer i, nerr
      data nerr/0/
      double precision dot,SumDot

c-----
c  Begin Code
c-----
      do i=0,3
        pstar(i)=p1(i)-p2(i)
      enddo
      sprev=SumDot(p1,ppart,1d0)
      sred=SumDot(pstar,ppart,1d0)

      if(sred.lt.1d0)then
        zclus=0d0
        return
      endif

      zclus=sred/sprev
      if((zclus.gt.1.or.zclus.lt.0).and.nerr.le.10)then
        print *,'Error in zclus: zclus = ',zclus,', sprev = ',sprev,
     $     ', sred = ',sred
        nerr=nerr+1
        if(nerr.eq.100)
     $       print *,'No more zclus errors will be printed'
      endif

      return
      end

      double precision function DJ2(p1,p2)
c***************************************************************************
c     Uses Lorentz
c***************************************************************************
      implicit none
c
c     Arguments
c
      double precision p1(0:3),p2(0:3)
c
c     Local
c
      integer j
c
c     External
c
      double precision dot
c-----
c  Begin Code
c-----
      dj2 = dot(p1,p1)+2d0*dot(p1,p2)+dot(p2,p2)
      return
      end

      subroutine switchmom(p1,p,ic,jc,nexternal)
c**************************************************************************
c     Changes stuff for crossings
c**************************************************************************
      implicit none
      integer nexternal
      integer jc(nexternal),ic(nexternal)
      real*8 p1(0:3,nexternal),p(0:3,nexternal)
      integer i,j
c-----
c Begin Code
c-----
      do i=1,nexternal
         do j=0,3
            p(j,ic(i))=p1(j,i)
         enddo
      enddo
      do i=1,nexternal
         jc(i)=1
      enddo
      jc(ic(1))=-1
      jc(ic(2))=-1
      end

      subroutine switchhel(hel,hel1,ic,nexternal)
c**************************************************************************
c     Changes stuff for crossings
c**************************************************************************
      implicit none
      integer nexternal
      integer ic(nexternal),hel(nexternal),hel1(nexternal)
      integer i
c-----
c Begin Code
c-----
      do i=1,nexternal
         hel1(ic(i))=hel(i)
      enddo
      end

      double precision function dot(p1,p2)
C****************************************************************************
C     4-Vector Dot product
C****************************************************************************
      implicit none
      double precision p1(0:3),p2(0:3)
      dot=p1(0)*p2(0)-p1(1)*p2(1)-p1(2)*p2(2)-p1(3)*p2(3)

      if(dabs(dot).lt.1d-6)then ! solve numerical problem
         dot=0d0
      endif

      end
C*****************************************************************************
C*****************************************************************************
C                      MadWeight function
C*****************************************************************************
C*****************************************************************************

      double precision function threedot(p1,p2)
C****************************************************************************
C     3-Vector  product
C****************************************************************************
      implicit none
      double precision p1(0:3),p2(0:3)
      threedot=p1(1)*p2(1)+p1(2)*p2(2)+p1(3)*p2(3)

      end

      double precision function rho(p1)
C****************************************************************************
C     computes rho(p)=dsqrt (p(1)**2+p(2)**2+p(3)**2)
C****************************************************************************
      implicit none
      double precision p1(0:3)
      double precision  threedot
      external  threedot
c
      rho=dsqrt(threedot(p1,p1))

      end

      double precision function theta(p)
c************************************************************************
c     Returns polar angle of particle
c************************************************************************
      IMPLICIT NONE
c
c     Arguments
c
      double precision p(0:3)
c-----
c  Begin Code
c-----

      theta=dacos(p(3)/dsqrt(p(1)**2+p(2)**2+p(3)**2))

      return
      end

      double precision function eta(p)
c************************************************************************
c     Returns pseudo rapidity of particle
c************************************************************************
      IMPLICIT NONE
c
c     Arguments
c
      double precision p(0:3)
c
c     external
c
      double precision theta,tp,pi
      parameter (pi=3.14159265358979323846264338327950d0)
      external theta
c-----
c  Begin Code
c-----

      tp=theta(p)
      if (abs(tp).lt.1d-5) then
         eta=25d0
      elseif (abs(tp-pi).lt.1d-5) then
         eta=-25d0
      else
         eta=-dlog(dtan(theta(p)/2d0))
      endif

      return
      end

      subroutine four_momentum(theta,phi,rho,m,p)
c****************************************************************************
c     modif 3/07/07 : this subroutine defines 4-momentum from theta,phi,rho,m
c     with rho=px**2+py**2+pz**2
c****************************************************************************
c
c     argument
c
      double precision theta,phi,rho,m,p(0:3)
c
      P(1)=rho*dsin(theta)*dcos(phi)
      P(2)=rho*dsin(theta)*dsin(phi)
      P(3)=rho*dcos(theta)
      P(0)=dsqrt(rho**2+m**2)

      return
      end
      subroutine four_momentum_set2(eta,phi,PT,m,p)
c****************************************************************************
c     modif 16/11/06 : this subroutine defines 4-momentum from PT,eta,phi,m
c****************************************************************************
c
c     argument
c
      double precision PT,eta,phi,m,p(0:3)
c
c
c
      P(1)=PT*dcos(phi)
      P(2)=PT*dsin(phi)
      P(3)=PT*dsinh(eta)
      P(0)=dsqrt(p(1)**2+p(2)**2+p(3)**2+m**2)
      return
      end

      DOUBLE PRECISION  FUNCTION phi(p)
c************************************************************************
c     MODIF 16/11/06 : this subroutine defines phi angle
c                      phi is defined from 0 to 2 pi
c************************************************************************
      IMPLICIT NONE
c
c     Arguments
c
      double precision  p(0:3)
c
c     Parameter
c

      double precision pi,zero
      parameter (pi=3.141592654d0,zero=0d0)
c-----
c  Begin Code
c-----
c
      if(p(1).gt.zero) then
      phi=datan(p(2)/p(1))
      else if(p(1).lt.zero) then
      phi=datan(p(2)/p(1))+pi
      else if(p(2).GE.zero) then !remind that p(1)=0
      phi=pi/2d0
      else if(p(2).lt.zero) then !remind that p(1)=0
      phi=-pi/2d0
      endif
      if(phi.lt.zero) phi=phi+2*pi
      return
      end


subroutine PairwiseGame_AnyWeightedGraph(nodeChosenUpdate, payoffUpdate, networkMain)
    use global
    implicit none
    type(structuredPopulations),intent(in)::networkMain(Ntotal)
    integer,intent(in)::nodeChosenUpdate
    real(8),intent(out)::payoffUpdate
    !!!
    integer::totalTimesInteractionsWithAInNeighbor
    integer::totalTimesInteractionsWithNeighbor
    !!!
    real::randNodeUpdate
    integer::nodeNeighNow, indexNeigh
    integer::strategyUpdateNode, strategyNeighNode

    !!! strategy of the node chosen to update
    strategyUpdateNode = strategyGame(nodeChosenUpdate)
    !!! initialize the payoff
    payoffUpdate = 0
    !!! the number of interactions in total
    totalTimesInteractionsWithNeighbor = sum(networkMain(nodeChosenUpdate)%neighborNodeTimesInteraction)
    !!! the number of interactions with A-neighbors in total
    totalTimesInteractionsWithAInNeighbor = sum(networkMain(nodeChosenUpdate)%neighborNodeTimesInteraction * strategyGame(networkMain(nodeChosenUpdate)%neighborNode))
    if(strategyUpdateNode == 1)then
        payoffUpdate = payoffUpdate + totalTimesInteractionsWithAInNeighbor * AA + (totalTimesInteractionsWithNeighbor - totalTimesInteractionsWithAInNeighbor) * AB
    else
        payoffUpdate = payoffUpdate + totalTimesInteractionsWithAInNeighbor * BA + (totalTimesInteractionsWithNeighbor - totalTimesInteractionsWithAInNeighbor) * BB
    end if
    !!!!!! accumulated payoff (set isPayoffAveraged = 0)
    !!!!!! average payoff (set isPayoffAveraged = 1)
    payoffUpdate = payoffUpdate / real(totalTimesInteractionsWithNeighbor ** isPayoffAveraged, 8)

    return
end subroutine PairwiseGame_AnyWeightedGraph


      DOUBLE PRECISION FUNCTION UPBND(A,LDA,NA,F,E,NE,NS,AS,LDAS,BS,
     .                                LDBS,CS,LDCS,INV,LDINV,IND,
     .                                IERR,W,WORK,LWORK,IWORK)
      IMPLICIT NONE
*
*  -- user defined driver routine --
*
*
*     .. Scalar Arguments ..
      INTEGER            NA, NE, NS, IERR, LWORK, LDA, LDAS, LDBS, LDCS,
     .                   LDINV
*     ..
*     .. Array Arguments ..
      INTEGER            F(*), E(*), IND(*), IWORK(*)
      DOUBLE PRECISION   A(LDA,*), AS(LDAS,*), CS(LDCS, *), BS(LDBS,*),
     .                   INV(LDINV,*), W(*), WORK(*)
*     ..
*
*  Purpose
*  =======
*
*  UPBND is a function to establish the upper bounds for the entropy
*  required by the branch and bound strategy described in
*  Ko, Lee, Queyranne (1994), An exact algorithm for maximum entropy
*  sampling, Operations Research 43 (1995), 684-691.
*
*
*  Arguments
*  =========
*
*  A        (input) DOUBLE PRECISION array of DIMENSION (NA,NA).
*           Before entry, the array A must contain matrix of
*           covariances.
*           Unchanged on exit.
*
*  NA       (input) INTEGER.
*           On entry, NA specifies the number of rows/columns of A
*           as declared in the calling (sub) program. NA >= 0.
*           Unchanged on exit.
*
*  F        (input) INTEGER vector of DIMENSION (NE).
*           On entry, F specifies the additional indices are forced
*           into the actual solution.
*           Unchanged on exit.
*
*  E        (input) INTEGER vector of DIMENSION (NE).
*           On entry, E specifies the indices still treated
*           as eligible for the actual solution.
*           Unchanged on exit.
*
*  NE       (input) INTEGER.
*           On entry, NE specifies how many stations will be treated
*           as eligible for consideration.
*           Unchanged on exit.
*
*  NS       (input) INTEGER.
*           On entry, NS specifies how many stations have to be added
*           to the current network. 1 <= NS <= NE.
*           Unchanged on exit.
*
*  AS       (work array) DOUBLE PRECISION, DIMENSION (NA,NA).
*
*  BS       (work array) DOUBLE PRECISION, DIMENSION (NA,NA).
*
*  CS       (work array) DOUBLE PRECISION, DIMENSION (NA,NA).
*
*  INV      (work array) DOUBLE PRECISION, DIMENSION (NA,NA).
*
*  IND      (work vector) INTEGER, DIMENSION (NA).
*
*  IERR     (output) INTEGER
*           the error indicator from DPOFA.  this will be
*           zero unless the matrix being factorized is
*           not positive definite.
*
*  W        (work vector) DOUBLE PRECISION, DIMENSION (NE).
*
*  WORK     (work vector) DOUBLE PRECISION, DIMENSION (LWORK).
*
*  LWORK    (integer) DIMENSION of the array WORK.
*
*  IWORK    (work vector) INTEGER, DIMENSION (8*NA).
*
*
*  =====================================================================
*
*     ..
*     .. Parameters ..
*     ..
*     .. Local Scalars ..
      INTEGER            I, NF, LF, LE, ILOEV, IUPEV, NEV, MI, NI, LFE
      DOUBLE PRECISION   SDET, ABSTOL, ALPHA, BETA, PROD
      CHARACTER*1        TRANSA,TRANSB,JOBZ,RANGE,UPLO
*     ..
*     .. Local Arrays ..
      INTEGER            IFAIL(1)
      DOUBLE PRECISION   DET(2), Z(1)
*     ..
*     .. External Functions ..
*     ..
*     .. External Subroutines ..
      EXTERNAL           PSUBM, DSCHUR, DSYEVX
*     ..
*     .. Intrinsic Functions ..
*     ..
*     .. Executable Statements ..
*
*
*     actual index sets of E and F

      NF=NA-NE
      DO 10 I=1,NF
         IND(I)=I
 10   CONTINUE

      LF=NF
      LFE=NF
      DO 20 I=1,NE
         IF(F(I).NE.0) THEN
            LFE=LFE+1
            LF=LF+1
            IND(LFE)=I+NF
         END IF
 20   CONTINUE
      LE=0
      DO 30 I=1,NE
         IF(E(I).NE.0) THEN
            LFE=LFE+1
            LE=LE+1
            IND(LFE)=I+NF
         END IF
 30   CONTINUE

      CALL PSUBM(A,LDA,NA,AS,LDAS,IND,LFE)

*     determining the Schur complement
*     B[F,E]=A[E,E]-A[E,F]*A[F,F]^(-1)*A[F,E]
*     and the determinant of A[F,F]

      CALL DSCHUR(LFE,LF,AS,LDAS,BS,LDBS,SDET,IERR)

*     s-f greatest eigenvalues of B[F,E]

      JOBZ='N'
      RANGE='I'
      UPLO='U'
      ILOEV=LE-NS-NF+LF+1
      IUPEV=LE
      NEV=NS+NF-LF
      ABSTOL=1.0D-16
      CALL DSYEVX(JOBZ,RANGE,UPLO,LE,BS,LDBS,0.0D0,0.0D0,ILOEV,IUPEV,
     .            ABSTOL,NEV,W,Z,1,WORK,LWORK,IWORK,IFAIL,IERR)

*     product of the eigenvalues

      PROD=1.0
      DO 40 I=1,NEV
         PROD=PROD*W(I)
 40   CONTINUE

*     new upper bound

      UPBND=SDET * PROD
      RETURN
      END


      subroutine pl_tstr

!!     ~ ~ ~ PURPOSE ~ ~ ~
!!     computes temperature stress for crop growth - strstmp

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    t_base(:)   |deg C         |minimum temperature for plant growth
!!    t_opt(:)    |deg C         |optimal temperature for plant growth
!!    tmp_an(:)   |deg C         |average annual air temperature
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    rto         |
!!    tgx         |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use climate_module
      use plant_data_module
      use hru_module, only : tmpav, tmn, ihru, ipl, iwgen, tmn, tmpav
      use plant_module

      implicit none

      integer :: j             !none        |HRU number
      integer :: idp           !            |
      real :: tgx              !            |
      real :: rto              !none        |cloud cover factor

      j = ihru

      idp = pcom(j)%plcur(ipl)%idplt
      tgx = tmpav(j) - pldb(idp)%t_base

      if (tgx <= 0.) then
        pcom(j)%plstr(ipl)%strst = 0.
      else
        if (tmpav(j) > pldb(idp)%t_opt) then
         tgx = 2. * pldb(idp)%t_opt - pldb(idp)%t_base - tmpav(j)
        end if

        rto = 0.
        rto = ((pldb(idp)%t_opt - tmpav(j)) / (tgx + 1.e-6)) ** 2

        if (rto <= 200. .and. tgx > 0.) then
          pcom(j)%plstr(ipl)%strst = Exp(-0.1054 * rto)
        else
          pcom(j)%plstr(ipl)%strst = 0.
        end if

        if(tmn(j)<=wgn_pms(iwgen)%tmp_an-15.)pcom(j)%plstr(ipl)%strst=0.

      end if

      return
      end subroutine pl_tstr