! This source file is part of the Limited-area GAME version (L-GAME), which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/L-GAME

module io

  ! This module handles everything dealing with IO.

  use definitions,    only: t_state,wp,t_diag,t_grid
  use netcdf
  use run_nml,        only: nlins,ncols,nlays,scenario,p_0,run_id
  use thermodynamics, only: gas_constant_diagnostics,spec_heat_cap_diagnostics_p
  use grid_generator, only: bg_temp,bg_pres,geopot

  implicit none

  private

  public :: ideal
  public :: restart
  public :: var_3d
  public :: var_4d
  public :: write_output

  contains

  subroutine ideal(state,diag,grid)

    ! sets the initial state of the model calculation i terms if analytic functions

    type(t_state), intent(inout) :: state ! state to write the initial state to
    type(t_diag),  intent(inout) :: diag  ! diagnostic quantities
    type(t_grid),  intent(in)    :: grid  ! model grid

    ! local variables
    integer                      :: ji,jk,jl                           ! loop indices
    real(wp)                     :: pres_lowest_layer(nlins+2,ncols+2) ! pressure in the lowest layer
    real(wp)                     :: n_squared                          ! Brunt-Väisälä frequency for the Schär test case
    real(wp)                     :: gravity                            ! gravity acceleration
    real(wp)                     :: delta_z                            ! delta z
    real(wp)                     :: T_0                                ! MSLP temperature variable
    real(wp)                     :: r_d                                ! specific gas constant of dry air
    real(wp)                     :: c_p                                ! specific heat capacity at const. pressure of dry air

    r_d = gas_constant_diagnostics(1)
    c_p = spec_heat_cap_diagnostics_p(1)

    select case (trim(scenario))

      case("standard","resting_mountain")

        ! This test case is the standard atmosphere.

        state%wind_u(:,:,:) = 0._wp
        state%wind_v(:,:,:) = 0._wp

        !$OMP PARALLEL
        !$OMP DO PRIVATE(ji,jk,jl)
        do ji=1,nlins+2
          do jk=1,ncols+2
            do jl=1,nlays
              diag%scalar_placeholder(ji,jk,jl) = bg_temp(grid%z_geo_scal(ji,jk,jl))
            enddo
            pres_lowest_layer(ji,jk) = bg_pres(grid%z_geo_scal(ji,jk,nlays))
          enddo
        enddo
        !$OMP END DO
        !$OMP END PARALLEL

      case("schaer")

        ! Schär et al. (2001): A New Terrain-Following Vertical Coordinate Formulation for Atmospheric Prediction Models

        state%wind_u(:,:,:) = 18.71_wp
        state%wind_v(:,:,:) = 0._wp

        n_squared = (0.01871_wp)**2
        T_0 = 273.16_wp

        !$OMP PARALLEL
        !$OMP DO PRIVATE(ji,jk,jl,delta_z,gravity)
        do ji=1,nlins+2
          do jk=1,ncols+2
            ! potential temperature in the lowest layer
            ! calculating delta_z
            delta_z = grid%z_geo_scal(ji,jk,nlays-1)-grid%z_geo_scal(ji,jk,nlays)
            ! calculating the gravity
            gravity = (geopot(grid%z_geo_scal(ji,jk,nlays-1))-geopot(grid%z_geo_scal(ji,jk,nlays)))/delta_z
            ! result
            state%theta_pert(ji,jk,nlays) &
            ! value at MSL
            = T_0 &
            + T_0/gravity*n_squared*grid%z_geo_scal(ji,jk,nlays) &
            ! substracting the background state
            - grid%theta_bg(ji,jk,nlays)
            state%exner_pert(ji,jk,nlays)=(exp(-grid%z_geo_scal(ji,jk,nlays)/8000._wp))**(r_d/c_p) &
            - grid%exner_bg(ji,jk,nlays)
            ! stacking the potential temperature
            do jl=nlays-1,1,-1
              ! calculating delta_z
              delta_z = grid%z_geo_scal(ji,jk,jl)-grid%z_geo_scal(ji,jk,jl+1)
              ! calculating the gravity
              gravity = (geopot(grid%z_geo_scal(ji,jk,jl))-geopot(grid%z_geo_scal(ji,jk,jl+1)))/delta_z
              ! result
              state%theta_pert(ji,jk,jl) &
              ! value in the lower layer
              = state%theta_pert(ji,jk,jl+1)+grid%theta_bg(ji,jk,jl+1) &
              + (state%theta_pert(ji,jk,jl+1)+grid%theta_bg(ji,jk,jl+1))/gravity*n_squared*delta_z &
              ! substracting the background state
              - grid%theta_bg(ji,jk,jl)
            enddo
            ! stacking the Exner pressure
            do jl=nlays-1,1,-1
              state%exner_pert(ji,jk,jl)=state%exner_pert(ji,jk,jl+1) &
              - (state%theta_pert(ji,jk,jl)+state%theta_pert(ji,jk,jl+1))/(grid%theta_bg(ji,jk,jl)+grid%theta_bg(ji,jk,jl+1) &
              +state%theta_pert(ji,jk,jl)+state%theta_pert(ji,jk,jl+1))*(grid%exner_bg(ji,jk,jl)-grid%exner_bg(ji,jk,jl+1))
            enddo
            ! filling up what's needed for the unessential_init routine
            ! temperature
            do jl=1,nlays
              diag%scalar_placeholder(ji,jk,jl)=(grid%exner_bg(ji,jk,jl)+state%exner_pert(ji,jk,jl)) &
              *(grid%theta_bg(ji,jk,jl)+state%theta_pert(ji,jk,jl))
            enddo
            ! pressure in the lowest layer
            pres_lowest_layer(ji,jk)=p_0*(grid%exner_bg(ji,jk,nlays)+state%exner_pert(ji,jk,nlays))**(c_p/r_d)
          enddo
        enddo
        !$OMP END DO
        !$OMP END PARALLEL

    endselect

    call unessential_init(state,diag,grid,pres_lowest_layer)

  end subroutine ideal

  subroutine restart(state,diag,grid)

    ! reads the initial state of the model calculation from a netcdf file

    type(t_state), intent(inout) :: state ! state to write the initial state to
    type(t_diag),  intent(inout) :: diag  ! diagnostic quantities
    type(t_grid),  intent(in)    :: grid  ! model grid

    ! local variables
    real(wp)                     :: pres_lowest_layer(nlins+2,ncols+2) ! pressure in the lowest layer

    call unessential_init(state,diag,grid,pres_lowest_layer)

  end subroutine restart

  subroutine var_3d(state,diag,grid)

    ! three-dimensional variational data assimilation

    type(t_state), intent(inout) :: state ! state to write the initial state to
    type(t_diag),  intent(inout) :: diag  ! diagnostic quantities
    type(t_grid),  intent(in)    :: grid  ! model grid

    ! local variables
    real(wp)                     :: pres_lowest_layer(nlins+2,ncols+2) ! pressure in the lowest layer

    call unessential_init(state,diag,grid,pres_lowest_layer)

  end subroutine var_3d

  subroutine var_4d(state,diag,grid)

    ! four-dimensional variational data assimilation

    type(t_state), intent(inout) :: state ! state to write the initial state to
    type(t_diag),  intent(inout) :: diag  ! diagnostic quantities
    type(t_grid),  intent(in)    :: grid  ! model grid

    ! local variables
    real(wp)                     :: pres_lowest_layer(nlins+2,ncols+2) ! pressure in the lowest layer

    call unessential_init(state,diag,grid,pres_lowest_layer)

  end subroutine var_4d

  subroutine write_output(state,diag,time_since_init_min,grid)
    ! reads out the state of the model atmosphere
    ! at a single timestep to a netcdf file

    type(t_state), intent(in)    :: state               ! state to write out
    type(t_diag),  intent(inout) :: diag                ! diagnostic quantities
    integer,       intent(in)    :: time_since_init_min ! time in minutes since init
    type(t_grid),  intent(in)    :: grid                ! model grid

    ! local variables
    integer                   :: ncid                      ! ID of the netcdf file
    integer                   :: x_dimid                   ! ID of the x dimension
    integer                   :: y_dimid                   ! ID of the y dimension
    integer                   :: z_dimid                   ! ID of the z dimension
    integer                   :: dimids_2d(2)              ! dimensions of horizontal fields
    integer                   :: dimids_3d(3)              ! dimensions of 3D fields
    integer                   :: varid_lat                 ! variable ID of the lat coordinates
    integer                   :: varid_lon                 ! variable ID of the lon coordinates
    integer                   :: varid_z                   ! variable ID of the z coordinates
    integer                   :: varid_p                   ! variable ID of the 3D pressure field
    integer                   :: varid_t                   ! variable ID of the 3D temperature field
    integer                   :: varid_u                   ! variable ID of the 3D u wind field
    integer                   :: varid_v                   ! variable ID of the 3D v wind field
    integer                   :: varid_w                   ! variable ID of the 3D w wind field
    character(len=64)         :: filename                  ! output filename
    character(len=64)         :: time_since_init_min_str   ! time_since_init_min as string
    integer                   :: ji,jk,jl                  ! line indices
    real(wp)                  :: upper_weight(nlins,ncols) ! interpolation weights

    ! creating the netcdf file
    write(time_since_init_min_str,*) time_since_init_min
    time_since_init_min_str = adjustl(time_since_init_min_str)
    filename = trim(run_id) // "+" // trim(time_since_init_min_str) // "min.nc"
    call check(nf90_create(trim(filename),NF90_CLOBBER,ncid))

    call check(nf90_put_att(ncid,NF90_GLOBAL,"Description","This is output of L-GAME."))
    call check(nf90_put_att(ncid,NF90_GLOBAL,"Run_ID",trim(run_id)))
    call check(nf90_put_att(ncid,NF90_GLOBAL,"Time_since_initialization_in_minutes",trim(time_since_init_min_str)))

    ! defining the dimensions
    call check(nf90_def_dim(ncid,"lon_model",ncols,x_dimid))
    call check(nf90_def_dim(ncid,"lat_model",nlins,y_dimid))
    call check(nf90_def_dim(ncid,"z",nlays,z_dimid))

    ! setting the dimension ID arrays
    ! 2D
    dimids_2d(1) = y_dimid
    dimids_2d(2) = x_dimid
    ! 3D
    dimids_3d(1) = y_dimid
    dimids_3d(2) = x_dimid
    dimids_3d(3) = z_dimid

    ! Define the variable. The type of the variable in this case is
    ! NF90_INT (4-byte integer).
    call check(nf90_def_var(ncid,"lat_model",NF90_REAL,y_dimid,varid_lat))
    call check(nf90_put_att(ncid,varid_lat,"Description","latitudes of the grid points (in the frame of reference of the model)"))
    call check(nf90_put_att(ncid,varid_lat,"Unit","rad"))
    call check(nf90_def_var(ncid,"lon_model",NF90_REAL,x_dimid,varid_lon))
    call check(nf90_put_att(ncid,varid_lon,"Description","longitudes of the grid points (in the frame of reference of the model)"))
    call check(nf90_put_att(ncid,varid_lon,"Unit","rad"))
    call check(nf90_def_var(ncid,"z",NF90_REAL,dimids_3d,varid_z))
    call check(nf90_put_att(ncid,varid_z,"Description","z coordinates of the grid points (MSL)"))
    call check(nf90_put_att(ncid,varid_z,"Unit","m"))
    call check(nf90_def_var(ncid,"T",NF90_REAL,dimids_3d,varid_t))
    call check(nf90_put_att(ncid,varid_t,"Description","air temperature"))
    call check(nf90_put_att(ncid,varid_t,"Unit","K"))
    call check(nf90_def_var(ncid,"p",NF90_REAL,dimids_3d,varid_p))
    call check(nf90_put_att(ncid,varid_p,"Description","air pressure"))
    call check(nf90_put_att(ncid,varid_p,"Unit","Pa"))
    call check(nf90_def_var(ncid,"u",NF90_REAL,dimids_3d,varid_u))
    call check(nf90_put_att(ncid,varid_u,"Description","zonal wind (in the frame of reference of the model)"))
    call check(nf90_put_att(ncid,varid_u,"Unit","m/s"))
    call check(nf90_def_var(ncid,"v",NF90_REAL,dimids_3d,varid_v))
    call check(nf90_put_att(ncid,varid_v,"Description","meridional wind (in the frame of reference of the model)"))
    call check(nf90_put_att(ncid,varid_v,"Unit","m/s"))
    call check(nf90_def_var(ncid,"w",NF90_REAL,dimids_3d,varid_w))
    call check(nf90_put_att(ncid,varid_w,"Description","vertical wind"))
    call check(nf90_put_att(ncid,varid_w,"Unit","m/s"))

    ! ending the definition section
    call check(nf90_enddef(ncid))

    ! latitude coordinates of the grid points
    call check(nf90_put_var(ncid,varid_lat,grid%lat_scalar(2:nlins+1)))
    ! longitude coordinates of the grid points
    call check(nf90_put_var(ncid,varid_lon,grid%lon_scalar(2:ncols+1)))
    ! z coordinates of the grid points
    call check(nf90_put_var(ncid,varid_z,grid%z_geo_scal(2:nlins+1,2:ncols+1,:)))

    ! 3D temperature
    diag%scalar_placeholder(2:nlins+1,2:ncols+1,:) =  (grid%theta_bg(2:nlins+1,2:ncols+1,:) &
    + state%theta_pert(2:nlins+1,2:ncols+1,:)) &
    *(grid%exner_bg(2:nlins+1,2:ncols+1,:) + state%exner_pert(2:nlins+1,2:ncols+1,:))
    call check(nf90_put_var(ncid,varid_t,diag%scalar_placeholder(2:nlins+1,2:ncols+1,:)))

    ! writing the data to the output file
    ! 3D pressure
    diag%scalar_placeholder(2:nlins+1,2:ncols+1,:) = state%rho(2:nlins+1,2:ncols+1,:) &
    *gas_constant_diagnostics(1)*diag%scalar_placeholder(2:nlins+1,2:ncols+1,:)
    call check(nf90_put_var(ncid,varid_p,diag%scalar_placeholder(2:nlins+1,2:ncols+1,:)))

    ! 3D u wind
    !$OMP PARALLEL
    !$OMP DO PRIVATE(jk)
    do jk=1,ncols
      diag%scalar_placeholder(2:nlins+1,jk+1,:) = 0.5_wp*(state%wind_u(2:nlins+1,jk,:)+state%wind_u(2:nlins+1,jk+1,:))
    enddo
    !$OMP END DO
    !$OMP END PARALLEL
    call check(nf90_put_var(ncid,varid_u,diag%scalar_placeholder(2:nlins+1,2:ncols+1,:)))

    ! 3D v wind
    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji)
    do ji=1,nlins
      diag%scalar_placeholder(ji+1,2:ncols+1,:) = 0.5_wp*(state%wind_v(ji,2:ncols+1,:)+state%wind_v(ji+1,2:ncols+1,:))
    enddo
    !$OMP END DO
    !$OMP END PARALLEL
    call check(nf90_put_var(ncid,varid_v,diag%scalar_placeholder(2:nlins+1,2:ncols+1,:)))

    ! 3D w wind
    !$OMP PARALLEL
    !$OMP DO PRIVATE(jl,upper_weight)
    do jl=1,nlays
      upper_weight(:,:) = (grid%z_geo_scal(2:nlins+1,2:ncols+1,jl) -&
      grid%z_geo_w(2:nlins+1,2:ncols+1,jl+1))/(grid%z_geo_w(2:nlins+1,2:ncols+1,jl)  &
      - grid%z_geo_w(2:nlins+1,2:ncols+1,jl+1))
      diag%scalar_placeholder(2:nlins+1,2:ncols+1,jl) = &
      upper_weight(:,:)*state%wind_w(2:nlins+1,2:ncols+1,jl)+(1._wp-upper_weight(:,:))*state%wind_w(2:nlins+1,2:ncols+1,jl+1)
    enddo
    !$OMP END DO
    !$OMP END PARALLEL
    call check(nf90_put_var(ncid,varid_w,diag%scalar_placeholder(2:nlins+1,2:ncols+1,:)))

    ! closing the netcdf file
    call check(nf90_close(ncid))

  end subroutine write_output

  subroutine unessential_init(state,diag,grid,pres_lowest_layer)

    ! setting the unessential quantities of an initial state
    ! scalar_placeholder is the temperature here

    type(t_state), intent(inout) :: state                  ! state to work with
    type(t_diag),  intent(in)    :: diag                   ! diagnostic quantities
    type(t_grid),  intent(in)    :: grid                   ! model grid
    real(wp),      intent(in)    :: pres_lowest_layer(:,:) ! pressure in the lowest layer

    ! local variables
    integer                      :: ji,jk,jl          ! loop indices
    real(wp)                     :: b,c               ! abbreviations needed for the hydrostatic initialization routine
    real(wp)                     :: temperature       ! single temperature value
    real(wp)                     :: pressure          ! single pressure value
    real(wp)                     :: r_d               ! specific gas constant of dry air
    real(wp)                     :: c_p               ! specific heat capacity at const. pressure of dry air

    r_d = gas_constant_diagnostics(1)
    c_p = spec_heat_cap_diagnostics_p(1)

    ! integrating the hydrostatic initial state according to the given temperature field and pressure in the lowest layer
    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji,jk,jl,b,c,temperature,pressure)
    do ji=1,nlins+2
      do jk=1,ncols+2
        ! integrating from bottom to top
        do jl=nlays,1,-1
          temperature = diag%scalar_placeholder(ji,jk,jl)
          ! lowest layer
          if (jl == nlays) then
            pressure    = pres_lowest_layer(ji,jk)
            state%exner_pert(ji,jk,jl) = (pressure/p_0)**(r_d/c_p)
            state%theta_pert(ji,jk,jl) = temperature/state%exner_pert(ji,jk,jl)
          ! other layers
          else
            ! solving a quadratic equation for the Exner pressure
            b = -0.5_wp*state%exner_pert(ji,jk,jl+1)/bg_temp(grid%z_geo_scal(ji,jk,jl+1)) &
            *(temperature - bg_temp(grid%z_geo_scal(ji,jk,jl+1)) + 2.0_wp/ &
            spec_heat_cap_diagnostics_p(1)*(geopot(grid%z_geo_scal(ji,jk,jl)) - geopot(grid%z_geo_scal(ji,jk,jl+1))))
            c = state%exner_pert(ji,jk,jl+1)**2*temperature/bg_temp(grid%z_geo_scal(ji,jk,jl+1))
            state%exner_pert(ji,jk,jl) = b+sqrt(b**2+c)
            state%theta_pert(ji,jk,jl) = temperature/state%exner_pert(ji,jk,jl)
          endif
        enddo
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

    ! density
    state%rho(:,:,:) = p_0*(state%exner_pert(:,:,:))**(c_p/r_d) &
    /(r_d*diag%scalar_placeholder(:,:,:))
    ! potential temperature density
    state%rhotheta(:,:,:) = state%rho(:,:,:)*state%theta_pert(:,:,:)

    ! substracting the background state
    state%theta_pert(:,:,:) = state%theta_pert(:,:,:) - grid%theta_bg(:,:,:)
    state%exner_pert(:,:,:) = state%exner_pert(:,:,:) - grid%exner_bg(:,:,:)

    ! vertical wind velocity
    state%wind_w(:,:,:) = 0._wp

  end subroutine unessential_init

  subroutine check(i_status)
    integer, intent(in) :: i_status

    if(i_status /= nf90_noerr) then
      print *, trim(nf90_strerror(i_status))
      stop "Netcdf threw an error."
    end if
  end subroutine check

