      subroutine ZWOFZ (Z, W, FLAG)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>>2002-11-06 ZWOFZ Krogh Corrected comments.
c>>1996-03-30 ZWOFZ Krogh Added external stmt., removed INT in type st.
c>>1992-10-13 ZWOFZ WVS Improve efficiency and avoid underflow.
c>>1992-03-13 ZWOFZ FTK Removed implicit statements.
c>>1991-08-23 ZWOFZ WV Snyder Initial adaptation to Math77
c
c     Algorithm 680, collected algorithms from ACM.
c     Reference - GPM Poppe, CMJ Wijers: More efficient computation of
c     the complex error-function, ACM Trans. Math. Software.
c     Vol. 16, No. 1, Pp. 47.
c
c     Modified by W. V. Snyder for inclusion in Math77:
c     Reorganize checking for overflow and loss of precision so
c     there are no redundant or unnecessary checks.  In the process,
c     the range of applicability is expanded to the entire upper
c     half-plane.
c     Reorganize some calculations to be immune from overflow.
c     Split loop for two outer regions into two loops -- faster in
c     region.
c     Use D1MACH to fetch machine characteristics.
c     Use Math77 error message processor.
c
c  Given a complex number z = (xi,yi), this subroutine computes
c  the value of the Faddeeva function w(z) = exp(-z**2)*erfc(-i*z),
c  where erfc is the complex complementary error function and i
c  means sqrt(-1).
c  The accuracy of the algorithm for z in the 1st and 2nd quadrant
c  is 14 significant digits; in the 3rd and 4th it is 13 significant
c  digits outside a circular region with radius 0.126 around a zero
c  of the function.
c
c
c  Argument list
c     Z [in]    = real and imaginary parts of z in Z(1) and Z(2)
c     W [out]   = real and imaginary parts of w(z) in W(1) and W(2)
c     FLAG [out] = an error flag indicating the status of the
c       computation.  Type INTEGER, with values having the following
c       meaning:
c         0 : No error condition,
c        -1 : Overflow would occur,
c        +1 : There would be no significant digits in the answer.
c
c
c  The routine is not underflow-protected but any variable can be
c  put to zero upon underflow.
c
c--   S version uses CWOFZ, R1MACH, r1mach, serv1
c--   D version uses ZWOFZ, D1MACH, d1mach, derv1
c
c
c     RSQPD2 = 2/sqrt(pi) = reciprocal ( sqrt(pi) / 2 ).
c     LN2    = ln(2).
c     SQLGOV = sqrt(ln(RMAX)), where RMAX = the overflow limit for
c              floating point arithmetic.
c     LGOV2  = ln(RMAX) - ln(2)
c     LGUND  = ln(RMIN), where RMIN = underflow limit.
c     MXGONI = the largest possible argument of sin or cos, restricted
c              here to sqrt ( pi / (2*round-off-limit) ).
c     INOGXM = 1 / MXGONI.
c  The reason these values are needed as defined
c  will be explained by comments in the code.
c
      external D1MACH
      logical A
      integer FLAG, I, J, KAPN, N, NU
      double precision C, H, H2, LN2, QLAMDA, QRHO, D1MACH, RSQPD2, RX
      double precision RY, SX, SY, TX, TY, U, U1, U2, UV, V, V1, V2
      double precision W(2), W1, X, XABS, XQUAD, XSUM, Y, YABS, YQUAD
      double precision YSUM, Z(2)
      parameter (RSQPD2 =  1.128379167095512573896158903121545171688d0)
      parameter (LN2    = 0.6931471805599453094172321214581765680755d0)
      double precision INOGXM, LGOV2, LGUND, MXGONI, SQLGOV
      save INOGXM, LGOV2, LGUND, MXGONI, SQLGOV
      data LGOV2 /-1.0d0/
c
      if (lgov2 .le. 0.0d0) then
        lgov2 = log(d1mach(2))
        sqlgov = sqrt(lgov2)
        lgov2 = lgov2 - ln2
        lgund = log(d1mach(1))
        mxgoni = sqrt(8.0d0 / d1mach(4)) / rsqpd2
        inogxm = 1.0d0 / mxgoni
      end if
c
      xabs = abs(z(1))
      yabs = abs(z(2))
      x    = xabs/6.3d0
      y    = yabs/4.4d0
c
      if (x .gt. y) then
        qrho = x * sqrt(1.0d0 + (y/x)**2)
      else if (y .eq. 0.0d0) then
        qrho = 0.0d0
      else
        qrho = y * sqrt(1.0d0 + (x/y)**2)
      end if
c
      a = qrho .lt. 0.292d0
      if (a) then
c
c       qrho .lt. 0.292, equivalently qrho**2 .lt. 0.085264: the Fadeeva
c       function is evaluated using a power-series (Abramowitz and
c       Stegun, equation (7.1.5), p.297).
c       N is the minimum number of terms needed to obtain the required
c       accuracy.
c
c       We know xquad and exp(-xquad) and yqyad and sin(yquad) won't
c       cause any trouble here, because qrho .lt. 1.
        xquad = (xabs - yabs) * (xabs + yabs)
        yquad = 2.0d0*xabs*yabs
        n     = int(6.5d0 + 72.0d0 * (1.0d0-0.85d0 * y) * qrho)
        j     = 2*n+1
        xsum  = rsqpd2/j
        ysum  = 0.0d0
        do 10 i = n, 1, -1
          j    = j - 2
          w1   = (xsum*xquad - ysum*yquad)/i
          ysum = (xsum*yquad + ysum*xquad)/i
          xsum = w1 + rsqpd2/j
 10     continue
        u1 = 1.0d0 - (xsum*yabs + ysum*xabs)
        v1 =         (xsum*xabs - ysum*yabs)
        w1 =  exp(-xquad)
        u2 =  w1*cos(yquad)
        v2 = -w1*sin(yquad)
c
        u  = u1*u2 - v1*v2
        v  = u1*v2 + v1*u2
      else
c
        rx = 0.0d0
        ry = 0.0d0
        sx = 0.0d0
        sy = 0.0d0
c
c       The loops in both branches of the IF block below are similar.
c       They could be combined to reduce space, but extra tests and
c       unnecessary computation would be needed.
c
        if (qrho .lt. 1.0d0) then
c         0.292 .le. qrho .lt. 1.0: w(z) is evaluated by a truncated
c         Taylor expansion, where the Laplace continued fraction
c         is used to calculate the derivatives of w(z).
c         KAPN is the minimum number of terms in the Taylor expansion
c         needed to obtain the required accuracy.
c         NU is the minimum number of terms of the continued fraction
c         needed to calculate the derivatives with the required
c         accuracy.
c         x*x + y*y is more accurate than qrho*qrho here:
          c    = (1.0d0-y) * sqrt(1.0d0-x*x-y*y)
          h    = 1.88d0 * c
          h2   = 2.0d0 * h
          nu   = int(17.5d0 + 26.0d0*c)
          kapn = int(8.5d0  + 34.0d0*c)
c         Select kapn so qlamda doesn't underflow.  Small kapn is good
c         (when possible) for performance also.
          if (h2 .lt. 0.25d0) kapn=min(kapn,1+int(lgund/log(h2)))
          qlamda = h2**(kapn-1)
c         0 < qlamda < 3.76**41 < 3.85d23.
          do 20 n = nu, kapn+1, -1
            tx  = yabs + h + n*rx
            ty  = xabs - n*ry
c           No overflow because tx*rx + ty*ry = 1 and 0.292 < qrho < 1:
            c = 0.5d0/(tx*tx + ty*ty)
            rx = tx*c
            ry = ty*c
20        continue
          do 30 n = kapn, 1, -1
            tx  = yabs + h + n*rx
            ty  = xabs - n*ry
c           No overflow because tx*rx + ty*ry = 1 and 0.292 < qrho < 1:
            c = 0.5d0/(tx*tx + ty*ty)
            rx = tx*c
            ry = ty*c
            tx = qlamda + sx
            sx = rx*tx - ry*sy
            sy = ry*tx + rx*sy
            qlamda = qlamda/h2
30        continue
          u = rsqpd2*sx
          v = rsqpd2*sy
        else
c         qrho .ge. 1.O: w(z) is evaluated using the Laplace continued
c         fraction.
c         NU is the minimum number of terms needed to obtain the
c         required accuracy.
          nu   = int(4.5d0 + (1442.0d0 / (26.0d0 * qrho + 77.0d0)))
          do 40 n = nu, 1, -1
            tx  = yabs + n*rx
            ty  = xabs - n*ry
            if (tx .gt. abs(ty)) go to 50
c           rx = 0.5*tx/(tx**2+ty**2) and ry = 0.5*ty/(tx**2+ty**2),
c           computed without overflow.  Underflow is OK.
            c = tx / ty
            ry = 0.5d0 / (ty * (1.0d0 + c*c))
            rx = ry * c
40        continue
          go to 60
c         Once tx>abs(ty), it stays that way.
50        continue
c           rx = 0.5*tx/(tx**2+ty**2) and ry = 0.5*ty/(tx**2+ty**2),
c           computed without overflow.  Underflow is OK.
            c = ty / tx
            rx = 0.5d0 / (tx * (1.0d0 + c*c))
            ry = rx * c
            n = n - 1
            if (n.eq.0) go to 60
            tx  = yabs + n*rx
            ty  = xabs - n*ry
          go to 50
60        u = rsqpd2*rx
          v = rsqpd2*ry
        end if
c
        if (yabs .eq. 0.0d0) then
          if (xabs .gt. sqlgov) then
            u = 0.0d0
          else
            u = exp(-xabs**2)
          end if
        end if
c
      end if
c
c     Evaluation of w(z) in the other quadrants.
c
      if (z(2) .lt. 0.0d0) then
        if (a) then
          u2 = u2 + u2
          v2 = v2 + v2
        else
c         Check whether sin(2*xabs*yabs) has any precision, without
c         allowing 2*xabs*yabs to overflow.
          if (yabs .gt. xabs) then
            if (yabs .gt. inogxm) then
c             The following protects 2*exp(-z**2) against overflow.
              if (lgov2/yabs .lt. yabs - xabs*(xabs/yabs)) go to 100
              w1 =  2.0d0*exp((yabs-xabs)*(yabs+xabs))
              uv = min(abs(u),abs(v))
              if (w1 .gt. uv) then
                if (xabs .gt. mxgoni/yabs) go to 110
              else
c               We put xabs*(w1/uv) here instead of simply xabs because
c               loss of precision in sin and cos will be diminished
c               relative to uv by w1.
                if (xabs*(w1/uv) .gt. mxgoni/yabs) go to 110
              end if
            end if
          else if (xabs .gt. inogxm) then
            if (lgov2/xabs .lt. xabs - yabs*(yabs/xabs)) then
c             (yabs-xabs)*(yabs+xabs) might have overflowed, but in that
c             case, exp((yabs-xabs)*(yabs+xabs)) would underflow.
              u2 = 0.0d0
              v2 = 0.0d0
              go to 80
            end if
c           (yabs-xabs)*(yabs+xabs) can't overflow here.
            w1 =  2.0d0*exp((yabs-xabs)*(yabs+xabs))
            uv = min(abs(u),abs(v))
            if (w1 .gt. uv) then
              if (yabs .gt. mxgoni/xabs) go to 110
            else
c             We put yabs*(w1/uv) here instead of simply yabs because
c             loss of precision in sin and cos will be diminished
c             relative to uv by w1.
              if (yabs*(w1/uv) .gt. mxgoni/xabs) go to 110
            end if
          end if
          yquad = 2.0d0*xabs*yabs
          u2 =  w1*cos(yquad)
          v2 = -w1*sin(yquad)
80        continue
        end if
c
        u = u2 - u
        v = v2 - v
        if (z(1) .gt. 0.0d0) v = -v
      else
        if (z(1) .lt. 0.0d0) v = -v
      end if
c
      flag = 0
      w(1) = u
      w(2) = v
      return
c
c     Overflow
100   flag = -1
      call ermsg ('ZWOFZ',-1,2,
     1'EXP(-REAL(Z**2)) would overflow, Y .lt. - SQRT(X**2 + LN(infinity
     2/2))'
     2,',')
      call derv1 ('LN(infinity/2)',lgov2,',')
      go to 120
c     No significant digits
110   flag = +1
      call ermsg ('ZWOFZ',+1,2,
     1'Too few significant digits in COS(IMAG(Z**2)),',',')
      call ermor ('2*Y*ABS(X) .lt. -SQRT(2*pi/eps)',',')
      call derv1 ('SQRT(2*pi/eps)',mxgoni,',')
120   call derv1 ('REAL(Z)',z(1),',')
      call derv1 ('IMAG(Z)',z(2),'.')
      w(1) = d1mach(2)
      w(2) = w(1)
      return
c
      end


      subroutine  mesh
c
c     ******************************************************************
c     *                                                                *
c     *   generates the mesh                                           *
c     *                                                                *
c     ******************************************************************
c
      use dims
c
c     ******************************************************************
c
      use geo_var
      use mesh_var
c
c     ******************************************************************
c
      use flo_param
      use geo_param
c
c     ******************************************************************
c
      implicit none
c
c     ******************************************************************
c
c     local variables
c
c     ******************************************************************
c
      integer  :: i,j
c
c     ******************************************************************
c
      real     :: x0,y0,s1,yp,r,angl
c
c     ******************************************************************
c
      x0        = xsing/scal
      y0        = ysing/scal

      do j=1,jl

      s1        = 1.  -(float(j  -1)/float(jl  -1))**2

      do i=1,il

      yp        = a1(i)*b0(j)  +s1*s0(i)
      x(i,j,1)  = x0  +.5*(a0(i)*a0(i)  -yp*yp)
      x(i,j,2)  = y0  +a0(i)*yp

      end do
      end do

      return

      end


module radiation

    implicit none

    private
    public sol_oz, cloud, radsw

    ! Shortwave radiation and cloud constants
    real, parameter :: solc    = 342.0 !! Solar constant (area averaged) in W/m^2
    real, parameter :: rhcl1   = 0.30  !! Relative humidity threshold corresponding to
                                       !! cloud cover = 0
    real, parameter :: rhcl2   = 1.00  !! Relative humidity correponding to cloud cover = 1
    real, parameter :: qcl     = 0.20  !! Specific humidity threshold for cloud cover
    real, parameter :: wpcl    = 0.2   !! Cloud cover weight for the square-root of precipitation
                                       !! (for p = 1 mm/day)
    real, parameter :: pmaxcl  = 10.0  !! Maximum value of precipitation (mm/day) contributing to
                                       !! cloud cover
    real, parameter :: clsmax  = 0.60  !! Maximum stratiform cloud cover
    real, parameter :: clsminl = 0.15  !! Minimum stratiform cloud cover over land (for RH = 1)
    real, parameter :: gse_s0  = 0.25  !! Gradient of dry static energy corresponding to
                                       !! stratiform cloud cover = 0
    real, parameter :: gse_s1  = 0.40  !! Gradient of dry static energy corresponding to
                                       !! stratiform cloud cover = 1
    real, parameter :: albcl   = 0.43  !! Cloud albedo (for cloud cover = 1)
    real, parameter :: albcls  = 0.50  !! Stratiform cloud albedo (for st. cloud cover = 1)
    real, parameter :: epssw   = 0.020 !! Fraction of incoming solar radiation absorbed by ozone

    ! Shortwave absorptivities (for dp = 10^5 Pa)
    real, parameter :: absdry  = 0.033 !! Absorptivity of dry air (visible band)
    real, parameter :: absaer  = 0.033 !! Absorptivity of aerosols (visible band)
    real, parameter :: abswv1  = 0.022 !! Absorptivity of water vapour
                                       !! (visible band, for dq = 1 g/kg)
    real, parameter :: abswv2  = 15.0  !! Absorptivity of water vapour
                                       !! (near IR band, for dq = 1 g/kg)
    real, parameter :: abscl1  = 0.015 !! Absorptivity of clouds (visible band, maximum value)
    real, parameter :: abscl2  = 0.15  !! Absorptivity of clouds
                                       !! (visible band, for dq_base = 1 g/kg)

    ! Longwave absorptivities (per dp = 10^5 Pa)
    real, parameter :: ablwin =  0.3  !! Absorptivity of air in "window" band
    real            :: ablco2 =  6.0  !! Absorptivity of air in CO2 band
    real, parameter :: ablwv1 =  0.7  !! Absorptivity of water vapour in H2O band 1 (weak),
                                      !! (for dq = 1 g/kg)
    real, parameter :: ablwv2 = 50.0  !! Absorptivity of water vapour in H2O band 2 (strong),
                                      !! (for dq = 1 g/kg)
    real, parameter :: ablcl1 = 12.0  !! Absorptivity of "thick" clouds in window band
                                      !! (below cloud top)
    real, parameter :: ablcl2 =  0.6  !! Absorptivity of "thin" upper clouds in window and H2O
                                      !! bands

    real, parameter :: epslw = 0.05 !! Fraction of blackbody spectrum absorbed/emitted by PBL only

    real, parameter :: pi = 3.14159265359

