module maths
use vars
! use Fast_Fourier
use singleton
!use nrutil, ONLY : assert_eq, imaxloc, outerprod, swap
implicit none
contains

!----------------------------------------------------------------
! This function calculates the 3-j symbol
! J_i and M_i have to be twice the actual value of J and M
!----------------------------------------------------------------
   function w3js(j1,j2,j3,m1,m2,m3)
   integer :: m1, m2, m3, j1, j2, j3
    integer :: ia, ib, ic, id, ie, im, ig, ih, z, zmin, zmax, jsum
    real(kind=8) :: w3js, cc, denom, cc1, cc2

!       w3js = w3js_regge(j1/2,j2/2,j3/2,m1/2,m2/2,m3/2)
!       return
      w3js = 0.d0
      if (m1+m2+m3 /= 0) return
      ia = j1 + j2
      if (j3 > ia) return
      ib = j1 - j2
      if (j3 < abs(ib)) return
        if (abs(m1) > j1) return
        if (abs(m2) > j2) return
        if (abs(m3) > j3) return

      jsum = j3 + ia
      ic = j1 - m1
      id = j2 - m2

        ie = j3 - j2 + m1
        im = j3 - j1 - m2
        zmin = max0(0,-ie,-im)
        ig = ia - j3
        ih = j2 + m2
        zmax = min0(ig,ih,ic)
        cc = 0.d0

        do z = zmin, zmax, 2
            denom = fact(z/2)*fact((ig-z)/2)*fact((ic-z)/2)*fact((ih-z)/2)*&
                fact((ie+z)/2)*fact((im+z)/2)
        if (mod(z,4) /= 0) denom = -denom
            cc = cc + 1.d0/denom
        enddo

        cc1 = fact(ig/2)*fact((j3+ib)/2)*fact((j3-ib)/2)/fact((jsum+2)/2)
      cc2 = fact((j1+m1)/2)*fact(ic/2)*fact(ih/2)*fact(id/2)*fact((j3-m3)/2)*fact((j3+m3)/2)
      cc = cc * sqrt(1.d0*cc1*cc2)
        if (mod(ib-m3,4) /= 0) cc = -cc
        w3js = cc
        if (abs(w3js) < 1.d-8) w3js = 0.d0
1000        return
   end function w3js

!----------------------------------------------------------------
! This function calculates the 6-j symbol
! J_i and M_i have to be twice the actual value of J and M
!----------------------------------------------------------------
    function w6js(j1,j2,j3,l1,l2,l3)
    integer :: j1,j2,j3,l1,l2,l3
    integer :: ia, ib, ic, id, ie, iif, ig, ih, sum1, sum2, sum3, sum4
    integer :: w, wmin, wmax, ii, ij, ik
   real(kind=8) :: w6js, omega, theta1, theta2, theta3, theta4, theta, denom

      w6js = 0.d0
        ia = j1 + j2
        if (ia < j3) return
        ib = j1 - j2
        if (abs(ib) > j3) return
        ic = j1 + l2
        if (ic < l3) return
        id = j1 - l2
        if (abs(id) > l3) return
        ie = l1 + j2
        if (ie < l3) return
        iif = l1 - j2
        if (abs(iif) > l3) return
        ig = l1 + l2
        if (ig < j3) return
        ih = l1 - l2
        if (abs(ih) > j3) return
      sum1=ia + j3
      sum2=ic + l3
      sum3=ie + l3
      sum4=ig + j3
        wmin = max0(sum1, sum2, sum3, sum4)
        ii = ia + ig
        ij = j2 + j3 + l2 + l3
        ik = j3 + j1 + l3 + l1
        wmax = min0(ii,ij,ik)
        omega = 0.d0
        do w = wmin, wmax, 2
          denom = fact((w-sum1)/2)*fact((w-sum2)/2)*fact((w-sum3)/2)&
                *fact((w-sum4)/2)*fact((ii-w)/2)*fact((ij-w)/2)&
                *fact((ik-w)/2)
            if (mod(w,4) /= 0) denom = -denom
            omega = omega + fact(w/2+1) / denom
        enddo
      theta1 = fact((ia-j3)/2)*fact((j3+ib)/2)*fact((j3-ib)/2)/fact(sum1/2+1)
      theta2 = fact((ic-l3)/2)*fact((l3+id)/2)*fact((l3-id)/2)/fact(sum2/2+1)
      theta3 = fact((ie-l3)/2)*fact((l3+iif)/2)*fact((l3-iiF)/2)/fact(sum3/2+1)
      theta4 = fact((ig-j3)/2)*fact((j3+ih)/2)*fact((j3-ih)/2)/fact(sum4/2+1)
      theta = theta1 * theta2 * theta3 * theta4
        w6js = omega * sqrt(theta)
      if (abs(w6js) < 1.d-8) w6js = 0.d0
1000        return
   end function w6js

!----------------------------------------------------------------
! This function calculates the 9-j symbol
! J_i and M_i have to be twice the actual value of J and M
!----------------------------------------------------------------
   function w9js(j1,j2,j3,j4,j5,j6,j7,j8,j9)
    integer :: j1,j2,j3,j4,j5,j6,j7,j8,j9
    integer :: i, kmin, kmax, k
    real(kind=8) :: x, s, x1, x2, x3, w9js

      kmin = abs(j1-j9)
        kmax = j1 + j9
        i = abs(j4-j8)
        if (i > kmin) kmin = i
        i = j4 + j8
        if (i < kmax) kmax = i
        i = abs(j2-j6)
        if (i > kmin) kmin = i
        i = j2 + j6
        if (i < kmax) kmax = i
        x = 0.d0
        do k = kmin, kmax, 2
            s = 1.d0
            if (mod(k,2) /= 0) s = -1.d0
            x1 = w6js(j1,j9,k,j8,j4,j7)
        x2 = w6js(j2,j6,k,j4,j8,j5)
        x3 = w6js(j1,j9,k,j6,j2,j3)
        x = x + s*x1*x2*x3*dfloat(k+1)
        enddo
      w9js = x
      return
   end function w9js

!----------------------------------------------------------------
! Reorder the Regge square to make it similar to eq. (2.11) in Rasch & Yu (SIAM J. Sci. Comput. Vol 25, n 4, 1416)
!----------------------------------------------------------------
   function reorder_regge(regge, factor)
    integer :: reorder_regge(3,3), regge(3,3), temp(3,3), loc_max(2), col_max, row_max, loc_min(2), col_min, row_min, t
    integer :: i, j, tot, minus1, factor

        tot = sum(regge(1,:))
        minus1 = (-1)**tot
        factor = 1

        temp = regge

        loc_max = maxloc(temp)
        row_max = loc_max(2)
        col_max = loc_max(1)

        loc_min = minloc(temp)
        row_min = loc_min(2)
        col_min = loc_min(1)

! Put the maximum and minimum in the same row
        if (col_min == col_max) then
            temp = transpose(regge)

            row_max = loc_max(1)
            col_max = loc_max(2)

            row_min = loc_min(1)
            col_min = loc_min(2)

        endif

        reorder_regge = temp
        if (row_min /= 1) then
            reorder_regge(:,1) = temp(:,row_min)
            reorder_regge(:,row_min) = temp(:,1)
            factor = factor * minus1
        endif
        temp = reorder_regge

        loc_min = minloc(temp)
        row_min = loc_min(2)
        col_min = loc_min(1)

! Put smallest one into R_11
        reorder_regge = temp
        if (col_min /= 1) then
            reorder_regge(1,:) = temp(col_min,:)
            reorder_regge(col_min,:) = temp(1,:)
            factor = factor * minus1
            temp = reorder_regge
        endif

! Put largest one into R_21
        loc_max = maxloc(temp)
        row_max = loc_max(2)
        col_max = loc_max(1)

        if (col_max /= 2) then
            reorder_regge = temp
            reorder_regge(2,:) = temp(col_max,:)
            reorder_regge(col_max,:) = temp(2,:)
            factor = factor * minus1
        endif

   end function reorder_regge

!----------------------------------------------------------------
! Calculate the 3j symbol by indexing a 1D array with all the 3j symbols Rasch & Yu (SIAM J. Sci. Comput. Vol 25, n 4, 1416)
!----------------------------------------------------------------
    function w3js_regge(j1,j2,j3,m1,m2,m3)
    integer :: j1, j2, j3, m1, m2, m3, regge(3,3), regge_order(3,3), L, X, T, B, S, c1, c2, c3, c4, c5, c, factor
    real(kind=8) :: w3js_regge

        w3js_regge = 0.d0
        if (abs(m1) > j1 .or. abs(m2) > j2 .or. abs(m3) > j3 .or. (m1+m2+m3) /= 0) return

        regge(1,1) = -j1+j2+j3
        regge(2,1) = j1-j2+j3
        regge(3,1) = j1+j2-j3

        regge(1,2) = j1-m1
        regge(2,2) = j2-m2
        regge(3,2) = j3-m3

        regge(1,3) = j1+m1
        regge(2,3) = j2+m2
        regge(3,3) = j3+m3

        regge_order = reorder_regge(regge,factor)

        L = regge_order(2,1)
        X = regge_order(1,2)
        T = regge_order(3,3)
        B = regge_order(2,2)
        S = regge_order(1,1)

        c1 = L*(24+L*(50+L*(35+L*(10+L))))/120
        c2 = X*(6+X*(11+X*(6+X)))/24
        c3 = T*(2+T*(3+T))/6
        c4 = B*(B+1)/2
        c5 = S
        c = c1+c2+c3+c4+c5+1

        w3js_regge = factor*threej(c)
    end function w3js_regge

!----------------------------------------------------------------
! Calculate the list of 3j symbols and store them in a 1D array
!----------------------------------------------------------------
    subroutine init_regge(Lmax)
    integer :: S, B, T, X, L, Lmax, cmax, c1, c2, c3, c4, c5, c, k, j1, j2, j3, m1, m2, m3

        cmax = Lmax*(274+Lmax*(225+Lmax*(85+Lmax*(15+Lmax))))/120+1

        allocate(threej(0:cmax))

        k = 0
        do L = 0, Lmax
            do X = 0, L
                do T = 0, X
                    do B = 0, T
                        do S = 0, B
                            j1 = (B+L-T+X)
                            j2 = (B+S-T+X)
                            j3 = (L+S)
                            m1 = (B+L-T-X)
                            m2 = (-B+S-T+X)
                            m3 = (T+T-L-S)

                            c1 = L*(24+L*(50+L*(35+L*(10+L))))/120
                            c2 = X*(6+X*(11+X*(6+X)))/24
                            c3 = T*(2+T*(3+T))/6
                            c4 = B*(B+1)/2
                            c5 = S
                            c = c1+c2+c3+c4+c5+1

                            threej(c) = w3js(j1,j2,j3,m1,m2,m3)

                            k = k + 1
                        enddo
                    enddo
                enddo
            enddo
        enddo

        open(unit=12,file='regge_3j.dat',action='write',form='unformatted')
        write(12) threej
        close(12)

    end subroutine init_regge

!----------------------------------------------------------------
! This function calculates the rotation matrix of order k
! The results are returned in dr(iq,iqp) and di(iq,iqp) representing
! the real and imaginary part of the rotation matrix respectevely.
! The angles alpha, beta and gamma are given in radians
!----------------------------------------------------------------
   subroutine rotmatk(k,alpha,beta,gamma,dr,di)
    integer :: k
    real(kind=8) :: alpha, beta, gamma
   real(kind=8) :: dr(-1:1,-1:1), di(-1:1,-1:1)
    integer :: iq, iqp, it, it1, it2, it3, itmax, itmin, ie1, ie2
    real(kind=8) :: a1, a2, ca, sa, cg, sg, bo2, cb2, sb2, redm, s, den

        dr = 0.d0
        di = 0.d0
        do iq = -k, k
            do iqp = -k, k
                a1 = alpha * dfloat(iq)
                a2 = gamma * dfloat(iqp)
                ca = dcos(a1)
                sa = dsin(a1)
                cg = dcos(a2)
                sg = dsin(a2)
                bo2 = beta / 2.d0
                cb2 = dcos(bo2)
                sb2 = dsin(bo2)
                it1 = k + iq
                it2 = k - iqp
                itmax = it1
                if (it2 < itmax) itmax = it2
                itmin = 0
                it3 = iq - iqp
                if (it3 > 0) itmin = it3
                redm = 0.d0
                if (beta /= 0.d0) then
                    do it = itmin, itmax
                        s = 1.d0
                        if (mod(it,2) /= 0) s = -1.d0
                        ie1 = 2*(k-it)+iq-iqp
                        ie2 = 2*it+iqp-iq
                        den = fact(it1-it) * fact(it2-it) * fact(it) * fact(it-it3)
                        redm = redm + s*(cb2**ie1)*(sb2**ie2) / den
                    enddo
                    redm = redm*sqrt(fact(k+iq)*fact(k-iq)*fact(k+iqp)*fact(k-iqp))
                else
                    if (iq == iqp) redm = 1.d0
                endif
                dr(iq,iqp) = redm*(ca*cg-sa*sg)
                di(iq,iqp) = -redm*(ca*sg+sa*cg)
            enddo
        enddo

    end subroutine rotmatk