end module io


MODULE TEST
  IMPLICIT NONE
  INTEGER, PARAMETER :: dp=KIND(0.0D0)
  TYPE mulliken_restraint_type
    INTEGER                         :: ref_count
    REAL(KIND = dp)                 :: strength
    REAL(KIND = dp)                 :: TARGET
    INTEGER                         :: natoms
    INTEGER, POINTER, DIMENSION(:)  :: atoms
  END TYPE mulliken_restraint_type
CONTAINS
  SUBROUTINE INIT(mulliken)
   TYPE(mulliken_restraint_type), INTENT(INOUT) :: mulliken
   ALLOCATE(mulliken%atoms(1))
   mulliken%atoms(1)=1
   mulliken%natoms=1
   mulliken%target=0
   mulliken%strength=0
  END SUBROUTINE INIT
  SUBROUTINE restraint_functional(mulliken_restraint_control,charges, &
                                charges_deriv,energy,order_p)
    TYPE(mulliken_restraint_type), &
      INTENT(IN)                             :: mulliken_restraint_control
    REAL(KIND=dp), DIMENSION(:, :), POINTER  :: charges, charges_deriv
    REAL(KIND=dp), INTENT(OUT)               :: energy, order_p

    INTEGER                                  :: I
    REAL(KIND=dp)                            :: dum

    charges_deriv=0.0_dp
    order_p=0.0_dp

    DO I=1,mulliken_restraint_control%natoms
       order_p=order_p+charges(mulliken_restraint_control%atoms(I),1) &
                      -charges(mulliken_restraint_control%atoms(I),2)
    ENDDO

energy=mulliken_restraint_control%strength*(order_p-mulliken_restraint_control%target)**2

dum=2*mulliken_restraint_control%strength*(order_p-mulliken_restraint_control%target)
    DO I=1,mulliken_restraint_control%natoms
       charges_deriv(mulliken_restraint_control%atoms(I),1)=  dum
       charges_deriv(mulliken_restraint_control%atoms(I),2)= -dum
    ENDDO
END SUBROUTINE restraint_functional

END MODULE

    USE TEST
    IMPLICIT NONE
    TYPE(mulliken_restraint_type) :: mulliken
    REAL(KIND=dp), DIMENSION(:, :), POINTER  :: charges, charges_deriv
    REAL(KIND=dp) :: energy,order_p
    ALLOCATE(charges(1,2),charges_deriv(1,2))
    charges(1,1)=2.0_dp
    charges(1,2)=1.0_dp
    CALL INIT(mulliken)
    CALL restraint_functional(mulliken,charges,charges_deriv,energy,order_p)
    write(6,*) order_p
END


subroutine invert_anneal()
!----
! Determine fault slip with a simulated annealing search, varying slip magnitude and rake angle
! randomly to find the best fitting solution.
!----

use trig, only: d2r
use annealing, only: anneal

