!>
!! @file m_time_steppers.f90
!! @brief Contains module m_time_steppers

!> @brief The following module features a variety of time-stepping schemes.
!!              Currently, it includes the following Runge-Kutta (RK) algorithms:
!!                   1) 1st Order TVD RK
!!                   2) 2nd Order TVD RK
!!                   3) 3rd Order TVD RK
!!                   4) 4th Order RK
!!                   5) 5th Order RK
!!              where TVD designates a total-variation-diminishing time-stepper.
MODULE m_time_steppers

    ! Dependencies =============================================================
    USE m_derived_types        !< Definitions of the derived types

    USE m_global_parameters    !< Definitions of the global parameters

    USE m_fftw                 !< Module for FFTW functions

    USE m_rhs                  !< Right-hand-side (RHS) evaluation procedures

    USE m_data_output          !< Run-time info & solution data output procedures

    USE m_bubbles              !< Bubble dynamics routines

    USE m_mpi_proxy            !< Message passing interface (MPI) module proxy
    ! ==========================================================================

    IMPLICIT NONE

    TYPE(vector_field), ALLOCATABLE, DIMENSION(:) :: q_cons_ts !<
    !! Cell-average conservative variables at each time-stage (TS)

    TYPE(scalar_field), PRIVATE, ALLOCATABLE, DIMENSION(:) :: q_prim_vf !<
    !! Cell-average primitive variables at the current time-stage

    TYPE(scalar_field), ALLOCATABLE, DIMENSION(:) :: rhs_vf !<
    !! Cell-average RHS variables at the current time-stage

    TYPE(vector_field), ALLOCATABLE, DIMENSION(:) :: q_prim_ts !<
    !! Cell-average primitive variables at consecutive TIMESTEPS

    INTEGER, PRIVATE :: num_ts !<
    !! Number of time stages in the time-stepping scheme

    CONTAINS

        !> The computation of parameters, the allocation of memory,
        !!      the association of pointers and/or the execution of any
        !!      other procedures that are necessary to setup the module.
        SUBROUTINE s_initialize_time_steppers_module() ! -----------------------

            TYPE(bounds_info) :: ix,iy,iz !<
            !! Indical bounds in the x-, y- and z-directions

            INTEGER :: i,j !< Generic loop iterators

            ! Setting number of time-stages for selected time-stepping scheme
            IF(time_stepper == 1) THEN
                num_ts = 1
            ELSEIF(ANY(time_stepper == (/2,3/))) THEN
                num_ts = 2
            ELSEIF(time_stepper == 4) THEN
                num_ts = 3
            ELSE
                num_ts = 6
            END IF

            ! Setting the indical bounds in the x-, y- and z-directions
            ix%beg = -buff_size; ix%end = m + buff_size

            IF(n > 0) THEN

                iy%beg = -buff_size; iy%end = n + buff_size

                IF(p > 0) THEN
                    iz%beg = -buff_size; iz%end = p + buff_size
                ELSE
                    iz%beg = 0; iz%end = 0
                END IF

            ELSE

                iy%beg = 0; iy%end = 0
                iz%beg = 0; iz%end = 0

            END IF

            ! Allocating the cell-average conservative variables
            ALLOCATE(q_cons_ts(1:num_ts))

            DO i = 1, num_ts
                ALLOCATE(q_cons_ts(i)%vf(1:sys_size))
            END DO

            DO i = 1, num_ts
                DO j = 1, sys_size
                    ALLOCATE(q_cons_ts(i)%vf(j)%sf( ix%beg:ix%end, &
                                                    iy%beg:iy%end, &
                                                    iz%beg:iz%end ))
                END DO
            END DO

            ! Allocating the cell-average primitive ts variables
            IF (ANY(com_wrt) .OR. ANY(cb_wrt) .OR. probe_wrt) THEN
                ALLOCATE(q_prim_ts(0:3))

                DO i = 0, 3
                    ALLOCATE(q_prim_ts(i)%vf(1:sys_size))
                END DO

                DO i = 0, 3
                    DO j = 1, sys_size
                        ALLOCATE(q_prim_ts(i)%vf(j)%sf( ix%beg:ix%end, &
                                        iy%beg:iy%end, &
                                        iz%beg:iz%end ))
                    END DO
                END DO
            END IF

            ! Allocating the cell-average primitive variables
            ALLOCATE(q_prim_vf(1:sys_size))

            DO i = mom_idx%beg, E_idx
                ALLOCATE(q_prim_vf(i)%sf( ix%beg:ix%end, &
                                          iy%beg:iy%end, &
                                          iz%beg:iz%end ))
            END DO

            IF (bubbles) THEN
                DO i = bub_idx%beg,sys_size
                    ALLOCATE(q_prim_vf(i)%sf( ix%beg:ix%end, &
                                          iy%beg:iy%end, &
                                          iz%beg:iz%end ))
                END DO
            END IF

            IF (hypoelasticity) THEN
                DO i = stress_idx%beg, stress_idx%end
                    ALLOCATE(q_prim_vf(i)%sf( ix%beg:ix%end, &
                                              iy%beg:iy%end, &
                                              iz%beg:iz%end ))
                END DO
            END IF

            IF (model_eqns == 3) THEN
                DO i = internalEnergies_idx%beg, internalEnergies_idx%end
                    ALLOCATE(q_prim_vf(i)%sf( ix%beg:ix%end, &
                                              iy%beg:iy%end, &
                                              iz%beg:iz%end ))
                END DO
            END IF

            ! Allocating the cell-average RHS variables
            ALLOCATE(rhs_vf(1:sys_size))

            DO i = 1, sys_size
                ALLOCATE(rhs_vf(i)%sf(0:m,0:n,0:p))
            END DO

            ! Opening and writing the header of the run-time information file
            IF(proc_rank == 0 .AND. run_time_info) THEN
                CALL s_open_run_time_information_file()
            END IF

        END SUBROUTINE s_initialize_time_steppers_module ! ---------------------

        !> 1st order TVD RK time-stepping algorithm
        !! @param t_step Current time step
        SUBROUTINE s_1st_order_tvd_rk(t_step) ! --------------------------------

            INTEGER, INTENT(IN) :: t_step

            INTEGER :: i !< Generic loop iterator

            ! Stage 1 of 1 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
            END DO

            IF (adv_alphan) THEN
                DO i = adv_idx%beg, adv_idx%end
                        q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
                END DO
            ELSE
                DO i = adv_idx%beg, sys_size
                    q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
                END DO
            END IF

            CALL s_compute_rhs(q_cons_ts(1)%vf, q_prim_vf, rhs_vf, t_step)
            IF (DEBUG) PRINT*, 'got rhs'

            IF(run_time_info) THEN
                CALL s_write_run_time_information(q_prim_vf, t_step)
            END IF
            IF (DEBUG) print*, 'wrote runtime info'

            IF (ANY(com_wrt) .OR. ANY(cb_wrt) .OR. probe_wrt) THEN
                CALL s_time_step_cycling(t_step)
            END IF

            IF(t_step == t_step_stop) RETURN

            DO i = 1, sys_size
                q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(1)%vf)

            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(1)%vf)

            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => NULL()
            END DO

            IF (adv_alphan) THEN
                DO i = adv_idx%beg, adv_idx%end
                    q_prim_vf(i)%sf => NULL()
                END DO
            ELSE
                DO i = adv_idx%beg, sys_size ! adv_idx%end
                    q_prim_vf(i)%sf => NULL()
                END DO
            END IF
            ! ==================================================================

        END SUBROUTINE s_1st_order_tvd_rk ! ------------------------------------

        !> 2nd order TVD RK time-stepping algorithm
        !! @param t_step Current time-step
        SUBROUTINE s_2nd_order_tvd_rk(t_step) ! --------------------------------

            INTEGER, INTENT(IN) :: t_step

            INTEGER :: i !< Generic loop iterator

            ! Stage 1 of 2 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(1)%vf, q_prim_vf, rhs_vf, t_step)

            IF(run_time_info) THEN
                CALL s_write_run_time_information(q_prim_vf, t_step)
            END IF

            IF (ANY(com_wrt) .OR. ANY(cb_wrt) .OR. probe_wrt) THEN
                CALL s_time_step_cycling(t_step)
            END IF

            IF(t_step == t_step_stop) RETURN

            DO i = 1, sys_size
                q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(2)%vf)

            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(2)%vf)
            ! ==================================================================

            ! Stage 2 of 2 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(2)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(2)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) = &
                             ( q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf ) / 2d0
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(1)%vf)

            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(1)%vf)

            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => NULL()
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => NULL()
            END DO
            ! ==================================================================

        END SUBROUTINE s_2nd_order_tvd_rk ! ------------------------------------

        !> 3rd order TVD RK time-stepping algorithm
        !! @param t_step Current time-step
        SUBROUTINE s_3rd_order_tvd_rk(t_step) ! --------------------------------

            INTEGER, INTENT(IN) :: t_step

            INTEGER :: i,j !< Generic loop iterator

            ! Stage 1 of 3 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(1)%vf, q_prim_vf, rhs_vf, t_step)

            IF(run_time_info) THEN
                CALL s_write_run_time_information(q_prim_vf, t_step)
            END IF

            IF (ANY(com_wrt) .OR. ANY(cb_wrt) .OR. probe_wrt) THEN
                CALL s_time_step_cycling(t_step)
            END IF

            IF(t_step == t_step_stop) RETURN

            DO i = 1, sys_size
                q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(2)%vf)

            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(2)%vf)

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

            ! Stage 2 of 3 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(2)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(2)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) = &
                           ( 3d0*q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                           +     q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) &
                           +     dt*rhs_vf(i)%sf ) / 4d0
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(2)%vf)

            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(2)%vf)

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

            ! Stage 3 of 3 =====================================================
            CALL s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) = &
                           (     q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                           + 2d0*q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) &
                           + 2d0*dt*rhs_vf(i)%sf ) / 3d0
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(1)%vf)

            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(1)%vf)

            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => NULL()
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => NULL()
            END DO
            ! ==================================================================

        END SUBROUTINE s_3rd_order_tvd_rk ! ------------------------------------

        !> Adaptive SSP RK23 time-stepping algorithm
        !! @param t_step Current time-step
        SUBROUTINE s_23_order_tvd_rk(t_step) ! --------------------------------

            INTEGER, INTENT(IN) :: t_step
            REAL(KIND(0d0)) :: relerr, absval, tmp
            REAL(KIND(0d0)) :: dtmin,dtmax

            INTEGER :: i,j !< Generic loop iterator

            ! Stage 1 of 3 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
            END DO
            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(1)%vf, q_prim_vf, rhs_vf, t_step)

            IF(run_time_info) CALL s_write_run_time_information(q_prim_vf, t_step)
            IF (ANY(com_wrt) .OR. ANY(cb_wrt) .OR. probe_wrt) &
                CALL s_time_step_cycling(t_step)

            IF(t_step == t_step_stop) RETURN

            DO i = 1, sys_size
                q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(2)%vf)
            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(2)%vf)

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

            ! Stage 2 of 3 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(2)%vf(i)%sf
            END DO
            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(2)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, t_step)

            ! RK2 estimate
            DO i = 1, sys_size
                q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p) = (              &
                                q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p)  &
                           +    q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p)  &
                           +    dt*rhs_vf(i)%sf ) / 2d0
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(3)%vf)
            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(3)%vf)

            ! Stage 2 of RK3
            DO i = 1, sys_size
                q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) = &
                           ( 3d0*q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                           +     q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) &
                           +     dt*rhs_vf(i)%sf ) / 4d0
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(2)%vf)
            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(2)%vf)

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

            ! Stage 3 of 3 =====================================================
            CALL s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) = &
                           (     q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                           + 2d0*q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) &
                           + 2d0*dt*rhs_vf(i)%sf ) / 3d0
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(1)%vf)
            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(1)%vf)

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

            ! Approximate error =================================================
            ! err = (q_cons_ts(1)%vf(i)%sf - q_cons_ts(3)%vf(i)%sf) / &
            !     q_cons_ts(1)%vf(i)

            ! PRINT*, '          '
            ! DO i = 1,sys_size
            !     PRINT*, 'MAXVAL', i,  MAXVAL( ABS( q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p)  ), 1 )
            ! END DO

            ! DO i = 1,sys_size
            !     PRINT*, 'ABSERR', i,  MAXVAL( ABS( q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) - &
            !         q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p)  ), 1 )
            ! END DO

            relerr = 0d0
            DO i = 1,sys_size
                absval = MAXVAL( ABS( q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p)  ) )
                IF ( absval >= 1D-10 ) THEN
                    relerr =  MAX( relerr, MAXVAL( ABS(             &
                       (q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) -        &
                        q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p)) /       &
                        q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) ) )   &
                        )
                END IF
            END DO

            IF (num_procs > 1) THEN
                tmp = relerr
                CALL s_mpi_allreduce_max(tmp,relerr)
            END IF

            dtmin = 0.002d0 / 2d0
            dtmax = 0.002d0 * 2d0

            dt = dt*Min( Max( Sqrt(t_tol/(2d0*relerr)) , 0.3d0 ), 2d0 )
            dt = Max( Min( dtmax, dt ), dtmin )
            ! dt = 0.0015d0

            IF (proc_rank==0) PRINT*, 'RELERR:', relerr
            IF (proc_rank==0) PRINT*, 'dt/dt0:', dt/dt0
            ! IF (proc_rank==0) PRINT*, '---t/T:', mytime/finaltime

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

            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => NULL()
            END DO
            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => NULL()
            END DO
            ! ==================================================================

        END SUBROUTINE s_23_order_tvd_rk ! ------------------------------------

        !> 4th order RK time-stepping algorithm
        !! @param t_step Current time-step
        SUBROUTINE s_4th_order_rk(t_step) ! ------------------------------------

            INTEGER, INTENT(IN) :: t_step

            INTEGER :: i !< Generic loop iterator

            ! Stage 1 of 4 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(1)%vf, q_prim_vf, rhs_vf, t_step)

            IF(run_time_info) THEN
                CALL s_write_run_time_information(q_prim_vf, t_step)
            END IF

            IF (ANY(com_wrt) .OR. ANY(cb_wrt) .OR. probe_wrt) THEN
                CALL s_time_step_cycling(t_step)
            END IF

            IF(t_step == t_step_stop) RETURN

            DO i = 1, sys_size
                q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf / 2d0
                q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf / 6d0
            END DO

            IF (grid_geometry == 3) THEN
                CALL s_apply_fourier_filter(q_cons_ts(2)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(3)%vf)
            END IF

            IF (model_eqns == 3) THEN
                CALL s_pressure_relaxation_procedure(q_cons_ts(2)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(3)%vf)
            END IF
            ! ==================================================================

            ! Stage 2 of 4 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(2)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(2)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf / 2d0
                q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf / 3d0
            END DO

            IF (grid_geometry == 3) THEN
                CALL s_apply_fourier_filter(q_cons_ts(2)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(3)%vf)
            END IF

            IF (model_eqns == 3) THEN
                CALL s_pressure_relaxation_procedure(q_cons_ts(2)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(3)%vf)
            END IF
            ! ==================================================================

            ! Stage 3 of 4 =====================================================
            CALL s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf
                q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf / 3d0
            END DO

            IF (grid_geometry == 3) THEN
                CALL s_apply_fourier_filter(q_cons_ts(2)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(3)%vf)
            END IF

            IF (model_eqns == 3) THEN
                CALL s_pressure_relaxation_procedure(q_cons_ts(2)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(3)%vf)
            END IF
            ! ==================================================================

            ! Stage 4 of 4 =====================================================
            CALL s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p) &
                             + dt*rhs_vf(i)%sf / 6d0
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(1)%vf)

            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(1)%vf)

            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => NULL()
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => NULL()
            END DO
            ! ==================================================================

        END SUBROUTINE s_4th_order_rk ! ----------------------------------------

        !> 5th order RK time-stepping algorithm
        !! @param t_step Current time-step
        SUBROUTINE s_5th_order_rk(t_step) ! ------------------------------------

            INTEGER, INTENT(IN) :: t_step

            INTEGER :: i !< Generic loop iterator

            ! Stage 1 of 6 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(1)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(1)%vf, q_prim_vf, rhs_vf, t_step)

            IF(run_time_info) THEN
                CALL s_write_run_time_information(q_prim_vf, t_step)
            END IF

            IF (ANY(com_wrt) .OR. ANY(cb_wrt) .OR. probe_wrt) THEN
                CALL s_time_step_cycling(t_step)
            END IF

            IF(t_step == t_step_stop) RETURN

            DO i = 1, sys_size
                q_cons_ts(2)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + 2d-1*dt*rhs_vf(i)%sf
                q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + 75d-3*dt*rhs_vf(i)%sf
                q_cons_ts(4)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + 3d-1*dt*rhs_vf(i)%sf
                q_cons_ts(5)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             - (11d0/54d0)*dt*rhs_vf(i)%sf
                q_cons_ts(6)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + (1631d0/55296d0)*dt*rhs_vf(i)%sf
                q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + (37d0/378d0)*dt*rhs_vf(i)%sf
            END DO

            IF (grid_geometry == 3) THEN
                CALL s_apply_fourier_filter(q_cons_ts(2)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(3)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(4)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(5)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(6)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(1)%vf)
            END IF

            IF (model_eqns == 3) THEN
                CALL s_pressure_relaxation_procedure(q_cons_ts(2)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(3)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(4)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(5)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(6)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(1)%vf)
            END IF
            ! ==================================================================

            ! Stage 2 of 6 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(2)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(2)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(3)%vf(i)%sf(0:m,0:n,0:p) &
                             + 225d-3*dt*rhs_vf(i)%sf
                q_cons_ts(4)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(4)%vf(i)%sf(0:m,0:n,0:p) &
                             - 9d-1*dt*rhs_vf(i)%sf
                q_cons_ts(5)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(5)%vf(i)%sf(0:m,0:n,0:p) &
                             + 25d-1*dt*rhs_vf(i)%sf
                q_cons_ts(6)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(6)%vf(i)%sf(0:m,0:n,0:p) &
                             + (175d0/512d0)*dt*rhs_vf(i)%sf
            END DO

            IF (grid_geometry == 3) THEN
                CALL s_apply_fourier_filter(q_cons_ts(3)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(4)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(5)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(6)%vf)
            END IF

            IF (model_eqns == 3) THEN
                CALL s_pressure_relaxation_procedure(q_cons_ts(3)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(4)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(5)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(6)%vf)
            END IF
            ! ==================================================================

            ! Stage 3 of 6 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(3)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(3)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(3)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(4)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(4)%vf(i)%sf(0:m,0:n,0:p) &
                             + 12d-1*dt*rhs_vf(i)%sf
                q_cons_ts(5)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(5)%vf(i)%sf(0:m,0:n,0:p) &
                             - (7d1/27d0)*dt*rhs_vf(i)%sf
                q_cons_ts(6)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(6)%vf(i)%sf(0:m,0:n,0:p) &
                             + (575d0/13824d0)*dt*rhs_vf(i)%sf
                q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + (25d1/621d0)*dt*rhs_vf(i)%sf
            END DO

            IF (grid_geometry == 3) THEN
                CALL s_apply_fourier_filter(q_cons_ts(4)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(5)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(6)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(1)%vf)
            END IF

            IF (model_eqns == 3) THEN
                CALL s_pressure_relaxation_procedure(q_cons_ts(4)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(5)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(6)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(1)%vf)
            END IF
            ! ==================================================================

            ! Stage 4 of 6 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(4)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(4)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(4)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(5)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(5)%vf(i)%sf(0:m,0:n,0:p) &
                             + (35d0/27d0)*dt*rhs_vf(i)%sf
                q_cons_ts(6)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(6)%vf(i)%sf(0:m,0:n,0:p) &
                             + (44275d0/110592d0)*dt*rhs_vf(i)%sf
                q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + (125d0/594d0)*dt*rhs_vf(i)%sf
            END DO

            IF (grid_geometry == 3) THEN
                CALL s_apply_fourier_filter(q_cons_ts(5)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(6)%vf)
                CALL s_apply_fourier_filter(q_cons_ts(1)%vf)
            END IF

            IF (model_eqns == 3) THEN
                CALL s_pressure_relaxation_procedure(q_cons_ts(5)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(6)%vf)
                CALL s_pressure_relaxation_procedure(q_cons_ts(1)%vf)
            END IF
            ! ==================================================================

            ! Stage 5 of 6 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(5)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(5)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(5)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(6)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(6)%vf(i)%sf(0:m,0:n,0:p) &
                             + (253d0/4096d0)*dt*rhs_vf(i)%sf
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(6)%vf)

            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(6)%vf)
            ! ==================================================================

            ! Stage 6 of 6 =====================================================
            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => q_cons_ts(6)%vf(i)%sf
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => q_cons_ts(6)%vf(i)%sf
            END DO

            CALL s_compute_rhs(q_cons_ts(6)%vf, q_prim_vf, rhs_vf, t_step)

            DO i = 1, sys_size
                q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) = &
                               q_cons_ts(1)%vf(i)%sf(0:m,0:n,0:p) &
                             + (512d0/1771d0)*dt*rhs_vf(i)%sf
            END DO

            IF (grid_geometry == 3) CALL s_apply_fourier_filter(q_cons_ts(1)%vf)

            IF (model_eqns == 3) CALL s_pressure_relaxation_procedure(q_cons_ts(1)%vf)

            DO i = 1, cont_idx%end
                q_prim_vf(i)%sf => NULL()
            END DO

            DO i = adv_idx%beg, adv_idx%end
                q_prim_vf(i)%sf => NULL()
            END DO
            ! ==================================================================

        END SUBROUTINE s_5th_order_rk ! ----------------------------------------

        !> This subroutine saves the temporary q_prim_vf vector
        !!      into the q_prim_ts vector that is then used in p_main
        !! @param t_step current time-step
        SUBROUTINE s_time_step_cycling(t_step) ! ----------------------------

            INTEGER, INTENT(IN) :: t_step

            INTEGER :: i !< Generic loop iterator

            IF (t_step == t_step_start) THEN
                DO i = 1, sys_size
                    q_prim_ts(3)%vf(i)%sf(:,:,:) = q_prim_vf(i)%sf(:,:,:)
                END DO
            ELSEIF (t_step == t_step_start + 1) THEN
                DO i = 1, sys_size
                    q_prim_ts(2)%vf(i)%sf(:,:,:) = q_prim_vf(i)%sf(:,:,:)
                END DO
            ELSEIF (t_step == t_step_start + 2) THEN
                DO i = 1, sys_size
                    q_prim_ts(1)%vf(i)%sf(:,:,:) = q_prim_vf(i)%sf(:,:,:)
                END DO
            ELSEIF (t_step == t_step_start + 3) THEN
                DO i = 1, sys_size
                    q_prim_ts(0)%vf(i)%sf(:,:,:) = q_prim_vf(i)%sf(:,:,:)
                END DO
            ELSE ! All other timesteps
                DO i = 1, sys_size
                    q_prim_ts(3)%vf(i)%sf(:,:,:) = q_prim_ts(2)%vf(i)%sf(:,:,:)
                    q_prim_ts(2)%vf(i)%sf(:,:,:) = q_prim_ts(1)%vf(i)%sf(:,:,:)
                    q_prim_ts(1)%vf(i)%sf(:,:,:) = q_prim_ts(0)%vf(i)%sf(:,:,:)
                    q_prim_ts(0)%vf(i)%sf(:,:,:) = q_prim_vf(i)%sf(:,:,:)
                END DO
            END IF

        END SUBROUTINE s_time_step_cycling ! -----------------------------------

        !> Module deallocation and/or disassociation procedures
        SUBROUTINE s_finalize_time_steppers_module() ! -------------------------

            INTEGER :: i,j !< Generic loop iterators

            ! Deallocating the cell-average conservative variables
            DO i = 1, num_ts

                DO j = 1, sys_size
                    DEALLOCATE(q_cons_ts(i)%vf(j)%sf)
                END DO

                DEALLOCATE(q_cons_ts(i)%vf)

            END DO

            DEALLOCATE(q_cons_ts)

            ! Deallocating the cell-average primitive ts variables
            IF (ANY(com_wrt) .OR. ANY(cb_wrt) .OR. probe_wrt) THEN
                DO i = 0, 3
                    DO j = 1, sys_size
                        DEALLOCATE(q_prim_ts(i)%vf(j)%sf)
                    END DO
                    DEALLOCATE(q_prim_ts(i)%vf)
                END DO
                DEALLOCATE(q_prim_ts)
            END IF

            ! Deallocating the cell-average primitive variables
            DO i = mom_idx%beg, E_idx
                DEALLOCATE(q_prim_vf(i)%sf)
            END DO
            IF (model_eqns == 3) THEN
                DO i = internalEnergies_idx%beg, internalEnergies_idx%end
                    DEALLOCATE(q_prim_vf(i)%sf)
                END DO
            END IF

            DEALLOCATE(q_prim_vf)

            ! Deallocating the cell-average RHS variables
            DO i = 1, sys_size
                DEALLOCATE(rhs_vf(i)%sf)
            END DO

            DEALLOCATE(rhs_vf)

            ! Writing the footer of and closing the run-time information file
            IF(proc_rank == 0 .AND. run_time_info) THEN
                CALL s_close_run_time_information_file()
            END IF

        END SUBROUTINE s_finalize_time_steppers_module ! -----------------------