!----------------------------------------------------------------
! This function calculates the reduced rotation matrix of order 0,1,2,...kmax
! The results are returned in complex format dr(K,iq,iqp)
! The angle beta is given in radians
! The maximum value of kmax is 6
!----------------------------------------------------------------
   subroutine reduced_matrix(kmax,beta,reduced)
    integer :: kmax, K, M, N, t, min_t, max_t
    real(kind=8) :: beta, cos_beta, sin_beta, suma, f1, f2
    real(kind=8) :: reduced(0:kmax,-kmax:kmax,-kmax:kmax)

        cos_beta = cos(beta/2.d0)
      sin_beta = sin(beta/2.d0)

        do K = 0, kmax
            do M = -K, K
                do N = -K, K
                    max_t = min(K+M,K-N)
                    min_t = max(0,M-N)
                    suma = 0.d0
                    f1 = sqrt(fact(K+M)*fact(K-M)*fact(K+N)*fact(K-N))
                    do t = min_t, max_t
                        f2 = fact(K+M-t)*fact(K-N-t)*fact(t)*fact(t+N-M)
                        suma = suma + (-1.d0)**t*cos_beta**(2*K+M-N-2*t)*sin_beta**(2*t-M+N) / f2
                    enddo
                    reduced(k,M,N) = f1 * suma
                enddo
            enddo
        enddo

    end subroutine reduced_matrix

!----------------------------------------------------------------
! This function calculates the rotation matrix of order 0,1,2,...kmax
! The results are returned in complex format dr(K,iq,iqp)
! The angles alpha, beta and gamma are given in radians
! The maximum value of kmax is 6
!----------------------------------------------------------------
   subroutine rotmatsu(kmax,alpha,beta,gamma,dr)
   integer :: kmax, K, M, N
    real(kind=8) :: alpha, beta, gamma, ca, sa, cg, sg
    complex(kind=8) :: dr(0:kmax,-kmax:kmax,-kmax:kmax), ii
    real(kind=8) :: reduced(0:kmax,-kmax:kmax,-kmax:kmax)

        ii = cmplx(0.d0,1.d0)
        call reduced_matrix(kmax,beta,reduced)

        do K = 0, kmax
            do M = -K, K
                do N = -K, K
                    dr(K,M,N) = reduced(K,M,N) * exp(-ii*(alpha*M+gamma*N))
                enddo
            enddo
        enddo

   end subroutine

!----------------------------------------------------------------
! This function returns the Kronecker delta
!----------------------------------------------------------------
    function delta(A,B)
    integer :: A, B, delta
        delta = 0.d0
        if (A == B) delta = 1.d0
    end function delta

!----------------------------------------------------------------
! This function calculates the t^K_P(i) symbol
!----------------------------------------------------------------
   function tkp(K,P)
    integer :: K, P
    complex(kind=8) :: tkp(0:3), ii

        tkp = 0.d0
        ii = cmplx(0.d0,1.d0)
        if (K == 0) then
            tkp(0) = delta(P,0)
            return
        endif

        if (K == 1) then
            tkp(3) = sqrt(3.d0/2.d0) * delta(P,0)
            return
        endif

        if (K == 2) then
            tkp(0) = sqrt(1.d0/2.d0) * delta(P,0)
            tkp(1) = -sqrt(3.d0)/2.d0 * (delta(P,-2) + delta(P,2))
            tkp(2) = ii * sqrt(3.d0)/2.d0 * (delta(P,-2) - delta(P,2))
            return
        endif
    end function tkp

!----------------------------------------------------------------
! This function calculates the tensor T^K_P(i,Omega) taking into account a double rotation
!----------------------------------------------------------------
   subroutine tkq2(alpha,beta,gamma,alphap,betap,gammap,tr)
    real(kind=8) :: alpha, beta, gamma, alphap, betap, gammap
    complex(kind=8) :: tr(0:2,-2:2,0:3), tkpi(0:3), dr1(0:2,-2:2,-2:2), dr2(0:2,-2:2,-2:2), suma
    integer :: i, K, Q, P, Qp

        call rotmatsu(2,alpha,beta,gamma,dr1)
        call rotmatsu(2,alphap,betap,gammap,dr2)

        tr = 0.d0

        do i = 0, 3
            do K = 0, 2
                do Q = -K, K
                    suma = 0.d0
                    do P = -K, K
                        tkpi = tkp(K,P)
                        do Qp = -K, K
                            suma = suma + tkpi(i) * dr1(K,P,Qp) * dr2(K,Qp,Q)
                        enddo
                    enddo
                    tr(K,Q,i) = suma
                enddo
            enddo
        enddo

    end subroutine tkq2

!----------------------------------------------------------------
! Calculates part of eq. 7.41 from Landi Degl'Innocenti & Landolfi (2004)
!----------------------------------------------------------------
   subroutine bigpar(l2,is2,k2,kp2,j2,jp2,js2,jt2,x)
    integer :: l2, is2, k2, kp2, j2, jp2, js2, jt2
    real(kind=8) :: x, x1, x2, x3, g

      x = 0.d0
      if (jp2 /= jt2 .and. j2 /= js2) return
      if (jp2 == jt2) then
        if (iabs(j2-js2) > 2 .or. j2+js2 == 0) then
            else
            call gamma(l2,is2,j2,js2,g)
            x1 = g
            x2 = w6js(k2,kp2,2,js2,j2,jp2)
            x = x1*x2
            endif
        endif

      if (j2 /= js2) return
      if (iabs(jt2-jp2) > 2 .or. jt2+jp2 == 0) return
      call gamma(l2,is2,jt2,jp2,g)
      x1 = g
      x2 = 1.d0
      if (mod(k2-kp2,4) /= 0) x2 = -1.d0
      x3 = w6js(k2,kp2,2,jt2,jp2,j2)
      x = x + x1*x2*x3
    end subroutine bigpar

!----------------------------------------------------------------
! Calculates eq. 7.42 from Landi Degl'Innocenti & Landolfi (2004)
!----------------------------------------------------------------
   subroutine gamma(l2,is2,j2,jp2,g)
    integer :: l2, is2, j2, jp2
    real(kind=8) :: g
    real(kind=8) :: x1, x2, x3

      g = 0.d0
      if (j2 == jp2) then
            g = g + dsqrt(dfloat(j2*(j2+2)*(j2+1))/4.d0)
        endif
      x1 = 1.d0
      if (mod(2+l2+is2+j2,4) /= 0) x1 = -1.d0
      x2 = dsqrt(dfloat((j2+1)*(jp2+1)*is2*(is2+2)*(is2+1))/4.d0)
      x3 = w6js(j2,jp2,2,is2,is2,l2)
      g = g + x1*x2*x3
    end subroutine gamma

!----------------------------------------------------------------
! Calculates the factorial of the integers up to 301 and save it into the fact array
!----------------------------------------------------------------
   subroutine factrl
    integer :: i
      fact(0) = 1.d0
      do i=1,101
            fact(I) = fact(I-1) * dble(I)
        enddo
   END subroutine factrl

! ---------------------------------------------------------
! LU decomposition of a matrix
!  INPUT:
!       - a is the matrix to decompose
!
!  OUTPUT:
!       - a is the LU decomposition of a
!       - indx is a vector that records the row permutation effected by the partial pivoting
!       - d takes values +1/-1 depending on whether the number of row interchanges was odd or even
! ---------------------------------------------------------
    subroutine ludcmp(a,indx,d,error)
    integer, INTENT(INOUT) :: indx(:)
    real*8, INTENT(INOUT) :: a(:,:), d
    real*8, parameter :: TINY = 1.d-20
    integer :: i, imax, j, k, n
    real*8 :: aamax, dum, sum, vv(size(a,1))
    integer :: values_start(8), values_end(8), error
    real(kind=8) :: start_time, end_time

!       call date_and_time(values=values_start)

        d = 1.d0
        n = size(a,1)
        error = 0

        do i = 1, n
            aamax = 0.d0
            aamax = maxval(dabs(a(i,:)))
            if (aamax == 0.d0) then
                print *, 'Singular matrix in LU decomposition'
                error = 1
                return
            endif
            vv(i) = 1.d0 / aamax
        enddo

!$OMP PARALLEL DO PRIVATE(I,J,K,sum,aamax,imax,d,dum) SHARED (A,indx)
        do j = 1, n
            do i = 1, j-1
                sum = a(i,j)
                do k = 1, i-1
                    sum = sum - a(i,k) * a(k,j)
                enddo
                a(i,j) = sum
            enddo
            aamax = 0.d0
            do i = j, n
                sum = a(i,j)
                do k = 1, j-1
                    sum = sum - a(i,k) * a(k,j)
                enddo
                a(i,j) = sum
                dum = vv(i) * dabs(sum)
                if (dum >= aamax) then
                    imax = i
                    aamax = dum
                endif
            enddo
            if (j /= imax) then
                do k = 1, n
                    dum = a(imax,k)
                    a(imax,k) = a(j,k)
                    a(j,k) = dum
                enddo
                d = -d
                vv(imax) = vv(j)
            endif
            indx(j) = imax
            if (a(j,j) == 0.d0) a(j,j) = TINY
            if (j /= n) then
                dum = 1.d0 / a(j,j)
                do i = j+1, n
                    a(i,j) = a(i,j) * dum
                enddo
            endif
        enddo
!$OMP END PARALLEL DO

!       call date_and_time(values=values_end)
!       start_time = values_start(5) * 3600 + values_start(6) * 60 + values_start(7) + 0.001 * values_start(8)
!       end_time = values_end(5) * 3600 + values_end(6) * 60 + values_end(7) + 0.001 * values_end(8)
!       print *, 'Time : ', end_time-start_time

    end subroutine ludcmp

! ---------------------------------------------------------
! Solves the set of equations AX=b where A is the LU decomposition of a matrix
!  INPUT:
!       - a is the LU decomposition of the system matrix
!       - b is the right hand side vector of the system
!       - indx is the vector returned by ludcmp
!  OUTPUT:
!       - b is the solution of the system
! ---------------------------------------------------------
    subroutine lubksb(a,indx,b)
    real*8, INTENT(IN) :: a(:,:)
    real*8, INTENT(INOUT) :: b(:)
    integer, INTENT(IN) :: indx(:)
    integer :: i, ii, n, j, ll
    real*8 :: sum
        n = size(a,1)
        ii = 0
        do i = 1, n
            ll = indx(i)
            sum = b(ll)
            b(ll) = b(i)
            if (ii /= 0) then
                do j = ii, i-1
                    sum = sum - a(i,j) * b(j)
                enddo
            else if (sum /= 0.d0) then
                ii = i
            endif
            b(i) = sum
        enddo
        do i = n, 1, -1
            sum = b(i)
            do j = i+1, n
                sum = sum - a(i,j) * b(j)
            enddo
            b(i) = sum / a(i,i)
        enddo
    end subroutine lubksb

