C
C      **********************************************************************
C      ******************* SUBROUTINE SYMINV  *******************************
C      **********************************************************************
C
       SUBROUTINE SYMINV(A,N,C,W,NULLTY,NA,NC,NW,IFAULT)
C
C      *      ALGORITHM AS 7 J.R.STATIST.SOC.C. (1968) VOL.17, NO.2         *
C      *                                                                    *
C      *        FORMS IN C( ) A LOWER TRIANGULAR MATRIX, WHICH IS A         *
C      *        GENERALISED INVERSE OF THE POSITIVE SEMI-DEFINITE SYMMETRIC *
C      *        MATRIX A( ) OF ORDER N.                                     *
C      *        C( ) MAY COINCIDE WITH A( ). NULLTY IS RETURNED AS          *
C      *        THE NULLITY OF A( ). IFAULT IS RETURNED AS 1 IF             *
C      *        N.LT.1,OTHERWISE ZERO. W( ) IS A WORK ARRAY OF              *
C      *        LENGTH AT LEAST N THAT IS ALLOCATED BY THE CALLING          *
C      *        ROUTINE.                                                    *
C
C      *        NOTE : THE VARIABLES NA,NC,AND,NW,HAVE BEEN ADDED           *
C      *               TO THE ARGUMENT LIST AND ARE USED TO                 *
C      *               DIMENSION TO ARRAYS A,C,AND W, RESPECTIVELY.         *
C      *               (BY WOLYNETZ (1979))                                 *
C      *                                                                    *
C      *        SUBROUTINES                                                 *
C      *               CHOL                                                 *
C
       IMPLICIT REAL*8 (A-H,O-Z), INTEGER (I-N)
       DIMENSION A(NA),C(NC),W(NW)
C
       NROW=N
       IFAULT=1
       IF(NROW.GT.0) THEN
          IFAULT=0

          CALL CHOL(A,NROW,C,NULLTY,NA,NC,IFAULT)

          IF(IFAULT.EQ.0) THEN
             NN=(NROW*(NROW+1))/2
             IROW=NROW
             NDIAG=NN
   16        IF(C(NDIAG).NE.0.0) THEN
                L=NDIAG

                DO 10 I=IROW,NROW
                   W(I)=C(L)
                   L=L+I
   10           CONTINUE

                ICOL=NROW
                JCOL=NN
                MDIAG=NN
   15           L=JCOL
                X=0.0
                IF(ICOL.EQ.IROW) X=1.0/W(IROW)

                K=NROW
   13           IF(K.NE.IROW) THEN
                   X=X-W(K)*C(L)
                   K=K-1
                   L=L-1
                   IF(L.GT.MDIAG) L=L-K+1
                   GOTO 13
                ENDIF

                C(L)=X/W(IROW)
                IF(ICOL.EQ.IROW) GOTO 14
                MDIAG=MDIAG-ICOL
                ICOL=ICOL-1
                JCOL=JCOL-1
                GOTO 15
             ENDIF

             L=NDIAG
             DO 17 J=IROW,NROW
                C(L)=0.0
                L=L+J
   17        CONTINUE

   14        NDIAG=NDIAG-IROW
             IROW=IROW-1
             IF(IROW.NE.0) GOTO 16
          ENDIF
       ENDIF

       RETURN
       END


      function sumit (f, mbuse, nbuse)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use stel_kinds
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer mbuse, nbuse
      real(rprec), dimension(-mbuse:mbuse,0:nbuse) :: f
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n, m
      real(rprec) :: sumit
C-----------------------------------------------
c-
c specific sum of terms in f(i,j) table
c-
c
      sumit = 0
      do m = -mbuse, mbuse
         sumit = sumit + sum(f(m,1:nbuse))
      end do
      sumit = 2*sumit
      sumit = sumit + sum(f(-mbuse:mbuse,0))
      sumit = sumit - f(0,0)

      end function sumit


module kinematics
  use nrutils_modules
  use constants
  use structure
  use variables
contains
  real(kind=8) function get_vel_anisotropy(r)

    implicit none

    real(kind=8) :: r

    if(r_a.le.0.0) then
       get_vel_anisotropy = beta0;
    else
       get_vel_anisotropy = beta0*r_a*r_a/(r_a+r)**2
    end if

    return

  end function get_vel_anisotropy

  real(kind=8) function sgfunc(logr)
    implicit none
    real(kind=8) :: logr,r

    r=dexp(logr)

    sgfunc=-r*r**(2.*get_vel_anisotropy(r))*rho(r)*dphidr(r)
    return
  end function sgfunc

  real(kind=8) function funk(logr)
    implicit none

    real(kind=8) :: logr,r,rmin,rmax,sigr,fmin,fmax,fmid
    integer(kind=4) :: i,imin,imax

    r=exp(logr)

    imin=1
    imax=nrbin

    if((rtab(imin)-r)*(rtab(imax)-r).gt.0) stop

    do
       i=(imin+imax)/2
       if(r.lt.rtab(i)) imax=i
       if(r.gt.rtab(i)) imin=i
       if((imax-imin).le.1) exit
    end do

    sigr=(r-rtab(i-1))/(rtab(i)-rtab(i-1))*sigma_r(i)+&
         & (rtab(i)-r)/(rtab(i)-rtab(i-1))*sigma_r(i-1)

    funk = (1.0-get_vel_anisotropy(r)*radius*radius/r/r)*rho(r)*sigr*r*r/sqrt(r*r-radius*radius)

    return

  end function funk

end module kinematics