END MODULE m_time_steppers


      SUBROUTINE AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find the dual of a given state-space representation.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBD    CHARACTER*1
C             Specifies whether or not a non-zero matrix D appears in
C             the given state space model:
C             = 'D':  D is present;
C             = 'Z':  D is assumed a zero matrix.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state-space representation.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the dual state dynamics matrix A'.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,MAX(M,P))
C             On entry, the leading N-by-M part of this array must
C             contain the original input/state matrix B.
C             On exit, the leading N-by-P part of this array contains
C             the dual input/state matrix C'.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the original state/output matrix C.
C             On exit, the leading M-by-N part of this array contains
C             the dual state/output matrix B'.
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= MAX(1,M,P) if N > 0.
C             LDC >= 1 if N = 0.
C
C     D       (input/output) DOUBLE PRECISION array, dimension
C             (LDD,MAX(M,P))
C             On entry, if JOBD = 'D', the leading P-by-M part of this
C             array must contain the original direct transmission
C             matrix D.
C             On exit, if JOBD = 'D', the leading M-by-P part of this
C             array contains the dual direct transmission matrix D'.
C             The array D is not referenced if JOBD = 'Z'.
C
C     LDD     INTEGER
C             The leading dimension of array D.
C             LDD >= MAX(1,M,P) if JOBD = 'D'.
C             LDD >= 1 if JOBD = 'Z'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     If the given state-space representation is the M-input/P-output
C     (A,B,C,D), its dual is simply the P-input/M-output (A',C',B',D').
C
C     REFERENCES
C
C     None
C
C     NUMERICAL ASPECTS
C
C     None
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine AB07AD by T.W.C.Williams, Kingston
C     Polytechnic, United Kingdom, March 1982.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004.
C
C     KEYWORDS
C
C     Dual system, state-space model, state-space representation.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      CHARACTER         JOBD
      INTEGER           INFO, LDA, LDB, LDC, LDD, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*)
