!
! The code here solves the linear shallow water equations in cartesian or spherical
! coordinates, with or without coriolis. It can also include a nonlinear friction term,
! (which may be an efficient choice for modelling large scale tsunami propagation with dissipation).
!
! It has been moved out of domain_mod.f90, because it became complex
!
! The subroutine header has been commented out

!    !
!    ! Linear shallow water equations leap-frog update
!    !
!    ! Update domain%U by timestep dt, using the linear shallow water equations.
!    !
!    ! @param domain the domain to advance
!    ! @param dt the timestep to advance. Should remain constant in between repeated calls
!    !     to the function (since the numerical method assumes constant timestep)
!    !
!    subroutine one_linear_leapfrog_step(domain, dt)
!        class(domain_type), intent(inout):: domain
!        real(dp), intent(in):: dt
!
!        ! Do we represent pressure gradients with a 'truely' linear term g * depth0 * dStage/dx,
!        ! or with a nonlinear term g * depth * dStage/dx (i.e. where the 'depth' varies)?
!        logical, parameter:: truely_linear = .TRUE.

        ! Domain size
        integer(ip) :: nx, ny
        ! Useful constants for removing divisons from inner loop (e.g. dt/area)
        real(dp):: inv_cell_area_dt, inv_cell_area_dt_vh_g, inv_cell_area_dt_g
        ! d(stage)/dy; depth_{i, j+1/2}, depth_{j, i+1/2, j}
        real(dp):: dw_j(domain%nx(1)), h_jph_vec(domain%nx(1)), h_iph_vec(domain%nx(1))
        real(dp) :: h_iph_wet(domain%nx(1)), h_jph_wet(domain%nx(1))

        integer(ip):: j, i, xl, xu, yl, yu, n_ext, my_omp_id, n_omp_threads, loop_work_count
        integer(ip) :: yl_omp, yU_omp

#if defined(CORIOLIS) || defined(LINEAR_PLUS_NONLINEAR_FRICTION)
        ! Vector to hold the (coriolis force x time-step x 0.5), which arises
        ! in an inner loop. Use a vector so we can zero it for dry cells
        real(dp):: dt_half_coriolis(domain%nx(1)), dt_half_coriolis_jph(domain%nx(1))

        ! Vector to hold the semi_implicit_friction_multiplier
        real(dp):: friction_multiplier_UH(domain%nx(1)), friction_multiplier_VH(domain%nx(1))

        ! For the coriolis term in the UH update, we store an interpolated version of
        ! the 'pre-update' VH at 'i+1/2', 'j-1/2'. We also need the same at 'i+1/2', 'j+1/2'
        real(dp) :: vh_iph_jmh(domain%nx(1)), vh_iph_jph(domain%nx(1))

        ! For the coriolis term in the VH update, we store and interpolated version of
        ! the 'pre-update' UH at 'i', 'j'. We also need that at 'i', 'j+1'
        real(dp) :: uh_i_j(domain%nx(1)), uh_i_jp1(domain%nx(1))
        real(dp) :: uh_i_jp1_max_loop_index(domain%nx(1))

#endif

        domain%dt_last_update = dt

        !
        ! idea: U(i, j, UH) = UH_{i+1/2, j}
        !     : U(i, j, VH) = VH_{i, j+1/2}
        ! We rely on boundary conditions for ALL boundary stage values, and
        ! apply the boundary condition after the stage update. We then update
        ! all uh/vh values which can be updated using those stage values [so avoid
        ! having to specify boundary conditions for them]

        ! If doing nesting, track fluxes through nesting regions (mass flux
        ! only, since momentum flux is zero by definition).
        ! For the leap-frog solver, the mass fluxes are given by the
        ! depth-integrated-velocity components.
        ! Note domain%U(:,1,VH) gives south-edge flux for cell j=2, and
        ! similarly domain%U(1,:,UH) gives the east-edge flux for cell i = 2.
        call domain%nesting_boundary_flux_integral_tstep(dt, &
           flux_NS=domain%U(:,:,VH:VH), flux_NS_lower_index=2_ip, &
           flux_EW=domain%U(:,:,UH:UH), flux_EW_lower_index=2_ip, &
           var_indices=[STG, STG], flux_already_multiplied_by_dx=.FALSE.)

        !TIMER_START('LF_update')

        nx = domain%nx(1)
        ny = domain%nx(2)

        xL = domain%xL
        xU = domain%xU
        yL = domain%yL
        yU = domain%yU

        !$OMP PARALLEL DEFAULT(PRIVATE) SHARED(domain, dt, nx, ny, xL, xU, yL, yU)

        !
        ! Update stage
        !
        !$OMP DO SCHEDULE(STATIC)
        do j = (yL+1),(yU-1)
            ! For spherical coordinates, cell area changes with y.
            ! For cartesian coordinates this could be moved out of the loop
            inv_cell_area_dt = dt / domain%area_cell_y(j)

            do i = (xL+1) , (xU-1)
                ! dstage/dt = - 1/(R cos (lat)) [ d uh / dlon + dvhcos(lat)/dlat ]
                domain%U(i, j, STG) = domain%U(i, j, STG) - inv_cell_area_dt * ( &
                    (domain%U(i, j, UH) - domain%U(i-1, j, UH)) * &
                        domain%distance_left_edge(i) + &
                    (domain%U(i, j, VH)*domain%distance_bottom_edge(j+1) - &
                        domain%U(i, j-1, VH)*domain%distance_bottom_edge(j))&
                    )

            end do
        end do
        !$OMP END DO
        !$OMP END PARALLEL

        domain%time = domain%time + dt * HALF_dp
        call domain%update_boundary()
        call domain%apply_forcing(dt)
        !TIMER_STOP('LF_update')

        !TIMER_START('partitioned_comms')
        if(domain%use_partitioned_comms) call domain%partitioned_comms%communicate(domain%U)
        !TIMER_STOP('partitioned_comms')

        !TIMER_START('LF_update')
        !! Boundary flux integration
        ! note : U(i, j, UH) = UH_{i+1/2, j}
        !      : U(i, j, VH) = VH_{i, j+1/2}
        n_ext = domain%exterior_cells_width
        ! Outward boundary flux over the north -- integrate over the 'interior'
        ! cells
        domain%boundary_flux_store(1) = &
            sum(domain%U((n_ext+1):(nx-n_ext),ny-n_ext,VH)) * &
            domain%distance_bottom_edge(ny-n_ext+1)
        ! Outward boundary flux over the east
        domain%boundary_flux_store(2) = &
            sum(domain%U(nx-n_ext,(1+n_ext):(ny-n_ext),UH)) * &
            domain%distance_left_edge(nx-n_ext+1)
        ! Outward boundary flux over the south
        domain%boundary_flux_store(3) = - &
            sum(domain%U((n_ext+1):(nx-n_ext),n_ext,VH)) * &
            domain%distance_bottom_edge(n_ext+1)
        ! Outward boundary flux over the west
        domain%boundary_flux_store(4) = - &
            sum(domain%U(n_ext,(1+n_ext):(ny-n_ext),UH)) * &
            domain%distance_left_edge(n_ext+1)

        domain%boundary_flux_evolve_integral = &
            sum(domain%boundary_flux_store) * dt

        !
        ! Compute fluxes relevant to the multidomain case
        !
        if(domain%nesting%my_index > 0) then
            ! We are in a multidomain -- carefully compute fluxes through
            ! exterior boundaries
            domain%boundary_flux_store_exterior = ZERO_dp

            ! Here we implement masked versions of the boundary flux sums above, only counting cells
            ! where the priority domain is receiving/sending the fluxes on actual physical boundaries

            ! North boundary
            if(domain%boundary_exterior(1)) then
                domain%boundary_flux_store_exterior(1) = domain%distance_bottom_edge(ny-n_ext+1) * sum(&
                    domain%U( (1+n_ext):(nx-n_ext), ny-n_ext, VH),&
                    mask = (&
                        domain%nesting%priority_domain_index((1+n_ext):(nx-n_ext), ny-n_ext) == domain%nesting%my_index .and. &
                        domain%nesting%priority_domain_image((1+n_ext):(nx-n_ext), ny-n_ext) == domain%nesting%my_image ))
            end if

            ! East boundary
            if(domain%boundary_exterior(2)) then
                domain%boundary_flux_store_exterior(2) = domain%distance_left_edge(nx-n_ext+1) * sum(&
                    domain%U( nx-n_ext, (1+n_ext):(ny-n_ext), UH),&
                    mask = (&
                        domain%nesting%priority_domain_index(nx-n_ext, (1+n_ext):(ny-n_ext)) == domain%nesting%my_index .and. &
                        domain%nesting%priority_domain_image(nx-n_ext, (1+n_ext):(ny-n_ext)) == domain%nesting%my_image ))
            end if

            ! South boundary
            if(domain%boundary_exterior(3)) then
                domain%boundary_flux_store_exterior(3) = - domain%distance_bottom_edge(n_ext+1) * sum(&
                    domain%U( (1+n_ext):(nx-n_ext), n_ext, VH),&
                    mask = (&
                        domain%nesting%priority_domain_index((1+n_ext):(nx-n_ext), 1+n_ext) == domain%nesting%my_index .and. &
                        domain%nesting%priority_domain_image((1+n_ext):(nx-n_ext), 1+n_ext) == domain%nesting%my_image ))
            end if

            ! West boundary
            if(domain%boundary_exterior(4)) then
                domain%boundary_flux_store_exterior(4) = - domain%distance_left_edge(n_ext+1) * sum(&
                    domain%U(n_ext, (1+n_ext):(ny-n_ext), UH),&
                    mask = (&
                        domain%nesting%priority_domain_index(1+n_ext, (1+n_ext):(ny-n_ext)) == domain%nesting%my_index .and. &
                        domain%nesting%priority_domain_image(1+n_ext, (1+n_ext):(ny-n_ext)) == domain%nesting%my_image ))
            end if
        else
            ! We are not doing nesting
            domain%boundary_flux_store_exterior = domain%boundary_flux_store
        end if

        domain%boundary_flux_evolve_integral_exterior = &
            sum(domain%boundary_flux_store_exterior, mask=domain%boundary_exterior) * dt

        !
        ! Update uh, vh
        !

#if defined(LINEAR_PLUS_NONLINEAR_FRICTION)
        ! Compute some expensive parts of the friction term
        ! If domain%linear_solver_is_truely_linear, this will only happen
        ! once (on the first timestep). Otherwise it should happen every timestep
        if(.not. domain%friction_work_is_setup) call precompute_friction_work(domain)
#endif

        ! NOTE: Here we manually determine the openmp loop indices. This is
        ! required to include the Coriolis terms without having to copy
        ! memory of size domain%U(:,:,UH:VH) -- which would increase memory use
        ! by 50%
        !
        loop_work_count = yU - yL ! Number of indices between 'yU - 1' and 'yL'
        !
        !$OMP PARALLEL DEFAULT(PRIVATE) SHARED(domain, dt, nx, ny, xL, xU, yL, yU, loop_work_count)
        !
#ifdef NOOPENMP
        ! Serial loop from yL:(yU-1)
        yl_omp = yL
        yu_omp = yU - 1