subroutine imc_get_energy_sources(e_surf, e_body, e_total)

    use imc_global_mesh_data, only: ncells, fleck, sigma_p, temp, dx
    use imc_global_bcon_data, only: t0
    use imc_global_phys_data, only: sb, a, c
    use imc_global_time_data, only: dt

    implicit none

    real(kind=8), intent(out)                    :: e_surf
    real(kind=8), intent(out)                    :: e_total
    real(kind=8), dimension(ncells), intent(out) :: e_body

    ! Left-hand boundary is a black-body emitter at constant temperature T0
    ! (Energy radiated per unit area = sigma.T0**4 (sigma = S-B constant)
    e_surf = sb * t0**4 * dt

    ! Emission source term
    e_body(:) = (fleck(:) * sigma_p(:) * a * c * temp(:)**4 * dx * dt)

    ! Total energy emitted
    e_total = e_surf + sum(e_body(:))

    write(*,'(/,A)') 'Energy radiated in timestep:'
    write(*,'(/,A)') 'In total:'
    write(*,'(ES24.16)') e_total
    write(*,'(/,A)') 'By boundary condition:'
    write(*,'(ES24.16)') e_surf
    write(*,'(/,A)') 'By mesh:'
    write(*,'(4(ES16.8))') e_body

end subroutine imc_get_energy_sources

subroutine imc_get_emission_probabilities(e_surf, e_body, e_total, p_surf, p_body)

    use imc_global_mesh_data, only: ncells

    implicit none

    real(kind=8), intent(in)                       :: e_surf
    real(kind=8), intent(in)                       :: e_total
    real(kind=8), dimension(ncells), intent(in)    :: e_body
    real(kind=8), intent(out)                      :: p_surf
    real(kind=8), dimension(0:ncells), intent(out) :: p_body
    integer                                        :: jcell

    p_surf = e_surf / e_total

    ! Probability of each cell given that the particle is from the mesh not the surface

    p_body(0) = 0.d0
    do jcell = 1, ncells
      p_body(jcell) = p_body(jcell-1) + e_body(jcell) / sum(e_body(:))
    enddo

    write(*,'(A)')
    write(*,'(A)') 'Probabilities:'
    write(*,'(A)')
    write(*,'(A)') 'In total'
    write(*,'(ES16.8)') p_surf + sum(p_body(:))
    write(*,'(A)')
    write(*,'(A)') 'Of boundary particle'
    write(*,'(ES16.8)') p_surf
    write(*,'(A)')
    write(*,'(A)') 'Of mesh particle (cumulative)'
    write(*,'(10F4.1)') p_body(1:ncells)

end subroutine imc_get_emission_probabilities

subroutine imc_get_source_particle_numbers(p_surf, p_body, n_surf, n_body)

    !use imc_global_bcon_data, only: t0
    use imc_global_mesh_data, only: ncells !, dx, temp, nodepos
    use imc_global_part_data, only: n_max, n_census, n_input !, , dead, xpos, icell, mu, &
    !                              & frq, nrg, startnrg, t, origin, inext
    !use imc_global_phys_data, only: h
    !use imc_global_time_data, only: step, dt, time
    !use imc_utils,            only: samplePlanckspectrum

    implicit none

    real(kind=8), intent(in)                        :: p_surf
    real(kind=8), dimension(0:ncells), intent(in)   :: p_body
    integer(kind=8), intent(out)                    :: n_surf
    integer(kind=8), dimension(ncells), intent(out) :: n_body
    real(kind=8)                            :: eta
    integer(kind=8)                         :: ip
    integer(kind=8)                         :: irannum
    integer(kind=8)                         :: n_source
    real(kind=8), allocatable, dimension(:) :: r
    integer                                 :: jcell

    ! Determine total number of particles to source this time-step
    n_source = n_input
    if ((n_source + n_census) > n_max) &
        n_source = n_max - n_census - ncells - 1

    write(*,'(/,A,I8,A)') 'Sourcing ',n_source,' particles this timestep'
    write(*,'(A,I8,A)') '(User requested ',n_input,' per timestep)'

    n_surf    = 0
    n_body(:) = 0

    allocate(r(2*n_source))
    call random_number(r)
    irannum = 0

    ! Calculate the number of particles emitted by the surface source and each mesh cell
    do ip = 1, n_source
        irannum = irannum + 1
        if (r(irannum) <= p_surf) then
            n_surf = n_surf + 1
        else
            irannum = irannum + 1
            eta = r(irannum)
            do jcell = 1, ncells
                if (eta <= p_body(jcell)) then
                    n_body(jcell) = n_body(jcell) + 1
                    exit
                endif
            enddo
        endif
    enddo
    deallocate(r)

    write(*,'(/,A)') 'Body source'
    write(*,'(10I6)') n_body(:)

end subroutine imc_get_source_particle_numbers

subroutine imc_source_particles(e_surf, e_body, n_surf, n_body)

    use imc_global_bcon_data, only: t0
    use imc_global_mesh_data, only: ncells, dx, temp, nodepos
    use imc_global_part_data, only: icell, inext, n_max, nrg, startnrg, dead, xpos, icell, mu, &
                                  & frq, nrg, startnrg, t, origin, inext
    use imc_global_phys_data, only: h
    use imc_global_time_data, only: dt, time ! step, dt, time
    use imc_utils,            only: samplePlanckspectrum

    implicit none

    real(kind=8), intent(in)                       :: e_surf
    real(kind=8), dimension(ncells), intent(in)    :: e_body
    integer(kind=8), intent(in)                    :: n_surf
    integer(kind=8), dimension(ncells), intent(in) :: n_body
    integer(kind=8)                         :: ip
    integer(kind=8)                         :: irannum
    real(kind=8), allocatable, dimension(:) :: r
    integer                                 :: jcell
    real(kind=8)                            :: jnrg
    real(kind=8)                            :: jstartnrg

    allocate(r(2*n_surf + 4*sum(n_body(:))))
    call random_number(r)
    irannum = 0

    ! Create the surface-source particles
    jnrg = e_surf/real(n_surf, 8)
    jstartnrg = jnrg
    do ip = 1, n_surf
        do while (.not. dead(inext))
           inext = inext + 1
           if (inext > n_max) inext = 1
        enddo
        dead(inext)     = .false.
        origin(inext)   = -1
        xpos(inext)     = 0.d0
        irannum         = irannum + 1
        t(inext)        = time + r(irannum) * dt
        irannum         = irannum + 1
        mu(inext)       = sqrt(r(irannum))                    ! Corresponds to f(mu) = 2mu
        frq(inext)      = t0 * samplePlanckspectrum() / h
        icell(inext)    = 1
        nrg(inext)      = jnrg
        startnrg(inext) = jstartnrg
    enddo

    ! Create the body-source particles
    do jcell = 1, ncells
        if (n_body(jcell) <= 0) &
            cycle
        jnrg = e_body(jcell)/real(n_body(jcell), 8)
        jstartnrg = jnrg
        do ip = 1, n_body(jcell)
            do while (.not. dead(inext))
                inext = inext + 1
                if (inext > n_max) inext = 1
            enddo
            dead(inext)     = .false.
            origin(inext)   = jcell
            irannum         = irannum + 1
            xpos(inext)     = nodepos(jcell) + r(irannum) * dx
            irannum         = irannum + 1
            mu(inext)       = 1.d0 - 2.d0 * r(irannum)
            irannum         = irannum + 1
            t(inext)        = time + r(irannum) * dt
            irannum         = irannum + 1
            frq(inext)      = temp(jcell) * abs(log(r(irannum))) / h
            icell(inext)    = jcell
            nrg(inext)      = jnrg
            startnrg(inext) = jstartnrg
        enddo
    enddo

    deallocate(r)

end subroutine imc_source_particles

subroutine imc_source

    use imc_global_mesh_data, only: ncells
    use imc_global_part_data, only: n_max, dead
    use imc_global_phys_data, only: h
    use imc_global_time_data, only: step

    implicit none

    real(kind=8)                            :: e_surf
    real(kind=8)                            :: e_total
    real(kind=8), dimension(ncells)         :: e_body
    real(kind=8)                            :: p_surf
    real(kind=8), dimension(0:ncells)       :: p_body
    integer(kind=8)                         :: n_surf
    integer(kind=8), dimension(ncells)      :: n_body
    integer(kind=8)                         :: numparts
    integer(kind=8)                         :: ip

    write(*,'(/,A)')    '-------------------------------------------------------------------------------'
    write(*,'(A,I4,A)') 'Source step (',step,')'
    write(*,'(A)')      '-------------------------------------------------------------------------------'

    ! Determine probability of particles belonging to sources
    ! -------------------------------------------------------

    ! Get the energy source terms
    call imc_get_energy_sources(e_surf, e_body, e_total)

    ! Emission probabilities
    call imc_get_emission_probabilities(e_surf, e_body, e_total, p_surf, p_body)

    ! Number of source particles
    call imc_get_source_particle_numbers(p_surf, p_body, n_surf, n_body)

    ! Create the particles
    call imc_source_particles(e_surf, e_body, n_surf, n_body)

    ! Particle count
    numparts = 0
    do ip = 1, n_max
        if (.not. dead(ip)) numparts = numparts + 1
    enddo
    write(*,'(A,I12)') 'Number of particles in the system = ', numparts

end subroutine imc_source


************************************************************************
*
*     Subroutine SETXL                       Called by: CALIBR, ESTLOAD
*
*     set explanatory variables (XLCAL for calibration, XLEST for
*     estimation)
*
************************************************************************
      SUBROUTINE SETXL(NMOD,NUMOBS,LQCENT,ADDL,FLOW,DECTIM,PER,XL,LDIM,
     &                 NEXPL,DVNAME,TRANS,NADDL)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 NMOD,NUMOBS,LDIM,NEXPL,NADDL
      DOUBLE PRECISION LQCENT
      DOUBLE PRECISION DECTIM(*),FLOW(*),XL(LDIM,*),PER(*)
      DOUBLE PRECISION ADDL(NADDL,*)
      CHARACTER*5 DVNAME(*),TRANS(*)
*
*     local vars
*
      INTEGER*4 I,J
      DOUBLE PRECISION PI
*
*     function declaration
*
      DOUBLE PRECISION TRANSF
*
*     define PI
*
      PARAMETER (PI=3.1415926536D0)
*
*     generate explanatory variables for one of the 12 models. Note
*     that the user-defined model is always the last model
*     (NMOD=NMODELS, see SETNPAR & SETUPC).
*
      IF (NMOD .EQ. 1) THEN
         DO 10 I=1,NUMOBS
            XL(I,1) = 1.D0
            XL(I,2) = DLOG(FLOW(I)) - LQCENT
 10      CONTINUE
      ELSEIF (NMOD .EQ. 2) THEN
         DO 20 I=1,NUMOBS
            XL(I,1) = 1.D0
            XL(I,2) = DLOG(FLOW(I)) - LQCENT
            XL(I,3) = XL(I,2)**2
 20      CONTINUE
      ELSEIF (NMOD .EQ. 3) THEN
         DO 30 I=1,NUMOBS
            XL(I,1) = 1.D0
            XL(I,2) = DLOG(FLOW(I)) - LQCENT
            XL(I,3) = DECTIM(I)
 30      CONTINUE
      ELSEIF (NMOD .EQ. 4) THEN
         DO 40 I=1,NUMOBS
            XL(I,1) = 1.D0
            XL(I,2) = DLOG(FLOW(I)) - LQCENT
            XL(I,3) = DSIN(2.D0*PI*DECTIM(I))
            XL(I,4) = DCOS(2.D0*PI*DECTIM(I))
 40      CONTINUE
      ELSEIF (NMOD .EQ. 5) THEN
         DO 50 I=1,NUMOBS
            XL(I,1) = 1.D0
            XL(I,2) = DLOG(FLOW(I)) - LQCENT
            XL(I,3) = XL(I,2)**2
            XL(I,4) = DECTIM(I)
 50      CONTINUE
      ELSEIF (NMOD .EQ. 6) THEN
         DO 60 I=1,NUMOBS
            XL(I,1) = 1.D0
            XL(I,2) = DLOG(FLOW(I)) - LQCENT
            XL(I,3) =  XL(I,2)**2
            XL(I,4) = DSIN(2.D0*PI*DECTIM(I))
            XL(I,5) = DCOS(2.D0*PI*DECTIM(I))
 60      CONTINUE
      ELSEIF (NMOD .EQ. 7) THEN
         DO 70 I=1,NUMOBS
            XL(I,1) = 1.D0
            XL(I,2) = DLOG(FLOW(I)) - LQCENT
            XL(I,3) = DSIN(2.D0*PI*DECTIM(I))
            XL(I,4) = DCOS(2.D0*PI*DECTIM(I))
            XL(I,5) = DECTIM(I)
 70      CONTINUE
      ELSEIF (NMOD .EQ. 8) THEN
         DO 80 I=1,NUMOBS
            XL(I,1) = 1.D0
            XL(I,2) = DLOG(FLOW(I)) - LQCENT
            XL(I,3) = XL(I,2)**2
            XL(I,4) = DSIN(2.D0*PI*DECTIM(I))
            XL(I,5) = DCOS(2.D0*PI*DECTIM(I))
            XL(I,6) = DECTIM(I)
 80      CONTINUE
      ELSEIF (NMOD .EQ. 9) THEN
         DO 90 I=1,NUMOBS
            XL(I,1) = 1.D0
            XL(I,2) = DLOG(FLOW(I)) - LQCENT
            XL(I,3) = XL(I,2)**2
            XL(I,4) = DSIN(2.D0*PI*DECTIM(I))
            XL(I,5) = DCOS(2.D0*PI*DECTIM(I))
            XL(I,6) = DECTIM(I)
            XL(I,7) = DECTIM(I)*DECTIM(I)
 90      CONTINUE
      ELSEIF (NMOD .EQ. 10) THEN
         DO 100 I=1,NUMOBS
            XL(I,1) = 1.D0
            XL(I,2) = PER(I)
            XL(I,3) = DLOG(FLOW(I)) - LQCENT
            XL(I,4) = XL(I,3)*PER(I)
 100      CONTINUE
      ELSEIF (NMOD .EQ. 11) THEN
         DO 110 I=1,NUMOBS
            XL(I,1) = 1.D0
            XL(I,2) = PER(I)
            XL(I,3) = DLOG(FLOW(I)) - LQCENT
            XL(I,4) = XL(I,3)*PER(I)
            XL(I,5) = XL(I,3)**2
            XL(I,6) = XL(I,5) * PER(I)
 110     CONTINUE
      ELSEIF (NMOD .EQ. NMODELS) THEN
         DO 130 I=1,NUMOBS
            XL(I,1) = 1.D0
            DO 120 J=2,NEXPL+1
               XL(I,J) = TRANSF(DVNAME(J-1),TRANS(J-1),DECTIM(I),
     &                          FLOW(I),ADDL(1,I),LQCENT)
 120        CONTINUE
 130     CONTINUE
      ENDIF

      RETURN
      END


! File: DBM_PHYS.f95
!
! Discrete Bubble Model Physics Equations from Clift et al. (1978)
!
! These subroutines compute the governing non-dimensional parameters, slip
! velocity equations, and equations for mass transfer coefficient based on
! models described in Clift et al. (1978).
!
! REQUIRES:
!     None.
!
! Complies in Mac OSX using:
!     f2py -c -m dbm dbm.f95
!
! S. Socolofsky
! June 2013
! Texas A&M University

module Phys_Constants

    ! Define constants for use by the Discrete Bubble Model
    implicit none
    integer, parameter :: DP = 8
    real(kind = DP), parameter :: G = 9.81D0, PI = 3.141592653589793D0

end module Phys_Constants

! ----------------------------------------------------------------------------
! Governing Non-dimensional Variables
! ----------------------------------------------------------------------------

subroutine eotvos(de, rho_p, rho, sigma, &
    &             Eo)

    !
    ! Calculate the Eotvos number per Clift et al. page 26
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     rho_p = dispersed phase density (kg/m^3)
    !     rho = continuous phase density (kg/m^3)
    !     sigma = interfacial tension (N/m)
    !
    ! Returns the non-dimensional Eo number
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    real(kind = DP), intent(in) :: de, rho_p, rho, sigma
    real(kind = DP), intent(out) :: Eo

    Eo = G * (rho - rho_p) * de**2 / sigma

end subroutine eotvos

subroutine morton(rho_p, rho, mu, sigma, &
    &             M)

    !
    ! Calculate the Morton number per Clift et al. page 26
    !
    ! Input variables:
    !     rho_p = dispersed phase density (kg/m^3)
    !     rho = continuous phase density (kg/m^3)
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !     sigma = interfacial tension (N/m)
    !
    ! Returns the non-dimensional M number
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    real(kind = DP), intent(in) :: rho_p, rho, mu, sigma
    real(kind = DP), intent(out) :: M

    M = G * mu**4 * (rho - rho_p) / (rho**2 * sigma**3)

end subroutine morton

subroutine reynolds(de, us, rho, mu, &
    &               Re)

    !
    ! Calculate the Reynolds number per Clift et al. page 26
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     us = slip velocity of the dispersed phase (m/s)
    !     rho = continuous phase density (kg/m^3)
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !
    ! Returns the non-dimensional Re number
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    real(kind = DP), intent(in) :: de, us, rho, mu
    real(kind = DP), intent(out) :: Re

    Re = rho * de * us / mu

end subroutine reynolds

subroutine h_parameter(Eo, M, mu, &
    &                  H)

    !
    ! Calculate H in equation (7-7) of Clift et al. page 176
    !
    ! Input variables:
    !     Eo = non-dimensional Eotvos number
    !     M = non-dimensional Morton number
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !
    ! Returns the non-dimensional parameter H in equation (7-7) of Clift et
    ! al. 1978 page 176
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    real(kind = DP), intent(in) :: Eo, M, mu
    real(kind = DP), intent(out) :: H

    H = 4.0D0 / 3.0D0 * Eo * M**(-0.149D0) * (mu / 0.0009D0)**(-0.14D0)

end subroutine h_parameter

! ----------------------------------------------------------------------------
! Slip velocity and shape functions
! ----------------------------------------------------------------------------

subroutine particle_shape(de, rho_p, rho, mu, sigma, &
    &                     shape_p)

    !
    ! Calculate the shape of a fluid particle
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     rho_p = dispersed phase density (kg/m^3)
    !     rho = continuous phase density (kg/m^3)
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !     sigma = interfacial tension (N/m)
    !
    ! Returns an integer flag:
    !     1 : sphere
    !     2 : ellipsoid
    !     3 : spherical cap
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    real(kind = DP), intent(in) :: de, rho_p, rho, mu, sigma
    integer, intent(out) :: shape_p

    ! Declare the variables internal to the subroutine
    real(kind = DP) :: Eo, M, H

    ! Calculate the non-dimensional variables
    call eotvos(de, rho_p, rho, sigma, Eo)
    call morton(rho_p, rho, mu, sigma, M)
    call h_parameter(Eo, M, mu, H)

    ! Select the appropriate shape classification
    if (H < 2.0D0) then
        shape_p = 1
    else if (Eo < 40.0D0 .and. M < 0.001D0 .and. H < 1000.0D0) then
        shape_p = 2
    else
        shape_p = 3
    end if

end subroutine particle_shape

subroutine theta_w_sc(de, us, rho, mu, &
    &                 theta_w)

    !
    ! Compute the wake angle for a spherical cap bubble
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     us = slip velocity of the dispersed phase (m/s)
    !     rho = continuous phase density (kg/m^3)
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !
    ! Returns the wake angle (rad) for a spherical cap bubble using equation
    ! (8-1) in Clift et al. (1978) p. 204.
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    real(kind = DP), intent(in) :: de, us, rho, mu
    real(kind = DP), intent(out) :: theta_w

    ! Declare the variables internal to the subroutine
    real(kind = DP) :: Re

    ! Get the Reynolds number
    call reynolds(de, us, rho, mu, Re)

    ! Return the wake angle
    theta_w = PI * (50.0D0 + 190.0D0 * exp(-0.62D0 * Re**(0.4D0))) / 180.0D0

end subroutine theta_w_sc

subroutine surface_area_sc(de, theta_w, &
    &                      area)

    !
    ! Compute the surface area for a spherical cap fluid particle
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     theta_w = wake angle for the partial sphere model (rad)
    !
    ! Returns the surface area (m^2) of a spherical cap fluid particle per the
    ! model sketched in figure 8.1 of Clift et al. (1978) p. 204.
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    real(kind = DP), intent(in) :: de, theta_w
    real(kind = DP), intent(out) :: area

    ! Declare the variables internal to the subroutine
    real(kind = DP) :: V, r_sc, Af, Ar

    ! Match the volume
    V = 4.0D0 / 3.0D0 * PI * (de / 2.0D0)**3

    ! Find the radius at the bottom of the partial sphere
    r_sc = (V / PI / (2.0D0 / 3.0D0 - cos(theta_W) + cos(theta_W)**3 / &
         & 3.0D0))**(1.0D0 / 3.0D0)

    ! Surface area of the frontal sphere
    Af = 2.0D0 * PI * r_sc**2 * (1.0D0 - cos(theta_W))

    ! Surface area of the real bottom of the partial sphere
    Ar = PI * (r_sc * sin(theta_W))**2

    ! Return the surface area
    area = Af + Ar

end subroutine surface_area_sc

subroutine surface_area_sphere(de, &
    &                          area)

    !
    ! Compute the surface area for a spherical cap fluid particle
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     theta_w = wake angle for the partial sphere model (rad)
    !
    ! Returns the surface area (m^2) of a spherical cap fluid particle per the
    ! model sketched in figure 8.1 of Clift et al. (1978) p. 204.
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    real(kind = DP), intent(in) :: de
    real(kind = DP), intent(out) :: area

    ! Return the surface area
    area = PI * de**2

end subroutine surface_area_sphere

subroutine us_sphere(de, rho_p, rho, mu, &
    &                u_slip)

    !
    ! Compute the slip velocity of a rigid sphere
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     rho_p = dispersed phase density (kg/m^3)
    !     rho = continuous phase density (kg/m^3)
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !
    ! Returns the slip velocity (m/s) of a rigid spherical particle per
    ! equation (5-15) and following in Clift et al. (1978) p. 133ff.
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    real(kind = DP), intent(in) :: de, rho_p, rho, mu
    real(kind = DP), intent(out) :: u_slip

    ! Declare the variables internal to the subroutine
    real(kind = DP) :: Nd, W, Re

    ! Compute the non-dimensional independent parameters
    Nd = 4.0D0 * rho * abs(rho - rho_p) * G * de**3 / (3.0D0 * mu**2)
    W = log10(Nd)

    ! Compute the Reynolds number from the correlations
    if (Nd <= 73.0D0) then
        Re = (Nd / 24.0D0 - 1.7569D-4 * Nd**2 + 6.9252D-7 * Nd**3 &
           &  - 2.3027D-10 * Nd**4)
    else if (Nd <= 580.0D0) then
        Re = 10.0D0**(-1.7095D0 + 1.33438D0 * W - 0.11591D0 * W**2)
    else if (Nd <= 1.55D7) then
        Re = 10.0D0**(-1.81391D0 + 1.34671D0 * W - 0.12427D0 * W**2 + &
           & 0.006344D0 * W**3)
    else if (Nd <= 5.0D10) then
        Re = 10.0D0**(5.33283D0 - 1.21728D0 * W + 0.19007D0 * W**2 - &
           & 0.007005D0 * W**3)
    else
        print *, "US_SPHERE: Outside range of Nd -- RE set to zero"
        Re = 0.0D0
    end if

    ! Return the slip velocity
    u_slip = mu / (rho * de) * Re

end subroutine us_sphere

subroutine us_ellipsoid(de, rho_p, rho, mu_p, mu, sigma, status, &
    &                   u_slip)

    !
    ! Compute the slip velocity of an elliptical-wobbling fluid particle
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     rho_p = dispersed phase density (kg/m^3)
    !     rho = continuous phase density (kg/m^3)
    !     mu_p = dynamic viscosity of the dispersed phase (Pa s)
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !     sigma = interfacial tension (N/m)
    !     status = flag indicating whether the interface is clean (status = 1)
    !              or dirty (status = -1)
    !
    ! Returns the slip velocity (m/s) of an elliptical-wobbling fluid
    ! particle per equation (7-4) and following in Clift et al. (1978)
    ! p. 175ff.
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    integer, intent(in) :: status
    real(kind = DP), intent(in) :: de, rho_p, rho, mu_p, mu, sigma
    real(kind = DP), intent(out) :: u_slip

    ! Declare the variables internal to the subroutine
    real(kind = DP) :: Eo, M, H, J, Re, us_dirty, kappa, xi, gamma

    ! Calculate the non-dimensional variables
    call eotvos(de, rho_p, rho, sigma, Eo)
    call morton(rho_p, rho, mu, sigma, M)
    call h_parameter(Eo, M, mu, H)

    ! Compute the correlation equations
    if (H > 59.3D0) then
        J = 3.42D0 * H**(0.441D0)
    else
        J = 0.94D0 * H**(0.757D0)
    end if

    ! Calculate the Reynolds number
    Re = M**(-0.149D0) * (J - 0.857D0)

    ! Compute the dirty-bubble the slip velocity
    us_dirty =  mu / (rho * de) * Re

    ! Return the correct slip velocity
    if (status > 0) then
        ! Compute the clean-bubble correction from Figure 7.7 and Eqn. 7-10 in
        ! Clift et al. (1978)
        kappa = mu_p / mu
        xi = Eo * (1.0D0 + 0.15D0 * kappa) / (1.0D0 + kappa)
        gamma = 2.0D0 * exp( -(log10(Xi) + 0.6383D0)**2 / &
              & (0.2598D0 + 0.2D0*(log10(Xi) + 1.0D0))**2 )
        u_slip = us_dirty * (1.0D0 + gamma/(1.0D0 + kappa))
    else
        u_slip = us_dirty
    end if

end subroutine us_ellipsoid

subroutine us_spherical_cap(de, rho_p, rho, &
    &                       u_slip)

    !
    ! Compute the slip velocity of a spherical cap fluid particle
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     rho_p = dispersed phase density (kg/m^3)
    !     rho = continuous phase density (kg/m^3)
    !
    ! Returns the slip velocity (m/s) of a spherical cap fluid particle using
    ! equation (8-11) in Clift et al. (1978) p. 206.  This is the equation
    ! also suggested by Zheng and Yapa (2000).  This is strictly valid for
    ! Re > 150 and Eo > 40, though these limits are not tested here.
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    real(kind = DP), intent(in) :: de, rho_p, rho
    real(kind = DP), intent(out) :: u_slip

    u_slip = 0.711D0 * sqrt(G * de * (rho - rho_p) / rho)

end subroutine  us_spherical_cap

! ----------------------------------------------------------------------------
! Mass Transfer Coefficients
! ----------------------------------------------------------------------------

subroutine xfer_kumar_hartland(de, us, rho, mu, D, sigma, mu_p, nc, &
    &                          beta)

    !
    ! Compute the mass transfer coefficient for clean fluid particles
    !
    ! Computes the mass transfer coefficients for clean fluid particles
    ! following the formulas in Kumar and Hartland (1999), "Correlations for
    ! prediction of mass transfer coefficients in single drop systems and
    ! liquid-liquid extraction columns," Trans. IChemE., 77, Part A, 372--
    ! 384.
    !
    ! This equation performs similarly to the Johnson et al. (1969) equation
    ! in the ellipsoidal bubble regime and for large spherical particles and
    ! follows the Clift et al. (1978) formulation for solid particles for
    ! smaller spherical particles.  For small spherical particles, the Johnson
    ! et al. (1969) formula gets very small; hence, either the Clift et al.
    ! (1978) or the Kumar and Hartland (1999) equations are preferred for
    ! small spherical particles.
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     us = slip velocity of the dispersed phase (m/s)
    !     rho = continuous phase density (kg/m^3)
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !     D = diffusion coefficients of the dispersed phase components in the
    !         continuous phase fluid (m^2/s)
    !     sigma = interfacial tension between seawater and the dispersed
    !             phase (N/m)
    !     mu_p = viscosity of the dispersed phase (Pa s)
    !     nc = number of tracked dispersed phase chemical components
    !
    ! Returns the mass transfer coefficients (m/s) for each component in the
    ! dispersed phase (assuming rigid spheres).
    !
    ! S. Socolofsky
    ! June 2015
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    integer, intent(in) :: nc
    real(kind = DP), intent(in) :: de, us, rho, mu, sigma, mu_p
    real(kind = DP), intent(in), dimension(nc) :: D
    real(kind = DP), intent(out), dimension(nc) :: beta

    ! Declare the variables internal to the subroutine
    real(kind = DP) :: C1, C2, n1, n2, n3, n4, Re
    real(kind = DP), dimension(nc) :: Sc, Pe, Sh_rigid, Sh_infty, lambda, Sh

    ! Compute the Reynolds, Schmidt, and Peclet numbers
    Re = de * us * rho / mu
    Sc(:) = mu / (rho * D(:))
    Pe(:) = de * us / D(:)

    ! Constants for the formulas
    C1 = 50.0D0
    C2 = 5.26D-2
    n1 = (1.0D0 / 3.0D0) + 6.59D-2 * Re**0.25D0
    n2 = 1.0D0 / 3.0D0
    n3 = 1.0D0 / 3.0D0
    n4 = 1.1D0

    ! Compute equation 16
    Sh_rigid(:) = 2.43D0 + 0.775D0 * Re**0.5D0 * Sc(:)**n2 + 0.0103D0 * Re &
        &         * Sc(:)**n2

    ! Compute equation 50
    Sh_infty(:) = C1 + 2.0D0 / sqrt(PI) * Pe(:)**0.5D0

    ! Compute lambda as the RHS of equation 51
    lambda(:) = C2 * Re**n1 * Sc(:)**n2 * (us * mu / sigma)**n3 * 1.0D0 / &
        &    (1.0D0 + (mu_p / mu)**n4)

    ! Compute the in situ Sherwood number
    Sh(:) = (Sh_infty(:) * lambda(:) + Sh_rigid(:)) / (1.0D0 + lambda(:))

    ! Convert Sherwood number to mass transfer coefficient
    beta(:) = Sh(:) * D(:) / de

end subroutine xfer_kumar_hartland

subroutine xfer_johnson(de, us, D, nc, &
    &                   beta)

    ! Compute the mass transfer coefficient for clean particles
    !
    ! Computes the mass transfer coefficient for clean particles given by
    ! equation (42) in Johnson et al. (1969), Canadian Journal of Chemical
    ! Engineering, vol. 47, pp. 559-564.
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     us = slip velocity of the dispersed phase (m/s)
    !     D = diffusion coefficients of the dispersed phase components in the
    !         continuous phase fluid (m^2/s)
    !     nc = number of tracked dispersed phase chemical components
    !
    ! S. Socolofsky
    ! June 2015
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    integer, intent(in) :: nc
    real(kind = DP), intent(in) :: de, us
    real(kind = DP), intent(in), dimension(nc) :: D
    real(kind = DP), intent(out), dimension(nc) :: beta

    ! Compute equation (42) in Johnson et al. (1969)
    beta(:) = 1.13D0 * sqrt(D(:) * us * 100.0D0**3 / (0.45D0 + &
            & 0.2D0 * de * 100.0D0)) / 100.0D0

end subroutine xfer_johnson

subroutine xfer_clift(de, us, rho, mu, D, nc, &
    &                 beta)

    !
    ! Compute the mass transfer coefficients for a rigid sphere
    !
    ! Computes the mass transfer coefficients for a rigid sphere in water from
    ! equations in Clift et al. (1978).  For Re < 1, uses equation (3-49) on
    ! page 49 for creeping flow past a sphere.  For higher Reynolds numbers,
    ! for Re < 100, equation (5-25) page 121 is used; for Re < 1e5, equations
    ! in Table 5.4 on page 123 are used.  All of these equations assume high
    ! Schmidt number.
    !
    ! These equations may be used for fluid particles in contaminated systems
    ! when slight impurities result in the bubble or droplet having no
    ! internal circulations.
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     us = slip velocity of the dispersed phase (m/s)
    !     rho = continuous phase density (kg/m^3)
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !     D = diffusion coefficients of the dispersed phase components in the
    !         continuous phase fluid (m^2/s)
    !     status = flag indicating whether the interface is clean (status = 1)
    !              or dirty (status = -1)
    !     nc = number of tracked dispersed phase chemical components
    !
    ! Returns the mass transfer coefficients (m/s) for each component in the
    ! dispersed phase.
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    integer, intent(in) :: nc
    real(kind = DP), intent(in) :: de, us, rho, mu
    real(kind = DP), intent(in), dimension(nc) :: D
    real(kind = DP), intent(out), dimension(nc) :: beta

    ! Declare the variables internal to the subroutine
    integer :: i
    real(kind = DP) :: Re
    real(kind = DP), dimension(nc) :: Sc, Pe, Sh

    ! Compute the non-dimensional governing parameters
    Sc = mu / (rho * D)
    Pe = us * de / D
    call reynolds(de, us, rho, mu, Re)

    ! Compute the Sherwood Number
    do i = 1, nc
        if (D(i) > 0.0D0) then
            if (Re < 1.0D0) then
                Sh(i)  = 1.0D0 + (1.0D0 + Pe(i))**(1.0D0/3.0D0)
            else if (Re < 100.0D0) then
                Sh(i) = 1.0D0 + (1.0D0 + 1.0D0 / Pe(i))**(1.0D0/3.0D0) * &
                    & Re**0.41D0 * Sc(i)**(1.0D0/3.0D0)
            else if (Re < 2000.0D0) then
                Sh(i) = 1.0D0 + 0.724D0 * Re**(0.48D0) * Sc(i)**(1.0D0/3.0D0)
            else
                Sh(i) = 1.0D0 + 0.425D0 * Re**0.55D0 * Sc(i)**(1.0D0/3.0D0)
            end if
        else
            Sh(i) = 0.0D0
        end if
    end do

    ! Return the mass transfer coefficient
    beta(:) = Sh(:) * D(:) / de

end subroutine xfer_clift

subroutine xfer_sphere(de, us, rho, mu, D, sigma, mu_p, fp_type, status, nc, &
    &                  beta)

    !
    ! Compute the mass transfer coefficients for a spherical fluid particle
    !
    ! This function computes the mass transfer for a spherical fluid particle
    ! using equations in Johnson et al. (1969) for clean bubbles and equations
    ! for solid particles in Clift et al. (1978) for dirty bubbles.
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     us = slip velocity of the dispersed phase (m/s)
    !     rho = continuous phase density (kg/m^3)
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !     D = diffusion coefficients of the dispersed phase components in the
    !         continuous phase fluid (m^2/s)
    !     sigma = interfacial tension between seawater and the dispersed
    !             phase (N/m)
    !     mu_p = viscosity of the dispersed phase (Pa s)
    !     fp_type = flag indicating whether the fluid is 0: gas or 1:
    !               liquid.
    !     nc = number of tracked dispersed phase chemical components
    !
    ! Returns the mass transfer coefficients (m/s) for each component in the
    ! dispersed phase (assuming rigid spheres).
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    integer, intent(in) :: nc, fp_type, status
    real(kind = DP), intent(in) :: de, us, rho, mu, sigma, mu_p
    real(kind = DP), intent(in), dimension(nc) :: D
    real(kind = DP), intent(out), dimension(nc) :: beta

    ! Declare the variables internal to the subroutine
    integer :: i
    real(kind = DP), dimension(nc) :: beta_j, beta_c

    ! Compute the correct mass transfer coefficients
    if (status > 0) then
        if (fp_type > 0) then
            ! This is a liquid particle: use Kumar and Hartland
            call xfer_kumar_hartland(de, us, rho, mu, D, sigma, mu_p, nc, &
                &                    beta)
        else
            ! This is gas: use larger of Johnson or Clift
            call xfer_johnson(de, us, D, nc, beta_j)
            call xfer_clift(de, us, rho, mu, D, nc, beta_c)

            ! For small particles, the Johnson formula is too low
            do i = 1, nc
                if (beta_j(i) > beta_c(i)) then
                    ! Johnson is ok
                    beta(i) = beta_j(i)
                else
                    ! Clift is better
                    beta(i) = beta_c(i)
                end if
            end do
        end if
    else
        call xfer_clift(de, us, rho, mu, D, nc, beta)
    end if

end subroutine xfer_sphere

subroutine xfer_ellipsoid(de, us, rho, mu, D, sigma, mu_p, fp_type, status, &
    &                     nc, &
    &                     beta)

    !
    ! Compute the mass transfer coefficients for an ellipsoidal fluid particle
    !
    ! Clift is not very clear on what equations should be used for ellipsoidal
    ! fluid particles (drops and bubbles), but indicates that in contaminanted
    ! liquids, the mass transfer is close to that of rigid particles (i.e.,
    ! there is no internal circulation due to the contamination).  Thus, this
    ! subroutine currently returns the result for rigid spheres if the
    ! particles are dirty.  For clean fluid particles, this function returns
    ! the result from equation (42) in Johnson et al. (1969).
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     us = slip velocity of the dispersed phase (m/s)
    !     rho = continuous phase density (kg/m^3)
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !     D = diffusion coefficients of the dispersed phase components in the
    !         continuous phase fluid (m^2/s)
    !     sigma = interfacial tension between seawater and the dispersed
    !             phase (N/m)
    !     mu_p = viscosity of the dispersed phase (Pa s)
    !     status = flag indicating whether the interface is clean (status = 1)
    !              or dirty (status = -1)
    !     nc = number of tracked dispersed phase chemical components
    !
    ! Returns the mass transfer coefficients (m/s) for each component in the
    ! dispersed phase (assuming rigid spheres).
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    integer, intent(in) :: status, fp_type, nc
    real(kind = DP), intent(in) :: de, us, rho, mu, sigma, mu_p
    real(kind = DP), intent(in), dimension(nc) :: D
    real(kind = DP), intent(out), dimension(nc) :: beta

    ! Declare the variables internal to the subroutine
    integer :: i
    real(kind = DP), dimension(nc) :: beta_j, beta_c

    ! Compute the correct mass transfer coefficients
    if (status > 0) then
        if (fp_type > 0) then
            ! This is a liquid particle: use Kumar and Hartland
            call xfer_kumar_hartland(de, us, rho, mu, D, sigma, mu_p, nc, &
                &                    beta)
        else
            ! This is gas: use larger of Johnson or Clift
            call xfer_johnson(de, us, D, nc, beta_j)
            call xfer_clift(de, us, rho, mu, D, nc, beta_c)

            ! For small particles, the Johnson formula is too low
            do i = 1, nc
                if (beta_j(i) > beta_c(i)) then
                    ! Johnson is ok
                    beta(i) = beta_j(i)
                else
                    ! Clift is better
                    beta(i) = beta_c(i)
                end if
            end do
        end if
    else
        call xfer_clift(de, us, rho, mu, D, nc, beta)
    end if

end subroutine xfer_ellipsoid

subroutine xfer_spherical_cap(de, us, rho, rho_p, mu, D, status, nc, &
    &                         beta)

    !
    ! Compute the mass transfer coefficients for spherical cap fluid particles
    !
    ! Computes the mass transfer coefficient for spherical-cap bubbles or
    ! droplets.  If the particles are clean, it uses equation (42) in
    ! Johnson et al. (1969).  If the particles are dirty, it uses equation
    ! (8-28) in Clift et al. (1978), p. 214.
    !
    ! Input variables:
    !     de = equivalent spherical diameter (m)
    !     us = slip velocity of the dispersed phase (m/s)
    !     rho = continuous phase density (kg/m^3)
    !     rho_p = dispersed phase density (kg/m^3)
    !     mu = dynamic viscosity of the continuous phase (Pa s)
    !     D = diffusion coefficients of the dispersed phase components in the
    !         continuous phase fluid (m^2/s)
    !     status = flag indicating whether the interface is clean (status = 1)
    !              or dirty (status = -1)
    !     nc = number of tracked dispersed phase chemical components
    !
    ! Returns the mass transfer coefficients (m/s) for each component in the
    ! dispersed phase.
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Phys_Constants
    implicit none

    ! Declare the input and output variable types
    integer, intent(in) :: status, nc
    real(kind = DP), intent(in) :: de, us, rho, rho_p, mu
    real(kind = DP), intent(in), dimension(nc) :: D
    real(kind = DP), intent(out), dimension(nc) :: beta

    ! Declare the variables internal to the subroutine
    real(kind = DP) :: theta_w, A, Ae

    ! Compute the correct mass transfer coefficients
    if (status > 0) then
        ! Use the Johnson et al. (1969) equation for clean bubbles
        call xfer_johnson(de, us, D, nc, beta)

    else
        ! Use the Clift et al. (1978) equation for spherical cap bubbles
        ! Compute the wake angle for the partial sphere model (equation 8-1)
        call theta_w_sc(de, us, rho, mu, theta_w)

        ! Compute the surface area of the spherical cap and equivalent sphere
        call surface_area_sc(de, theta_w, A)
        Ae = 4.0D0 * PI * (de / 2.0D0)**2

        ! Compute the mass transfer (equation 8-28)
        beta = (1.25D0 * (G * (rho - rho_p) / rho)**(0.25D0) * sqrt(D(:)) / &
             & de**(0.25D0)) * Ae / A

    end if

end subroutine xfer_spherical_cap

! End File: DBM_PHYS.f95


program problem25
  implicit none
  integer, parameter       :: m=52 ! 64*52=3328 bits is sufficient
  integer*16, parameter    :: magic=27421685952577297_16 ! 10^999 / ((2^64)^51)
  integer*16, dimension(m) :: f1,f2
  integer                  :: i

  f1(1)=1
  f2(1)=1
  do i=2,m
     f1(i)=0
     f2(i)=0
  end do

  ! Calculate fibonacci numbers until one is found that is greater
  ! than 10^999 (the first number with one thousand digits).
  i=2
  do while (f1(m) <= magic .and. f2(m) <= magic)
     if (mod(i,2) == 0) then
        call add(f1,f2)
     else
        call add(f2,f1)
     end if
     i=i+1
  end do

  ! Report result
  if (mod(i,2) == 1) then
     print *, f1
  else
     print *, f2
  end if
  print *, i

contains
  subroutine add(f1,f2)
    implicit none
    integer*16, parameter    :: mask=lshift(1_16,64)-1
    integer*16, dimension(m) :: f1,f2
    integer*16               :: temp
    integer                  :: i

    do i=1,m
       f1(i)=f1(i)+f2(i)       ! add
       temp=rshift(f1(i),64)
       f1(i)=iand(f1(i),mask)  ! start carry ...
       if (i < m) then
          f1(i+1)=f1(i+1)+temp ! ... finish carry
       end if
    end do

  end subroutine add

end program problem25


SUBROUTINE spabac_gauss(kv,loads,kdiag)
!
! This subroutine performs Gaussian forwrad and back-substitution on a
! skyline matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kv(:)
 REAL(iwp),INTENT(IN OUT)::loads(0:)
 INTEGER,INTENT(IN)::kdiag(:)
 REAL(iwp)::num,den,fac,asum,zero=0.0_iwp
 INTEGER::i,j,l,n,ii,jj,l1,l2
 n=UBOUND(kdiag,1)
 DO j=1,n-1
   den=kv(kdiag(j))
   ii=0
   DO i=j+1,n
     ii=ii+1
     l=kdiag(i)-ii
     IF(l-kdiag(i-1)>zero)THEN
       num=kv(l)
       fac=num/den
       loads(i)=loads(i)-fac*loads(j)
     END IF
   END DO
 END DO
 loads(n)=loads(n)/kv(kdiag(n))
 DO i=n-1,1,-1
   jj=0
   asum=zero
   DO j=i+1,n
     jj=jj+1
     l1=kdiag(i+jj)-jj
     l2=kdiag(i+jj-1)
     IF(l1-l2>zero)asum=asum+kv(l1)*loads(j)
   END DO
   loads(i)=(loads(i)-asum)/kv(kdiag(i))
 END DO
RETURN
END SUBROUTINE spabac_gauss


      double precision function DCDNML (X, MU, SIGMA)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 DCDNML Krogh  Moved external statement up for mangle.
c>> 1994-10-20 DCDNML Krogh  Changes to use M77CON
c>> 1994-08-05 DCDNML WV Snyder
c
c     Compute the Cumulative Distribution Function for the Normal
c     (Gaussian) distribution, g(x;mu,sigma).  This is given in terms of
c     erf by g(x;mu,sigma) = (1 + erf((x-mu) / (sqrt(2)*sigma)) ) / 2 =
c     1 - erfc((x-mu) / (sqrt(2)*sigma)) / 2.  To avoid cancellation
c     error when (X-MU) < 0, substitute erfc(z) = 2 - erfc(-z) in the
c     second expression above to get g(-x;mu,sigma) = erfc((mu-x) /
c     (sqrt(2)*sigma)) / 2.  This also works well when (X-MU) >= 0.
c
      double precision X, MU, SIGMA
c--D replaces "?": ?CDNML, ?ERFC
      external D1MACH, DERFC
      double precision BIG, RSQT2, D1MACH, S, DERFC, U
c     BIG is the largest representable number.
c     RSQT2 = 1.0 / sqrt(2.0)
      parameter (RSQT2 = 0.707106781186547524400844362104849039284836d0)
      save BIG
      data BIG /-1.0d0/
c
      if (big .lt. 0.0d0) big = d1mach(2)
      u = (mu-x)*rsqt2
      s = abs(sigma)
      if (s .lt. 1.0d0) then
         if (u .gt. s * big) then
            dcdnml = 1.0d0
            return
         end if
      end if
      dcdnml = 0.5d0 * derfc(u/s)
      return
      end


        SUBROUTINE FE5(N,X,Y,F,RPAR,IPAR)
C --- RIGHT-HAND SIDE OF E5 PROBLEM
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),F(N)
        PROD1=7.89D-10*Y(1)
        PROD2=1.1D7*Y(1)*Y(3)
        PROD3=1.13D9*Y(2)*Y(3)
        PROD4=1.13D3*Y(4)
        F(1)=-PROD1-PROD2
        F(2)=PROD1-PROD3
        F(4)=PROD2-PROD4
        F(3)=F(2)-F(4)
        RETURN
        END