C     .. Local Scalars ..
      LOGICAL           LJOBD
      INTEGER           J, MINMP, MPLIM
C     .. External functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External subroutines ..
      EXTERNAL          DCOPY, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      LJOBD = LSAME( JOBD, 'D' )
      MPLIM = MAX( M, P )
      MINMP = MIN( M, P )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' )  ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, MPLIM ) ) .OR.
     $         ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN
         INFO = -10
      ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, MPLIM ) ) .OR.
     $    ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN
         INFO = -12
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB07MD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, MINMP ).EQ.0 )
     $   RETURN
C
      IF ( N.GT.0 ) THEN
C
C        Transpose A, if non-scalar.
C
         DO 10 J = 1, N - 1
            CALL DSWAP( N-J, A(J+1,J), 1, A(J,J+1), LDA )
   10    CONTINUE
C
C        Replace B by C' and C by B'.
C
         DO 20 J = 1, MPLIM
            IF ( J.LE.MINMP ) THEN
               CALL DSWAP( N, B(1,J), 1, C(J,1), LDC )
            ELSE IF ( J.GT.P ) THEN
               CALL DCOPY( N, B(1,J), 1, C(J,1), LDC )
            ELSE
               CALL DCOPY( N, C(J,1), LDC, B(1,J), 1 )
            END IF
   20    CONTINUE