! ---------------------------------------------------------
! This subroutine solves a linear system of equations using the SLAP routines
! It uses an Incomplete LU BiConjugate Gradient Sparse Ax=b solver
! ---------------------------------------------------------
!   subroutine slapsolver(a,b)
!   real(kind=8), INTENT(INOUT) :: a(:,:), b(:)
!   integer :: i, j, k, j2
!   real(kind=8), allocatable :: a_sparse(:), x(:), rwork(:)
!   integer, allocatable :: ia(:), ja(:), iwork(:)
!   integer :: n, nelt, isym, itol, itmax, iter, ierr, iunit, lenw, leniw, nsave
!   real(kind=8) :: tol, err
!   integer, allocatable :: indx(:)
!
!       n = size(b)
!       allocate(x(n))
!       k = 0
!       do i = 1, n
!           do j = 1, n
!               if (a(j,i) /= 0.d0) k = k + 1
!           enddo
!       enddo
!       nelt = k
!       if (verbose_mode == 1) then
!           print *, 'Number of non-zero elements : ', nelt
!       endif
!       allocate(a_sparse(nelt))
!       allocate(ia(nelt))
!       allocate(ja(nelt))
!
!       k = 1
!       do i = 1, n
!           do j = 1, n
!               if (a(j,i) /= 0.d0) then
!                   a_sparse(k) = a(j,i)
!                   ia(k) = j
!                   ja(k) = i
!                   k = k + 1
!               endif
!           enddo
!       enddo
!
!       x = 0.d0
!
!       isym = 0
!       itol = 1
!       tol = 1.d-10
!       itmax = 10000
!       iunit = 0
!       lenw = n*n
!       leniw = n*n
!       nsave = 10
!       allocate(iwork(leniw))
!       allocate(rwork(lenw))
!
!       if (verbose_mode == 1) then
!           print *, 'Solving the system...'
!       endif
!       call ds2y( n, nelt, ia, ja, a_sparse, isym )
!       call dslubc(n, b, x, nelt, ia, ja, a_sparse, isym, itol, tol, &
!           itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
!       if (verbose_mode == 1) then
!           print *, 'Number of iterations : ', iter, 'of ', itmax
!           print *, 'Error : ', err, ierr
!       endif
!       if (iter >= itmax+1 .or. ierr /= 0) then
!           if (verbose_mode == 1) then
!               print *, 'Couldn''t reach convergence. Trying other initialization...'
!           endif
!           write(17,*) 'Couldn''t reach convergence. Trying other initialization...'
!           x = 1.d0
!           isym = 0
!           itol = 0
!           tol = 1.d-10
!           itmax = 10000
!           iunit = 0
!           lenw = n*n
!           leniw = n*n
!           nsave = 10
!           call dslucs(n, b, x, nelt, ia, ja, a_sparse, isym, itol, tol, &
!           itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
!           if (verbose_mode == 1) then
!               print *, 'Number of iterations : ', iter, 'of ', itmax
!               print *, 'Error : ', err, ierr
!           endif
!       endif
!
!       if (iter >= itmax+1 .or. ierr /= 0) then
!           if (verbose_mode == 1) then
!               print *, 'Couldn''t reach convergence. Trying GMRES...'
!           endif
!           write(17,*) 'Couldn''t reach convergence. Trying GMRES...'
!           x = 0.d0
!           isym = 0
!           itol = 0
!           tol = 1.d-10
!           itmax = 10000
!           iunit = 0
!           lenw = n*n
!           leniw = n*n
!           nsave = 10
!           call dsdgmr(n, b, x, nelt, ia, ja, a_sparse, isym, nsave, itol, tol, &
!           itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
!           if (verbose_mode == 1) then
!               print *, 'Number of iterations : ', iter, 'of ', itmax
!               print *, 'Error : ', err, ierr
!           endif
!       endif
!
!       if (iter >= itmax+1 .or. ierr /= 0) then
!           if (verbose_mode == 1) then
!               print *, 'Couldn''t reach convergence. Trying other initialization...'
!           endif
!           write(17,*) 'Couldn''t reach convergence. Trying other initialization...'
!           x = 1.d0
!           isym = 0
!           itol = 0
!           tol = 1.d-10
!           itmax = 10000
!           iunit = 0
!           lenw = n*n
!           leniw = n*n
!           nsave = 10
!           call dsdgmr(n, b, x, nelt, ia, ja, a_sparse, isym, nsave, itol, tol, &
!           itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
!           if (verbose_mode == 1) then
!               print *, 'Number of iterations : ', iter, 'of ', itmax
!               print *, 'Error : ', err, ierr
!           endif
!       endif
!
!       b = x
!
!       deallocate(x)
!       deallocate(a_sparse)
!       deallocate(ia)
!       deallocate(ja)
!       deallocate(iwork)
!       deallocate(rwork)
!
!       if (iter >= itmax+1 .or. ierr /= 0) then
!           if (verbose_mode == 1) then
!               print *, 'Couldn''t reach convergence. Trying LU decomposition...'
!           endif
!           write(17,*) 'Couldn''t reach convergence. Trying LU decomposition...'
!           allocate(indx(n))
!           call ludcmp(a,indx,tol)
!           call lubksb(a,indx,b)
!           deallocate(indx)
!       endif
!
!   end subroutine slapsolver

! ---------------------------------------------------------
! Read lines that don't mind in a file
! INPUT:
!     - unit : unit to whom the file is associated
!     - n : number of lines to read
! ---------------------------------------------------------
   subroutine lb(unit, n)
   integer, INTENT(IN) :: unit, n
   integer :: i
          do i = 1, n
                     read(unit,*)
          enddo
   end subroutine lb

! ---------------------------------------------------------
! Returns the sizes of the eigenvectors of the Paschen Back effect
! ---------------------------------------------------------
    subroutine paschen_size(l2,is2,j2max,njlargest)
    integer :: l2, is2
    integer :: m2, j2max, j2min, j2a, j2b, nj, njlargest

        j2min = abs(l2-is2)
        j2max = l2 + is2

! First find the largest value of nj
        njlargest = 0
        do m2 = -j2max, j2max, 2
            j2a = abs(m2)
            if (j2a < j2min) j2a = j2min
            j2b = j2max
            nj = 1 + (j2b-j2a) / 2
            if (nj > njlargest) njlargest = nj
        enddo
    end subroutine paschen_size

! ---------------------------------------------------------
! Calculates the eigenvalues and eigenvectors of the Paschen-Back matrix
! INPUT:
!     l2 = 2*L
!     is2 = 2*S
!     e0 = a vector containing the energy in cm^-1 of the level J (Jmin <= J <= Jmax) organized in terms of the J2 value
!          ex. e0(3) is the energy of the J=3/2 level. (Some elements remain undefined)
!     b = magnetic field in gauss
! OUTPUT:
!     njlev = number of levels for each m2
!     e = a vector containing the eigenvalues of the matrix. It is organized as e(m2,jsmall), where m2 is 2*M and
!         jsmall is a quantum number which takes values between 1 and the number of J compatible with M
!     c = eigenvectors, organized as c(m2,jsmall,J2)
! ---------------------------------------------------------
    subroutine paschen(l2,is2,e0,B,njlev,e,c,j2m,njl)
    integer :: l2, is2, j2m, njl
    integer :: njlev(-j2m:j2m)
    real(kind=8) :: e(-j2m:j2m,njl), c(-j2m:j2m,njl,0:j2m)
    real(kind=8) :: b, e0(0:jlimit2), bb
    real(kind=8), allocatable :: d(:), ud(:), z(:,:)
    integer :: m2, j2max, j2min, j2a, j2b, nj, j2vero, j, jp, jp2vero, njlargest, i, jsmall, jaux, j2
    real(kind=8) :: x1, x2, x3, x4

        bb = PE / (4.d0*PI*PME*PC**2) * B
        j2min = abs(l2-is2)
        j2max = l2 + is2

        do m2 = -j2max, j2max, 2

! Build the matrix which corresponds to the value of M
            j2a = abs(m2)
            if (j2a < j2min) j2a = j2min
            j2b = j2max
            nj = 1 + (j2b-j2a) / 2
            njlev(m2) = nj

            allocate(d(nj))
            d = 0.d0
            allocate(ud(nj))
            ud = 0.d0
            allocate(z(nj,nj))

! First the diagonal part
            do j = 1, nj
                j2vero = j2a+2*(j-1)
            d(j) = e0(j2vero)
            x1 = 1.d0
            if (mod(2*j2vero+l2+is2+m2,4) /= 0) x1 = -1.d0
            x2 = dfloat(j2vero+1)*dsqrt(dfloat(is2*(is2+2)*(is2+1))/4.d0)
            x3 = w3js(j2vero,j2vero,2,-m2,m2,0)
            x4 = w6js(j2vero,j2vero,2,is2,is2,l2)
            d(j) = d(j) + bb * (dfloat(m2)/2.d0+x1*x2*x3*x4)
            enddo

! If we use the Pashen-Back regime
            if (use_paschen_back == 1) then
! Then the upper diagonal (only if the matrix is at least 2x2)
                if (nj /= 1) then
                    do jp = 2, nj
                    jp2vero = j2a+2*(jp-1)
                    j2vero = jp2vero-2
                    x1 = 1.d0
                    if (mod(j2vero+jp2vero+l2+is2+m2,4) /= 0) x1 = -1.d0
                    x2 = dsqrt(dfloat((j2vero+1)*(jp2vero+1)*is2*(is2+2)*(is2+1))/4.d0)
                    x3 = w3js(j2vero,jp2vero,2,-m2,m2,0)
                    x4 = w6js(j2vero,jp2vero,2,is2,is2,l2)
                    ud(jp) = bb*x1*x2*x3*x4
                    enddo
                endif
            endif

! Initializes the matrix z with the eigenvectors
            z = 0.d0
            do i = 1, nj
                z(i,i) = 1.d0
            enddo

! Diagonalize the matrix
            call tqli(d,ud,nj,nj,z)

            do jsmall = 1, nj
                e(m2,jsmall) = d(jsmall)
                do jaux = 1, nj
                    j2 = j2a + 2*(jaux-1)
                    c(m2,jsmall,j2) = z(jaux,jsmall)
                enddo
            enddo

            deallocate(d)
            deallocate(ud)
            deallocate(z)

        enddo

    end subroutine paschen

! ---------------------------------------------------------
! Diagonalizes a tridiagonal matrix
! ---------------------------------------------------------
    subroutine tqli(d,e,n,np,z)
    integer :: n, np, i, l, m, iter, k
    real(kind=8) :: d(np),e(np),z(np,np), g, r, s, c, p, f, b, dd

        if (n.gt.1) then
      do 11 i=2,n
      e(i-1)=e(i)
 11   continue
      e(n)=0.d0
      do 15 l=1,n
      iter=0
 1    do 12 m=l,n-1
      dd=dabs(d(m))+dabs(d(m+1))
      if(dabs(e(m))+dd.eq.dd) go to 2
 12   continue
      m=n
 2    if(m.ne.l) then
      if(iter.eq.30) then
        print *, 'too many iterations'
        stop
      endif
      iter=iter+1
      g=(d(l+1)-d(l))/(2.d0*e(l))
      r=dsqrt(g**2+1.d0)
      g=d(m)-d(l)+e(l)/(g+dsign(r,g))
      s=1.d0
      c=1.d0
      p=0.d0
      do 14 i=m-1,l,-1
      f=s*e(i)
      b=c*e(i)
      if(dabs(f).ge.dabs(g)) then
      c=g/f
      r=dsqrt(c**2+1.d0)
      e(i+1)=f*r
      s=1.d0/r
      c=c*s
      else
      s=f/g
      r=dsqrt(s**2+1.d0)
      e(i+1)=g*r
      c=1.d0/r
      s=s*c
      endif
      g=d(i+1)-p
      r=(d(i)-g)*s+2.d0*c*b
      p=s*r
      d(i+1)=g+p
      g=c*r-b
      do 13 k=1,n
      f=z(k,i+1)
      z(k,i+1)=s*z(k,i)+c*f
      z(k,i)=c*z(k,i)-s*f
 13   continue
 14   continue
      d(l)=d(l)-p
      e(l)=g
      e(m)=0.d0
      go to 1
      endif
 15   continue
      endif
      return
      end subroutine tqli

! ---------------------------------------------------------
! Sets the imaginary part of a complex to a given number
! ---------------------------------------------------------
        subroutine set_imaginary(A,b)
        complex(kind=8) :: A
        real(kind=8) :: b
            A = cmplx(real(A),b)
        end subroutine set_imaginary

! ---------------------------------------------------------
! Sets the imaginary part of a complex to a given number
! ---------------------------------------------------------
        subroutine set_real(A,b)
        complex(kind=8) :: A
        real(kind=8) :: b
            A = cmplx(b,aimag(A))
        end subroutine set_real

!--------------------------------------------------------------
! Dawson's integral
!--------------------------------------------------------------
    function dawson(dv)
    real(kind=8) :: dv(:)
    real(kind=8) :: dawson(size(dv)), c(6), x
    real(kind=8), parameter :: H=0.4, A1=2./3., A2=0.4, A3=2./7.
    integer :: i, n, j, n0
    real(kind=8) :: xx, xp, e1, e2, d1, d2, sum, x2

        n = size(dv)
        do i = 1, 6
            c(i)=exp(-((2.*float(i)-1.)*H)**2)
        enddo

        do i = 1, n
            if (abs(dv(i)) < 0.2) then
                x = dv(i)
                x2 = dv(i)**2
                dawson(i) = x*(1.-A1*x2*(1.-A2*x2*(1.-A3*x2)))
            else
                x = dv(i)
                xx = abs(dv(i))
                n0 = 2*nint(0.5*xx/H)
                xp = xx-float(n0)*H
                e1 = exp(2.*xp*H)
                e2 = e1**2
                d1 = float(n0+1)
                d2 = d1-2.
                sum = 0.
                do j = 1,6
                  sum = sum + c(j)*(e1/d1+1./(d2*e1))
                  d1 = d1+2.
                  d2 = d2-2.
                  e1 = e2*e1
                enddo
                dawson(i) = 0.5641895835*sign(exp(-xp**2),x)*sum
            endif
        enddo

    end function dawson

!--------------------------------------------------------------
! Generates Voigt and anomalous dispersion profiles using a different damping for each frequency
! point
! See Humlicek (1982) JQSRT 27, 437
!--------------------------------------------------------------
    function profile(da, dv)
    real(kind=8) :: da
    real(kind=8) :: dv(:)
    complex(kind=8) :: profile(size(dv))
    complex(kind=8) :: w4, z, t, u, v4
    real(kind=8) :: s
    integer :: i, n

        n = size(dv)

! For small a, evaluate the power expansion up to second order (Landi degl'Innocenti & Landolfi 2004, p. 168)
        if (da < 1.d-3) then
            profile = cmplx(exp(-dv**2) + 2.d0*da/sqrt(PI)*(2*dv*dawson(dv)-1.d0), 2.d0*dawson(dv) / sqrt(PI) - 2.d0*da*dv*exp(-dv**2))
            return
        endif
        do i = 1, n
! There is a problem for very small dampings. We force it to be 0 using a threshold
            z = cmplx(dv(i), da)
            t = cmplx(da, -dv(i))
            s = dabs(dv(i)) + da
            u = t*t

            if (s >= 15.d0) then
                w4 = t * 0.5641896d0 / (0.5d0+u)
            elseif (s >= 5.5) then
                w4 = t*(1.410474d0+u*0.5641896d0)/(0.75d0+u*(3.d0+u))
            elseif (da >= 0.195d0*dabs(dv(i))-0.176d0) then
                w4 = (16.4955d0+t*(20.20933d0+t*(11.96482d0+t*(3.778987d0+t*0.5642236d0)))) / &
                    (16.4955d0+t*(38.82363d0+t*(39.27121d0+t*(21.69274d0+t*(6.699398d0+t)))))
            else
                w4 = t*(36183.31d0-u*(3321.9905d0-u*(1540.787d0-u*(219.0313d0-u*(35.76683d0-&
                    u*(1.320522d0-u*0.56419d0))))))
                v4 = (32066.6d0-u*(24322.84d0-u*(9022.228d0-u*(2186.181d0-u*(364.2191d0-&
                    u*(61.57037d0-u*(1.841439d0-u)))))))
                w4 = exp(u) - w4/v4
            endif
            profile(i) = w4
        enddo

    end function profile

! ---------------------------------------------------------
! Given xa(:) and ya(:) which tabulate a function, returns the interpolation using
! linear interpolation of vector x(:) in y(:)
! ---------------------------------------------------------
    subroutine lin_interpol(xa,ya,x,y)
    real*8, INTENT(IN) :: xa(:), ya(:), x(:)
    real*8, INTENT(INOUT) :: y(:)
    integer :: i, n
    integer :: locat(1), loc

        n = size(x)

        do i = 1, n
            locat = minloc(dabs(xa-x(i)))
            loc = locat(1)
            if (loc == 1) then
                y(i) = ya(loc)
            else
                y(i) = (ya(loc)-ya(loc-1))/(xa(loc)-xa(loc-1)) * (x(i)-xa(loc-1)) + ya(loc-1)
            endif
        enddo

    end subroutine lin_interpol

! ---------------------------------------------------------
! Given etaI, etaQ, etaU, etaV, rhoQ, rhoU and rhoV, fill the absorption matrix
! ---------------------------------------------------------
    subroutine fill_absorption_matrix(matrix,etaI,etaQ,etaU,etaV,rhoQ,rhoU,rhoV)
    real(kind=8) :: matrix(4,4), etaI, etaQ, etaU, etaV, rhoQ, rhoU, rhoV

        matrix(1,1) = etaI
        matrix(2,2) = etaI
        matrix(3,3) = etaI
        matrix(4,4) = etaI
        matrix(1,2) = etaQ
        matrix(2,1) = etaQ
        matrix(1,3) = etaU
        matrix(3,1) = etaU
        matrix(1,4) = etaV
        matrix(4,1) = etaV
        matrix(2,3) = rhoV
        matrix(3,2) = -rhoV
        matrix(2,4) = -rhoU
        matrix(4,2) = rhoU
        matrix(3,4) = rhoQ
        matrix(4,3) = -rhoQ

    end subroutine fill_absorption_matrix

!--------------------------------------------------------------
! Inversion of a 4x4 matrix
!--------------------------------------------------------------
    subroutine invert(a)
    real*8 :: a(4,4)
    real*8 :: b(4,4), det, maxim, fabsmax
    ! First some tests of singularity
        b = dabs(a)
        maxim = maxval(b)
        fabsmax = 1.d0 / maxim
        if (maxim == 0.d0) then
            print *, 'Singularity in the inversion'
!           stop
        endif

        a = a * fabsmax

    b(1,1) = a(2,2) * a(3,3) * a(4,4) + a(2,3) * a(3,4) * a(4,2)&
        + a(2,4) * a(3,2) * a(4,3) - a(2,2) * a(3,4) * a(4,3)&
        - a(2,3) * a(3,2) * a(4,4) - a(2,4) * a(3,3) * a(4,2)
    b(2,1) = a(2,3) * a(3,1) * a(4,4) + a(2,4) * a(3,3) * a(4,1)&
        + a(2,1) * a(3,4) * a(4,3) - a(2,3) * a(3,4) * a(4,1)&
        - a(2,4) * a(3,1) * a(4,3) - a(2,1) * a(3,3) * a(4,4)
    b(3,1) = a(2,4) * a(3,1) * a(4,2) + a(2,1) * a(3,2) * a(4,4)&
        + a(2,2) * a(3,4) * a(4,1) - a(2,4) * a(3,2) * a(4,1)&
        - a(2,1) * a(3,4) * a(4,2) - a(2,2) * a(3,1) * a(4,4)
    b(4,1) = a(2,1) * a(3,3) * a(4,2) + a(2,2) * a(3,1) * a(4,3)&
        + a(2,3) * a(3,2) * a(4,1) - a(2,1) * a(3,2) * a(4,3)&
        - a(2,2) * a(3,3) * a(4,1) - a(2,3) * a(3,1) * a(4,2)
    b(1,2) = a(3,2) * a(4,4) * a(1,3) + a(3,3) * a(4,2) * a(1,4)&
        + a(3,4) * a(4,3) * a(1,2) - a(3,2) * a(4,3) * a(1,4)&
        - a(3,3) * a(4,4) * a(1,2) - a(3,4) * a(4,2) * a(1,3)
    b(2,2) = a(3,3) * a(4,4) * a(1,1) + a(3,4) * a(4,1) * a(1,3)&
        + a(3,1) * a(4,3) * a(1,4) - a(3,3) * a(4,1) * a(1,4)&
        - a(3,4) * a(4,3) * a(1,1) - a(3,1) * a(4,4) * a(1,3)
    b(3,2) = a(3,4) * a(4,2) * a(1,1) + a(3,1) * a(4,4) * a(1,2)&
        + a(3,2) * a(4,1) * a(1,4) - a(3,4) * a(4,1) * a(1,2)&
        - a(3,1) * a(4,2) * a(1,4) - a(3,2) * a(4,4) * a(1,1)
    b(4,2) = a(3,1) * a(4,2) * a(1,3) + a(3,2) * a(4,3) * a(1,1)&
        + a(3,3) * a(4,1) * a(1,2) - a(3,1) * a(4,3) * a(1,2)&
        - a(3,2) * a(4,1) * a(1,3) - a(3,3) * a(4,2) * a(1,1)
    b(1,3) = a(4,2) * a(1,3) * a(2,4) + a(4,3) * a(1,4) * a(2,2)&
        + a(4,4) * a(1,2) * a(2,3) - a(4,2) * a(1,4) * a(2,3)&
        - a(4,3) * a(1,2) * a(2,4) - a(4,4) * a(1,3) * a(2,2)
    b(2,3) = a(4,3) * a(1,1) * a(2,4) + a(4,4) * a(1,3) * a(2,1)&
        + a(4,1) * a(1,4) * a(2,3) - a(4,3) * a(1,4) * a(2,1)&
        - a(4,4) * a(1,1) * a(2,3) - a(4,1) * a(1,3) * a(2,4)
    b(3,3) = a(4,4) * a(1,1) * a(2,2) + a(4,1) * a(1,2) * a(2,4)&
        + a(4,2) * a(1,4) * a(2,1) - a(4,4) * a(1,2) * a(2,1)&
        - a(4,1) * a(1,4) * a(2,2) - a(4,2) * a(1,1) * a(2,4)
    b(4,3) = a(4,1) * a(1,3) * a(2,2) + a(4,2) * a(1,1) * a(2,3)&
        + a(4,3) * a(1,2) * a(2,1) - a(4,1) * a(1,2) * a(2,3)&
        - a(4,2) * a(1,3) * a(2,1) - a(4,3) * a(1,1) * a(2,2)
    b(1,4) = a(1,2) * a(2,4) * a(3,3) + a(1,3) * a(2,2) * a(3,4)&
        + a(1,4) * a(2,3) * a(3,2) - a(1,2) * a(2,3) * a(3,4)&
        - a(1,3) * a(2,4) * a(3,2) - a(1,4) * a(2,2) * a(3,3)
    b(2,4) = a(1,3) * a(2,4) * a(3,1) + a(1,4) * a(2,1) * a(3,3)&
        + a(1,1) * a(2,3) * a(3,4) - a(1,3) * a(2,1) * a(3,4)&
        - a(1,4) * a(2,3) * a(3,1) - a(1,1) * a(2,4) * a(3,3)
    b(3,4) = a(1,4) * a(2,2) * a(3,1) + a(1,1) * a(2,4) * a(3,2)&
        + a(1,2) * a(2,1) * a(3,4) - a(1,4) * a(2,1) * a(3,2)&
        - a(1,1) * a(2,2) * a(3,4) - a(1,2) * a(2,4) * a(3,1)
    b(4,4) = a(1,1) * a(2,2) * a(3,3) + a(1,2) * a(2,3) * a(3,1)&
        + a(1,3) * a(2,1) * a(3,2) - a(1,1) * a(2,3) * a(3,2)&
        - a(1,2) * a(2,1) * a(3,3) - a(1,3) * a(2,2) * a(3,1)

        det = a(1,1) * b(1,1) + a(1,2) * b(2,1) + a(1,3) * b(3,1) + a(1,4) * b(4,1)

        a = b * (fabsmax / det)

    end subroutine invert

!--------------------------------------------------------------
! Returns in b the evolution operator if the propagation matrix is constant
! given by exp(-A*t). It uses Eqs. A5.20 of Landi Degl'Innocenti & Landolfi 2004
!--------------------------------------------------------------
    subroutine evol_operator(a,t,b)
    real(kind=8) :: a(4,4), t
    real(kind=8) :: b(4,4), det, maxim, fabsmax, w(3), y(3), w_y_scalar, sigma
    real(kind=8) :: Lambda_plus, Lambda_minus, tt, Theta, w_mod_sq, y_mod_sq, factor1, factor2, factor3, factor4, w0, temp1, temp2
    real(kind=8), dimension(4,4) :: M1, M2, M3, M4
    integer :: i

        w0 = a(1,1)

        w(1) = a(1,2)
        w(2) = a(1,3)
        w(3) = a(1,4)
        w_mod_sq = sum(w*w)

        y(1) = a(3,4)
        y(2) = a(4,2)
        y(3) = a(2,3)
        y_mod_sq = sum(y*y)

        w_y_scalar = sum(w*y)
        sigma = 1.d0
        if (w_y_scalar < 0.d0) sigma = -1.d0

! Eigenvalues
        temp1 = sqrt((w_mod_sq - y_mod_sq)**2 / 4.d0 + w_y_scalar**2)
        temp2 = (w_mod_sq - y_mod_sq) / 2.d0
        if (temp1+temp2 < 0.d0) then
            Lambda_plus = 0.d0
        else
            Lambda_plus = sqrt(temp1 + temp2)
        endif
        if (temp1-temp2 < 0.d0) then
            Lambda_minus = 0.d0
        else
            Lambda_minus = sqrt(temp1 - temp2)
        endif

        Theta = 2.d0 * temp1
        tt = (w_mod_sq + y_mod_sq) / 2.d0

        M1 = 0.d0
        M2 = 0.d0
        M3 = 0.d0
        M4 = 0.d0

! M1
        do i = 1, 4
            M1(i,i) = 1.d0
        enddo

! M2
        M2(1,2) = Lambda_minus * w(1) - sigma * Lambda_plus * y(1)
        M2(1,3) = Lambda_minus * w(2) - sigma * Lambda_plus * y(2)
        M2(1,4) = Lambda_minus * w(3) - sigma * Lambda_plus * y(3)
        M2(2,1) = M2(1,2)
        M2(2,3) = sigma * Lambda_plus * w(3) + Lambda_minus * y(3)
        M2(2,4) = -sigma * Lambda_plus * w(2) - Lambda_minus * y(2)
        M2(3,1) = M2(1,3)
        M2(3,2) = -M2(2,3)
        M2(3,4) = sigma * Lambda_plus * w(1) + Lambda_minus * y(1)
        M2(4,1) = M2(1,4)
        M2(4,2) = -M2(2,4)
        M2(4,3) = -M2(3,4)

! M3
        M3(1,2) = Lambda_plus * w(1) + sigma * Lambda_minus * y(1)
        M3(1,3) = Lambda_plus * w(2) + sigma * Lambda_minus * y(2)
        M3(1,4) = Lambda_plus * w(3) + sigma * Lambda_minus * y(3)
        M3(2,1) = M3(1,2)
        M3(2,3) = -sigma * Lambda_minus * w(3) + Lambda_plus * y(3)
        M3(2,4) = sigma * Lambda_minus * w(2) - Lambda_plus * y(2)
        M3(3,1) = M3(1,3)
        M3(3,2) = -M3(2,3)
        M3(3,4) = -sigma * Lambda_minus * w(1) + Lambda_plus * y(1)
        M3(4,1) = M3(1,4)
        M3(4,2) = -M3(2,4)
        M3(4,3) = -M3(3,4)

! M4
        M4(1,1) = tt
        M4(1,2) = w(3)*y(2) - w(2)*y(3)
        M4(1,3) = w(1)*y(3) - w(3)*y(1)
        M4(1,4) = w(2)*y(1) - w(1)*y(2)
        M4(2,1) = -M4(1,2)
        M4(2,2) = w(1)**2 + y(1)**2 - tt
        M4(2,3) = w(1)*w(2) + y(1)*y(2)
        M4(2,4) = w(3)*w(1) + y(3)*y(1)
        M4(3,1) = -M4(1,3)
        M4(3,2) = M4(2,3)
        M4(3,3) = w(2)**2 + y(2)**2 - tt
        M4(3,4) = w(2)*w(3) + y(2)*y(3)
        M4(4,1) = -M4(1,4)
        M4(4,2) = M4(2,4)
        M4(4,3) = M4(3,4)
        M4(4,4) = w(3)**2 + y(3)**2 - tt

        M2 = M2 / Theta
        M3 = M3 / Theta
        M4 = 2.d0 * M4 / Theta

        factor1 = 0.5d0*(cosh(t*Lambda_plus) + cos(t*Lambda_minus))
        factor2 = sin(t*Lambda_minus)
        factor3 = sinh(t*Lambda_plus)
        factor4 = 0.5d0*(cosh(t*Lambda_plus) - cos(t*Lambda_minus))

        b = factor1*M1 - factor2*M2 - factor3*M3 + factor4*M4
        b = exp(-t*w0) * b

    end subroutine evol_operator

! ---------------------------------------------------------
! Return the input array but shifted by a sub-pixel amount
! Note that it works only for any length of series which has no prime factor greater than 23
! ---------------------------------------------------------
        function fft_shift(x, sh)
        real(kind=8) :: x(:), fft_shift(size(x)), sh
        complex(kind=8) :: k(size(x)), ff(size(x))
        integer :: nx, i, n21

            nx = size(x)

            do i = 1, nx
            k(i) = i-1
         enddo
         n21 = nx/2+1
         do i = n21+1, nx
            k(i) = n21-nx+(i-1-n21)
         enddo

         k = 2.d0*PI*k/(1.d0*nx)
         k = k * cmplx(0.d0,1.d0)

         ff = x

         ff = fft(ff)

         fft_shift = real(fft(ff * exp(k*sh), inv=.TRUE.))

        end function fft_shift

        function erf(x)
        real(kind=8) :: erf, x, dumerfc, t, z

            z = abs(x)
            t = 1.0 / ( 1.0 + 0.5 * z )

            dumerfc =       t * exp(-z * z - 1.26551223 + t *       &
             ( 1.00002368 + t * ( 0.37409196 + t *      &
             ( 0.09678418 + t * (-0.18628806 + t *      &
             ( 0.27886807 + t * (-1.13520398 + t *      &
             ( 1.48851587 + t * (-0.82215223 + t * 0.17087277 )))))))))

            if ( x.lt.0.0 ) dumerfc = 2.0 - dumerfc

            erf = 1.0 - dumerfc

        end function erf

! ---------------------------------------------------------
! Solve a one-dimensional equality using the secant method
! ---------------------------------------------------------
    function confidenceLevel(x, nu, P)
    real(kind=8) :: confidenceLevel, x, nu, P
        confidenceLevel = gammq(0.5*nu,0.5*x) + P - 1.d0
        return
    end function confidenceLevel

! ---------------------------------------------------------
! Solve a one-dimensional equality using the secant method
! ---------------------------------------------------------
    function secantConfidenceLevel(nu,P)
    real(kind=8) :: func, x1, x2, xacc, fl, f, secantConfidenceLevel, xl, swap, dx, nu,P
    integer :: j
    integer, parameter :: maxit=30
        xacc = 1e-3
        x1 = nu-0.1
        x2 = nu+14.d0
        fl=confidenceLevel(x1,nu,P)
        f=confidenceLevel(x2,nu,P)
      if(abs(fl).lt.abs(f))then
        secantConfidenceLevel=x1
        xl=x2
        swap=fl
        fl=f
        f=swap
      else
        xl=x1
        secantConfidenceLevel=x2
      endif
      do j=1,maxit
        dx=(xl-secantConfidenceLevel)*f/(f-fl)
        xl=secantConfidenceLevel
        fl=f
        secantConfidenceLevel=secantConfidenceLevel+dx
        f=confidenceLevel(secantConfidenceLevel,nu,P)
        if(abs(dx).lt.xacc.or.f.eq.0.)return
      enddo
      print *, 'rtsec exceed maximum iterations'
      end function secantConfidenceLevel

! ---------------------------------------------------------
! Return the log of the gamma function
! ---------------------------------------------------------
      function gammln(xx)
      real(kind=8) :: cof(6),stp,half,one,fpf,x,tmp,ser,gammln, dx, xx
      data cof,stp/76.18009173d0,-86.50532033d0,24.01409822d0,-1.231739516d0,.120858003d-2,-.536382d-5,2.50662827465d0/
      data half,one,fpf/0.5d0,1.0d0,5.5d0/
      integer :: j
      x=xx-one
      tmp=x+fpf
      tmp=(x+half)*log(tmp)-tmp
      ser=one
      do j=1,6
        x=x+one
        ser=ser+cof(j)/x
      enddo
      gammln=tmp+log(stp*ser)
      return
      end function gammln

! ---------------------------------------------------------
!
! ---------------------------------------------------------
     subroutine gcf(gammcf,a,x,gln)
     real(kind=8) :: gammcf, a, x, gln, gold, a0, a1, b0, b1, fac, an, ana, anf, g
     real(kind=8), parameter :: eps=3e-7
     integer, parameter :: itmax=200
     integer :: n

      gln=gammln(a)
      gold=0.
      a0=1.
      a1=x
      b0=0.
      b1=1.
      fac=1.
      do n=1,itmax
        an=float(n)
        ana=an-a
        a0=(a1+a0*ana)*fac
        b0=(b1+b0*ana)*fac
        anf=an*fac
        a1=x*a0+anf*a1
        b1=x*b0+anf*b1
        if(a1.ne.0.)then
          fac=1./a1
          g=b1*fac
          if(abs((g-gold)/g).lt.eps) then
            gammcf=exp(-x+a*log(x)-gln)*g
            return
          endif
          gold=g
        endif
      enddo
        print *, 'a too large, itmax too small'
      end subroutine gcf

      subroutine gser(gamser,a,x,gln)
      real(kind=8) :: gamser, a, x, gln, ap, sum, del
      real(kind=8), parameter :: eps=3e-7
      integer, parameter :: itmax=200
      integer :: n

      gln=gammln(a)
      if(x.le.0.)then
        gamser=0.
        return
      endif
      ap=a
      sum=1./a
      del=sum
      do n=1,itmax
        ap=ap+1.
        del=del*x/ap
        sum=sum+del
        if(abs(del).lt.abs(sum)*eps) then
            gamser=sum*exp(-x+a*log(x)-gln)
            return
        endif
      enddo
      print *, 'a too large, itmax too small'
      end subroutine gser

    function gammq(a,x)
    real(kind=8) :: gammq, a, x, gln, gamser, gammcf
      if(x.lt.0..or.a.le.0.) then
        print *, x, a
        stop
    endif
      if(x.lt.a+1.)then
        call gser(gamser,a,x,gln)
        gammq=1.-gamser
      else
        call gcf(gammcf,a,x,gln)
        gammq=gammcf
      endif
      return
      end function gammq

end module maths


      subroutine root(a,b,c,x1,x2)
c
c     + + + PURPOSE + + +
c     Finds roots for the equation y=a*x**2+b*x+c
c
c     Called from subroutine XCRIT.
c     Author(s): G. Foster, M. Nearing
c     Reference in User Guide:
c
c     Changes:
c
c     Version: This module recoded from WEPP version 90.92.
c     Date recoded: 01/08/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real a, b
      double precision c, x1, x2
c
c     a    -
c     b    -
c     c    -
c     x1   -
c     x2   -
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     + + + LOCAL VARIABLES + + +
      double precision cc, part
      real b1, tmpvr1
c     cc     -
c     part   -
c
c     + + + END SPECIFICATIONS + + +
c
      b1 = -b
      tmpvr1 = 2.0 * a
      cc = -c
      part = sqrt(b**2-4.0*a*cc)
      x1 = (b1-part) / tmpvr1
      x2 = (b1+part) / tmpvr1
c
      if (x1.gt.x2) then
        part = x2
        x2 = x1
        x1 = part
      end if
c
      return
      end


	SUBROUTINE SSIZE
     .	(SALPHA,SBETA,SR,SP0,M,XSPSI,XN,ERR)
	IMPLICIT NONE
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Determine case patient sample size N
C  Arguments:
C
C   INPUT:
C
C   i	SALPHA	(REAL)
C	Type I error probability
C   i	SBETA	(REAL)
C	Type II error probability
C   i	SR	(REAL)
C	Correlation coefficient
C   i	SP0	(REAL)
C	Probability of exposure in control group
C   i	M	(Integer)
C	Number of matched controls per case patient
C   i	XSPSI	(REAL)
C	Odds ratio
C
C   OUTPUT:
C
C   o	XN	(Real)
C	Number of case patients
C   o	ERR	(Integer)
C  Notes:
C   .	This routine was written by Dale Plummer.
C   .	Designed by Dr. William Dupont.
C   .   The LaTeX notation given in the comments is from:
C       Dupont, Biometrics 1988;44:1157-68.
C
C-Declarations----------------------------------------------------------
C
	INTEGER M,ERR
	REAL XN
	REAL SALPHA,SBETA,SR,SP0,XSPSI
        DOUBLE PRECISION ALPHA,BETA,R,P0,PSI
	DOUBLE PRECISION ZALPHA,ZBETA
	REAL ZCRVALUE
	DOUBLE PRECISION RM,RN
	DOUBLE PRECISION SQV1,SQVPSI
	DOUBLE PRECISION NM

	DOUBLE PRECISION MEAN,VAR,PSI_VALUE
	DOUBLE PRECISION E1, V1, EPSI, VPSI
C
C Code:
C
C    Assume a successful run.
C
	ERR=0
C
C    Copy arguments M and N to floating point local storage.
C
	RM=DBLE(M)
	RN=DBLE(XN)
C
C    Copy single precision arguments to double precision internal
C    representation.
C
C    ALPHA = \alpha
C    BETA = \beta
C    P0 = p_0
C    PSI = \psi
C    ZALPHA = z_{\alpha/2}
C    ZBETA = z_{\beta}
C
	ALPHA=DBLE(SALPHA)
	BETA=DBLE(SBETA)
	R=DBLE(SR)
	P0=DBLE(SP0)
	PSI=DBLE(XSPSI)
	ZALPHA=DBLE(ZCRVALUE(SALPHA/2.))
	ZBETA=DBLE(ZCRVALUE(SBETA))

	PSI_VALUE=1
	CALL MEANANDVAR(P0,R,M,RM,PSI_VALUE,MEAN,VAR)
C
C    E1 = e_1 in equation (7)
C    V1 = v_1 in equation (7)
C
	E1 = MEAN
	V1 = VAR

	PSI_VALUE=PSI
	CALL MEANANDVAR(P0,R,M,RM,PSI_VALUE,MEAN,VAR)
C
C    EPSI = e_{\PSI} in equation (7)
C    VPSI = v_{\PSI} in equation (7)
C
	EPSI = MEAN
	VPSI = VAR

C ----------------------------------------------------

	SQV1=SQRT(V1)
	SQVPSI=SQRT(VPSI)
C
C    NM is equation (7) in Dupont (Biometrics 1988).
C
	NM=(ZBETA*SQVPSI+ZALPHA*SQV1)**2/(EPSI-E1)**2
	XN=NM

	RETURN
	END

C ======================================================

	SUBROUTINE MEANANDVAR(P0,R,M,RM,PSI,MEAN,VAR)
	IMPLICIT NONE
C
C  When the alternaitve hypothesis is true this
C  routine calculates e_{\psi} and v_{\psi}
C
C  When the null hypothesis is true (\psi=1)
C  then it calculates e_1 and v_1
C
	DOUBLE PRECISION P0,R,RM,PSI
	INTEGER M
	DOUBLE PRECISION MEAN,VAR

	INTEGER IMPOSS,I,IM
	DOUBLE PRECISION P1,Q1,Q0,P01,P00,Q01,Q00,C1,C2,T(1000)

	INTEGER ERR
	REAL FM, XN
C
C Code:
C
C    Calculate P1 = p_1.
C
	CALL PONE(P0,PSI,R,P1,IMPOSS)
	IF (IMPOSS.EQ.1) THEN
	    ERR=1
	    FM=0.
	    XN=0.
	    RETURN
	END IF
C
C    Q1=q_1 Probability that a case patient is not exposed.
C
	Q1=1.-P1
C
C    Q0=q_0 Probability that a control is not exposed.
C
	Q0=1.-P0
C
C    P01 = p_{o+}
C    Probability that a control is exposed given that his matched case
C    is exposed.
C
	P01=P0+R*SQRT(Q1*P0*Q0/P1)
C
C    P00 = p_{o-}
C    Probability that a control is exposed given that his matched case
C    is NOT exposed.
C
	P00=P0-R*SQRT(P1*P0*Q0/Q1)
	Q01=1.-P01
	Q00=1.-P00
	IM=M
1	CONTINUE
	C1=1.
	C2=RM
C
C  The index I is denoted "m" in Dupont 1988.
C  T(I) = T(m) = t_m is the probability of
C  observing m exposed subjects among a case
C  and his M matched controls.
C
	DO 10 I=1,IM
	    T(I)=P1*C1*P01**(I-1)*Q01**(IM-I+1) + Q1*C2*P00**I*Q00**(IM-I)
	    C1=C2
	    C2=C2*(RM-DBLE(I))/(DBLE(I)+1.)
10	CONTINUE

	MEAN=0D0
	DO 40 I=1,IM
	    MEAN=MEAN+(DBLE(I)*T(I)*PSI/(DBLE(I)*PSI+RM-DBLE(I)+1.))
40	CONTINUE

	VAR=0D0
	DO 50 I=1,IM
	    VAR=VAR+
     .	(DBLE(I)*T(I)*PSI*(RM-DBLE(I)+1.)/(DBLE(I)*PSI+RM-DBLE(I)+1)**2)
50	CONTINUE

	RETURN
	END


*> \brief \b DROTG
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DROTG(DA,DB,C,S)
*
*       .. Scalar Arguments ..
*       DOUBLE PRECISION C,DA,DB,S
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    DROTG construct givens plane rotation.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] DA
*> \verbatim
*>          DA is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] DB
*> \verbatim
*>          DB is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*>          C is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is DOUBLE PRECISION
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>     jack dongarra, linpack, 3/11/78.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE DROTG(DA,DB,C,S)
*
*  -- Reference BLAS level1 routine (version 3.8.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2017
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION C,DA,DB,S
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION R,ROE,SCALE,Z
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC DABS,DSIGN,DSQRT
*     ..
      ROE = DB
      IF (DABS(DA).GT.DABS(DB)) ROE = DA
      SCALE = DABS(DA) + DABS(DB)
      IF (SCALE.EQ.0.0d0) THEN
         C = 1.0d0
         S = 0.0d0
         R = 0.0d0
         Z = 0.0d0
      ELSE
         R = SCALE*DSQRT((DA/SCALE)**2+ (DB/SCALE)**2)
         R = DSIGN(1.0d0,ROE)*R
         C = DA/R
         S = DB/R
         Z = 1.0d0
         IF (DABS(DA).GT.DABS(DB)) Z = S
         IF (DABS(DB).GE.DABS(DA) .AND. C.NE.0.0d0) Z = 1.0d0/C
      END IF
      DA = R
      DB = Z
      RETURN
      END


!***********************************************************************
! This file is part of project ISFRC.                                  *
! ISFRC is an Integrated Simulation code for Field-Reversed            *
! Configuration.                                                       *
!                                                                      *
! Developers:                                                          *
! Shuying SUN, Yang LI, Huasheng XIE, ...                              *
!                                                                      *
! ENN Sci. & Tech. Development Coorporation, 2008-2019.                *
! (c) All rights reserved.                                             *
!***********************************************************************

subroutine comelp ( hk2, ck, ce )

!*****************************************************************************80
!
!! COMELP computes complete elliptic integrals K(k) and E(k).
!
!  Licensing:
!
!    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!    they give permission to incorporate this routine into a user program
!    provided that the copyright is acknowledged.
!
!  Modified:
!
!    07 July 2012
!
!  Author:
!
!    Shanjie Zhang, Jianming Jin
!
!  Reference:
!
!    Shanjie Zhang, Jianming Jin,
!    Computation of Special Functions,
!    Wiley, 1996,
!    ISBN: 0-471-11963-6,
!    LC: QA351.C45.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) HK, the modulus.  0 <= HK <= 1.
!
!    Output, real ( kind = 8 ) CK, CE, the values of K(HK) and E(HK).
!
  implicit none

  real ( kind = 8 ) ae
  real ( kind = 8 ) ak
  real ( kind = 8 ) be
  real ( kind = 8 ) bk
  real ( kind = 8 ) ce
  real ( kind = 8 ) ck
  real ( kind = 8 ) hk2 ! hk2=hk*hk
  real ( kind = 8 ) pk

  !pk = 1.0D+00 - hk * hk
  pk = 1.0D+00 - hk2

  if ( hk2 == 1.0D+00 ) then

    ck = 1.0D+300
    ce = 1.0D+00

  else

    ak = ((( &
        0.01451196212D+00   * pk &
      + 0.03742563713D+00 ) * pk &
      + 0.03590092383D+00 ) * pk &
      + 0.09666344259D+00 ) * pk &
      + 1.38629436112D+00

    bk = ((( &
        0.00441787012D+00   * pk &
      + 0.03328355346D+00 ) * pk &
      + 0.06880248576D+00 ) * pk &
      + 0.12498593597D+00 ) * pk &
      + 0.5D+00

    ck = ak - bk * log ( pk )

    ae = ((( &
        0.01736506451D+00   * pk &
      + 0.04757383546D+00 ) * pk &
      + 0.0626060122D+00  ) * pk &
      + 0.44325141463D+00 ) * pk &
      + 1.0D+00

    be = ((( &
        0.00526449639D+00   * pk &
      + 0.04069697526D+00 ) * pk &
      + 0.09200180037D+00 ) * pk &
      + 0.2499836831D+00  ) * pk

    ce = ae - be * log ( pk )

  end if

  return
end


*DECK COMLR2
      SUBROUTINE COMLR2 (NM, N, LOW, IGH, INT, HR, HI, WR, WI, ZR, ZI,
     +   IERR)
C***BEGIN PROLOGUE  COMLR2
C***PURPOSE  Compute the eigenvalues and eigenvectors of a complex upper
C            Hessenberg matrix using the modified LR method.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C2B
C***TYPE      COMPLEX (COMLR2-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK, LR METHOD
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure COMLR2,
C     NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C
C     This subroutine finds the eigenvalues and eigenvectors
C     of a COMPLEX UPPER Hessenberg matrix by the modified LR
C     method.  The eigenvectors of a COMPLEX GENERAL matrix
C     can also be found if  COMHES  has been used to reduce
C     this general matrix to Hessenberg form.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, HR, HI, ZR and ZI, as declared in the
C          calling program dimension statement.  NM is an INTEGER
C          variable.
C
C        N is the order of the matrix H=(HR,HI).  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  CBAL.  If  CBAL  has not been used,
C          set LOW=1 and IGH equal to the order of the matrix, N.
C
C        INT contains information on the rows and columns
C          interchanged in the reduction by  COMHES, if performed.
C          Only elements LOW through IGH are used.  If you want the
C          eigenvectors of a complex general matrix, leave INT as it
C          came from  COMHES.  If the eigenvectors of the Hessenberg
C          matrix are desired, set INT(J)=J for these elements.  INT
C          is a one-dimensional INTEGER array, dimensioned INT(IGH).
C
C        HR and HI contain the real and imaginary parts, respectively,
C          of the complex upper Hessenberg matrix.  Their lower
C          triangles below the subdiagonal contain the multipliers
C          which were used in the reduction by  COMHES, if performed.
C          If the eigenvectors of a complex general matrix are
C          desired, leave these multipliers in the lower triangles.
C          If the eigenvectors of the Hessenberg matrix are desired,
C          these elements must be set to zero.  HR and HI are
C          two-dimensional REAL arrays, dimensioned HR(NM,N) and
C          HI(NM,N).
C
C     On OUTPUT
C
C        The upper Hessenberg portions of HR and HI have been
C          destroyed, but the location HR(1,1) contains the norm
C          of the triangularized matrix.
C
C        WR and WI contain the real and imaginary parts, respectively,
C          of the eigenvalues of the upper Hessenberg matrix.  If an
C          error exit is made, the eigenvalues should be correct for
C          indices IERR+1, IERR+2, ..., N.  WR and WI are one-
C          dimensional REAL arrays, dimensioned WR(N) and WI(N).
C
C        ZR and ZI contain the real and imaginary parts, respectively,
C          of the eigenvectors.  The eigenvectors are unnormalized.
C          If an error exit is made, none of the eigenvectors has been
C          found.  ZR and ZI are two-dimensional REAL arrays,
C          dimensioned ZR(NM,N) and ZI(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30*N iterations.
C                     The eigenvalues should be correct for indices
C                     IERR+1, IERR+2, ..., N, but no eigenvectors are
C                     computed.
C
C     Calls CSROOT for complex square root.
C     Calls CDIV for complex division.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  CDIV, CSROOT
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  COMLR2
C
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NM,NN,IGH,IM1,IP1
      INTEGER ITN,ITS,LOW,MP1,ENM1,IEND,IERR
      REAL HR(NM,*),HI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*)
      REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,S1,S2
      INTEGER INT(*)
C
C***FIRST EXECUTABLE STATEMENT  COMLR2
      IERR = 0
C     .......... INITIALIZE EIGENVECTOR MATRIX ..........
      DO 100 I = 1, N
C
         DO 100 J = 1, N
            ZR(I,J) = 0.0E0
            ZI(I,J) = 0.0E0
            IF (I .EQ. J) ZR(I,J) = 1.0E0
  100 CONTINUE
C     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
C                FROM THE INFORMATION LEFT BY COMHES ..........
      IEND = IGH - LOW - 1
      IF (IEND .LE. 0) GO TO 180
C     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
      DO 160 II = 1, IEND
         I = IGH - II
         IP1 = I + 1
C
         DO 120 K = IP1, IGH
            ZR(K,I) = HR(K,I-1)
            ZI(K,I) = HI(K,I-1)
  120    CONTINUE
C
         J = INT(I)
         IF (I .EQ. J) GO TO 160
C
         DO 140 K = I, IGH
            ZR(I,K) = ZR(J,K)
            ZI(I,K) = ZI(J,K)
            ZR(J,K) = 0.0E0
            ZI(J,K) = 0.0E0
  140    CONTINUE
C
         ZR(J,I) = 1.0E0
  160 CONTINUE
C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  180 DO 200 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  200 CONTINUE
C
      EN = IGH
      TR = 0.0E0
      TI = 0.0E0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  220 IF (EN .LT. LOW) GO TO 680
      ITS = 0
      ENM1 = EN - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 300
         S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1))
     1             + ABS(HR(L,L)) + ABS(HI(L,L))
         S2 = S1 + ABS(HR(L,L-1)) + ABS(HI(L,L-1))
         IF (S2 .EQ. S1) GO TO 300
  260 CONTINUE
C     .......... FORM SHIFT ..........
  300 IF (L .EQ. EN) GO TO 660
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
      SR = HR(EN,EN)
      SI = HI(EN,EN)
      XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1)
      XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1)
      IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340
      YR = (HR(ENM1,ENM1) - SR) / 2.0E0
      YI = (HI(ENM1,ENM1) - SI) / 2.0E0
      CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI)
      IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
      SR = SR - XR
      SI = SI - XI
      GO TO 340