C
        SUBROUTINE JE5(N,X,Y,DFY,LDFY,RPAR,IPAR)
C --- JACOBIAN OF E5 PROBLEM
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),DFY(LDFY,N)
        A=7.89D-10
        B=1.1D7
        CM=1.13D9
        C=1.13D3
        DFY(1,1)=-A-B*Y(3)
        DFY(1,2)=0.D0
        DFY(1,3)=-B*Y(1)
        DFY(1,4)=0.D0
        DFY(2,1)=A
        DFY(2,2)=-CM*Y(3)
        DFY(2,3)=-CM*Y(2)
        DFY(2,4)=0.D0
        DFY(3,1)=A-B*Y(3)
        DFY(3,2)=-CM*Y(3)
        DFY(3,3)=-B*Y(1)-CM*Y(2)
        DFY(3,4)=C
        DFY(4,1)=B*Y(3)
        DFY(4,2)=0.D0
        DFY(4,3)=B*Y(1)
        DFY(4,4)=-C
        RETURN
        END


program try_matz
use M_matrix, only : lala, get_from_lala, put_into_lala, ifin_lala
implicit none
integer,parameter             :: lda=10
integer                       :: m,n, i,j, ierr
doubleprecision               :: arr(lda,lda)
real                          :: vec(lda)
integer                       :: ivec(lda)
integer                       :: whole
character(len=:),allocatable  :: string
character(len=:),allocatable  :: strings(:)
doubleprecision,allocatable   :: dble_array(:,:)
doubleprecision,allocatable   :: dble_vector(:)
doubleprecision,allocatable   :: scalar

   ! pass some commands to lala
   call lala( 'b=<1 2 3 4; 5 6 7 8>;') ! create some values in lala(3f)
   ! the commands may be an array
   call lala( [character(len=80) :: &
    & 'a=magic(4);', &
    & 'c=3**3;', &
    & 'FRED=3**3;', &
    & ''])
    write(*,*)'a',ifin_lala('a')
    write(*,*)'b',ifin_lala('b')
    write(*,*)'c',ifin_lala('c')
    write(*,*)'d',ifin_lala('d')
    write(*,*)'reallylongname_reallylongname_really_long_name_really_longname', &
    & ifin_lala('reallylongname_reallylongname_really_long_name_really_longname')
    write(*,*)'///',ifin_lala('///')

   RUN: block
       ! put some values from the program into lala
       ! note not testing ierr
       call put_into_lala('C',(30.0,40.0),ierr) ! a complex scalar
       call put_into_lala('I',20,ierr)          ! an integer scalar
       call put_into_lala('R',10.0,ierr)        ! a real scalar
       ivec=[000,100,200,300,400,500,600,700,800,900]
       call put_into_lala('IVEC',ivec,ierr)     ! an integer vector
       vec=[0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0]
       call put_into_lala('VEC',vec,ierr)       ! a real vector
       call put_into_lala('string',"this is a string",ierr) ! string
       call put_into_lala('strings', &
       & [character(len=30) ::     &
       & "this is a string",       &
       & "this is another string"] &
       & ,ierr) ! string array

       ! now this program generates an array
       do i=1,lda
          do j=1,lda
             arr(i,j)=(i-1)*lda+j
          enddo
       enddo

       write(*,*)'THE ORIGINAL ARR ARRAY IN THE USER PROGRAM'
       dble_array=arr;call checkit

       ! The matrix ARR is sent to the lala() stack
       call put_into_lala('ARR',arr,ierr)

       if (ierr .ne. 0) then
          write(*,*)'<ERROR> could not store array, ERR=',ierr
          exit run
       endif

       ! The call to lala() will transpose our matrix, put the result
       ! X on the stack and go back to our program.
       call lala([character(len=80) :: &
       & "X=ARR';", &
       & "// ARR,R,C,I,IVEC,VEC,display(string),display(strings)'", &
       & 'who', &
       & ''])

       ! now enter lala() interactively to look around
       ! once interactive mode is exited get some values back out of lala()
       write(*,*)'entering interactive mode. Enter "help" for a description'
       write(*,*)'Entering "return" will return back to the main program.'
       call lala()

       ! at least for now, return values should be allocatable, primarily
       ! because lala() can change the sive of arrays. Might change this
       ! of make another procedure that fails unless the requested array
       ! matches in size.
       call get_from_lala('a',dble_array,ierr); call checkit()

       call get_from_lala('b',dble_array,ierr); call checkit()
       call get_from_lala('b',dble_vector,ierr); write(*,*)'as a vector',dble_vector

       call get_from_lala('c',dble_array,ierr); call checkit()
       call get_from_lala('unknown',dble_array,ierr); call checkit()
       write(*,*)'ARR retrieved'
       call get_from_lala('ARR',dble_array,ierr=ierr); call checkit()
       !NO: NOT FIXED SIZE:call get_from_lala('ARR',ARR,err=ierr); call checkit()
       write(*,*)'X retrieved'
       call get_from_lala('X',dble_array,ierr=ierr); call checkit()
       call get_from_lala('c',whole,ierr); write(*,*)'as a scalar',whole
       call get_from_lala('string',string,ierr); write(*,*)string
       call get_from_lala('strings',strings,ierr); write(*,'(a)')strings
       call get_from_lala('strings',strings,ierr); write(*,*)'strings(2)=',strings(2)

       ! The next call to lala() will again place you in interactive mode in lala().
       ! Entering "return" will return back to the main program.
       call lala()

   endblock RUN