contains

    subroutine sol_oz(tyear, nlon, lats, topsr, fsol, ozupp, ozone, zenit, stratz)
        real, intent(in) :: tyear
        integer, intent(in) :: nlon
        real, intent(in) :: lats(:)
        real, intent(out) :: topsr(size(lats))
        real, intent(out) :: fsol(nlon*size(lats))
        real, intent(out) :: ozupp(nlon*size(lats))
        real, intent(out) :: ozone(nlon*size(lats))
        real, intent(out) :: zenit(nlon*size(lats))
        real, intent(out) :: stratz(nlon*size(lats))

        integer :: ngp, nlat, nzen, i, j, j0

        real :: alpha, dalpha, coz1, coz2, azen, rzen, czen, szen, fs0, flat2
        real :: clat(size(lats)), slat(size(lats))

        nlat = size(lats)
        ngp = nlon*nlat

        ! Compute cosine and sine of latitude
        clat = cos(lats*pi/180.0)
        slat = sin(lats*pi/180.0)

        ! alpha = year phase ( 0 - 2pi, 0 = winter solstice = 22dec.h00 )
        alpha = 4.0*asin(1.0)*(tyear+10.0/365.0)
        dalpha = 0.0

        coz1 = 1.0*max(0.0, cos(alpha - dalpha))
        coz2 = 1.8
        azen = 1.0
        nzen = 2

        rzen = -cos(alpha)*23.45*asin(1.0)/90.0
        czen = cos(rzen)
        szen = sin(rzen)

        fs0 = 6.0

        ! Solar radiation at the top
        call solar(tyear, 4.0*solc, lats, topsr)

        do j = 1, nlat
            j0 = 1 + nlon*(j - 1)
            flat2 = 1.5*slat(j)**2 - 0.5

            ! Solar radiation at the top
            fsol(j0) = topsr(j)

            ! Ozone depth in upper and lower stratosphere
            ozupp(j0) = 0.5*epssw
            ozone(j0) = 0.4*epssw*(1.0 + coz1*slat(j) + coz2*flat2)

            ! Zenith angle correction to (downward) absorptivity
            zenit(j0) = 1.0 + azen*(1.0 - (clat(j)*czen + slat(j)*szen))**nzen

            ! Ozone absorption in upper and lower stratosphere
            ozupp(j0) = fsol(j0)*ozupp(j0)*zenit(j0)
            ozone(j0) = fsol(j0)*ozone(j0)*zenit(j0)

            ! Polar night cooling in the stratosphere
            stratz(j0) = max(fs0 - fsol(j0), 0.0)

            do i = 1, nlon - 1
                fsol  (i+j0) = fsol  (j0)
                ozone (i+j0) = ozone (j0)
                ozupp (i+j0) = ozupp (j0)
                zenit (i+j0) = zenit (j0)
                stratz(i+j0) = stratz(j0)
            end do
        end do
    end subroutine sol_oz

    subroutine solar(tyear, csol, lats, topsr)
        ! Average daily flux of solar radiation, from Hartmann (1994)

        real, intent(in) :: tyear
        real, intent(in) :: csol
        real, intent(in) :: lats(:)
        real, intent(out) :: topsr(size(lats))

        integer :: nlat, j
        real :: clat(size(lats)), slat(size(lats))
        real :: ca1, ca2, ca3, cdecl, ch0, csolp, decl, fdis, h0, alpha, pigr, sa1
        real :: sa2, sa3, sdecl, sh0, tdecl

        nlat = size(lats)

        ! Compute cosine and sine of latitude
        clat = cos(lats*pi/180.0)
        slat = sin(lats*pi/180.0)

        ! 1. Compute declination angle and Earth-Sun distance factor
        pigr  = 2.0*asin(1.0)
        alpha = 2.0*pigr*tyear

        ca1 = cos(alpha)
        sa1 = sin(alpha)
        ca2 = ca1*ca1-sa1*sa1
        sa2 = 2.*sa1*ca1
        ca3 = ca1*ca2-sa1*sa2
        sa3 = sa1*ca2+sa2*ca1

        decl = 0.006918 - 0.399912*ca1 + 0.070257*sa1 - 0.006758*ca2 + 0.000907*sa2&
            & - 0.002697*ca3 + 0.001480*sa3

        fdis = 1.000110 + 0.034221*ca1 + 0.001280*sa1 + 0.000719*ca2 + 0.000077*sa2

        cdecl = cos(decl)
        sdecl = sin(decl)
        tdecl = sdecl/cdecl

        ! 2. Compute daily-average insolation at the atm. top
        csolp = csol/pigr

        do j = 1, nlat
            ch0 = min(1.0, max(-1.0, -tdecl*slat(j)/clat(j)))
            h0  = acos(ch0)
            sh0 = sin(h0)

            topsr(j) = csolp*fdis*(h0*slat(j)*sdecl + sh0*clat(j)*cdecl)
        end do
    end subroutine solar

    subroutine solar_diurnal(tyear, rday, csol, lats, nlon, topsr)
        !-----------------------------------------------------------------------
        ! From ECBILT-CLIO model
        ! Calculates incoming solar radiation as a function of latitude
        ! for each day of the year, given the orbital parameters (see PMIP)
        ! One year has 360 days.  Reference: A. Berger, JAS, 35, 2362-2367,1978
        !-----------------------------------------------------------------------

        real, intent(in) :: tyear
        real, intent(in) :: rday
        real, intent(in) :: csol
        real, intent(in) :: lats(:)
        integer, intent(in) :: nlon
        real, intent(out) :: topsr(nlon,size(lats))

        integer :: i, j, l, NVE, nlat
        real :: clat(size(lats)), slat(size(lats))

        real :: beta, alam, alam0, ala, ala0
        real :: fac1, fac2, fac3, ro
        real :: deltal, sindl, cosdl, tandl
        real :: rkosz, rkosha1, ha1
        real :: deg2rad, day2rad
        real :: solard, solarf, solarcf, rlon, omweb, obl, hangle, ecc, cmu

        nlat = size(lats)

        ! Compute cosine and sine of latitude
        clat = cos(lats*pi/180.0)
        slat = sin(lats*pi/180.0)

        deg2rad = 2.0*asin(1.0)/180.0
        day2rad = 2.0*asin(1.0)/180.0

        ! Present-day orbital parameters: eccentricity ecc, obliquity obl and
        ! angle om between Vernal Equinox and Perihelion (angles all given
        ! in degrees and converted to radians). Solarc is the solar constant.
        ! NVE is day of the Vernal Equinox, set at 21 MARCH
        ! Implementatie van Nanne

        !mbp_s
        ecc = 0.016724
        !      ecc=0.016724*3.
        !mbp_e
        obl = 23.446*deg2rad
        !mbp_s
        omweb = (102.04 + 180.00)*deg2rad
        !      omweb=(102.04+180.00-180.0)*deg2rad
        !mbp_e
        !      csol=1365.
        NVE = 30 + 30 + 21

        ! In old SW-routine of ECBilt-model values were as follows:
        !
        !      ecc=0.0
        !      csol=1353.
        !      NVE=90
        !
        ! At 6000 years BP (Before Present) values were as follows:
        !
        !      ecc=0.018682
        !      obl=24.105*deg2rad
        !      omweb=(0.87+180.00)*deg2rad
        !
        ! :LGM:
        !     ecc=0.018994
        !     obl=22.949*deg2rad
        !     omweb=(114.42+180.00)*deg2rad

        ! First compute alam0 (the starting point). Then convert days to
        ! the true longitude ala, using Berger's formulae.
        ! Longitude ala loops from 0 (Vernal Equinox) to 359, ro is earth-sun
        ! distance relative to the major axis, del is declination.
        ala0 = 0.0
        beta = (1.0 - ecc**2.0)**0.5
        fac1 = (0.5*ecc + 0.125*ecc**3.0)*(1.0 + beta)*sin(ala0 - omweb)
        fac2 = 0.25*ecc**2.0*(0.5 + beta)*sin(2.0*(ala0 - omweb))
        fac3 = 0.125*ecc**3.0*(1.0/3.0 + beta)*sin(3.0*(ala0 -omweb))
        alam0 = ala0-2.0*(fac1 - fac2 + fac3)

        !      l=(imonth-1)*30+iday-NVE
        l = int(tyear*360) - NVE

        if (l < 0) l = l + 360
        alam = alam0 + l*1.0*2.0*asin(1.0)/180.0

        fac1 = (2.0*ecc - 0.25*ecc**3.0)*sin(alam - omweb)
        fac2 = 1.25*ecc**2.0*sin(2.0*(alam - omweb))
        fac3 = (13.0/12.0)*ecc**3.0*sin(3.0*(alam - omweb))
        ala = alam + fac1 + fac2 + fac3
        ro = (1.0 - ecc**2.0)/(1.0 + ecc*cos(ala - omweb))
        deltal = asin(sin(obl)*sin(ala))

        sindl = sin(deltal)
        cosdl = cos(deltal)
        tandl = tan(deltal)

        ! factor voor variable afstand Aarde-Zon (Berger, p.2367; Velds, p. 99)
        solard = 1.0/ro**2.0
        solarcf = csol
        ! beide effecten samen
        solarf = solarcf*solard

        do i = 1, nlon
            do j = 1, nlat
                rkosha1 = -(slat(j)/clat(j))*tandl
                rkosha1 = sign(min(abs(rkosha1), 1.0), rkosha1)
                ha1 = acos(rkosha1)
                rlon = float(i)/float(nlon)
                hangle = 2.0*acos(-1.0)*(tyear + rday + rlon)
                cmu = slat(j)*sindl - clat(j)*cosdl*cos(hangle)
                !fk
                !fk  NCAR Technical Note NCAR/TN-485+STR (CAM4.0), page 116
                !fk  note that only if cmu pos it is counted (Wiki pedia
                !fk  Solar Irradiance, https://en.wikipedia.org/wiki/Solar_irradiance)
                !fk
                !fk   daily mean formulae
                !fk
                !fk          rkosz=slat(j)*sindl*(ha1 - tan(ha1))/(2.*asin(1.))
                !fk   daily variing formulae
                !fk
                rkosz = max(cmu,0.0)
                topsr(i,j) = rkosz*csol*solard
            end do
        end do
    end subroutine solar_diurnal

    subroutine cloud(prog_q, rh, cnv_prec, precls, cnv_top, gse, fmask, &
                   & ngp, nlev, &
                   & icltop, cloudc, clstr, qcloud)
        real, intent(in) :: prog_q(ngp,nlev)
        real, intent(in) :: rh(ngp,nlev)
        real, intent(in) :: cnv_prec(ngp)
        real, intent(in) :: precls(ngp)
        integer, intent(in) :: cnv_top(ngp)
        real, intent(in) :: gse(ngp)
        real, intent(in) :: fmask(ngp)
        integer, intent(in) :: ngp
        integer, intent(in) :: nlev
        integer, intent(out) :: icltop(ngp)
        real, intent(out) :: cloudc(ngp)
        real, intent(out) :: clstr(ngp)
        real, intent(out) :: qcloud(ngp)

        integer :: nl1, nlp, j, k
        real :: clfact, clstrl, drh, fstab, pr1, rgse, rrcl

        nl1  = nlev - 1
        nlp  = nlev + 1
        rrcl = 1.0/(rhcl2 - rhcl1)

        ! 1. Cloud cover, defined as the sum of:
        !  - a term proportional to the square-root of precip. rate
        !  - a quadratic function of the max. relative humidity
        !    in tropospheric layers above pbl where q > prog_qcl :
        !     ( = 0 for rhmax < rhcl1, = 1 for rhmax > rhcl2 )
        !    Cloud-top level: defined as the highest (i.e. least sigma)
        !      between the top of convection/condensation and
        !      the level of maximum relative humidity.
        do j = 1, ngp
            if (rh(j,nl1) > rhcl1) then
                cloudc(j) = rh(j,nl1) - rhcl1
                icltop(j) = nl1
            else
                cloudc(j) = 0.0
                icltop(j) = nlp
            endif
        end do

        do k = 3, nlev - 2
            do j = 1, ngp
                drh = rh(j,k) - rhcl1
                if (drh > cloudc(j) .and. prog_q(j,k) > qcl) then
                    cloudc(j) = drh
                    icltop(j) = k
                endif
            end do
        end do

        do j = 1, ngp
            pr1 = min(pmaxcl, 86.4*(cnv_prec(j) + precls(j)))
            cloudc(j) = min(1.0, wpcl*sqrt(pr1) + min(1.0, cloudc(j)*rrcl)**2.0)
            icltop(j) = min(cnv_top(j), icltop(j))
        end do

        ! 2.  Equivalent specific humidity of clouds
        do j = 1, ngp
            qcloud(j) = prog_q(j,nl1)
        end do

        ! 3. Stratiform clouds at the top of pbl
        clfact = 1.2
        rgse   = 1.0/(gse_s1 - gse_s0)

        do j = 1, ngp
            ! Stratocumulus clouds over sea
            fstab = max(0.0, min(1.0, rgse*(gse(j) - gse_s0)))
            clstr(j) = fstab*max(clsmax - clfact*cloudc(j), 0.0)

            ! Stratocumulus clouds over land
            clstrl   = max(clstr(j), clsminl)*rh(j,nlev)
            clstr(j) = clstr(j) + fmask(j)*(clstrl - clstr(j))
        end do
    end subroutine cloud

    subroutine radsw(prog_sp, prog_q, icltop, cloudc, clstr, ozupp, ozone, zenit, stratz, fsol, qcloud, albsfc, &
                   & ngp, nlev, sig, dsig, &
                   & ssrd, ssr, tsr, tau2, tend_t_rsw)
        real, intent(in) :: prog_sp(ngp)
        real, intent(in) :: prog_q(ngp,nlev)
        integer, intent(in) :: icltop(ngp)
        real, intent(in) :: cloudc(ngp)
        real, intent(in) :: clstr(ngp)
        real, intent(in) :: ozupp(ngp)
        real, intent(in) :: ozone(ngp)
        real, intent(in) :: zenit(ngp)
        real, intent(in) :: stratz(ngp)
        real, intent(in) :: fsol(ngp)
        real, intent(in) :: qcloud(ngp)
        real, intent(in) :: albsfc(ngp)
        integer, intent(in) :: ngp
        integer, intent(in) :: nlev
        real, intent(in) :: sig(nlev)
        real, intent(in) :: dsig(nlev)
        real, intent(out) :: ssrd(ngp)
        real, intent(out) :: ssr(ngp)
        real, intent(out) :: tsr(ngp)
        real, intent(out) :: tau2(ngp,nlev,4)
        real, intent(out) :: tend_t_rsw(ngp,nlev)
!
!      equivalence (frefl(1,1),tau2(1,1,3))
        integer :: nl1, j, k
        real :: fband1, fband2
        real :: acloud(ngp), psaz(ngp), abs1, deltap, flux(ngp,2), eps1, stratc(ngp,2), acloud1

        nl1 = nlev - 1

        fband2 = 0.05
        fband1 = 1.0 - fband2

        ! 1. Initialization
        tau2 = 0.0

        do j = 1, ngp
            ! Change to ensure only ICLTOP <= NLEV used
            if (icltop(j) <= nlev) then
                tau2(j,icltop(j),3) = albcl*cloudc(j)
            end if
            ! end change
            tau2(j,nlev,3) = albcls*clstr(j)
        end do

        ! 2. Shortwave transmissivity:
        ! function of layer mass, ozone (in the statosphere),
        ! abs. humidity and cloud cover (in the troposphere)
        do j = 1, ngp
            psaz(j) = prog_sp(j)*zenit(j)
            acloud(j) = cloudc(j)*min(abscl1*qcloud(j), abscl2)
        end do

        do j = 1, ngp
            deltap = psaz(j)*dsig(1)
            tau2(j,1,1) = exp(-deltap*absdry)
        end do

        do k = 2, nl1
            abs1 = absdry + absaer*sig(k)**2
            do j = 1, ngp
                deltap = psaz(j)*dsig(k)
                if (k >= icltop(j)) then
                    tau2(j,k,1) = exp(-deltap*(abs1 + abswv1*prog_q(j,k) + acloud(j)))
                else
                    tau2(j,k,1) = exp(-deltap*(abs1 + abswv1*prog_q(j,k)))
                end if
            end do
        end do

        abs1 = absdry + absaer*sig(nlev)**2
        do j = 1, ngp
            deltap = psaz(j)*dsig(nlev)
            tau2(j,nlev,1) = exp(-deltap*(abs1 + abswv1*prog_q(j,nlev)))
        end do

        do k = 2, nlev
            do j = 1, ngp
                deltap = psaz(j)*dsig(k)
                tau2(j,k,2) = exp(-deltap*abswv2*prog_q(j,k))
            end do
        end do

        ! 3. Shortwave downward flux
        ! 3.1 Initialization of fluxes
        do j = 1, ngp
            tsr(j)    = fsol(j)
            flux(j,1) = fsol(j)*fband1
            flux(j,2) = fsol(j)*fband2
        end do

        ! 3.2 Ozone and dry-air absorption in the stratosphere
        k = 1
        do j = 1, ngp
            tend_t_rsw(j,k) = flux(j,1)
            flux (j,1) = tau2(j,k,1)*(flux(j,1) - ozupp(j)*prog_sp(j))
            tend_t_rsw(j,k) = tend_t_rsw(j,k) - flux(j,1)
        end do

        k = 2
        do j = 1, ngp
            tend_t_rsw(j,k) = flux(j,1)
            flux (j,1) = tau2(j,k,1)*(flux(j,1) - ozone(j)*prog_sp(j))
            tend_t_rsw(j,k) = tend_t_rsw(j,k) - flux(j,1)
        end do

        ! 3.3  Absorption and reflection in the troposphere
        do k = 3, nlev
            do j = 1, ngp
                tau2(j,k,3)      = flux(j,1)*tau2(j,k,3)
                flux (j,1)      = flux(j,1) - tau2(j,k,3)
                tend_t_rsw(j,k) = flux(j,1)
                flux (j,1)      = tau2(j,k,1)*flux(j,1)
                tend_t_rsw(j,k) = tend_t_rsw(j,k) - flux(j,1)
            end do
        end do

        do k = 2, nlev
            do j = 1, ngp
                tend_t_rsw(j,k) = tend_t_rsw(j,k) + flux(j,2)
                flux (j,2)      = tau2(j,k,2)*flux(j,2)
                tend_t_rsw(j,k) = tend_t_rsw(j,k) - flux(j,2)
            end do
        end do

        ! 4. Shortwave upward flux
        ! 4.1  Absorption and reflection at the surface
        do j = 1, ngp
            ssrd(j)   = flux(j,1)+flux(j,2)
            flux(j,1) = flux(j,1)*albsfc(j)
            ssr(j)    = ssrd(j) - flux(j,1)
        end do

        ! 4.2  Absorption of upward flux
        do k = nlev, 1, -1
            do j = 1, ngp
                tend_t_rsw(j,k) = tend_t_rsw(j,k) + flux(j,1)
                flux (j,1)      = tau2(j,k,1)*flux(j,1)
                tend_t_rsw(j,k) = tend_t_rsw(j,k) - flux(j,1)
                flux (j,1)      = flux(j,1) + tau2(j,k,3)
            end do
        end do

        ! 4.3  Net solar radiation = incoming - outgoing
        do j = 1, ngp
            tsr(j) = tsr(j) - flux(j,1)
        end do

        ! 5.  Initialization of longwave radiation model
        ! 5.1  Longwave transmissivity:
        !      function of layer mass, abs. humidity and cloud cover.

        !    Cloud-free levels (stratosphere + PBL)
        k = 1
        do j=1,ngp
            deltap = prog_sp(j)*dsig(k)
            tau2(j,k,1) = exp(-deltap*ablwin)
            tau2(j,k,2) = exp(-deltap*ablco2)
            tau2(j,k,3) = 1.0
            tau2(j,k,4) = 1.0
        end do

        do k = 2, nlev, nlev - 2
            do j = 1, ngp
                deltap      = prog_sp(j)*dsig(k)
                tau2(j,k,1) = exp(-deltap*ablwin)
                tau2(j,k,2) = exp(-deltap*ablco2)
                tau2(j,k,3) = exp(-deltap*ablwv1*prog_q(j,k))
                tau2(j,k,4) = exp(-deltap*ablwv2*prog_q(j,k))
            end do
        end do

        ! Cloudy layers (free troposphere)
        do j = 1, ngp
            acloud(j) = cloudc(j)*ablcl2
        end do

        do k = 3, nl1
            do j = 1, ngp
                deltap = prog_sp(j)*dsig(k)
                if (k < icltop(j)) then
                    acloud1 = acloud(j)
                else
                    acloud1 = ablcl1*cloudc(j)
                endif
                tau2(j,k,1) = exp(-deltap*(ablwin+acloud1))
                tau2(j,k,2) = exp(-deltap*ablco2)
                tau2(j,k,3) = exp(-deltap*max(ablwv1*prog_q(j,k),acloud(j)))
                tau2(j,k,4) = exp(-deltap*max(ablwv2*prog_q(j,k),acloud(j)))
            end do
        end do

        ! 5.2  Stratospheric correction terms
        eps1 = epslw/(dsig(1) + dsig(2))
        do j = 1, ngp
            stratc(j,1) = stratz(j)*prog_sp(j)
            stratc(j,2) = eps1*prog_sp(j)
        end do
    end subroutine radsw

!      SUBROUTINE RADLW (IMODE,TA,TS,
!     &                  FSFCD,FSFCU,
!     &                  FSFC,FTOP,DFABS)
!
!C--
!C--   SUBROUTINE RADLW (IMODE,TA,TS,
!C--  &                  FSFCD,FSFCU,
!C--  &                  FSFC,FTOP,DFABS)
!C--
!C--   Purpose: Compute the absorption of longwave radiation
!C--   Input:   IMODE  = index for operation mode
!C--                     -1 : downward flux only
!C--                      0 : downward + upward flux
!C--                     +1 : upward flux only
!C--            TA     = absolute temperature (3-dim)
!C--            TS     = surface temperature                    [if IMODE=0]
!C--            FSFCD  = downward flux of lw rad. at the sfc.   [if IMODE=1]
!C--            FSFCU  = surface blackbody emission (upward)    [if IMODE=1]
!C--            DFABS  = DFABS output from RADLW(-1,... )       [if IMODE=1]
!C--   Output:  FSFCD  = downward flux of lw rad. at the sfc.[if IMODE=-1,0]
!C--            FSFCU  = surface blackbody emission (upward)  [if IMODE=  0]
!C--            FSFC   = net upw. flux of lw rad. at the sfc. [if IMODE=0,1]
!C--            FTOP   = outgoing flux of lw rad. at the top  [if IMODE=0,1]
!C--            DFABS  = flux of lw rad. absorbed by each atm. layer (3-dim)
!C--
!C     Resolution parameters
!C
!      include "atparam.h"
!      include "atparam1.h"
!C
!      PARAMETER ( NLON=IX, NLAT=IL, NLEV=KX, NGP=NLON*NLAT )
!
!C     Number of radiation bands with tau < 1
!      PARAMETER ( NBAND=4 )
!
!C     Constants + functions of sigma and latitude
!
!      include "com_physcon.h"
!
!C     Radiation parameters
!
!      include "com_radcon.h"
!
!      REAL TA(NGP,NLEV), TS(NGP)
!
!      REAL FSFCD(NGP), FSFCU(NGP)
!
!      REAL FTOP(NGP), FSFC(NGP), DFABS(NGP,NLEV)
!
!C
!      NL1=NLEV-1
!
!      REFSFC=1.-EMISFC
!
!      IF (IMODE.EQ.1) GO TO 410
!
!C---  1. Blackbody emission from atmospheric levels.
!C        The linearized gradient of the blakbody emission is computed
!C        from temperatures at layer boundaries, which are interpolated
!C        assuming a linear dependence of T on log_sigma.
!C        Above the first (top) level, the atmosphere is assumed isothermal.
!
!C     Temperature at level boundaries
!      DO K=1,NL1
!       DO J=1,NGP
!         ST4A(J,K,1)=TA(J,K)+WVI(K,2)*(TA(J,K+1)-TA(J,K))
!       ENDDO
!      ENDDO
!
!C     Mean temperature in stratospheric layers
!      DO J=1,NGP
!        ST4A(J,1,2)=0.75*TA(J,1)+0.25* ST4A(J,1,1)
!        ST4A(J,2,2)=0.50*TA(J,2)+0.25*(ST4A(J,1,1)+ST4A(J,2,1))
!      ENDDO
!
!C     Temperature gradient in tropospheric layers
!
!      ANIS =1.0
!      ANISH=0.5*ANIS
!
!      DO K=3,NL1
!       DO J=1,NGP
!         ST4A(J,K,2)=ANISH*MAX(ST4A(J,K,1)-ST4A(J,K-1,1),0.)
!       ENDDO
!      ENDDO
!
!      DO J=1,NGP
!        ST4A(J,NLEV,2)=ANIS*MAX(TA(J,NLEV)-ST4A(J,NL1,1),0.)
!      ENDDO
!
!C     Blackbody emission in the stratosphere
!      DO K=1,2
!       DO J=1,NGP
!         ST4A(J,K,1)=SBC*ST4A(J,K,2)**4
!         ST4A(J,K,2)=0.
!       ENDDO
!      ENDDO
!
!C     Blackbody emission in the troposphere
!      DO K=3,NLEV
!       DO J=1,NGP
!         ST3A=SBC*TA(J,K)**3
!         ST4A(J,K,1)=ST3A*TA(J,K)
!         ST4A(J,K,2)=4.*ST3A*ST4A(J,K,2)
!       ENDDO
!      ENDDO
!
!
!C---  2. Initialization of fluxes
!
!      DO J=1,NGP
!        FSFCD(J)=0.
!      ENDDO
!
!      DO K=1,NLEV
!       DO J=1,NGP
!         DFABS(J,K)=0.
!       ENDDO
!      ENDDO
!
!C---  3. Emission ad absorption of longwave downward flux.
!C        For downward emission, a correction term depending on the
!C        local temperature gradient and on the layer transmissivity is
!C        added to the average (full-level) emission of each layer.
!
!C     3.1  Stratosphere
!
!      K=1
!      DO JB=1,2
!       DO J=1,NGP
!         EMIS=1.-TAU2(J,K,JB)
!         BRAD=FBAND(NINT(TA(J,K)),JB)*(ST4A(J,K,1)+EMIS*ST4A(J,K,2))
!         FLUX(J,JB)=EMIS*BRAD
!         DFABS(J,K)=DFABS(J,K)-FLUX(J,JB)
!       ENDDO
!      ENDDO
!
!      DO JB=3,NBAND
!       DO J=1,NGP
!         FLUX(J,JB)=0.
!       ENDDO
!      ENDDO
!
!C     3.2  Troposphere
!
!      DO JB=1,NBAND
!       DO K=2,NLEV
!        DO J=1,NGP
!          EMIS=1.-TAU2(J,K,JB)
!          BRAD=FBAND(NINT(TA(J,K)),JB)*(ST4A(J,K,1)+EMIS*ST4A(J,K,2))
!          DFABS(J,K)=DFABS(J,K)+FLUX(J,JB)
!          FLUX(J,JB)=TAU2(J,K,JB)*FLUX(J,JB)+EMIS*BRAD
!          DFABS(J,K)=DFABS(J,K)-FLUX(J,JB)
!        ENDDO
!       ENDDO
!      ENDDO
!
!C     3.3 Surface downward flux
!
!      DO JB=1,NBAND
!       DO J=1,NGP
!         FSFCD(J)=FSFCD(J)+EMISFC*FLUX(J,JB)
!       ENDDO
!      ENDDO
!
!C     3.4 Correction for "black" band (incl. surface reflection)
!
!      EPS1=EPSLW*EMISFC
!      DO J=1,NGP
!        CORLW=EPS1*ST4A(J,NLEV,1)
!        DFABS(J,NLEV)=DFABS(J,NLEV)-CORLW
!        FSFCD(J)     =FSFCD(J)     +CORLW
!      ENDDO
!
!      IF (IMODE.EQ.-1) RETURN
!
!C---  4. Emission ad absorption of longwave upward flux.
!C        For upward emission, a correction term depending on the
!C        local temperature gradient and on the layer transmissivity is
!C        subtracted from the average (full-level) emission of each layer.
!
!C     4.1  Surface
!
!C     Black-body (or grey-body) emission
!      ESBC=EMISFC*SBC
!      DO J=1,NGP
!        TSQ=TS(J)*TS(J)
!        FSFCU(J)=ESBC*TSQ*TSQ
!      ENDDO
!
!C     Entry point for upward-only mode (IMODE=1)
! 410  CONTINUE
!
!      DO J=1,NGP
!        FSFC(J)=FSFCU(J)-FSFCD(J)
!      ENDDO
!
!      DO JB=1,NBAND
!       DO J=1,NGP
!         FLUX(J,JB)=FBAND(NINT(TS(J)),JB)*FSFCU(J)
!     &              +REFSFC*FLUX(J,JB)
!       ENDDO
!      ENDDO
!
!C     4.2  Troposphere
!
!C     Correction for "black" band
!      DO J=1,NGP
!        DFABS(J,NLEV)=DFABS(J,NLEV)+EPSLW*FSFCU(J)
!      ENDDO
!
!      DO JB=1,NBAND
!       DO K=NLEV,2,-1
!        DO J=1,NGP
!          EMIS=1.-TAU2(J,K,JB)
!          BRAD=FBAND(NINT(TA(J,K)),JB)*(ST4A(J,K,1)-EMIS*ST4A(J,K,2))
!          DFABS(J,K)=DFABS(J,K)+FLUX(J,JB)
!          FLUX(J,JB)=TAU2(J,K,JB)*FLUX(J,JB)+EMIS*BRAD
!          DFABS(J,K)=DFABS(J,K)-FLUX(J,JB)
!        ENDDO
!       ENDDO
!      ENDDO
!
!C     4.3  Stratosphere
!
!      K=1
!      DO JB=1,2
!       DO J=1,NGP
!         EMIS=1.-TAU2(J,K,JB)
!         BRAD=FBAND(NINT(TA(J,K)),JB)*(ST4A(J,K,1)-EMIS*ST4A(J,K,2))
!         DFABS(J,K)=DFABS(J,K)+FLUX(J,JB)
!         FLUX(J,JB)=TAU2(J,K,JB)*FLUX(J,JB)+EMIS*BRAD
!         DFABS(J,K)=DFABS(J,K)-FLUX(J,JB)
!       ENDDO
!      ENDDO
!
!C     Correction for "black" band and polar night cooling
!
!      DO J=1,NGP
!        CORLW1=DSIG(1)*STRATC(J,2)*ST4A(J,1,1)+STRATC(J,1)
!        CORLW2=DSIG(2)*STRATC(J,2)*ST4A(J,2,1)
!        DFABS(J,1)=DFABS(J,1)-CORLW1
!        DFABS(J,2)=DFABS(J,2)-CORLW2
!        FTOP(J)   =CORLW1+CORLW2
!      ENDDO
!
!C     4.4  Outgoing longwave radiation
!
!      DO JB=1,NBAND
!       DO J=1,NGP
!         FTOP(J)=FTOP(J)+FLUX(J,JB)
!       ENDDO
!      ENDDO
!
!C---
!      RETURN
!      END
!
!
!      SUBROUTINE RADSET
!C--
!C--   SUBROUTINE RADSET
!C--
!C--   Purpose: compute energy fractions in LW bands
!C--            as a function of temperature
!C--   Initialized common blocks: RADFIX
!
!C     Resolution parameters
!
!      include "atparam.h"
!      include "atparam1.h"
!
!      PARAMETER ( NLON=IX, NLAT=IL, NLEV=KX, NGP=NLON*NLAT )
!
!C     Radiation constants
!      include "com_radcon.h"
!
!      EPS1=1.-EPSLW
!
!      DO JTEMP=200,320
!        FBAND(JTEMP,2)=(0.148-3.0e-6*(JTEMP-247)**2)*EPS1
!        FBAND(JTEMP,3)=(0.356-5.2e-6*(JTEMP-282)**2)*EPS1
!        FBAND(JTEMP,4)=(0.314+1.0e-5*(JTEMP-315)**2)*EPS1
!        FBAND(JTEMP,1)=EPS1-(FBAND(JTEMP,2)+
!     &                       FBAND(JTEMP,3)+FBAND(JTEMP,4))
!      ENDDO
!
!      DO JB=1,4
!        DO JTEMP=100,199
!          FBAND(JTEMP,JB)=FBAND(200,JB)
!        ENDDO
!        DO JTEMP=321,400
!          FBAND(JTEMP,JB)=FBAND(320,JB)
!        ENDDO
!      ENDDO
!
!C--
!      RETURN
!      END
end module radiation


!==============================================================================!
  subroutine Turb_Mod_Src_Kin_K_Eps_Zeta_F(turb, sol)
!------------------------------------------------------------------------------!
!   Computes the source terms in kin transport equation.                       !
!------------------------------------------------------------------------------!
!   In kinetic energy equation there are two source terms:                     !
!                                                                              !
!     /
!    |                                                                         !
!    | (density (p_kin - eps)) dV                                              !
!    |                                                                         !
!   /                                                                          !
!                                                                              !
!------------------------------------------------------------------------------!
  implicit none
!--------------------------------[Arguments]-----------------------------------!
  type(Turb_Type),   target :: turb
  type(Solver_Type), target :: sol
!---------------------------------[Calling]------------------------------------!
  real :: Roughness_Coefficient
  real :: Tau_Wall_Low_Re
  real :: Tau_Wall_Rough_Walls
  real :: Y_Plus_Low_Re
  real :: Y_Plus_Rough_Walls
!-----------------------------------[Locals]-----------------------------------!
  type(Field_Type),  pointer :: flow
  type(Grid_Type),   pointer :: grid
  type(Var_Type),    pointer :: u, v, w, t
  type(Var_Type),    pointer :: kin, eps, zeta, f, ut, vt, wt, t2
  type(Matrix_Type), pointer :: a
  real,              pointer :: b(:)
  integer                    :: c, c1, c2, s
  real                       :: u_tan, u_tau
  real                       :: lf, ebf, p_kin_int, p_kin_wf, l_rans_d, l_rans_v
  real                       :: l_rans, l_sgs, u_rans, u_sgs, kin_vis
  real                       :: z_o, alpha_d, alpha_v, l_sgs_d, l_sgs_v
  real                       :: ut_log_law, vt_log_law, wt_log_law
  real                       :: nx, ny, nz, qx, qy, qz, g_buoy_wall
!==============================================================================!
!   Dimensions:                                                                !
!                                                                              !
!   production    p_kin    [m^2/s^3]   | rate-of-strain  shear     [1/s]       !
!   dissipation   eps % n  [m^2/s^3]   | turb. visc.     vis_t     [kg/(m*s)]  !
!   wall shear s. tau_wall [kg/(m*s^2)]| dyn visc.       viscosity [kg/(m*s)]  !
!   density       density  [kg/m^3]    | turb. kin en.   kin % n   [m^2/s^2]   !
!   cell volume   vol      [m^3]       | length          lf        [m]         !
!   left hand s.  A        [kg/s]      | right hand s.   b         [kg*m^2/s^3]!
!------------------------------------------------------------------------------!
!   p_kin = 2*vis_t / density S_ij S_ij                                        !
!   shear = sqrt(2 S_ij S_ij)                                                  !
!------------------------------------------------------------------------------!

  ! Take aliases
  flow => turb % pnt_flow
  grid => flow % pnt_grid
  call Field_Mod_Alias_Momentum   (flow, u, v, w)
  call Field_Mod_Alias_Energy     (flow, t)
  call Turb_Mod_Alias_K_Eps_Zeta_F(turb, kin, eps, zeta, f)
  call Turb_Mod_Alias_Heat_Fluxes (turb, ut, vt, wt)
  call Solver_Mod_Alias_System    (sol, a, b)
  call Turb_Mod_Alias_T2          (turb, t2)

  ! Production source:
  do c = 1, grid % n_cells
    turb % p_kin(c) = turb % vis_t(c) * flow % shear(c)**2
    b(c) = b(c) + turb % p_kin(c) * grid % vol(c)
  end do

  if(buoyancy) then
    do c = 1, grid % n_cells
      turb % g_buoy(c) = -flow % beta             &
                         * (grav_x * ut % n(c)    &
                          + grav_y * vt % n(c)    &
                          + grav_z * wt % n(c))   &
                          * flow % density(c)

      if(turb % g_buoy(c) + turb % p_kin(c) < 0.0) then
        turb % g_buoy(c) = 0.0
      end if

      b(c) = b(c) + max(0.0, turb % g_buoy(c) * grid % vol(c))
             a % val(a % dia(c)) = a % val(a % dia(c))         &
                                 + max(0.0,-turb % g_buoy(c)   &
                                 * grid % vol(c)               &
                                 / (kin % n(c) + TINY))
    end do
  end if

  if(turb % model .eq. HYBRID_LES_RANS) then
    do c = 1, grid % n_cells

      lf = grid % vol(c)**ONE_THIRD

      ! Distance switch
      l_sgs_d  = 0.8 * lf
      l_rans_d = 0.41 * grid % wall_dist(c)
      alpha_d  = max(1.0,l_rans_d/l_sgs_d)

      ! Velocity switch
      l_sgs_v  = lf * flow % shear(c)
      l_rans_v = sqrt(kin % n(c) * zeta % n(c))
      alpha_v  = l_rans_v / (l_sgs_v + TINY)

      if( (turb % hybrid_les_rans_switch .eq. SWITCH_DISTANCE)  &
          .and. (alpha_d < 1.05)                         &
          .or.                                           &
          (turb % hybrid_les_rans_switch .eq. SWITCH_VELOCITY)  &
          .and. (alpha_v < 0.85) ) then
        a % val(a % dia(c)) = a % val(a % dia(c))             &
                            + flow % density(c) * eps % n(c)  &
                            / (kin % n(c) + TINY) * grid % vol(c)
      else
        a % val(a % dia(c)) = a % val(a % dia(c))   &
          + flow % density(c)                       &
          * min(alpha_d**1.4 * eps % n(c), kin % n(c)**1.5 / (lf*0.01))  &
          / (kin % n(c) + TINY) * grid % vol(c)
      end if
    end do
  else  ! turbuence model will be K_EPS_ZETA_F
    do c = 1, grid % n_cells
      a % val(a % dia(c)) = a % val(a % dia(c))             &
                          + flow % density(c) * eps % n(c)  &
                          / (kin % n(c) + TINY) * grid % vol(c)

    end do
  end if

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    if(c2 < 0) then
      ! Kinematic viscosities
      kin_vis = flow % viscosity(c1) / flow % density(c1)

      if(Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALL .or. &
         Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALLFL) then

        ! Compute tangential velocity component
        u_tan = Field_Mod_U_Tan(flow, s)

        u_tau = c_mu25 * sqrt(kin % n(c1))

        turb % y_plus(c1) = Y_Plus_Low_Re(turb,                  &
                                          u_tau,                 &
                                          grid % wall_dist(c1),  &
                                          kin_vis)

        turb % tau_wall(c1) = Tau_Wall_Low_Re(turb,               &
                                              flow % density(c1), &
                                              u_tau,              &
                                              u_tan,              &
                                              turb % y_plus(c1))

        ebf = Turb_Mod_Ebf_Momentum(turb, c1)

        p_kin_wf  = turb % tau_wall(c1) * c_mu25 * sqrt(kin % n(c1))  &
                  / (grid % wall_dist(c1) * kappa)

        p_kin_int = turb % vis_t(c1) * flow % shear(c1)**2

        turb % p_kin(c1) = p_kin_wf

        if(turb % rough_walls) then
          z_o = Roughness_Coefficient(turb, turb % z_o_f(c1))
          z_o = max(grid % wall_dist(c1)/(e_log * max(turb % y_plus(c1),1.0)),z_o)

          turb % y_plus(c1) = Y_Plus_Rough_Walls(turb,                  &
                                                 u_tau,                 &
                                                 grid % wall_dist(c1),  &
                                                 kin_vis)

          turb % tau_wall(c1) = Tau_Wall_Rough_Walls(turb,                  &
                                                     flow % density(c1),    &
                                                     u_tau,                 &
                                                     u_tan,                 &
                                                     grid % wall_dist(c1),  &
                                                     z_o)

          turb % p_kin(c1) = turb % tau_wall(c1) * c_mu25 * sqrt(kin % n(c1)) &
                           / (kappa*(grid % wall_dist(c1)+z_o))

        end if ! rough_walls

        b(c1) = b(c1) + (turb % p_kin(c1)  &
              - turb % vis_t(c1) * flow % shear(c1)**2) * grid % vol(c1)

        ! Implementation of wall function for buoyancy-driven flows
        if(buoyancy) then

          nx = grid % sx(s) / grid % s(s)
          ny = grid % sy(s) / grid % s(s)
          nz = grid % sz(s) / grid % s(s)
          qx = t % q(c2) * nx
          qy = t % q(c2) * ny
          qz = t % q(c2) * nz

          ut_log_law = - turb % con_w(c1) &
                     * (t % n(c2) - t % n(c1))/grid % wall_dist(c1) * nx
          vt_log_law = - turb % con_w(c1) &
                     * (t % n(c2) - t % n(c1))/grid % wall_dist(c1) * ny
          wt_log_law = - turb % con_w(c1) &
                     * (t % n(c2) - t % n(c1))/grid % wall_dist(c1) * nz

          ut % n(c1) = ut %n(c1)  * exp(-1.0 * ebf) &
                     + ut_log_law * exp(-1.0 / ebf)
          vt % n(c1) = vt %n(c1)  * exp(-1.0 * ebf) &
                     + vt_log_law * exp(-1.0 / ebf)
          wt % n(c1) = wt %n(c1)  * exp(-1.0 * ebf) &
                     + wt_log_law * exp(-1.0 / ebf)

          if(Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALL) &
          t % q(c2) = turb % con_w(c1) * (t % n(c1) &
                      - t % n(c2))/grid % wall_dist(c1)

          g_buoy_wall = flow % beta*abs(grav_x + grav_y + grav_z)  &
                        * sqrt(abs(t % q(c2))                      &
                        * c_mu_theta5                              &
                        * sqrt(abs(t2 % n(c1) * kin % n(c1))))

          ! This limiter is preventing unphysical solutions
          ! when flow starts to develop
          ! g_buoy_wall = min(3.0*turb % p_kin(c1),g_buoy_wall)

          ! Clean up b(c) from old values of g_buoy
          b(c1)      = b(c1) - turb % g_buoy(c1) * grid % vol(c1)

          turb % g_buoy(c1) = turb % g_buoy(c1) * exp(-1.0 * ebf) &
                     + g_buoy_wall * exp(-1.0 / ebf)

          ! Add new values of g_buoy based on wall function approach
          b(c1)      = b(c1) + turb % g_buoy(c1) * grid % vol(c1)

        end if ! buoyancy

      end if  ! Grid_Mod_Bnd_Cond_Type(grid,c2).eq.WALL or WALLFL
    end if    ! c2 < 0
  end do

  end subroutine


*DECK DQC25C
      SUBROUTINE DQC25C (F, A, B, C, RESULT, ABSERR, KRUL, NEVAL)
C***BEGIN PROLOGUE  DQC25C
C***PURPOSE  To compute I = Integral of F*W over (A,B) with
C            error estimate, where W(X) = 1/(X-C)
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A2A2, J4
C***TYPE      DOUBLE PRECISION (QC25C-S, DQC25C-D)
C***KEYWORDS  25-POINT CLENSHAW-CURTIS INTEGRATION, QUADPACK, QUADRATURE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Integration rules for the computation of CAUCHY
C        PRINCIPAL VALUE integrals
C        Standard fortran subroutine
C        Double precision version
C
C        PARAMETERS
C           F      - Double precision
C                    Function subprogram defining the integrand function
C                    F(X). The actual name for F needs to be declared
C                    E X T E R N A L  in the driver program.
C
C           A      - Double precision
C                    Left end point of the integration interval
C
C           B      - Double precision
C                    Right end point of the integration interval, B.GT.A
C
C           C      - Double precision
C                    Parameter in the WEIGHT function
C
C           RESULT - Double precision
C                    Approximation to the integral
C                    result is computed by using a generalized
C                    Clenshaw-Curtis method if C lies within ten percent
C                    of the integration interval. In the other case the
C                    15-point Kronrod rule obtained by optimal addition
C                    of abscissae to the 7-point Gauss rule, is applied.
C
C           ABSERR - Double precision
C                    Estimate of the modulus of the absolute error,
C                    which should equal or exceed ABS(I-RESULT)
C
C           KRUL   - Integer
C                    Key which is decreased by 1 if the 15-point
C                    Gauss-Kronrod scheme has been used
C
C           NEVAL  - Integer
C                    Number of integrand evaluations
C
C ......................................................................
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DQCHEB, DQK15W, DQWGTC
C***REVISION HISTORY  (YYMMDD)
C   810101  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  DQC25C
C
      DOUBLE PRECISION A,ABSERR,AK22,AMOM0,AMOM1,AMOM2,B,C,CC,CENTR,
     1  CHEB12,CHEB24,DQWGTC,F,FVAL,HLGTH,P2,P3,P4,RESABS,
     2  RESASC,RESULT,RES12,RES24,U,X
      INTEGER I,ISYM,K,KP,KRUL,NEVAL
C
      DIMENSION X(11),FVAL(25),CHEB12(13),CHEB24(25)
C
      EXTERNAL F, DQWGTC
C
C           THE VECTOR X CONTAINS THE VALUES COS(K*PI/24),
C           K = 1, ..., 11, TO BE USED FOR THE CHEBYSHEV SERIES
C           EXPANSION OF F
C
      SAVE X
      DATA X(1) / 0.9914448613 7381041114 4557526928 563D0 /
      DATA X(2) / 0.9659258262 8906828674 9743199728 897D0 /
      DATA X(3) / 0.9238795325 1128675612 8183189396 788D0 /
      DATA X(4) / 0.8660254037 8443864676 3723170752 936D0 /
      DATA X(5) / 0.7933533402 9123516457 9776961501 299D0 /
      DATA X(6) / 0.7071067811 8654752440 0844362104 849D0 /
      DATA X(7) / 0.6087614290 0872063941 6097542898 164D0 /
      DATA X(8) / 0.5000000000 0000000000 0000000000 000D0 /
      DATA X(9) / 0.3826834323 6508977172 8459984030 399D0 /
      DATA X(10) / 0.2588190451 0252076234 8898837624 048D0 /
      DATA X(11) / 0.1305261922 2005159154 8406227895 489D0 /
C
C           LIST OF MAJOR VARIABLES
C           ----------------------
C           FVAL   - VALUE OF THE FUNCTION F AT THE POINTS
C                    COS(K*PI/24),  K = 0, ..., 24
C           CHEB12 - CHEBYSHEV SERIES EXPANSION COEFFICIENTS,
C                    FOR THE FUNCTION F, OF DEGREE 12
C           CHEB24 - CHEBYSHEV SERIES EXPANSION COEFFICIENTS,
C                    FOR THE FUNCTION F, OF DEGREE 24
C           RES12  - APPROXIMATION TO THE INTEGRAL CORRESPONDING
C                    TO THE USE OF CHEB12
C           RES24  - APPROXIMATION TO THE INTEGRAL CORRESPONDING
C                    TO THE USE OF CHEB24
C           DQWGTC - EXTERNAL FUNCTION SUBPROGRAM DEFINING
C                    THE WEIGHT FUNCTION
C           HLGTH  - HALF-LENGTH OF THE INTERVAL
C           CENTR  - MID POINT OF THE INTERVAL
C
C
C           CHECK THE POSITION OF C.
C
C***FIRST EXECUTABLE STATEMENT  DQC25C
      CC = (0.2D+01*C-B-A)/(B-A)
      IF(ABS(CC).LT.0.11D+01) GO TO 10
C
C           APPLY THE 15-POINT GAUSS-KRONROD SCHEME.
C
      KRUL = KRUL-1
      CALL DQK15W(F,DQWGTC,C,P2,P3,P4,KP,A,B,RESULT,ABSERR,
     1  RESABS,RESASC)
      NEVAL = 15
      IF (RESASC.EQ.ABSERR) KRUL = KRUL+1
      GO TO 50
C
C           USE THE GENERALIZED CLENSHAW-CURTIS METHOD.
C
   10 HLGTH = 0.5D+00*(B-A)
      CENTR = 0.5D+00*(B+A)
      NEVAL = 25
      FVAL(1) = 0.5D+00*F(HLGTH+CENTR)
      FVAL(13) = F(CENTR)
      FVAL(25) = 0.5D+00*F(CENTR-HLGTH)
      DO 20 I=2,12
        U = HLGTH*X(I-1)
        ISYM = 26-I
        FVAL(I) = F(U+CENTR)
        FVAL(ISYM) = F(CENTR-U)
   20 CONTINUE
C
C           COMPUTE THE CHEBYSHEV SERIES EXPANSION.
C
      CALL DQCHEB(X,FVAL,CHEB12,CHEB24)
C
C           THE MODIFIED CHEBYSHEV MOMENTS ARE COMPUTED BY FORWARD
C           RECURSION, USING AMOM0 AND AMOM1 AS STARTING VALUES.
C
      AMOM0 = LOG(ABS((0.1D+01-CC)/(0.1D+01+CC)))
      AMOM1 = 0.2D+01+CC*AMOM0
      RES12 = CHEB12(1)*AMOM0+CHEB12(2)*AMOM1
      RES24 = CHEB24(1)*AMOM0+CHEB24(2)*AMOM1
      DO 30 K=3,13
        AMOM2 = 0.2D+01*CC*AMOM1-AMOM0
        AK22 = (K-2)*(K-2)
        IF((K/2)*2.EQ.K) AMOM2 = AMOM2-0.4D+01/(AK22-0.1D+01)
        RES12 = RES12+CHEB12(K)*AMOM2
        RES24 = RES24+CHEB24(K)*AMOM2
        AMOM0 = AMOM1
        AMOM1 = AMOM2
   30 CONTINUE
      DO 40 K=14,25
        AMOM2 = 0.2D+01*CC*AMOM1-AMOM0
        AK22 = (K-2)*(K-2)
        IF((K/2)*2.EQ.K) AMOM2 = AMOM2-0.4D+01/(AK22-0.1D+01)
        RES24 = RES24+CHEB24(K)*AMOM2
        AMOM0 = AMOM1
        AMOM1 = AMOM2
   40 CONTINUE
      RESULT = RES24
      ABSERR = ABS(RES24-RES12)
   50 RETURN
      END


C
C**************************  ANIS3D ************************************
C
C  rotate the current element so that the local x-axis is aligned with
C  the velocity vector
C
C***********************************************************************
C
      SUBROUTINE ANIS3D(UUL,VVL,WWL,XX,YY,ZZ,VEL)
C
      IMPLICIT  NONE
      INTEGER   I
      REAL*8    UMOD,WMOD
      REAL*8    UUL,VVL,WWL,VEL
      REAL*8    XA(4),YA(4),ZA(4)
      REAL*8    XX(4),YY(4),ZZ(4)
C
      VEL =DSQRT(UUL*UUL + VVL*VVL + WWL*WWL)
      IF (VEL .EQ. 0.0D0) RETURN
      UMOD=DSQRT(VVL*VVL + UUL*UUL)
      WMOD=UMOD*VEL

      DO I=1,4
         XA(I)=XX(I)
         YA(I)=YY(I)
         ZA(I)=ZZ(I)
      END DO
      IF (UMOD .EQ. 0.0D0) THEN
         DO I=1,4
            XX(I)=ZA(I)
            YY(I)=XA(I)
            ZZ(I)=YA(I)
         END DO
      ELSE
         DO I=1,4
            XX(I)=(UUL*XA(I) + VVL*YA(I) + WWL*ZA(I))/VEL
            YY(I)=(VVL*XA(I) - UUL*YA(I))/UMOD
            ZZ(I)=(UUL*WWL*XA(I) + VVL*WWL*YA(I) -
     1            (UUL*UUL + VVL*VVL)*ZA(I))/WMOD
         END DO
      END IF
C
      RETURN
      END


      double precision function sciround(x1)
c!
c     Copyright INRIA
      double precision x1,x,y,z,e,h
      data h/1.0d+9/
c
      x=x1
      if (x.eq.0d0) then
         sciround=x
         return
      endif
      if ((2.0d0*x).eq.dble(int(2.d0*x))) then
c     changing the signs gives round(0.5)=0 round(-0.5)=0
         if (x.gt.0.d0) x=x+1.d-10
         if (x.lt.0.d0) x=x-1.d-10
      endif
      z = abs(x)
c     -----testing Nans
      if (isanan(x).eq.1) then
         sciround=x
         return
      endif
      y = z + 1.0d+0
      if (y .eq. z) then
         sciround=x
         return
      endif
      y = 0.0d+0
      e = h
 10   if (e .ge. z) go to 20
      e = 2.0d+0*e
      go to 10
 20   if (e .le. h) go to 30
      if (e .le. z) y = y + e
      if (e .le. z) z = z - e
      e = e/2.0d+0
      go to 20
 30   z = int(z + 0.50d+0)
      y = y + z
      if (x .lt. 0.0d+0) y = -y
      sciround = y
      return
      end


program test_blas
  use magma
  use omp_lib
  implicit none
  INTEGER,PARAMETER::Ns(3)=(/5000,10000,15000/)
  INTEGER,PARAMETER::M=1000
  COMPLEX,ALLOCATABLE :: A(:,:),B(:,:),z(:,:)
  COMPLEX,ALLOCATABLE :: AA(:,:),BB(:,:)
  REAL,ALLOCATABLE    :: R(:,:,:)
  COMPLEX,ALLOCATABLE :: WORK(:)
  REAL,ALLOCATABLE    ::rwork(:),eig(:)
  INTEGER,ALLOCATABLE ::iwork(:)
  INTEGER :: i,j,lwork,lrwork,liwork,ne(5),info
  INTEGER :: nn,n

  REAL    :: time1,time2

  call magmaf_init()
  DO nn=1,3
        N=Ns(nn)
   time1=omp_get_wtime()
  Allocate(eig(N),R(N,N,4),A(N,N),b(N,N),z(N,N))
  CALL random_number(r)
  A=cmplx(R(:,:,1),R(:,:,2))
  call zherk("L","N",N,N,1.0,cmplx(R(:,:,3),R(:,:,4)),N,0.0,B,N)
  DO i=1,N
     DO j=1,i
        A(i,j)=conjg(A(j,i))
 !       B(i,j)=conjg(B(j,i))
     ENDDO
     b(i,i)=b(i,i)+50.0
     A(i,i)=real(A(i,i))
  ENDDO
  time2=omp_get_wtime()
  print *, "Init:",time2-time1

 time1=omp_get_wtime()
 allocate(work(1),rwork(1),iwork(1))
 call magmaf_zhegvdx_m(4,1,'v','i','L',N,A,N,B,N,0.0,0.0,1,M,ne,eig,work,-1,rwork,lrwork,iwork,liwork,info)
 print*,info
 lwork=work(1);lrwork=rwork(1);liwork=iwork(1)
 print *,info,lwork
 deallocate(work,iwork,rwork)
 allocate(work(lwork),rwork(lrwork),iwork(liwork))
 call magmaf_zhegvdx_m(4,1,'v','i','L',N,A,N,B,N,0.0,0.0,1,M,ne,eig,work,lwork,rwork,lrwork,iwork,liwork,info)
 print *,ne,info
 time2=omp_get_wtime()
 print *, N,"MAGMA:",time2-time1
 deallocate(work,iwork,rwork)
 deallocate(eig,R,A,b,z)

 enddo

end


       double precision function sig2_corrdebye(natoms, tk, theta,
     $     rnorm, x, y, z, atwt)
c
c  copyright 2012  matt newville
c
c arguments:
c    natoms  *int, lengths for x, y, z, atwt        [in]
c    tk      *double, sample temperature (K)        [in]
c    theta   *double, Debye temperature (K)         [in]
c    rnorm   *double, Norman radius (Ang)           [in]
c    x       *double, array of x coord (Ang)        [in]
c    y       *double, array of y coord (Ang)        [in]
c    x       *double, array of z coord (Ang)        [in]
c    atwt    *double, array of atomic_weight (amu)  [in]
c ouput:
c    sig2_cordby  double, calculated sigma2
c
c Note:
c     natoms must be >= 2.
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  the following routines calculate the debye-waller factor for a
c  path based on the temperature, debye temperature, average
c  norman radius, atoms in the path, and their positions.
c  these routines come courtesy of jj rehr and si zabinsky.
c  i changed them a bit.   matt n
c-------------------------------------------------------------------
c
c  from s i zabinsky.
c  inputs:
c       tk      temperature in degrees k
c       theta   debye temp in degrees k
c       rs      average wigner seitz or norman radius in bohr
c                     averaged over entire problem:
c                     (4pi/3)*rs**3 = sum( (4pi/3)rnrm**3 ) / n
c                     (sum is over all atoms in the problem)
c       nleg    nlegs in path
c       rat     positions of each atom in path (in bohr)
c       iz      atomic number of each atom in path
c output:
c       sig2    debye waller factor
c  notes:
c     all units of distance in this routine are angstroms
c     there are nleg atoms including the central atom.
c     index 0 and index nleg both refer to central atom.
       implicit none
       integer          natoms, i0, i1, j0, j1
       double precision tk, theta, rnorm, sig2
       double precision ri0j0, ri1j1, ri1j0, ri0i1, rj0j1, ri0j1
       double precision ci0j0, ci1j1, ci1j0, ci0j1, sig2ij
       double precision ridotj, corrfn, dist
       double precision  x(*), y(*), z(*), atwt(*)
       external dist, corrfn
c
       sig2 = 0.d0
       do 800 i0 = 1, natoms
          i1 = 1 + mod(i0, natoms)
          do 800 j0 = i0, natoms
             j1 = 1 + mod(j0, natoms)
c  calculate r_i-r_i-1 and r_j-r_j-1 and the rest of the
c  distances, and get the partial cosine term:
c       cosine(i,j) = r_i.r_j / ((r_i0- r_i-1) * (r_j - r_j-1))
           ri0j0  = dist(x(i0), y(i0), z(i0), x(j0), y(j0), z(j0))
           ri1j1  = dist(x(i1), y(i1), z(i1), x(j1), y(j1), z(j1))
           ri0j1  = dist(x(i0), y(i0), z(i0), x(j1), y(j1), z(j1))
           ri1j0  = dist(x(i1), y(i1), z(i1), x(j0), y(j0), z(j0))
           ri0i1  = dist(x(i0), y(i0), z(i0), x(i1), y(i1), z(i1))
           rj0j1  = dist(x(j0), y(j0), z(j0), x(j1), y(j1), z(j1))
           ridotj = ((x(i0) - x(i1)) * (x(j0) - x(j1)) +
     $               (y(i0) - y(i1)) * (y(j0) - y(j1)) +
     $               (z(i0) - z(i1)) * (z(j0) - z(j1)) )
c
c  call corrfn to get the correlations between atom pairs
           ci0j0 = corrfn(ri0j0, theta, tk, atwt(i0), atwt(j0), rnorm)
           ci1j1 = corrfn(ri1j1, theta, tk, atwt(i1), atwt(j1), rnorm)
           ci0j1 = corrfn(ri0j1, theta, tk, atwt(i0), atwt(j1), rnorm)
           ci1j0 = corrfn(ri1j0, theta, tk, atwt(i1), atwt(j0), rnorm)
c
c  combine outputs of corrfn to give the debye-waller factor for
c  this atom pair. !! note: don't double count (i.eq.j) terms !!!
           sig2ij = ridotj*(ci0j0 + ci1j1 - ci0j1 - ci1j0)/(ri0i1*rj0j1)
           if (j0.eq.i0) sig2ij = sig2ij / 2.d0
           sig2 = sig2 + sig2ij
 800   continue
       sig2_corrdebye = sig2/2.d0
       return
c  end subroutine sig2_corrdebye
       end
       double precision function corrfn(rij, theta, tk, am1, am2, rs)
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  subroutine calculates correlation function
c  c(ri, rj) = <xi xj> in the debye approximation
c
c            = (1/n)sum_k exp(ik.(ri-rj)) (1/sqrt(mi*mj))*
c                              (hbar/2w_k)*coth(beta hbar w_k/2)
c
c            = (3kt/mu w_d**2) * sqrt(mu**2/mi*mj) * int
c  where :
c       x        k_d*r (distance parameter)  r distance in angstroms
c       theta    debye temp in degrees k
c       tk       temperature in degrees k
c       temper   theta / tk = hbar omegad/kt
c       k_d      debye wave number = (6*pi**2 n/v)
c       n/v      free electron number density = 1/(4pi/3rs**3)
c       rs       wigner seitz or norman radius in bohr
c       ami      atomic mass at sites i in amu
c       amj      atomic mass at sites j in amu
c       int      int_0^1 (temper/x) dw sin(wx)coth(w*temper/2)
c
c  solution by numerical integration
c
c  parameters pi, bohr, con
c  con=hbar**2/kb*amu)*10**20   in ang**2 units
c    k_boltz = 8.6173324e-5  # [eV / K]
c    amu     = 931.494061e6  # [eV / (c*c)]
c    hbarc   = 1973.26938    # [eV * A]
c    bohr    = 0.52917721    # [A]
c conh = (3/2.)* hbar**2 / (kb*amu) ~= 72.76
c conr = (9*pi/2)**(1/3.0) / bohr   ~=  4.57
       implicit none
       double precision rs, theta, tk,  rij, rx, tx, am1, am2
       double precision conr, conh, rmass, debint
       parameter (conh = 72.7630804732553d0, conr = 4.5693349700844d0)
       external debint