C     .......... FORM EXCEPTIONAL SHIFT ..........
  320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2))
      SI = ABS(HI(EN,ENM1)) + ABS(HI(ENM1,EN-2))
C
  340 DO 360 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  360 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
      ITN = ITN - 1
C     .......... LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS ..........
      XR = ABS(HR(ENM1,ENM1)) + ABS(HI(ENM1,ENM1))
      YR = ABS(HR(EN,ENM1)) + ABS(HI(EN,ENM1))
      ZZR = ABS(HR(EN,EN)) + ABS(HI(EN,EN))
C     .......... FOR M=EN-1 STEP -1 UNTIL L DO -- ..........
      DO 380 MM = L, ENM1
         M = ENM1 + L - MM
         IF (M .EQ. L) GO TO 420
         YI = YR
         YR = ABS(HR(M,M-1)) + ABS(HI(M,M-1))
         XI = ZZR
         ZZR = XR
         XR = ABS(HR(M-1,M-1)) + ABS(HI(M-1,M-1))
         S1 = ZZR / YI * (ZZR + XR + XI)
         S2 = S1 + YR
         IF (S2 .EQ. S1) GO TO 420
  380 CONTINUE
C     .......... TRIANGULAR DECOMPOSITION H=L*R ..........
  420 MP1 = M + 1