use fltinv, only: fault, &
                  max_iteration, &
                  reset_iteration, &
                  temp_start, &
                  temp_minimum, &
                  cooling_factor, &
                  fault_slip, &
                  modelUncertainty

implicit none

! Interface to driver subroutines
interface
    subroutine anneal_init(model,n)
        integer :: n
        double precision :: model(n)
    end subroutine
    subroutine anneal_propose(model_current,model_proposed,n)
        integer :: n
        double precision :: model_current(n)
        double precision :: model_proposed(n)
    end subroutine
    function anneal_objective(model,n)
        integer :: n
        double precision :: model(n)
        double precision :: anneal_objective
    end function
    subroutine anneal_log(it,temp,obj,model_current,model_proposed,n,isAccepted,string)
        integer :: it, n
        double precision :: temp, obj
        double precision :: model_current(n)
        double precision :: model_proposed(n)
        logical :: isAccepted
        character(len=*) :: string
    end subroutine
end interface

! Local variables
integer :: i, ierr, nflt_dof
double precision, allocatable :: model_best(:)
logical :: saveRejected

saveRejected = .true.

! Number of parameters to include in search depends on whether searching for model uncertainty
if (modelUncertainty) then
    nflt_dof = 2*fault%nrows + 1
else
    nflt_dof = 2*fault%nrows
endif
allocate(model_best(nflt_dof),stat=ierr)
if (ierr.ne.0) then
    call usage('invert_anneal: error allocating memory to model_best (usage:none)')
endif

! Call anneal routine with specific driver routines anneal_init, anneal_propose, and anneal_objective
call anneal(nflt_dof, &
            model_best, &
            anneal_init, &
            anneal_propose, &
            anneal_objective, &
            max_iteration, &
            reset_iteration, &
            temp_start, &
            temp_minimum, &
            cooling_factor, &
            anneal_log)

! Save results for printing
do i = 1,fault%nrows
    fault_slip(i,1) = model_best(i)*cos(model_best(i+fault%nrows)*d2r)
    fault_slip(i,2) = model_best(i)*sin(model_best(i+fault%nrows)*d2r)
enddo

return
end subroutine invert_anneal

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

subroutine anneal_init(model,n)
!----
! Initialize the annealing variables:
!     - iseed: random number seed
!     - model array: slip magnitude and rake angle
!     - step array: standard deviations of the Gaussian step size for slip and rake
!----

use io, only: stdout, fileExists, line_count, verbosity
use random, only: iseed, timeseed, r8_uniform_01

use fltinv, only: fault, &
                  slip_constraint, &
                  rake_constraint, &
                  anneal_init_mode, &
                  anneal_init_file, &
                  anneal_step_file, &
                  step, &
                  anneal_seed, &
                  modelUncertainty

implicit none

! Arguments
integer :: n
double precision :: model(n)

! Local variables
integer :: i, ios, nflt

if (verbosity.ge.2) then
    write(stdout,*) 'anneal_init: starting'
endif

! Initialize the random number generator seed
if (anneal_seed.eq.0) then
    iseed = -timeseed()
else
    iseed = -abs(anneal_seed)
endif

! Check array dimensions:
!     The first nflt entries in the model array are fault slip magnitude
!     The next nflt entries are rake angles
!     If searching for model uncertainty, then add to the end of the array
nflt = fault%nrows
if (modelUncertainty) then
    if (n.ne.2*nflt+1) then
        call usage('anneal_init: looking for model uncertainty, input n not equal to 2*nflt+1 '//&
                   '(usage:none)')
    endif
else
    if (n.ne.2*nflt) then
        call usage('anneal_init: not looking for model uncertainty, input n not equal to 2*nflt '//&
                   '(usage:none)')
    endif
endif

! Initialize the model array values
model = 0.0d0
if (anneal_init_mode.eq.'mean'.or.anneal_init_mode.eq.'half') then
    ! Set the initial solution to the magnitude and rake halfway between their limits
    do i = 1,nflt
        model(i)      = 0.5d0*(slip_constraint%array(i,1)+slip_constraint%array(i,2))
        model(i+nflt) = 0.5d0*(rake_constraint%array(i,1)+rake_constraint%array(i,2))
    enddo

elseif (anneal_init_mode.eq.'min') then
    model(1:nflt) = slip_constraint%array(:,1)
    model(nflt+1:2*nflt) = rake_constraint%array(:,1)

elseif (anneal_init_mode.eq.'max') then
    ! Set the initial solution to zero
    model(1:nflt) = slip_constraint%array(:,2)
    model(nflt+1:2*nflt) = rake_constraint%array(:,2)

elseif (anneal_init_mode.eq.'rand') then
    ! Set the initial solution to a random value within the limits of the constraint arrays
    do i = 1,nflt
        model(i)      = slip_constraint%array(i,1) + &
                        r8_uniform_01(iseed)*(slip_constraint%array(i,2)-slip_constraint%array(i,1))
        model(i+nflt) = rake_constraint%array(i,1) + &
                        r8_uniform_01(iseed)*(rake_constraint%array(i,2)-rake_constraint%array(i,1))
    enddo

elseif (anneal_init_mode.eq.'user') then
    ! Read the initial solution from a file (slip rake)
    if (anneal_init_file.eq.'none') then
        call usage('anneal_init: no initialization file defined for anneal_init_mode=user '//&
                   '(usage:anneal)')
    elseif (.not.fileExists(anneal_init_file)) then
        call usage('anneal_init: no anneal_init_file found named "'//trim(anneal_init_file)//'" '//&
                   '(usage:anneal)')
    endif
    if (line_count(anneal_init_file).ne.nflt) then
        call usage('anneal_init: number of lines in anneal_init_file must be equal to nflt '//&
                   '(usage:anneal)')
    endif
    open(unit=29,file=anneal_init_file,status='old')
    do i = 1,nflt
        read(29,*,iostat=ios) model(i),model(i+nflt)
        if (ios.ne.0) then
            call usage('anneal_init: error reading anneal init file (usage:anneal)')
        endif
    enddo
    close(29)

else
    call usage('anneal_init: no initialization mode named "'//trim(anneal_init_mode)//'" '//&
               '(usage:anneal)')
endif

! Set the parameter step values
allocate(step(2*nflt))
if (anneal_step_file.eq.'none') then
    step(1:nflt)        = (slip_constraint%array(:,2)-slip_constraint%array(:,1))/50.0d0
    step(nflt+1:2*nflt) = (rake_constraint%array(:,2)-rake_constraint%array(:,1))/50.0d0
else
    if (.not.fileExists(anneal_step_file)) then
        call usage('anneal_init: no anneal_step_file found named "'//trim(anneal_step_file)//'" '//&
                   '(usage:anneal)')
    endif
    if (line_count(anneal_step_file).ne.nflt) then
        call usage('anneal_init: anneal step file must have nflt lines (usage:anneal)')
    endif
    open(unit=30,file=anneal_step_file,status='old')
    do i = 1,nflt
        read(30,*,iostat=ios) step(i),step(i+nflt)
        if (ios.ne.0) then
            call usage('anneal_init: error reading anneal step file (usage:anneal)')
        endif
    enddo
    close(30)
endif

! If searching for model uncertainty, set the initial value here (between 0 and 1)
if (modelUncertainty) then
    model(2*nflt+1) = r8_uniform_01(iseed)
endif

if (verbosity.ge.2) then
    write(stdout,*) 'anneal_init: finished'
endif
if (verbosity.ge.3) then
    write(stdout,*) 'Initial model:'
    do i = 1,nflt
        write(stdout,*) model(i),model(i+nflt)
    enddo
endif

return
end subroutine

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

subroutine anneal_propose(model_in,model_out,n)
!----
! Propose a new model from a multi-dimensional normal distribution around the current model
!----

use io, only: verbosity, stdout
use random, only: iseed, r8_normal_ab

use fltinv, only: fault, &
                  slip_constraint, &
                  rake_constraint, &
                  step, &
                  modelUncertainty

implicit none

! Arguments
integer :: n
double precision :: model_in(n), model_out(n)

! Local variables
integer :: i, j, nflt

if (verbosity.ge.3) then
    write(stdout,*) 'anneal_propose: starting'
endif

nflt = fault%nrows
if (modelUncertainty) then
    if (n.ne.2*nflt+1) then
        call usage('anneal_propose: looking for model uncertainty, input n not equal to 2*nflt+1 '//&
                   '(usage:none)')
    endif
else
    if (n.ne.2*nflt) then
        call usage('anneal_propose: not looking for model uncertainty, input n not equal to '//&
                   '2*nflt (usage:none)')
    endif
endif

do i = 1,nflt
    j = i+nflt

    ! The new model is sampled from a Gaussian distribution around the current model
    model_out(i) = r8_normal_ab(model_in(i),step(i),iseed)
    model_out(j) = r8_normal_ab(model_in(j),step(j),iseed)

    ! Make sure model values do not go beyond values in constraint files

    ! Hard boundary for slip magnitude is value set in slip_constraint%array
    if (model_out(i).lt.slip_constraint%array(i,1)) then
        model_out(i) = slip_constraint%array(i,1)
    elseif (model_out(i).gt.slip_constraint%array(i,2)) then
        model_out(i) = slip_constraint%array(i,2)
    endif

    ! If range is 360, rake angle can vary continuously
    ! Otherwise, the rake constraints are hard boundaries
    if (model_out(j).lt.rake_constraint%array(i,1)) then
        if (rake_constraint%array(i,2)-rake_constraint%array(i,1).ge.360.0d0) then
            model_out(j) = model_out(j)+360.0d0
        else
            model_out(j) = rake_constraint%array(i,1)
        endif
    elseif (model_out(j).gt.rake_constraint%array(i,2)) then
        if (rake_constraint%array(i,2)-rake_constraint%array(i,1).ge.360.0d0) then
            model_out(j) = model_out(j)-360.0d0
        else
            model_out(j) = rake_constraint%array(i,2)
        endif
    endif
enddo

! If searching for model uncertainty, propose a new value here
if (modelUncertainty) then
    model_out(2*nflt+1) = r8_normal_ab(model_in(2*nflt+1),0.05d0,iseed)
    if (model_out(2*nflt+1).le.1.0d-8) then
        model_out(2*nflt+1) = 1.0d-8
    endif
endif

if (verbosity.ge.3) then
    write(stdout,*) 'anneal_propose: finished'
    write(stdout,*) 'Proposed model:'
    do i = 1,nflt
        write(stdout,*) model_out(i),model_out(i+nflt)
    enddo
endif

return
end subroutine

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

function anneal_objective(model,n)
!----
! The objective function is -0.5 times the chi-squared misfit.
!
! If model uncertainty (variance) is included, then the objective function needs to also
! include the pre-exponential coefficient, which includes a covariance matrix that changes with
! the model uncertainty value.
!----

use trig, only: d2r
use misfit, only: misfit_chi2

use fltinv, only: fault, &
                  displacement, &
                  disp_components, &
                  los, &
                  cov_matrix, &
                  isCovMatrixDiagonal, &
                  gf_disp, &
                  gf_los, &
                  modelUncertainty

implicit none

! Arguments
integer, intent(in) :: n
double precision :: model(n), anneal_objective