C
      END IF
C
      IF ( LJOBD .AND. MINMP.GT.0 ) THEN
C
C        Transpose D, if non-scalar.
C
         DO 30 J = 1, MPLIM
            IF ( J.LT.MINMP ) THEN
               CALL DSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD )
            ELSE IF ( J.GT.P ) THEN
               CALL DCOPY( P, D(1,J), 1, D(J,1), LDD )
            ELSE IF ( J.GT.M ) THEN
               CALL DCOPY( M, D(J,1), LDD, D(1,J), 1 )
            END IF
   30    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of AB07MD ***
      END


*     TB01ID EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX )
*     .. Local Scalars ..
      CHARACTER*1      JOB
      INTEGER          I, INFO, J, M, N, P
      DOUBLE PRECISION MAXRED
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 SCALE(NMAX)
*     .. External Subroutines ..
      EXTERNAL         TB01ID, UD01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, JOB, MAXRED
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Balance system matrix S.
               CALL TB01ID( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C,
     $                      LDC, SCALE, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  CALL UD01MD( N, N, 5, NOUT, A, LDA,
     $                        'The balanced matrix A', INFO )
                  IF ( M.GT.0 )
     $               CALL UD01MD( N, M, 5, NOUT, B, LDB,
     $                            'The balanced matrix B', INFO )
                  IF ( P.GT.0 )
     $               CALL UD01MD( P, N, 5, NOUT, C, LDC,
     $                            'The balanced matrix C', INFO )
                  CALL UD01MD( 1, N, 5, NOUT, SCALE, 1,
     $                        'The scaling vector SCALE', INFO )
                  WRITE ( NOUT, FMT = 99994 ) MAXRED
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01ID EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01ID = ',I2)
99994 FORMAT (/' MAXRED is ',E13.4)
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' P is out of range.',/' P = ',I5)
      END