C
      DO 520 I = MP1, EN
         IM1 = I - 1
         XR = HR(IM1,IM1)
         XI = HI(IM1,IM1)
         YR = HR(I,IM1)
         YI = HI(I,IM1)
         IF (ABS(XR) + ABS(XI) .GE. ABS(YR) + ABS(YI)) GO TO 460
C     .......... INTERCHANGE ROWS OF HR AND HI ..........
         DO 440 J = IM1, N
            ZZR = HR(IM1,J)
            HR(IM1,J) = HR(I,J)
            HR(I,J) = ZZR
            ZZI = HI(IM1,J)
            HI(IM1,J) = HI(I,J)
            HI(I,J) = ZZI
  440    CONTINUE
C
         CALL CDIV(XR,XI,YR,YI,ZZR,ZZI)
         WR(I) = 1.0E0
         GO TO 480
  460    CALL CDIV(YR,YI,XR,XI,ZZR,ZZI)
         WR(I) = -1.0E0
  480    HR(I,IM1) = ZZR
         HI(I,IM1) = ZZI
C
         DO 500 J = I, N
            HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J)
            HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J)
  500    CONTINUE
C
  520 CONTINUE
C     .......... COMPOSITION R*L=H ..........
      DO 640 J = MP1, EN
         XR = HR(J,J-1)
         XI = HI(J,J-1)
         HR(J,J-1) = 0.0E0
         HI(J,J-1) = 0.0E0
