	subroutine luminosity(tot_lumin)

	use gravdata
	use unitdata

	implicit none

	integer :: i,j
	real(kind=8) :: tot_lumin,lumin,Blam(1000)
	real(kind=8) :: lambda, dlambda, Teff

	do i = 1, 1000
  	spectrum(2,i) = 0.0d0
	Blam(i) = 0.0d0
	enddo

	do i=isr, ier

	Teff = Tc(i)**4.0d0*tau(i)/(1.0d0+tau(i)**2.0d0)
  	Teff = Teff**0.25d0

    	lumin =  16.0d0/3.0d0*stefan*Tc(i)**4.0d0
    	lumin =  lumin*tau(i)/(1.0d0+tau(i)**2.0d0)
    	lumin =  lumin*(pi*rz(i+1)**2.0d0-pi*rz(i)**2.0d0)

    	tot_lumin = tot_lumin+lumin

    	lambda = 1.0d-4      ! 1 micron in cm
    	dlambda = 1.0d-4     ! 1 micron in cm

    	do j = 1, 1000
      	Blam(j) = 2.0d0*planck*3.0d10**2.0d0/lambda**5.0d0
      	Blam(j) = Blam(j)/(DExp(planck*3.0d10/lambda/k_B/Teff)-1.0d0)

      	Blam(j) = Blam(j)*lambda*2.0d0*pi*rz(i)*(rz(i+1)-rz(i))

      	spectrum(1,j) = lambda

      	spectrum(2,j) = spectrum(2,j) + Blam(j)
      	spectrum(2,j) = spectrum(2,j)/4.0d0/pi/(140.0d0*pc)**2.0d0  ! distance of 140 pc

      	lambda = lambda + dlambda
    	enddo

	enddo

	return

	end subroutine luminosity