contains

subroutine checkit()
integer                       :: m,n
   if (ierr .ne. 0)then
      write(*,*)'<ERROR> retrieving variable, ERR=',ierr
   else
      m=size(dble_array,dim=1)
      n=size(dble_array,dim=2)
      write(*,'(*(g0))')'BACK IN THE CALLING PROGRAM. THE VALUES ARE:SIZE:',size(dble_array),':ROWS:',m,':COLS:',n,':IERR:',ierr
      write(*,'(*(g0,1x))')'<INFO>',new_line('A'),(int(dble_array(j,:)),new_line('A'),j=1,m)
   endif
end subroutine checkit

end program try_matz


! =============================================================================
!                       Test subroutine lapinv0
!
!  This unit test checks the subroutine lapinv0.
! =============================================================================
program test_lapinv0_2
    use unit_test
    use options, only : verbose
    use constants, only : zero, one, two, pi, twopi, f12
    use parameters, only : lower, update_parameters, dx, nx, ny, nz, extent, ncell
    use inversion_utils, only : init_fft, fftxyp2s, fftxys2p
    use inversion_mod, only : lapinv0
    implicit none

    !Gridded x component of vorticity (note array order in 3D):
    double precision, allocatable :: vorx(:, :, :)

    !Corresponding potential and exact form:
    double precision, allocatable :: potx(:, :, :), potxe(:, :, :)

    !Spectral work array:
    double precision, allocatable :: ds(:, :, :)

    double precision :: akx, aky, akz  !k, l, m
    double precision :: sikx, siky, sikz
    double precision :: vmult, erms, emax
    integer :: iz, iy, ix

    call parse_command_line

    nx = 32
    ny = 64
    nz = 128
    lower  = (/zero, zero, zero/)
    extent =  (/pi, twopi, two * twopi/)

    call update_parameters

    allocate(vorx(0:nz, ny, nx))
    allocate(potx(0:nz, ny, nx))
    allocate(potxe(0:nz, ny, nx))
    allocate(ds(0:nz, nx, ny))

    !-------------------------------------------------------
    ! Initialise
    call init_fft

    ! Define exact potential and vorticity:
    akx = twopi / extent(1)
    aky = twopi / extent(2)
    akz =    pi / extent(3)
    vmult = -(akx ** 2 + aky ** 2 + akz ** 2)

    do ix = 1, nx
        sikx = dsin(akx * (lower(1) + dx(1) * dble(ix-1)))
        do iy = 1, ny
            siky = dsin(aky * (lower(2) + dx(2) *dble(iy-1)))
            do iz = 0, nz
                sikz = dsin(akz * dx(3) * dble(iz))
                potxe(iz, iy, ix) = sikx * siky * sikz
                vorx(iz, iy, ix) = vmult * potxe(iz, iy, ix)
            enddo
        enddo
    enddo

    !-------------------------------------------------------
    ! Invert vorticity to obtain potential:
    call fftxyp2s(vorx, ds)
    call lapinv0(ds)
    call fftxys2p(ds, potx)

    !-------------------------------------------------------
    ! Check error:
    potx = potx - potxe
    emax = maxval(abs(potx))
    erms = sqrt((f12 * sum(potx(0, :, :) ** 2 + potx(nz,:,:) ** 2) &
                     + sum(potx(1:nz-1, :, :) ** 2) ) / dble(ncell))

    if (verbose) then
        write(*,*)
        write(*,*) ' Max abs error = ', emax
        write(*,*) ' R.m.s.  error = ', erms
        write(*,*)
    endif

    call print_result_dp('Test inversion (lapinv0)', emax, atol=7.0e-7)

    deallocate(vorx)
    deallocate(potx)
    deallocate(potxe)
    deallocate(ds)