c
c  theta in degrees k, t temperature in degrees k
       rx     = conr  * rij / rs
       tx     = theta / tk
       rmass  = theta * sqrt(am1 * am2)
       corrfn = conh  * debint(rx, tx) / rmass
       return
c  end subroutine corrfn
       end
       double precision function debfun(w, rx, tx)
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  debfun = (sin(w*rx)/rx) * coth(w*tx/2)
c
       implicit none
       double precision  wmin, argmax, w, emwt
       parameter (wmin = 1.d-20, argmax = 50.d0)
       double precision rx, tx

c  allow t = 0 without bombing
       debfun = 2 / tx
       if (w.gt.wmin) then
          debfun = w
          if (rx.gt.0) debfun = sin(w*rx) / rx
          emwt   = exp(-min(w*tx,argmax))
          debfun = debfun * (1 + emwt) / (1 - emwt)
       end if
       return
c  end function debfun
       end
       double precision function debint (rx, tx)
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  subroutine calculates integrals between [0,1]  b = int_0^1 f(z) dz
c  by trapezoidal rule and binary refinement  (romberg integration)
c  coded by j rehr (10 feb 92)   see, e.g., numerical recipes
c  for discussion and a much fancier version
c-----------------------------------------------
c     del=dz  itn=2**n tol=1.e-5
c     starting values
c      implicit double precision (a-h,o-z)
c     error is approximately 2**(-2n) ~ 10**(-.6n)
c     so nmax=10 implies an error of 1.e-6
c
       implicit none
       integer  nmax, n, itn, i
       double precision tol, zero, one, two, three, debfun
       double precision rx, tx
       parameter(nmax = 12, tol = 1.d-9)
       parameter(zero=0.d0, one=1.d0, two=2.d0, three=3.d0)
       double precision del, bn, bo, zi, sum, bnp1
       external debfun