#else
        ! Parallel loop from yL:(yU-1)
        !
        ! NOTE: In fortran,
        !     DO i = start, end
        !       .... code here ...
        !     END DO
        ! will not do anything at all if start > end [that's the standard, if
        ! we don't specify a stride other than 1].
        ! This behaviour is important for ensuring the openmp loop sharing
        ! code here works, even if e.g. we have more omp threads than loop
        ! indices. In that case, we will have some threads with yl_omp >
        ! yu_omp -- which will not loop -- and that is the desired behaviour.
        !
        my_omp_id = omp_get_thread_num()
        n_omp_threads = omp_get_num_threads()
        ! yl_omp = lower loop index of the thread my_omp_id
        yl_omp = nint(loop_work_count * my_omp_id * 1.0_dp / n_omp_threads) + yL
        ! yu_omp = upper loop index of the thread my_omp_id
        yu_omp = nint(loop_work_count * (my_omp_id + 1) * 1.0_dp / n_omp_threads) + yL - 1
#endif
        !
        ! Now loop indices are determined
        !
#if defined(CORIOLIS) || defined(LINEAR_PLUS_NONLINEAR_FRICTION)
        ! Tricks to implement coriolis without increasing memory usage much
        !
        ! For coriolis, we need values of 'VH' at coorinates corresponding to UH,
        ! and also values of UH at coordinates corresponding to VH.
        !
        ! This requires 4 point averaging of the 'OLD' values of UH and VH.
        !
        ! A simply way to do that is to store all the OLD values -- but that involves
        ! lots of memory. Or,
        ! We can do this in a loop with care, without storing those 'OLD' values,
        ! so long as we store values needed at omp thread loop boundaries, and
        ! control the order that the 'j' indices are iterated, and generally be
        ! careful about openmp.

        !
        ! Zero vectors which hold strategically stored information
        !
        vh_iph_jmh(xL:(xU-1)) = ZERO_dp
        vh_iph_jph(xL:(xU-1)) = ZERO_dp
        uh_i_j(xL:(xU-1)) = ZERO_dp
        uh_i_jp1(xL:(xU-1)) = ZERO_dp
        uh_i_jp1_max_loop_index(xL:(xU-1)) = ZERO_dp
        dt_half_coriolis(xL:(xU-1)) = ZERO_dp
        dt_half_coriolis_jph(xL:(xU-1)) = ZERO_dp

        !
        ! Before starting the loop, get the value of VH at
        ! 'i+1/2', 'yl_omp-1/2', to prevent the possibility that it is
        ! updated by another openmp thread before we read it !
        if(yl_omp == 1) then
            ! In this case, there is no 'j-1/2' value, just use the boundary value
            vh_iph_jmh(xL:(xU-1)) = HALF_dp * &
                (domain%U(xL    :(xU-1), 1, VH) + &
                 domain%U((xL+1):xU    , 1, VH))
        else
            ! Average values at 'i' and 'i+1'
            vh_iph_jmh(xL:(xU-1)) = HALF_dp * &
                (domain%U(xL    :(xU-1), yl_omp - 1, VH) + &
                 domain%U((xL+1):xU    , yl_omp - 1, VH))
        end if

        !
        ! Before starting the loop, store the value of UH at 'i', 'yu_omp+1', to prevent the
        ! possibility that it is updated by another openmp thread before we read it
        !
        if(xL > 1) then
            ! Average values at 'i-1/2' and 'i+1/2'
            uh_i_jp1_max_loop_index(xL:(xU-1)) = HALF_dp * &
                (domain%U( (xL-1):(xU-2), yu_omp + 1, UH) + &
                 domain%U( xL    :(xU-1), yu_omp + 1, UH))
        else
            ! Avoid out-of bounds error
            uh_i_jp1_max_loop_index((xL+1):(xU-1)) = HALF_dp * &
                (domain%U( xL   :(xU-2), yu_omp + 1, UH) + &
                 domain%U( xL+1 :(xU-1), yu_omp + 1, UH))
            uh_i_jp1_max_loop_index(xL) = domain%U(1, yu_omp + 1, UH)
        end if

        !
        ! Get the initial value of UH at 'i, yl_omp'. This 'starting value' is required because
        ! inside the loop we set 'uh_i_j = uh_i_jph' after the update.
        !
        uh_i_j((xL+1):(xU-1)) = HALF_dp * &
            ( domain%U((xL+1):(xU-1), yl_omp, UH) + &
              domain%U(    xL:(xU-2), yl_omp, UH) )
        !
        ! Special case of xL which is protective if xL == 1
        uh_i_j(xL) = HALF_dp * ( domain%U(xL, yl_omp, UH) + &
            domain%U(max(xL-1, 1), yl_omp, UH) )

        !! No thread can start updating the loop until all threads have their
        !! 'bounding' coriolis terms
        !$OMP BARRIER

#endif
        !! Main update-flux loop
        !do j = 1, ny - 1
        do j = yl_omp, yu_omp
            ! For spherical coordiantes, cell area changes with y.
            ! For cartesian coordinates this could be moved out of the loop
            inv_cell_area_dt_g = gravity * dt / domain%area_cell_y(j)
            !
            ! For leap-frog with spherical coordinates, the area associated
            ! with the NS momentum term is different to the area associated
            ! with the stage and EW momentum term
            inv_cell_area_dt_vh_g = gravity * dt / &
                (HALF_dp * (domain%area_cell_y(j) + domain%area_cell_y(j+1)))

            !
            ! Try to keep control-flow and non-local memory jumps out of inner loop
            ! This improves speed on my machine with gfortran (11/08/2016)
            !
            dw_j(xL:(xU-1)) = domain%U(xL:(xU-1), j+1, STG) - domain%U(xL:(xU-1), j, STG)

            if(truely_linear) then
                !
                ! In the g * d * dStage/dx type term, let d be constant
                !

                ! Depth at j-plus-half
                h_jph_vec(xL:xU) = merge( &
                    domain%msl_linear - HALF_dp * (domain%U(xL:xU,j+1,ELV) + domain%U(xL:xU,j,ELV)), &
                    ZERO_dp, &
                    (( domain%U(xL:xU,j+1,ELV) < -minimum_allowed_depth + domain%msl_linear).AND. &
                     ( domain%U(xL:xU,j,ELV)   < -minimum_allowed_depth + domain%msl_linear)))

                ! Depth at i-plus-half
                h_iph_vec(xL:(xU-1)) = merge( &
                    domain%msl_linear - HALF_dp * (domain%U((xL+1):xU, j, ELV) + domain%U((xL):(xU-1), j, ELV)), &
                    ZERO_dp, &
                    (( domain%U(xL:(xU-1),j,ELV) < -minimum_allowed_depth + domain%msl_linear).AND.&
                     ( domain%U((xL+1):xU,j,ELV) < -minimum_allowed_depth + domain%msl_linear)))

                ! These variables can be used to zero UH/VH when stage < bed. However, this would introduce a nonlinearity into the
                ! equations, which seems undesirable for a 'truely-linear' approach.
                h_jph_wet(xL:xU    ) = ONE_dp
                h_iph_wet(xL:(xU-1)) = ONE_dp
            else
                !
                ! In the g * d * dStage/dx type term, let d vary. This means
                ! the equations are not actually linear!
                !

                ! Depth at j-plus-half
                h_jph_vec(xL:xU) = merge(&
                    HALF_dp * ((domain%U(xL:xU,j+1,STG) + domain%U(xL:xU,j,STG)) - &
                               (domain%U(xL:xU,j+1,ELV) + domain%U(xL:xU,j,ELV))), &
                    ZERO_dp, &
                    ((domain%U(xL:xU,j+1,STG) - domain%U(xL:xU,j+1,ELV) > minimum_allowed_depth).AND. &
                     (domain%U(xL:xU,j  ,STG) - domain%U(xL:xU,j  ,ELV) > minimum_allowed_depth)))

                ! Depth at i-plus-half
                h_iph_vec(xL:(xU-1)) = merge( &
                    HALF_dp * ((domain%U((xL+1):xU, j, STG) + domain%U(xL:(xU-1), j, STG)) -&
                               (domain%U((xL+1):xU, j, ELV) + domain%U(xL:(xU-1), j, ELV))), &
                    ZERO_dp, &
                    ((domain%U(    xL:(xU-1), j, STG) - domain%U(    xL:(xU-1),j,ELV) > minimum_allowed_depth).AND.&
                     (domain%U((xL+1):xU    , j, STG) - domain%U((xL+1):xU    ,j,ELV) > minimum_allowed_depth)))

                ! Zero UH/VH when depths are < minimum_allowed_depth. This introduces an additional nonlinearity into the equations,
                ! but seems reasonable in the 'not-truely-linear case'
                h_jph_wet(xL:xU    ) = merge(ONE_dp, ZERO_dp, h_jph_vec(xL:xU)     > ZERO_dp)
                h_iph_wet(xL:(xU-1)) = merge(ONE_dp, ZERO_dp, h_iph_vec(xL:(xU-1)) > ZERO_dp)

            end if

#if defined(CORIOLIS) || defined(LINEAR_PLUS_NONLINEAR_FRICTION)
            ! 'Old' VH at (i+1/2, j+1/2) -- requires averaging values at 'i,j+1/2' and 'i+1, j+1/2'
            vh_iph_jph(xL:(xU-1)) = HALF_dp * &
                (domain%U(xL    :(xU-1), j, VH) + &
                 domain%U((xL+1):xU    , j, VH))

            ! 'Old' UH at (i, j+1).
            ! First get it assuming we are not at the last loop index -- and then fix it
            ! Step1: Get everything except xL, which needs special treatment if xL == 1
            uh_i_jp1((xL+1):(xU-1)) = HALF_dp * &
                (domain%U((xL+1):(xU-1), j+1, UH) + &
                 domain%U(    xL:(xU-2), j+1, UH) )
            ! Special case of xL which is protective if xL == 1
            uh_i_jp1(xL) = HALF_dp * ( domain%U(xL          , j+1, UH) + &
                                       domain%U(max(xL-1, 1), j+1, UH) )
            ! Final step to ensure that if (j == yu_omp), then we get the
            ! non-updated value of UH.
            uh_i_jp1(xl:(xU-1)) = merge(&
                               uh_i_jp1(xL:(xU-1)), &
                uh_i_jp1_max_loop_index(xL:(xU-1)), &
                j /= yu_omp)
#endif

#if defined(CORIOLIS)
            ! Avoid recomputing coriolis coefficient in loop. Note we set the
            ! coriolis force to zero over dry cells, as is obviously desirable.
            dt_half_coriolis(xL:(xU-1)) = dt * domain%coriolis(j) * HALF_dp * &
                merge(ONE_dp, ZERO_dp, h_iph_vec(xL:(xU-1)) > ZERO_dp)
            dt_half_coriolis_jph(xL:(xU-1)) = dt * &
                domain%coriolis_bottom_edge(j+1) * HALF_dp * &
                merge(ONE_dp, ZERO_dp, h_jph_vec(xL:(xU-1)) > ZERO_dp)
#endif

#if defined(LINEAR_PLUS_NONLINEAR_FRICTION)
            ! Compute a multiplier that applies a semi-implicit treatment of manning friction.
            !
            ! This is equivalent to adding a term "g * depth * friction_slope" to the equations.
            !   where friction_slope = {manning_sq * depth**(-4./3.) * speed * velocity_component}
            !   assuming Manning friction; for Chezy friction the power term is depth**(-1.)
            !
            ! The term is broken up into a fast, semi-implicit discretization.
            ! For UH, we break it up as (terms in { } -- again assuming Manning friction for illustration)
            !    g * depth * friction_slope = {g * manning_sq * depth^(-7/3)} * { sqrt(uh^2 + vh^2) } * {uh}
            ! while for VH, the final term is vh
            !    g * depth * friction_slope = {g * manning_sq * depth^(-7/3)} * { sqrt(uh^2 + vh^2) } * {vh}
            ! The discretization is semi-implicit as follows:
            !    - The component 'g n^2 depth^(-7/3)' is a constant in time, because the effective depth
            !       never changes in this "linear" framework.
            !    - The term sqrt(uh^2+vh^2) {= speed*depth} is treated explicitly.
            !    - The remaining 'uh' or 'vh' term is treated implicitly.
            !
            ! Thus, appending the term g * depth * friction slope to the equations can be reduced to
            ! a multiplication of the form { 1/(1 + explicit_part_of_friction_terms) }
            !

            if(domain%friction_with_ambient_fluxes) then
                ! Add a tidal current to the friction speed term
                friction_multiplier_UH(xL:(xU-1)) = ONE_dp / ( ONE_dp + &
                    ! Linear friction like in Fine et al (2012), Kulikov et al (2014)
                    dt * domain%linear_friction_coeff + &
                    ! Nonlinear friction
                    dt * domain%friction_work(xL:(xU-1), j, UH) * ( &
                    ! Velocity * depth
                    ! FIXME: Stagger tidal flux appropriately
                    sqrt( (domain%U(xL:(xU-1),j,UH) + domain%ambient_flux(xL:(xU-1), j, UH)) **2 + &
                        (0.5_dp * ( vh_iph_jmh(xL:(xU-1)) + vh_iph_jph(xL:(xU-1)) ) + &
                         domain%ambient_flux(xL:(xU-1), j, VH) )**2 )))
                friction_multiplier_VH(xL:(xU-1)) = ONE_dp / (ONE_dp + &
                    ! Linear friction like in Fine et al (2012), Kulikov et al (2014)
                    dt * domain%linear_friction_coeff + &
                    ! Nonlinear friction
                    dt * domain%friction_work(xL:(xU-1), j, VH) * ( &
                    ! Velocity * depth
                    ! FIXME: Stagger tidal flux appropriately
                    sqrt( (domain%U(xL:(xU-1),j,VH) + domain%ambient_flux(xL:(xU-1), j, VH))**2 + &
                        (0.5_dp * ( uh_i_j(xL:(xU-1)) + uh_i_jp1(xL:(xU-1)) ) + &
                         domain%ambient_flux(xL:(xU-1), j, UH) )**2) ))
            else
                ! Regular friction
                friction_multiplier_UH(xL:(xU-1)) = ONE_dp / ( ONE_dp + &
                    ! Linear friction like in Fine et al (2012), Kulikov et al (2014)
                    dt * domain%linear_friction_coeff + &
                    ! Nonlinear friction
                    dt * domain%friction_work(xL:(xU-1), j, UH) * ( &
                    ! Velocity * depth
                    sqrt(domain%U(xL:(xU-1),j,UH)**2 + &
                         (0.5_dp * ( vh_iph_jmh(xL:(xU-1)) + vh_iph_jph(xL:(xU-1)) ) )**2 ) ))
                friction_multiplier_VH(xL:(xU-1)) = ONE_dp / (ONE_dp + &
                    ! Linear friction like in Fine et al (2012), Kulikov et al (2014)
                    dt * domain%linear_friction_coeff + &
                    ! Nonlinear friction
                    dt * domain%friction_work(xL:(xU-1), j, VH) * ( &
                    ! Velocity * depth
                    sqrt(domain%U(xL:(xU-1),j,VH)**2 + &
                         (0.5_dp * ( uh_i_j(xL:(xU-1)) + uh_i_jp1(xL:(xU-1)) ) )**2 ) ))
            endif

#endif

            do i = xL , (xU-1)
#ifndef CORIOLIS
                ! This update has no coriolis [other that that, it still 'works' in spherical coords]
                ! duh/dt = - g * h0/(R cos (lat)) [ d stage / dlon ]
                domain%U(i, j, UH) = domain%U(i, j, UH) * h_iph_wet(i) - &
                    inv_cell_area_dt_g * h_iph_vec(i) *&
                    (domain%U(i+1, j, STG) - domain%U(i, j, STG)) * &
                    domain%distance_left_edge(i+1)

                ! dvh/dt = - g * h0/(R) [ d stage / dlat ]
                domain%U(i, j, VH) = domain%U(i, j, VH) * h_jph_wet(i) - &
                    inv_cell_area_dt_vh_g * h_jph_vec(i) *&
                    dw_j(i) * domain%distance_bottom_edge(j+1)

#else
                !
                ! This update has coriolis.
                !

                ! duh/dt = - g * h0/(R cos (lat)) [ d stage / dlon ] + f*vh
                domain%U(i, j, UH) = domain%U(i, j, UH) * h_iph_wet(i) - &
                    inv_cell_area_dt_g * h_iph_vec(i) *&
                    (domain%U(i+1, j, STG) - domain%U(i, j, STG)) * &
                    domain%distance_left_edge(i+1) &
                    + dt_half_coriolis(i) * (vh_iph_jmh(i) + vh_iph_jph(i))

                ! dvh/dt = - g * h0/(R) [ d stage / dlat ] - f*uh
                domain%U(i, j, VH) = domain%U(i, j, VH) * h_jph_wet(i) - &
                    inv_cell_area_dt_vh_g * h_jph_vec(i) *&
                    dw_j(i) * domain%distance_bottom_edge(j+1) &
                    - dt_half_coriolis_jph(i) * (uh_i_j(i) + uh_i_jp1(i))

#endif

#ifdef LINEAR_PLUS_NONLINEAR_FRICTION
                ! Add the friction terms, if desired -- including both nonlinear and linear friction
                domain%U(i,j,UH) = friction_multiplier_UH(i) * domain%U(i,j,UH)
                domain%U(i,j,VH) = friction_multiplier_VH(i) * domain%U(i,j,VH)
#endif

            end do

#ifndef LINEAR_PLUS_NONLINEAR_FRICTION
            if(domain%linear_friction_coeff /= ZERO_dp) then
                ! Add an implicit linear friction treatment for the 'regular linear solver', which missed out
                ! earlier for cases treated using LINEAR_PLUS_NONLINEAR_FRICTION.
                ! This is linear friction like in Fine et al (2012), Kulikov et al (2014)
                domain%U(xL:(xU-1),j,UH) = ONE_dp/(ONE_dp + dt*domain%linear_friction_coeff) * domain%U(xL:(xU-1),j,UH)
                domain%U(xL:(xU-1),j,VH) = ONE_dp/(ONE_dp + dt*domain%linear_friction_coeff) * domain%U(xL:(xU-1),j,VH)
            end if
#endif

#if defined(CORIOLIS) || defined(LINEAR_PLUS_NONLINEAR_FRICTION)
            ! On the next j iteration, the value of 'old' value of VH at i+1/2,
            ! j-1/2 can be derived using the current value of VH at i+1, j+1/2
            vh_iph_jmh(xL:(xU-1)) = vh_iph_jph(xL:(xU-1))
            uh_i_j(xL:(xU-1)) = uh_i_jp1(xL:(xU-1))
#endif

        end do

        !!!!!$OMP END DO
        !$OMP END PARALLEL
        domain%time = domain%time + HALF_dp*dt

        !TIMER_STOP('LF_update')

    contains

    ! Precompute the friction-work for the solver "leapfrog_linear_plus_nonlinear_friction"
    !
    ! This assumes stage/UH/VH/elev have been set
    !
    ! The friction work term is of the form
    !     g * n^2 / constant_depth^(7/3)
    ! The key point is that when multiplied by ||UH|| * uh, it will be equal to the
    ! standard friction form: g*constant_depth*friction_slope
    !
    ! The pre-computation removes an expensive power-law call from the inner loop
    !
    subroutine precompute_friction_work(domain)
        type(domain_type), intent(inout) :: domain

        integer(ip) :: i, j, jp1, ip1
        real(dp) :: depth_iph, depth_jph, nsq_iph, nsq_jph
        real(dp), parameter :: manning_depth_power = NEG_SEVEN_ON_THREE_dp, chezy_depth_power = -2.0_dp

        if(domain%timestepping_method /= 'leapfrog_linear_plus_nonlinear_friction') &
            stop 'precompute_friction_work can only be called with timestepping_method=leapfrog_linear_plus_nonlinear_friction'

        if(.not. allocated(domain%friction_work)) &
            stop 'friction_work is not allocated: ensure elevation is set before running this routine'

        ! For code efficiency, make the friction power-law power explicitly known to the code.
        if(domain%friction_type == 'manning') then

#define _FRICTION_DEPTH_POWER_ manning_depth_power
#include "domain_mod_leapfrog_solver_friction_include.f90"
#undef _FRICTION_DEPTH_POWER_

        else if(domain%friction_type == 'chezy') then

#define _FRICTION_DEPTH_POWER_ chezy_depth_power
#include "domain_mod_leapfrog_solver_friction_include.f90"
#undef _FRICTION_DEPTH_POWER_

        end if

    end subroutine

!end subroutine


      SUBROUTINE CLANV2( A, B, C, D, RT1, RT2, CS, SN )
*
*  -- ScaLAPACK routine (version 1.7) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     May 28, 1999
*
*     .. Scalar Arguments ..
      REAL               CS
      COMPLEX            A, B, C, D, RT1, RT2, SN
*     ..
*
*  Purpose
*  =======
*
*  CLANV2 computes the Schur factorization of a complex 2-by-2
*  nonhermitian matrix in standard form:
*
*       [ A  B ] = [ CS -SN ] [ AA  BB ] [ CS  SN ]
*       [ C  D ]   [ SN  CS ] [  0  DD ] [-SN  CS ]
*
*  Arguments
*  =========
*
*  A       (input/output) COMPLEX
*  B       (input/output) COMPLEX
*  C       (input/output) COMPLEX
*  D       (input/output) COMPLEX
*          On entry, the elements of the input matrix.
*          On exit, they are overwritten by the elements of the
*          standardised Schur form.
*
*  RT1     (output) COMPLEX
*  RT2     (output) COMPLEX
*          The two eigenvalues.
*
*  CS      (output) REAL
*  SN      (output) COMPLEX
*          Parameters of the rotation matrix.
*
*  Further Details
*  ===============
*
*  Implemented by Mark R. Fahey, May 28, 1999
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               RZERO, HALF, RONE
      PARAMETER          ( RZERO = 0.0E+0, HALF = 0.5E+0,
     $                   RONE = 1.0E+0 )
      COMPLEX            ZERO, ONE
      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      COMPLEX            AA, BB, DD, T, TEMP, TEMP2, U, X, Y
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLARTG, CLADIV2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          REAL, CMPLX, CONJG, AIMAG, SQRT
*     ..
*     .. Executable Statements ..
*
*     Initialize CS and SN
*
      CS = RONE
      SN = ZERO
*
      IF( C.EQ.ZERO ) THEN
         GO TO 10
*
      ELSE IF( B.EQ.ZERO ) THEN
*
*        Swap rows and columns
*
         CS = RZERO
         SN = ONE
         TEMP = D
         D = A
         A = TEMP
         B = -C
         C = ZERO
         GO TO 10
      ELSE IF( ( A-D ).EQ.ZERO ) THEN
         TEMP = SQRT( B*C )
         A = A + TEMP
         D = D - TEMP
         IF( ( B+C ).EQ.ZERO ) THEN
            CS = SQRT( HALF )
            SN = CMPLX( RZERO, RONE )*CS
         ELSE
            TEMP = SQRT( B+C )
            CALL CLADIV2( SQRT( B ), TEMP, TEMP2 )
            CS = REAL( TEMP2 )
            CALL CLADIV2( SQRT( C ), TEMP, SN )
         END IF
         B = B - C
         C = ZERO
         GO TO 10
      ELSE
*
*        Compute eigenvalue closest to D
*
         T = D
         U = B*C
         X = HALF*( A-T )
         Y = SQRT( X*X+U )
         IF( REAL( X )*REAL( Y )+AIMAG( X )*AIMAG( Y ).LT.RZERO )
     $      Y = -Y
         CALL CLADIV2( U, ( X+Y ), TEMP )
         T = T - TEMP
*
*        Do one QR step with exact shift T - resulting 2 x 2 in
*        triangular form.
*
         CALL CLARTG( A-T, C, CS, SN, AA )
*
         D = D - T
         BB = CS*B + SN*D
         DD = -CONJG( SN )*B + CS*D
*
         A = AA*CS + BB*CONJG( SN ) + T
         B = -AA*SN + BB*CS
         C = ZERO
         D = T
*
      END IF
*
   10 CONTINUE
*
*     Store eigenvalues in RT1 and RT2.
*
      RT1 = A
      RT2 = D
      RETURN
*
*     End of CLANV2
*
      END


      SUBROUTINE TRIF (XC,YC,ZC,IVECT,JVECT,KVECT,A,B,C,ID,ELEM)
C
C     CALCULATEIONS FOR THE TRIANGLE USED IN TRIM6,TRPLT1,TRSHL - THE HI
C     LEVEL PLATE ELEMENTS.  COMPUTATIONS IN SINGLE PRECISION ONLY
C
C     IVECT, JVECT, AND KVECT ARE UNIT VECTORS OF THE TRIANGLE
C     B IS THE DISTANCE OF THE GRID POINT 1
C     A IS THE DISTANCE OF THE GRID POINT 3
C     C IS THE DISTANCE OF THE GRID POINT 5
C
      LOGICAL         NOGO
      REAL            IVECT(3),JVECT(3),KVECT(3),XC(6),YC(6),ZC(6),
     1                ELEM(2)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /SYSTEM/ IBUF,NOUT,NOGO
C
C     EVALUATE DIRECTIONAL COSINES
C
      X1 = XC(3) - XC(1)
      Y1 = YC(3) - YC(1)
      Z1 = ZC(3) - ZC(1)
      X2 = XC(5) - XC(1)
      Y2 = YC(5) - YC(1)
      Z2 = ZC(5) - ZC(1)
      TEMP = X1*X1 + Y1*Y1 + Z1*Z1
      IF (TEMP .LE. 1.0E-10) GO TO 40
      TEMP = SQRT(TEMP)
C
C     I-VECTOR
C
      IVECT(1) = X1/TEMP
      IVECT(2) = Y1/TEMP
      IVECT(3) = Z1/TEMP
      SAVE = TEMP
C
C     NON-NORMALIZED K-VECTOR
C
      KVECT(1) = IVECT(2)*Z2 - Y2*IVECT(3)
      KVECT(2) = IVECT(3)*X2 - Z2*IVECT(1)
      KVECT(3) = IVECT(1)*Y2 - X2*IVECT(2)
      TEMP = SQRT(KVECT(1)**2 + KVECT(2)**2 + KVECT(3)**2)
      IF (TEMP .LE. 1.0E-10) GO TO 50
C
C     NORMALIZE K-VECTOR
C     DISTANCE C OF THE TRAINGLE IS TEMP
C
      KVECT(1) = KVECT(1)/TEMP
      KVECT(2) = KVECT(2)/TEMP
      KVECT(3) = KVECT(3)/TEMP
      C = TEMP
C
C     J-VECTOR = K X I VECTORS
C
      JVECT(1) = KVECT(2)*IVECT(3) - IVECT(2)*KVECT(3)
      JVECT(2) = KVECT(3)*IVECT(1) - IVECT(3)*KVECT(1)
      JVECT(3) = KVECT(1)*IVECT(2) - IVECT(1)*KVECT(2)
      TEMP = SQRT(JVECT(1)**2 + JVECT(2)**2 + JVECT(3)**2)
      IF (TEMP .LE. 1.0E-10) GO TO 60
C
C     NORMALIZE J-VECTOR TO MAKE SURE
C
      JVECT(1) = JVECT(1)/TEMP
      JVECT(2) = JVECT(2)/TEMP
      JVECT(3) = JVECT(3)/TEMP
C
C     DISTANCE B OF THE TRIANGLE IS OBTAINED BY DOTTING (X2,Y2,Z2) WITH
C     THE IVECT UNIT VECTOR
C
      B = X2*IVECT(1) + Y2*IVECT(2) + Z2*IVECT(3)
C
C     THE LOCAL X AND Y COORINATES OF THE SIX GRID PTS. ARE AS FOLLOWS
C
      YC(1) = 0.0
      YC(2) = 0.0
      YC(3) = 0.0
      YC(4) = C*0.5
      YC(5) = C
      YC(6) = YC(4)
C
C     THE TRIANGLE SHOULD BELONG TO
C
C     KASE1 (ACUTE ANGLES AT GRID POINTS 1 AND 3),
C     KASE2 (OBTUSE ANGLE AT GRID POINT 3), OR
C     KASE3 (OBTUSE ANGLE AT GRID POINT 1)
C
C     KASE  = 1
C     IF (B .GT. SAVE) KASE = 2
C     IF (B .LT.  0.0) KASE = 3
      TEMP  = -B
C     IF (KASE .EQ. 3) TEMP = ABS(B)
C     IF (B .LT.  0.0) TEMP = ABS(B)
      XC(1) = TEMP
      XC(2) = TEMP + SAVE*0.5
      XC(3) = TEMP + SAVE
      XC(4) = XC(3)*0.5
      XC(5) = 0.0
      XC(6) = XC(1)*0.5
C
C     RE-SET DISTANCE A AND B
C
      B = ABS(B)
      A = ABS(XC(3))
      RETURN
C
C     GEOMETRY ERRORS
C
 40   WRITE (NOUT,140) UFM,ELEM,ID
      GO TO 80
 50   WRITE (NOUT,150) UFM,ELEM,ID
      GO TO 80
 60   WRITE (NOUT,160) UFM,ELEM,ID
 80   NOGO = .TRUE.
C
 140  FORMAT (A23,' 2404, GRID POINTS 1 AND 3 OF ',A4,A2,
     1       ' WITH ELEMENT ID =',I9,' HAVE SAME COORDINATES.')
 150  FORMAT (A23,' 2405, GRID POINTS 1, 3, AND 5 OF ',A4,A2,' WITH ',
     1       'ELEMENT ID =',I9,' APPEAR TO BE ON A STRAIGHT LINE.')
 160  FORMAT (A23,' 2406, GRID POINTS 1 AND 5 OF ',A4,A2,
     1       ' WITH ELEMENT ID =',I9,' HAVE SAME COORDINATES.')
      RETURN
      END


*DECK CSYMM
      SUBROUTINE CSYMM (SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA,
     $   C, LDC)
C***BEGIN PROLOGUE  CSYMM
C***PURPOSE  Multiply a complex general matrix by a complex symmetric
C            matrix.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1B6
C***TYPE      COMPLEX (SSYMM-S, DSYMM-D, CSYMM-C)
C***KEYWORDS  LEVEL 3 BLAS, LINEAR ALGEBRA
C***AUTHOR  Dongarra, J., (ANL)
C           Duff, I., (AERE)
C           Du Croz, J., (NAG)
C           Hammarling, S. (NAG)
C***DESCRIPTION
C
C  CSYMM  performs one of the matrix-matrix operations
C
C     C := alpha*A*B + beta*C,
C
C  or
C
C     C := alpha*B*A + beta*C,
C
C  where  alpha and beta are scalars, A is a symmetric matrix and  B and
C  C are m by n matrices.
C
C  Parameters
C  ==========
C
C  SIDE   - CHARACTER*1.
C           On entry,  SIDE  specifies whether  the  symmetric matrix  A
C           appears on the  left or right  in the  operation as follows:
C
C              SIDE = 'L' or 'l'   C := alpha*A*B + beta*C,
C
C              SIDE = 'R' or 'r'   C := alpha*B*A + beta*C,
C
C           Unchanged on exit.
C
C  UPLO   - CHARACTER*1.
C           On  entry,   UPLO  specifies  whether  the  upper  or  lower
C           triangular  part  of  the  symmetric  matrix   A  is  to  be
C           referenced as follows:
C
C              UPLO = 'U' or 'u'   Only the upper triangular part of the
C                                  symmetric matrix is to be referenced.
C
C              UPLO = 'L' or 'l'   Only the lower triangular part of the
C                                  symmetric matrix is to be referenced.
C
C           Unchanged on exit.
C
C  M      - INTEGER.
C           On entry,  M  specifies the number of rows of the matrix  C.
C           M  must be at least zero.
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the number of columns of the matrix C.
C           N  must be at least zero.
C           Unchanged on exit.
C
C  ALPHA  - COMPLEX         .
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  A      - COMPLEX          array of DIMENSION ( LDA, ka ), where ka is
C           m  when  SIDE = 'L' or 'l'  and is n  otherwise.
C           Before entry  with  SIDE = 'L' or 'l',  the  m by m  part of
C           the array  A  must contain the  symmetric matrix,  such that
C           when  UPLO = 'U' or 'u', the leading m by m upper triangular
C           part of the array  A  must contain the upper triangular part
C           of the  symmetric matrix and the  strictly  lower triangular
C           part of  A  is not referenced,  and when  UPLO = 'L' or 'l',
C           the leading  m by m  lower triangular part  of the  array  A
C           must  contain  the  lower triangular part  of the  symmetric
C           matrix and the  strictly upper triangular part of  A  is not
C           referenced.
C           Before entry  with  SIDE = 'R' or 'r',  the  n by n  part of
C           the array  A  must contain the  symmetric matrix,  such that
C           when  UPLO = 'U' or 'u', the leading n by n upper triangular
C           part of the array  A  must contain the upper triangular part
C           of the  symmetric matrix and the  strictly  lower triangular
C           part of  A  is not referenced,  and when  UPLO = 'L' or 'l',
C           the leading  n by n  lower triangular part  of the  array  A
C           must  contain  the  lower triangular part  of the  symmetric
C           matrix and the  strictly upper triangular part of  A  is not
C           referenced.
C           Unchanged on exit.
C
C  LDA    - INTEGER.
C           On entry, LDA specifies the first dimension of A as declared
C           in the  calling (sub) program. When  SIDE = 'L' or 'l'  then
C           LDA must be at least  max( 1, m ), otherwise  LDA must be at
C           least max( 1, n ).
C           Unchanged on exit.
C
C  B      - COMPLEX          array of DIMENSION ( LDB, n ).
C           Before entry, the leading  m by n part of the array  B  must
C           contain the matrix B.
C           Unchanged on exit.
C
C  LDB    - INTEGER.
C           On entry, LDB specifies the first dimension of B as declared
C           in  the  calling  (sub)  program.   LDB  must  be  at  least
C           max( 1, m ).
C           Unchanged on exit.
C
C  BETA   - COMPLEX         .
C           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
C           supplied as zero then C need not be set on input.
C           Unchanged on exit.
C
C  C      - COMPLEX          array of DIMENSION ( LDC, n ).
C           Before entry, the leading  m by n  part of the array  C must
C           contain the matrix  C,  except when  beta  is zero, in which
C           case C need not be set on entry.
C           On exit, the array  C  is overwritten by the  m by n updated
C           matrix.
C
C  LDC    - INTEGER.
C           On entry, LDC specifies the first dimension of C as declared
C           in  the  calling  (sub)  program.   LDC  must  be  at  least
C           max( 1, m ).
C           Unchanged on exit.
C
C***REFERENCES  Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S.
C                 A set of level 3 basic linear algebra subprograms.
C                 ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990.
C***ROUTINES CALLED  LSAME, XERBLA
C***REVISION HISTORY  (YYMMDD)
C   890208  DATE WRITTEN
C   910605  Modified to meet SLATEC prologue standards.  Only comment
C           lines were modified.  (BKS)
C***END PROLOGUE  CSYMM
C     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO
      INTEGER            M, N, LDA, LDB, LDC
      COMPLEX            ALPHA, BETA
C     .. Array Arguments ..
      COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * )
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, INFO, J, K, NROWA
      COMPLEX            TEMP1, TEMP2