end program test_lapinv0_2


function SHPowerL(cilm, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power at
!   degree l corresponding to the 4pi spherical harmonic coefficients \
!   cilm(i, l, m)
!
!   Power = Sum_{m=0}^l ( c1lm**2 + c2lm**2 )
!
!   Calling Parameters
!
!       cilm    Spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       l       Spherical harmonic degree to compute power.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: SHPowerL
    real(dp), intent(in) :: cilm(:,:,:)
    integer(int32), intent(in) :: l
    integer(int32) :: i, m, l1, m1

    l1 = l + 1

    if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < l1 .or. &
            size(cilm(1,1,:)) < l1) then
        print*, "Error --- SHPowerL"
        print*, "CILM must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm(:,1,1)), &
                size(cilm(1,:,1)), size(cilm(1,1,:))
        stop

    end if

    SHPowerL = cilm(1, l1, 1)**2  ! m=0 term

    do m = 1, l, 1
        m1 = m + 1

        do i = 1, 2
            SHPowerL = SHPowerL + cilm(i, l1, m1)**2

        end do

    end do

end function SHPowerL

function SHPowerDensityL(cilm, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power per coefficient
!   (density) at degree l of the 4pi spherical harmonic coefficients
!   cilm(i, l, m)
!
!   PowerSpectralDensity = Sum_{m=0}^l ( c1lm**2 + c2lm**2 ) / (2l+1)
!
!   Calling Parameters
!
!       cilm    Spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       l       Spherical harmonic degree to compute power.
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: SHPowerDensityL
    real(dp), intent(in) :: cilm(:,:,:)
    integer(int32), intent(in) :: l
    integer(int32) :: i, m, l1, m1

    l1 = l + 1

    if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < l1 &
            .or. size(cilm(1,1,:)) < l1) then
        print*, "Error --- SHPowerDensityL"
        print*, "CILM must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm(:,1,1)), &
                size(cilm(1,:,1)), size(cilm(1,1,:))
        stop

    end if

    SHPowerDensityL = cilm(1, l1, 1)**2
    ! m=0 term

    do m = 1, l, 1
        m1 = m + 1

        do i = 1, 2
            SHPowerDensityL = SHPowerDensityL + cilm(i, l1, m1)**2

        end do

    end do

    SHPowerDensityL = SHPowerDensityL / dble(2*l+1)