c
       itn = 1
       del  = one
       debint = zero
       bn   = (debfun(zero,rx,tx) + debfun(one,rx,tx)) /2
       bo   = bn
       do 40 n = 1, nmax
c  nth iteration
c  b_n+1=(b_n)/2+deln*sum_0^2**n f([2n-1]deln)
         del = del / two
         sum = zero
         do 20 i= 1, itn
            zi  = (two * i - 1) * del
            sum = sum + debfun(zi,rx,tx)
 20      continue
c     bnp1=b_n+1 is current value of integral
c     cancel leading error terms b=[4b-bn]/3
c     note: this is the first term in the neville table - remaining
c           errors were found too small to justify the added code
         bnp1   = del * sum + (bn / two)
         debint = (4 * bnp1 - bn)/three
         if (abs( (debint - bo) / debint).lt.tol) goto 45
         bn   = bnp1
         bo   = debint
         itn  = itn * 2
 40    continue
 45    continue
       return
c end function debint
       end
       double precision function dist(x0, y0, z0, x1, y1, z1)
c  find distance between cartesian points (x, y, z)0 and (x, y, z)1
       double precision x0, y0, z0, x1, y1, z1
       dist = sqrt((x0-x1)**2 + (y0-y1)**2 + (z0-z1)**2)
       return