! Local variables
integer :: i, ierr, idsp, iflt, icmp, nflt, ndsp, ndsp_dof, nlos, nobs
double precision, allocatable :: obs(:), pre(:)
double precision :: slip, rake
double precision, allocatable :: model_cov_matrix(:)
double precision :: log_cov_matrix_determinant

nflt = fault%nrows
if (modelUncertainty) then
    if (n.ne.2*nflt+1) then
        call usage('anneal_objective: looking for model uncertainty, input n not equal to '//&
                   '2*nflt+1 (usage:none)')
    endif
else
    if (n.ne.2*nflt) then
        call usage('anneal_objective: not looking for model uncertainty, input n not equal to '//&
                   '2*nflt (usage:none)')
    endif
endif

ndsp = displacement%nrows
ndsp_dof = len_trim(disp_components)*displacement%nrows
nlos = los%nrows
nobs = ndsp_dof + nlos

! Observed displacements
if (.not.allocated(obs)) then
    allocate(obs(nobs),stat=ierr)
    if (ierr.ne.0) then
        call usage('anneal_objective: error allocating memory to obs (usage:none)')
    endif
endif
obs = 0.0d0

! Load observed three-component displacements
if (displacement%file.ne.'none') then
    do i = 1,len_trim(disp_components)
        read(disp_components(i:i),*) icmp
        obs((i-1)*ndsp+1:i*ndsp) = displacement%array(1:ndsp,3+icmp)
    enddo
endif

! Load observed line-of-sight displacements
if (los%file.ne.'none') then
    obs(ndsp_dof+1:ndsp_dof+nlos) = los%array(1:nlos,4)
endif

! Predicted displacements
if (.not.allocated(pre)) then
    allocate(pre(nobs),stat=ierr)
    if (ierr.ne.0) then
        call usage('anneal_objective: error allocating memory to pre (usage:none)')
    endif
endif
pre = 0.0d0

! Load predicted three-component displacements
do i = 1,len_trim(disp_components)
    read(disp_components(i:i),*) icmp
    do idsp = 1,ndsp
        do iflt = 1,nflt
            slip = model(iflt)
            rake = model(nflt+iflt)
            pre((i-1)*ndsp+idsp) = pre((i-1)*ndsp+idsp) + &
                                   gf_disp%array((icmp-1)*ndsp+idsp,     iflt)*slip*cos(rake*d2r)
            pre((i-1)*ndsp+idsp) = pre((i-1)*ndsp+idsp) + &
                                   gf_disp%array((icmp-1)*ndsp+idsp,nflt+iflt)*slip*sin(rake*d2r)
        enddo
    enddo
enddo

! Load predicted line-of-sight displacements
do i = 1,nlos
    do iflt = 1,nflt
        slip = model(iflt)
        rake = model(nflt+iflt)
        pre(ndsp_dof+i) = pre(ndsp_dof+i) + gf_los%array(i,     iflt)*slip*cos(rake*d2r)
        pre(ndsp_dof+i) = pre(ndsp_dof+i) + gf_los%array(i,nflt+iflt)*slip*sin(rake*d2r)
    enddo
enddo

if (modelUncertainty) then
    if (.not.isCovMatrixDiagonal) then
        call usage('anneal_objective: covariance matrix must be diagonal to estimate model '//&
                   'uncertainty for now (usage:input)')
    endif
    if (los%file.ne.'none') then
        call usage('anneal_objective: model uncertainty cannot be estimated with LOS data yet '//&
                   '(usage:none)')
    endif

    ! Initialize model prediction error covariance matrix
    if (.not.allocated(model_cov_matrix)) then
        allocate(model_cov_matrix(nobs),stat=ierr)
        if (ierr.ne.0) then
            call usage('anneal_objective: error allocating memory to model_cov_matrix (usage:none)')
        endif
    endif
    model_cov_matrix = 0.0d0

    ! Load model error prediction covariance matrix
    do idsp = 1,ndsp
        ! Model prediction error covariance at each station is (for three-component displacements):
        !     error_cov(ista) = e^2*(obs(ista,1)^2+obs(ista,2)^2+obs(ista,3)^2)
        ! where e is the percent error
        do icmp = 1,len_trim(disp_components)
            i = (icmp-1)*ndsp + idsp
            model_cov_matrix(idsp) = model_cov_matrix(idsp) + model(2*nflt+1)**2 * obs(i)**2
        enddo
    enddo
    do icmp = 2,len_trim(disp_components)
        model_cov_matrix((icmp-1)*ndsp+1:icmp*ndsp) = model_cov_matrix(1:ndsp)
    enddo

    ! Calculate chi-squared and scale it for (Gaussian) probability
    cov_matrix(:,1) = cov_matrix(:,1) + model_cov_matrix
    call misfit_chi2(obs,pre,cov_matrix,isCovMatrixDiagonal,nobs,anneal_objective)
    cov_matrix(:,1) = cov_matrix(:,1) - model_cov_matrix

    ! Scale objective value by determinant of the covariance matrix (including both observation
    ! and model prediction error covariances) to determine its probability, e.g.:
    !
    ! Tarantola, A. (2005). Inverse Problem Theory and Methods for Model Parameter Estimation.
    !     Philadelphia, PA, USA: Society for Industrial and Applied Mathematics.
    ! Beck, J.L. (2010). Bayesian system identification based on probability logic. Structural
    !     Control and Health Monitoring 17, 825–847.
    ! Minson, S.E., Simons, M., & Beck, J.L. (2013). Bayesian inversion for finite fault earthquake
    !     source models I—theory and algorithm. Geophysical Journal International 194, 1701–1726.
    log_cov_matrix_determinant = 0.0d0
    do i = 1,nobs
        log_cov_matrix_determinant = log_cov_matrix_determinant + &
                                     log(cov_matrix(i,1) + model_cov_matrix(i))
    enddo
    anneal_objective = anneal_objective + log_cov_matrix_determinant

else
    call misfit_chi2(obs,pre,cov_matrix,isCovMatrixDiagonal,nobs,anneal_objective)
endif
anneal_objective = -0.5d0*anneal_objective

return
end function

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

subroutine anneal_log(it,temp,obj,model_current,model_proposed,n,isAccepted,string)

use fltinv, only: fault, &
                  max_iteration, &
                  anneal_log_file, &
                  modelUncertainty

implicit none

! Arguments
integer :: it, n
double precision :: temp, obj, model_current(n), model_proposed(n)
character(len=*) :: string
logical :: isAccepted

! Local variables
integer :: i, nflt
character(len=8) :: rejected_string
character(len=16) :: str, it_str, temp_str, obj_str, uncert_str

if (anneal_log_file.eq.'') then
    return
endif

nflt = fault%nrows

! Update annealing log file
write(it_str,'(I8)') it
write(temp_str,'(1PE12.4)') temp
write(obj_str,'(1PE12.4)') obj
if (modelUncertainty) then
    write(uncert_str,'(1PE12.4)') model_current(2*nflt+1)
else
    write(uncert_str,'(1PE12.4)') -1.0d0
endif
it_str = adjustl(it_str)
temp_str = adjustl(temp_str)
obj_str = adjustl(obj_str)
uncert_str = adjustl(uncert_str)

if (string.eq.'init') then
    ! Open the log file
    open(unit=29,file=anneal_log_file,status='unknown')

    ! Write header

    write(str,'(I8)') max_iteration
    write(29,'(A)') '# niterations='//adjustl(str)
    write(str,'(I8)') nflt
    write(29,'(A)') '# nfaults='//adjustl(str)
    write(29,'(A)') '# format=anneal'

    ! Write iteration parameters, fault slip values
    write(29,2901) it_str, temp_str, obj_str, uncert_str
    do i = 1,nflt
        write(29,2902) model_current(i)
    enddo
    do i = nflt+1,2*nflt
        write(29,2903) model_current(i)
    enddo
    2901 format('> Iteration=',A8,X,'Temperature=',A12,X,'Objective=',A12,X,'Model_Uncertainty=',&
                A12)
    2902 format(1PE14.6)
    2903 format(F12.2)

elseif (string.eq.'append') then
    ! Is this a rejected model?
    if (isAccepted) then
        rejected_string = 'accepted'
    else
        rejected_string = 'rejected'
    endif

    ! Write iteration parameters, fault slip values
    write(29,2904) it_str, temp_str, obj_str, uncert_str, trim(rejected_string)
    do i = 1,nflt
        write(29,2905) model_current(i),model_proposed(i)
    enddo
    do i = nflt+1,2*nflt
        write(29,2906) model_current(i),model_proposed(i)
    enddo
    2904 format('> Iteration=',A8,X,'Temperature=',A12,X,'Objective=',A12,X,'Model_Uncertainty=',&
                A12,X,A)
    2905 format(1PE14.6,X,E14.6)
    2906 format(F12.2,X,F12.2)

elseif (string.eq.'close') then
    ! Close the log file
    close(29)

else
    call usage('anneal_log: no string option named '//trim(string)//' (usage:none)')
endif

return
end subroutine


module SphereSWEModule

use NumberKindsModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use EdgesModule
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use PSEDirectSumModule
use SphereGeomModule

implicit none

include 'mpif.h'

private

!
!----------------
! Module types and public declarations
!----------------
!
public SWEMesh, New, Delete, Copy
public AddTracers
public LogStats
public OutputToVTK
public SetInitialHOnMesh, SetInitialDivergenceOnMesh, SetInitialPotVortOnMesh
public SetInitialVelocityOnMesh, SetInitialRelVortOnMesh
public SetBottomHeightOnMesh

type SWEMesh
	type(PolyMesh2d) :: mesh
	type(Field) :: potVort
	type(Field) :: relVort
	type(Field) :: divergence
	type(Field) :: velocity
	type(Field) :: h
	type(FIeld) :: hBottom
	type(Field), pointer :: tracers(:) => null()
	real(kreal) :: radius
	real(kreal) :: rotationRate = 0.0_kreal
	real(kreal) :: g = 1.0_kreal
	real(kreal) :: pseEps = 0.0_kreal
	type(MPISetup) :: mpiParticles

	contains
		final :: deletePrivate
end type

!
!----------------
! Module interfaces
!----------------
!
interface New
	module procedure newPrivate
end interface

interface Delete
	module procedure deletePrivate
end interface

interface Copy
	module procedure copyPrivate
end interface

interface LogStats
	module procedure logStatsPrivate
end interface

!
!----------------
! Logging
!----------------
!
logical(klog), save :: logInit = .FALSE.
type(Logger) :: log
character(len=28), save :: logKey = 'SWE'
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL

contains

!
!----------------
! public methods
!----------------
!
subroutine newPrivate( self, meshSeed, initNest, maxNest, amrLimit, sphereRadius, rotationRate, g)
	type(SWEMesh), intent(out) :: self
	integer(kint), intent(in) :: meshSeed
	integer(kint), intent(in) :: initNest
	integer(kint), intent(in) :: maxNest
	integer(kint), intent(in) :: amrLimit
	real(kreal), intent(in) :: sphereRadius
	real(kreal), intent(in) :: rotationRate
	real(kreal), intent(in) :: g

	if ( .NOT. logInit ) call InitLogger(log, procRank)

	if ( meshSeed /= ICOS_TRI_SPHERE_SEED .AND. meshSeed /= CUBED_SPHERE_SEED ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logKey), "new SWEMesh ERROR : invalid meshSeed.")
		return
	endif

	call New(self%mesh, meshSeed, initNest, maxNest, amrLimit, sphereRadius)

	call New(self%potVort, 1, self%mesh%particles%N_Max, "potVort", "1/s")
	call New(self%relVort, 1, self%mesh%particles%N_Max, "relVort", "1/s")
	call New(self%divergence, 1, self%mesh%particles%N_Max, "divergence", "1/s")
	call New(self%h, 1, self%mesh%particles%N_Max, "h", "m")
	call New(self%hBottom, 1, self%mesh%particles%N_Max, "hBottom", "m")
	call New(self%velocity, 3, self%mesh%particles%N_Max, "velocity", "m/s")

	call New(self%mpiParticles, self%mesh%particles%N, numProcs)

	self%radius = sphereRadius
	self%rotationRate = rotationRate
	self%g = g