*> \brief \b ZPOT01
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            LDA, LDAFAC, N
*       DOUBLE PRECISION   RESID
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   RWORK( * )
*       COMPLEX*16         A( LDA, * ), AFAC( LDAFAC, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZPOT01 reconstructs a Hermitian positive definite matrix  A  from
*> its L*L' or U'*U factorization and computes the residual
*>    norm( L*L' - A ) / ( N * norm(A) * EPS ) or
*>    norm( U'*U - A ) / ( N * norm(A) * EPS ),
*> where EPS is the machine epsilon, L' is the conjugate transpose of L,
*> and U' is the conjugate transpose of U.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the upper or lower triangular part of the
*>          Hermitian matrix A is stored:
*>          = 'U':  Upper triangular
*>          = 'L':  Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of rows and columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          The original Hermitian matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N)
*> \endverbatim
*>
*> \param[in,out] AFAC
*> \verbatim
*>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
*>          On entry, the factor L or U from the L * L**H or U**H * U
*>          factorization of A.
*>          Overwritten with the reconstructed matrix, and then with
*>          the difference L * L**H - A (or U**H * U - A).
*> \endverbatim
*>
*> \param[in] LDAFAC
*> \verbatim
*>          LDAFAC is INTEGER
*>          The leading dimension of the array AFAC.  LDAFAC >= max(1,N).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is DOUBLE PRECISION
*>          If UPLO = 'L', norm(L * L**H - A) / ( N * norm(A) * EPS )
*>          If UPLO = 'U', norm(U**H * U - A) / ( N * norm(A) * EPS )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex16_lin
*
*  =====================================================================
      SUBROUTINE ZPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, LDAFAC, N
      DOUBLE PRECISION   RESID
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   RWORK( * )
      COMPLEX*16         A( LDA, * ), AFAC( LDAFAC, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, K
      DOUBLE PRECISION   ANORM, EPS, TR
      COMPLEX*16         TC
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, ZLANHE
      COMPLEX*16         ZDOTC
      EXTERNAL           LSAME, DLAMCH, ZLANHE, ZDOTC
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZHER, ZSCAL, ZTRMV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DIMAG
*     ..
*     .. Executable Statements ..
*
*     Quick exit if N = 0.
*
      IF( N.LE.0 ) THEN
         RESID = ZERO
         RETURN
      END IF
*
*     Exit with RESID = 1/EPS if ANORM = 0.
*
      EPS = DLAMCH( 'Epsilon' )
      ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
      IF( ANORM.LE.ZERO ) THEN
         RESID = ONE / EPS
         RETURN
      END IF
*
*     Check the imaginary parts of the diagonal elements and return with
*     an error code if any are nonzero.
*
      DO 10 J = 1, N
         IF( DIMAG( AFAC( J, J ) ).NE.ZERO ) THEN
            RESID = ONE / EPS
            RETURN
         END IF
   10 CONTINUE
*
*     Compute the product U**H * U, overwriting U.
*
      IF( LSAME( UPLO, 'U' ) ) THEN
         DO 20 K = N, 1, -1
*
*           Compute the (K,K) element of the result.
*
            TR = ZDOTC( K, AFAC( 1, K ), 1, AFAC( 1, K ), 1 )
            AFAC( K, K ) = TR
*
*           Compute the rest of column K.
*
            CALL ZTRMV( 'Upper', 'Conjugate', 'Non-unit', K-1, AFAC,
     $                  LDAFAC, AFAC( 1, K ), 1 )
*
   20    CONTINUE
*
*     Compute the product L * L**H, overwriting L.
*
      ELSE
         DO 30 K = N, 1, -1
*
*           Add a multiple of column K of the factor L to each of
*           columns K+1 through N.
*
            IF( K+1.LE.N )
     $         CALL ZHER( 'Lower', N-K, ONE, AFAC( K+1, K ), 1,
     $                    AFAC( K+1, K+1 ), LDAFAC )
*
*           Scale column K by the diagonal element.
*
            TC = AFAC( K, K )
            CALL ZSCAL( N-K+1, TC, AFAC( K, K ), 1 )
*
   30    CONTINUE
      END IF
*
*     Compute the difference L * L**H - A (or U**H * U - A).
*
      IF( LSAME( UPLO, 'U' ) ) THEN
         DO 50 J = 1, N
            DO 40 I = 1, J - 1
               AFAC( I, J ) = AFAC( I, J ) - A( I, J )
   40       CONTINUE
            AFAC( J, J ) = AFAC( J, J ) - DBLE( A( J, J ) )
   50    CONTINUE
      ELSE
         DO 70 J = 1, N
            AFAC( J, J ) = AFAC( J, J ) - DBLE( A( J, J ) )
            DO 60 I = J + 1, N
               AFAC( I, J ) = AFAC( I, J ) - A( I, J )
   60       CONTINUE
   70    CONTINUE
      END IF
*
*     Compute norm(L*U - A) / ( N * norm(A) * EPS )
*
      RESID = ZLANHE( '1', UPLO, N, AFAC, LDAFAC, RWORK )
*
      RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
*
      RETURN
*
*     End of ZPOT01
*
      END


C     ( Last modified on 23 Dec 2000 at 22:01:38 )
      PROGRAM          TENMA
C
C  TENSOR test driver for problems derived from SIF files.
C
C  Ali Bouaricha, CERFACS (April, 1993), updated by Ph. Toint (March 2001)
C
      INTEGER          NMAX  , IOUT  , N     , METHOD, INPUT , ITNNO
      INTEGER          MSG   , NDIGIT, ILIM  , IAGFLG, IAHFLG, INSPEC
CS    REAL             GRADTL, STEPTL, FSCALE, FPLS  , STEPMX, TYPX
CD    DOUBLE PRECISION GRADTL, STEPTL, FSCALE, FPLS  , STEPMX, TYPX
CTOY  PARAMETER      ( NMAX =  10 )
CMED  PARAMETER      ( NMAX = 100 )
CBIG  PARAMETER      ( NMAX = 500 )
CCUS  PARAMETER      ( NMAX = 200 )
      PARAMETER      ( INPUT = 55, IOUT = 6, INSPEC = 56 )
CS    REAL             X( NMAX ), TYPSIZ( NMAX ), XPLS( NMAX )
CS    REAL             H( NMAX, NMAX ), WRK( NMAX, 8 ), GPLS( NMAX )
CD    DOUBLE PRECISION X( NMAX ), TYPSIZ( NMAX ), XPLS( NMAX )
CD    DOUBLE PRECISION H( NMAX, NMAX ), WRK( NMAX, 8 ), GPLS( NMAX )
      CHARACTER*10     XNAMES( NMAX ), PNAME
      INTEGER          IWRK( NMAX )  , I
      LOGICAL          BOUNDS
CS    REAL             GNORM, BIGINF, ZERO
CD    DOUBLE PRECISION GNORM, BIGINF, ZERO
      INTRINSIC        ABS  , MAX
CS    PARAMETER      ( BIGINF = 9.0E+19, ZERO = 0.0E0 )
CD    PARAMETER      ( BIGINF = 9.0D+19, ZERO = 0.0D0 )
      REAL             CPU( 2 ), CALLS( 4 )
      EXTERNAL         FCN, GRD, HSN
C
C  Open the Spec file for the method.
C
      OPEN ( INSPEC, FILE = 'TENMIN.SPC', FORM = 'FORMATTED',
     *       STATUS = 'OLD' )
      REWIND INSPEC
C
C  Read input Spec data.
C
      READ ( INSPEC, 1000 ) ILIM, GRADTL, IAGFLG, IAHFLG, FSCALE,
     *                      TYPX, METHOD, MSG
C
C  Close input file.
C
      CLOSE ( INSPEC )
C
C  Open the relevant file.
C
      OPEN ( INPUT, FILE = 'OUTSDIF.d', FORM = 'FORMATTED',
     *       STATUS = 'OLD' )
      REWIND INPUT
C
C  Set up SIF data.
C
      CALL USETUP( INPUT, IOUT, N, X, XPLS, GPLS, NMAX )
C
C  Obtain variable names.
C
      CALL UNAMES( N, PNAME, XNAMES )
C
C  Set up algorithmic input data.
C
CS    NDIGIT = 7
CD    NDIGIT = 15
CS    STEPTL = 0.00001E0
CD    STEPTL = 0.00001D0
      STEPMX = BIGINF
      BOUNDS  = .FALSE.
      DO 10 I = 1, N
         TYPSIZ( I ) = TYPX
         IF ( XPLS( I ) .GT. - BIGINF .OR. GPLS( I ) .LT. BIGINF )
     *      BOUNDS = .TRUE.
   10 CONTINUE
      IF ( BOUNDS ) WRITE( IOUT, 2030 )
C
C  Call the optimizer.
C
      CALL TENSOR( NMAX  , N, X  , FCN   , GRD   , HSN   , TYPSIZ,
     *             FSCALE, GRADTL, STEPTL, ILIM  , STEPMX, IOUT  ,
     *             METHOD, IAGFLG, IAHFLG, NDIGIT, MSG   , XPLS  ,
     *             FPLS  , GPLS  , H     , ITNNO , WRK   , IWRK  )
      CALL UREPRT( CALLS, CPU )
C
      GNORM    = ZERO
      DO 20 I  = 1, N
         GNORM = MAX( GNORM, ABS( GPLS( I ) ) )
   20 CONTINUE
      WRITE ( IOUT, 2010 )
      DO 30 I = 1, N
         WRITE( IOUT, 2020 ) XNAMES(I), XPLS( I ), GPLS( I )
   30 CONTINUE
      WRITE ( IOUT, 2001 ) GNORM
      WRITE ( IOUT, 2000 ) PNAME, N, ( CALLS( I ), I = 1, 3 ),
     *                     ITNNO, FPLS, CPU( 1 ), CPU( 2 )
      CLOSE( INPUT  )
      STOP
C
C  Non-executable statements.
C
 1000 FORMAT( I10, /, D10.3, 2(/,I10), 2(/,D10.3), 2(/,I10) )
 2000 FORMAT( /, 24('*'), ' CUTEr statistics ', 24('*') //
     *    ,' Code used               :  TENMIN',   /
     *    ,' Problem                 :  ', A10,    /
     *    ,' # variables             =      ', I10 /
     *    ,' # objective functions   =        ', F8.2 /
     *    ,' # objective gradients   =        ', F8.2 /
     *    ,' # objective Hessians    =        ', F8.2 /
     *     ' Exit code               =      ', I10 /
     *    ,' Final f                 = ', E15.7 /
     *    ,' Set up time             =      ', 0P, F10.2, ' seconds' /
     *     ' Solve time              =      ', 0P, F10.2, ' seconds' //
     *     66('*') / )
 2001 FORMAT( / ' FINAL NORMG = ', 1P, D12.4 )
 2010 FORMAT( /, '                 X         G ' )
 2020 FORMAT(  A10, 1P, 2D12.4 )
 2030 FORMAT(  /, ' ** Warning from TENMA. The problem as stated',
     *            ' includes simple bounds. ', /,
     *            '    These bounds will be ignored. ' )
      END
C
C
C
      SUBROUTINE FCN   ( N, X, F )
      INTEGER            N
CS    REAL               F
CD    DOUBLE PRECISION   F
CS    REAL               X( N )
CD    DOUBLE PRECISION   X( N )
C
C  Interface for TENSOR (Chow, Schnabel, Eskow).
C
C  Ali Bouaricha, CERFACS.
C  April, 1993.
C
      EXTERNAL         UFN
      CALL UFN   ( N, X, F )
      RETURN
C
C  end of FCN.
C
      END
C
C
C
      SUBROUTINE GRD   ( N, X, G )
      INTEGER            N
CS    REAL               X( N ), G( N )
CD    DOUBLE PRECISION   X( N ), G( N )
C
C  Interface for TENSOR (Chow, Schnabel, Eskow).
C
C  Ali Bouaricha, CERFACS.
C  April, 1993.
C
      EXTERNAL         UGR
      CALL UGR   ( N, X, G )
C
C  end of GRD.
C
      END
C
C
C
      SUBROUTINE HSN   ( NR, N, X, H )
      INTEGER            N, NR
CS    REAL               X( N ), H( NR, N )
CD    DOUBLE PRECISION   X( N ), H( NR, N )
C
C  Interface for TENSOR (Chow, Schnabel, Eskow).
C
C  Ali Bouaricha, CERFACS.
C  April, 1993.
C
      EXTERNAL         UDH
      CALL UDH   ( N, X, NR, H )
      RETURN
C
C  end of HSN.
C
      END


! Copyright (c) 2011-2013 Bartosz Szczesny
! LICENSE: The MIT License (MIT)

program task_5
    interface
        subroutine mean_std( xmax, ymax, inc, iwc, v, w, inc_mi, iwc_mi, v_mi, v_mo, &
                w_mi, w_mo, inc_si, iwc_si, v_si, v_so, w_si, w_so )
            integer :: xmax, ymax
            real :: inc( xmax, ymax ), iwc( xmax, ymax )
            real :: v( xmax, ymax ), w( xmax, ymax )
            real :: inc_mi, iwc_mi, v_mi, v_mo, w_mi, w_mo
            real :: inc_si, iwc_si, v_si, v_so, w_si, w_so
            integer :: x, y
            integer :: Ni, No ! numbers of points inside/outside of clouds
        end subroutine
        subroutine mx_mn( xmax, ymax, inc, iwc, v, w, inc_mx_i, iwc_mx_i, v_mx_i, v_mx_o, &
                w_mx_i, w_mx_o, inc_mn_i, iwc_mn_i, v_mn_i, v_mn_o, w_mn_i, w_mn_o )
            integer :: xmax, ymax
            real :: inc( xmax, ymax ), iwc( xmax, ymax ), v( xmax, ymax ), w( xmax, ymax )
            real :: inc_mx_i, iwc_mx_i, v_mx_i, v_mx_o, w_mx_i, w_mx_o
            real :: inc_mn_i, iwc_mn_i, v_mn_i, v_mn_o, w_mn_i, w_mn_o
            real :: T, H   ! tiny and huge
            real :: Ni, No ! numbers of points inside/outside of clouds
            integer :: x, y
        end subroutine
    end interface

    integer, parameter :: xmax = 100, ymax = 62
    real :: inc( xmax, ymax ), iwc( xmax, ymax ), v( xmax, ymax ), w( xmax, ymax ), z( ymax )
    real :: inc_mi, iwc_mi, v_mi, v_mo, w_mi, w_mo
    real :: inc_si, iwc_si, v_si, v_so, w_si, w_so
    real :: inc_mx_i, iwc_mx_i, v_mx_i, v_mx_o, w_mx_i, w_mx_o
    real :: inc_mn_i, iwc_mn_i, v_mn_i, v_mn_o, w_mn_i, w_mn_o
    integer :: x, y

    open( unit = 11, file = "inc.txt" )
    open( unit = 22, file = "iwc.txt" )
    open( unit = 33, file = "v.txt" )
    open( unit = 44, file = "w.txt" )
    open( unit = 55, file = "z.txt" )

    do x = 1, xmax
        do y = 1, ymax
            read( 11, * ) inc( x, y )
            read( 22, * ) iwc( x, y )
            read( 33, * ) v( x, y )
            read( 44, * ) w( x, y )
        enddo
    enddo

    do y = 1, ymax      ! if put above it would be done xmax times
        read( 55, * ) z( y ) ! also the data file would end
    enddo

    close( 11 )
    close( 22 )
    close( 33 )
    close( 44 )
    close( 55 )

    call mean_std( xmax, ymax, inc, iwc, v, w, inc_mi, iwc_mi, v_mi, v_mo, &
        w_mi, w_mo, inc_si, iwc_si, v_si, v_so, w_si, w_so )
    call mx_mn( xmax, ymax, inc, iwc, v, w, inc_mx_i, iwc_mx_i, v_mx_i, v_mx_o, &
        w_mx_i, w_mx_o, inc_mn_i, iwc_mn_i, v_mn_i, v_mn_o, w_mn_i, w_mn_o )

    print *, 'means'
    print 10, inc_mi, iwc_mi, v_mi, v_mo, w_mi, w_mo
    print *, 'stddevs'
    print 10, inc_si, iwc_si, v_si, v_so, w_si, w_so
    print *, 'max'
    print *, inc_mx_i, iwc_mx_i, v_mx_i, v_mx_o, w_mx_i, w_mx_o
    print *, 'min'
    print *, inc_mn_i, iwc_mn_i, v_mn_i, v_mn_o, w_mn_i, w_mn_o
10  format ( 6E10.2 )

    stop
end

! subroutines begin

subroutine mean_std( xmax, ymax, inc, iwc, v, w, inc_mi, iwc_mi, v_mi, v_mo, &
        w_mi, w_mo, inc_si, iwc_si, v_si, v_so, w_si, w_so )
    integer :: xmax, ymax
    real :: inc( xmax, ymax ), iwc( xmax, ymax )
    real :: v( xmax, ymax ), w( xmax, ymax )
    real :: inc_mi, iwc_mi, v_mi, v_mo, w_mi, w_mo
    real :: inc_si, iwc_si, v_si, v_so, w_si, w_so
    integer :: x, y
    integer :: Ni, No ! numbers of points inside/outside of clouds

    inc_mi = 0.0; iwc_mi = 0.0; v_mi = 0.0; v_mo = 0.0; w_mi = 0.0; w_mo = 0.0
    inc_si = 0.0; iwc_si = 0.0; v_si = 0.0; v_so = 0.0; w_si = 0.0; w_so = 0.0
    Ni = 0; No = 0

    do x = 1, xmax
        do y = 1, ymax
            if ( iwc( x, y ) > 0.00001 ) then ! inside a cloud
                inc_mi = inc_mi + inc( x, y )
                iwc_mi = iwc_mi + iwc( x, y )
                v_mi = v_mi + v( x, y )
                w_mi = w_mi + w( x, y )
                Ni = Ni + 1
            else ! outside a cloud
                v_mo = v_mo + v( x, y )
                w_mo = w_mo + w( x, y )
                No = No + 1
            endif
        enddo
    enddo

    v_mi = v_mi / Ni; w_mi = w_mi / Ni; inc_mi = inc_mi / Ni; iwc_mi = iwc_mi / Ni
    v_mo = v_mo / No; w_mo = w_mo / No

    do x = 1, xmax
        do y = 1, ymax
            if ( iwc(x,y)>0.00001 ) then ! inside a cloud
                inc_si = inc_si + ( inc_mi-inc( x, y ) )**2
                iwc_si = iwc_si + ( iwc_mi-iwc( x, y ) )**2
                v_si = v_si + ( v_mi-v( x, y ) )**2
                w_si = w_si + ( w_mi-w( x, y ) )**2
            else ! outside a cloud
                v_so = v_so + ( v_mo-v( x, y ) )**2
                w_so = w_so + ( w_mo-w( x, y ) )**2
            endif
        enddo
    enddo

    Ni = Ni - 1; No = No - 1 ! need to divide by N-1 in stddev formula

    v_si = v_si / Ni; w_si = w_si / Ni; inc_si = inc_si / Ni; iwc_si = iwc_si / Ni
    v_so = v_so / No; w_so = w_so / No

    inc_si = sqrt( inc_si ); iwc_si = sqrt( iwc_si )
    v_si = sqrt( v_si ); w_si = sqrt( w_si )
    v_so = sqrt( v_so ); w_so = sqrt( w_so )

    return
end

subroutine mx_mn( xmax, ymax, inc, iwc, v, w, inc_mx_i, iwc_mx_i, v_mx_i, v_mx_o, &
        w_mx_i, w_mx_o, inc_mn_i, iwc_mn_i, v_mn_i, v_mn_o, w_mn_i, w_mn_o )
    integer :: xmax, ymax
    real :: inc( xmax, ymax ), iwc( xmax, ymax ), v( xmax, ymax ), w( xmax, ymax )
    real :: inc_mx_i, iwc_mx_i, v_mx_i, v_mx_o, w_mx_i, w_mx_o
    real :: inc_mn_i, iwc_mn_i, v_mn_i, v_mn_o, w_mn_i, w_mn_o
    real :: T, H   ! tiny and huge
    real :: Ni, No ! numbers of points inside/outside of clouds
    integer :: x, y

    T = 10e-34
    H = 10e+34
    inc_mx_i = T; iwc_mx_i = T; v_mx_i = T; v_mx_o = T; w_mx_i = T; w_mx_o = T
    inc_mn_i = H; iwc_mn_i = H; v_mn_i = H; v_mn_o = H; w_mn_i = H; w_mn_o = H

    do x = 1, xmax
        do y = 1, ymax
            if ( iwc( x, y ) > 0.00001 ) then ! inside a cloud
                ! max values
                if ( inc( x, y ) > inc_mx_i ) inc_mx_i = inc( x, y )
                if ( iwc( x, y ) > iwc_mx_i ) iwc_mx_i = iwc( x, y )
                if ( v( x, y ) > v_mx_i ) v_mx_i = v( x, y )
                if ( w( x, y ) > w_mx_i ) w_mx_i = w( x, y )
                ! min values
                if ( inc( x, y ) < inc_mn_i ) inc_mn_i = inc( x, y )
                if ( iwc( x, y ) < iwc_mn_i ) iwc_mn_i = iwc( x, y )
                if ( v( x, y ) < v_mn_i ) v_mn_i = v( x, y )
                if ( w( x, y ) < w_mn_i ) w_mn_i = w( x, y )
                Ni = Ni + 1
            else ! outside a cloud
                ! max values
                if ( v( x, y ) > v_mx_o ) v_mx_o = v( x, y )
                if ( w( x, y ) > w_mx_o ) w_mx_o = w( x, y )
                ! min values
                if ( v( x, y ) < v_mn_o ) v_mn_o = v( x, y )
                if ( w( x, y ) < w_mn_o ) w_mn_o = w( x, y )
                No = No + 1
            endif
        enddo
    enddo

    return
end


MODULE solvar

! Module to store the solution variables

IMPLICIT NONE
SAVE

! Variables for subroutine 'weight'
REAL*8 :: alpha, beta, ex, ey

! Scalar flux final solution
REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE :: flux

! Scalar flux moments: SI
REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE :: f
REAL*8, DIMENSION(:,:,:,:), ALLOCATABLE :: e, fold

! Scalar flux moments: ITM
REAL*8, DIMENSION(:,:), ALLOCATABLE :: phi
REAL*8, DIMENSION(:), ALLOCATABLE :: phiold

! Convergence flag
INTEGER, DIMENSION(:), ALLOCATABLE :: cnvf, bcnvf

! Number of warnings
INTEGER :: warn

! Matrices for constructing gamma
REAL*8, DIMENSION(:,:), ALLOCATABLE :: amat, bmat, gmat

! Gamma sub-matrices
REAL*8, DIMENSION(:,:), ALLOCATABLE :: gaa, gax, gay
REAL*8, DIMENSION(:,:), ALLOCATABLE :: gxa, gxx, gxy
REAL*8, DIMENSION(:,:), ALLOCATABLE :: gya, gyx, gyy

! X and Y matrices
REAL*8, DIMENSION(:,:,:,:), ALLOCATABLE   :: xmat, xold, yold
REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE :: ymat

! Matrices for solving the system of equations
REAL*8, DIMENSION(:,:), ALLOCATABLE :: jmat
REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: kmat
REAL*8, DIMENSION(:), ALLOCATABLE :: src, sv

! Matrices for composing the kmats
REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: xbcy, xbcyo, xbcxo, ybcy, ybcyo, ybcxo
REAL*8, DIMENSION(:,:,:,:), ALLOCATABLE :: xbcx, ybcx

! Matrix for computing the angular flux out of the domain at the boundaries
REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: psio, jpsi
REAL*8, DIMENSION(:,:,:,:), ALLOCATABLE :: kpsi

END MODULE


      SUBROUTINE sgbfa1 (ABD, LDA, N, ML, MU, IPVT, INFO)
      USE LIPREC, ONLY: WP => SP
      IMPLICIT NONE
!-----------------------------------------------
!   D U M M Y   A R G U M E N T S
!-----------------------------------------------
      INTEGER LDA, N, ML, MU, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(*) :: ABD

      CALL sgbfa (ABD, LDA, N, ML, MU, IPVT, INFO)

      END SUBROUTINE sgbfa1

      SUBROUTINE dgbfa1 (ABD, LDA, N, ML, MU, IPVT, INFO)
      USE LIPREC, ONLY: WP => DP
      IMPLICIT NONE
!-----------------------------------------------
!   D U M M Y   A R G U M E N T S
!-----------------------------------------------
      INTEGER LDA, N, ML, MU, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(*) :: ABD

      CALL dgbfa (ABD, LDA, N, ML, MU, IPVT, INFO)

      END SUBROUTINE dgbfa1

#ifndef CRAY
      SUBROUTINE sgbfa (ABD, LDA, N, ML, MU, IPVT, INFO)
      USE LIPREC, ONLY: WP => SP
      IMPLICIT NONE
!-----------------------------------------------
!   D U M M Y   A R G U M E N T S
!-----------------------------------------------
      INTEGER LDA, N, ML, MU, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(LDA,N) :: ABD
!-----------------------------------------------
!   L O C A L   V A R I A B L E S
!-----------------------------------------------
      REAL(WP), PARAMETER :: ZERO = 0, ONE = 1
      INTEGER :: I0, J, JU, JZ, J0, J1, K, KP1, L, LM, M, MM, NM1
      REAL(WP) :: T
      INTEGER :: ISAMAX1(1)
!-----------------------------------------------
      EXTERNAL SSCAL, SAXPY
!
!     sgbfa factors a REAL band matrix by elimination.
!
!     sgbfa is usually called by sgbco, but it can be called
!     directly with a saving in time if  rcond  is not needed.
!
!     on entry
!
!        abd     real(lda, n)
!                contains the matrix in band storage.  the columns
!                of the matrix are stored in the columns of  abd  and
!                the diagonals of the matrix are stored in rows
!                ml+1 through 2*ml+mu+1 of  abd .
!                see the comments below for details.
!
!        lda     integer
!                the leading dimension of the array  abd .
!                lda must be .ge. 2*ml + mu + 1 .
!
!        n       integer
!                the order of the original matrix.
!
!        ml      integer
!                number of diagonals below the main diagonal.
!                0 .le. ml .lt. n .
!
!        mu      integer
!                number of diagonals above the main diagonal.
!                0 .le. mu .lt. n .
!                more efficient if  ml .le. mu .
!     on return
!
!        abd     an upper triangular matrix in band storage and
!                the multipliers which were used to obtain it.
!                the factorization can be written  a = l*u  where
!                l  is a product of permutation and unit lower
!                triangular matrices and  u  is upper triangular.
!
!        ipvt    integer(n)
!                an integer vector of pivot indices.
!
!        info    integer
!                = 0  normal value.
!                = k  if  u(k,k) .eq. 0.0 .  this is not an error
!                     condition for this subroutine, but it does
!                     indicate that sgbsl will divide by zero if
!                     called.  use  rcond  in sgbco for a reliable
!                     indication of singularity.
!
!     band storage
!
!           if  a  is a band matrix, the following program segment
!           will set up the input.
!
!                   ml = (band width below the diagonal)
!                   mu = (band width above the diagonal)
!                   m = ml + mu + 1
!                   do 20 j = 1, n
!                      i1 = max(1, j-mu)
!                      i2 = min(n, j+ml)
!                      do 10 i = i1, i2
!                         k = i - j + m
!                         abd(k,j) = a(i,j)
!                10    continue
!                20 continue
!
!           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
!           in addition, the first  ml  rows in  abd  are used for
!           elements generated during the triangularization.
!           the total number of rows needed in  abd  is  2*ml+mu+1 .
!           the  ml+mu by ml+mu  upper left triangle and the
!           ml by ml  lower right triangle are not referenced.
!
!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas saxpy ,sscal
!     fortran max,min
!
!     internal variables
!
!
      m = ml + mu + 1
      info = 0
!
!     zero initial fill-in columns
!
      j0 = mu + 2
      j1 = MIN(n,m) - 1
      DO jz = j0, j1
         i0 = m + 1 - jz
         abd(i0:ml,jz) = zero
      END DO
      jz = j1
      ju = 0
!
!     gaussian elimination with partial pivoting
!
      nm1 = n - 1
      IF (nm1 .ge. 1) THEN
         DO k = 1, nm1
            kp1 = k + 1
!
!        zero next fill-in column
!
            jz = jz + 1
            IF (jz .le. n) THEN
               abd(:ml,jz) = zero
            END IF
!
!        find l = pivot INDEX
!
            lm = MIN(ml,n - k)
            isamax1 = MAXLOC(ABS(abd(m:m+lm,k)))
            l = isamax1(1) + m - 1
!           l = isamax(lm + 1,abd(m,k),1) + m - 1
            ipvt(k) = l + k - m
!
!        zero pivot implies this column already triangularized
!
            IF (abd(l,k) .ne. zero) THEN
!
!           interchange if necessary
!
               IF (l .ne. m) THEN
                  t = abd(l,k)
                  abd(l,k) = abd(m,k)
                  abd(m,k) = t
               END IF
!
!           compute multipliers
!
               t = -one/abd(m,k)
               CALL sscal (lm, t, abd(m+1,k), 1)
!
!           row elimination with column indexing
!
               ju = MIN(MAX(ju,mu + ipvt(k)),n)
               mm = m
               DO j = kp1, ju
                  l = l - 1
                  mm = mm - 1
                  t = abd(l,j)
                  IF (l .ne. mm) THEN
                     abd(l,j) = abd(mm,j)
                     abd(mm,j) = t
                  END IF
                  CALL saxpy (lm, t, abd(m+1,k), 1, abd(mm+1,j), 1)
               END DO
            ELSE
               info = k
            END IF
         END DO
      END IF
      ipvt(n) = n
      IF (abd(m,n) .eq. zero) info = n

      END SUBROUTINE sgbfa

      SUBROUTINE dgbfa (ABD, LDA, N, ML, MU, IPVT, INFO)
      USE LIPREC, ONLY: WP => DP
      IMPLICIT NONE
!-----------------------------------------------
!   D U M M Y   A R G U M E N T S
!-----------------------------------------------
      INTEGER LDA, N, ML, MU, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(LDA,N) :: ABD
!-----------------------------------------------
!   L O C A L   V A R I A B L E S
!-----------------------------------------------
      REAL(WP), PARAMETER :: ZERO = 0, ONE = 1
      INTEGER :: I0, J, JU, JZ, J0, J1, K, KP1, L, LM, M, MM, NM1
      REAL(WP) :: T
      INTEGER :: ISAMAX1(1)
!-----------------------------------------------
      EXTERNAL DSCAL, DAXPY
!
!     sgbfa factors a REAL band matrix by elimination.
!
!     sgbfa is usually called by sgbco, but it can be called
!     directly with a saving in time if  rcond  is not needed.
!
!     on entry
!
!        abd     real(lda, n)
!                contains the matrix in band storage.  the columns
!                of the matrix are stored in the columns of  abd  and
!                the diagonals of the matrix are stored in rows
!                ml+1 through 2*ml+mu+1 of  abd .
!                see the comments below for details.
!
!        lda     integer
!                the leading dimension of the array  abd .
!                lda must be .ge. 2*ml + mu + 1 .
!
!        n       integer
!                the order of the original matrix.
!
!        ml      integer
!                number of diagonals below the main diagonal.
!                0 .le. ml .lt. n .
!
!        mu      integer
!                number of diagonals above the main diagonal.
!                0 .le. mu .lt. n .
!                more efficient if  ml .le. mu .
!     on return
!
!        abd     an upper triangular matrix in band storage and
!                the multipliers which were used to obtain it.
!                the factorization can be written  a = l*u  where
!                l  is a product of permutation and unit lower
!                triangular matrices and  u  is upper triangular.
!
!        ipvt    integer(n)
!                an integer vector of pivot indices.
!
!        info    integer
!                = 0  normal value.
!                = k  if  u(k,k) .eq. 0.0 .  this is not an error
!                     condition for this subroutine, but it does
!                     indicate that sgbsl will divide by zero if
!                     called.  use  rcond  in sgbco for a reliable
!                     indication of singularity.
!
!     band storage
!
!           if  a  is a band matrix, the following program segment
!           will set up the input.
!
!                   ml = (band width below the diagonal)
!                   mu = (band width above the diagonal)
!                   m = ml + mu + 1
!                   do 20 j = 1, n
!                      i1 = max(1, j-mu)
!                      i2 = min(n, j+ml)
!                      do 10 i = i1, i2
!                         k = i - j + m
!                         abd(k,j) = a(i,j)
!                10    continue
!                20 continue
!
!           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
!           in addition, the first  ml  rows in  abd  are used for
!           elements generated during the triangularization.
!           the total number of rows needed in  abd  is  2*ml+mu+1 .
!           the  ml+mu by ml+mu  upper left triangle and the
!           ml by ml  lower right triangle are not referenced.
!
!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas saxpy ,sscal
!     fortran max,min
!
!     internal variables
!
      m = ml + mu + 1
      info = 0
!
!     zero initial fill-in columns
!
      j0 = mu + 2
      j1 = MIN(n,m) - 1
      DO jz = j0, j1
         i0 = m + 1 - jz
         abd(i0:ml,jz) = zero
      END DO
      jz = j1
      ju = 0
!
!     gaussian elimination with partial pivoting
!
      nm1 = n - 1
      IF (nm1 .ge. 1) THEN
         DO k = 1, nm1
            kp1 = k + 1
!
!        zero next fill-in column
!
            jz = jz + 1
            IF (jz .le. n) THEN
               abd(:ml,jz) = zero
            END IF
!
!        find l = pivot INDEX
!
            lm = MIN(ml,n - k)
            isamax1 = MAXLOC(ABS(abd(m:m+lm,k)))
            l = isamax1(1) + m - 1
!           l = isamax(lm + 1,abd(m,k),1) + m - 1
            ipvt(k) = l + k - m
!
!        zero pivot implies this column already triangularized
!
            IF (abd(l,k) .ne. zero) THEN
!
!           interchange if necessary
!
               IF (l .ne. m) THEN
                  t = abd(l,k)
                  abd(l,k) = abd(m,k)
                  abd(m,k) = t
               END IF
!
!           compute multipliers
!
               t = -one/abd(m,k)
               CALL dscal (lm, t, abd(m+1,k), 1)
!
!           row elimination with column indexing
!
               ju = MIN(MAX(ju,mu + ipvt(k)),n)
               mm = m
               DO j = kp1, ju
                  l = l - 1
                  mm = mm - 1
                  t = abd(l,j)
                  IF (l .ne. mm) THEN
                     abd(l,j) = abd(mm,j)
                     abd(mm,j) = t
                  END IF
                  CALL daxpy (lm, t, abd(m+1,k), 1, abd(mm+1,j), 1)
               END DO
            ELSE
               info = k
            END IF
         END DO
      END IF
      ipvt(n) = n
      IF (abd(m,n) .eq. zero) info = n

      END SUBROUTINE dgbfa
#endif