c  end function dist
       end


      SUBROUTINE TAVISPAK3B(ANGREQ,UTARG,ORBDATA,EABEGIN,EACEASE,
     *             KVISFLAG,LUERR,IERR)
      IMPLICIT REAL*8(A-H, O-Z)
C
C THIS ROUTINE IS PART OF THE TAVISPAK SUBROUTINE SET. IT COMPUTES THE
C ECCENTRIC ANOMALY ANGLES AT WHICH THE ZENITH SEPARATION REQUIREMENT IS
C FIRST AND LAST SATISFIED. IT DIFFERS FROM TAVISPAK3A1 AND TAVISPAK3A2
C IN THAT THOSE ARE PART OF AN ITERATION PROCESS.  THIS ROUTINE PRODUCES
C THE ANGLES WITHOUT ITERATING.
C
C
C VARIABLE DIM TYPE I/O DESCRIPTION
C -------- --- ---- --- -----------
C
C ANGREQ    1   R*8  I  SAME DESCRIPTION AS IN TAVISPAK.
C
C UTARG     1   R*8  I  SAME DESCRIPTION AS IN TAVISPAK.
C
C EABEGIN   1   R*8  O  THE ECCENTRIC ANOMALY ANGLE AT WHICH THE ZENITH
C                       SEPARATION REQUIREMENT IS FIRST SATISFIED.
C
C EACEASE   1   R*8  O  THE ECCENTRIC ANOMALY ANGLE AT WHICH THE ZENITH
C                       SEPARATION REQUIREMENT IS LAST SATISFIED.
C
C ORBDATA   *   R*8  I  VALUES OF QUANTITES NEEDED TO COMPUTE RAMFCN.
C                       SET IN TAVISPAK. SEE TAVISPAK FOR DIMENSION.
C
C KVISFLAG  1   I*4  O  FLAG INDICATING NEVER/SOMETIMES/ALWAYS NATURE
C                       OF THE TARGET'S AVAILABILITY.
C                       = -1, NEVER AVAILABLE.
C                       =  0, SOMETIMES AVAILABLE, SOMETIMES NOT.
C                       =  1, ALWAYS AVAILABLE.
C
C IERR      1   I*4  O  ERROR RETURN FLAG.
C                       = 0, NO ERRORS.
C                       = 7, ANGREQ OUTSIDE OF 0 TO PI RANGE.
C
C***********************************************************************
C
C  CODED BY H SWARTWOOD AND C PETRUZZO, GSFC/742, 1/86.
C    MODIFIED....
C
C***********************************************************************
C
      REAL*8 POS(3),P(3),Q(3),UTARG(3),ORBDATA(20),SOLN(2),ANGOLD/1.D10/
      REAL*8 HALFPI / 1.570796326794897D0 /
      REAL*8 PI     / 3.141592653589793D0 /
      REAL*8 DEGRAD / 57.29577951308232D0 /
      REAL*8 TOLER/1.D-5/