C     .......... INTERCHANGE COLUMNS OF HR, HI, ZR, AND ZI,
C                IF NECESSARY ..........
         IF (WR(J) .LE. 0.0E0) GO TO 580
C
         DO 540 I = 1, J
            ZZR = HR(I,J-1)
            HR(I,J-1) = HR(I,J)
            HR(I,J) = ZZR
            ZZI = HI(I,J-1)
            HI(I,J-1) = HI(I,J)
            HI(I,J) = ZZI
  540    CONTINUE
C
         DO 560 I = LOW, IGH
            ZZR = ZR(I,J-1)
            ZR(I,J-1) = ZR(I,J)
            ZR(I,J) = ZZR
            ZZI = ZI(I,J-1)
            ZI(I,J-1) = ZI(I,J)
            ZI(I,J) = ZZI
  560    CONTINUE
C
  580    DO 600 I = 1, J
            HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J)
            HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J)
  600    CONTINUE
C     .......... ACCUMULATE TRANSFORMATIONS ..........
         DO 620 I = LOW, IGH
            ZR(I,J-1) = ZR(I,J-1) + XR * ZR(I,J) - XI * ZI(I,J)
            ZI(I,J-1) = ZI(I,J-1) + XR * ZI(I,J) + XI * ZR(I,J)
  620    CONTINUE