end subroutine

subroutine deletePrivate( self )
	type(SWEMesh), intent(inout) :: self
	integer(kint) :: i

	call Delete(self%mpiParticles)
	call Delete(self%velocity)
	call Delete(self%h)
	call Delete(self%divergence)
	call Delete(self%relVort)
	call Delete(self%potVort)
	call Delete(self%mesh)
	call Delete(self%hBottom)
	if ( associated(self%tracers)) then
		do i = 1, size(self%tracers)
			call Delete(self%tracers(i))
		enddo
		deallocate(self%tracers)
	endif
end subroutine

subroutine copyPrivate(self, other)
	type(SWEMesh), intent(inout) :: self
	type(SWEMesh), intent(in) :: other
	integer(kint) :: i

	call Copy(self%mesh, other%mesh)
	call Copy(self%h, other%h)
	call Copy(self%relVort, other%relVort)
	call Copy(self%potVort, other%potVort)
	call Copy(self%divergence, other%divergence)
	call Copy(self%velocity, other%velocity)
	call Copy(self%hBottom, other%hBottom)
	self%radius = other%radius
	self%rotationRate = other%rotationRate
	self%g = other%g
	call Copy(self%mpiParticles, other%mpiParticles)
	if ( associated(other%tracers) ) then
		if ( associated(self%tracers)) then
			if ( size(self%tracers) < size(other%tracers) ) then
				call LogMessage(log, ERROR_LOGGING_LEVEL, logkey, " copy SWEMesh ERROR : tracers not allocated properly.")
			else
				do i = 1, size(other%tracers)
					call Copy(self%tracers(i), other%tracers(i))
				enddo
			endif
		else
			allocate(self%tracers(size(other%tracers)))
			do i = 1, size(other%tracers)
				call New(self%tracers(i), other%tracers(i)%nDim, other%mesh%particles%N)
				call Copy(self%tracers(i), other%tracers(i))
			enddo
		endif
	endif
end subroutine

subroutine AddTracers(self, nTracers, tracerDims)
	type(SWEMesh), intent(inout) :: self
	integer(kint), intent(in) :: nTracers
	integer(kint), intent(in), dimension(:) :: tracerDims
	integer(kint) :: i

	if ( size(tracerDims) /= nTracers ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logkey)//" AddTracers ERROR : ", &
			" must specify dimension of each tracer field.")
		return
	endif

	allocate(self%tracers(nTracers))
	do i = 1, nTracers
		call New(self%tracers(i), tracerDims(i), self%mesh%particles%N_Max)
	enddo
end subroutine

subroutine logStatsPrivate( self, aLog )
	type(SWEMesh), intent(in) :: self
	type(Logger), intent(inout) :: aLog
	!
	integer(kint) :: i

	call StartSection(aLog, "SWEMesh ", "stats:")
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "rotationRate = ", self%rotationRate)
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "gravity = ", self%g )
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "radius = ", self%radius )
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "pseEps = ", self%pseEps)
	call LogStats(self%mesh, aLog)
	call LogStats(self%velocity, aLog )
	call LogStats(self%relVort, aLog )
	call LogStats(self%potVort, aLog )
	call LogStats(self%h, aLog )
	call LogStats(self%divergence, aLog )
	call LogStats(self%hBottom, aLog )
	if ( associated(self%tracers) ) then
		do i = 1, size(self%tracers)
			call LogStats(self%tracers(i), aLog)
		enddo
	endif
	call EndSection(aLog)
end subroutine