C
      IBUG = 0
      LUBUG = 19
C
      IF(IBUG.NE.0) WRITE(LUBUG,9001) ANGREQ*DEGRAD,UTARG,ORBDATA
 9001 FORMAT(' TAVISPAK3B. DEBUG. ENTRY INFO. ANGREQ=',G16.8/,
     *  '    UTARG=',3G16.8/,'    ORBDATA=',(T15,4G16.8))
C
C INITIALIZE
C
      IERR =  0
      SMA =   ORBDATA( 1)
      ECC =   ORBDATA( 2)
      P(1) =  ORBDATA( 3)
      P(2) =  ORBDATA( 4)
      P(3) =  ORBDATA( 5)
      Q(1) =  ORBDATA( 6)
      Q(2) =  ORBDATA( 7)
      Q(3) =  ORBDATA( 8)
      TERM3 = ORBDATA(11)
C
      IF(ANGREQ.NE.ANGOLD) THEN
        COSREQ = DCOS(ANGREQ)
        ANGOLD = ANGREQ
        END IF
C
C COMPUTE COEFFICIENTS A,B,C OF ZENITH FUNCTION.  THE ZENITH FUNCTION
C CAN BE EXPRESSED(NOT AN APPROXIMATION) AS
C       FCN = A*DCOS(ECCANOM) + B*DSIN(ECCANOM) - C
C
      SDOTP = DOT(UTARG,P)
      SDOTQ = DOT(UTARG,Q)
      A = SDOTP * SMA + SMA * ECC * COSREQ
      B = SDOTQ * TERM3
      C = SDOTP * SMA * ECC + SMA * COSREQ
C
      IF(IBUG.NE.0) WRITE(LUBUG,9002) SDOTP,SDOTQ,A,B,C
 9002 FORMAT(' TAVISPAK3B DEBUG. SDOTP,SDOTQ=',2G16.8/,
     *       '    A,B,C=',3G16.8)
C
C SOLVE FOR THE ZEROS OF THE ZENITH FUNCTION.
C
      CALL TAVISPAK99(A,B,C,SOLN,KVISFLAG,LUERR,IERR)
      IF(IERR.NE.0) GO TO 9999
C
      EABEGIN = SOLN(1)
      EACEASE = SOLN(2)
C
 9999 CONTINUE
      RETURN
      END


module global_variables
  complex(8),parameter :: zi = (0d0, 1d0)
  real(8),parameter :: pi = 4d0*atan(1d0)
  integer,parameter :: nx = 512
  real(8),parameter :: ev = 27.2114d0
  real(8),parameter :: Lx = 200d-9/0.529d-10, dx = Lx/nx
  real(8),parameter :: clight = 137.035999084d0
  real(8),parameter :: cm = 0.529177210903e-8
  real(8),parameter :: gamma = 2.0d0/ev
  integer,parameter :: nw = 128
  real(8),parameter :: wi = 20d0/ev, wf = 80d0/ev, dw = (wf-wi)/nw
  real(8),parameter :: volume = 112.0394d0

  integer,parameter :: nene = 4
  real(8) :: Eex_surface = 0d0 !(0.1d0/ev)/volume
  complex(8) :: zeps_w(0:nw,nene)
  real(8) :: Eene(nene), Temp(nene)

  real(8) :: Eex_x(0:nx),Temp_x(0:nx)
  complex(8) :: zeps_x(0:nx)

end module global_variables
!-------------------------------------------------------------------------------
program main
  use global_variables
  implicit none
  integer :: iw
  real(8) :: ww, reflectivity, transmission
  real(8) :: ref_gs(0:nw), tra_gs(0:nw)
  real(8) :: ref_pp(0:nw), tra_pp(0:nw)

  call setup_dielectric_function

  Eex_surface = 0d0 !(0.1d0/ev)/volume
  call calc_energy_distribution

  open(30,file='ref_trans_gs.out')
  do iw = 0, nw
    ww = wi + dw*iw
    call setup_dielectric_function_in_real_space(iw)
    call calc_maxwell(iw, reflectivity, transmission)
    ref_gs(iw) = reflectivity
    tra_gs(iw) = transmission
    write(30,"(999e26.16e3)")ww,reflectivity,transmission
  end do
  close(30)

  Eex_surface = (0.5d0/ev)/volume
  call calc_energy_distribution

  open(30,file='ref_trans_pp.out')
  do iw = 0, nw
    ww = wi + dw*iw
    call setup_dielectric_function_in_real_space(iw)
    call calc_maxwell(iw, reflectivity, transmission)
    ref_pp(iw) = reflectivity
    tra_pp(iw) = transmission
    write(30,"(999e26.16e3)")ww,reflectivity,transmission
  end do
  close(30)

  open(30,file='transient_abs.out')
  do iw = 0, nw
    ww = wi + dw*iw
    write(30,"(999e26.16e3)")ww,-log(tra_pp(iw)/tra_gs(iw))
  end do
  close(30)

!  zeps = 1d0
!  zeps_dx2 = 1d0
!  omega = 1d0
!  kx = omega/clight
!
!  Ez(nx) = 1d0
!  dEz_dx(nx) = zi*kx
!
!  do ix = 0, nx-1
!     Ez_0  = Ez(nx-ix)
!     dEz_dx_0 = dEz_dx(nx-ix)
!
!     zk1 = dEz_dx_0
!     zl1 = -omega**2/clight**2*zeps(nx-ix)*Ez_0
!
!     zk2 = dEz_dx_0 -0.5d0*dx*zl1
!     zl2 = -omega**2/clight**2*zeps_dx2(nx-ix)*(Ez_0-0.5d0*dx*zk1)
!
!     zk3 = dEz_dx_0 -0.5d0*dx*zl2
!     zl3 = -omega**2/clight**2*zeps_dx2(nx-ix)*(Ez_0-0.5d0*dx*zk2)
!
!     zk4 = dEz_dx_0 -1d0*dx*zl3
!     zl4 = -omega**2/clight**2*zeps(nx-ix-1)*(Ez_0-1d0*dx*zk3)
!
!     Ez(nx-ix-1) = Ez_0 - dx/6d0*(zk1+2d0*zk2+2d0*zk3+zk4)
!     dEz_dx(nx-ix-1) = dEz_dx_0 - dx/6d0*(zl1+2d0*zl2+2d0*zl3+zl4)
!
!  end do
!
!
!  open(20,file="zEz.out")
!  do ix = 0, nx
!     write(20,"(99e26.16e3)")dx*ix,Ez(ix)
!  end do
!  close(20)