C
  640 CONTINUE
C
      GO TO 240
C     .......... A ROOT FOUND ..........
  660 HR(EN,EN) = HR(EN,EN) + TR
      WR(EN) = HR(EN,EN)
      HI(EN,EN) = HI(EN,EN) + TI
      WI(EN) = HI(EN,EN)
      EN = ENM1
      GO TO 220
C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM ..........
  680 NORM = 0.0E0
C
      DO 720 I = 1, N
C
         DO 720 J = I, N
            NORM = NORM + ABS(HR(I,J)) + ABS(HI(I,J))
  720 CONTINUE
C
      HR(1,1) = NORM
      IF (N .EQ. 1 .OR. NORM .EQ. 0.0E0) GO TO 1001
C     .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
      DO 800 NN = 2, N
         EN = N + 2 - NN
         XR = WR(EN)
         XI = WI(EN)
         ENM1 = EN - 1
C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
         DO 780 II = 1, ENM1
            I = EN - II
            ZZR = HR(I,EN)
            ZZI = HI(I,EN)
            IF (I .EQ. ENM1) GO TO 760
            IP1 = I + 1
C
            DO 740 J = IP1, ENM1
               ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
               ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
  740       CONTINUE
C
  760       YR = XR - WR(I)
            YI = XI - WI(I)
            IF (YR .NE. 0.0E0 .OR. YI .NE. 0.0E0) GO TO 775
            YR = NORM
  770       YR = 0.5E0*YR
            IF (NORM + YR .GT. NORM) GO TO 770
            YR = 2.0E0*YR
  775       CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
  780    CONTINUE
C
  800 CONTINUE
C     .......... END BACKSUBSTITUTION ..........
      ENM1 = N - 1
C     .......... VECTORS OF ISOLATED ROOTS ..........
      DO 840 I = 1, ENM1
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
         IP1 = I + 1
C
         DO 820 J = IP1, N
            ZR(I,J) = HR(I,J)
            ZI(I,J) = HI(I,J)
  820    CONTINUE
C
  840 CONTINUE
C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW+1 DO -- ..........
      DO 880 JJ = LOW, ENM1
         J = N + LOW - JJ
         M = MIN(J-1,IGH)
C
         DO 880 I = LOW, IGH
            ZZR = ZR(I,J)
            ZZI = ZI(I,J)
C
            DO 860 K = LOW, M
               ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
               ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
  860       CONTINUE
C
            ZR(I,J) = ZZR
            ZI(I,J) = ZZI
  880 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END


! Converts the binary string in BIN to its real value
! Igor Lopes, February 2015
DOUBLE PRECISION FUNCTION BIN2REAL(BIN,NBIT)
    IMPLICIT NONE
    REAL(8) R0 /0.0D0/
    REAL(8) R2 /2.0D0/
    ! Arguments
    INTEGER NBIT
    INTEGER,DIMENSION(NBIT) :: BIN
    ! Locals
    INTEGER :: IBIT
    ! Begin algorithm
    BIN2REAL=R0
    DO IBIT=1,NBIT
        BIN2REAL=BIN2REAL+BIN(IBIT)*R2**(NBIT-IBIT)
    ENDDO
    RETURN
END FUNCTION


      PROGRAM xpredic
C     driver for routine predic
      INTEGER NPTS,NPOLES,NFUT
      REAL PI
      PARAMETER(NPTS=500,NPOLES=10,NFUT=20,PI=3.1415926)
      INTEGER i,n
      REAL f,dum,data(NPTS),d(NPOLES),future(NFUT)
      f(n)=exp(-1.0*n/NPTS)*sin(2.0*PI*n/50.0)
     *     +exp(-2.0*n/NPTS)*sin(2.2*PI*n/50.0)
      do 11 i=1,NPTS
        data(i)=f(i)
11    continue
      call memcof(data,NPTS,NPOLES,dum,d)
      call fixrts(d,NPOLES)
      call predic(data,NPTS,d,NPOLES,future,NFUT)
      write(*,'(6x,a,t13,a,t25,a)') 'I','Actual','PREDIC'
      do 12 i=1,NFUT
        write(*,'(1x,i6,2f12.6)') i,f(i+NPTS),future(i)
12    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xpredic.for


MODULE Snowaccumulationmod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_snowaccumulation(tsmax, &
        tmax, &
        trmax, &
        precip, &
        Snowaccu)
        IMPLICIT NONE
        REAL, INTENT(IN) :: tsmax
        REAL, INTENT(IN) :: tmax
        REAL, INTENT(IN) :: trmax
        REAL, INTENT(IN) :: precip
        REAL, INTENT(OUT) :: Snowaccu
        REAL:: fs
        fs = 0.0
        !- Name: SnowAccumulation -Version: 1.0, -Time step: 1
        !- Description:
    !            * Title: snowfall accumulation  calculation
    !            * Author: STICS
    !            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    !            * Institution: INRA
    !            * Abstract: It simulates the depth of snow cover and recalculate weather data
        !- inputs:
    !            * name: tsmax
    !                          ** description : maximum daily air temperature (tmax) below which all precipitation is assumed to be snow
    !                          ** inputtype : parameter
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 1000
    !                          ** unit : degC
    !                          ** uri :
    !            * name: tmax
    !                          ** description : current maximum air temperature
    !                          ** inputtype : variable
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 5000.0
    !                          ** unit : degC
    !                          ** uri :
    !            * name: trmax
    !                          ** description : tmax above which all precipitation is assumed to be rain
    !                          ** inputtype : parameter
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 5000.0
    !                          ** unit : degC
    !                          ** uri :
    !            * name: precip
    !                          ** description : current precipitation
    !                          ** inputtype : variable
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 5000.0
    !                          ** unit : mmW
    !                          ** uri :
        !- outputs:
    !            * name: Snowaccu
    !                          ** description : snowfall accumulation
    !                          ** variablecategory : rate
    !                          ** datatype : DOUBLE
    !                          ** min : 0.0
    !                          ** max : 500.0
    !                          ** unit : mmW/d
    !                          ** uri :
        IF(tmax .LT. tsmax) THEN
            fs = 1.0
        END IF
        IF(tmax .GE. tsmax .AND. tmax .LE. trmax) THEN
            fs = (trmax - tmax) / (trmax - tsmax)
        END IF
        Snowaccu = fs * precip
    END SUBROUTINE model_snowaccumulation

END MODULE


C DATANA.F - Gateway function for data analysis calculations using
C            SLICOT routines DE01OD, DE01PD, DF01MD, DG01MD, DG01ND,
C            DG01OD, and DK01MD.
C
C RELEASE 2.0 of SLICOT Basic Systems and Control Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C Matlab call:
C   [C(,D)] = datana(job,A(,B)(,T)(,window)(,pad0))
C
C   [C]     = datana(job,A(,pad0))        |job| = 0, 6;
C   [C]     = datana(job,A,B(,pad0))      |job| = 1, 2;
C   [C]     = datana(job,A(,T)(,pad0))    |job| = 3;
C   [YR,YI] = datana(job,XR,XI(,pad0))    |job| = 4, 5;
C   [C]     = datana(job,A(,window))       job  = 7.
C
C Purpose:
C  To perform various transforms of real or complex vectors, used in
C  data analysis calculations.
C
C Input parameters:
C   job    - option parameter indicating the task to be performed.
C            =-6 :  scrambled discrete Hartley transform of a real
C                   signal A (the input signal is bit-reversed);
C            =-5 :  inverse discrete Fourier transform of a real signal;
C            =-4 :  inverse discrete Fourier transform of a complex
C                   signal XR+i*XI;
C            =-3 :  sine transform of a real signal A;
C            =-2 :  deconvolution of two real signals A and B using
C                   Hartley transform;
C            =-1 :  deconvolution of two real signals A and B using FFT;
C            = 0 :  discrete Hartley transform of a real signal A
C                   (the signal is not scrambled);
C            = 1 :  convolution of two real signals A and B using FFT,
C                   defined in MATLAB by real(ifft(fft(A).*fft(B)));
C            = 2 :  convolution of two real signals A and B using
C                   Hartley transform;
C            = 3 :  cosine transform of a real signal A;
C            = 4 :  discrete Fourier transform of a complex signal
C                   XR+i*XI;
C            = 5 :  discrete Fourier transform of a real signal X;
C            = 6 :  scrambled discrete Hartley transform of a real
C                   signal A (the output transform is bit-reversed);
C            = 7 :  anti-aliasing window applied to a real signal A.
C   A      - the n-vector A.
C   B      - (optional) if |job| = 1 or 2, the n-vector B.
C   T      - (optional) if |job| = 3, the sampling time of the
C            signal; otherwise, it is not used.
C            Default:  T = 1.
C   XR     - if job =  4, the n-vector containing the real part of the
C                         complex signal X.
C            if job = -4, the n-vector containing the real part of the
C                         discrete Fourier transform.
C            if job =  5, the n-vector containing the odd part of the
C                         real signal X.
C            if job = -5, the n+1-vector containing the real part of
C                         the discrete Fourier transform.
C   XI     - if job =  4, the n-vector containing the imaginary part of
C                         the complex signal X.
C            if job = -4, the n-vector containing the imaginary part of
C                         the discrete Fourier transform.
C            if job =  5, the n-vector containing the even part of the
C                         real signal X.
C            if job = -5, the n+1-vector containing the imaginary
C                         part of the discrete Fourier transform.
C   window - (optional) if job = 7, integer specifying the type of
C            window to use:
C            = 1: Hamming window;
C            = 2: Hann window;
C            = 3: Quadratic window.
C            Default:  window = 1.
C   pad0   - (optional) if job <> 7, integer specifying how sequences
C            whose length is not a power of 2 should be dealt with:
C            = 0: truncate the trailing part and use a number of data
C                 points corresponding to the largest power of 2, i.e.,
C                 2^m, if |job| <> 3, or 2^m+1, if |job| = 3;
C            = 1: pad the trailing part with 0 till the next power
C                 of 2 (plus 1, if |job| = 3).
C            Default:  pad0 = 0.
C
C Output parameters:
C   C      - the n-vector of results computed according to job.
C   YR     - if job =  4, the n-vector containing the real part of
C                         the computed discrete Fourier transform.
C            if job = -4, the n-vector containing the real part of
C                         inverse discrete Fourier transform.
C            if job =  5, the n+1-vector containing the real part of
C                         the discrete Fourier transform.
C            if job = -5, the odd part of the inverse discrete
C                         Fourier transform.
C   YI     - if job =  4, the n-vector containing the imaginary part
C                         of the computed discrete Fourier transform.
C            if job = -4, the n-vector containing the imaginary part
C                         of the inverse discrete Fourier transform.
C            if job =  5, the n+1-vector containing the imaginary part
C                         of the discrete Fourier transform.
C            if job = -5, the even part of the inverse discrete
C                         Fourier transform.
C
C Further Comments:
C   1) Except for job = 7, this function essentially works on signals
C      whose length is a power of 2, 2^m (or 2^m+1, if |job| = 3).
C      For |job| = 3, m >= 2.
C   2) For job = 5, this function computes the first n+1 elements
C      of the discrete Fourier transform.  The remaining n-1 elements
C      can be obtained using the MATLAB command conj( Y(n:-1:2) ),
C      where Y = YR + i*YI.
C   3) For job = -5, this function uses as input the first
C      n+1 elements of the discrete Fourier transform.
C
C Contributor:
C   V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002.
C
C Revisions:
C   V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009,
C   Dec. 2012.
C
C **********************************************************************
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         CONV, INDI, SCR, SICO, WGHT, WIND
      INTEGER           INFO, N
      DOUBLE PRECISION  DT
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      DOUBLE PRECISION, ALLOCATABLE :: A(:), B(:), DWORK(:), W(:),
     $                                 XI(:), XR(:)
C
C .. Local variables and constant dimension arrays ..
      CHARACTER*120     TEXT
      INTEGER           I, IJOB, IP, IPAD, IWIN, JOB, LA, M, NZ
      DOUBLE PRECISION  DUM(1), TEMP
C
C .. External subroutines ..
      EXTERNAL          DCOPY,  DE01OD, DE01PD, DF01MD, DG01MD, DG01ND,
     $                  DG01OD, DK01MD, DSCAL
C
C .. Intrinsic functions ..
      INTRINSIC         ABS, DBLE, MAX, MIN
C
C Check for proper number of arguments.
C
      IF ( NRHS.LT.2 ) THEN
         CALL mexErrMsgTxt
     $        ( 'DATANA requires at least 2 input arguments' )
      ELSE IF ( NLHS.LT.1 ) THEN
         CALL mexErrMsgTxt
     $        ( 'DATANA requires at least 1 output argument' )
      END IF