subroutine OutputToVTK( self, filename )
	type(SWEMesh), intent(in) :: self
	character(len=*), intent(in) :: filename
	!
	integer(kint) :: i, writeStat

	open(unit=WRITE_UNIT_1, file=filename, status='REPLACE', action='WRITE', iostat = writeStat)
		if ( writeStat /= 0 ) then
			call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logkey)//" OutputToVTK ERROR writing to file = ", trim(filename))
			return
		endif
		!
		!	write points and topology
		!
		call WriteVTKPoints(self%mesh%particles, WRITE_UNIT_1)
		call WriteFacesToVTKPolygons(self%mesh%faces, WRITE_UNIT_1)
		!
		!	write vtk point data
		!
		call WriteVTKPointDataSectionHeader(WRITE_UNIT_1, self%mesh%particles%N)
		call WriteVTKLagCoords( self%mesh%particles, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( self%potVort, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( self%relVort, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( self%divergence, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( self%h, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( self%hBottom, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( self%velocity, WRITE_UNIT_1)
		if ( associated( self%tracers ) ) then
			do i = 1, size(self%tracers)
				call WriteFieldToVTKPointData( self%tracers(i), WRITE_UNIT_1)
			enddo
		endif
		!
		!	write vtk cell data
		!
		call WriteFaceAreaToVTKCellData( self%mesh%faces, self%mesh%particles, WRITE_UNIT_1)

	close(WRITE_UNIT_1)
end subroutine

subroutine SetInitialRelVortOnMesh( self, vortFn )
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOf3DSpace) :: vortFn
	!
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		call InsertScalarToField(self%relVort, &
				vortFn( self%mesh%particles%x(i), self%mesh%particles%y(i), self%mesh%particles%z(i)))
	enddo
end subroutine

subroutine SetScalarTracerOnMesh( self, tracerID, tracerFn)
	type(SWEMesh), intent(inout) :: self
	integer(kint), intent(in) :: tracerID
	procedure(scalarFnOf3DSpace) :: tracerFn
	integer(kint) :: i
	call SetFieldToZero(self%tracers(tracerID))
	self%tracers(tracerId)%N = self%mesh%particles%N
	do i = 1, self%mesh%particles%N
		self%tracers(tracerID)%scalar(i) = &
			tracerFn( self%mesh%particles%x0(i), self%mesh%particles%y0(i), self%mesh%particles%z0(i))
	enddo
end subroutine

subroutine SetVectorTracerOnMesh( self, tracerID, tracerFn )
	type(SWEMesh), intent(inout) :: self
	integer(kint), intent(in) :: tracerID
	procedure(vectorFnOf3DSpace) :: tracerFn
	integer(kint) :: i
	real(kreal), dimension(3) :: vec
	call SetFieldToZero(self%tracers(tracerID))
	self%tracers(tracerID)%N = self%mesh%particles%N
	do i = 1, self%mesh%particles%N
		vec = tracerFn( self%mesh%particles%x0(i), self%mesh%particles%y0(i), self%mesh%particles%z0(i) )
		self%tracers(tracerID)%xComp(i) = vec(1)
		self%tracers(tracerID)%yComp(i) = vec(2)
		self%tracers(tracerID)%zComp(i) = vec(3)
	enddo
end subroutine

subroutine SetInitialHOnMesh( self, hFn )
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOf3DSpace) :: hFn
	integer(kint) :: i
	do i = 1, self%mesh%particles%N
		call InsertScalarToField( self%h, &
			hFn( self%mesh%particles%x(i), self%mesh%particles%y(i), self%mesh%particles%z(i)))
	enddo
end subroutine

subroutine SetBottomHeightOnMesh( self, topographyFn)
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOf3DSpace) :: topographyFn
	!
	integer(kint) :: i

	self%hBottom%N = self%mesh%particles%N
	do i = 1, self%mesh%particles%N
		self%hBottom%scalar(i) = topographyFn( self%mesh%particles%x(i), self%mesh%particles%y(i), self%mesh%particles%z(i))
	enddo
end subroutine

subroutine SetInitialDivergenceOnMesh( self, divFn )
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOf3DSpace) :: divFn
	integer(kint) :: i
	do i = 1, self%mesh%particles%N
		call InsertScalarToField( self%divergence, &
			divFn( self%mesh%particles%x(i), self%mesh%particles%y(i), self%mesh%particles%z(i)))
	enddo
end subroutine

subroutine SetInitialVelocityOnMesh( self, velFn )
	type(SWEMesh), intent(inout) :: self
	procedure(vectorFnOf3DSpace) :: velFn
	integer(kint) :: i
	do i = 1, self%mesh%particles%N
		call InsertVectorToField( self%velocity, &
			velFn( self%mesh%particles%x(i), self%mesh%particles%y(i), self%mesh%particles%z(i)))
	enddo
end subroutine

subroutine SetInitialPotVortOnMesh( self )
	type(SWEMesh), intent(inout) :: self
	integer(kint) :: i
	real(kreal) :: pv, xi(3)
	do i = 1, self%mesh%particles%N
		xi = PhysCoord(self%mesh%particles, i)
		pv = (self%relVort%scalar(i) + 2.0_kreal * self%rotationRate * sin(Latitude(xi)) ) / self%h%scalar(i)
		call InsertScalarToField(self%potVort, pv)
	enddo
end subroutine

!
!----------------
! private methods
!----------------
!
subroutine InitLogger(aLog,rank)
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	write(logKey,'(A,A,I0.2,A)') trim(logKey),'_',rank,' : '
	if ( rank == 0 ) then
		call New(aLog,logLevel)
	else
		call New(aLog,ERROR_LOGGING_LEVEL)
	endif
	logInit = .TRUE.
end subroutine

end module


module my_data
    implicit none
    real grid(2, 500, 250)
    integer gridIndex
    integer visualScale
end module

function RealToGrayscaleRGB(grey) result(res)
    real, intent(in) :: grey
    real :: greySanitized
    real greyStep1
    integer greyStep2
    integer res

    greySanitized = max(-1., grey)
    greySanitized = min(1., greySanitized)

    greyStep1 = ((greySanitized + 1.) / 2.) * 255
    greyStep2 = greyStep1
    res = ior(ishft(ior(ishft(greyStep2, 8), greyStep2), 8), greyStep2)

end function

subroutine Initialize()
    !DEC$ ATTRIBUTES DLLEXPORT::Initialize
    use my_data
    implicit none

    integer :: x, y, j

    !Initialize grid
    gridIndex = 1
    do j=1,2
        do x=1,500
            do y=1,250
                grid(j, x, y) = 0
            end do
        end do
    end do

end subroutine Initialize

subroutine Redraw(buffer)
    !DEC$ ATTRIBUTES DLLEXPORT::Redraw

    use my_data
    implicit none

    integer(4) :: buffer(512, 250) ! Width = stride / 4
    integer :: x, y

    integer grayscaleRGB
    integer :: RealToGrayscaleRGB

    do y=1,250
        do x=1,500
            grayscaleRGB = RealToGrayscaleRGB(grid(gridIndex, x, y))
            buffer(x, y) = grayscaleRGB
        end do
    end do

end subroutine Redraw

subroutine Update()
    !DEC$ ATTRIBUTES DLLEXPORT::Update

    use my_data
    implicit none

    real :: total
    real :: average
    integer :: x
    integer :: y
    integer :: otherIndex
    real :: dampen, superDampen
    integer :: l, t, r, b

    dampen = 0.95
    superDampen = 0.8

    otherIndex = 3 - gridIndex

    do x=1,500
        do y=1,250
            l = max(x-1, 1)
            r = min(x+1, 500)
            t = max(y-1, 1)
            b = min(y+1, 250)

            ! Get the average of cells
            total = &
                grid(gridIndex, x, t) + grid(gridIndex, x, b) + &
                grid(gridIndex, l, y) + grid(gridIndex, r, y)

            average = total / 2.
            average = average - grid(otherIndex, x, y)
            average = average * dampen

            grid(otherIndex, x, y) = average
        end do
    end do

    gridIndex = otherIndex

end subroutine Update

subroutine OnMouseEvent(mx, my)
    !DEC$ ATTRIBUTES DLLEXPORT::OnMouseEvent

    use my_data
    implicit none

    integer, intent(in) :: mx
    integer, intent(in) :: my

    grid(gridIndex, mx, my) = 30

end subroutine OnMouseEvent


*> \brief \b SLAGGE
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, KL, KU, LDA, M, N
*       ..
*       .. Array Arguments ..
*       INTEGER            ISEED( 4 )
*       REAL               A( LDA, * ), D( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLAGGE generates a real general m by n matrix A, by pre- and post-
*> multiplying a real diagonal matrix D with random orthogonal matrices:
*> A = U*D*V. The lower and upper bandwidths may then be reduced to
*> kl and ku by additional orthogonal transformations.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*>          KL is INTEGER
*>          The number of nonzero subdiagonals within the band of A.
*>          0 <= KL <= M-1.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*>          KU is INTEGER
*>          The number of nonzero superdiagonals within the band of A.
*>          0 <= KU <= N-1.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL array, dimension (min(M,N))
*>          The diagonal elements of the diagonal matrix D.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          The generated m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= M.
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          On entry, the seed of the random number generator; the array
*>          elements must be between 0 and 4095, and ISEED(4) must be
*>          odd.
*>          On exit, the seed is updated.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (M+N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup real_matgen
*
*  =====================================================================
      SUBROUTINE SLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      REAL               A( LDA, * ), D( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      REAL               TAU, WA, WB, WN
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMV, SGER, SLARNV, SSCAL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SIGN
*     ..
*     .. External Functions ..
      REAL               SNRM2
      EXTERNAL           SNRM2
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 .OR. KL.GT.M-1 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -7
      END IF
      IF( INFO.LT.0 ) THEN
         CALL XERBLA( 'SLAGGE', -INFO )
         RETURN
      END IF
*
*     initialize A to diagonal matrix
*
      DO 20 J = 1, N
         DO 10 I = 1, M
            A( I, J ) = ZERO
   10    CONTINUE
   20 CONTINUE
      DO 30 I = 1, MIN( M, N )
         A( I, I ) = D( I )
   30 CONTINUE
*
*     pre- and post-multiply A by random orthogonal matrices
*
      DO 40 I = MIN( M, N ), 1, -1
         IF( I.LT.M ) THEN
*
*           generate random reflection
*
            CALL SLARNV( 3, ISEED, M-I+1, WORK )
            WN = SNRM2( M-I+1, WORK, 1 )
            WA = SIGN( WN, WORK( 1 ) )
            IF( WN.EQ.ZERO ) THEN
               TAU = ZERO
            ELSE
               WB = WORK( 1 ) + WA
               CALL SSCAL( M-I, ONE / WB, WORK( 2 ), 1 )
               WORK( 1 ) = ONE
               TAU = WB / WA
            END IF
*
*           multiply A(i:m,i:n) by random reflection from the left
*
            CALL SGEMV( 'Transpose', M-I+1, N-I+1, ONE, A( I, I ), LDA,
     $                  WORK, 1, ZERO, WORK( M+1 ), 1 )
            CALL SGER( M-I+1, N-I+1, -TAU, WORK, 1, WORK( M+1 ), 1,
     $                 A( I, I ), LDA )
         END IF
         IF( I.LT.N ) THEN
*
*           generate random reflection
*
            CALL SLARNV( 3, ISEED, N-I+1, WORK )
            WN = SNRM2( N-I+1, WORK, 1 )
            WA = SIGN( WN, WORK( 1 ) )
            IF( WN.EQ.ZERO ) THEN
               TAU = ZERO
            ELSE
               WB = WORK( 1 ) + WA
               CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
               WORK( 1 ) = ONE
               TAU = WB / WA
            END IF
*
*           multiply A(i:m,i:n) by random reflection from the right
*
            CALL SGEMV( 'No transpose', M-I+1, N-I+1, ONE, A( I, I ),
     $                  LDA, WORK, 1, ZERO, WORK( N+1 ), 1 )
            CALL SGER( M-I+1, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1,
     $                 A( I, I ), LDA )
         END IF
   40 CONTINUE
*
*     Reduce number of subdiagonals to KL and number of superdiagonals
*     to KU
*
      DO 70 I = 1, MAX( M-1-KL, N-1-KU )
         IF( KL.LE.KU ) THEN
*
*           annihilate subdiagonal elements first (necessary if KL = 0)
*
            IF( I.LE.MIN( M-1-KL, N ) ) THEN
*
*              generate reflection to annihilate A(kl+i+1:m,i)
*
               WN = SNRM2( M-KL-I+1, A( KL+I, I ), 1 )
               WA = SIGN( WN, A( KL+I, I ) )
               IF( WN.EQ.ZERO ) THEN
                  TAU = ZERO
               ELSE
                  WB = A( KL+I, I ) + WA
                  CALL SSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
                  A( KL+I, I ) = ONE
                  TAU = WB / WA
               END IF
*
*              apply reflection to A(kl+i:m,i+1:n) from the left
*
               CALL SGEMV( 'Transpose', M-KL-I+1, N-I, ONE,
     $                     A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
     $                     WORK, 1 )
               CALL SGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1,
     $                    A( KL+I, I+1 ), LDA )
               A( KL+I, I ) = -WA
            END IF
*
            IF( I.LE.MIN( N-1-KU, M ) ) THEN
*
*              generate reflection to annihilate A(i,ku+i+1:n)
*
               WN = SNRM2( N-KU-I+1, A( I, KU+I ), LDA )
               WA = SIGN( WN, A( I, KU+I ) )
               IF( WN.EQ.ZERO ) THEN
                  TAU = ZERO
               ELSE
                  WB = A( I, KU+I ) + WA
                  CALL SSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
                  A( I, KU+I ) = ONE
                  TAU = WB / WA
               END IF
*
*              apply reflection to A(i+1:m,ku+i:n) from the right
*
               CALL SGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
     $                     A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
     $                     WORK, 1 )
               CALL SGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
     $                    LDA, A( I+1, KU+I ), LDA )
               A( I, KU+I ) = -WA
            END IF
         ELSE
*
*           annihilate superdiagonal elements first (necessary if
*           KU = 0)
*
            IF( I.LE.MIN( N-1-KU, M ) ) THEN
*
*              generate reflection to annihilate A(i,ku+i+1:n)
*
               WN = SNRM2( N-KU-I+1, A( I, KU+I ), LDA )
               WA = SIGN( WN, A( I, KU+I ) )
               IF( WN.EQ.ZERO ) THEN
                  TAU = ZERO
               ELSE
                  WB = A( I, KU+I ) + WA
                  CALL SSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
                  A( I, KU+I ) = ONE
                  TAU = WB / WA
               END IF
*
*              apply reflection to A(i+1:m,ku+i:n) from the right
*
               CALL SGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
     $                     A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
     $                     WORK, 1 )
               CALL SGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
     $                    LDA, A( I+1, KU+I ), LDA )
               A( I, KU+I ) = -WA
            END IF
*
            IF( I.LE.MIN( M-1-KL, N ) ) THEN
*
*              generate reflection to annihilate A(kl+i+1:m,i)
*
               WN = SNRM2( M-KL-I+1, A( KL+I, I ), 1 )
               WA = SIGN( WN, A( KL+I, I ) )
               IF( WN.EQ.ZERO ) THEN
                  TAU = ZERO
               ELSE
                  WB = A( KL+I, I ) + WA
                  CALL SSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
                  A( KL+I, I ) = ONE
                  TAU = WB / WA
               END IF
*
*              apply reflection to A(kl+i:m,i+1:n) from the left
*
               CALL SGEMV( 'Transpose', M-KL-I+1, N-I, ONE,
     $                     A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
     $                     WORK, 1 )
               CALL SGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1,
     $                    A( KL+I, I+1 ), LDA )
               A( KL+I, I ) = -WA
            END IF
         END IF
*
         DO 50 J = KL + I + 1, M
            A( J, I ) = ZERO
   50    CONTINUE
*
         DO 60 J = KU + I + 1, N
            A( I, J ) = ZERO
   60    CONTINUE
   70 CONTINUE
      RETURN
*
*     End of SLAGGE
*
      END


!*==sgelss.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  SGELSS solves overdetermined or underdetermined systems for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SGELSS + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
!                          WORK, LWORK, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
!       REAL               RCOND
!       ..
!       .. Array Arguments ..
!       REAL               A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SGELSS computes the minimum norm solution to a real linear least
!> squares problem:
!>
!> Minimize 2-norm(| b - A*x |).
!>
!> using the singular value decomposition (SVD) of A. A is an M-by-N
!> matrix which may be rank-deficient.
!>
!> Several right hand side vectors b and solution vectors x can be
!> handled in a single call; they are stored as the columns of the
!> M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
!> X.
!>
!> The effective rank of A is determined by treating as zero those
!> singular values which are less than RCOND times the largest singular
!> value.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A. M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A. N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X. NRHS >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the first min(m,n) rows of A are overwritten with
!>          its right singular vectors, stored rowwise.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is REAL array, dimension (LDB,NRHS)
!>          On entry, the M-by-NRHS right hand side matrix B.
!>          On exit, B is overwritten by the N-by-NRHS solution
!>          matrix X.  If m >= n and RANK = n, the residual
!>          sum-of-squares for the solution in the i-th column is given
!>          by the sum of squares of elements n+1:m in that column.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,max(M,N)).
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is REAL array, dimension (min(M,N))
!>          The singular values of A in decreasing order.
!>          The condition number of A in the 2-norm = S(1)/S(min(m,n)).
!> \endverbatim
!>
!> \param[in] RCOND
!> \verbatim
!>          RCOND is REAL
!>          RCOND is used to determine the effective rank of A.
!>          Singular values S(i) <= RCOND*S(1) are treated as zero.
!>          If RCOND < 0, machine precision is used instead.
!> \endverbatim
!>
!> \param[out] RANK
!> \verbatim
!>          RANK is INTEGER
!>          The effective rank of A, i.e., the number of singular values
!>          which are greater than RCOND*S(1).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= 1, and also:
!>          LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  the algorithm for computing the SVD failed to converge;
!>                if INFO = i, i off-diagonal elements of an intermediate
!>                bidiagonal form did not converge to zero.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realGEsolve
!
!  =====================================================================
      SUBROUTINE SGELSS(M,N,Nrhs,A,Lda,B,Ldb,S,Rcond,Rank,Work,Lwork,   &
     &                  Info)
      IMPLICIT NONE