MODULE chirp_transform
! Module for the Fast Fourier transform of series of arbitrary length,
! using the CHIRP-Z transform.
! Adapted from Applied Statistics algorithms AS 117 and AS 83.
! Monro, D.M. & Branch, J.L. (1977) `The Chirp discrete Fourier transform of
! general length', Appl. Statist., 26 (3), 351-361.

! Translated to be compatible with Lahey's ELF90 compiler by Alan Miller
! amiller@bigpond.net.au    http://users.bigpond.net.au/amiller/
! Latest revision - 3 December 2002

IMPLICIT NONE
PRIVATE
PUBLIC  :: chrft, chfor, chrev, fastf, fastg, setwt

CONTAINS

SUBROUTINE chrft(x, y, wr, wi, isize, lwork, itype, ifault)

!  Algorithm AS 117.1 Appl. Statist. (1977) vol.26, no.3

!  Code for complex discrete Fourier transform of a sequence of general
!  length by the Chirp-Z transform

REAL, INTENT(IN OUT) :: x(:), y(:)
REAL, INTENT(IN)     :: wr(:), wi(:)
INTEGER, INTENT(IN)  :: isize, lwork, itype
INTEGER, INTENT(OUT) :: ifault

INTEGER         :: ii, k, np1, nn
REAL, PARAMETER :: zero = 0.0, one = 1.0
REAL            :: xwi, z, gc

!       Check that ISIZE and LWORK are valid

ifault = 0
IF (isize < 3) ifault = 1
ii = 4
DO k = 3, 20
  ii = ii * 2
  IF (ii == lwork) GO TO 3
  IF (ii > lwork) GO TO 2
END DO

2 ifault = ifault + 2
3 IF (lwork < 2 * isize) ifault = ifault + 4
IF (itype == 0) ifault = ifault + 8
IF (ifault /= 0) RETURN

!       Multiply by the Chirp function in the time domain

CALL chrp(x, y, one, isize, itype)
np1 = isize + 1
DO nn = np1, lwork
  x(nn) = zero
  y(nn) = zero
END DO

!       Fourier transform the chirped series

CALL fastf(x, y, lwork, 1)

!       Convolve by frequency domain multiplication with (wr, wi)

DO nn = 1, lwork
  xwi = wi(nn)
  IF (itype < 0) xwi = -xwi
  z = x(nn) * wr(nn) - y(nn) * xwi
  y(nn) = x(nn) * xwi + y(nn) * wr(nn)
  x(nn) = z
END DO

!       Inverse Fourier transform

CALL fastf(x, y, lwork, -1)

!       Multiply by Chirp function & gain correction

gc = lwork
IF (itype > 0) gc = gc/isize
CALL chrp(x, y, gc, isize, itype)

RETURN
END SUBROUTINE chrft

SUBROUTINE chfor(xray, wr, wi, jsize, lwork, mwork, ifault)

!       Algorithm AS 117.2 Appl. Statist. (1977) vol.26, no.3

!       Forward Chirp DFT for real even length input sequence

REAL, INTENT(IN)     :: wr(:), wi(:)
REAL, INTENT(IN OUT) :: xray(:)
INTEGER, INTENT(IN)  :: jsize, lwork, mwork
INTEGER, INTENT(OUT) :: ifault

INTEGER         :: ii, k, nn, ll, i, m, nnn, mm, j, jj
REAL, PARAMETER :: zero = 0.0, quart = 0.25, half = 0.5, one = 1.0,  &
                   one5 = 1.5, two = 2.0, four = 4.0
REAL            :: z, bcos, bsin, un, vn, save1, an, bn, cn, dn

!       Check for valid JSIZE, LWORK & MWORK

ifault = 0
ii = 8
DO k = 4, 21
  ii = ii * 2
  IF (ii == lwork) GO TO 3
  IF (ii > lwork) GO TO 2
END DO
2 ifault = 2
3 IF (lwork < 2 * jsize) ifault = ifault + 4
IF (lwork /= 2 * mwork) ifault = ifault + 16
nn = jsize / 2
IF (2 * nn /= jsize) ifault = ifault + 32
IF (nn < 3) ifault = ifault + 1
IF (ifault /= 0) RETURN
ll = mwork

!       Split XRAY into even and odd sequences of length n/2 placing
!       the even terms in the bottom half of XRAY as dummy real terms
!       and odd terms in the top half as dummy imaginary terms.

DO i = 1, nn
  ii = 2 * i
  m = ll + i
  xray(m) = xray(ii)
  xray(i) = xray(ii-1)
END DO

!       Perform forward Chirp DFT on even and odd sequences.

CALL chrft(xray, xray(ll+1:), wr, wi, nn, ll, 1, ifault)

!       Reorder the results according to output format.
!       First, the unique real terms.

z = half * (xray(1) + xray(ll+1))
xray(nn+1) = half * (xray(1) - xray(ll+1))
xray(1) = z

!       If nn is even, terms at nn/2 + 1 and 3*nn/2 can be calculated

nnn = nn / 2
IF (nn /= 2 * nnn) GO TO 5
m = nnn + 1
xray(m) = half * xray(m)
mm = m + ll
m = m + nn
xray(m) = -half * xray(mm)
GO TO 6
5 nnn = nnn + 1

!       Set up trig functions for calculations of remaining non-unique terms

6 z = four * ATAN(one) / nn
bcos = -two * (SIN(z/two) ** 2)
bsin = SIN(z)
un = one
vn = zero

!       Calculate & place remaining terms in correct locations.

DO i = 2, nnn
  z = un * bcos + un + vn * bsin
  vn = vn * bcos + vn - un * bsin
  save1 = one5 - half * (z * z + vn * vn)
  un = z * save1
  vn = vn * save1
  ii = nn + 2 - i
  m = ll + i
  mm = ll + ii
  an = quart * (xray(i) + xray(ii))
  bn = quart * (xray(m) - xray(mm))
  cn = quart * (xray(m) + xray(mm))
  dn = quart * (xray(i) - xray(ii))
  xray(i) = an + un * cn + vn * dn
  xray(ii) = two * an - xray(i)
  j = nn + i
  jj = nn + ii
  xray(j) = bn - un * dn + vn * cn
  xray(jj) = xray(j) - two * bn
END DO

RETURN
END SUBROUTINE chfor

SUBROUTINE chrev(xray, wr, wi, jsize, lwork, mwork, ifault)

!       Algorithm AS 117.3 Appl. Statist. (1977) vol.26, no.3

!       Inverse Chirp DFT to give real even length sequence

REAL, INTENT(IN OUT) :: xray(:)
REAL, INTENT(IN)     :: wr(:), wi(:)
INTEGER, INTENT(IN)  :: jsize, lwork, mwork
INTEGER, INTENT(OUT) :: ifault

INTEGER         :: ii, k, nn, ll, nnn, m, mm, i, j, jj
REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0, one5 = 1.5, two = 2.0,  &
                   four = 4.0
REAL            :: z, bcos, bsin, un, vn, save1, an, bn, pn, qn, cn, dn

!       Check for valid JSIZE, LWORK & MWORK

ifault = 0
ii = 8
DO k = 4, 21
  ii = ii * 2
  IF (ii == lwork) GO TO 3
  IF (ii > lwork) GO TO 2
END DO
2 ifault = 2
3 IF (lwork < 2 * jsize) ifault = ifault + 4
IF (lwork /= 2 * mwork) ifault = ifault + 16
nn = jsize / 2
IF (2 * nn /= jsize) ifault = ifault + 32
IF (nn < 3) ifault = ifault + 1
IF (ifault /= 0) RETURN
ll = mwork

!       Reorder the spectrum; first the unique terms.

z = xray(1) + xray(nn+1)
xray(ll+1) = xray(1) - xray(nn+1)
xray(1) = z

!       If nn is even then terms nn/2 + 1 and 3*nn/2 + 1 must be reordered.

nnn = nn / 2
IF (nn /= 2 * nnn) GO TO 4
m = nnn + 1
xray(m) = two * xray(m)
mm = m + ll
m = m + nn
xray(mm) = -two * xray(m)
GO TO 5
4 nnn = nnn + 1

!       Set up trig functions for manipulation of remaining terms.

5 z = four * ATAN(one) / nn
bcos = -two * (SIN(z/two) ** 2)
bsin = SIN(z)
un = one
vn = zero

!       Perform manipulation and reordering of remaining non-unique terms.

DO i = 2, nnn
  z = un * bcos + un + vn * bsin
  vn = vn * bcos + vn - un * bsin
  save1 = one5 - half * (z * z + vn * vn)
  un = z * save1
  vn = vn * save1
  ii = nn + 2 - i
  j = nn + i
  jj = nn + ii
  an = xray(i) + xray(ii)
  bn = xray(j) - xray(jj)
  pn = xray(i) - xray(ii)
  qn = xray(j) + xray(jj)
  cn = un * pn + vn * qn
  dn = vn * pn - un * qn
  xray(i) = an + dn
  xray(ii) = an - dn
  m = ll + i
  mm = ll + ii
  xray(m) = cn + bn
  xray(mm) = cn - bn
END DO

!       Do inverse Chirp DFT to give even and odd sequences.

CALL chrft(xray, xray(ll+1:), wr, wi, nn, ll, -1, ifault)

!       Interlace the results to produce the required output sequence.

nnn = nn + 1
ii = jsize + 2
DO i = 1, nn
  j = nnn - i
  jj = ll + j
  m = ii - 2 * i
  mm = m - 1
  xray(m) = xray(jj)
  xray(mm) = xray(j)
END DO

RETURN
END SUBROUTINE chrev

SUBROUTINE setwt(wr, wi, ksize, kwork, ifault)

!       Algorithm AS 117.4 Appl. Statist. (1977) vol.26, no.3

!       Subroutine to set up Fourier transformed Chirp function for
!       use by subroutine CHRFT.

REAL, INTENT(OUT)    :: wr(:), wi(:)
INTEGER, INTENT(IN)  :: ksize, kwork
INTEGER, INTENT(OUT) :: ifault

INTEGER         :: ii, k, nn, ll
REAL, PARAMETER :: zero = 0.0, one = 1.0, four = 4.0
REAL            :: tc, z

!       Check that KSIZE & KWORK are valid

ifault = 0
IF (ksize < 3) ifault = 1
ii = 4
DO k = 3, 20
  ii = ii * 2
  IF (ii == kwork) GO TO 3
  IF (ii > kwork) GO TO 2
END DO
2 ifault = 2
3 IF (kwork < 2 * ksize) ifault = ifault + 4
IF (ifault /= 0) RETURN
tc = four * ATAN(one) / ksize

!       Set up bottom segment of Chirp function

DO nn = 1, ksize
  z = nn - 1
  z = z * z * tc
  wr(nn) = COS(z)
  wi(nn) = SIN(z)
END DO

!       Clear the rest

DO nn = ksize+1, kwork
  wr(nn) = zero
  wi(nn) = zero
END DO

!       Copy to the top segment

DO nn = kwork-ksize+2, kwork
  ll = kwork - nn + 2
  wr(nn) = wr(ll)
  wi(nn) = wi(ll)
END DO

!       Fourier transform the Chirp function

CALL fastf(wr, wi, kwork, 1)

RETURN
END SUBROUTINE setwt

SUBROUTINE chrp(x, y, gc, isize, itype)

!       Algorithm AS 117.5 Appl. Statist. (1977) vol.26, no.3

!       Subroutine to multiply time series by Chirp function

REAL, INTENT(IN OUT) :: x(:), y(:)
REAL, INTENT(IN)     :: gc
INTEGER, INTENT(IN)  :: isize, itype

INTEGER         :: nn
REAL, PARAMETER :: one = 1.0, four = 4.0
REAL            :: tc, z, xwr, xwi

tc = four * ATAN(one) / isize
DO nn = 1, isize
  z = nn - 1
  z = z * z * tc
  xwr = COS(z)
  xwi = -SIN(z)
  IF (itype < 0) xwi = -xwi
  z = x(nn) * xwr - y(nn) * xwi
  y(nn) = (x(nn) * xwi + y(nn) * xwr) * gc
  x(nn) = z * gc
END DO

RETURN
END SUBROUTINE chrp

SUBROUTINE fastf(xreal, ximag, isize, itype)

!       Algorithm AS 83.1 Appl. Statist. (1975) vol.24, no.1

!       Radix 4 complex discrete fast Fourier transform with
!       unscrambling of the transformed arrays.

REAL, INTENT(IN OUT)  :: xreal(:), ximag(:)
INTEGER, INTENT(IN)   :: isize, itype

INTEGER :: ii, k

!       Check for valid transform size.

ii = 4
DO k = 2, 20
  IF (ii == isize) GO TO 4
  IF (ii > isize) EXIT
  ii = ii * 2
END DO

!       If this point is reached a size error has occurred.

RETURN

!       Call FASTG to perform the transform.

4 CALL fastg(xreal, ximag, isize, itype)

!       Call SCRAM to unscramble the results.

CALL scram(xreal, ximag, k)

RETURN
END SUBROUTINE fastf

SUBROUTINE fastg(xreal, ximag, n, itype)

!       Algorithm AS 83.2 Appl. Statist. (1975) vol.24, no.1

!       Radix 4 complex discrete fast Fourier transform without unscrambling,
!       suitable for convolutions or other applications which do not require
!       unscrambling.   Called by subroutine FASTF which also does the
!       unscrambling.

REAL, INTENT(IN OUT) :: xreal(:), ximag(:)
INTEGER, INTENT(IN)  :: n, itype

INTEGER         :: ifaca, k, ifcab, litla, i0, i1, i2, i3
REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0, one5 = 1.5, two = 2.0, &
                   four = 4.0
REAL            :: pi, z, bcos, bsin, cw1, sw1, xs0, xs1, ys0, ys1, xs2, xs3, &
                   ys2, ys3, x1, y1, x2, y2, x3, y3, tempr, cw2, sw2, cw3, sw3

pi = four * ATAN(one)
ifaca = n / 4
IF (itype == 0) RETURN
IF (itype > 0) GO TO 5

!       ITYPE < 0 indicates inverse transform required.
!       Calculate conjugate.

ximag(1:n) = -ximag(1:n)

!       Following code is executed for IFACA = N/4, N/16, N/64, ...
!       until IFACA <= 1.

5 ifcab = ifaca * 4
z = pi / ifcab
bcos = -two * SIN(z)**2
bsin = SIN(two * z)
cw1 = one
sw1 = zero
DO litla = 1, ifaca
  DO i0 = litla, n, ifcab
    i1 = i0 + ifaca
    i2 = i1 + ifaca
    i3 = i2 + ifaca
    xs0 = xreal(i0) + xreal(i2)
    xs1 = xreal(i0) - xreal(i2)
    ys0 = ximag(i0) + ximag(i2)
    ys1 = ximag(i0) - ximag(i2)
    xs2 = xreal(i1) + xreal(i3)
    xs3 = xreal(i1) - xreal(i3)
    ys2 = ximag(i1) + ximag(i3)
    ys3 = ximag(i1) - ximag(i3)
    xreal(i0) = xs0 + xs2
    ximag(i0) = ys0 + ys2
    x1 = xs1 + ys3
    y1 = ys1 - xs3
    x2 = xs0 - xs2
    y2 = ys0 - ys2
    x3 = xs1 - ys3
    y3 = ys1 + xs3
    IF (litla == 1) THEN
      xreal(i2) = x1
      ximag(i2) = y1
      xreal(i1) = x2
      ximag(i1) = y2
      xreal(i3) = x3
      ximag(i3) = y3
    ELSE
      xreal(i2) = x1 * cw1 + y1 * sw1
      ximag(i2) = y1 * cw1 - x1 * sw1
      xreal(i1) = x2 * cw2 + y2 * sw2
      ximag(i1) = y2 * cw2 - x2 * sw2
      xreal(i3) = x3 * cw3 + y3 * sw3
      ximag(i3) = y3 * cw3 - x3 * sw3
    END IF
  END DO

!       Calculate a new set of twiddle factors.

  IF (litla < ifaca) THEN
    z = cw1 * bcos - sw1 * bsin + cw1
    sw1 = bcos * sw1 + bsin * cw1 + sw1
    tempr = one5 - half * (z * z + sw1 * sw1)
    cw1 = z * tempr
    sw1 = sw1 * tempr
    cw2 = cw1 * cw1 - sw1 * sw1
    sw2 = two * cw1 * sw1
    cw3 = cw1 * cw2 - sw1 * sw2
    sw3 = cw1 * sw2 + cw2 * sw1
  END IF
END DO
IF (ifaca <= 1) GO TO 14

!       Set up the transform split for the next stage.

ifaca = ifaca / 4
IF (ifaca > 0) GO TO 5

!       Radix 2 calculation, if needed.

IF (ifaca < 0) RETURN
DO k = 1, n, 2
  tempr = xreal(k) + xreal(k+1)
  xreal(k+1) = xreal(k) - xreal(k+1)
  xreal(k) = tempr
  tempr = ximag(k) + ximag(k+1)
  ximag(k+1) = ximag(k) - ximag(k+1)
  ximag(k) = tempr
END DO
14 IF (itype < 0) THEN

!       Inverse transform; conjugate the result.

  ximag(1:n) = -ximag(1:n)
  RETURN
END IF

!       Forward transform

z = one / n
DO k = 1, n
  xreal(k) = xreal(k) * z
  ximag(k) = ximag(k) * z
END DO

RETURN
END SUBROUTINE fastg

SUBROUTINE scram(xreal, ximag, ipow)

!       Algorithm AS 83.3 Appl. Statist. (1975) vol.24, no.1

!       Subroutine for unscrambling FFT data.

REAL, INTENT(IN OUT) :: xreal(:), ximag(:)
INTEGER, INTENT(IN)  :: ipow

INTEGER :: ii, itop, i, k, l0, j1, j2, j3, j4, j5, j6, j7, j8, j9,  &
           j10, j11, j12, j13, j14, j15, j16, j17, j18, j19, j20, l(19)
REAL    :: tempr

ii = 1
itop = 2 ** (ipow - 1)
i = 20 - ipow
l(1:i) = ii
l0 = ii
i = i + 1
DO k = i, 19
  ii = ii * 2
  l(k) = ii
END DO

ii = 0
DO j1 = 1, l(1), l0
  DO j2 = j1, l(2), l(3)
    DO j3 = j2, l(3), l(2)
      DO j4 = j3, l(4), l(3)
        DO j5 = j4, l(5), l(4)
          DO j6 = j5, l(6), l(5)
            DO j7 = j6, l(7), l(6)
              DO j8 = j7, l(8), l(7)
                DO j9 = j8, l(9), l(8)
                  DO j10 = j9, l(10), l(9)
                    DO j11 = j10, l(11), l(10)
                      DO j12 = j11, l(12), l(11)
                        DO j13 = j12, l(13), l(12)
                          DO j14 = j13, l(14), l(13)
                            DO j15 = j14, l(15), l(14)
                              DO j16 = j15, l(16), l(15)
                                DO j17 = j16, l(17), l(16)
                                  DO j18 = j17, l(18), l(17)
                                    DO j19 = j18, l(19), l(18)
                                      j20 = j19
                                      DO i = 1, 2
                                        ii = ii + 1
                                        IF (ii < j20) THEN

!       J20 is the bit-reverse of II pairwise interchange.

                                          tempr = xreal(ii)
                                          xreal(ii) = xreal(j20)
                                          xreal(j20) = tempr
                                          tempr = ximag(ii)
                                          ximag(ii) = ximag(j20)
                                          ximag(j20) = tempr
                                        END IF
                                        j20 = j20 + itop
                                      END DO
                                    END DO
                                  END DO
                                END DO
                              END DO
                            END DO
                          END DO
                        END DO
                      END DO
                    END DO
                  END DO
                END DO
              END DO
            END DO
          END DO
        END DO
      END DO
    END DO
  END DO
END DO

RETURN
END SUBROUTINE scram

END MODULE chirp_transform


      SUBROUTINE RAND3 (F,S,Q,N)
C
C     COMPUTES  MEAN RESPONSE  Q
C
      INTEGER         CHECK   ,NAME(2)
      REAL            Q(2)    ,F(1)     ,S(1)
      COMMON /CONDAS/ PHI     ,TWOPI    ,RADEG    ,DEGRA    ,
     1                S4PISQ
      DATA    NAME  / 4HRAND  ,4H3      /
C
C     F IS ARRAY OF FREQUENCIES
C     S IS ARRAY OF POWER SPECTRAL DENSITY FUNCTIONS
C     Q IS MEAN RESPONSE
C     N IS NUMBER OF FREQUENCIES
C
      SUM1 = 0.0
      NN   = N - 1
      SUM  = 0.0
      DO 10 I = 1,NN
      DF   = F(I+1) - F(I)
      SUM  = SUM + (S(I)+S(I+1))*DF
      FI   = F(I   )*F(I  )
      FI1  = F(I+1 )*F(I+1)
      FII1 = 2.*F(I)*F(I+1)
      ALP  = (3.*FI+FII1+FI1)/6.
      BTA  = (FI+FII1+3.*FI1)/6.
      SUM1 = SUM1 + (ALP*S(I)+BTA*S(I+1))*DF
   10 CONTINUE
      SUM  = SQRT(SUM*0.5)
      SUM1 = SQRT(SUM1*.5)
      Q(1) = SUM
      Q(2) = 0.0
      Q1   = Q(1)
      IF (Q1 .NE. 0.0) Q(2) = SUM1/Q1
      CHECK= 123456789
      RETURN
C
C     AUTOCORRALATION FUNCTION
C
      ENTRY RAND4 (F,S,TAU,R,N)
C     =========================
C
C     COMPUTES  AUTOCORRALATION FUNCTION R  AT TIME TAU
C     WHERE F,S AS ABOVE. IF TAU = 0.0  R = Q*Q
C
      IF (CHECK .NE. 123456789) CALL MESAGE (-37,0,NAME)
      IF (TAU .EQ. 0.0) GO TO 30
      NN  = N - 1
      A   = 2.0*PHI*TAU
      B   = 1.0/A
      SUM = 0.0
      DO 20 I = 1,NN
      SUM = SUM + B*(S(I+1)-S(I))/(F(I+1)-F(I))*(COS(A*F(I+1))
     1          - COS(A*F(I))) + S(I+1)*SIN(A*F(I+1))-S(I)*SIN(A*F(I))
   20 CONTINUE
      SUM = SUM*B
      R   = SUM
      GO TO 40
   30 R   = Q1*Q1
   40 RETURN
      END


C
C**************************  MC ****************************************
C  MUSKINGUM CUNGE METHOD: FROM THE INFLOW HYDROGRAPHS AT T+1 AND T,
C  Q_IN_KKP1 AND Q_IN_KK RESPECTIVELY, FROM THE OUTFLOW HYDROGRAPH AT T,
C  Q_OUT_KK, AND FROM THE LATERAL CONTRIBUTION, Q_OVERLAND, IT DETERMINES
C  THE OUTFLOW HYDROGRAPH FOR THE DOWNSTREAM CELL AT T+1, Q_OUT_KKP1.
C***********************************************************************
C

      SUBROUTINE MC(LOCAL_SLOPE,EPL,KS,W,B1,Y1,DELTAT,CU,PE,X,C1,
     1     AK,Q_IN_KK,Q_IN_KKP1,Q_OUT_KK,Q_OVERLAND,Q_OUT_KKP1)

      IMPLICIT NONE

      REAL*8 LOCAL_SLOPE,EPL,KS,W
      REAL*8 B1,Y1,DELTAT
      REAL*8 CU
      REAL*8 Q_IN_KK,Q_IN_KKP1,Q_OUT_KK,Q_OUT_KKP1,Q_OVERLAND
      REAL*8 QC,QCMIN,BETA,G
      REAL*8 CK,DH,PE,X,AK
      REAL*8 C1,C2,C3,C4

C     THREE-POINT AVERAGE DISCHARGE
      QC=1.0D0/3.0D0*(Q_IN_KK+Q_IN_KKP1+Q_OUT_KK)
      QCMIN=1.0D-05
      IF(QC.LE.QCMIN)  QC=QCMIN

C     SLOPE
      BETA=ATAN(LOCAL_SLOPE)

C     HYDRAULIC GEOMETRY TERM
      G=(1.0D0-Y1+2.0D0/3.0D0*B1)

C     KINEMATIC WAVE CELERITY
      CK=5.0D0/(3.0D0*G)*KS**(3.0D0/5.0D0)*W**(-2.0D0/5.0D0)*
     1     SIN(BETA)**(3.0D0/1.0D1)*QC**(1.0D0-3.0D0*G/5.0D0)

      AK=CK/EPL

C     COURANT NUMBER
      CU=CK*DELTAT/EPL

C     HYDRAULIC DIFFUSIVITY
      DH=(QC**(1.0D0-B1))/(2*G*W*TAN(BETA))

      IF (DH.LT.(1.0D0-CU)) DH=1.0D0-CU

C     PECLET NUMBER
      PE=CK*EPL/DH

      X=0.50D0-DH/(CK*EPL)

      C1=(CU-2.0D0*X)/(2.0D0*(1.0D0-X)+CU)

      C2=(CU+2.0D0*X)/(2.0D0*(1.0D0-X)+CU)

      C3=(2.0D0*(1.0D0-X)-CU)/(2.0D0*(1.0D0-X)+CU)

      C4=(2.0D0*CK*DELTAT)/(2.0D0*(1.0D0-X)+CU)

      Q_OUT_KKP1=C1*Q_IN_KKP1+C2*Q_IN_KK+C3*Q_OUT_KK+C4*Q_OVERLAND

      RETURN
      END


      SUBROUTINE kermom(w,y,m)
      INTEGER m
      DOUBLE PRECISION w(m),y,x,d,df,clog,x2,x3,x4
      COMMON /momcom/ x
      if (y.ge.x) then
        d=y-x
        df=2.d0*sqrt(d)*d
        w(1)=df/3.d0
        w(2)=df*(x/3.d0+d/5.d0)
        w(3)=df*((x/3.d0 + 0.4d0*d)*x + d**2/7.d0)
        w(4)=df*(((x/3.d0 + 0.6d0*d)*x + 3.d0*d**2/7.d0)*x+ d**3/9.d0)
      else
        x2=x**2
        x3=x2*x
        x4=x2*x2
        d=x-y
        clog=log(d)
        w(1)=d*(clog-1.d0)
        w(2)=-0.25d0*(3.d0*x+y-2.d0*clog*(x+y))*d
        w(3)=(-11.d0*x3+y*(6.d0*x2+y*(3.d0*x+2.d0*y))+6.d0*clog*(x3-y**
     *3))/18.d0
        w(4)=(-25.d0*x4+y*(12.d0*x3+y*(6.d0*x2+y*(4.d0*x+3.d0*y)))+
     *12.d0*clog*(x4-y**4))/48.d0
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/kermom.for


! The pbl-compare library, and Fortran module.
!
! This is open source software, covered by the MIT license.
!
! Author: Patrizia Favaron

module pbl_compare

    implicit none

    private

    ! Public interface
    public  :: CompareType

    ! Main data type
    type CompareType
        logical                             :: lGo = .false.
        integer                             :: iNumData
        real, dimension(:), allocatable     :: rvPrimary
        real, dimension(:), allocatable     :: rvSecondary
    contains
        procedure   :: Set
        procedure   :: FB       ! Fractional bias
        procedure   :: NMSE     ! Normalized Mean Squared Error
        procedure   :: MG       ! Geometric mean
        procedure   :: VG       ! Geometric variance
        procedure   :: FAC2     ! Fracion within a factor of 2
        procedure   :: NAD      ! Normalizes absolute difference
    end type CompareType

contains

    function Set(this, rvP, rvS) result(iRetCode)

        ! Routine arguments
        class(CompareType), intent(inout)   :: this
        real, dimension(:), intent(in)      :: rvP
        real, dimension(:), intent(in)      :: rvS
        integer                             :: iRetCode

        ! Locals
        integer     :: iErrCode
        integer     :: iSize

        ! Assume success (will falsify on failure)
        iRetCode = 0

        ! Check the input data is "correct", that is,
        ! the two sets are non-empty and of same size
        iSize = size(rvP)
        if(iSize <= 0) then
            iRetCode = 1
            return
        end if
        if(iSize /= size(rvS)) then
            iRetCode = 2
            return
        end if
        ! Note the two tests, apparently not covering the whole intention,
        ! in reality test it exhaistively.

        ! Clean-out and fill internal space
        if(allocated(this % rvPrimary))   deallocate(this % rvPrimary)
        if(allocated(this % rvSecondary)) deallocate(this % rvSecondary)
        allocate(this % rvPrimary(iSize))
        allocate(this % rvSecondary(iSize))
        this % rvPrimary   = rvP
        this % rvSecondary = rvS

        ! Check data is not identically zero
        if(sum(rvP) > epsilon(rvP(1))*iSize .and. sum(rvS) > epsilon(rvS(1))*iSize) then

            ! Set data set size
            this % iNumData = iSize

            ! Indicate function computing may really start
            this % lGo = .true.

        end if

    end function Set

    ! Fractional Bias (FB)
    function FB(this) result(rFB)

        ! Routine arguments
        class(CompareType), intent(inout)   :: this
        real                                :: rFB

        ! Locals
        real    :: rNumerator
        real    :: rDenominator

        ! Check execution may start
        if(.not.this % lGo) then
            rFB = -9999.9
            return
        end if

        ! Compute the information desired
        rNumerator   = 2. * sum(this % rvPrimary - this % rvSecondary)
        rDenominator = sum(this % rvPrimary) + sum(this % rvSecondary)
        rFB          = rNumerator / rDenominator

    end function FB

    ! Normalized Mean Squared Error (NMSE)
    function NMSE(this) result(rNMSE)

        ! Routine arguments
        class(CompareType), intent(inout)   :: this
        real                                :: rNMSE

        ! Locals
        real    :: rNumerator
        real    :: rDenominator

        ! Check execution may start
        if(.not.this % lGo) then
            rNMSE = -9999.9
            return
        end if

        ! Compute the information desired
        rNumerator   = sum((this % rvPrimary - this % rvSecondary)**2)
        rDenominator = sum(this % rvPrimary) * sum(this % rvSecondary)
        rNMSE        = this % iNumData * rNumerator / rDenominator

    end function NMSE

    ! Geometric Mean (GM)
    function MG(this) result(rMG)

        ! Routine arguments
        class(CompareType), intent(inout)   :: this
        real                                :: rMG

        ! Locals
        real    :: rPos
        real    :: rNeg
        integer :: i

        ! Check execution may start
        if(.not.this % lGo) then
            rMG = -9999.9
            return
        end if

        ! Compute the information desired
        rPos = 0.
        rNeg = 0.
        do i = 1, this % iNumData
            if(this % rvPrimary(i) > 0. .and. this % rvSecondary(i) > 0.) then
                rPos = rPos + log(this % rvPrimary(i))
                rNeg = rNeg + log(this % rvSecondary(i))
            end if
        end do
        if(abs(rPos) < epsilon(rPos) .and. abs(rNeg) < epsilon(rNeg)) then
            rMG = -9999.9
        else
            rMG = exp(rPos - rNeg)
        end if

    end function MG

    ! Geometric Variance (VG)
    function VG(this) result(rVG)

        ! Routine arguments
        class(CompareType), intent(inout)   :: this
        real                                :: rVG

        ! Locals
        real    :: rPos
        integer :: i
        integer :: iPositive

        ! Check execution may start
        if(.not.this % lGo) then
            rVG = -9999.9
            return
        end if

        ! Compute the information desired
        rPos = 0.
        iPositive = 0
        do i = 1, this % iNumData
            if(this % rvPrimary(i) > 0. .and. this % rvSecondary(i) > 0.) then
                rPos = rPos + (log(this % rvPrimary(i)) - log(this % rvSecondary(i)))**2
                iPositive = iPositive + 1
            end if
        end do
        rVG = exp(rPos / iPositive)

    end function VG

    ! Fraction within a factor of 2 (FAC2)
    function FAC2(this) result(rFAC2)

        ! Routine arguments
        class(CompareType), intent(inout)   :: this
        real                                :: rFAC2

        ! Locals
        integer :: i
        integer :: iWithin
        real    :: rLower
        real    :: rUpper

        ! Check execution may start
        if(.not.this % lGo) then
            rFAC2 = -9999.9
            return
        end if

        ! Compute the information desired
        iWithin = 0
        do i = 1, this % iNumData
            if(0.5 * this % rvSecondary(i) <= this % rvPrimary(i) .and. this % rvPrimary(i) <= 2. * this % rvSecondary(i)) then
                iWithin = iWithin + 1
            end if
        end do
        rFAC2 = float(iWithin) / this % iNumData

    end function FAC2

    ! Normalized Absolute Difference (NAD)
    function NAD(this) result(rNAD)

        ! Routine arguments
        class(CompareType), intent(inout)   :: this
        real                                :: rNAD

        ! Locals
        real    :: rNumerator
        real    :: rDenominator

        ! Check execution may start
        if(.not.this % lGo) then
            rNAD = -9999.9
            return
        end if

        ! Compute the information desired
        rNumerator   = sum(abs(this % rvPrimary - this % rvSecondary))
        rDenominator = sum(this % rvPrimary) + sum(this % rvSecondary)
        rNAD          = rNumerator / rDenominator

    end function NAD

end module pbl_compare


C***********************************************************************
      REAL*8 FUNCTION SDOT(L,X,INCX,Y,INCY)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION X(*),Y(*)
      IX0=1-INCX
      IY0=1-INCY
      SDOT=0.
      DO 1 I=1,L
1     SDOT=SDOT+X(IX0+I*INCY)*Y(IY0+I*INCY)
      RETURN
	end


! { dg-do compile }
! { dg-require-effective-target vect_double }

      function trs2a2 (j, k, u, d, m)
!      matrice de transition intermediaire, partant de k sans descendre
!      sous j. R = IjU(I-Ik)DIj, avec Ii = deltajj, j >= i.
!      alternative: trs2a2 = 0
!                   trs2a2 (j:k-1, j:k-1) = matmul (utrsft (j:k-1,j:k-1),
!                                                   dtrsft (j:k-1,j:k-1))
!
      real, dimension (1:m,1:m) :: trs2a2  ! resultat
      real, dimension (1:m,1:m) :: u, d    ! matrices utrsft, dtrsft
      integer, intent (in)      :: j, k, m ! niveaux vallee pic
!
!##### following line replaced by Prentice to make less system dependent
!      real (kind = kind (1.0d0)) :: dtmp
      real (kind = selected_real_kind (10,50)) :: dtmp
!
      trs2a2 = 0.0
      do iclw1 = j, k - 1
         do iclw2 = j, k - 1
            dtmp = 0.0d0
            do iclww = j, k - 1
               dtmp = dtmp + u (iclw1, iclww) * d (iclww, iclw2)
            enddo
            trs2a2 (iclw1, iclw2) = dtmp
         enddo
      enddo
      return
      end function trs2a2

! { dg-final { scan-tree-dump-times "vectorized 2 loops" 1 "vect"  } }


C COMPLEX FUNCTION CSZ1       (NEXT)
      COMPLEX FUNCTION CSZ1 (X)
C
C     CSZ1 - EVALUATES THE COSINE-INTEGRAL AND SINE-INTEGRAL FUNCTIONS.
C     SEE THE REFERENCES IN SUBROUTINE GAIN AND THOSE GIVEN BELOW.
C
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RO, VOFL
C
      COMPLEX A,AM1, AM2, B,BM1, BM2, SA
      real*8 testq,t,tm1
C
C
C.....TEST ARGUMENT RANGE...............................................
ccc      DATA TESTQ / 4.0E-10/
      DATA TESTQ / 4.0E-9/     !  the above values cause floating point errors
      IF (X .GT. 6.0) GO TO 120
C.....FOR X .LE. 6 USE THE SERIES EXPANSION.............................
C. . .SEE THE HANDBOOK OF MATHEMATICAL FUNCTIONS, ABRAMOWITZ AND STEGUN,
C. . .P 232, EQU 5.2.14 AND 5.2.16 . . . . . . . . . . . . . . . . . . .
      EN = 0.0
      X2 = X * * 2
      TN = X
      SI = X
 100  EN = EN + 1.0
      TN = - TN * X2 * (2.0 * EN - 1.0) / ((2.0 * EN) * (2.0 * EN + 1.0)
     1 * * 2)
      IF (ABS (TN / SI) .LE. TESTQ) GO TO 105
      SI = SI + TN
      GO TO 100
 105  EN = 1.0
      TN = - X2 / 4.0
      CI = TN + GAMA + ALOG (X)
 110  EN = EN + 1.0
      TN = - TN * X2 * (2.0 * EN - 2.0) / ((2.0 * EN - 1.0) * (2.0 * EN)
     1 * * 2)
      IF (ABS (TN / CI) .LE. TESTQ) GO TO 115
      CI = CI + TN
      GO TO 110
 115  CSZ1 = CMPLX (CI, - SI)
      GO TO 145
C.....FOR X .GT. 6 USE THE CONTINUED FRACTION EXPANSION.................
C. . .SEE  ANALYSIS AND DESIGN OF THE LOG PERIODIC DIPOLE ANTENNA. . . .
C. . .BY ROBERT L. CARREL, UNIV. OF ILL. ANTENNA LAB. TECH. REPORT . . .
C. . .NUMBER 52 (NTIS NO. AD264558), PAGE 177 (APPENDIX A) . . . . . . .
 120  AM1 = (1.0, 0.0)
      AM2 = (1.0, 0.0)
      BM1 = (1.0, 0.0)
      BM2 = (0.0, 0.0)
      P = 0.0
      K = 0
      TM1 = 0.0
 125  P = P + 1.0
      K = K + 1
      IF (MOD (K, 2) .EQ. 0) GO TO 130
      SA = CMPLX (0.0, (P + 1.0) / (2.0 * X))
      GO TO 135
 130  SA = CMPLX (0.0, P / (2.0 * X))
 135  A = AM1 + SA * AM2
      B = BM1 + SA * BM2
      CSZ1 = A / B
      T = CABS (CSZ1)
      IF (DABS ((T - TM1) / T) .LE. TESTQ) GO TO 140
      AM2 = AM1
      AM1 = A
      BM2 = BM1
      BM1 = B
      TM1 = T
      GO TO 125
140   CSZ1=CMPLX(0.0,PIO2)+CMPLX(COS(X),SIN(X))/(CMPLX(0.0,X)*CSZ1)
      CSZ1 = CONJG (CSZ1)
 145  RETURN
      END


! The Computer Language Benchmarks Game
! https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
!
! contributed by Steve Decker based on the version by Simon Geard
! compilation:
!   g95 -O1 -fomit-frame-pointer -funroll-loops spectral_norm.f90
!   ifort -ipo -O3 -static spectral_norm.f90
module norm_subs
  implicit none

  integer, parameter :: dp = selected_real_kind(12)

contains

  ! Return element i,j of infinite matrix A
  pure real(dp) function A(i, j)
    integer, intent(in) :: i, j

    a = 1.d0 / ((i+j-2) * (i+j-1)/2 + i)
  end function A

  ! Multiply v by A
  pure function MultiplyAv(v) result (Av)
    real(dp), dimension(:), intent(in) :: v
    real(dp), dimension(size(v))       :: Av

    integer :: n, i, j

    n = size(v)
    Av = 0.d0
    do i = 1, n
       do j = 1, n
          Av(i) = Av(i) + A(i,j) * v(j)
       end do
    end do
  end function MultiplyAv

  ! Multiply v by A transpose
  pure function MultiplyAtv(v) result (Atv)
    real(dp), dimension(:), intent(in) :: v
    real(dp), dimension(size(v))       :: Atv

    integer :: n, i, j

    n = size(v)
    Atv = 0.d0
    do i = 1, n
       do j = 1, n
          Atv(i) = Atv(i) + A(j,i) * v(j)
       end do
    end do
  end function MultiplyAtv

  ! Multiply v by A and then by A transpose
  pure function MultiplyAtAv(v) result (AtAv)
    real(dp), dimension(:), intent(in) :: v
    real(dp), dimension(size(v))       :: AtAv

    AtAv = MultiplyAtv(MultiplyAv(v))
  end function MultiplyAtAv
end module norm_subs

program spectral_norm
  use norm_subs
  implicit none

  real(dp), dimension(:), allocatable :: u, v
  integer          :: i, n
  character(len=6) :: argv

  call get_command_argument(1, argv)
  read(argv, *) n

  allocate(u(n), v(n))
  u = 1.d0
  do i = 1, 10
     v = MultiplyAtAv(u)
     u = MultiplyAtAv(v)
  end do

  write(*, "(f0.9)") sqrt(dot_product(u,v) / dot_product(v,v))
  deallocate(u, v)
end program spectral_norm


! ------------------------------------------------------------------------------
! Subroutine for the derivative of Fun with respect to rate coefficients
! -----------------------------------------------------------------------------

      SUBROUTINE  dFun_dRcoeff( V, F, NCOEFF, JCOEFF, DFDR )

      USE KPP_ROOT_Parameters
      USE KPP_ROOT_StoichiomSP
      IMPLICIT NONE

! V - Concentrations of variable/radical/fixed species
      KPP_REAL V(NVAR), F(NFIX)
! NCOEFF - the number of rate coefficients with respect to which we differentiate
      INTEGER NCOEFF
! JCOEFF - a vector of integers containing the indices of reactions (rate
!          coefficients) with respect to which we differentiate
      INTEGER JCOEFF(NCOEFF)
! DFDR  - a matrix containg derivative values; specifically,
!         column j contains d Fun(1:NVAR) / d RCT( JCOEFF(j) )
!         for each 1 <= j <= NCOEFF
!         This matrix is stored in a column-wise linearized format
      KPP_REAL DFDR(NVAR*NCOEFF)

! Local vector with reactant products
      KPP_REAL A_RPROD(NREACT)
      KPP_REAL aj
      INTEGER i,j,k

! Compute the reactant products of all reactions
      CALL ReactantProd ( V, F, A_RPROD )

! Compute the derivatives by multiplying column JCOEFF(j) of the stoichiometric matrix with A_RPROD
      DO j=1,NCOEFF
!                  Initialize the j-th column of derivative matrix to zero
         DO i=1,NVAR
           DFDR(i+NVAR*(j-1)) = 0.0_dp
         END DO
!                  Column JCOEFF(j) in the stoichiometric matrix times the
!                  reactant product  of the JCOEFF(j)-th reaction
!                  give the j-th column of the derivative matrix
         aj = A_RPROD(JCOEFF(j))
         DO k=CCOL_STOICM(JCOEFF(j)),CCOL_STOICM(JCOEFF(j)+1)-1
           DFDR(IROW_STOICM(k)+NVAR*(j-1)) = STOICM(k)*aj
         END DO
      END DO

      END SUBROUTINE  dFun_dRcoeff


c---------------------------------------------------------------------

      pure extrinsic (hpf_local) subroutine
     >              Swarztrauber(is,m,len,n,x,xd1,exponent)
      implicit none
      include 'global.h'

c---------------------------------------------------------------------
c   Computes NY N-point complex-to-complex FFTs of X using an algorithm due
c   to Swarztrauber.  X is both the input and the output array, while Y is a
c   scratch array.  It is assumed that N = 2^M.  Before calling
c   Swarztrauber to
c   perform FFTs
c---------------------------------------------------------------------

      integer, intent(in) :: is,m,len,n,xd1
      double complex, dimension(:,:), intent(inout) ::  x
      double complex, dimension(:), intent(in) :: exponent
      integer i,j,l,mx
      double complex u1,x11,x21
      integer k, n1,li,lj,lk,ku,i11,i12,i21,i22
      integer BlockStart,BlockEnd

      call timer_start(4)
c---------------------------------------------------------------------
c   Perform one variant of the Stockham FFT.
c---------------------------------------------------------------------

cc     This is an extra loop for fitting a slab into cash
cc     Origin 2000 cash size 32K = 4096 of 8 byte words
      fftblock = 4*4096/n

      do BlockStart = 1, len, fftblock
        BlockEnd = BlockStart + fftblock - 1
        if ( BlockEnd .gt. len) then
	  BlockEnd = len
	endif
      do l = 1, m, 2
        n1 = n / 2
        lk = 2 ** (l - 1)
        li = 2 ** (m - l)
        lj = 2 * lk
        ku = li + 1

        do i = 0, li - 1
          i11 = i * lk + 1
          i12 = i11 + n1
          i21 = i * lj + 1
          i22 = i21 + lk

          if (is .ge. 1) then
            u1 = exponent(ku+i)
          else
            u1 = dconjg (exponent(ku+i))
          endif
          do k = 0, lk - 1
            do j = BlockStart, BlockEnd
              x11 = x(j,i11+k)
              x21 = x(j,i12+k)
              scr(j,i21+k) = x11 + x21
              scr(j,i22+k) = u1 * (x11 - x21)
            end do
          end do
        end do

        if (l .eq. m) then
          x(BlockStart:BlockEnd,1:n) = scr(BlockStart:BlockEnd,1:n)
        else
          n1 = n / 2
          lk = 2 ** l
          li = 2 ** (m - l - 1)
          lj = 2 * lk
          ku = li + 1

          do i = 0, li - 1
            i11 = i * lk + 1
            i12 = i11 + n1
            i21 = i * lj + 1
            i22 = i21 + lk

            if (is .ge. 1) then
              u1 = exponent(ku+i)
            else
              u1 = dconjg (exponent(ku+i))
            endif
            do k = 0, lk - 1
              do j = BlockStart, BlockEnd
                x11 = scr(j,i11+k)
                x21 = scr(j,i12+k)
                x(j,i21+k) = x11 + x21
                x(j,i22+k) = u1 * (x11 - x21)
              end do
            end do
          end do
        endif
      end do
      end do

      call timer_stop(4)

      return
      end

c---------------------------------------------------------------------

      extrinsic(HPF)
     > subroutine fftXYZ(sign,x,x3,exp1,exp2,exp3,n1,n2,n3)
       include 'fftXYZ.h'
       include 'global.h'

         interface
           pure extrinsic (hpf_local) subroutine
     >            Swarztrauber(is, m,len,n, x,xd1,exponent)
               integer, intent(in) :: is,m,len,n,xd1
               double complex, dimension(:,:), intent(inout) ::  x
               double complex, dimension(:), intent(in) :: exponent
           end subroutine Swarztrauber

         end interface
       double complex x2(n2+1,n1,n3)
!hpf$    template grid2(n3)
!hpf$    distribute(block) :: grid2
!hpf$    align(*,*,:) with grid2 :: x2
       integer i, j, k, log
         call timer_start(3)
	 log = ilog2( n2 )
         call timer_start(7)
!HPF$ INDEPENDENT
         do k = 1, n3
            call Swarztrauber(sign,log,n1,n2,x(:,:,k),n1,exp2)
         end do
         call timer_stop(7)
	 log = ilog2( n1)
         call timer_start(8)
!HPF$ INDEPENDENT
         do k = 1, n3
         call timer_start(6)
           do j = 1, n2
           do i = 1, n1
             plane(j,i) = x(i,j,k)
           end do
           end do
         call timer_stop(6)
           call Swarztrauber(sign,log,n2,n1,plane,maxdim,exp1)
         call timer_start(6)
           do j = 1, n2
           do i = 1, n1
             x(i,j,k)=plane(j,i)
           end do
           end do
         call timer_stop(6)
         end do
         call timer_stop(8)

         call timer_start(5)
         do k = 1, n3
         do i = 1, n2
         do j = 1, n1
           x3(j,k,i) = x(j,i,k)
         end do
         end do
         end do
         call timer_stop(5)

       	 log = ilog2(n3)
         call timer_start(9)

!HPF$ independent
         do k = 1, n2
           call Swarztrauber(sign,log,n1,n3,x3(:,:,k),n1,exp3)
         end do
         call timer_stop(9)

         call timer_stop(3)

         return
      end


	parameter (NGX=256)
	real*8 x, w, a, h
        complex*16 f(NGX)
	integer nn
	integer i, j

	nn = ngx
c stepsize
        h = 1.d0/ngx
	x=0.d0
	do i=1, NGX
	  f(i) = dcmplx(dcos(6.28*x)*dcos(62.8*x), 0.d0)
	  x = x + h
	enddo
        do i=1,40,4
          print*,i,f(i)
	enddo
C FFT
	call four1( f, nn,-1)
C inv-FFT
	call four1( f, nn, 1)
        do i=1,40,4
c	  a = f(i)*conjg(f(i))
	  print*,i,f(i)/nn
	enddo
	stop
	end


      SUBROUTINE lmpar (n, r, ldr, ipvt, diag, qtb, delta, par, x,
     1                 sdiag, wa1, wa2)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: n, ldr, ipvt(n)
      REAL(rprec), INTENT(in) :: delta
      REAL(rprec), INTENT(inout) :: par
      REAL(rprec), DIMENSION(ldr,n), INTENT(inout) :: r
      REAL(rprec), DIMENSION(n) :: wa1, wa2
      REAL(rprec), DIMENSION(n), INTENT(in) :: diag, qtb
      REAL(rprec), DIMENSION(n), INTENT(out) :: x, sdiag
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: p1=0.1_dp, zero = 0,
     1     p001 = 0.001_dp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: iter, j, jm1, jp1, k, l, nsing
      REAL(rprec) :: dxnorm, dwarf, fp, gnorm, parc, parl, paru,
     1   sum0, enorm, dpmpar, temp, epsmch
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      EXTERNAL dpmpar, enorm
C-----------------------------------------------
c
c     SUBROUTINE lmpar
c
c     given an m by n matrix a, an n by n nonsingular diagonal
c     matrix d, an m-vector b, and a positive number delta,
c     the problem is to determine a value for the parameter
c     par such that IF x solves the system
c
c           a*x = b ,     SQRT(par)*d*x = 0 ,
c
c     in the least squares sense, and dxnorm is the euclidean
c     norm of d*x, THEN either par is zero and
c
c           (dxnorm-delta) .le. 0.1*delta ,
c
c     or par is positive and
c
c           ABS(dxnorm-delta) .le. 0.1*delta .
c
c     this SUBROUTINE completes the solution of the problem
c     IF it is provided with the necessary information from the
c     qr factorization, with column pivoting, of a. that is, IF
c     a*p = q*r, WHERE p is a permutation matrix, q has orthogonal
c     columns, and r is an upper triangular matrix with diagonal
c     elements of nonincreasing magnitude, THEN lmpar EXPects
c     the full upper triangle of r, the permutation matrix p,
c     and the first n components of (q TRANSPOSE)*b. on output
c     lmpar also provides an upper triangular matrix s such that
c
c            t   t                   t
c           p *(a *a + par*d*d)*p = s *s .
c
c     s is employed within lmpar and may be of separate interest.
c
c     ONLY a few iterations are generally needed for convergence
c     of the algorithm. IF, however, the limit of 10 iterations
c     is reached, THEN the output par will contain the best
c     value obtained so far.
c
c     the SUBROUTINE statement is
c
c       SUBROUTINE lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,
c                        wa1,wa2)
c
c     WHERE
c
c       n is a positive INTEGER input variable set to the order of r.
c
c       r is an n by n array. on input the full upper triangle
c         must contain the full upper triangle of the matrix r.
c         on output the full upper triangle is unaltered, and the
c         strict lower triangle CONTAINS the strict upper triangle
c         (transposed) of the upper triangular matrix s.
c
c       ldr is a positive INTEGER input variable not less than n
c         which specifies the leading DIMENSION of the array r.
c
c       ipvt is an INTEGER input array of length n which defines the
c         permutation matrix p such that a*p = q*r. column j of p
c         is column ipvt(j) of the identity matrix.
c
c       diag is an input array of length n which must contain the
c         diagonal elements of the matrix d.
c
c       qtb is an input array of length n which must contain the first
c         n elements of the vector (q TRANSPOSE)*b.
c
c       delta is a positive input variable which specifies an upper
c         bound on the euclidean norm of d*x.
c
c       par is a nonnegative variable. on input par CONTAINS an
c         initial estimate of the levenberg-marquardt PARAMETER.
c         on output par CONTAINS the final estimate.
c
c       x is an output array of length n which CONTAINS the least
c         squares solution of the system a*x = b, SQRT(par)*d*x = 0,
c         for the output par.
c
c       sdiag is an output array of length n which CONTAINS the
c         diagonal elements of the upper triangular matrix s.
c
c       wa1 and wa2 are work arrays of length n.
c
c     subprograms called
c
c       MINpack-supplied ... dpmpar,enorm,qrsolv
c
c       fortran-supplied ... ABS,max,min,sqrt
c
c     argonne national laboratory. MINpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********

c
c     dwarf is the smallest positive magnitude.
c
      dwarf = dpmpar(2)
      epsmch = SQRT(dpmpar(1))       !SPH: Gives better lower bound for r(j,j)
c
c     compute and store in x the gauss-newton direction. IF the
c     jacobian is rank-deficient, obtain a least squares solution.
c
      nsing = n
      DO j = 1, n
         wa1(j) = qtb(j)
!SPH     IF (r(j,j).eq.zero .and. nsing.eq.n) nsing = j - 1
         IF (ABS(r(j,j)).le.epsmch .and. nsing.eq.n) nsing = j - 1
         IF (nsing .lt. n) wa1(j) = zero
      END DO
      IF (nsing .ge. 1) THEN
         DO k = 1, nsing
            j = nsing - k + 1
            wa1(j) = wa1(j)/r(j,j)
            temp = wa1(j)
            jm1 = j - 1
            IF (jm1 .ge. 1) THEN
               wa1(:jm1) = wa1(:jm1) - r(:jm1,j)*temp
            END IF
         END DO
      END IF
      DO j = 1, n
         l = ipvt(j)
         x(l) = wa1(j)
      END DO
c
c     initialize the iteration counter.
c     evaluate the FUNCTION at the origin, and test
c     for acceptance of the gauss-newton direction.
c
      wa2 = diag * x
      dxnorm = enorm(n,wa2)
      fp = dxnorm - delta

      IF (fp .le. p1*delta) THEN
         par = zero
         RETURN
      END IF

c
c     BEGIN GAUSS-NEWTON STEP
c
c     IF the jacobian is not rank deficient, the newton
c     step provides a lower bound, parl, for the zero of
c     the FUNCTION. otherwise set this bound to zero.
c
      parl = zero
      IF (nsing .ge. n) THEN
         wa1 = diag(ipvt)*(wa2(ipvt)/dxnorm)
         DO j = 1, n
            SUM0 = zero
            jm1 = j - 1
            IF (jm1 .ge. 1) SUM0 = SUM(r(:jm1,j)*wa1(:jm1))
            wa1(j) = (wa1(j)-sum0)/r(j,j)
         END DO
         temp = enorm(n,wa1)
         parl = ((fp/delta)/temp)/temp
      END IF
c
c     calculate an upper bound, paru, for the zero of the FUNCTION.
c
      DO j = 1, n
         SUM0 = SUM(r(:j,j)*qtb(:j))
         l = ipvt(j)
         wa1(j) = SUM0/diag(l)
      END DO
      gnorm = enorm(n,wa1)
      paru = gnorm/delta
      IF (paru .eq. zero) paru = dwarf/MIN(delta,p1)
c
c     IF the input par lies outside of the interval (parl,paru),
c     set par to the CLOSEr ENDpoint.
c
      par = MAX(par,parl)
      par = MIN(par,paru)
      IF (par .eq. zero) par = gnorm/dxnorm

c
c     beginning of an iteration loop.
c
      DO iter = 1, 10
c
c        evaluate the FUNCTION at the current value of par.
c
         IF (par .le. zero) par = MAX(dwarf,p001*paru)
         temp = SQRT(par)

         wa1 = temp*diag
         CALL qrsolv (n, r, ldr, ipvt, wa1, qtb, x, sdiag, wa2)
         wa2 = diag*x
         dxnorm = enorm(n,wa2)
         temp = fp
         fp = dxnorm - delta
c
c        If the function is small enough, accept the current value
c        of par. also test for the exceptional cases where parl
c        is zero or the number of iterations has reached 10.
c
         IF (ABS(fp).le.p1*delta .or. parl.eq.zero .and.
     1       fp.le.temp .and. temp.lt.zero .or. iter.eq.10) EXIT
c
c        compute the newton correction.
c
         wa1 = diag(ipvt)*(wa2(ipvt)/dxnorm)
         DO j = 1, n
            wa1(j) = wa1(j)/sdiag(j)
            temp = wa1(j)
            jp1 = j + 1
            IF (n .ge. jp1) wa1(jp1:n) = wa1(jp1:n) - r(jp1:n,j)*temp
         END DO
         temp = enorm(n,wa1)
         parc = ((fp/delta)/temp)/temp
c
c        depending on the sign of the FUNCTION, update parl or paru.
c
         IF (fp .gt. zero) parl = MAX(parl,par)
         IF (fp .lt. zero) paru = MIN(paru,par)
c
c        compute an improved estimate for par.
c
         par = MAX(parl,par + parc)

      END DO                        !!end of an iteration.

      END SUBROUTINE lmpar


C
C	$Id: csgivens.f,v 1.5 2008-07-27 03:10:06 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSGIVENS ( A,B, C,S)
      DOUBLE PRECISION A, B, C, S
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   05/09/92
C
C   This subroutine constructs the Givens plane rotation,
C
C           ( C  S)
C       G = (     ) , where C*C + S*S = 1,
C           (-S  C)
C
C which zeros the second component of the vector (A,B)**T
C (transposed).  Subroutine CSROTATE may be called to apply
C the transformation to a 2 by N matrix.
C
C   This routine is identical to Subroutine SROTG from the
C LINPACK BLAS (Basic Linear Algebra Subroutines).
C
C On input:
C
C       A,B = Components of the vector defining the rota-
C             tion.  These are overwritten by values R
C             and Z (described below) which define C and S.
C
C On output:
C
C       A = Signed Euclidean norm R of the input vector:
C           R = +/-SQRT(A*A + B*B)
C
C       B = Value Z such that:
C             C = SQRT(1-Z*Z) and S=Z if ABS(Z) .LE. 1, and
C             C = 1/Z and S = SQRT(1-C*C) if ABS(Z) > 1.
C
C       C = +/-(A/R) or 1 if R = 0.
C
C       S = +/-(B/R) or 0 if R = 0.
C
C Modules required by CSGIVENS:  None
C
C Intrinsic functions called by CSGIVENS:  ABS, SQRT
C
C***********************************************************
C
      DOUBLE PRECISION AA, BB, R, U, V
C
C Local parameters:
C
C AA,BB = Local copies of A and B
C R =     C*A + S*B = +/-SQRT(A*A+B*B)
C U,V =   Variables used to scale A and B for computing R
C
      AA = A
      BB = B
      IF (ABS(AA) .GT. ABS(BB)) THEN
C
C ABS(A) > ABS(B).
C
        U = AA + AA
        V = BB/U
        R = SQRT(.25 + V*V) * U
        C = AA/R
        S = V * (C + C)
C
C Note that R has the sign of A, C > 0, and S has
C   SIGN(A)*SIGN(B).
C
        B = S
        A = R
      ELSEIF (BB .NE. 0.) THEN
C
C ABS(A) .LE. ABS(B).
C
        U = BB + BB
        V = AA/U
C
C Store R in A.
C
        A = SQRT(.25 + V*V) * U
        S = BB/A
        C = V * (S + S)
C
C Note that R has the sign of B, S > 0, and C has
C   SIGN(A)*SIGN(B).
C
        B = 1.
        IF (C .NE. 0.) B = 1./C
      ELSE
C
C A = B = 0.
C
        C = 1.
        S = 0.
      ENDIF
      RETURN
      END


SUBROUTINE  SPREADING(BETA1,PI,S0,CTA0,SEED2,NCTA)

INTEGER S,I,J,NT,NCTA,NCTA1,SEED2
REAL*8 CTAMAX,CTAMIN,DCTA,CTA0,IPOW,DS,SUM1,AAA,DCTA1,S0,PI,SPM
REAL*8 CTA(16384),COSINT(16384),CC1(16384),BETA1(NCTA),PS(16384)

  IPOW=2*S0

  NCTA1=16384

!!!!!  out put
!      OPEN(1110,FILE='spreading.dat')

!   write(1110,*) s0,cta0,ncta

!  close(1110)

  CTAMAX=CTA0+0.5*PI
  CTAMIN=CTA0-0.5*PI

!FOR THE MULTIDIRECTIONAL SPREADING  'G0'

       DCTA1=(CTAMAX-CTAMIN)/FLOAT(NCTA1-1)

	DO I=1,NCTA1
        CC1(I)=CTAMIN+(I-1)*DCTA1
        END DO

        SUM1=0.0
        DO I=1,NCTA1
        AAA=CC1(I)

        SUM1=SUM1+((COS((AAA-CTA0)/2.))**IPOW)*DCTA1
        END DO
        SPM=1./SUM1

  CTA(1)=CTAMIN
  CTA(NCTA)=CTAMAX

  DS=0.0

  DCTA=PI/REAL(NCTA)
!  OPEN(1,FILE='1 ',status='unknown')
!  OPEN(2,FILE='2.TXT')
  DO I=1,NCTA

  CTA(I)=CTAMIN+(I-1)*DCTA

  DS=DS+((COS((CTA(I)-CTA0)/2.0))**IPOW)*DCTA

  COSINT(I)=DS*SPM
!   WRITE(*,*) i
!   WRITE(1,*)   CTA(I) ,i
  END DO

!  OPEN(4,FILE='4.TXT')
!  OPEN(3,FILE='3.TXT')
  DO J=1,NCTA

   PS(J)=RAN1_b(SEED2)
!   WRITE(2,*)   PS(J),SEED2,J,spm
  DO I=1,NCTA

  IF (COSINT(I).GE.PS(J)) then
!   WRITE(4,*)   CTA(I),COSINT(I),PS(J),I
  GO TO 100

  end if

  END DO

 100  BETA1(J)=CTA(I)

 !  WRITE(3,*)   CTA(I),COSINT(I),PS(J),I

  END DO

!!!!  output
!   OPEN(1110,FILE='anglespreading')
!  do i=1,ncta
!   write(1110,*) beta1(i)
!   end do
!  close(1110)

  return
  END SUBROUTINE SPREADING


Subroutine CONFIGINI

  use cte

  Implicit None

  Real    :: XRan, YRan, ZRan
  Integer :: i

  Ls = (1.0 * Nc/ns)**(1.E0/3.E0)

  Write(*,*) "LONGITUD DE LA CELDA:", Ls
  Open (1, file = "ConfigIni.txt")

  !Posicion de las particulas
  Colocar: Do i = 1, Nc

     !GENERANDO VALORES ALEATORIOS PARA LA POSICION
     Call Random_Number(xRan)                   !VALOR ALEATORIO DE POSICION X \
     Call Random_Number(yRan)                   !VALOR ALEATORIO DE POSICION Y | TENTATIVO
     Call Random_Number(zRan)                   !VALOR ALEATORIO DE POSICION Z /

     X(i) = (xRan-0.5)*(Ls-1)                   !\
     Y(i) = (yRan-0.5)*(Ls-1)                   !|   [-(Ls-1)/2 , (Ls-1)/2] AJUSTANDO A LA CELDA
     Z(i) = (zRan-0.5)*(Ls-1)                   !/

     Write(1,*) X(i), Y(i), Z(i) ! GUARDANDO CONFIGURACION INICIAL EN ARCHIVO

  End Do Colocar

  Close(1)

End Subroutine CONFIGINI


!----------------------------------------------------------------
! (c) Copyright, 2011 by the Regents of the University of California.
! Version: 1.1
! Author: Ji Qiang, LBNL
! Description: find the Fourier coeficients of input discrete RF data.
!----------------------------------------------------------------

      program rfcoef
      integer, parameter :: Ndata = 50000
      integer, parameter :: Ncoef = 100
      double precision, dimension(Ndata) :: zdata,edata
      double precision, dimension(Ncoef) :: Fcoef,Fcoef2
      double precision :: emax

      emax = 0.0d0
      open(3,file="rfdata.in",status="old")
      n = 0
10    continue
        read(3,*,end=100)tmp1,tmp2
        n = n+1
        zdata(n) = tmp1
        edata(n) = tmp2
        if(emax.le.abs(tmp2)) then
          emax = abs(tmp2)
        endif
      goto 10
100   continue
      close(3)
      ndatareal = n

      print*,"Emax is: ",emax

      print*,"How many Fourier coeficients you want?"
      read(*,*)ncoefreal

      zlen = zdata(ndatareal)-zdata(1)
      zhalf = zlen/2.0
      zmid = (zdata(ndatareal)+zdata(1))/2
      h = zlen/(ndatareal-1)
      pi = 2*asin(1.0)
      print*,"The RF data number is: ",ndatareal,zlen,zmid,h

      do j = 1, ncoefreal
        zz = zdata(1) - zmid
        Fcoef(j) = (-0.5*edata(1)*cos((j-1)*2*pi*zz/zlen)*h)/zhalf
        Fcoef2(j) = (-0.5*edata(1)*sin((j-1)*2*pi*zz/zlen)*h)/zhalf
        zz = zdata(ndatareal) - zmid
        Fcoef(j) = Fcoef(j)-(0.5*edata(ndatareal)*cos((j-1)*2*pi*zz/zlen)*h)&
                            /zhalf
        Fcoef2(j) = Fcoef2(j)-(0.5*edata(ndatareal)*sin((j-1)*2*pi*zz/zlen)*h)&
                            /zhalf
      enddo

      do i = 1, ndatareal

        zz = (i-1)*h + zdata(1)
!        zz = zdata(i) - zmid
        klo=1
        khi=ndatareal
1       if(khi-klo.gt.1) then
          k=(khi+klo)/2
          if(zdata(k).gt.zz)then
             khi=k
          else
             klo=k
          endif
          goto 1
        endif
        hstep=zdata(khi)-zdata(klo)
        slope=(edata(khi)-edata(klo))/hstep
        ez1 =edata(klo)+slope*(zz-zdata(klo))

        !zz = (i-1)*h - zmid
        !zz = (i-1)*h - half
        zz = zdata(1) + (i-1)*h - zmid
!        zz = zdata(i) - zmid
        do j = 1, ncoefreal
          !Fcoef(j) = Fcoef(j) + (edata(i)*cos((j-1)*2*pi*zz/zlen)*h)/zhalf
          !Fcoef2(j) = Fcoef2(j) + (edata(i)*sin((j-1)*2*pi*zz/zlen)*h)/zhalf
          Fcoef(j) = Fcoef(j) + (ez1*cos((j-1)*2*pi*zz/zlen)*h)/zhalf
          Fcoef2(j) = Fcoef2(j) + (ez1*sin((j-1)*2*pi*zz/zlen)*h)/zhalf
        enddo
      enddo

      open(7,file="rfcoef.out",status="unknown")
      do j = 1, ncoefreal
        write(7,*)j,Fcoef(j),Fcoef2(j)
      enddo
      close(7)

      emax = 1.0d0
      open(8,file="rfdatax",status="unknown")
      write(8,*)Fcoef(1)/emax
      do j = 2, ncoefreal
        write(8,*)Fcoef(j)/emax
        write(8,*)Fcoef2(j)/emax
      enddo
      close(8)

      open(8,file="rfdata.out",status="unknown")
      do i = 1, ndatareal
        zz = zdata(i) - zmid
        tmpsum = 0.5*Fcoef(1)
        tmpsump = 0.0
        tmpsumpp = 0.0
        do j = 2,ncoefreal
         tmpsum = tmpsum + Fcoef(j)*cos((j-1)*2*pi*zz/zlen) + &
                  Fcoef2(j)*sin((j-1)*2*pi*zz/zlen)
         tmpsump = tmpsump-(j-1)*2*pi*Fcoef(j)*sin((j-1)*2*pi*zz/zlen)/zlen +&
                  (j-1)*2*pi*Fcoef2(j)*cos((j-1)*2*pi*zz/zlen)/zlen
         tmpsumpp = tmpsumpp-((j-1)*2*pi*Fcoef(j)/zlen)**2*cos((j-1)*2*pi*zz/zlen) -&
                  ((j-1)*2*pi*Fcoef2(j)/zlen)**2*sin((j-1)*2*pi*zz/zlen)
        enddo
        write(8,*)zdata(i),tmpsum,tmpsump,tmpsumpp
      enddo
      close(8)

      stop
      end program rfcoef


MODULE params_raytracing

	use constantes
	use environ
	use subs_raytracing

	implicit none

	contains

subroutine thetakB(k,V,thkB)
	!-----------------------------------------------------
	! (k,B) angle computation
	! CALLING SEQUENCE: call thetakB(k,V,thkB)
	! INPUTS:     k: wave vector in cartesian coordinates.
	!             V: position vector in cartesian coordinates.
	! OUTPUTS: thkB: (k,B) angle in radian
	!-----------------------------------------------------
	real(kind=8), dimension(:,:),intent(in) :: k,V
	real(kind=8), dimension(:),intent(out)  :: thkB
	real(kind=8), dimension(3,size(thkb))   :: B
	real(kind=8),dimension(size(thkb))      :: normB,normk

	call magneticf(V,B)
	normB=sqrt(B(1,:)**2+B(2,:)**2+B(3,:)**2)
	normk=sqrt(k(1,:)**2+k(2,:)**2+k(3,:)**2)

	where (normB .ne. 0)
		thkB=acos((k(1,:)*B(1,:)+k(2,:)*B(2,:)+k(3,:)*B(3,:))/(normB*normk))
	elsewhere
		thkB=0.d0
	end where

end subroutine thetakB

subroutine thetarB(V,Vap,thrB)
	!-----------------------------------------------------
	! (r,B) angle computation
	! CALLING SEQUENCE: call thetarB(k,V,thrB)
	! INPUTS:   Vap: vector in cartesian coordinates.
	!             V: position vector in cartesian coordinates.
	! OUTPUTS: thrB: (r,B) angle in radian
	!-----------------------------------------------------
	real(kind=8), dimension(:,:),intent(in) :: V,Vap
	real(kind=8), dimension(:),intent(out)  :: thrB
	real(kind=8), dimension(3,size(thrb))   :: B
	real(kind=8), dimension(size(thrb))     :: normB,normV

	call magneticf(V,B)
	normB=sqrt(B(1,:)**2+B(2,:)**2+B(3,:)**2)
	normV=sqrt((V(1,:)-Vap(1,:))**2+(V(2,:)-Vap(2,:))**2+(V(3,:)-Vap(3,:))**2)

	where (normB .ne. 0)
		thrB=acos(((Vap(1,:)-V(1,:))*B(1,:)+(Vap(2,:)-V(2,:))*B(2,:)+(Vap(3,:)-V(3,:))*B(3,:))/(normB*normV))
	elsewhere
		thrB=0.d0
	end where

end subroutine thetarB

subroutine thetakr(k,V,Y,Vap,thkr)
	!-----------------------------------------------------
	! (k,r) angle computation
	! CALLING SEQUENCE: call thetakr(k,V,Vap,thkr)
	! INPUTS:     k: wave vector in cartesian coordinates.
	!             V: position vector in cartesian coordinates at step n.
	!             Y: magnetic vector
	!           Vap: position vector in cartesian coordinates at step n+1
	! OUTPUTS: thkr: (k,r) angle in radian
	!-----------------------------------------------------
	real(kind=8), dimension(:,:),intent(in) :: k,V,Vap,Y
	real(kind=8), dimension(:),intent(out)  :: thkr
	real(kind=8), dimension(3,size(thkr))	:: d
	real(kind=8),dimension(size(thkr))      :: normV,normk,normY

	d=Vap-V
	normV=sqrt(d(1,:)**2+d(2,:)**2+d(3,:)**2)
	normk=sqrt(k(1,:)**2+k(2,:)**2+k(3,:)**2)
	normY=sqrt(Y(1,:)**2+Y(2,:)**2+Y(3,:)**2)

	where ((normV .ne. 0) .and. (normY /= 0.d0))
		thkr=acos((k(1,:)*d(1,:)+k(2,:)*d(2,:)+k(3,:)*d(3,:))/(normV*normk))
	elsewhere
		thkr=0.d0
	end where

end subroutine thetakr

subroutine vgroup(V,k,f,thkr,mode,vg)
	!-----------------------------------------------------
	! Group velocity calculation (Budden p.140)
	!      vg = 1/(n'*cos(alpha))
	!      n' = d(f*n)df
	!   alpha = angle (k,ray)
	! CALLING SEQUENCE: call vgroup(V,k,f,thkr,mode,vg)
	! INPUTS:     V: position vector in cartesian coordinates
	!             k: wave vector in cartesian coordinates.
	!             f: wave frequency
	!          mode: propagation mode
	!          thkr: (k,r) angle
	! OUTPUTS:   vg: group velocity
	!-----------------------------------------------------
	real(kind=8), dimension(:,:), intent(in)	:: V,k
	real(kind=8), dimension(:), intent(in)		:: thkr
	real(kind=8), intent(in) 			:: f
	character(len=1), intent(in), dimension(:)      :: mode
	real(kind=8), dimension(:), intent(out)		:: vg

	real(kind=8), dimension(3,size(V,2)) 		:: Y, Yav, Yap
	real(kind=8), dimension(size(V,2))		:: X,Xav,Xap,mu, muav, muap,muprime
	real(kind=8)					:: df

	df=1.d0 !Hz

	call varplasma(V,f-df,Xav,Yav)
	call varplasma(V,f+df,Xap,Yap)
	call varplasma(V,f,X,Y)

	call index(Xav,Yav,k,mode,muav)
	call index(Xap,Yap,k,mode,muap)
	call index(X,Y,k,mode,mu)

	muprime = mu +f*(muap-muav)/(2.d0*df)

	vg(:) = 1.d0/(muprime(:)*cos(thkr(:)))

end subroutine vgroup

subroutine vphase(mu,vp)
	!-----------------------------------------------------
	! Phase velocity calculation
	!      vp = c/mu
	! CALLING SEQUENCE: call vphase(mu,vp)
	! INPUTS:     mu: indice
	! OUTPUTS:    vp: phase velocity
	!-----------------------------------------------------
	real(kind=8), dimension(:), intent(in) 	:: mu
	real(kind=8), dimension(:), intent(out) :: vp

	vp = 1.d0/mu

end subroutine vphase

subroutine distance(V,Vav,dist,numray)
	!-----------------------------------------------------
	! Calculation of the distance travelled by the ray from its starting point
	!
	! CALLING SEQUENCE: call distance(d,V,dist)
	! INPUTS:     d: distance at the last step
	!             V: position vector in cartesian coordinates at step n
	!           Vav: position vector in cartesian coordinates at step n-1
	! OUTPUTS: dist: distance
	!-----------------------------------------------------
	real(kind=8), dimension(:,:), intent(in) :: V, Vav
	integer(kind=8), dimension(:), intent(in)   :: numray
	real(kind=8), dimension(:), intent(inout):: dist

	dist(numray) = dist(numray) + sqrt((V(1,:)-Vav(1,:))**2+(V(2,:)-Vav(2,:))**2+(V(3,:)-Vav(3,:))**2)

end subroutine distance

subroutine fplasma(f,X,fp)
	!-----------------------------------------------------
	! Plasma frequency computation fp = f*sqrt(X)
	!
	! CALLING SEQUENCE: call fplasma(f,X,fp)
	! INPUTS:     f: wave frequency
	!             X: (fp/f)^2
	! OUTPUTS:   fp: plasma  frequency
	!-----------------------------------------------------
	real(kind=8), intent(in)  				:: f
	real(kind=8), dimension(:), intent(in)  :: X
	real(kind=8), dimension(:), intent(out) :: fp

	fp(:) = f*sqrt(X(:))

end subroutine fplasma

subroutine fcyclo(f,Y,fc)
	!-----------------------------------------------------
	! Cyclotron frequency calculation fc = f*norm(Y)
	!
	! CALLING SEQUENCE: call fcyclo(f,X,fp)
	! INPUTS:     f: wave frequency
	!             Y: fc/f
	! OUTPUTS:   fc: Cyclotron frequency
	!-----------------------------------------------------
	real(kind=8), intent(in)  				:: f
	real(kind=8), dimension(:,:), intent(in):: Y
	real(kind=8), dimension(:), intent(out) :: fc

	fc(:) = f*sqrt(Y(1,:)**2+Y(2,:)**2+Y(3,:)**2)

end subroutine fcyclo

subroutine fuph(f,X,Y,fuh)
	!-----------------------------------------------------
	! Upper hybrid frequency calculation fuh = sqrt(fp^2+fc^2)
	!
	! CALLING SEQUENCE: call fuh(f,X,Y,fuh)
	! INPUTS:     f: wave frequency
	!             X: (fp/f)^2
	!             Y: fc/f
	! OUTPUTS:  fuh: upper hybrid frequency
	!-----------------------------------------------------
	real(kind=8), intent(in)  				:: f
	real(kind=8), dimension(:), intent(in)  :: X
	real(kind=8), dimension(:,:), intent(in):: Y
	real(kind=8), dimension(:), intent(out) :: fuh
	real(kind=8), dimension(size(fuh)) 		:: fp,fc

	call fplasma(f,X,fp)
	call fcyclo(f,Y,fc)

	fuh = sqrt(fp**2+fc**2)

end subroutine fuph

subroutine polar_ratio(mode,f,k,V,LP, pratio,pratio_1)
	!-----------------------------------------------------
	! Axial polarisation ratio calculation: (Quemada)
	!       system: (x',y',z') with z' // k and B in (x',z')
	!
	!       S = 1-X(1-Y^2) ; D = XY/(1-Y^2) ; P = 1-X
	!
	!       p = Ey'/Ex' = iPcos(th)(n^2-S)/D(n^2sin^2(th)-P)
	!       q = Ez'/Ex' = -(n^2-P)sin(th)/Pcos(th)(n^2-S)
	!       r = Ez'/Ey' = q/p
	!
	!       WARNING: BUDDEN Y=eB/mf avec e=-1.6e-19C donc \Theta_Budden = angle(k,Y) = pi - angle(k,B)
	!
	! CALLING SEQUENCE: call polar_ratio(mode,f,k,V,pratio)
	! INPUTS:      mode: propagation mode ('X', 'O' ou 'V')
	!                 f: wave frequency
	!                 k: wave vector in cartesian coordinates.
	!                 V: position vector in cartesian coordinates
	!            pratio: polarisation ration at step n
	!                LP: limiting polarisation vector ('VP' -> polar variable, 'LP' -> limiting polar
	! OUTPUTS: pratio_1: p,q,r (dim 3*Nray)
	!-----------------------------------------------------
	character(len=1), intent(in),dimension(:)		:: mode
	real(kind=8), intent(in)  				 		:: f
	real(kind=8), dimension(:,:), intent(in)  		:: V,k
	character(len=2),dimension(:), intent(in)		:: LP
	complex(kind=8), dimension(:,:), intent(in) 	:: pratio
	complex(kind=8), dimension(:,:), intent(out) 	:: pratio_1

	real(kind=8), dimension(size(V,2))   :: X, S,D,P, mu, th, normY, sinth,costh,racine,mu2, tanth
	real(kind=8), dimension(size(V,2))   :: sinth4, sinth2,costh2, nmode
	real(kind=8), dimension(3,size(V,2)) :: Y
	integer								 :: i
		call varplasma(V,f,X,Y)
		normY = sqrt(Y(1,:)**2+Y(2,:)**2+Y(3,:)**2)
		call index(X,Y,k,mode,mu)
		call thetakb(k,V,th)

		nmode(:)=1.d0
		where (mode .eq. 'X')
			nmode=-1.d0
		end where

		S = 1-X/(1-normY**2)
		D = X*normY/(1-normY**2)
		P = 1-X

		where (LP .eq. 'VP')
			where (normY /= 0.d0) ! polarisation calculation
        			!p = Ey'/Ex'
        			pratio_1(1,:) = -ic*(D*(mu**2*sin(th)**2-P))/(P*cos(th)*(mu**2-S))

	        		!q = Ez'/Ex'
        			pratio_1(2,:) = -(mu**2-P)*sin(th)/(P*cos(th))

	        		!r = Ez'/Ey'
        			pratio_1(3,:) = -ic*(mu**2-S)*(mu**2-P)*sin(th)/(D*(mu**2*sin(th)**2-P))

			elsewhere !polarisation circulaire si B = 0
				pratio_1(1,:) = nmode*ic
				pratio_1(2,:) = 0.d0
				pratio_1(3,:) = 0.d0
			end where
			!DL around de th=90 in mode O
			!-------------------------------

			!	where (mode .ne. 'X' .and. ((th .gt. pi/2.-0.0174533) .and. (th .lt. pi/2.+0.0174533)))
			!	where (((th .gt. pi/2.-0.0174533) .and. (th .lt. pi/2.+0.0174533)))
			!		sinth = 1.d0-(pi/2.d0-th)**2/2.d0
			!		costh = (pi/2.d0 -th)-(pi/2.d0-th)**3/6.d0
			!		costh2 = (pi/2.d0 -th)**2
			!		mu2 = 1-X/(1-X*costh2)
			!		pratio(1,:) = ic*(D/(P*(mu2-S)))*costh2
			!		pratio(2,:) = -((mu2-P)/P)*tan(th)
			!		pratio(3,:) = -ic*(mu2-S)*(mu2-P)*tan(th)**2/(D*sinth)
			!	end where
		else where
			pratio_1(1,:) = pratio(1,:)
			pratio_1(2,:) = pratio(2,:)
			pratio_1(3,:) = pratio(3,:)
		end where

end subroutine polar_ratio

subroutine limiting_polar(f,V,k,V_1,k_1,dr,unit,LP)
	!-----------------------------------
	! Limiting polarization flag
	! if abs(mux-muo) < c/2pif*dmux/dr ou c/2pif*dmux/dr then the polarization is fixed
	!
	! WARNING WITH THE CHOICE OF DR AND WITH UNITS OF V (m,km,Rs,...)
	!-----------------------------------
	real(kind=8), intent(in)  				 		:: f !en Hz
	real(kind=8), dimension(:,:), intent(in)  		:: V,k,V_1,k_1
	real(kind=8), dimension(:),intent(in)			:: dr
	character(len=2), intent(in)                    :: unit
	character(len=2),dimension(:), intent(out)		:: LP

	character(len=1), dimension(size(V,2))			:: modeX,modeO
	real(kind=8), dimension(size(V,2))				:: X, mux,muo, mux_1,muo_1, dmux,dmuo,dmuxo
	real(kind=8),dimension(3,size(V,2))				:: Y, Vdr
	real(kind=8)									:: dr2, convunit
	integer 										:: i

	modeX(:)='X'
	modeO(:)='O'

	if ((unit .eq. 'KM') .or. (unit .eq. 'km')) then
		convunit = 1.d3
	else if ((unit .eq. 'RS') .or. (unit .eq. 'rs') .or. (unit .eq. 'Rs')) then
		convunit = RS*1.d3
	else if ((unit .eq. 'RSol') .or. (unit .eq. 'rsol') .or. (unit .eq. 'Rsol') .or. (unit .eq. 'RSOL')) then
		convunit=RSol*1.d3
	else if ((unit .eq. 'RT') .or. (unit .eq. 'rt') .or. (unit .eq. 'Rt')) then
		convunit=RT*1.d3
	else if ((unit .eq. 'RJ') .or. (unit .eq. 'rj') .or. (unit .eq. 'RJ')) then
		convunit=RJ*1.d3
	else
		write(*,*) 'PB UNITE'
		convunit = 1.d0
	endif

	! mux and muo calculation in (r_n, k_n)
	call varplasma(V,f,X,Y)
	call index(X,Y,k,modeX,muX)
	call index(X,Y,k,modeO,muO)

	! mux et muo calculation in (r_n+1,k_n+1)
	call varplasma(V_1,f,X,Y)
	call index(X,Y,k_1,modeX,muX_1)
	call index(X,Y,k_1,modeO,muO_1)

	!dmu = c/(2pif)*(mu1-mu)/dr !WARNING WITH UNITS
	dmux = c/(2.d0*pi*f)*abs(muX_1-muX)/(dr*convunit)
	dmuo = c/(2.d0*pi*f)*abs(muO_1-muO)/(dr*convunit)

	!muo_1-mux_1 calculation
	dmuxo = abs(muo_1-mux_1)

	!Limiting polarization when (muo-mux) < dmuo or dmux < 1%
	where((abs(dmuxo) .le. dmux) .or. (abs(dmuxo) .le. dmuo))
		LP(:) ='LP' !limiting polarization
	else where
		LP(:)='VP'  !variable polarization
	end where

	do i=1,size(X)
		write(19,*) 'mux',mux_1(i),'muo',muo_1(i),'dmuxo',dmuxo(i), 'dmux', dmux(i), 'dmuo',dmuo(i), 'Limiting Polar ', LP(i)
		!write(19,*) '----------------------------------------------------------'
	enddo
		!write(19,*) '----------------------------------------------------------'

end subroutine limiting_polar

subroutine errordisp(k,V,X,Y,mu,errdisp)
	!---------------------------------
	! error calculation k^2-1-X*(pY-1) (Haselgrove (1960))
	! CALLING SEQUENCE: call error(k,X,Y, err)
	! INPUTS : V: position vector in cartesian coordinates
	!          k: wave vector in cartesian coordinates.
	!          f: wave frequency
	! OUTPUTS: err: scalar = 0
	!------------------------------------
	real(kind=8), dimension(:,:), intent(in)  :: Y,k,V
	real(kind=8), dimension(:), intent(in)    :: X,mu
	real(kind=8), dimension(:), intent(out)   :: errdisp
	real(kind=8), dimension(size(X))          :: A,B,C, normY,p,s,d, th

	normY = sqrt(Y(1,:)**2+Y(2,:)**2+Y(3,:)**2)
	!normk2 = k(1,:)**2+k(2,:)**2+k(3,:)**2
	!call index(X,Y,k,mode,mu)
			!si B=0 (Y=0) alors direction de Y = verticale (vdotk ne pas tre nul)
	!where (normY .eq. 0.d0)
!		vdotk(:) = maxval(k(:,:))
!	elsewhere
!		vdotk(:) = (Y(1,:)*k(1,:)+Y(2,:)*k(2,:)+Y(3,:)*k(3,:))/normY(:)
!	end where
!
!	AH = 1-X-normY**2+X*normY**2*(vdotk)**2/normk2
!	!BH = 2B_60
!	BH = -2*(1-X)*(1-x-normY**2)+X*normY**2-X*normY**2*(vdotk)**2/normk2
!	CH = (1-X)*((1-X)**2-normY**2)
!
!	errdisp = abs(AH*mu**4+BH*mu**2+CH)
!
p=1.d0-x
s=1.d0-x/(1.d0-normY**2)
d=x*normY/(1.d0-normY**2)

call thetakb(k,V,th)
A = p*cos(th)**2+s*sin(th)**2
B = (d**2-s**2)*sin(th)**2-p*s*(1+cos(th)**2)
C = p*(s**2-d**2)

errdisp = A*mu**4+B*mu**2+C

!write(*,*) errdisp

end subroutine errordisp

END MODULE params_raytracing


C Convert from ring plane coordinates (radius,longitude) to camera coordinates
C (line,sample) in a perspective projection camera system.
C
      SUBROUTINE RING_PROJ(OM,VSC,FL,OAL,OAS,SCALE,RADIUS,RLON,
     &		rline,rsamp,ind)
      IMPLICIT NONE
      REAL*8 OM(3,3)		!Camera to planet transformation matrix
      REAL*8 VSC(3)		!Vector from target center to spacecraft (RS)
      REAL*4 FL			!Camera focal length in mm
      REAL*4 OAL,OAS		!Optical axis intercept line-sample
      REAL*4 SCALE 		!Picture scale in pixels/mm
      REAL*8 RADIUS,RLON	!Input ring coordinates.
      REAL*8 RLINE,RSAMP 	!Output image coordinates
      INTEGER*4 IND		! =1 if RLINE,RSAMP are valid, =0 otherwise

      REAL*8 x0,y0,z0,xc,yc,zc,S,ELON,PI,RPD

      PI = 3.141592653589793D0
      RPD = PI/180.D0		!radians per degree
      ELON = 360.D0 - RLON	!East longitude

C     ...Compute vector from camera to point on ring
      xc =  RADIUS*DCOS(ELON*RPD) - VSC(1)
      yc =  RADIUS*DSIN(ELON*RPD) - VSC(2)
      zc =                        - VSC(3)
C     ...Rotate vector into camera coordinates
      x0 = OM(1,1)*xc + OM(1,2)*yc + OM(1,3)*zc
      y0 = OM(2,1)*xc + OM(2,2)*yc + OM(2,3)*zc
      z0 = OM(3,1)*xc + OM(3,2)*yc + OM(3,3)*zc
      IF (z0 .LE. 0.) THEN	!Camera is looking away from ring plane
        RLINE = -999.
        RSAMP = -999.
	IND = 0
        RETURN
      ENDIF

C     ...Scale vector into pixels
      S = FL*SCALE/z0			!pixels/km
      RLINE = S*y0 + OAL
      RSAMP = S*x0 + OAS
      IND = 1
      RETURN
      END


SUBROUTINE fmplat(d2x,d2y,d2xy,points,aa,bb,i)
!
! This subroutine forms the 2nd derivatives for rectangular
! plate bending elements.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::points(:,:),aa,bb
 REAL(iwp),INTENT(OUT)::d2x(:),d2y(:),d2xy(:)
 INTEGER,INTENT(IN)::i
 REAL(iwp)::x,e,xp1,xp12,xp13,ep1,ep12,ep13,p1,q1,p2,q2,p3,q3,p4,q4,dp1,  &
   dq1,dp2,dq2,dp3,dq3,dp4,dq4,d2p1,d2p2,d2p3,d2p4,d2q1,d2q2,d2q3,d2q4,   &
   pt25=0.25_iwp,pt375=0.375_iwp,pt5=0.5_iwp,pt75=0.75_iwp,one=1.0_iwp,   &
   opt5=1.5_iwp,d3=3.0_iwp
 x=points(i,1)
 e=points(i,2)
 xp1=x+one
 xp12=xp1*xp1
 xp13=xp12*xp1
 ep1=e+one
 ep12=ep1*ep1
 ep13=ep12*ep1
 p1=one-pt75*xp12+pt25*xp13
 q1=one-pt75*ep12+pt25*ep13
 p2=pt5*aa*xp1*(one-xp1+pt25*xp12)
 q2=pt5*bb*ep1*(one-ep1+pt25*ep12)
 p3=pt25*xp12*(d3-xp1)
 q3=pt25*ep12*(d3-ep1)
 p4=pt25*aa*xp12*(pt5*xp1-one)
 q4=pt25*bb*ep12*(pt5*ep1-one)
 dp1=opt5*xp1*(pt5*xp1-one)
 dq1=opt5*ep1*(pt5*ep1-one)
 dp2=aa*(pt5-xp1+pt375*xp12)
 dq2=bb*(pt5-ep1+pt375*ep12)
 dp3=opt5*xp1*(one-pt5*xp1)
 dq3=opt5*ep1*(one-pt5*ep1)
 dp4=pt5*aa*xp1*(pt75*xp1-one)
 dq4=pt5*bb*ep1*(pt75*ep1-one)
 d2p1=opt5*x
 d2p2=pt25*aa*(d3*x-one)
 d2p3=-d2p1
 d2p4=pt25*aa*(d3*x+one)
 d2q1=opt5*e
 d2q2=pt25*bb*(d3*e-one)
 d2q3=-d2q1
 d2q4=pt25*bb*(d3*e+one)
 d2x(1)=d2p1*q1
 d2x(2)=d2p2*q1
 d2x(3)=d2p1*q2
 d2x(4)=d2p2*q2
 d2x(5)=d2p1*q3
 d2x(6)=d2p2*q3
 d2x(7)=d2p1*q4
 d2x(8)=d2p2*q4
 d2x(9)=d2p3*q3
 d2x(10)=d2p4*q3
 d2x(11)=d2p3*q4
 d2x(12)=d2p4*q4
 d2x(13)=d2p3*q1
 d2x(14)=d2p4*q1
 d2x(15)=d2p3*q2
 d2x(16)=d2p4*q2
 d2y(1)=p1*d2q1
 d2y(2)=p2*d2q1
 d2y(3)=p1*d2q2
 d2y(4)=p2*d2q2
 d2y(5)=p1*d2q3
 d2y(6)=p2*d2q3
 d2y(7)=p1*d2q4
 d2y(8)=p2*d2q4
 d2y(9)=p3*d2q3
 d2y(10)=p4*d2q3
 d2y(11)=p3*d2q4
 d2y(12)=p4*d2q4
 d2y(13)=p3*d2q1
 d2y(14)=p4*d2q1
 d2y(15)=p3*d2q2
 d2y(16)=p4*d2q2
 d2xy(1)=dp1*dq1
 d2xy(2)=dp2*dq1
 d2xy(3)=dp1*dq2
 d2xy(4)=dp2*dq2
 d2xy(5)=dp1*dq3
 d2xy(6)=dp2*dq3
 d2xy(7)=dp1*dq4
 d2xy(8)=dp2*dq4
 d2xy(9)=dp3*dq3
 d2xy(10)=dp4*dq3
 d2xy(11)=dp3*dq4
 d2xy(12)=dp4*dq4
 d2xy(13)=dp3*dq1
 d2xy(14)=dp4*dq1
 d2xy(15)=dp3*dq2
 d2xy(16)=dp4*dq2
RETURN
END SUBROUTINE fmplat


      subroutine genpt(xr,ptmin,exact,pt,xjac)
      implicit none
c--- given a random number xr between 0 and 1, generate a transverse
c--- momentum pt according to the flag exact:
c---    exact=true:  generate according to dpt/pt down to ptmin
c---    exact=false: generate down to pt=0 with a shape determined by ptmin
c---
c--- returns: pt and xjac, the Jacobian of the transformation from pt dpt to dxr
      logical exact
      double precision xr,ptmin,pt,xjac,hmin,hmax,h,delh,ptmax
      include 'energy.f'

      ptmax=sqrts/2d0

      if (exact) then
        hmin=1d0/ptmax
        hmax=1d0/ptmin
        delh=hmax-hmin
        h=hmin+xr*delh
        pt=1d0/h
        xjac=delh/h**3
      else
        pt=2d0*ptmin*ptmax*xr/(2d0*ptmin+ptmax*(1d0-xr))
        xjac=pt*ptmax/2d0/ptmin/(2d0*ptmin+ptmax)*(2d0*ptmin+pt)**2
      endif

      return
      end


	subroutine hcncrd (x,y,z)
C       changing of coordinates with respect of matrix
	common /gfmatr/ t (4,4), a(4,4), nt, nt1 /gfcrd/ xp,yp,zp
c
	c  =  x*t(1,4) + y*t(2,4) + z*t(3,4) + t(4,4)
	xp = (x*t(1,1) + y*t(2,1) + z*t(3,1) + t(4,1)) / c
	yp = (x*t(1,2) + y*t(2,2) + z*t(3,2) + t(4,2)) / c
	zp = (x*t(1,3) + y*t(2,3) + z*t(3,3) + t(4,3)) / c
	return
	end


      function al31 (x, zeff, alphae, alphai)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use vmec0
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(rprec) :: x, zeff, alphae, alphai
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      real(rprec) :: z, z2, d, a, al31
C-----------------------------------------------
c-
c calculates L31 transport coefficient, according to
c S. Hirshman, Phys. Fluids 31, 3150 (1988)
c x - ratio of trapped to circulated particles
c-
      z = zeff                              !effective ion charge number
      z2 = z**2
      d=1.414_dp*z+z2+x*(0.754_dp+2.657_dp*z+2.0_dp*z2)+
     1   x*x*(0.348_dp+1.243_dp*z+z2)
      a = 0.754_dp + 2.21_dp*z + z2 + x*(0.348_dp + 1.243_dp*z + z2)
      al31 = x*a/d
      alphae = 1 - (0.884_dp + 2.074_dp*z)/a
      alphai = 1 - 1.172_dp/(1 + 0.462_dp*x)

      end function al31


!==============================================================================!
  real function U_Plus_Rough_Walls(wall_dist)
!------------------------------------------------------------------------------!
!   Calculates U+ for rough walls.                                             !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod, only: TINY
  use Rans_Mod,  only: z_o, kappa
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  real :: wall_dist
!==============================================================================!

  U_Plus_Rough_Walls = log((wall_dist + z_o) / z_o) / (kappa + TINY) + TINY

  end function