C
C   job, A(n), (B(n)) (,T) (,window) (,pad0).
C
      M = mxGetM( PRHS(2) )
      N = mxGetN( PRHS(2) )
      I = MIN( M, N )
      N = MAX( M, N )
      M = I
C
      IF ( mxGetM( PRHS(1) ).NE.1 .OR.
     $     mxGetN( PRHS(1) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'JOB must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'JOB must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), TEMP, 1 )
      JOB  = TEMP
      IJOB = ABS( JOB )
      IF ( JOB.LT.-6 ) THEN
         CALL mexErrMsgTxt
     $           ( 'JOB must be larger than or equal to -6' )
      ELSE IF ( JOB.GT.7 ) THEN
         CALL mexErrMsgTxt
     $           ( 'JOB must be less than or equal to 7' )
      END IF
C
C Recheck for proper number of arguments.
C
      IF ( ( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 .OR. IJOB.EQ.5 )
     $     .AND. NRHS.LT.3 ) THEN
         CALL mexErrMsgTxt
     $        ( 'DATANA requires at least 3 input arguments' )
      END IF
      IF ( ( IJOB.EQ.4 .OR. IJOB.EQ.5 ) .AND. NLHS.LT.2 ) THEN
         CALL mexErrMsgTxt
     $        ( 'DATANA requires 2 output arguments' )
      END IF
C
      IF ( ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(2) ).EQ.1 ) .OR. M.NE.1 ) THEN
         IF ( IJOB.EQ.4 .OR. IJOB.EQ.5 ) THEN
            CALL mexErrMsgTxt( 'XR must be a real vector' )
         ELSE
            CALL mexErrMsgTxt( 'A must be a real vector' )
         END IF
      END IF
C
      IP = 3
      IF ( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN
         IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(3) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'B must be a real vector' )
         END IF
         IF ( MAX( mxGetM( PRHS(3) ), mxGetN( PRHS(3) ) ).NE.N .AND.
     $        MIN( mxGetM( PRHS(3) ), mxGetN( PRHS(3) ) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'B must have the same size as A' )
         END IF
         IP = 4
C
      ELSE IF ( IJOB.EQ.4 .OR. IJOB.EQ.5 ) THEN
         IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(3) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'XI must be a real vector' )
         END IF
         IF ( MAX( mxGetM( PRHS(3) ), mxGetN( PRHS(3) ) ).NE.N .AND.
     $        MIN( mxGetM( PRHS(3) ), mxGetN( PRHS(3) ) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'XI must have the same size as XR' )
         END IF
         IP = 4
C
      ELSE IF ( IJOB.EQ.3 ) THEN
         IF ( NRHS.GE.3 ) THEN
C
C   T
C
            IF ( mxGetM( PRHS(3) ).NE.1 .OR.
     $           mxGetN( PRHS(3) ).NE.1 ) THEN
               CALL mexErrMsgTxt( 'T must be a scalar' )
            END IF
            IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $           mxIsComplex( PRHS(3) ).EQ.1 ) THEN
               CALL mexErrMsgTxt( 'T must be a real scalar' )
            END IF
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), DT, 1 )
            IP = IP + 1
         ELSE
            DT = ONE
         END IF
C
      ELSE IF ( JOB.EQ.7 ) THEN
         IF ( NRHS.EQ.3 ) THEN
C
C   window
C
            IF ( mxGetM( PRHS(3) ).NE.1 .OR.
     $           mxGetN( PRHS(3) ).NE.1 ) THEN
               CALL mexErrMsgTxt( 'WINDOW must be a scalar' )
            END IF
            IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $           mxIsComplex( PRHS(3) ).EQ.1 ) THEN
               CALL mexErrMsgTxt( 'WINDOW must be an integer scalar' )
            END IF
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), TEMP, 1 )
            IWIN = TEMP
            IF ( IWIN.LT.0 .OR. IWIN.GT.3 ) THEN
               CALL mexErrMsgTxt
     $            ( 'WINDOW has 1, 2, or 3 the only admissible values' )
            END IF
         ELSE
            IWIN = 1
         END IF
      END IF
C
      IF ( JOB.NE.7 .AND. NRHS.GE.IP ) THEN
C
C   pad0
C
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'PAD0 must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'PAD0 must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
         IPAD = TEMP
         IF ( IPAD.LT.0 .OR. IPAD.GT.1 ) THEN
            CALL mexErrMsgTxt
     $         ( 'PAD0 has 0 or 1 the only admissible values' )
         END IF
      ELSE
         IPAD = 0
      END IF
C
      IF ( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN
         IF ( JOB.LT.0 ) THEN
            CONV = 'D'
         ELSE
            CONV = 'C'
         END IF
         IF ( IJOB.EQ.2 )
     $      WGHT = 'N'
      ELSE IF ( IJOB.EQ.3 ) THEN
         IF ( JOB.LT.0 ) THEN
            SICO = 'S'
         ELSE
            SICO = 'C'
         END IF
      ELSE IF ( IJOB.EQ.4 .OR. IJOB.EQ.5 ) THEN
         IF ( JOB.LT.0 ) THEN
            INDI = 'I'
         ELSE
            INDI = 'D'
         END IF
         IF ( JOB.EQ.-5 )
     $      N = N - 1
C
      ELSE IF ( IJOB.EQ.6 ) THEN
         IF ( JOB.LT.0 ) THEN
            SCR = 'I'
         ELSE
            SCR = 'O'
         END IF
         WGHT = 'N'
      ELSE IF ( IJOB.EQ.0 ) THEN
         SCR  = 'N'
         WGHT = 'N'
C
      ELSE IF ( JOB.EQ.7 ) THEN
         IF ( IWIN.EQ.1 ) THEN
            WIND = 'M'
         ELSE IF ( IWIN.EQ.2 ) THEN
            WIND = 'N'
         ELSE
            WIND = 'Q'
         END IF
      END IF
C
C Determine the lenghts of working arrays.
C First check if for job <> 7, n is power of 2, n = 2^m
C (or 2^m+1, for |job| = 3).
C
      IF ( IJOB.LT.7 ) THEN
         I = 1
         M = 0
         IF ( N.GT.1 ) THEN
C           WHILE 2**M < N DO
   10       CONTINUE
               I = I*2
               M = M + 1
               IF ( I.LT.N )
     $            GO TO 10
C           END WHILE 10
         END IF
         IF ( I.GT.N ) THEN
            IF ( IPAD.EQ.1 ) THEN
               IF ( IJOB.EQ.3 ) THEN
                  IF ( I/2 + 1.NE.N ) THEN
                     LA = I + 1
                  ELSE
                     LA = N
                  END IF
               ELSE
                  LA = I
               END IF
            ELSE
               IF ( IJOB.EQ.3 ) THEN
                  N = I/2 + 1
               ELSE
                  N = I/2
               END IF
               LA = N
            END IF
         ELSE
            IF ( IJOB.EQ.3 ) THEN
               IF ( IPAD.EQ.1 ) THEN
                  LA = I + 1
               ELSE
                  N  = I/2 + 1
                  LA = N
               END IF
            ELSE
               LA = N
            END IF
         END IF
         NZ = LA - N
         IF ( JOB.EQ.-5 .AND. NZ.GT.0 )
     $      NZ = NZ - 1
      ELSE
         NZ = 0
      END IF
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      IF ( IJOB.EQ.3 .AND. LA.LT.5 ) THEN
         CALL mexErrMsgTxt( 'N must be at least 5' )
      ELSE IF ( ( IJOB.EQ.1 .OR. IJOB.EQ.4 .OR. IJOB.EQ.5 ) .AND.
     $          LA.LT.2 ) THEN
         CALL mexErrMsgTxt( 'N must be at least 2' )
      ELSE IF ( JOB.EQ.7 .AND. N.LT.1 ) THEN
         CALL mexErrMsgTxt( 'N must be at least 1' )
      END IF
C
      IF ( IJOB.EQ.1 ) THEN
         ALLOCATE ( A( LA ), B( LA ) )
      ELSE IF ( IJOB.EQ.2 ) THEN
         ALLOCATE ( A( LA ), B( LA ), W( LA-M ) )
      ELSE IF ( IJOB.EQ.3 ) THEN
         ALLOCATE ( A( LA ), DWORK( LA+1 ) )
      ELSE IF ( IJOB.EQ.4 ) THEN
         ALLOCATE ( XI( LA ), XR( LA ) )
      ELSE IF ( IJOB.EQ.5 ) THEN
         ALLOCATE ( XI( LA+1 ), XR( LA+1 ) )
      ELSE IF ( IJOB.EQ.6 .OR. IJOB.EQ.0 ) THEN
         ALLOCATE ( A( LA ), W( LA-M ) )
      ELSE
         ALLOCATE ( A( N ) )
      END IF
C
C Copy inputs from MATLAB workspace to locally allocated arrays.
C
      M = N
      IF ( JOB.EQ.-5 )
     $   M = N + 1
      IF ( IJOB.LE.3 .OR. IJOB.GE.6 ) THEN
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), A, N )
      ELSE
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), XR, M )
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), XI, M )
      END IF
      IF ( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), B, N )
      END IF
C
      IF ( NZ.GT.0 ) THEN
C
C Pad the trailing part with zero and reset N.
C
         DUM(1) = ZERO
         IF ( IJOB.LE.3 .OR. IJOB.GE.6 ) THEN
            CALL DCOPY( NZ, DUM(1), 0, A(N+1), 1 )
         ELSE
            CALL DCOPY( NZ, DUM(1), 0, XR(M+1), 1 )
            CALL DCOPY( NZ, DUM(1), 0, XI(M+1), 1 )
         END IF
         IF ( IJOB.LE.2 ) THEN
            CALL DCOPY( NZ, DUM(1), 0, B(N+1), 1 )
         END IF
         N = LA
      END IF
      M = N
      IF ( JOB.EQ.5 )
     $   M = N + 1
C
C Do the actual computations.
C
      IF ( IJOB.EQ.1 ) THEN
         CALL DE01OD( CONV, N, A, B, INFO )
      ELSE IF ( IJOB.EQ.2 ) THEN
         CALL DE01PD( CONV, WGHT, N, A, B, W, INFO )
      ELSE IF ( IJOB.EQ.3 ) THEN
         CALL DF01MD( SICO, N, DT, A, DWORK, INFO )
      ELSE IF ( IJOB.EQ.4 ) THEN
         CALL DG01MD( INDI, N, XR, XI, INFO )
         IF ( JOB.LT.0 ) THEN
            TEMP = ONE/DBLE( N )
            CALL DSCAL( N, TEMP, XR, 1 )
            CALL DSCAL( N, TEMP, XI, 1 )
         END IF
      ELSE IF ( IJOB.EQ.5 ) THEN
         CALL DG01ND( INDI, N, XR, XI, INFO )
         IF ( JOB.LT.0 ) THEN
            TEMP = ONE/DBLE( 2*N )
            CALL DSCAL( N, TEMP, XR, 1 )
            CALL DSCAL( N, TEMP, XI, 1 )
         END IF
      ELSE IF ( IJOB.EQ.6 .OR. IJOB.EQ.0 ) THEN
         CALL DG01OD( SCR, WGHT, N, A, W, INFO )
      ELSE
         CALL DK01MD( WIND, N, A, INFO )
      END IF
C
C Copy output to MATLAB workspace.
C
      IF ( IJOB.LE.3 .OR. IJOB.GE.6 ) THEN
         PLHS(1) = mxCreateDoubleMatrix( N, 1, 0 )
         CALL mxCopyReal8ToPtr( A, mxGetPr( PLHS(1) ), N )
      ELSE
         PLHS(1) = mxCreateDoubleMatrix( M, 1, 0 )
         CALL mxCopyReal8ToPtr( XR, mxGetPr( PLHS(1) ), M )
         PLHS(2) = mxCreateDoubleMatrix( M, 1, 0 )
         CALL mxCopyReal8ToPtr( XI, mxGetPr( PLHS(2) ), M )
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
      IF ( IJOB.EQ.1 ) THEN
         DEALLOCATE ( A, B )
      ELSE IF ( IJOB.EQ.2 ) THEN
         DEALLOCATE ( A, B, W )
      ELSE IF ( IJOB.EQ.3 ) THEN
         DEALLOCATE ( A, DWORK )
      ELSE IF ( IJOB.EQ.4 .OR. IJOB.EQ.5 ) THEN
         DEALLOCATE ( XI, XR )
      ELSE IF ( IJOB.EQ.6 .OR. IJOB.EQ.0 ) THEN
         DEALLOCATE ( A, W )
      ELSE
         DEALLOCATE ( A )
      END IF
C
C Error and warning handling.
C
      IF ( INFO.NE.0 ) THEN
         IF ( IJOB.EQ.1 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM DE01OD'')'
     $           ) INFO
         ELSE IF ( IJOB.EQ.2 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM DE01PD'')'
     $           ) INFO
         ELSE IF ( IJOB.EQ.3 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM DF01MD'')'
     $           ) INFO
         ELSE IF ( IJOB.EQ.4 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM DG01MD'')'
     $           ) INFO
         ELSE IF ( IJOB.EQ.5 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM DG01ND'')'
     $           ) INFO
         ELSE IF ( IJOB.EQ.6 .OR. IJOB.EQ.0 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM DG01OD'')'
     $           ) INFO
         ELSE
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM DK01MD'')'
     $           ) INFO
         END IF
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      RETURN
C *** Last line of DATANA ***
      END