!*--SGELSS176
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , Ldb , Lwork , M , N , Nrhs , Rank
      REAL Rcond
!     ..
!     .. Array Arguments ..
      REAL A(Lda,*) , B(Ldb,*) , S(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery
      INTEGER bdspac , bl , chunk , i , iascl , ibscl , ie , il , itau ,&
     &        itaup , itauq , iwork , ldwork , maxmn , maxwrk , minmn , &
     &        minwrk , mm , mnthr
      INTEGER lwork_sgeqrf , lwork_sormqr , lwork_sgebrd ,              &
     &        lwork_sormbr , lwork_sorgbr , lwork_sormlq
      REAL anrm , bignum , bnrm , eps , sfmin , smlnum , thr
!     ..
!     .. Local Arrays ..
      REAL dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL SBDSQR , SCOPY , SGEBRD , SGELQF , SGEMM , SGEMV ,       &
     &         SGEQRF , SLABAD , SLACPY , SLASCL , SLASET , SORGBR ,    &
     &         SORMBR , SORMLQ , SORMQR , SRSCL , XERBLA
!     ..
!     .. External Functions ..
      INTEGER ILAENV
      REAL SLAMCH , SLANGE
      EXTERNAL ILAENV , SLAMCH , SLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      minmn = MIN(M,N)
      maxmn = MAX(M,N)
      lquery = (Lwork==-1)
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Nrhs<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,maxmn) ) THEN
         Info = -7
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.)
!
      IF ( Info==0 ) THEN
         minwrk = 1
         maxwrk = 1
         IF ( minmn>0 ) THEN
            mm = M
            mnthr = ILAENV(6,'SGELSS',' ',M,N,Nrhs,-1)
            IF ( M>=N .AND. M>=mnthr ) THEN
!
!              Path 1a - overdetermined, with many more rows than
!                        columns
!
!              Compute space needed for SGEQRF
               CALL SGEQRF(M,N,A,Lda,dum(1),dum(1),-1,Info)
               lwork_sgeqrf = dum(1)
!              Compute space needed for SORMQR
               CALL SORMQR('L','T',M,Nrhs,N,A,Lda,dum(1),B,Ldb,dum(1),  &
     &                     -1,Info)
               lwork_sormqr = dum(1)
               mm = N
               maxwrk = MAX(maxwrk,N+lwork_sgeqrf)
               maxwrk = MAX(maxwrk,N+lwork_sormqr)
            ENDIF
            IF ( M>=N ) THEN
!
!              Path 1 - overdetermined or exactly determined
!
!              Compute workspace needed for SBDSQR
!
               bdspac = MAX(1,5*N)
!              Compute space needed for SGEBRD
               CALL SGEBRD(mm,N,A,Lda,S,dum(1),dum(1),dum(1),dum(1),-1, &
     &                     Info)
               lwork_sgebrd = dum(1)
!              Compute space needed for SORMBR
               CALL SORMBR('Q','L','T',mm,Nrhs,N,A,Lda,dum(1),B,Ldb,    &
     &                     dum(1),-1,Info)
               lwork_sormbr = dum(1)
!              Compute space needed for SORGBR
               CALL SORGBR('P',N,N,N,A,Lda,dum(1),dum(1),-1,Info)
               lwork_sorgbr = dum(1)
!              Compute total workspace needed
               maxwrk = MAX(maxwrk,3*N+lwork_sgebrd)
               maxwrk = MAX(maxwrk,3*N+lwork_sormbr)
               maxwrk = MAX(maxwrk,3*N+lwork_sorgbr)
               maxwrk = MAX(maxwrk,bdspac)
               maxwrk = MAX(maxwrk,N*Nrhs)
               minwrk = MAX(3*N+mm,3*N+Nrhs,bdspac)
               maxwrk = MAX(minwrk,maxwrk)
            ENDIF
            IF ( N>M ) THEN
!
!              Compute workspace needed for SBDSQR
!
               bdspac = MAX(1,5*M)
               minwrk = MAX(3*M+Nrhs,3*M+N,bdspac)
               IF ( N>=mnthr ) THEN
!
!                 Path 2a - underdetermined, with many more columns
!                 than rows
!
!                 Compute space needed for SGEBRD
                  CALL SGEBRD(M,M,A,Lda,S,dum(1),dum(1),dum(1),dum(1),  &
     &                        -1,Info)
                  lwork_sgebrd = dum(1)
!                 Compute space needed for SORMBR
                  CALL SORMBR('Q','L','T',M,Nrhs,N,A,Lda,dum(1),B,Ldb,  &
     &                        dum(1),-1,Info)
                  lwork_sormbr = dum(1)
!                 Compute space needed for SORGBR
                  CALL SORGBR('P',M,M,M,A,Lda,dum(1),dum(1),-1,Info)
                  lwork_sorgbr = dum(1)
!                 Compute space needed for SORMLQ
                  CALL SORMLQ('L','T',N,Nrhs,M,A,Lda,dum(1),B,Ldb,dum(1)&
     &                        ,-1,Info)
                  lwork_sormlq = dum(1)
!                 Compute total workspace needed
                  maxwrk = M + M*ILAENV(1,'SGELQF',' ',M,N,-1,-1)
                  maxwrk = MAX(maxwrk,M*M+4*M+lwork_sgebrd)
                  maxwrk = MAX(maxwrk,M*M+4*M+lwork_sormbr)
                  maxwrk = MAX(maxwrk,M*M+4*M+lwork_sorgbr)
                  maxwrk = MAX(maxwrk,M*M+M+bdspac)
                  IF ( Nrhs>1 ) THEN
                     maxwrk = MAX(maxwrk,M*M+M+M*Nrhs)
                  ELSE
                     maxwrk = MAX(maxwrk,M*M+2*M)
                  ENDIF
                  maxwrk = MAX(maxwrk,M+lwork_sormlq)
               ELSE
!
!                 Path 2 - underdetermined
!
!                 Compute space needed for SGEBRD
                  CALL SGEBRD(M,N,A,Lda,S,dum(1),dum(1),dum(1),dum(1),  &
     &                        -1,Info)
                  lwork_sgebrd = dum(1)
!                 Compute space needed for SORMBR
                  CALL SORMBR('Q','L','T',M,Nrhs,M,A,Lda,dum(1),B,Ldb,  &
     &                        dum(1),-1,Info)
                  lwork_sormbr = dum(1)