end program main
!-------------------------------------------------------------------------------
subroutine calc_maxwell(iw, reflectivity, transmission)
  use global_variables
  implicit none
  integer,intent(in) :: iw
  real(8),intent(out) :: reflectivity, transmission
  real(8) :: ww, k0
  complex(8) :: Ez, dEz_dx
  complex(8) :: Ez_0, dEz_dx_0
  complex(8) :: zeps_mid
  complex(8) :: zk1, zk2, zk3, zk4
  complex(8) :: zl1, zl2, zl3, zl4
  integer :: ix
  complex(8) :: za, zr, zt

  ww = wi + dw*iw
  k0 = ww/clight

  Ez = 1d0
  dEz_dx = zi*k0*Ez
  zt = Ez

  do ix = 0, nx-1
    zk1 = -k0**2*zeps_x(nx-ix)*Ez
    zl1 = dEz_dx

    zeps_mid = 0.5d0*(zeps_x(nx-ix)+zeps_x(nx-ix-1))
    zk2 = -k0**2*zeps_mid*(Ez-0.5d0*dx*zl1)
    zl2 = dEz_dx -0.5d0*dx*zk1

    zk3 = -k0**2*zeps_mid*(Ez-0.5d0*dx*zl2)
    zl3 = dEz_dx -0.5d0*dx*zk2

    zk4 = -k0**2*zeps_x(nx-ix-1)*(Ez-dx*zl3)
    zl4 = dEz_dx -dx*zk3

    dEz_dx = dEz_dx -dx/6d0*(zk1+2d0*zk2+2d0*zk3+zk4)
    Ez = Ez -dx/6d0*(zl1+2d0*zl2+2d0*zl3+zl4)

  end do

  za = 0.5d0*(Ez+dEz_dx/(zi*k0))
  zr = 0.5d0*(Ez-dEz_dx/(zi*k0))

  reflectivity = abs(zr/za)**2
  transmission = abs(zt/za)**2

end subroutine calc_maxwell
!-------------------------------------------------------------------------------
subroutine setup_dielectric_function
  use global_variables
  implicit none
  integer,parameter :: nt = 15503
  real(8) :: jt(0:nt,3), tt(0:nt), Act(0:nt,3), Act0
  real(8) :: ww, xx, window, dt
  integer :: it, iw, it_t
  complex(8) :: zsigma, zj, zE0, zeps
  character(256) :: cfilename(nene)
  real(8) :: ss
  integer :: iene

  Temp(1) = 300d0
  Eene(1) = -2.09855190d0/volume
  cfilename(1) ='../Te_300K/td.general/total_current'

  Temp(2) = 1000d0
  Eene(2) = -2.09838665d0/volume
  cfilename(2) ='../Te_1000K/td.general/total_current'

  Temp(3) = 2000d0
  Eene(3) = -2.09784157d0/volume
  cfilename(3) ='../Te_2000K/td.general/total_current'

  Temp(4) = 13000d0
  Eene(4) = -2.06769810d0/volume
  cfilename(4) ='../Te_13000K/td.general/total_current'

  ss = Eene(1)
  Eene = Eene -ss

  do iene = 1, nene

    open(20,file=trim(cfilename(iene)))
    read(20,*); read(20,*)
    read(20,*); read(20,*)
    do it = 0, nt
      read(20,*)it_t,tt(it), jt(it,1:3)
    end do
    dt = tt(1)-tt(0)

    Act0 = -6.851799983950d-01/137.035999679d0

    do iw = 0, nw
      ww = wi + dw*iw
      zj = 0d0
      do it = 0, nt
!        xx = (tt(it)-tt(0))/(tt(nt)-tt(0))
!        window = 1d0 -3d0*xx**2 + 2d0*xx**3
        window = exp(-gamma*(tt(it)-tt(0)))
        zj = zj + exp(zi*ww*(tt(it)-tt(0))-0.5d0*dt)*window*jt(it,3)
      end do
      zj = zj*dt/volume
      zE0 = Act0*exp(zi*ww*tt(0))
      zsigma = zj/zE0

      zeps_w(iw,iene) = 1d0 + 4d0*pi*zi*zsigma/ww

    end do

  end do

end subroutine setup_dielectric_function
!-------------------------------------------------------------------------------
subroutine calc_energy_distribution
  use global_variables
  implicit none
  complex(8) :: zeps_IR
  real(8) :: ww, k0, ss, xx
  complex(8) :: zk,zt,zalpha, zbeta, zE0
  integer,parameter :: Np = nene
  real(8) :: xn(0:Np-1),yn(0:Np-1),an(0:Np-2),bn(0:Np-2),cn(0:Np-2),dn(0:Np-2)
  integer :: ix

  zeps_IR = -66.405d0 + zi*44.255d0
  ww = 1.6d0/ev
  k0 = ww/clight
  zk = k0 * sqrt(zeps_IR)
  zt = 2d0*k0*zk/(2d0*k0*zk*cos(zk*Lx) - zI*(k0**2+zk**2)*sin(zk*Lx))
  zalpha = -2d0*k0*(k0+zk)*exp(-zi*zk*Lx)/(&
    -(k0+zk)**2*exp(-zi*zk*Lx)+(k0-zk)**2*exp(zi*zk*Lx) )
  zbeta  = 2d0*k0*(k0-zk)*exp(zi*zk*Lx)/(&
    -(k0+zk)**2*exp(-zi*zk*Lx)+(k0-zk)**2*exp(zi*zk*Lx) )

  do ix = 0, nx
    xx = dx*ix
    zE0 = zalpha*exp(zi*zk*xx) + zbeta*exp(-zi*zk*xx)
    Eex_x(ix) = abs(zE0)**2
  end do

  ss = Eex_x(0)
  Eex_x = Eex_x*Eex_surface/ss

  xn(0:np-1) = Eene(1:np)
  yn(0:np-1) = Temp(1:np)
  call spline(Np,xn,yn,an,bn,cn,dn)

  do ix = 0, nx
    xx = dx*ix
    call calc_signal(Np,xn,yn,an,bn,cn,dn,Eex_x(ix),ss)
    Temp_x(ix) = ss
  end do

  open(30,file='Eex_Te_dist.out')
  do ix = 0, nx
    xx = dx*ix
    write(30,"(999e26.16e3)")xx, Eex_x(ix), Temp_x(ix)
  end do
  close(30)

end subroutine calc_energy_distribution
!-------------------------------------------------------------------------------
subroutine setup_dielectric_function_in_real_space(iw)
  use global_variables
  implicit none
  integer,intent(in) :: iw
  integer,parameter :: Np = nene
  real(8) :: xn(0:Np-1)
  real(8) :: yn_r(0:Np-1),an_r(0:Np-2),bn_r(0:Np-2),cn_r(0:Np-2),dn_r(0:Np-2)
  real(8) :: yn_i(0:Np-1),an_i(0:Np-2),bn_i(0:Np-2),cn_i(0:Np-2),dn_i(0:Np-2)
  integer :: iene, ix
  real(8) :: sr, si, xx

  do iene = 1, nene
    xn(iene-1)    = Eene(iene)
    yn_r(iene-1)  = real( zeps_w(iw,iene))
    yn_i(iene-1)  = aimag(zeps_w(iw,iene))
  end do

  call spline(Np,xn,yn_r,an_r,bn_r,cn_r,dn_r)
  call spline(Np,xn,yn_i,an_i,bn_i,cn_i,dn_i)

  zeps_x = 0d0

  do ix = 0, nx
    xx = dx*ix
    call calc_signal(Np,xn,yn_r,an_r,bn_r,cn_r,dn_r,Eex_x(ix),sr)
    call calc_signal(Np,xn,yn_i,an_i,bn_i,cn_i,dn_i,Eex_x(ix),si)
    zeps_x(ix) = sr + zi*si
  end do

end subroutine setup_dielectric_function_in_real_space
!-------------------------------------------------------------------------------
subroutine spline(Np,xn,yn,an,bn,cn,dn)
  implicit none
  integer,intent(in) :: Np
  real(8),intent(in) :: xn(0:Np-1),yn(0:Np-1)
  real(8),intent(out) :: an(0:Np-2),bn(0:Np-2),cn(0:Np-2),dn(0:Np-2)
  integer :: i,j,k,Npm2
  real(8) :: dxn(0:Np-1),dyn(0:Np-1),u(1:Np-2),v(1:Np-2),Amat(1:Np-2,1:Np-2)
  real(8) :: Amat_t(1:Np-2,1:Np-2),Amat_chk(1:Np-2,1:Np-2)
  real(8) :: ss
! for lapack
  integer :: LWORK
  integer, allocatable :: IPIV(:) ! dimension N
  real(8), allocatable :: WORK(:) ! dimension LWORK
  integer :: info

  Npm2 = Np-2
  LWORK = Npm2*Npm2*6
  allocate(IPIV(Npm2),WORK(Npm2))

  do i = 0,Np-2
    dxn(i) = xn(i+1) - xn(i)
    dyn(i) = yn(i+1) - yn(i)
  end do

  do i = 1,Npm2
    v(i) = 6d0*(dyn(i)/dxn(i) - dyn(i-1)/dxn(i-1))
  end do

  Amat = 0d0
  Amat(1,1) = 2d0*(dxn(1) + dxn(0))
  Amat(1,2) = dxn(1)
  do i = 2,Npm2-1
    Amat(i,i+1) = dxn(i)
    Amat(i,i) = 2d0*(dxn(i)+dxn(i-1))
    Amat(i,i-1) = dxn(i-1)
  end do
  Amat(Npm2,Npm2) = 2d0*(dxn(Npm2)+dxn(Npm2-1))
  Amat(Npm2,Npm2-1) = dxn(Npm2-1)

! inverse matrix problem
  Amat_t = Amat

  call DGETRF(Npm2, Npm2, Amat_t, Npm2, IPIV, info)  ! factorize
  call DGETRI(Npm2, Amat_t, Npm2, IPIV, WORK, LWORK, info)  ! inverse

!  check inverse matrix problem
!  do i = 1,Npm2
!    do j = 1,Npm2
!      ss = 0d0
!      do k = 1,Npm2
!        ss = ss + Amat(i,k)*Amat_t(k,j)
!      end do
!      Amat_chk(i,j) = ss
!    end do
!  end do
!
!  do i = 1,Npm2
!    write(*,'(999e16.6e3)')(Amat_chk(i,j),j=1,Npm2)
!  end do
!
!  stop

  do i = 1,Npm2
    u(i) = sum(Amat_t(i,:)*v(:))
!    write(*,*)u(i),v(i)
  end do
!  stop

! for b
  bn(0) = 0d0
  bn(1:Np-2) = 0.5d0*u(1:Np-2)
! for a
  do i = 0,Npm2-1
    an(i) = (u(i+1) -2d0*bn(i))/(6d0*dxn(i))
  end do
  an(Npm2) = (0d0 -2d0*bn(Npm2))/(6d0*dxn(Npm2))
! for d
  dn(0:Npm2) = yn(0:Npm2)
! for c
  cn(0) = dyn(0)/dxn(0) - dxn(0)*(u(0+1)+2d0*0d0)/6d0
  do i = 1,Npm2-1
    cn(i) = dyn(i)/dxn(i) - dxn(i)*(u(i+1)+2d0*u(i))/6d0
  end do
  cn(Npm2) = dyn(Npm2)/dxn(Npm2) - dxn(Npm2)*(0d0+2d0*u(Npm2))/6d0

  return
end subroutine spline
!-------------------------------------------------------------------------------
subroutine calc_signal(Np,xn,yn,an,bn,cn,dn,xx,signal)
  implicit none
  integer,intent(in) :: Np
  real(8),intent(in) :: xn(0:Np-1),yn(0:Np-1)
  real(8),intent(in) :: an(0:Np-2),bn(0:Np-2),cn(0:Np-2),dn(0:Np-2)
  real(8),intent(in) :: xx
  real(8),intent(out) :: signal
  integer :: ip
  real(8) :: dx, xx_abs

  xx_abs = abs(xx)

  if(xx_abs < xn(0))then
    write(*,*)"Error: xx<xn(0)"
    stop
  end if

  if(xx_abs > xn(Np-1))then
    write(*,*)"Error: xx>xn(Np-1)"
    stop
  end if

  do ip = 1,Np-1
    if(xx_abs <= xn(ip))exit
  end do
  ip = ip - 1
  dx = xx_abs - xn(ip)

  signal = an(ip)*dx**3 + bn(ip)*dx**2 + cn(ip)*dx + dn(ip)
  signal = sign(signal,xx)

end subroutine calc_signal