C     .. Parameters ..
      COMPLEX            ONE
      PARAMETER        ( ONE  = ( 1.0E+0, 0.0E+0 ) )
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
C***FIRST EXECUTABLE STATEMENT  CSYMM
C
C     Set NROWA as the number of rows of A.
C
      IF( LSAME( SIDE, 'L' ) )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      UPPER = LSAME( UPLO, 'U' )
C
C     Test the input parameters.
C
      INFO = 0
      IF(      ( .NOT.LSAME( SIDE, 'L' ) ).AND.
     $         ( .NOT.LSAME( SIDE, 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER              ).AND.
     $         ( .NOT.LSAME( UPLO, 'L' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 7
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 9
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 12
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CSYMM ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
C
C     And when  alpha.eq.zero.
C
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
C
C     Start the operations.
C
      IF( LSAME( SIDE, 'L' ) )THEN
C
C        Form  C := alpha*A*B + beta*C.
C
         IF( UPPER )THEN
            DO 70, J = 1, N
               DO 60, I = 1, M
                  TEMP1 = ALPHA*B( I, J )
                  TEMP2 = ZERO
                  DO 50, K = 1, I - 1
                     C( K, J ) = C( K, J ) + TEMP1    *A( K, I )
                     TEMP2     = TEMP2     + B( K, J )*A( K, I )
   50             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2
                  ELSE
                     C( I, J ) = BETA *C( I, J ) +
     $                           TEMP1*A( I, I ) + ALPHA*TEMP2
                  END IF
   60          CONTINUE
   70       CONTINUE
         ELSE
            DO 100, J = 1, N
               DO 90, I = M, 1, -1
                  TEMP1 = ALPHA*B( I, J )
                  TEMP2 = ZERO
                  DO 80, K = I + 1, M
                     C( K, J ) = C( K, J ) + TEMP1    *A( K, I )
                     TEMP2     = TEMP2     + B( K, J )*A( K, I )
   80             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2
                  ELSE
                     C( I, J ) = BETA *C( I, J ) +
     $                           TEMP1*A( I, I ) + ALPHA*TEMP2
                  END IF
   90          CONTINUE
  100       CONTINUE
         END IF
      ELSE
C
C        Form  C := alpha*B*A + beta*C.
C
         DO 170, J = 1, N
            TEMP1 = ALPHA*A( J, J )
            IF( BETA.EQ.ZERO )THEN
               DO 110, I = 1, M
                  C( I, J ) = TEMP1*B( I, J )
  110          CONTINUE
            ELSE
               DO 120, I = 1, M
                  C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J )
  120          CONTINUE
            END IF
            DO 140, K = 1, J - 1
               IF( UPPER )THEN
                  TEMP1 = ALPHA*A( K, J )
               ELSE
                  TEMP1 = ALPHA*A( J, K )
               END IF
               DO 130, I = 1, M
                  C( I, J ) = C( I, J ) + TEMP1*B( I, K )
  130          CONTINUE
  140       CONTINUE
            DO 160, K = J + 1, N
               IF( UPPER )THEN
                  TEMP1 = ALPHA*A( J, K )
               ELSE
                  TEMP1 = ALPHA*A( K, J )
               END IF
               DO 150, I = 1, M
                  C( I, J ) = C( I, J ) + TEMP1*B( I, K )
  150          CONTINUE
  160       CONTINUE
  170    CONTINUE
      END IF
C
      RETURN
C
C     End of CSYMM .
C
      END


program Couplage

use prec_mod
use parametres
use init_mod
use tools
use stochastique
use fonctioncvode
use mpi

implicit none

integer :: mainloop, nloop, mloop, iloop, jloop
real(dp) :: Mtemp, nue

namelist /parameter/etape,dt_sto,methode,cas_physique

open(8,file="parametre_entree")!, status='OLD', recl=80, delim='APOSTROPHE')

read (8, nml=parameter)

Nmax = 2000

select case (etape)

! Methode explicite !
case(1)

	Neq = 1000

	allocate(C(Neq))
	allocate(C_init(Neq))

	call fnvinits(isolver,Neq,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fnvinits'
		stop
	end if

	T = 0._dp
	T0 = 0._dp
	TF = 100._dp
	abstol = 1e-18_dp
	reltol = 1e-5_dp
	C_init(1) = Cq
	C_init(2:Neq) = 0._dp

	call fcvmalloc(T,C_init,meth,itmeth,iatol,reltol,abstol,Iout,Rout,IPAR,RPAR,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvmalloc', IER
		stop
	end if

	maxerrfail = 15
	nitermax = 10000

	call fcvsetiin('MAX_NSTEPS',nitermax,IER)
	call fcvsetiin('MAX_ERRFAIL',maxerrfail,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvsetiin'
		stop
	end if

	call fcvdense(Neq,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvdense', IER
		stop
	end if

	do mainloop = 1,100
		call fcvode(TF,T,C,itask,IER)
		call output(C,T)
		TF = TF + 100._dp
	enddo

	deallocate(C)

case(2)

call MPI_INIT(ierror)

call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierror)

call MPI_COMM_SIZE(MPI_COMM_WORLD,numproc,ierror)

	! --- Initialisation du générateur aléatoire
	call init_random_seed

	! --- Initialisation du solver
	Neq = 250
	allocate(C(Neq))
	allocate(C_init(Neq))
	allocate(C_stotodis(Neq))
	allocate(MPI_C_stotodis(Neq))
	allocate(C_sto(1200))

	call fnvinits(isolver,Neq,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fnvinits'
		stop
	end if

	T = 0._dp
	T0 = 0._dp
	TF = 100._dp
	DeltaT = 100._dp
	abstol = 1e-18_dp
	reltol = 1e-5_dp
	C_init(1) = Cq
	C_init(2:Neq) = 0._dp

	call fcvmalloc(T0,C_init,meth,itmeth,iatol,reltol,abstol,Iout,Rout,IPAR,RPAR,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvmalloc', IER
		stop
	end if

	maxerrfail = 15
	nitermax = 10000

	call fcvsetiin('MAX_NSTEPS',nitermax,IER)
	call fcvsetiin('MAX_ERRFAIL',maxerrfail,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvsetiin'
		stop
	end if

	call fcvdense(Neq,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvdense', IER
		stop
	end if

	! --- Boucle principale solver+stochastique

	! --- On propage en full EDO jusqu'au critere d'arret
	quasi = .False.
	do while (M_queue < Cq/1000._dp) ! 0.1% de la masse totale se trouve dans la queue
		call fcvode(TF,T,C,itask,IER)
		call output(C,T)
		M_queue = Mtail(C,N_front,N_front+N_buff)
		TF = TF + DeltaT
	end do

	! --- On genere la partie stochastique et on restart avec la nouvelle CI sur C
	quasi = .True.
	C_init = 0._dp
	C_init(N_front:N_front+N_buff) = C(N_front:N_front+N_buff)
	MStochastique = sum(C_init)

	M_queue = Mtail(C_init,N_front,N_front+N_buff)
	if (methode.eq.1) then
		Xpart = Multinomial(C_init,N_front,N_front+N_buff,Taille)
	else
		Xpart = Metropolis(C_init,N_0,alpha_m,Taille)
	end if
	C_init = 0._dp
	C_init(1:N_front-1) = C(1:N_front-1)
	M_queue = 0._dp
	Cvac(1) = C(1)
	call FCVREINIT(T, C_init, iatol, reltol, abstol, IER)

	! --- Boucle de couplage
	do mainloop = 1, 100
		C_sto = 0._dp

		if (methode.eq.1) then
			call SSA(Xpart,Cvac,DeltaT)
		else
			call Langevin(Xpart,Cvac,DeltaT)
		end if

		call fcvode(TF,T,C,itask,IER)

		DeltaT = 100._dp
		TF = TF + DeltaT

		Cvac(1) = Calcul_Cvac(C,Xpart)

		call MPI_REDUCE(Cvac,MPI_Cvac,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, MPI_COMM_WORLD,ierror)
		MPI_Cvac = MPI_Cvac/real(numproc,8)
		call MPI_BCAST(MPI_Cvac,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
		Cvac = MPI_Cvac

		C_stotodis = StotoDiscret(Xpart,0)
		Xpart = Sampling(C,Xpart,0)

		call MPI_REDUCE(C_stotodis,MPI_C_stotodis,Neq,MPI_DOUBLE_PRECISION,MPI_SUM,0, MPI_COMM_WORLD,ierror)
		MPI_C_stotodis = MPI_C_stotodis/real(numproc,8)
		call MPI_BCAST(MPI_C_stotodis,Neq,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
		C_stotodis = MPI_C_stotodis

		C_init = 0._dp
		C_init(2:N_front-1) = C(2:N_front-1)+C_stotodis(2:N_front-1)
		C_init(1) = Cvac(1)
		C_sto(2:N_front-1) = C_init(2:N_front-1)

		if (rank.eq.0) then
			call output(C_sto,T)
		end if
		call FCVREINIT(T, C_init, iatol, reltol, abstol, IER)
	end do

	deallocate(C)
	deallocate(C_init)
	deallocate(C_stotodis)
	deallocate(MPI_C_stotodis)
	deallocate(C_sto)

call MPI_FINALIZE(ierror)

case(3)

	Ni = 2500
	Nv = 1000
	Neq = 1 + Ni + Nv
	Nmaxi = 2500
	Nmaxv = 1000
	mv = 1!4
	mi = 1!3
	! Allocation des principaux tableaux
	allocate(C(Neq))
	allocate(C_init(Neq))
	!allocate(C_stotodis(Neq))
	!allocate(MPI_C_stotodis(Neq))
	!allocate(C_sto(Nmax))

	! Allocation et calcul des coefficients alpha/beta
	allocate(Alpha_tab(-Nmaxv:Nmaxi,-mv:mi))
	allocate(Beta_tab(-Nmaxv:Nmaxi,-mv:mi))

	do nloop = -Nmaxv,Nmaxi
		do mloop = -mv,mi
			Alpha_tab(nloop,mloop) = alpha_nm(real(nloop,8),real(mloop,8)) + alpha_nm(real(nloop,8),real(mloop,8))*1.e-3
			Beta_tab(nloop,mloop) = beta_nm(real(nloop,8),real(mloop,8)) + beta_nm(real(nloop,8),real(mloop,8))*1.e-4
		end do
	end do

	do nloop = -10,10
		do mloop = -mv,mi
			print *, nloop, mloop, Alpha_tab(nloop,mloop), Beta_tab(nloop,mloop)
		end do
	end do

	print *, "init ok"

	call fnvinits(isolver,Neq,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fnvinits'
		stop
	end if
	print *, "init ok 2"
	T = 0._dp
	T0 = 0._dp
	TF = 100._dp
	abstol = 1e-20_dp
	reltol = 1e-5_dp
	C_init = 0._dp

	call fcvmalloc(T,C_init,meth,itmeth,iatol,reltol,abstol,Iout,Rout,IPAR,RPAR,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvmalloc', IER
		stop
	end if
	print *, "alloc ok"
	maxerrfail = 15
	nitermax = 10000

	call fcvsetiin('MAX_NSTEPS',nitermax,IER)
	call fcvsetiin('MAX_ERRFAIL',maxerrfail,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvsetiin'
		stop
	end if
	print *, "setting ok"
	call fcvdense(Neq,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvdense', IER
		stop
	end if
	print *, "dense ok"
	!TF = 0.001_dp
	TF = 2.58397_dp!100._dp!1.72383_dp!2.58397_dp
	quasi = .False.
	do mainloop = 1,5
		print *, mainloop
		call fcvode(TF,T,C,itask,IER)
		call output(C,T)
		TF = TF*10._dp!TF + 100._dp
	enddo

	deallocate(C)

case(4)

call MPI_INIT(ierror)

call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierror)

call MPI_COMM_SIZE(MPI_COMM_WORLD,numproc,ierror)

	! --- Initialisation du générateur aléatoire
	call init_random_seed
	print *, "Initialisation"
	! --- Initialisation du solver
	Ni = Nf_Inter+Nb_Inter
	Nv = Nf_Vac+Nb_Vac
	Neq = 1 + Ni + Nv
	Nmaxi = 5000
	Nmaxv = 1000
	mv = 1
	mi = 1
	allocate(C(Neq))
	allocate(C_init(Neq))
	allocate(C_stotodis(-Nv:Ni))
	allocate(MPI_C_stotodis(-Nv:Ni))
	allocate(C_sto(-2000:2000))
	allocate(C_Inter(1:Ni))
	allocate(C_Vac(1:Nv))
	allocate(C_Mob(-mv:mi))
	allocate(MPI_C_mob(-mv:mi))
	allocate(bCn_sto(-mv:mi))
	allocate(aCmob_sto(-mv:mi))

	allocate(Alpha_tab(-Nmaxv:Nmaxi,-mv:mi))
	allocate(Beta_tab(-Nmaxv:Nmaxi,-mv:mi))

	do nloop = -Nmaxv,Nmaxi
		do mloop = -mv,mi
			Alpha_tab(nloop,mloop) = alpha_nm(real(nloop,8),real(mloop,8))
			Beta_tab(nloop,mloop) = beta_nm(real(nloop,8),real(mloop,8))
		end do
	end do

	do nloop = -10,10
		do mloop = -mv, mi
			print *, nloop, mloop, Alpha_tab(nloop,mloop), Beta_tab(nloop, mloop)
		end do
	end do

	call fnvinits(isolver,Neq,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fnvinits'
		stop
	end if

	T = 0._dp
	T0 = 0._dp
	TF = 100._dp
	DeltaT = 100._dp
	abstol = 1e-10_dp
	reltol = 1e-5_dp
	C_init(1) = 0._dp
	C_init(2:Neq) = 0._dp
	quasi1 = .False.

	call fcvmalloc(T0,C_init,meth,itmeth,iatol,reltol,abstol,Iout,Rout,IPAR,RPAR,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvmalloc', IER
		stop
	end if

	maxerrfail = 15
	nitermax = 10000

	call fcvsetiin('MAX_NSTEPS',nitermax,IER)
	call fcvsetiin('MAX_ERRFAIL',maxerrfail,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvsetiin'
		stop
	end if

	call fcvdense(Neq,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvdense', IER
		stop
	end if

	print *, "Initialisation : ok"

	! --- Boucle principale solver+stochastique

	print *, "Boucle deterministe"
	! --- On propage en full EDO jusqu'au critere d'arret
	quasi = .False.
	do while ((C(tab_fe(Nf_Inter,Nv)) < 1.e15) .and. (C(tab_fe(-Nf_Vac,Nv)) < 1.e17))
		call fcvode(TF,T,C,itask,IER)
		call output(C,T)
		TF = TF + DeltaT
	end do
	if (C(tab_fe(Nf_Inter,Nv)) > 1.e15) then
		print *, "INTERSTITIELS"
		Coupling_Inter = .True.
	end if
	if (C(tab_fe(-Nf_Vac,Nv)) > 1.e17) then
		Coupling_Vac = .True.
		print *, "LACUNES"
	end if
	print *, "Boucle deterministe : ok"

	! --- On genere la partie stochastique et on restart avec la nouvelle CI sur C

	print *, "Initialisation boucle stochastique"
	quasi = .True.

	if (Coupling_Inter) then
		C_Inter = 0._dp
		C_Inter(Nf_Inter:Nf_Inter+Nb_Inter) = C(tab_fe(Nf_Inter,Nv):tab_fe(Nf_Inter+Nb_Inter,Nv))
		MStoInter = sum(C_Inter)
		if ((methode.eq.1) .or. (methode.eq.3)) then
			XpartInter = Multinomial(C_Inter,Nf_Inter,Nf_Inter+Nb_Inter,Taille)
		else
			N_0 = real(Nf_Inter+Nb_Inter/5._dp,8)
			alpha_m = real(Nb_Inter/10._dp,8)
			XpartInter = Metropolis(C_Inter,N_0,alpha_m,Taille)
		end if
		DeltaT = 100._dp!0.1_dp
		TF = T+DeltaT
	end if
	if (Coupling_Vac) then
		C_Vac = 0._dp
		C_Vac(Nf_Vac:Nf_Vac+Nb_Vac) = C(tab_fe(-Nf_Vac,Nv):tab_fe(-Nf_Vac-Nb_Vac,Nv):-1)
		MStoVac = sum(C_Vac)
		if ((methode.eq.1) .or. (methode.eq.3)) then
			XpartVac = -1._dp*Multinomial(C_Vac,Nf_Vac,Nf_Vac+Nb_Vac,Taille)
		else
			N_0 = real(Nf_Vac+Nb_Vac/5._dp,8)
			alpha_m = real(Nb_Vac/10._dp,8)
			XpartVac = -1._dp*Metropolis(C_vac,N_0,alpha_m,Taille)
		end if
		DeltaT = 100._dp!0.1_dp
		TF = T+DeltaT
	end if

	C_init = 0._dp
	C_Mob = 0._dp
	C_Mob(-mv:mi) = C(tab_fe(-mv,Nv):tab_fe(mi,Nv))
	C_init(tab_fe(-Nf_Vac+1,Nv):tab_fe(Nf_Inter-1,Nv)) = C(tab_fe(-Nf_Vac+1,Nv):tab_fe(Nf_Inter-1,Nv))

	call FCVREINIT(T, C_init, iatol, reltol, abstol, IER)

	print *, "Initialisation boucle stochastique : ok"

	! --- Boucle de couplage
	do mainloop = 1, 2000
		C_sto = 0._dp

		print *, "Calcul deterministe"

		! Somme sur les amas stochastiques
		!bCnCi_sto = 0._dp
		!bCnCv_sto = 0._dp
		!aCi_sto = 0._dp
		!aCv_sto = 0._dp
		bCn_sto = 0._dp
		aCmob_sto = 0._dp
		Si_sto = 0._dp
		Sv_sto = 0._dp
		if (Coupling_Inter) then
			print *, "FCVfun Coupling Inter"
			do iloop = 1, Taille
				!bCnCi_sto = bCnCi_sto - MStoInter/Taille*beta_nm(XpartInter(iloop),1._dp)*C(tab_fe(1,Nv))
				!bCnCv_sto = bCnCv_sto - MStoInter/Taille*beta_nm(XpartInter(iloop),-1._dp)*C(tab_fe(-1,Nv))
				!aCi_sto = aCi_sto + MStoInter/Taille*alpha_nm(XpartInter(iloop)+1._dp,1._dp)
				!aCv_sto = aCv_sto + MStoInter/Taille*alpha_nm(XpartInter(iloop)-1._dp,-1._dp)
				do nloop = -mv,mi
					rloop = real(nloop,8)
					bCn_sto(nloop) = bCn_sto(nloop) - MStoInter/Taille*beta_nm(XpartInter(iloop),rloop)
					aCmob_sto(nloop) = aCmob_sto(nloop) + MStoInter/Taille*alpha_nm(XpartInter(iloop)+rloop,rloop)
				end do
				Si_sto = Si_sto + MStoInter/Taille*beta_nm(XpartInter(iloop),1._dp)
				Sv_sto = Sv_sto + MStoInter/Taille*beta_nm(XpartInter(iloop),-1._dp)
			enddo
		end if
		if (Coupling_Vac) then
			do iloop = 1, Taille
			!	bCnCi_sto = bCnCi_sto - MStoVac/Taille*beta_nm(XpartVac(iloop),1._dp)*C(tab_fe(1,Nv))
			!	bCnCv_sto = bCnCv_sto - MStoVac/Taille*beta_nm(XpartVac(iloop),-1._dp)*C(tab_fe(-1,Nv))
			!	aCi_sto = aCi_sto + MStoVac/Taille*alpha_nm(XpartVac(iloop)+1._dp,1._dp)
			!	aCv_sto = aCv_sto + MStoVac/Taille*alpha_nm(XpartVac(iloop)-1._dp,-1._dp)
				do nloop = -mv,mi
					rloop = real(nloop,8)
					bCn_sto(nloop) = bCn_sto(nloop) - MStoVac/Taille*beta_nm(XpartVac(iloop),rloop)*C(tab_fe(nloop,Nv))
					aCmob_sto(nloop) = aCmob_sto(nloop) + MStoVac/Taille*alpha_nm(XpartVac(iloop)+rloop,rloop)
				end do
				Si_sto = Si_sto + MStoVac/Taille*beta_nm(XpartVac(iloop),1._dp)
				Sv_sto = Sv_sto + MStoVac/Taille*beta_nm(XpartVac(iloop),-1._dp)
			enddo
		end if

		print *, TF, T
		call fcvode(TF,T,C,itask,IER)
		print *, TF, T
		print *, "Calcul deterministe : ok"

		C_Mob = 0._dp
		C_Mob(-mv:mi) = C(tab_fe(-mv,Nv):tab_fe(mi,Nv))

		print *, "Calcul Langevin"
		if (Coupling_Inter) then
			if (methode.eq.1) then
				call SSA(XpartInter,C_Mob,DeltaT)
			else if (methode.eq.2) then
				call Langevin(XpartInter,C_Mob,DeltaT)
			else if (methode.eq.3) then
				call PropagationSto(XpartInter,C_Mob,DeltaT)
			end if
		end if
		if (Coupling_Vac) then
			if (methode.eq.1) then
				call SSA(XpartVac,C_Mob,DeltaT)
			else if (methode.eq.2) then
				call Langevin(XpartVac,C_Mob,DeltaT)
			else if (methode.eq.3) then
				call PropagationSto(XpartVac,C_Mob,DeltaT)
			end if
		end if
		print *, "Calcul Langevin : ok"

		!DeltaT = min(2._dp*DeltaT,1000._dp)
		TF = TF + DeltaT

		dt_sto = max(0.1_dp,DeltaT/10._dp)

		!print *, "Calcul amas mobiles"

		!C_Mob = Calcul_ConcMob(C,XpartInter,XpartVac,DeltaT/1000._dp,DeltaT)

		!call MPI_REDUCE(C_Mob,MPI_C_Mob,mv+mi+1,MPI_DOUBLE_PRECISION,MPI_SUM,0, MPI_COMM_WORLD,ierror)
		!MPI_C_Mob = MPI_C_Mob/real(numproc,8)
		!call MPI_BCAST(MPI_C_Mob,mv+mi+1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
		!C_Mob = MPI_C_Mob

		print *, "Calcul amas mobiles : ok"

		C_stotodis = 0._dp

		if (Coupling_Inter) then
			C_stotodis(1:Nf_Inter+Nb_Inter) = StotoDiscret(XpartInter,1)
			XpartInter = Sampling(C,XpartInter,1)
			C_sto(1:1200) = MStoInter*C_sto(1:1200)/sum(C_sto(1:1200))
		end if
		if (Coupling_Vac) then
			C_stotodis(-Nf_Vac-Nb_Vac:-1) = StotoDiscret(XpartVac,-1)
			XpartVac = Sampling(C,XpartVac,-1)
			C_sto(-1200:-1) = MStoVac*C_sto(-1200:-1)/sum(C_sto(-1200:-1))
		end if

		print *, "MStoInter : ", MStoInter

		call MPI_REDUCE(C_stotodis,MPI_C_stotodis,1+Nf_Inter+Nb_Inter+Nf_Vac+Nb_Vac,MPI_DOUBLE_PRECISION,MPI_SUM,0, MPI_COMM_WORLD,ierror)
		MPI_C_stotodis = MPI_C_stotodis/real(numproc,8)
		call MPI_BCAST(MPI_C_stotodis,1+Nf_Inter+Nb_Inter+Nf_Vac+Nb_Vac,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
		C_stotodis = MPI_C_stotodis

		C_init = 0._dp
		C_init(tab_fe(mi+1,Nv):tab_fe(Nf_Inter-1,Nv)) = C(tab_fe(mi+1,Nv):tab_fe(Nf_Inter-1,Nv)) + C_stotodis(mi+1:Nf_Inter-1)
		C_init(tab_fe(-Nf_Vac+1,Nv):tab_fe(-mv-1,Nv)) = C(tab_fe(-Nf_Vac+1,Nv):tab_fe(-mv-1,Nv)) + C_stotodis(-Nf_Vac+1:-mv-1)
		C_init(tab_fe(-mv,Nv):tab_fe(mi,Nv)) = C(tab_fe(-mv,Nv):tab_fe(mi,Nv))
		C_sto(-Nf_Vac+1:Nf_Inter-1) = C_init(tab_fe(-Nf_Vac+1,Nv):tab_fe(Nf_Inter-1,Nv))

		if ((C(tab_fe(Nf_Inter,Nv)) > 1.e14).and.(.not.Coupling_Inter)) then
			Coupling_Inter = .True.
			print *, "INTERSTITIELS"
			C_Inter = 0._dp
			C_Inter(Nf_Inter:Nf_Inter+Nb_Inter) = C(tab_fe(Nf_Inter,Nv):tab_fe(Nf_Inter+Nb_Inter,Nv))
			MStoInter = sum(C_Inter)
			if ((methode.eq.1) .or. (methode.eq.3)) then
				XpartInter = Multinomial(C_Inter,Nf_Inter,Nf_Inter+Nb_Inter,Taille)
			else
				N_0 = real(Nf_Inter+Nb_Inter/5._dp,8)
				alpha_m = real(Nb_Inter/10._dp,8)
				XpartInter = Metropolis(C_Inter,N_0,alpha_m,Taille)
			end if
			DeltaT = 100._dp!0.1_dp
			TF = T+DeltaT
			!dt_sto = 0.1_dp
		end if
		if ((C(tab_fe(-Nf_Vac,Nv)) > 1.e17).and.(.not.Coupling_Vac)) then
			Coupling_Vac = .True.
			print *, "LACUNES"
			C_Vac = 0._dp
			C_Vac(Nf_Vac:Nf_Vac+Nb_Vac) = C(tab_fe(-Nf_Vac,Nv):tab_fe(-Nf_Vac-Nb_Vac,Nv):-1)
			MStoVac = sum(C_Vac)
			if ((methode.eq.1) .or. (methode.eq.3)) then
				XpartVac = -1._dp*Multinomial(C_Vac,Nf_Vac,Nf_Vac+Nb_Vac,Taille)
			else
				N_0 = real(Nf_Vac+Nb_Vac/5._dp,8)
				alpha_m = real(Nb_Vac/10._dp,8)
				XpartVac = -1._dp*Metropolis(C_vac,N_0,alpha_m,Taille)
			end if
			DeltaT = 100._dp!0.1_dp
			TF = T+DeltaT
			!dt_sto = 0.1_dp
		end if

		if (rank.eq.0) then
			call output(C_sto,T)
		end if
		call FCVREINIT(T, C_init, iatol, reltol, abstol, IER)
	end do

	deallocate(C)
	deallocate(C_init)
	deallocate(C_stotodis)
	deallocate(MPI_C_stotodis)
	deallocate(C_sto)
	deallocate(C_Inter)
	deallocate(C_Vac)
	deallocate(C_Mob)
	deallocate(MPI_C_Mob)

call MPI_FINALIZE(ierror)

case(5)

call MPI_INIT(ierror)

call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierror)

call MPI_COMM_SIZE(MPI_COMM_WORLD,numproc,ierror)

	! --- Initialisation du générateur aléatoire
	call init_random_seed
	print *, "Initialisation"
	! --- Initialisation du solver
	Ni = Nf_Inter+Nb_Inter
	Nv = Nf_Vac+Nb_Vac
	Neq = 1 + Ni + Nv
	Nmaxi = 5000
	Nmaxv = 1000
	mv = 1
	mi = 1
	allocate(C(Neq))
	allocate(C_init(Neq))
	allocate(C_init1(Neq))
	allocate(C_init2(Neq))
	allocate(C_stotodis(-Nv:Ni))
	allocate(MPI_C_stotodis(-Nv:Ni))
	allocate(C_sto(-2000:2000))
	allocate(C_Inter(1:Ni))
	allocate(C_Vac(1:Nv))
	allocate(C_Mob(-mv:mi))
	allocate(MPI_C_mob(-mv:mi))

	allocate(Alpha_tab(-Nmaxv:Nmaxi,-mv:mi))
	allocate(Beta_tab(-Nmaxv:Nmaxi,-mv:mi))

	do nloop = -Nmaxv,Nmaxi
		do mloop = -mv,mi
			Alpha_tab(nloop,mloop) = alpha_nm(real(nloop,8),real(mloop,8))
			Beta_tab(nloop,mloop) = beta_nm(real(nloop,8),real(mloop,8))
		end do
	end do

	call fnvinits(isolver,Neq,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fnvinits'
		stop
	end if

	T = 0._dp
	T0 = 0._dp
	TF = 100._dp
	DeltaT = 100._dp
	abstol = 1e-10_dp
	reltol = 1e-5_dp
	C_init(1) = 0._dp
	C_init(2:Neq) = 0._dp

	call fcvmalloc(T0,C_init,meth,itmeth,iatol,reltol,abstol,Iout,Rout,IPAR,RPAR,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvmalloc', IER
		stop
	end if

	maxerrfail = 15
	nitermax = 10000

	call fcvsetiin('MAX_NSTEPS',nitermax,IER)
	call fcvsetiin('MAX_ERRFAIL',maxerrfail,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvsetiin'
		stop
	end if

	call fcvdense(Neq,IER)
	if (IER /= 0) then
		write(*,*) 'ERROR in fcvdense', IER
		stop
	end if

	print *, "Initialisation : ok"

	! --- Boucle principale solver+stochastique

	print *, "Boucle deterministe"
	! --- On propage en full EDO jusqu'au critere d'arret
	quasi = .False.
	do while ((C(tab_fe(Nf_Inter,Nv)) < 1.e15) .and. (C(tab_fe(-Nf_Vac,Nv)) < 1.e17))
		call fcvode(TF,T,C,itask,IER)
		call output(C,T)
		TF = TF + DeltaT
	end do
	if (C(tab_fe(Nf_Inter,Nv)) > 1.e15) then
		print *, "INTERSTITIELS"
		Coupling_Inter = .True.
	end if
	if (C(tab_fe(-Nf_Vac,Nv)) > 1.e17) then
		Coupling_Vac = .True.
		print *, "LACUNES"
	end if
	print *, "Boucle deterministe : ok"

	! --- On genere la partie stochastique et on restart avec la nouvelle CI sur C

	print *, "Initialisation boucle stochastique"
	quasi = .True.

	C_init1 = 0._dp
	C_init2 = 0._dp
	CmobVac = C(tab_fe(-mv,Nv))
	CmobInter = C(tab_fe(mi,Nv))
	C_init1(tab_fe(-Nf_Vac+1,Nv):tab_fe(Nf_Inter-1,Nv)) = C(tab_fe(-Nf_Vac+1,Nv):tab_fe(Nf_Inter-1,Nv))
	C_init2(tab_fe(-Nv,Nv):tab_fe(-Nf_Vac,Nv)) = C(tab_fe(-Nv,Nv):tab_fe(-Nf_Vac,Nv))
	C_init2(tab_fe(Nf_Inter,Nv):tab_fe(Ni,Nv)) = C(tab_fe(Nf_Inter,Nv):tab_fe(Ni,Nv))

	T = 0._dp
	call FCVREINIT(T, C_init1, iatol, reltol, abstol, IER)

	print *, "Initialisation boucle stochastique : ok"

	! --- Boucle de couplage
	do mainloop = 1, 2000
		C_sto = 0._dp

		CmobInter = C_init1(tab_fe(1,Nv))
		CmobVac = C_init1(tab_fe(-1,Nv))

		print *, "Calcul deterministe"

		! Somme sur les amas C_init2
		bCnCi_sto = 0._dp
		bCnCv_sto = 0._dp
		aCi_sto = 0._dp
		aCv_sto = 0._dp
		Si_sto = 0._dp
		Sv_sto = 0._dp

		do iloop = Nf_Inter, Nf_Inter + Nb_Inter-1
			bCnCi_sto = bCnCi_sto - Beta_tab(iloop,1)*C_init2(tab_fe(iloop,Nv))*CmobInter
			bCnCv_sto = bCnCv_sto - Beta_tab(iloop,-1)*C_init2(tab_fe(iloop,Nv))*CmobVac
			aCi_sto = aCi_sto + Alpha_tab(iloop+1,1)*C_init2(tab_fe(iloop+1,Nv))
			aCv_sto = aCv_sto + Alpha_tab(iloop-1,-1)*C_init2(tab_fe(iloop-1,Nv))
			Si_sto = Si_sto + Beta_tab(iloop,1)*C_init2(tab_fe(iloop,Nv))
			Sv_sto = Sv_sto + Beta_tab(iloop,-1)*C_init2(tab_fe(iloop,Nv))
		enddo

		quasi1 = .False.

		TF1 = DeltaT
		print *, TF, T
		call fcvode(TF1,T,C,itask,IER)
		print *, TF, T
		print *, "Calcul deterministe : ok"

		T2 = TF1-DeltaT
		TF2 = TF1
		C_init1 = C

		quasi1 = .True.

		call FCVREINIT(T2, C_init2, iatol, reltol, abstol, IER)

		call fcvode(TF2,T2,C,itask,IER)
		C_init2 = C

		!DeltaT = min(2._dp*DeltaT,1000._dp)

		C_init1(tab_fe(-Nf_Vac+1,Nv):tab_fe(Nf_Inter-1,Nv)) = C_init1(tab_fe(-Nf_Vac+1,Nv):tab_fe(Nf_Inter-1,Nv)) + &
															& C_init2(tab_fe(-Nf_Vac+1,Nv):tab_fe(Nf_Inter-1,Nv))

		C_init2(tab_fe(-Nv,Nv):tab_fe(-Nf_Vac,Nv)) = C_init2(tab_fe(-Nv,Nv):tab_fe(-Nf_Vac,Nv)) + &
													& C_init1(tab_fe(-Nv,Nv):tab_fe(-Nf_Vac,Nv))

		C_init2(tab_fe(Nf_Inter,Nv):tab_fe(Ni,Nv)) = C_init2(tab_fe(Nf_Inter,Nv):tab_fe(Ni,Nv)) + &
													& C_init1(tab_fe(Nf_Inter,Nv):tab_fe(Ni,Nv))

		C_init1(tab_fe(-Nv,Nv):tab_fe(-Nf_Vac,Nv)) = 0._dp
		C_init1(tab_fe(Nf_Inter,Nv):tab_fe(Ni,Nv)) = 0._dp
		C_init2(tab_fe(-Nf_Vac+1,Nv):tab_fe(Nf_Inter-1,Nv)) = 0._dp

		T = 0._dp
		if (rank.eq.0) then
			call output(C_init1+C_init2,TF)
		end if
		call FCVREINIT(T, C_init1, iatol, reltol, abstol, IER)

		TF = TF + DeltaT
	end do

	deallocate(C)
	deallocate(C_init)
	deallocate(C_stotodis)
	deallocate(MPI_C_stotodis)
	deallocate(C_sto)
	deallocate(C_Inter)
	deallocate(C_Vac)
	deallocate(C_Mob)
	deallocate(MPI_C_Mob)

call MPI_FINALIZE(ierror)

end select

end program


module mtutil

character(len=32) :: mtutil_mode
character(len=512) :: input
character(len=32) :: input_mode
character(len=512) :: output
integer :: nvals_input
integer :: nvals_output
character(len=5) :: scalar_moment_mode

end module

!==================================================================================================!

program main
!----
! Program for manipulating seismic source data, including:
!     Moment tensors
!     P, N, and T axes
!     Double couple parameters
!     Seismic moment/Moment magnitude
!     Ternary characterization (after Frohlich, 1992)
!----

use io, only: stdin, stdout, stderr, fileExists, line_count
use eq, only: mag2mom, &
              mom2mag, &
              mij2dcp, &
              mij2mag, &
              mij2mom, &
              mij2pnt, &
              mij2sdr, &
              mij2sv, &
              mij2ter, &
              pnt2dcp, &
              pnt2mag, &
              pnt2mag_nondc, &
              pnt2mij, &
              pnt2mom, &
              pnt2mom_nondc, &
              pnt2sdr, &
              pnt2sv, &
              pnt2ter, &
              sdr2mij, &
              sdr2pnt, &
              sdr2sdr, &
              sdr2sv, &
              sdr2ter, &
              sdr2kagan, &
              mij2kagan

use mtutil, only: mtutil_mode, &
                  input, &
                  input_mode, &
                  output, &
                  nvals_input, &
                  nvals_output, &
                  scalar_moment_mode
implicit none

! Local variables
integer :: i, j, ninputs, luin, luout, ios
double precision :: input_values(12), input_values2(12), output_values(12)
character(len=512) :: tmp_file, input_line
character(len=64) :: fmt_string
character(len=8) :: output_mode

! Initialize variables
input_values = 0.0d0
output_values = 0.0d0
tmp_file = 'mtutil_86_this_file_when_program_exits.tmp'

! Parse the command line
call gcmdln()

! Count the number of input lines and set the input unit
if (input_mode.eq.'file') then
    luin = 11
    if (.not.fileExists(input)) then
        call usage('mtutil: input file "'//trim(input)//'" not found')
    endif
    ninputs = line_count(input)
elseif (input_mode.eq.'cmdln') then
    luin = 11
    ! Replace commas with spaces in command line argument
    i = index(input,',')
    do while (i.ne.0)
        input(i:i) = ' '
        i = index(input,',')
    enddo
    ! Write command line info to temporary input file
    open(unit=luin,file=tmp_file,status='unknown')
    write(luin,*) input
    close(luin)
    input = tmp_file
    ninputs = 1
elseif (input_mode.eq.'stdin') then
    luin = stdin
    ninputs = 100000000
else
    call usage('mtutil: no input_mode named "'//trim(input_mode)//'"')
endif

! Open the input file if necessary
if (input_mode.eq.'file'.or.input_mode.eq.'cmdln') then
    open(unit=luin,file=input,status='old')
endif

! Set the output unit
if (output.eq.'stdout') then
    luout = stdout
else
    luout = 12
    open(unit=luout,file=output,status='unknown')
endif

! Read the inputs and run specified calculation
do i = 1,ninputs
    read(luin,'(A)',end=1001) input_line
    if (nvals_input.ge.1) then
        read(input_line,*,iostat=ios) (input_values(j),j=1,nvals_input)
    elseif (nvals_input.le.-1) then
        read(input_line,*,iostat=ios) (input_values(j),j=1,abs(nvals_input)), &
                                      (input_values2(j),j=1,abs(nvals_input))
    else
        write(stderr,*) 'nvals_input set to illegal value'
    endif
    if (ios.ne.0) then
        write(stderr,*) 'mtutil: error parsing inputs "',trim(input_line),'"'
        call usage('')
    endif
    ! write(0,*) input_values(1:nvals_input)

    ! Convert between moment and magnitude
    if (mtutil_mode.eq.'mag2mom') then
        call mag2mom(input_values(1),output_values(1))
    elseif (mtutil_mode.eq.'mom2mag') then
        call mom2mag(input_values(1),output_values(1))

    ! Input quantity: moment tensor
    elseif (mtutil_mode.eq.'mij2dcp') then
        call mij2dcp(input_values(1),input_values(2),input_values(3),&
                     input_values(4),input_values(5),input_values(6),&
                     output_values(1))
    elseif (mtutil_mode.eq.'mij2mag') then
        call mij2mag(input_values(1),input_values(2),input_values(3),&
                     input_values(4),input_values(5),input_values(6),&
                     output_values(1),scalar_moment_mode)
        if (abs(output_values(1)).le.-99.0d0) then
            call usage('mtutil: no scalar moment mode called '//trim(scalar_moment_mode))
        endif
    elseif (mtutil_mode.eq.'mij2mom') then
        call mij2mom(input_values(1),input_values(2),input_values(3),&
                     input_values(4),input_values(5),input_values(6),&
                     output_values(1),scalar_moment_mode)
        if (abs(output_values(1)).le.1.0d-50) then
            call usage('mtutil: no scalar moment mode called '//trim(scalar_moment_mode))
        endif
    elseif (mtutil_mode.eq.'mij2pnt') then
        call mij2pnt(input_values(1),input_values(2),input_values(3),&
                     input_values(4),input_values(5),input_values(6),&
                     output_values)
    elseif (mtutil_mode.eq.'mij2sdr') then
        nvals_output = 6
        call mij2sdr(input_values(1),input_values(2),input_values(3),&
                     input_values(4),input_values(5),input_values(6),&
                     output_values(1),output_values(2),output_values(3),&
                     output_values(4),output_values(5),output_values(6))
    elseif (mtutil_mode.eq.'mij2sv') then
        nvals_output = 6
        call mij2sv(input_values(1),input_values(2),input_values(3),&
                    input_values(4),input_values(5),input_values(6),&
                    output_values(1:3),output_values(4:6))
    elseif (mtutil_mode.eq.'mij2ter') then
        call mij2ter(input_values(1),input_values(2),input_values(3),&
                     input_values(4),input_values(5),input_values(6),&
                     output_values(1),output_values(2),output_values(3))

    ! Input quantity: moment tensor eigenvectors/eigenvalues (P, N, T axes)
    elseif (mtutil_mode.eq.'pnt2dcp') then
        call pnt2dcp(input_values,output_values(1))
    elseif (mtutil_mode.eq.'pnt2mag') then
        if (scalar_moment_mode.eq.'dc') then
            call pnt2mag(input_values,output_values(1))
        elseif (scalar_moment_mode.eq.'nondc') then
            call pnt2mag_nondc(input_values,output_values(1))
        else
            call usage('mtutil: no scalar moment mode called '//trim(scalar_moment_mode))
        endif
    elseif (mtutil_mode.eq.'pnt2mij') then
        call pnt2mij(input_values,&
                     output_values(1),output_values(2),output_values(3),&
                     output_values(4),output_values(5),output_values(6))
    elseif (mtutil_mode.eq.'pnt2mom') then
        if (scalar_moment_mode.eq.'dc') then
            call pnt2mom(input_values,output_values(1))
        elseif (scalar_moment_mode.eq.'nondc') then
            call pnt2mom_nondc(input_values,output_values(1))
        else
            call usage('mtutil: no scalar moment mode called '//trim(scalar_moment_mode))
        endif
    elseif (mtutil_mode.eq.'pnt2sdr') then
        nvals_output = 6
        call pnt2sdr(input_values,&
                     output_values(1),output_values(2),output_values(3),&
                     output_values(4),output_values(5),output_values(6))
    elseif (mtutil_mode.eq.'pnt2sv') then
        nvals_output = 6
        call pnt2sv(input_values,output_values(1:3),output_values(4:6))
    elseif (mtutil_mode.eq.'pnt2ter') then
        call pnt2ter(input_values,output_values(1),output_values(2),output_values(3))

    ! Input quantity: double couple strike, dip, rake
    elseif (mtutil_mode.eq.'sdr2mij') then
        call sdr2mij(input_values(1),input_values(2),input_values(3),&
                     output_values(1),output_values(2),output_values(3),&
                     output_values(4),output_values(5),output_values(6))
    elseif (mtutil_mode.eq.'sdr2pnt') then
        call sdr2pnt(input_values(1),input_values(2),input_values(3),output_values)
    elseif (mtutil_mode.eq.'sdr2sdr') then
        nvals_output = 3
        call sdr2sdr(input_values(1),input_values(2),input_values(3),&
                     output_values(1),output_values(2),output_values(3))
    elseif (mtutil_mode.eq.'sdr2sv') then
        nvals_output = 3
        call sdr2sv(input_values(1),input_values(2),input_values(3),&
                    output_values(1:3))
    elseif (mtutil_mode.eq.'sdr2ter') then
        call sdr2ter(input_values(1),input_values(2),input_values(3),&
                     output_values(1),output_values(2),output_values(3))

    ! output -> kagan angle
    elseif (mtutil_mode.eq.'sdr2kagan') then
        call sdr2kagan(input_values(1), input_values(2), input_values(3), &
                       input_values2(1),input_values2(2),input_values2(3), &
                       output_values(1))
    elseif (mtutil_mode.eq.'mij2kagan') then
        call mij2kagan(input_values(1), input_values(2), input_values(3), &
                       input_values(4), input_values(5), input_values(6), &
                       input_values2(1),input_values2(2),input_values2(3), &
                       input_values2(4),input_values2(5),input_values2(6), &
                       output_values(1))

    else
        call usage('mtutil: no option '//trim(mtutil_mode))
    endif

    ! Print output quantity
    j = index(mtutil_mode,'2')
    output_mode = mtutil_mode(j+1:len(mtutil_mode))
    if (output_mode.eq.'mag') then
        fmt_string = '(1F10.4)'
    elseif (output_mode.eq.'mom') then
        fmt_string = '(1P1E14.6)'
    elseif (output_mode.eq.'mij') then
        fmt_string = '(1P6E14.6)'
    elseif (output_mode.eq.'pnt') then
        fmt_string = '(3(3F12.8,X),X,1P3E14.6)'
    elseif (output_mode.eq.'sdr') then
        if (nvals_output.eq.3) then
            fmt_string = '(F12.6,F12.6,F12.4)'
        else
            fmt_string = '(F12.6,F12.6,F12.4,4X,F12.6,F12.6,F12.4)'
        endif
    elseif (output_mode.eq.'ter') then
        fmt_string = '(3F12.8)'
    elseif (output_mode.eq.'dcp') then
        fmt_string = '(1F12.8)'
    elseif (output_mode.eq.'sv') then
        if (nvals_output.eq.3) then
            fmt_string = '(3F12.8)'
        else
            fmt_string = '(3F12.8,2X,3F12.8)'
        endif
    else
        write(fmt_string,'("(1P",I3,"E14.6)")') nvals_output
    endif
    write(luout,fmt_string) output_values(1:nvals_output)

enddo
1001 continue

! Close the input file and delete it if necessary
if (input_mode.eq.'file') then
    close(luin)
elseif (input_mode.eq.'cmdln') then
    close(luin,status='delete')
endif

! Close the output file
if (output.ne.'stdout') then
    close(luout)
endif

end

!--------------------------------------------------------------------------------------------------!

subroutine gcmdln()

use io, only: isNumeric
use mtutil, only: mtutil_mode, &
                  input, &
                  input_mode, &
                  output, &
                  nvals_input, &
                  nvals_output, &
                  scalar_moment_mode
implicit none

! Local variables
integer :: i, j, narg
character(len=512) :: tag

! Initialize
mtutil_mode = ''
input = ''
input_mode = ''
output = 'stdout'
nvals_input = 0
nvals_output = 0
scalar_moment_mode = 'dc'

! Number of arguments
narg = command_argument_count()
if (narg.eq.0) then
  call usage('')
endif

! First argument defines input parameters
i = 1
call get_command_argument(i,tag)
if (trim(tag).eq.'-sdr') then
    mtutil_mode = 'sdr2'
    nvals_input = 3
elseif (trim(tag).eq.'-mij') then
    mtutil_mode = 'mij2'
    nvals_input = 6
elseif (trim(tag).eq.'-pnt') then
    mtutil_mode = 'pnt2'
    nvals_input = 12
elseif (trim(tag).eq.'-mag') then
    mtutil_mode = 'mag2'
    nvals_input = 1
elseif (trim(tag).eq.'-mom') then
    mtutil_mode = 'mom2'
    nvals_input = 1
else
    call usage('mtutil: no input option '//tag)
endif
! write(0,*) trim(mode), nvals_input

! Optional argument defines a file name or value(s) for input
i = i + 1
if (i.gt.narg) then
    call usage('mtutil: input and output are required')
endif
! Determine how to read the second argument
call get_command_argument(i,input)
j = index(input,',')
if (j.ne.0) then
    ! comma => list of numbers to be read directly
    input_mode = 'cmdln'
    i = i + 1
else
    ! no comma => single number OR file name OR blank
    if (isNumeric(input)) then
        ! argument is readable as floating point number => read directly
        input_mode = 'cmdln'
        i = i + 1
    else
        ! argument is not readable as floating point number
        j = index(input,'-')
        if (j.eq.1) then
            ! argument starts with dash => mtutil flag
            input_mode = 'stdin'
        else
            ! argument does not start with dash => file name
            input_mode = 'file'
            i = i + 1
        endif
    endif
endif
! Make sure some input mode is specified
if (input_mode.eq.'') then
    call usage('mtutil: no input mode specified')
endif
! write(0,*) trim(input_mode)

! Second argument defines output parameters
if (i.gt.narg) then
    call usage('mtutil: an output option is required')
endif
call get_command_argument(i,tag)
if (trim(tag).eq.'-sdr') then
    mtutil_mode = trim(mtutil_mode)//'sdr'
    nvals_output = 3
elseif (trim(tag).eq.'-mij') then
    mtutil_mode = trim(mtutil_mode)//'mij'
    nvals_output = 6
elseif (trim(tag).eq.'-pnt') then
    mtutil_mode = trim(mtutil_mode)//'pnt'
    nvals_output = 12
elseif (trim(tag).eq.'-mag') then
    mtutil_mode = trim(mtutil_mode)//'mag'
    nvals_output = 1
elseif (trim(tag).eq.'-mom') then
    mtutil_mode = trim(mtutil_mode)//'mom'
    nvals_output = 1
elseif (trim(tag).eq.'-dcp') then
    mtutil_mode = trim(mtutil_mode)//'dcp'
    nvals_output = 1
elseif (trim(tag).eq.'-ternary') then
    mtutil_mode = trim(mtutil_mode)//'ter'
    nvals_output = 3
elseif (trim(tag).eq.'-sv') then
    mtutil_mode = trim(mtutil_mode)//'sv'
    nvals_output = 6
elseif (trim(tag).eq.'-kagan') then
    mtutil_mode = trim(mtutil_mode)//'kagan'
    nvals_output = 1
    nvals_input = -nvals_input
else
      call usage('mtutil: no output option '//tag)
endif
! write(0,*) trim(mode)

! Optional argument defines a file name for output
i = i + 1
if (i.le.narg) then
    call get_command_argument(i,output)
    j = index(output,'-')
    if (j.eq.1) then
        ! argument starts with dash => mtutil flag, so send output to stdout
        output = 'stdout'
    else
        ! argument does not start with dash => output file name
        i = i + 1
    endif
endif

! Extra arguments
do while (i.le.narg)
    call get_command_argument(i,tag)
    if (trim(tag).eq.'-dc') then
        scalar_moment_mode = 'dc'
    elseif (trim(tag).eq.'-non-dc') then
        scalar_moment_mode = 'nondc'
    else
        call usage('mtutil: no option '//trim(tag))
    endif
    i = i + 1
enddo

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine usage(str)
use io, only: stderr
implicit none
character(len=*) :: str

if (str.ne.'') then
    write(stderr,*) trim(str)
    write(stderr,*)
endif

write(stderr,*) 'Usage: mtutil -opt [INPUT] -opt [FILE] [...OPTIONS...]'
write(stderr,*)
write(stderr,*) 'Input/output:'
write(stderr,*) '-sdr      Strike, dip, and rake angles'
write(stderr,*) '-mij      Moment tensor components (mrr mtt mpp mrt mrp mtp)'
write(stderr,*) '-pnt      P, N, T axes (px,py,pz,nx,ny,nz,tx,ty,tz,pmag,nmag,tmag)'
write(stderr,*) '-mag      Moment magnitude'
write(stderr,*) '-mom      Seismic moment (Nm)'
write(stderr,*)
write(stderr,*) 'Output only:'
write(stderr,*) '-ternary  Ternary classification (fth fss fno)'
write(stderr,*) '-dcp      Double couple percentage'
write(stderr,*) '-sv       Slip vector (e n z components)'
write(stderr,*) '-kagan    Calculate angle between two moment tensors (requires double inputs)'
write(stderr,*)
write(stderr,*) 'Other options:'
write(stderr,*) '-dc       Use the double couple scalar seismic moment for -mom/-mag (default)'
write(stderr,*) '-non-dc   Use the general scalar seismic moment for -mom/-mag'
write(stderr,*)
write(stderr,*) 'Input format options:'
write(stderr,*) 'file name: read from file INPUT'
write(stderr,*) 'comma delimited list: read from command line'
write(stderr,*) '"stdin" or blank: read from standard input'
write(stderr,*)
write(stderr,*) 'Output format options:'
write(stderr,*) 'file name: write to file OUTPUT'
write(stderr,*) 'blank: print to standard output'
write(stderr,*)

call error_exit(1)
end subroutine


*DECK BKSOL
      SUBROUTINE BKSOL (N, A, X)
C***BEGIN PROLOGUE  BKSOL
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BKSOL-S, DBKSOL-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C **********************************************************************
C     Solution of an upper triangular linear system by
C     back-substitution
C
C     The matrix A is assumed to be stored in a linear
C     array proceeding in a row-wise manner. The
C     vector X contains the given constant vector on input
C     and contains the solution on return.
C     The actual diagonal of A is unity while a diagonal
C     scaling matrix is stored there.
C **********************************************************************
C
C***SEE ALSO  BVSUP
C***ROUTINES CALLED  SDOT
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  BKSOL
C
      DIMENSION A(*),X(*)
C
C***FIRST EXECUTABLE STATEMENT  BKSOL
      M=(N*(N+1))/2
      X(N)=X(N)*A(M)
      IF (N .EQ. 1) GO TO 20
      NM1=N-1
      DO 10 K=1,NM1
      J=N-K
      M=M-K-1
   10 X(J)=X(J)*A(M) - SDOT(K,A(M+1),1,X(J+1),1)
C
   20 RETURN
      END


module damage_var
	! contains routines for computation of damage part of the modified leon model

	! load additional modules
	use constants
	use derived_types

    implicit none

contains

	function comp_delta_alpha_d(delta_epsilon_p, alpha)
		! computes increment of internal scalar strain like softening variable,

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: delta_epsilon_p		! incremental plastic strains vector
		real(kind=dbl), dimension(:), intent(in) :: alpha				! internal variables vector (for continuum hardening and softening)

		! return variable
		real(kind=dbl) :: comp_delta_alpha_d					! increment of internal scalar strain like softening variable

		! internal variable
		! --------------------------------------------------------------------------

		! compuation of delta alpha_d
		! .
		! .
		! .
		! comp_delta_alpha_d = ...

	end function comp_delta_alpha_d

end module damage_var