!                 Compute space needed for SORGBR
                  CALL SORGBR('P',M,N,M,A,Lda,dum(1),dum(1),-1,Info)
                  lwork_sorgbr = dum(1)
                  maxwrk = 3*M + lwork_sgebrd
                  maxwrk = MAX(maxwrk,3*M+lwork_sormbr)
                  maxwrk = MAX(maxwrk,3*M+lwork_sorgbr)
                  maxwrk = MAX(maxwrk,bdspac)
                  maxwrk = MAX(maxwrk,N*Nrhs)
               ENDIF
            ENDIF
            maxwrk = MAX(minwrk,maxwrk)
         ENDIF
         Work(1) = maxwrk
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -12
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('SGELSS',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( M==0 .OR. N==0 ) THEN
         Rank = 0
         RETURN
      ENDIF
!
!     Get machine parameters
!
      eps = SLAMCH('P')
      sfmin = SLAMCH('S')
      smlnum = sfmin/eps
      bignum = ONE/smlnum
      CALL SLABAD(smlnum,bignum)
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = SLANGE('M',M,N,A,Lda,Work)
      iascl = 0
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL SLASCL('G',0,0,anrm,smlnum,M,N,A,Lda,Info)
         iascl = 1
      ELSEIF ( anrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL SLASCL('G',0,0,anrm,bignum,M,N,A,Lda,Info)
         iascl = 2
      ELSEIF ( anrm==ZERO ) THEN
!
!        Matrix all zero. Return zero solution.
!
         CALL SLASET('F',MAX(M,N),Nrhs,ZERO,ZERO,B,Ldb)
         CALL SLASET('F',minmn,1,ZERO,ZERO,S,minmn)
         Rank = 0
         GOTO 100
      ENDIF
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      bnrm = SLANGE('M',M,Nrhs,B,Ldb,Work)
      ibscl = 0
      IF ( bnrm>ZERO .AND. bnrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL SLASCL('G',0,0,bnrm,smlnum,M,Nrhs,B,Ldb,Info)
         ibscl = 1
      ELSEIF ( bnrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL SLASCL('G',0,0,bnrm,bignum,M,Nrhs,B,Ldb,Info)
         ibscl = 2
      ENDIF
!
!     Overdetermined case
!
      IF ( M>=N ) THEN
!
!        Path 1 - overdetermined or exactly determined
!
         mm = M
         IF ( M>=mnthr ) THEN
!
!           Path 1a - overdetermined, with many more rows than columns
!
            mm = N
            itau = 1
            iwork = itau + N
!
!           Compute A=Q*R
!           (Workspace: need 2*N, prefer N+N*NB)
!
            CALL SGEQRF(M,N,A,Lda,Work(itau),Work(iwork),Lwork-iwork+1, &
     &                  Info)
!
!           Multiply B by transpose(Q)
!           (Workspace: need N+NRHS, prefer N+NRHS*NB)
!
            CALL SORMQR('L','T',M,Nrhs,N,A,Lda,Work(itau),B,Ldb,        &
     &                  Work(iwork),Lwork-iwork+1,Info)
!
!           Zero out below R
!
            IF ( N>1 ) CALL SLASET('L',N-1,N-1,ZERO,ZERO,A(2,1),Lda)
         ENDIF
!
         ie = 1
         itauq = ie + N
         itaup = itauq + N
         iwork = itaup + N
!
!        Bidiagonalize R in A
!        (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
!
         CALL SGEBRD(mm,N,A,Lda,S,Work(ie),Work(itauq),Work(itaup),     &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors of R
!        (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
!
         CALL SORMBR('Q','L','T',mm,Nrhs,N,A,Lda,Work(itauq),B,Ldb,     &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Generate right bidiagonalizing vectors of R in A
!        (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
!
         CALL SORGBR('P',N,N,N,A,Lda,Work(itaup),Work(iwork),           &
     &               Lwork-iwork+1,Info)
         iwork = ie + N
!
!        Perform bidiagonal QR iteration
!          multiply B by transpose of left singular vectors
!          compute right singular vectors in A
!        (Workspace: need BDSPAC)
!
         CALL SBDSQR('U',N,N,0,Nrhs,S,Work(ie),A,Lda,dum,1,B,Ldb,       &
     &               Work(iwork),Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by reciprocals of singular values
!
         thr = MAX(Rcond*S(1),sfmin)
         IF ( Rcond<ZERO ) thr = MAX(eps*S(1),sfmin)
         Rank = 0
         DO i = 1 , N
            IF ( S(i)>thr ) THEN
               CALL SRSCL(Nrhs,S(i),B(i,1),Ldb)
               Rank = Rank + 1
            ELSE
               CALL SLASET('F',1,Nrhs,ZERO,ZERO,B(i,1),Ldb)
            ENDIF
         ENDDO
!
!        Multiply B by right singular vectors
!        (Workspace: need N, prefer N*NRHS)
!
         IF ( Lwork>=Ldb*Nrhs .AND. Nrhs>1 ) THEN
            CALL SGEMM('T','N',N,Nrhs,N,ONE,A,Lda,B,Ldb,ZERO,Work,Ldb)
            CALL SLACPY('G',N,Nrhs,Work,Ldb,B,Ldb)
         ELSEIF ( Nrhs>1 ) THEN
            chunk = Lwork/N
            DO i = 1 , Nrhs , chunk
               bl = MIN(Nrhs-i+1,chunk)
               CALL SGEMM('T','N',N,bl,N,ONE,A,Lda,B(1,i),Ldb,ZERO,Work,&
     &                    N)
               CALL SLACPY('G',N,bl,Work,N,B(1,i),Ldb)
            ENDDO
         ELSE
            CALL SGEMV('T',N,N,ONE,A,Lda,B,1,ZERO,Work,1)
            CALL SCOPY(N,Work,1,B,1)
         ENDIF
!
      ELSEIF ( N>=mnthr .AND. Lwork>=4*M+M*M+MAX(M,2*M-4,Nrhs,N-3*M) )  &
     &         THEN
!
!        Path 2a - underdetermined, with many more columns than rows
!        and sufficient workspace for an efficient algorithm
!
         ldwork = M
         IF ( Lwork>=MAX(4*M+M*Lda+MAX(M,2*M-4,Nrhs,N-3*M),             &
     &        M*Lda+M+M*Nrhs) ) ldwork = Lda
         itau = 1
         iwork = M + 1
!
!        Compute A=L*Q
!        (Workspace: need 2*M, prefer M+M*NB)
!
         CALL SGELQF(M,N,A,Lda,Work(itau),Work(iwork),Lwork-iwork+1,    &
     &               Info)
         il = iwork
!
!        Copy L to WORK(IL), zeroing out above it
!
         CALL SLACPY('L',M,M,A,Lda,Work(il),ldwork)
         CALL SLASET('U',M-1,M-1,ZERO,ZERO,Work(il+ldwork),ldwork)
         ie = il + ldwork*M
         itauq = ie + M
         itaup = itauq + M
         iwork = itaup + M
!
!        Bidiagonalize L in WORK(IL)
!        (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
!
         CALL SGEBRD(M,M,Work(il),ldwork,S,Work(ie),Work(itauq),        &
     &               Work(itaup),Work(iwork),Lwork-iwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors of L
!        (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
!
         CALL SORMBR('Q','L','T',M,Nrhs,M,Work(il),ldwork,Work(itauq),B,&
     &               Ldb,Work(iwork),Lwork-iwork+1,Info)
!
!        Generate right bidiagonalizing vectors of R in WORK(IL)
!        (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB)
!
         CALL SORGBR('P',M,M,M,Work(il),ldwork,Work(itaup),Work(iwork), &
     &               Lwork-iwork+1,Info)
         iwork = ie + M
!
!        Perform bidiagonal QR iteration,
!           computing right singular vectors of L in WORK(IL) and
!           multiplying B by transpose of left singular vectors
!        (Workspace: need M*M+M+BDSPAC)
!
         CALL SBDSQR('U',M,M,0,Nrhs,S,Work(ie),Work(il),ldwork,A,Lda,B, &
     &               Ldb,Work(iwork),Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by reciprocals of singular values
!
         thr = MAX(Rcond*S(1),sfmin)
         IF ( Rcond<ZERO ) thr = MAX(eps*S(1),sfmin)
         Rank = 0
         DO i = 1 , M
            IF ( S(i)>thr ) THEN
               CALL SRSCL(Nrhs,S(i),B(i,1),Ldb)
               Rank = Rank + 1
            ELSE
               CALL SLASET('F',1,Nrhs,ZERO,ZERO,B(i,1),Ldb)
            ENDIF
         ENDDO
         iwork = ie
!
!        Multiply B by right singular vectors of L in WORK(IL)
!        (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS)
!
         IF ( Lwork>=Ldb*Nrhs+iwork-1 .AND. Nrhs>1 ) THEN
            CALL SGEMM('T','N',M,Nrhs,M,ONE,Work(il),ldwork,B,Ldb,ZERO, &
     &                 Work(iwork),Ldb)
            CALL SLACPY('G',M,Nrhs,Work(iwork),Ldb,B,Ldb)
         ELSEIF ( Nrhs>1 ) THEN
            chunk = (Lwork-iwork+1)/M
            DO i = 1 , Nrhs , chunk
               bl = MIN(Nrhs-i+1,chunk)
               CALL SGEMM('T','N',M,bl,M,ONE,Work(il),ldwork,B(1,i),Ldb,&
     &                    ZERO,Work(iwork),M)
               CALL SLACPY('G',M,bl,Work(iwork),M,B(1,i),Ldb)
            ENDDO
         ELSE
            CALL SGEMV('T',M,M,ONE,Work(il),ldwork,B(1,1),1,ZERO,       &
     &                 Work(iwork),1)
            CALL SCOPY(M,Work(iwork),1,B(1,1),1)
         ENDIF
!
!        Zero out below first M rows of B
!
         CALL SLASET('F',N-M,Nrhs,ZERO,ZERO,B(M+1,1),Ldb)
         iwork = itau + M
!
!        Multiply transpose(Q) by B
!        (Workspace: need M+NRHS, prefer M+NRHS*NB)
!
         CALL SORMLQ('L','T',N,Nrhs,M,A,Lda,Work(itau),B,Ldb,Work(iwork)&
     &               ,Lwork-iwork+1,Info)
!
      ELSE
!
!        Path 2 - remaining underdetermined cases
!
         ie = 1
         itauq = ie + M
         itaup = itauq + M
         iwork = itaup + M
!
!        Bidiagonalize A
!        (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
!
         CALL SGEBRD(M,N,A,Lda,S,Work(ie),Work(itauq),Work(itaup),      &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors
!        (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
!
         CALL SORMBR('Q','L','T',M,Nrhs,N,A,Lda,Work(itauq),B,Ldb,      &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Generate right bidiagonalizing vectors in A
!        (Workspace: need 4*M, prefer 3*M+M*NB)
!
         CALL SORGBR('P',M,N,M,A,Lda,Work(itaup),Work(iwork),           &
     &               Lwork-iwork+1,Info)
         iwork = ie + M
!
!        Perform bidiagonal QR iteration,
!           computing right singular vectors of A in A and
!           multiplying B by transpose of left singular vectors
!        (Workspace: need BDSPAC)
!
         CALL SBDSQR('L',M,N,0,Nrhs,S,Work(ie),A,Lda,dum,1,B,Ldb,       &
     &               Work(iwork),Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by reciprocals of singular values
!
         thr = MAX(Rcond*S(1),sfmin)
         IF ( Rcond<ZERO ) thr = MAX(eps*S(1),sfmin)
         Rank = 0
         DO i = 1 , M
            IF ( S(i)>thr ) THEN
               CALL SRSCL(Nrhs,S(i),B(i,1),Ldb)
               Rank = Rank + 1
            ELSE
               CALL SLASET('F',1,Nrhs,ZERO,ZERO,B(i,1),Ldb)
            ENDIF
         ENDDO
!
!        Multiply B by right singular vectors of A
!        (Workspace: need N, prefer N*NRHS)
!
         IF ( Lwork>=Ldb*Nrhs .AND. Nrhs>1 ) THEN
            CALL SGEMM('T','N',N,Nrhs,M,ONE,A,Lda,B,Ldb,ZERO,Work,Ldb)
            CALL SLACPY('F',N,Nrhs,Work,Ldb,B,Ldb)
         ELSEIF ( Nrhs>1 ) THEN
            chunk = Lwork/N
            DO i = 1 , Nrhs , chunk
               bl = MIN(Nrhs-i+1,chunk)
               CALL SGEMM('T','N',N,bl,M,ONE,A,Lda,B(1,i),Ldb,ZERO,Work,&
     &                    N)
               CALL SLACPY('F',N,bl,Work,N,B(1,i),Ldb)
            ENDDO
         ELSE
            CALL SGEMV('T',M,N,ONE,A,Lda,B,1,ZERO,Work,1)
            CALL SCOPY(N,Work,1,B,1)
         ENDIF
      ENDIF
!
!     Undo scaling
!
      IF ( iascl==1 ) THEN
         CALL SLASCL('G',0,0,anrm,smlnum,N,Nrhs,B,Ldb,Info)
         CALL SLASCL('G',0,0,smlnum,anrm,minmn,1,S,minmn,Info)
      ELSEIF ( iascl==2 ) THEN
         CALL SLASCL('G',0,0,anrm,bignum,N,Nrhs,B,Ldb,Info)
         CALL SLASCL('G',0,0,bignum,anrm,minmn,1,S,minmn,Info)
      ENDIF
      IF ( ibscl==1 ) THEN
         CALL SLASCL('G',0,0,smlnum,bnrm,N,Nrhs,B,Ldb,Info)
      ELSEIF ( ibscl==2 ) THEN
         CALL SLASCL('G',0,0,bignum,bnrm,N,Nrhs,B,Ldb,Info)
      ENDIF
!
 100  Work(1) = maxwrk
!
!     End of SGELSS
!
      END SUBROUTINE SGELSS


C FILE: SCALAR.F
      SUBROUTINE FOO(A,B)
      REAL*8 A, B
Cf2py intent(in) a
Cf2py intent(inout) b
      PRINT*, "    A=",A," B=",B
      PRINT*, "INCREMENT A AND B"
      A = A + 1D0
      B = B + 1D0
      PRINT*, "NEW A=",A," B=",B
      END
C END OF FILE SCALAR.F


MODULE FUN_xyVECTOR
!!#### PURPOSE
!! Determine a vector <V>, from:
!!  @ two points <PP> or
!!  @ two points in a list <P2>.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

INTERFACE xyVECTOR_PP
 MODULE PROCEDURE xyVECTOR_PP_Rsp
 MODULE PROCEDURE xyVECTOR_PP_Rdp
END INTERFACE

INTERFACE xyVECTOR_P2
 MODULE PROCEDURE xyVECTOR_P2_Rsp
 MODULE PROCEDURE xyVECTOR_P2_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyVECTOR_P2
PUBLIC :: xyVECTOR_PP

CONTAINS

PURE FUNCTION xyVECTOR_PP_Rsp( P_a , P_b ) RESULT( xyV )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyVECTOR_PP.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyVECTOR_PP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyVECTOR_PP_Rdp( P_a , P_b ) RESULT( xyV )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyVECTOR_PP.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyVECTOR_PP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyVECTOR_P2_Rsp( P2 ) RESULT( xyV )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyVECTOR_P2.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyVECTOR_P2.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyVECTOR_P2_Rdp( P2 ) RESULT( xyV )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyVECTOR_P2.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyVECTOR_P2.f90.bdy"
!!--end--
END FUNCTION

END MODULE


submodule (parent) parent

contains

module procedure pi2tau
  pi2tau = 2*pi
end procedure pi2tau

end submodule parent


      subroutine levmap(c,nc,f0,sp,sm,np)
      dimension c(1)
      do 1 i=1,np
    1 c(i)=f0+sp*i
      ns=np+1
      do 2 k=ns,nc
    2 c(k)=f0-sm*(k-ns)
      return
      end