!>
!! Evaluate a pressure forcing terms in the unsteady
!! kinematic and dynamic free surface conditions.
!!
!!    dE/dt = rhsE + Wavefield%NuD
!!    dP/dt = rhsP + Wavefield%P0 + Wavefield%Pd
!!
!! Wavefield%P0 represents an applied pressure patch on the free surface to model
!! for example a simple ship-like geometry.  It is in general of the form
!!
!!    Wavefield%P0 = -p/rho
!!
!! with rho the density of the fluid and p the applied free surface pressure.
!!
!! Pd and NuD are pressures corresponding to the application of friction damping
!! to either the potential and elevation; or the velocity and elevation.  These
!! pressures are only non-zero in the wave absorption regions defined by the
!! Data Structure "PDampZones" which is set up in the subroutine
!! PreprocessPDampingZones.f90.
!!
!! This function needs to be updated and recompiled for
!! changes to take effect.
!!
!! NuD and Pd are friction damping terms applied to absorb waves.
!<
SUBROUTINE funPressureTerm(t,g,Nx,Ny,FineGrid,Wavefield)
  USE Precision
  USE Constants
  USE DataTypes
  USE GlobalVariables, ONLY: PressureTermONOFF, Lz, NDampZones, PDampingOnOff, PDampZones, alpha
  IMPLICIT NONE
  INTEGER :: Nx,Ny, i, j, k, nd, rank, id0, job, id, idebug
  REAL(KIND=long) :: t, g, x0, y0, sigma, sigmay, Lx, Ly, dx, Fr, V, rhs(Nx*Ny),            &
       tmp(Nx*Ny), magk
  !REAL(KIND=long), DIMENSION(Nx,Ny), INTENT(OUT) :: term ! includes ghost points
  TYPE (Level_def), INTENT(IN) :: FineGrid
  TYPE (Wavefield_FS), INTENT(OUT) :: Wavefield
  !
  ! The implemented types of pressure patches are:
  !
  !  PressureTermOnOff=0  -> No pressure (default)
  !  PressureTermOnOff=1  -> Stationary 2D Gaussian hump
  !  PressureTermOnOff=2  -> Moving 3D Gaussian hump
  !
  !
  If (PressureTermOnOff==1) Then
     !
     ! Apply a 2D stationary Gaussian hump
     !
     Lx=FineGrid%x(Nx-1,1)-FineGrid%x(2,1);
     if(Lx .lt. 1.e-14) then
        Lx=one
     endif
     !
     ! The center and variance of the Gaussian.
     !
     x0=Lx/2;  sigma=Lx/8;
     !
     DO j = 1, Ny ! ghost points implicitly assumed to be included
        DO i = 1 , Nx ! ghost points implicitly assumed to be included
           ! This following line defines the pressure forcing for each point
           Wavefield%P0(i,j) = -.01*g*Exp(-(FineGrid%x(i,j)-x0)**2/(2*sigma**2))
        END DO
     END DO
  ELSEIf (PressureTermOnOff==2) Then
     !
     ! Apply a moving Gaussian hump in 3D
     !
     Lx=FineGrid%x(Nx-1,1)-FineGrid%x(2,1); dx=FineGrid%x(2,1)-FineGrid%x(1,1);
     Ly=FineGrid%y(1,Ny-1)-FineGrid%y(1,2);
     !
     if(Lx .lt. 1.e-14) then
        Lx=one
     endif
     if(Ly .lt. 1.e-14) then
        Ly=one
     endif
     !
     ! The center and variance of the Gaussian.
     !
     sigma=sqrt(3*dx); x0=3*sigma**2+2*t;
     y0=0; sigmay=sigma/2;
     !
     DO j = 1, Ny ! ghost points implicitly assumed to be included
        DO i = 1 , Nx-1 ! ghost points implicitly assumed to be included
           !
           ! The pressure forcing for each point
           !
           Wavefield%P0(i,j) =-0.01*g*Exp(-(FineGrid%x(i,j)-x0)**2/(2*sigma**2)  &
                -(FineGrid%y(i,j)-y0)**2/(2*sigmay**2))
        END DO
     END DO
  ELSEIf (PressureTermOnOff==3) Then
     !
     ! Apply a moving tanh hump in 3D
     !
     Lx=FineGrid%x(Nx-1,1)-FineGrid%x(2,1); dx=FineGrid%x(2,1)-FineGrid%x(1,1);
     Ly=FineGrid%y(1,Ny-1)-FineGrid%y(1,2);
     !
     if(Lx .lt. 1.e-14) then
        Lx=one
     endif
     if(Ly .lt. 1.e-14) then
        Ly=one
     endif
     !
     ! The center and variance of the Gaussian.
     !
     Fr=0.9;
     V=Fr*sqrt(g*Lz);
     sigma=sqrt(3*dx); x0=3*sigma**2+V*t;
     y0=0; sigmay=sigma/2;
     !
     DO j = 1, Ny ! ghost points implicitly assumed to be included
        DO i = 1 , Nx-1 ! ghost points implicitly assumed to be included
           !
           ! The pressure forcing for each point
           !
           ! Wavefield%P0(i,j) =-0.07*g*Exp(-(FineGrid%x(i,j)-x0)**2/(2*sigma**2)  &
           !     -(FineGrid%y(i,j)-y0)**2/(2*sigmay**2))
           !
           !! Li and Sclavounos
           !If ((FineGrid%x(i,j)-x0-1.3*t) .lt. (2*10.25)) then
           !            Wavefield%P0(i,j) =-g*0.735*((COS(Pi*(FineGrid%x(i,j)-x0-1.3*t)/(2*10.25)))**2) &
           !*((COS(Pi*(FineGrid%y(i,j)-y0)/(2*1.825)))**2)
           !else
           !Wavefield%P0(i,j) =0
           !endif
           !
           !! Sung & Grilli (2005)
           !
           Wavefield%P0(i,j) =-g*0.01*(TANH(FineGrid%x(i,j)-x0+2)-TANH(FineGrid%x(i,j)-x0-2)) &
                *(TANH(FineGrid%y(i,j)-y0+2)-TANH(FineGrid%y(i,j)-y0-2))
        END DO
     END DO
  endif
  !
  ! Pressure damping terms.
  !
  If (PDampingOnOff /= 0) Then
     id=1
     IF(PDampZones(id)%type==0) THEN
        !
        ! Apply a friction damping pressure to the velocity and/or elevation.
        !
        !
        ! Solve the equation L^2 p_d = Div(gamma Grad Phi) over the
        ! pressure damping region to get p_d there.
        !
        nd=PDampZones(id)%nx; id0=PDampZones(id)%idx(1); rank=2*alpha+1
        !
        ! A test case for debugging...
        idebug=0
        IF (idebug==1)THEN
           magk=10.*two*pi/(FineGrid%x(Nx,1)-FineGrid%x(1,1))
           do i=1,Nx
              Wavefield%P(i,1)=cos(magk*(FineGrid%x(i,1)-FineGrid%x(PDampZones(id)%idx(2),1)))
           end do
        end IF
        !
        ! Extract phi over the damping zone region
        !
        tmp(1:nd)=Wavefield%P(id0:id0+nd-1,1)
        !
        ! Take Grad phi
        !
        CALL DfDx_1D_Uneven(tmp,nd,PDampZones(id)%Grad,rank,rhs)
        !
        ! Multiply by gamma and take the divergence
        !
        Do i=1,nd
           tmp(i)=PDampZones(id)%gamPhi(id0+i-1)*rhs(i)
        END Do
        CALL DfDx_1D_Uneven(tmp,nd,PDampZones(id)%Grad,rank,rhs)
        !
        ! Add in the Dirichlet condition at the start of the zone and the Neumann
        ! condition at the end.
        !
        rhs(1) = Wavefield%P(id0,1); rhs(nd)=zero
        !
        ! Solve for p_d using the LU-factored Laplacian matrix.
        !
        JOB = 3;   ! Solution
        CALL MA41AD(JOB, nd, PDampZones(id)%Lop%nnz, PDampZones(id)%Lop%irn, PDampZones(id)%Lop%icn,    &
             PDampZones(id)%Lop%val, rhs, PDampZones(id)%Lop%COLSCA, PDampZones(id)%Lop%ROWSCA,         &
             PDampZones(id)%Lop%KEEP, PDampZones(id)%Lop%IS_HSL, PDampZones(id)%Lop%MAXIS,              &
             PDampZones(id)%Lop%SS, PDampZones(id)%Lop%MAXS, PDampZones(id)%Lop%CNTL,                   &
             PDampZones(id)%Lop%ICNTL, PDampZones(id)%Lop%INFOHSL, PDampZones(id)%Lop%RINFO)

        if (PDampZones(id)%Lop%INFOHSL(1) .LT. 0) then ! Check for problems
           print *, 'Problems with MA41, JOB = 3 (Solution), in funPressureTerm.f90'
        end if
        !
        ! Apply friction damping to the elevation (kinematic FSBC).
        !
        j=1
        Do i=1,Nx
           k=(j-1)*Nx+i
           Wavefield%NuD(i,j)=-PDampZones(id)%gamEta(k)*Wavefield%E(i,j)
        END Do
        !
        ! Apply p_d to the dynamic FSBC to apply friction damping to the velocity.
        !
        !
        ! Set the pressure at the first point of the zone to zero to remove the arbitrary
        ! constant of integration.  Then apply the pressure over the damping zone.
        !
        Wavefield%Pd(1:Nx,1:Ny)=zero;
        Do i=1,nd
           Wavefield%Pd(id0+i-1,j)=-(rhs(i)-rhs(1))
        END Do
        !
        !
        IF(idebug==1)THEN
           Do i=1,nx
              write(202,*)FineGrid%x(i,1),WaveField%P(i,1),Wavefield%Pd(i,1)
           end Do
           stop
        END IF
     ELSE
        !
        ! Apply a friction damping pressure to the potential and/or elevation.
        !
        Do j=1,Ny
           Do i=1,Nx
              k=(j-1)*Nx+i
              Wavefield%NuD(i,j)=-PDampZones(id)%gamEta(k)*Wavefield%E(i,j)
              Wavefield%Pd(i,j)=-PDampZones(id)%gamPhi(k)*Wavefield%P(i,j)
           END Do
        END Do
     END IF
  END If
END SUBROUTINE funPressureTerm

!>
!! Evaluate the initial free surface elevation and the applied pressure.
!!
!!    dP/dt = rhsP + Wavefield%P0
!!
!! Wavefield%P0 is in general of the form
!!
!!    Wavefield%P0 = -p/rho
!!
!! with rho the density of the fluid and p the free surface pressure.
!!
!! This function needs to be updated and recompiled for
!! changes to take effect and it should be synched with the applied
!! pressure subroutine "funPressureTerm".
!<
SUBROUTINE funInitialFreeSurfaceElevation(g,Nx,Ny,FineGrid,WaveField)
  USE Precision
  USE Constants
  USE DataTYpes
  USE GlobalVariables, ONLY: PressureTermONOFF
  IMPLICIT NONE
  INTEGER :: Nx,Ny, i, j
  REAL(KIND=long) :: g, x0, y0, sigma, sigmay, Lx, Ly, dx
  TYPE (Level_def), INTENT(IN) :: FineGrid
  TYPE (Wavefield_FS), INTENT(OUT) :: Wavefield
  !
  !
  !  PressureTermOnOff=0  -> No pressure (default)
  !  PressureTermOnOff=1  -> Stationary 2D Gaussian hump
  !
  !
  If (PressureTermOnOff==1) Then
     !
     ! Apply a stationary Gaussian hump in 2D
     !
     Lx=FineGrid%x(Nx-1,1)-FineGrid%x(2,1);
     if(Lx .lt. 1.e-14) then
        Lx=one
     endif
     x0=Lx/2;  sigma=Lx/8;
     !
     DO j = 1, Ny ! ghost points implicitly assumed to be included
        DO i = 1 , Nx ! ghost points implicitly assumed to be included
           ! This following line defines the pressure forcing for each point
           Wavefield%P0(i,j) = -.01*g*Exp(-(FineGrid%x(i,j)-x0)**2/(2*sigma**2))
           Wavefield%E(i,j) = Wavefield%P0(i,j)/g
           Wavefield%P(i,j)=zero; Wavefield%W(i,j)=zero
        END DO
     END DO
  ELSEIf (PressureTermOnOff==2) Then
     !
     ! Apply a stationary Gaussian hump in 3D
     !
     Lx=FineGrid%x(Nx-1,1)-FineGrid%x(2,1); dx=FineGrid%x(2,1)-FineGrid%x(1,1);
     Ly=FineGrid%y(1,Ny-1)-FineGrid%y(1,2);
     !
     if(Lx .lt. 1.e-14) then
        Lx=one
     endif
     if(Ly .lt. 1.e-14) then
        Ly=one
     endif
     !
     ! The variance and center of the Gaussian
     !
     sigma=sqrt(3*dx); x0=3*sigma**2;
     y0=0; sigmay=sigma/2;
     !
     DO j = 1, Ny ! ghost points implicitly assumed to be included
        DO i = 1 , Nx-1 ! ghost points implicitly assumed to be included
           ! This line defines the pressure forcing for each point
           Wavefield%P0(i,j) =-0.01*g*Exp(-(FineGrid%x(i,j)-x0)**2/(2*sigma**2) &
                -(FineGrid%y(i,j)-y0)**2/(2*sigmay**2))
           Wavefield%E(i,j) = Wavefield%P0(i,j)/g
           Wavefield%P(i,j)=zero; Wavefield%W(i,j)=zero
        END DO
     END DO
   ELSEIf (PressureTermOnOff==3) Then
     !
     ! Apply a stationary tanh hump in 3D
     !
     Lx=FineGrid%x(Nx-1,1)-FineGrid%x(2,1); dx=FineGrid%x(2,1)-FineGrid%x(1,1);
     Ly=FineGrid%y(1,Ny-1)-FineGrid%y(1,2);
     !
     if(Lx .lt. 1.e-14) then
        Lx=one
     endif
     if(Ly .lt. 1.e-14) then
        Ly=one
     endif
     !
     ! The variance and center of the Gaussian
     !
     sigma=sqrt(3*dx); x0=3*sigma**2;
     y0=0; sigmay=sigma/2;
     !
     DO j = 1, Ny ! ghost points implicitly assumed to be included
        DO i = 1 , Nx-1 ! ghost points implicitly assumed to be included
           ! This line defines the pressure forcing for each point
           ! Wavefield%P0(i,j) =-0.05*g*Exp(-(FineGrid%x(i,j)-x0)**2/(2*sigma**2) &
           !     -(FineGrid%y(i,j)-y0)**2/(2*sigmay**2))
 !! Li and Sclavounos
!If ((FineGrid%x(i,j)-x0) .lt. (2*10.25)) then
 !           Wavefield%P0(i,j) =-g*0.735*((COS(Pi*(FineGrid%x(i,j)-x0)/(2*10.25)))**2) &
!*((COS(Pi*(FineGrid%y(i,j)-y0)/(2*1.825)))**2)
!else
!Wavefield%P0(i,j) =0
!endif
!
           ! Sung & Grilli (2005)
           !
           Wavefield%P0(i,j) =-g*0.01*(TANH(FineGrid%x(i,j)-x0+2)-TANH(FineGrid%x(i,j)-x0-2)) &
                *(TANH(FineGrid%y(i,j)-y0+2)-TANH(FineGrid%y(i,j)-y0-2))
           !
           Wavefield%E(i,j) = Wavefield%P0(i,j)/g
           Wavefield%P(i,j)=zero; Wavefield%W(i,j)=zero
        END DO
     END DO
 endif
END SUBROUTINE funInitialFreeSurfaceElevation


c /***************************************************
c   dmhalogen.f  for dbulhalo
c  18 Jan. 2011  written by D.Kawata
c ****************************************************/
c70*******************************************************************

c /*****   generating NFW DM halo or mext.dat *****/
      subroutine dmhaloprof(omg0,omz,hub,cnfw,rvir,zt
     &  ,xcut,rt,fb,flag)
      include 'define.f'

      integer flag
      double precision omg0,omz,hub,cnfw,rvir,zt
      double precision fb
      double precision rhoc,delc
c for work
      integer i
      character filen*60
c *** for radial profile ***
      double precision ri,ro,xcut,lri,lro,dlr,dr,rt,rs
      double precision mr,pmr,facnfw
      double precision rhoi,rhoo,x
c *** external function
      integer idum
      real ran1
      external ran1
      double precision rhonfwsw,mrnfw
      external rhonfwsw,mrnfw

      idum = -111

      rhoc = (3.0d0*HUB0*HUB0*hub*hub/(8.0d0*M_PI*G))
     &  *(omg0/omz)*((1.0d0+zt)**3)
      delc = (200.0d0/3.0d0)*(cnfw**3/(dlog(1.0d0+cnfw)
     &  -cnfw/(1.0d0+cnfw)))
      facnfw = delc*rhoc
      if(myrank.eq.0) then
        write(6,*) ' rhoc,delc,facnfw=',rhoc,delc,facnfw
      endif

c /*** integral of NFW profile ****/
      ri = frini0*rt
      ro = xcut*rt
      lri = dlog10(ri)
      lro = dlog10(ro)
      dlr = (lro-lri)/dble(ndr)
      ro = 0.0d0
      mr = 0.0d0
      do i=0,ndr
        if(i.ge.0) then
          rhoi = rhoo
          pmr = mr
        endif
        ri = ro
        ro = 10.0d0**(lri+dlr*dble(i))
        dr = ro-ri
        rhoo = rhonfwsw(ro,cnfw,rvir,rt,flag)
        if(i.lt.0) then
          rhoi = rhoo
        endif
        mr = mr+4.0d0*M_PI*0.5d0*(rhoo*(ro**2)+rhoi*(ri**2))
     &    *dr
        if(i.lt.0) then
          pmr = mr
        endif
        mrdmh(i) = (1.0d0-fb)*mr*facnfw
        rdmh(i) = ro
        rhodmh(i)=(1.0d0-fb)*rhoo*facnfw
      enddo

c *** set common values
      lrodmh=lro
      lridmh=lri
      dlrdmh=dlr
c NFW rs
      rs=rvir/cnfw

      if(myrank.eq.0) then
        open(62,file='mext-dmh.dat',status='unknown'
     &   ,form='unformatted')
        open(63,file='mexta-dmh.dat',status='unknown')
        write(62) ndr+1
        write(62) dlr,lri,lro
        do i=0,ndr
          x=rdmh(i)
          write(63,'(6(1pE13.5))') rdmh(i)*LUKPC,mrdmh(i)
     &     ,rhodmh(i)
     &     ,(1.0d0-fb)*facnfw*mrnfw(x,cnfw,rvir)
c escape velocity BT2nd p.71
     &     ,VUKMS*dsqrt(2.0d0*(1.0d0-fb)*facnfw*4.0d0*M_PI*(rs**2)
     &     *dlog(1.0d0+x/rs)/(x/rs)),x
          write(62) rdmh(i),mrdmh(i)
        enddo
        close(62)
        close(63)
      endif

      return
      end