end function SHPowerDensityL

function SHCrossPowerL(cilm1, cilm2, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power at
!   degree l for the 4pi spherical harmonic coefficients cilm1(i, l, m)
!   and cilm2(i,l,m).
!
!   CrossPower = Sum_{m=0}^l ( c1lm1*c1lm2 + c2lm1*c2lm2 )
!
!   Calling Parameters
!
!       cilm1   Spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       cilm2   Spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       l       Spherical harmonic degree to compute power.
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: SHCrossPowerL
    real(dp), intent(in) :: cilm1(:,:,:), cilm2(:,:,:)
    integer(int32), intent(in) :: l
    integer(int32) :: i, m, l1, m1

    l1 = l + 1

    if (size(cilm1(:,1,1)) < 2 .or. size(cilm1(1,:,1)) < l1 &
            .or. size(cilm1(1,1,:)) < l1) then
        print*, "Error --- SHCrossPowerL"
        print*, "CILM1 must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm1(:,1,1)), &
                size(cilm1(1,:,1)), size(cilm1(1,1,:))
        stop

    else if (size(cilm2(:,1,1)) < 2 .or. size(cilm2(1,:,1)) < l1 &
            .or. size(cilm2(1,1,:)) < l1) then
        print*, "Error --- SHCrossPowerL"
        print*, "CILM2 must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm2(:,1,1)), &
                size(cilm2(1,:,1)), size(cilm2(1,1,:))
        stop

    end if

    SHCrossPowerL = cilm1(1, l1, 1) * cilm2(1,l1,1)

    do m = 1, l, 1
        m1 = m + 1

        do i = 1, 2
            SHCrossPowerL = SHCrossPowerL + cilm1(i,l1,m1) * cilm2(i,l1,m1)

        end do

    end do

end function SHCrossPowerL

function SHCrossPowerDensityL(cilm1, cilm2, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power
!   (density) at degree l of the 4pi spherical harmonic coefficients
!   cilm1(i, l, m) and cilm2(i,l,m).
!
!   CrossPower = Sum_{m=0}^l ( c1lm1*c1lm2 + c2lm1*c2lm2 ) / (2l+1)
!
!   Calling Parameters
!
!       cilm1   Spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       cilm2   Spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       l       Spherical harmonic degree to compute power.
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: SHCrossPowerDensityL
    real(dp), intent(in) :: cilm1(:,:,:), cilm2(:,:,:)
    integer(int32), intent(in) :: l
    integer(int32) :: i, m, l1, m1

    l1 = l + 1

    if (size(cilm1(:,1,1)) < 2 .or. size(cilm1(1,:,1)) < l1 &
            .or. size(cilm1(1,1,:)) < l1) then
        print*, "Error --- SHCrossPowerDensityL"
        print*, "CILM1 must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm1(:,1,1)), &
                size(cilm1(1,:,1)), size(cilm1(1,1,:))
        stop

    else if (size(cilm2(:,1,1)) < 2 .or. size(cilm2(1,:,1)) < l1 &
            .or. size(cilm2(1,1,:)) < l1) then
        print*, "Error --- SHCrossPowerDensityL"
        print*, "CILM2 must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm2(:,1,1)), &
                size(cilm2(1,:,1)), size(cilm2(1,1,:))
        stop

    end if

    SHCrossPowerDensityL = cilm1(1, l1, 1) * cilm2(1,l1,1)

    do m = 1, l, 1
        m1 = m + 1
        do i = 1, 2
            SHCrossPowerDensityL = SHCrossPowerDensityL &
                                   + cilm1(i,l1,m1) * cilm2(i,l1,m1)

        end do

    end do

    SHCrossPowerDensityL = SHCrossPowerDensityL / dble(2*l+1)

end function SHCrossPowerDensityL

subroutine SHPowerSpectrum(cilm, lmax, spectra, exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power spectrum
!   of the 4pi spherical harmonic coefficients cilm(i, l, m).
!
!   Power(l) = Sum_{m=0}^l ( c1lm**2 + c2lm**2 )
!
!   Calling Parameters
!
!       IN
!           cilm        Spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           lmax        Spherical harmonic degree to compute power.
!
!       OUT
!           spectra     Array of length (lmax+1) containing the power
!                       spectra of cilm.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(in) :: cilm(:,:,:)
    integer(int32), intent(in) :: lmax
    real(dp), intent(out) :: spectra(:)
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

    if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 &
            .or. size(cilm(1,1,:)) < lmax+1) then
        print*, "Error --- SHPowerSpectrum"
        print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(cilm(:,1,1)), &
                size(cilm(1,:,1)), size(cilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(spectra) < lmax+1) then
        print*, "Error --- SHPowerSpectrum"
        print*, "SPECTRA must be dimensioned as (LMAX+1) where LMAX is ", lmax
        print*, "Input vector has dimension ", size(spectra)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    spectra = 0.0_dp

    do l = 0, lmax
        l1 = l + 1

        spectra(l1) = cilm(1, l1, 1)**2

        do m = 1, l, 1
            m1 = m + 1

            do i = 1, 2
                spectra(l1) = spectra(l1) + cilm(i, l1, m1)**2

            end do

        end do

    end do

end subroutine SHPowerSpectrum

subroutine SHPowerSpectrumDensity(cilm, lmax, spectra, exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power spectrum
!   density of the 4pi spherical harmonic coefficients cilm(i, l, m).
!
!   PowerSpectralDensity = Sum_{m=0}^l ( c1lm**2 + c2lm**2 ) / (2l+1)
!
!   Calling Parameters
!
!       IN
!           cilm        Spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           lmax        Spherical harmonic degree to compute power.
!
!       OUT
!           spectra     Array of length (lmax+1) containing the power
!                       spectra density of cilm.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(in) :: cilm(:,:,:)
    integer(int32), intent(in) :: lmax
    real(dp), intent(out) :: spectra(:)
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

    if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 &
            .or. size(cilm(1,1,:)) < lmax+1) then
        print*, "Error --- SHPowerSpectrumDensity"
        print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(cilm(:,1,1)), &
                size(cilm(1,:,1)), size(cilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(spectra) < lmax+1) then
        print*, "Error --- SHPowerSpectrumDensity"
        print*, "SPECTRA must be dimensioned as (LMAX+1) where LMAX is ", lmax
        print*, "Input vector has dimension ", size(spectra)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    spectra = 0.0_dp

    do l = 0, lmax
        l1 = l + 1

        spectra(l1) = cilm(1, l1, 1)**2

        do m = 1, l, 1
            m1 = m + 1

            do i = 1, 2
                spectra(l1) = spectra(l1) + cilm(i, l1, m1)**2

            end do

        end do

        spectra(l1) = spectra(l1) / dble(2*l+1)

    end do

end subroutine SHPowerSpectrumDensity

subroutine SHCrossPowerSpectrum(cilm1, cilm2, lmax, cspectra, exitstatus)
!-------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power spectrum
!   of the 4pi spherical harmonic coefficients c1(i, l, m) and c2(1,l,m).
!
!   CrossPower(l) = Sum_{m=0}^l ( c1lm1*c1lm2 + c2lm1*c2lm2 )
!
!   Calling Parameters
!
!       IN
!           cilm1       Spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           cilm2       Spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           lmax        Spherical harmonic degree to compute power.
!       OUT
!           cspectra    Array of length (lmax+1) containing the cross power
!                       spectra of cilm1 and cilm2.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!-------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(in) :: cilm1(:,:,:), cilm2(:,:,:)
    integer(int32), intent(in) :: lmax
    real(dp), intent(out) :: cspectra(:)
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

    if (size(cilm1(:,1,1)) < 2 .or. size(cilm1(1,:,1)) < lmax+1 &
            .or. size(cilm1(1,1,:)) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrum"
        print*, "CILM1 must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where lmax is", lmax
        print*, "Input array is dimensioned ", size(cilm1(:,1,1)), &
                size(cilm1(1,:,1)), size(cilm1(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(cilm2(:,1,1)) < 2 .or. size(cilm2(1,:,1)) < lmax+1 &
            .or. size(cilm2(1,1,:)) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrum"
        print*, "CILM2 must be dimensioned as (2, LMAX+1, LMAX+1)"
        print*, "Input array is dimensioned ", size(cilm2(:,1,1)), &
                size(cilm2(1,:,1)), size(cilm2(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(cspectra) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrum"
        print*, "CSPECTRA must be dimensioned as (LMAX+1) where lmax is ", lmax
        print*, "Input vector has dimension ", size(cspectra)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    cspectra = 0.0_dp

    do l = 0, lmax
        l1 = l + 1

        cspectra(l1) = cilm1(1, l1, 1) * cilm2(1, l1, 1)

        do m = 1, l, 1
            m1 = m + 1

            do i = 1, 2
                cspectra(l1) = cspectra(l1) + cilm1(i,l1,m1) * cilm2(i, l1, m1)

            end do

        end do

    end do

end subroutine SHCrossPowerSpectrum

subroutine SHCrossPowerSpectrumDensity(cilm1, cilm2, lmax, cspectra, &
                                       exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power spectrum
!   density of the 4pi spherical harmonic coefficients cilm1(i, l, m) and
!   cilm2(i,l,m).
!
!   CrossPower = Sum_{m=0}^l ( c1lm1*c1lm2 + c2lm1*c2lm2 ) / (2l+1)
!
!   Calling Parameters
!
!       IN
!           cilm1       Spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           cilm2       Spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           lmax        Spherical harmonic degree to compute power.
!
!       OUT
!           cspectra    Array of length (lmax+1) containing the cross power
!                       spectral density of cilm1 and cilm2.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(in) :: cilm1(:,:,:), cilm2(:,:,:)
    integer(int32), intent(in) :: lmax
    real(dp), intent(out) :: cspectra(:)
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: i, m, l1, m1, l

    if (size(cilm1(:,1,1)) < 2 .or. size(cilm1(1,:,1)) < lmax+1 &
            .or. size(cilm1(1,1,:)) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrumDensity"
        print*, "CILM1 must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where lmax is", lmax
        print*, "Input array is dimensioned ", size(cilm1(:,1,1)), &
                size(cilm1(1,:,1)), size(cilm1(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(cilm2(:,1,1)) < 2 .or. size(cilm2(1,:,1)) < lmax+1 &
            .or. size(cilm2(1,1,:)) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrumDensity"
        print*, "CILM2 must be dimensioned as (2, LMAX+1, LMAX+1)"
        print*, "Input array is dimensioned ", size(cilm2(:,1,1)), &
                size(cilm2(1,:,1)), size(cilm2(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(cspectra) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrumDensity"
        print*, "CSPECTRA must be dimensioned as (LMAX+1) where lmax is ", lmax
        print*, "Input vector has dimension ", size(cspectra)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    cspectra = 0.0_dp

    do l = 0, lmax
        l1 = l + 1

        cspectra(l1) = cilm1(1, l1, 1) * cilm2(1, l1, 1)

        do m = 1, l, 1
            m1 = m + 1

            do i = 1, 2
                cspectra(l1) = cspectra(l1) + cilm1(i,l1,m1) * cilm2(i, l1, m1)

            end do

        end do

        cspectra(l1) = cspectra(l1) / dble(2*l+1)

    end do

end subroutine SHCrossPowerSpectrumDensity


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZUFFQR (Zomplex Unitary hessenberg Factored Fast QR)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the eigenvalues and optionally eigenvectors of
! a unitary upper hessenberg matrix that is stored as a product of
! givens rotations and a complex diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  COMPZ           CHARACTER
!                    'N': no eigenvectors
!                    'I': eigenvectors, initializing Z to the identity
!                    'V': eigenvectors, assume Z already initialized
!
!  N               INTEGER
!                    dimension of matrix
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for givens rotations
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!                    on output contains the eigenvalues
!
! OUTPUT VARIABLES:
!
!  Z              COMPLEX(8) array of dimension (N,N)
!                   if COMPZ = 'N' unused
!                   if COMPZ = 'I' stores eigenvectors in Z
!                   if COMPZ = 'V' update Z to store eigenvectors
!
!  ITS            INTEGER array of dimension (N-1)
!                   Contains the number of iterations per deflation
!
!  INFO           INTEGER
!                   INFO = 1 implies no convergence
!                   INFO = 0 implies successful computation
!                   INFO = -1 implies COMPZ is invalid
!                   INFO = -2 implies N, Q or D is invalid
!                   INFO = -5 implies Z is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZUFFQR(COMPZ,N,Q,D,Z,ITS,INFO)

  implicit none

  ! input variables
  character, intent(in) :: COMPZ
  integer, intent(in) :: N
  real(8), intent(inout) :: Q(3*(N-1)), D(2*N)
  integer, intent(inout) :: INFO, ITS(N-1)
  complex(8), intent(inout) :: Z(N,N)

  ! compute variables
  integer :: ii, jj, kk, ind1, ind2, ll, strt, k
  integer :: start_index, stop_index, zero_index, it_max, it_count
  real(8) :: nrm
  complex(8) :: block(2,2), eigs(2), temp(2,2)

  ! initialize info
  INFO = 0

  ! check COMPZ
  if ((COMPZ.NE.'N').AND.(COMPZ.NE.'I').AND.(COMPZ.NE.'V')) then
    INFO = -1
    ! check input in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"COMPZ must be 'N', 'I' or 'V'",INFO,INFO)
    end if
    return
  end if

  ! check factorization
  call ZUFCHF(N,Q,D,INFO)
  if (INFO.NE.0) then
    ! check input in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"N, Q, or D is invalid",INFO,INFO)
    end if
    INFO = -2
    return
  end if

  ! check Z
  if (COMPZ.EQ.'V') then
    call ZARACH2(N,N,Z,INFO)
    if (INFO.NE.0) then
      INFO = -5
      ! check input in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"Z is invalid",INFO,INFO)
      end if
      return
    end if
  end if

  ! initialize storage
  ITS = 0

  if (COMPZ.EQ.'I') then
    Z = cmplx(0d0,0d0,kind=8)
    do ii=1,n
      Z(ii,ii) = cmplx(1d0,0d0,kind=8)
    end do
  end if

  ! initialize indices
  start_index = 1
  stop_index = N-1
  zero_index = 0
  it_max = 20*N
  it_count = 0

  ! loop for bulgechasing
  do kk=1,it_max

    ! check for completion
    if(stop_index <= 0)then
      exit
    end if

    ! check for deflation
    call ZUFGRD(N,start_index,stop_index,zero_index,Q,D,it_count,ITS,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"ZUFGRD failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! if 1x1 block remove and check again
    if(stop_index == zero_index)then

      ! update indices
      stop_index = stop_index - 1
      zero_index = 0
      start_index = 1

    ! if 2x2 block remove and check again
    else if(stop_index-1 == zero_index)then

      ! get 2x2 block
      call ZUFTDB(N,stop_index,Q,D,block,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"ZUFTDB failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

      ! compute eigenvalues and eigenvectors
      call ZTTEEV(block,eigs,temp,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"ZTTEEV failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

      ! store eigenvalues
      D(2*(stop_index-1)+1) = dble(eigs(1))
      D(2*(stop_index-1)+2) = aimag(eigs(1))
      D(2*(stop_index-1)+3) = dble(eigs(2))
      D(2*(stop_index-1)+4) = aimag(eigs(2))

      ! update Q
      Q(3*(stop_index-1)+1) = 1d0
      Q(3*(stop_index-1)+2) = 0d0
      Q(3*(stop_index-1)+3) = 0d0

      ! update eigenvectors
      if ((COMPZ.EQ.'I').OR.(COMPZ.EQ.'V')) then
        Z(:,stop_index:(stop_index+1)) = matmul(Z(:,stop_index:(stop_index+1)),temp)
      end if

      ! update indices
      stop_index = stop_index-2
      zero_index = 0
      start_index = 1

    ! if greater than 2x2 chase a bulge and check again
    else

      ! chase bulge
      call ZUFSFI(COMPZ,N,start_index,stop_index,Q,D,Z,it_count,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"ZUFSFI failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

    end if

    ! if it_max hit
    if (kk == it_max) then
      INFO = 1
      its(stop_index) = it_count
    end if

  end do

end subroutine ZUFFQR


c----------------------------------------------------------------------
      subroutine ilutp(n,a,ja,ia,lfil,droptol,permtol,mbloc,alu,
     *     jlu,ju,iwk,w,jw,iperm,ierr)
c-----------------------------------------------------------------------
c     implicit none
      integer n,ja(*),ia(n+1),lfil,jlu(*),ju(n),jw(2*n),iwk,
     *     iperm(2*n),ierr
      real*8 a(*), alu(*), w(n), droptol
c----------------------------------------------------------------------*
c       *** ILUTP preconditioner -- ILUT with pivoting  ***            *
c      incomplete LU factorization with dual truncation mechanism      *
c----------------------------------------------------------------------*
c author Yousef Saad *Sep 8, 1993 -- Latest revision, August 1996.     *
c----------------------------------------------------------------------*
c on entry:
c==========
c n       = integer. The dimension of the matrix A.
c
c a,ja,ia = matrix stored in Compressed Sparse Row format.
c           ON RETURN THE COLUMNS OF A ARE PERMUTED. SEE BELOW FOR
c           DETAILS.
c
c lfil    = integer. The fill-in parameter. Each row of L and each row
c           of U will have a maximum of lfil elements (excluding the
c           diagonal element). lfil must be .ge. 0.
c           ** WARNING: THE MEANING OF LFIL HAS CHANGED WITH RESPECT TO
c           EARLIER VERSIONS.
c
c droptol = real*8. Sets the threshold for dropping small terms in the
c           factorization. See below for details on dropping strategy.
c
c lfil    = integer. The fill-in parameter. Each row of L and
c           each row of U will have a maximum of lfil elements.
c           WARNING: THE MEANING OF LFIL HAS CHANGED WITH RESPECT TO
c           EARLIER VERSIONS.
c           lfil must be .ge. 0.
c
c permtol = tolerance ratio used to  determne whether or not to permute
c           two columns.  At step i columns i and j are permuted when
c
c                     abs(a(i,j))*permtol .gt. abs(a(i,i))
c
c           [0 --> never permute; good values 0.1 to 0.01]
c
c mbloc   = if desired, permuting can be done only within the diagonal
c           blocks of size mbloc. Useful for PDE problems with several
c           degrees of freedom.. If feature not wanted take mbloc=n.
c
c
c iwk     = integer. The lengths of arrays alu and jlu. If the arrays
c           are not big enough to store the ILU factorizations, ilut
c           will stop with an error message.
c
c On return:
c===========
c
c alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing
c           the L and U factors together. The diagonal (stored in
c           alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix
c           contains the i-th row of L (excluding the diagonal entry=1)
c           followed by the i-th row of U.
c
c ju      = integer array of length n containing the pointers to
c           the beginning of each row of U in the matrix alu,jlu.
c
c iperm   = contains the permutation arrays.
c           iperm(1:n) = old numbers of unknowns
c           iperm(n+1:2*n) = reverse permutation = new unknowns.
c
c ierr    = integer. Error message with the following meaning.
c           ierr  = 0    --> successful return.
c           ierr .gt. 0  --> zero pivot encountered at step number ierr.
c           ierr  = -1   --> Error. input matrix may be wrong.
c                            (The elimination process has generated a
c                            row in L or U whose length is .gt.  n.)
c           ierr  = -2   --> The matrix L overflows the array al.
c           ierr  = -3   --> The matrix U overflows the array alu.
c           ierr  = -4   --> Illegal value for lfil.
c           ierr  = -5   --> zero row encountered.
c
c work arrays:
c=============
c jw      = integer work array of length 2*n.
c w       = real work array of length n
c
c IMPORTANR NOTE:
c --------------
c TO AVOID PERMUTING THE SOLUTION VECTORS ARRAYS FOR EACH LU-SOLVE,
C THE MATRIX A IS PERMUTED ON RETURN. [all column indices are
c changed]. SIMILARLY FOR THE U MATRIX.
c To permute the matrix back to its original state use the loop:
c
c      do k=ia(1), ia(n+1)-1
c         ja(k) = iperm(ja(k))
c      enddo
c
c-----------------------------------------------------------------------
c     local variables
c
      integer k,i,j,jrow,ju0,ii,j1,j2,jpos,len,imax,lenu,lenl,jj,mbloc,
     *     icut
      real*8 s, tmp, tnorm,xmax,xmax0, fact, abs, t, permtol
c
      if (lfil .lt. 0) goto 998
c-----------------------------------------------------------------------
c     initialize ju0 (points to next element to be added to alu,jlu)
c     and pointer array.
c-----------------------------------------------------------------------
      ju0 = n+2
      jlu(1) = ju0
c
c  integer double pointer array.
c
      do 1 j=1, n
         jw(n+j)  = 0
         iperm(j) = j
         iperm(n+j) = j
 1    continue
c-----------------------------------------------------------------------
c     beginning of main loop.
c-----------------------------------------------------------------------
      do 500 ii = 1, n
         j1 = ia(ii)
         j2 = ia(ii+1) - 1
         tnorm = 0.0d0
         do 501 k=j1,j2
            tnorm = tnorm+abs(a(k))
 501     continue
         if (tnorm .eq. 0.0) goto 999
         tnorm = tnorm/(j2-j1+1)
c
c     unpack L-part and U-part of row of A in arrays  w  --
c
         lenu = 1
         lenl = 0
         jw(ii) = ii
         w(ii) = 0.0
         jw(n+ii) = ii
c
         do 170  j = j1, j2
            k = iperm(n+ja(j))
            t = a(j)
            if (k .lt. ii) then
               lenl = lenl+1
               jw(lenl) = k
               w(lenl) = t
               jw(n+k) = lenl
            else if (k .eq. ii) then
               w(ii) = t
            else
               lenu = lenu+1
               jpos = ii+lenu-1
               jw(jpos) = k
               w(jpos) = t
               jw(n+k) = jpos
            endif
 170     continue
         jj = 0
         len = 0
c
c     eliminate previous rows
c
 150     jj = jj+1
         if (jj .gt. lenl) goto 160
c-----------------------------------------------------------------------
c     in order to do the elimination in the correct order we must select
c     the smallest column index among jw(k), k=jj+1, ..., lenl.
c-----------------------------------------------------------------------
         jrow = jw(jj)
         k = jj
c
c     determine smallest column index
c
         do 151 j=jj+1,lenl
            if (jw(j) .lt. jrow) then
               jrow = jw(j)
               k = j
            endif
 151     continue
c
         if (k .ne. jj) then
c     exchange in jw
            j = jw(jj)
            jw(jj) = jw(k)
            jw(k) = j
c     exchange in jr
            jw(n+jrow) = jj
            jw(n+j) = k
c     exchange in w
            s = w(jj)
            w(jj) = w(k)
            w(k) = s
         endif
c
c     zero out element in row by resetting jw(n+jrow) to zero.
c
         jw(n+jrow) = 0
c
c     get the multiplier for row to be eliminated: jrow
c
         fact = w(jj)*alu(jrow)
c
c     drop term if small
c
         if (abs(fact) .le. droptol) goto 150
c
c     combine current row and row jrow
c
         do 203 k = ju(jrow), jlu(jrow+1)-1
            s = fact*alu(k)
c     new column number
            j = iperm(n+jlu(k))
            jpos = jw(n+j)
            if (j .ge. ii) then
c
c     dealing with upper part.
c
               if (jpos .eq. 0) then
c
c     this is a fill-in element
c
                  lenu = lenu+1
                  i = ii+lenu-1
                  if (lenu .gt. n) goto 995
                  jw(i) = j
                  jw(n+j) = i
                  w(i) = - s
               else
c     no fill-in element --
                  w(jpos) = w(jpos) - s
               endif
            else
c
c     dealing with lower part.
c
               if (jpos .eq. 0) then
c
c     this is a fill-in element
c
                 lenl = lenl+1
                 if (lenl .gt. n) goto 995
                 jw(lenl) = j
                 jw(n+j) = lenl
                 w(lenl) = - s
              else
c
c     this is not a fill-in element
c
                 w(jpos) = w(jpos) - s
              endif
           endif
 203    continue
c
c     store this pivot element -- (from left to right -- no danger of
c     overlap with the working elements in L (pivots).
c
        len = len+1
        w(len) = fact
        jw(len)  = jrow
        goto 150
 160    continue
c
c     reset double-pointer to zero (U-part)
c
        do 308 k=1, lenu
           jw(n+jw(ii+k-1)) = 0
 308    continue
c
c     update L-matrix
c
        lenl = len
        len = min0(lenl,lfil)
c
c     sort by quick-split
c
        if(lenl.GT.0) then
           call qsplit (w,jw,lenl,len)
        endif
c
c     store L-part -- in original coordinates ..
c
        do 204 k=1, len
           if (ju0 .gt. iwk) goto 996
           alu(ju0) =  w(k)
           jlu(ju0) = iperm(jw(k))
           ju0 = ju0+1
 204    continue
c
c     save pointer to beginning of row ii of U
c
        ju(ii) = ju0
c
c     update U-matrix -- first apply dropping strategy
c
         len = 0
         do 205 k=1, lenu-1
            if (abs(w(ii+k)) .gt. droptol*tnorm) then
               len = len+1
               w(ii+len) = w(ii+k)
               jw(ii+len) = jw(ii+k)
            endif
205      continue
         lenu = len+1
         len = min0(lenu,lfil)

         if((lenu-1).GT.0) then
            call qsplit (w(ii+1), jw(ii+1), lenu-1,len)
         endif
c
c     determine next pivot --
c
        imax = ii
        xmax = abs(w(imax))
        xmax0 = xmax
        icut = ii - 1 + mbloc - mod(ii-1,mbloc)
        do 206 k=ii+1,ii+len-1
           t = abs(w(k))
           if (t .gt. xmax .and. t*permtol .gt. xmax0 .and.
     *          jw(k) .le. icut) then
              imax = k
              xmax = t
           endif
206     continue
c
c     exchange w's
c
        tmp = w(ii)
        w(ii) = w(imax)
        w(imax) = tmp
c
c     update iperm and reverse iperm
c
        j = jw(imax)
        i = iperm(ii)
        iperm(ii) = iperm(j)
        iperm(j) = i
c
c     reverse iperm
c
        iperm(n+iperm(ii)) = ii
        iperm(n+iperm(j)) = j
c-----------------------------------------------------------------------
c
        if (len + ju0 .gt. iwk) goto 997
c
c     copy U-part in original coordinates
c
        do 302 k=ii+1,ii+len-1
           jlu(ju0) = iperm(jw(k))
           alu(ju0) = w(k)
           ju0 = ju0+1
 302    continue
c
c     store inverse of diagonal element of u
c
        if (w(ii) .eq. 0.0) w(ii) = (1.0D-4 + droptol)*tnorm
        alu(ii) = 1.0d0/ w(ii)
c
c     update pointer to beginning of next row of U.
c
        jlu(ii+1) = ju0
c-----------------------------------------------------------------------
c     end main loop
c-----------------------------------------------------------------------
 500  continue
c
c     permute all column indices of LU ...
c
      do 503 k = jlu(1),jlu(n+1)-1
         jlu(k) = iperm(n+jlu(k))
503   continue
c
c     ...and of A
c
      do 502 k=ia(1), ia(n+1)-1
         ja(k) = iperm(n+ja(k))
502   continue
c
      ierr = 0
      return
c
c     incomprehensible error. Matrix must be wrong.
c
 995  ierr = -1
      return
c
c     insufficient storage in L.
c
 996  ierr = -2
      return
c
c     insufficient storage in U.
c
 997  ierr = -3
      return
c
c     illegal lfil entered.
c
 998  ierr = -4
      return
c
c     zero row encountered
c
 999  ierr = -5
      return
c----------------end-of-ilutp-------------------------------------------
c-----------------------------------------------------------------------
      end