! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!                       Fluides geophysiques  v14         (11.04.96)
!                       -------------------------
!   . Red Black
!   . Calcul des vitesses
!   . Sauvegarde tous les X pas de temps
! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
! ------------------------------------------------------------------

module GEOPHY

    integer, parameter :: DP  = KIND(1.0D0)            !< double precision

    real(DP), parameter :: U = 1D-1
    real(DP), parameter :: g = 1D-2
    real(DP), parameter :: f = 1D-4

    integer, parameter :: pasx  = 31
    integer, parameter :: pasy  = 31

end module GEOPHY

! ------------------------------------------------------------------
subroutine init_xy(x, y, dx, dy, Ly)
    use GEOPHY
    implicit none

    real(DP) :: x(pasx+1), y(pasx+1)   !! [RB] taille exacte necessaire sinon ca plante au runtime
    real(DP) :: dx, dy, Ly

    integer :: i, j

    do i = 2, pasx+1
        print *,"i=",i
        x(i) = (i-2)*dx
    end do

    x(1) = x(pasx)
    x(2) = x(pasx+1)

    do j = 1, pasy
        y(j) = -Ly + (j-1)*dy
    end do
end subroutine init_xy

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

program NIHOUL

    use GEOPHY
    implicit none

    ! Declarations

    integer :: Nmax
    logical :: fin
    integer :: i, j, n, compt, startj, start, nsave, fsave, saveu
    real(DP) :: pi, h0, L, T, Lx, Ly, Bu, Ro, Et, w
    real(DP) :: dx, dy, dt, tol, kmoy

    real(DP), allocatable :: x(:), y(:)

    real(DP) :: temp1, temp2, temp3, temp4, temp5, erreur
    real(DP) :: d1, d2, d3
    real(DP) :: aeta1, aeta2

    real(DP), allocatable :: eta(:,:), b(:,:), q(:,:)
    real(DP), allocatable :: jacob(:,:), deta(:,:)
    real(DP), allocatable :: leta(:,:), v1(:,:), v2(:,:)

    ! Donnees

    print *, 'L (5000)?'
    read(*,*) L
    print *, 'Lx/L (5)?'
    read(*,*) Lx

    pi    = acos(-1.0D0)
    h0    = 1D2
    T     = L/U
    Ly    = min((3.0D0/4.0D0 + g*h0/(2.0D0*f*U*L)), 4.0D0)
    Bu    = g*h0/(f*L)**2
    Ro    = U/(f*L)
    Et    = 1.0D0/(f*T)
    dx    = 2.0D0*Lx/(pasx-1)
    dt    = dx*dx/2.0D0
    dy    = 2.0D0*Ly/(pasy-1)
    kmoy  = 0.0D0
    nsave  = 1

    print *, 'Ly/L =', Ly, '(', (3.0D0/4.0D0 + g*h0/(2.0D0*f*U*L)), ')'
    print *, 'Bu   =', Bu, ' ; Ro   =', Ro
    print *, 'dx   =', dx, ' ; dy   =', dy
    print *, 'pasx =', pasx,' ; pasy =', pasy
    print *, 'T    =', T, ' ; dH   =', f*L*U/g
    print *, 'dt (max) =', dt, 'sec.'
    print *, 'Le canal fait ', 2.0D0*Lx*L, 'm de long'
    print *, '           et ', 2.0D0*Ly*L, 'm de large'
    print *, 'tol (1D-6)?'
    read(*,*) tol
    print *, 'w (1.825)?'
    read(*,*) w
    print *, 'dt (2D-2)?'
    read(*,*) dt
    print *, 'Nmax (100)?'
    read(*,*) Nmax
    print *, 'fsave (Nmax)?'
    read(*,*) fsave
    print *, 'save U (1 = oui)?'
    read(*,*) saveu

    if(fsave > Nmax) then
        fsave = Nmax
    endif

    print *
    print *, 'Un pas de temps =', T*dt, 'sec.'

    ! dynamic arrays
    allocate( x(pasx+1) )
    allocate( y(pasx) )

    allocate( eta(pasx+1, pasy) )
    allocate( b(pasx+1, pasy) )
    allocate( q(pasx+1, pasy) )

    allocate( jacob(pasx+1, pasy) )
    allocate( deta(pasx+1, 2) )

    allocate( leta(pasx+1, pasy) )
    allocate( v1(pasx+1, pasy) )
    allocate( v2(pasx+1, pasy) )

    ! Calcul du profil initial
    call init_xy(x, y, dx, dy, Ly)

    temp1 = g*h0/f/L/U
    do i = 1, pasx+1
        temp2 = 0.01*sin(pi*x(i)/Lx)
        do j = 1, pasy
            if (abs(y(j)) < 1.0D0) then
                eta(i,j) = temp1*temp2 - 0.5*y(j)**2 * (1 + temp2)
            else
                eta(i,j) = temp1*temp2 + (0.5-abs(y(j))) * (1 + temp2)
            endif
        end do
    end do

    ! Ouverture du fichier RES.M et sauvegarde du profil initial

    open (UNIT = 1, FILE = 'res.m', STATUS ='unknown')

    do i = 2, pasx+1
        do j = 1, pasy
            write(1,*) 'a(', (nsave-1)*pasx+i-1, ',', j, ')=', eta(i,j), ';'
        end do
    end do

    ! Boucle principale (progression dans le temps)

    do n = 1, Nmax
        print *, 'Pas de temps n :', n

        ! Calcul de Beta (b) et du laplacien (q)

        ! Interieur

        do i = 2, pasx
            do j = 2, pasy-1
                temp1 = (eta(i-1,j) + eta(i+1,j) - 2*eta(i,j))/(dx*dx)      &
                      + (eta(i,j-1) + eta(i,j+1) - 2*eta(i,j))/(dy*dy)
                temp2 = ((eta(i+1,j) - eta(i-1,j))/(2*dx))**2               &
                      + ((eta(i,j+1) - eta(i,j-1))/(2*dy))**2

                b(i,j) = (Bu+Ro*eta(i,j))*temp1 + Ro/2*temp2
                q(i,j) = temp1
            end do
        end do

        ! Bords y

        do i = 2, pasx
            j = 1
            temp1 = (eta(i-1,j) + eta(i+1,j) - 2*eta(i,j))   /(dx*dx)       &
                  + (eta(i,j)   + eta(i,j+2) - 2*eta(i,j+1)) /(dy*dy)
            temp2 = ((  eta(i+1,j) - eta(i-1,j)) / (2*dx))**2               &
                  + ((4*eta(i,j+1) - eta(i,j+2) - 3*eta(i,j)) / (2*dy))**2

            b(i,j) = (Bu+Ro*eta(i,j))*temp1 + Ro/2*temp2
            q(i,j) = temp1

            j = pasy
            temp1 = (eta(i-1,j) + eta(i+1,j) - 2*eta(i,j))   /(dx*dx)       &
                  + (eta(i,j)   + eta(i,j-2) - 2*eta(i,j-1)) /(dy*dy)
            temp2 = ((eta(i+1,j) - eta(i-1,j))/(2*dx))**2                   &
                  + ((-4*eta(i,j-1) + eta(i,j-2) + 3*eta(i,j)) / (2*dy))**2

            b(i,j) = (Bu+Ro*eta(i,j))*temp1 + Ro/2*temp2
            q(i,j) = temp1
        end do

        ! Ajout des lignes i = 1 et i = pasx+1

        do j = 1, pasy
            b(1,j) = b(pasx,j)
            b(pasx+1,j) = b(2,j)

            q(1,j) = q(pasx,j)
            q(pasx+1,j) = q(2,j)
        end do

        ! Calcul du Jacobien

        do i = 2, pasx
            do j = 2, pasy-1
                temp1 = ((eta(i+1,j) - eta(i-1,j))*(b(i,j+1) - b(i,j-1)) -         &
                (eta(i,j+1) - eta(i,j-1))*(b(i+1,j) - b(i-1,j)))/4/dx/dy
                temp2 = (eta(i+1,j)*(b(i+1,j+1) - b(i+1,j-1)) - eta(i-1,j)*        &
                    (b(i-1,j+1) - b(i-1,j-1)) - eta(i,j+1)*(b(i+1,j+1)             &
                    -b(i-1,j+1)) + eta(i,j-1)*(b(i+1,j-1) - b(i-1,j-1)))           &
                    /4/dx/dy
                temp3 = (b(i,j+1)*(eta(i+1,j+1) - eta(i-1,j+1)) - b(i,j-1)*        &
                    (eta(i+1,j-1) - eta(i-1,j-1)) - b(i+1,j)*(eta(i+1,j+1) -       &
                    eta(i+1,j-1)) + b(i-1,j)*(eta(i-1,j+1) - eta(i-1,j-1)))        &
                    /4/dx/dy
                jacob(i,j) = (temp1 + temp2 + temp3)/3.0D0
            end do
        end do

        ! Ajout des lignes i = 1 et i = pasx+1

        do j = 1,pasy
            jacob(1,j) = jacob(pasx,j)
            jacob(pasx+1,j) = jacob(2,j)
        end do

        ! Calcul de q

        do i = 1, pasx+1
            do j = 1, pasy
                q(i,j) = Bu*q(i,j) - eta(i,j)
                q(i,j) = q(i,j) - Ro/Et*dt*jacob(i,j)
            end do
        end do

        ! Calcul de d(eta)/dy pour les bords

        do i = 1, pasx+1
            deta(i,1) = (4*eta(i,2) - eta(i,3) - 3*eta(i,1)) / (2*dy)
            deta(i,2) = (-4*eta(i,pasy-1) + eta(i,pasy-2) + 3*eta(i,pasy)) / (2*dy)
        end do

        ! Red Black

        fin = .false.
        compt = 0

        do while (fin == 0)
            compt = compt + 1
            fin = .true.

            ! Deux passages alternes

            do startj = 1, 2
                start = startj

                ! Red Black

                do i = 2, pasx
                    do j = start+1, pasy-1, 2
                        temp1 = -2/dx**2 - 2/dy**2 - 1/Bu
                        temp1 = (q(i,j)/Bu - (eta(i+1,j) + eta(i-1,j))/dx**2   &
                                           - (eta(i,j+1) + eta(i,j-1))/dy**2  ) / temp1
                        temp1 = eta(i,j) + w*(temp1-eta(i,j))
                        if(abs(eta(i,j)) > 0.0D0) then
                            erreur = abs( (temp1-eta(i,j))/eta(i,j) )
                            if(erreur > tol) then
                                fin = .false.
                            endif
                        endif
                        eta(i,j) = temp1
                    end do

                    if(start == 2) then
                        start = 1
                    else
                        start = 2
                    endif
                end do

                do j = 1, pasy
                    eta(1,j) = eta(pasx,j)
                    eta(pasx+1,j) = eta(2,j)
                end do

            end do

            ! Conditions aux limites

            aeta1 = eta(1,1)
            aeta2 = eta(1,pasy)

            do i = 2, pasx
                j = 1
                temp1 = (eta(i+1,j) - aeta1) / (2*dx)
                temp2 = (eta(i,j+2) - 2*eta(i,j+1)) / dy**2
                d1 = (eta(i+1,j) - aeta1) / (2*dx)
                d2 = (eta(i+1,j+1) - eta(i-1,j+1))/(2*dx)
                d3 = (eta(i+1,j+2) - eta(i-1,j+2))/(2*dx)
                temp3 = (4*d2 - d3 - 3*d1)/(2*dy)
                temp4 = -3*Et/(2*dy*dt) + 3*Ro*temp3/(2*dy) + Ro*temp1/dy**2
                temp5 = (temp1  -Et*((4*eta(i,j+1) - eta(i,j+2)) / (2*dy*dt)    &
                        -deta(i,1)/dt) - Ro*temp1*temp2 + Ro*temp3*             &
                        (4*eta(i,j+1) - eta(i,j+2))/(2*dy) ) / temp4
                temp5 = eta(i,j) + w*(temp5-eta(i,j))
                if(abs(eta(i,j)) > 0.0D0) then
                    erreur = abs( (temp5-eta(i,j))/eta(i,j) )
                    if(erreur > tol) then
                        fin = .false.
                    endif
                endif
                aeta1 = eta(i,j)
                eta(i,j) = temp5

                j = pasy
                temp1 = (eta(i+1,j) - aeta2) / (2*dx)
                temp2 = (eta(i,j-2) - 2*eta(i,j-1)) / dy**2
                d1 = (eta(i+1,j) - aeta2) / (2*dx)
                d2 = (eta(i+1,j-1) - eta(i-1,j-1)) / (2*dx)
                d3 = (eta(i+1,j-2) - eta(i-1,j-2)) / (2*dx)
                temp3 = (-4*d2 + d3 + 3*d1) / (2*dy)
                temp4 = 3*Et/(2*dy*dt) - 3*Ro*temp3/(2*dy) + Ro*temp1/dy**2
                temp5 = (temp1 - Et*((-4*eta(i,j-1) + eta(i,j-2)) / (2*dy*dt)    &
                        - deta(i,2)/dt) - Ro*temp1*temp2 + Ro*temp3*             &
                        (-4*eta(i,j-1) + eta(i,j-2))/(2*dy) ) / temp4
                temp5 = eta(i,j) + w*(temp5-eta(i,j))
                if (abs(eta(i,j)) > 0.0D0) then
                    erreur = abs( (temp5-eta(i,j)) / eta(i,j) )
                    if (erreur > tol) then
                        fin = .false.
                    endif
                endif
                aeta2 = eta(i,j)
                eta(i,j) = temp5
            end do

            ! Periodicite
            do j = 1, pasy
                eta(1,j) = eta(pasx,j)
                eta(pasx+1,j) = eta(2,j)
            end do

        end do

        print *, '    no it. =', compt
        kmoy = kmoy + compt

        ! Copie de eta (futur calcul des vitesses)

        if(n == nsave*fsave-1) then
            do i = 1, pasx+1
                do j = 1, pasy
                    leta(i,j) = eta(i,j)
                end do
            end do
        endif

        ! Calcul des vitesses

        if(saveu == 1) then
            if(n == nsave*fsave) then
                do i = 2, pasx
                    do j = 2, pasy-1

                        ! u (interieur)

                        temp1 = (eta(i,j+1) - eta(i,j-1))/2/dy
                        temp2 = (eta(i+1,j) - eta(i-1,j))/2/dx
                        temp3 = (leta(i+1,j) - leta(i-1,j))/2/dx
                        temp4 = (eta(i+1,j+1) - eta(i-1,j+1) - eta(i+1,j-1)     &
                                + eta(i-1,j-1)) / (4*dy*dy)
                        temp5 = (eta(i+1,j) + eta(i-1,j) - 2*eta(i,j)) / (dx*dx)
                        v1(i,j) = -temp1 - Et*(temp2 - temp3)/dt           &
                                - Ro*(temp2*temp4 - temp1*temp5)

                        ! v (interieur)

                        temp3 = (leta(i,j+1) - leta(i,j-1))/2/dy
                        temp5 = (eta(i,j+1) + eta(i,j-1) - 2*eta(i,j))/(dy*dy)
                        v2(i,j) = temp2 - Et*(temp1 - temp3)/dt            &
                                - Ro*(temp2*temp5 - temp1*temp4)
                    end do

                    ! u (j=1)
                    j = 1
                    temp1 = (4*eta(i,j+1)  -eta(i,j+2) - 3*eta(i,j))/2/dy
                    temp2 = (eta(i+1,j) - eta(i-1,j))/2/dx
                    temp3 = (leta(i+1,j) - leta(i-1,j))/2/dx
                    d1 = temp2
                    d2 = (eta(i+1,j+1) - eta(i-1,j+1))/(2*dx)
                    d3 = (eta(i+1,j+2) - eta(i-1,j+2))/(2*dx)
                    temp4 = (4*d2 - d3 - 3*d1)/(2*dy)
                    temp5 = (eta(i+1,j) + eta(i-1,j) - 2*eta(i,j))/(dx*dx)
                    v1(i,j) = -temp1 - Et*(temp2-temp3)/dt            &
                              -Ro*(temp2*temp4 - temp1*temp5)

                    ! v (j=1)
                    temp3 = (4*leta(i,j+1) - leta(i,j+2) - 3*leta(i,j))/2/dy
                    temp5 = (eta(i,j+2) + eta(i,j) - 2*eta(i,j+1))/(dy*dy)
                    v2(i,j) = temp2-Et*(temp1 - temp3)/dt             &
                             - Ro*(temp2*temp5 - temp1*temp4)

                    ! u (j=pasy)
                    j = pasy
                    temp1 = (-4*eta(i,j-1) + eta(i,j-2) + 3*eta(i,j))/2/dy
                    temp2 = (eta(i+1,j) - eta(i-1,j))/2/dx
                    temp3 = (leta(i+1,j) - leta(i-1,j))/2/dx
                    d1 = temp2
                    d2 = (eta(i+1,j-1) - eta(i-1,j-1))/(2*dx)
                    d3 = (eta(i+1,j-2) - eta(i-1,j-2))/(2*dx)
                    temp4 = (-4*d2 + d3 + 3*d1)/(2*dy)
                    temp5 = (eta(i+1,j) + eta(i-1,j) - 2*eta(i,j))/(dx*dx)
                    v1(i,j) = -temp1 - Et*(temp2 - temp3)/dt            &
                               - Ro*(temp2*temp4 - temp1*temp5)

                    ! v (j=pasy)
                    temp3 = (-4*leta(i,j-1) + leta(i,j-2) + 3*leta(i,j))/2/dy
                    temp5 = (eta(i,j-2) + eta(i,j) - 2*eta(i,j-1))/(dy*dy)
                    v2(i,j) = temp2 - Et*(temp1 - temp3)/dt         &
                             - Ro*(temp2*temp5 - temp1*temp4)
                end do

                ! periodicite

                do j = 1, pasy
                    v1(pasx+1,j) = v1(2,j)
                    v2(pasx+1,j) = v2(2,j)
                end do
            endif
        endif

        ! Resultats (save -> Matlab)

        if(n == nsave*fsave) then
            do i = 2, pasx+1
                do j = 1, pasy
                    write(1,*) 'a(', nsave*pasx+i-1, ',', j, ')=', eta(i,j), ';'
                    if(saveu == 1) then
                        write(1,*) 'u(', nsave*pasx+i-1, ',', j, ')=', v1(i,j), ';'
                        write(1,*) 'v(', nsave*pasx+i-1, ',', j, ')=', v2(i,j), ';'
                    endif
                end do
            end do
            nsave = nsave + 1
        endif

    end do

    close (UNIT=1)

    !  Commentaires finaux
    print "('Calcul effectue sur :', F10.1,'s')", Nmax*T*dt
    print "('Nb iterations (moy) :', F5.1)", kmoy/Nmax
    print "('Resultats dans RES.M')"

    ! free memory
    deallocate( x )
    deallocate( y )

    deallocate( eta )
    deallocate( b )
    deallocate( q )

    deallocate( jacob )
    deallocate( deta )

    deallocate( leta )
    deallocate( v1 )
    deallocate( v2 )

end program NIHOUL


! test_genalg.f90 --
!     Test for the genetic_algorithms module
!
!     Note:
!     The first step (find the minimum for f) does not work as
!     expected, the algorithm gets stuck on a suboptimum (at least
!     with one random sequence). Probably it is necessary to tune
!     the parameters to get a better performance
!     (Intended minimum: (-1.1, 0, 0, ... )
!
!     The second step does find the absolute minimum, but this is
!     a much simpler function.
!
module minimize_function
    use select_precision
contains

real(wp) function f( coords )
    real(wp), dimension(:), intent(in) :: coords

    real(wp)                           :: r

    r = sqrt( sum(coords**2) )
    f = (r**2 - 1.0) ** 2 - coords(1)

end function f

real(wp) function g( coords )
    real(wp), dimension(:), intent(in) :: coords

    g = sum(coords**2) - 1.0

end function g

end module minimize_function

program test_genalg
    use minimize_function
    use genetic_algorithms
    use select_precision

    implicit none

    type(GA_PARAMETERS)            :: params
    integer, parameter             :: ncoords = 10
    real(wp), dimension(2,ncoords) :: range
    real(wp), dimension(ncoords)   :: vector
    real(wp)                       :: value
    integer                        :: i

    !
    ! Set the parameters for the procedure
    !
    call set_parameters( params, update = .false., verbose = .true., &
             number_iterations = 1000 )

    !
    ! We can use the default procedure, so let's do that
    ! (Otherwise we would use the reversed communication example)
    !
    range(1,:) = -5.0
    range(2,:) =  5.0

    call find_minimum( params, range, vector, f, value )

    write(*,*) 'Minimum:         ',value
    write(*,*) 'Solution vector: ',vector
    write(*,*) 'f(vector):       ',f(vector)

    call find_minimum( params, range, vector, g, value )

    write(*,*) 'Minimum:         ',value
    write(*,*) 'Solution vector: ',vector
    write(*,*) 'g(vector):       ',g(vector)

end program


module mod_coswsamples
#include "Config.hpp"
 !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_coswsamples'
 !
 !          Purpose:
 !                   Mathematical representation and computation
 !                   of power weather sample of cosine radar signal.
 !                   This module also contains subroutines which
 !                   perform computation of signal statistics.
 !          History:
 !                        Date: 20-10-2017
 !                        Time: 09:43 GMT+2
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:
 !                  Bernard Gingold
 !
 !          References:
 !
 !                      Doppler Radar and Weather Observations
 !                      Richard L. Dvorak, Dusan S. Zrnic
 !                      pages 67-72
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85

 ! Tab:5 col - Type and etc.. definitions
 ! Tab:10,11 col - Type , function and subroutine code blocks.
    implicit none
    private
    use module_kinds
    use module_logger,   only : log_startup, &
                                log_UsrMsg,  &
                                log_shutdown
    use ISO_FORTRAN_ENV, only : stderr=>ERROR_UNIT , &
                                stdout=>OUTPUT_UNIT
    use IFPORT, only : TRACEBACKQQ
    use mod_timer
    use mod_constants, only : LAM_PINF

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Version major
    integer(I32P), parameter :: MOD_COSWSAMPLES_MAJOR = 1

    ! Version minor
    integer(I32P), parameter :: MOD_COSWSAMPLES_MINOR = 0

    ! Version micro
    integer(I32P), parameter :: MOD_COSWSAMPLES_MICRO = 0

    ! Module full version
    integer(I32P), parameter :: MOD_COSWSAMPLES_FULLVER = 1000*MOD_COSWSAMPLES_MAJOR+100*MOD_COSWSAMPLES_MINOR+ &
                                                          10*MOD_COSWSAMPLES_MICRO

    ! Module creation date
    character(*),  parameter :: MOD_COSWSAMPLES_CREATE_DATE = "20-10-2017 10:37 +00200 (FRI 20 OCT 2017 GMT+2)"

    ! Module buiild date (should be set after successful compilation)
    character(*),  parameter :: MOD_COSWSAMPLES_BUILD_DATE = " "

    ! Module author info
    character(*),  parameter :: MOD_COSWSAMPLES_AUTHOR = "Programmer: Bernard Gingold e-mail: beniekg@gmail.com"

    ! Module short description
    character(*),  parameter :: MOD_COSWSAMPLES_DESCRIPT = "Weather radar signal power and statistics computation"

    !============================================50
    !   Type: CSWSample_t
    !============================================50

    type, public :: CSWSamples_t

        private

        ! Number of  (echoes)
        integer(I32P) :: m_nechoes

        ! Sample (echo) ID
        integer(I32P) :: m_sampID

        ! Complex arrays length
        ! Must be equal to m_nechoes
        integer(I32P) :: m_size

        ! Number of scatterers
        integer(I32P)     :: m_scatnum

        ! Time duration of sample
        real(R64P)  :: m_Ts

        ! Sample = Sigma Ai**2*Wi*exp**-j*4piri/gamma
        complex(R64P), allocatable, dimension(:) :: m_Vsamp

        ! Sample averaged over cycle of transmitted frequency
        complex(R64P), allocatable, dimension(:) :: m_Vsampavg

        logical(I32P) :: m_isbuilt

        contains

        !==========================================!
        !  Construction,copying and destruction.                                        !
        !==========================================!
        procedure, pass(this), public :: init

        procedure, pass(this), public :: copy

        procedure, pass(this), public :: destroy

        !==========================================!
        !   getters                                       !
        !==========================================!

        procedure, pass(this), public :: get_nechoes

        procedure, pass(this), public :: get_sampID

        procedure, pass(this), public :: get_size

        procedure, pass(this), public :: get_scatnum

        procedure, pass(this), public :: get_Ts

        procedure, pass(this), public :: get_Vsamp

        procedure, pass(this), public :: get_Vsampavg

        procedure, pass(this), public :: get_isbuilt

        !==========================================!
        !   Read/write procedures
        !==========================================!

        procedure, nopass, public :: read_samples

        procedure, nopass, public :: write_samples

        !==========================================
        !   Computational subroutines
        !==========================================

        procedure, pass(this), public :: compute_Vsamp

        procedure, pass(this), public :: compute_Vsampavg

    end type CSWSamples_t

        !==========================================!
        !   Module operators
        !==========================================!

        interface assignment (=)
            module procedure assign_samples
        end interface

        interface operator   (/=)
            module procedure samples_neq_samples
        end interface

        interface operator   (==)
            module procedure samples_eq_samples
        end interface

        interface operator   (>)
            module procedure samples_gt_samples
        end interface

        interface operator   (<)
            module procedure samples_lt_samples
        end interface

    contains

        !========================================!
        !    Implementation                      !
        !========================================!

    !=================================================!
    !  @subroutine: init
    !  Initialization of object state.
    !  Allocation and initialization to default values
    !  of complex arrays
    !  @Warning
    !            Upon detection of non-fatal error
    !            variable 'err' will be set to -1
    !            Upon detection of fatal error like
    !            failed memory allocation 'STOP'
    !            will be executed.
    !            Values of variable 'err'
    !   1) -1 -- Object built already
    !   2) -2 -- Invalid argument (any of them)
    !   3) -3 -- Floating-point arithmentic error
    !            (general error) (not in this scope)
    !   4) -4 -- Overflow
    !   5) -5 -- Underflow
    !   6) -6 -- Inexact
    !   7) -7 -- Denormal
    !   8) -8 -- Cancellation error (cadna)
    !=================================================!
    subroutine init(this,nechoes,sampID,size,scatnum, &
                    Ts,logging,filename,append,dbg,err)
          implicit none
          class(CSWSamples_t), intent(inout) :: this
          integer(I32P),      intent(in)    :: nechoes,sampID,  &
                                               size,scatnum
          real(R64P),         intent(in)    :: Ts
          logical(I32P),      intent(in)    :: logging
          character(len=*),   intent(in)    :: filename
          logical(I32P),      intent(in)    :: append,dbg
          integer(I32P),      intent(inout) :: err
          ! Locals
          character(len=40)  :: sdate,stime
          character(len=256) :: emsg
          integer(I32P)      :: i,aerr
          integer(BOOL)      :: ifail
          logical(I32P)      :: bfail
          ! Start of executable statements
          if(err < 0) err = 0
          if(this%m_isbuilt == .true.) then
              if(logging == .true.) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:227, In->mod_coswsamples/init: CSWSample_t already initialized!!")
                  call log_shutdown()
              else
                  call DATE_AND_TIME(date=sdate,time=stime)
                  write(stderr,*) "===========================NON-FATAL=========================="
                  write(sdterr,*) " ( mod_coswsamples/init:227, CSWSample_t already initialized!!)"
                  write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================NON-FATAL=========================="
              end if
              err = -1
              return
          end if
          if(nechoes < 1     .OR. &
             nechoes /= size .OR. &
             size < 1 .OR. Ts <= 0._R64P) then
              if(logging == .true.) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:244, In->mod_coswsamples/init: Invalid input to subroutine: init !!")
                  call log_shutdown()
              else
                  call DATE_AND_TIME(date=sdate,time=stime)
                  write(stderr,*) "===========================NON-FATAL=========================="
                  write(sdterr,*) " ( mod_coswsamples/init:244, Invalid input to subroutine: init !!)"
                  write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================NON-FATAL=========================="
              end if
              err = -2
              return
          end if
          ! Begin construction
          this%m_nechoes = nechoes
          this%m_sampID  = sampID
          this%m_size    = size
          this%m_scatnum = scatnum
          this%m_Ts      = Ts
          allocate(this%m_Vsamp(this%m_size),    &
                   this%m_Vsampavg(this%m_size), &
                   STAT=aerr, &
                   ERRMSG=emsg)
          if(aerr/=0) then
              if(logging == .true.) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:272, In->mod_coswsamples/init: Memory allocation failure!!")
                  call log_shutdown()
              else
                  write(stderr,*) "===========================NON-FATAL=========================="
                  write(sdterr,*) " ( mod_coswsamples/init:272, Memory allocation failure !!)"
                  write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================NON-FATAL=========================="
              end if
!DIR$         IF (SHOW_CALLSTACK .EQ. 1)
              call TRACEBACKQQ(STRING="FATAL-ERROR", USER_EXIT_CODE= -1)
!DIR$         ENDIF
              ERROR STOP "mod_coswsamples/init:272 -> [FATAL-ERROR]: Terminating execution!!"
          end if
          ! Arrays initialization
          do i = 1, this%m_size
             this%m_Vsamp(i)    = DCMPLX(LAM_PINF,LAM_PINF)
             this%m_Vsampavg(i) = DCMPLX(LAM_PINF,LAM_PINF)
          end do
          this%m_isbuilt = .true.
          if(dbg == .true.) then
              print*, "V sample:         ", this%m_Vsamp
              print*, "V sample average: ", this%m_Vsampavg
          end if
    end subroutine

    !=================================================!
    !  @subroutine: copy
    !  @Purpose:
    !            Copying of object state.
    !  @Warning
    !            Upon detection of non-fatal error
    !            variable 'err' will be set to -1
    !            Upon detection of fatal error like
    !            failed memory allocation 'STOP'
    !            will be executed.
    !            Values of variable 'err'
    !   1) -1 -- Object built already
    !   2) -2 -- Invalid argument (any of them)
    !   3) -3 -- Floating-point arithmentic error
    !            (general error) (not in this scope)
    !   4) -4 -- Overflow
    !   5) -5 -- Underflow
    !   6) -6 -- Inexact
    !   7) -7 -- Denormal
    !   8) -8 -- Cancellation error (cadna)
    !=================================================!
    subroutine copy(this,other,logging,filename,append,err)
          implicit none
          class(CSWSamples_t), intent(inout) :: this
          class(CSWSamples_t), intent(in)    :: other
          logical(I32P),      intent(in)     :: logging
          character(len=*),   intent(in)     :: filename
          logical(I32P),      intent(in)     :: append
          integer(I32P),      intent(inout)  :: err
          ! Locals
          character(len=40) :: sdate,stime
          ! Start of executable satements
          if(err < 0) err = 0
          if(this%m_isbuilt == .true.) then
              if(logging == .true.) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:336, In->mod_coswsamples/copy: CSWSample_t already initialized!!")
                  call log_shudown()
              else
                  call DATE_AND_TIME(date=sdate,time=stime)
                  write(stderr,*) "===========================NON-FATAL=========================="
                  write(sdterr,*) " ( mod_coswsamples/copy:336, CSWSample_t already initialized!!)"
                  write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================NON-FATAL=========================="
              end if
              err = -1
              return
          end if
          ! Begin construction
          this%m_nechoes  = other%m_nechoes
          this%m_sampID   = other%m_sampID
          this%m_size     = other%m_size
          this%m_scatnum  = other%m_scatnum
          this%m_Ts       = other%m_Ts
          this%m_Vsamp    = other%m_Vsamp
          this%m_Vsampavg = other%m_Vsampavg
          this%m_isbuilt = .true.
    end subroutine

    !=================================================!
    !  @subroutine: copy
    !  @Purpose:
    !            Destroys object state by allocatble
    !            arrays deallocation and setting
    !            member scalar variables to default values.
    !  @Warning
    !            Upon detection of non-fatal error
    !            variable 'err' will be set to -1
    !            Upon detection of fatal error like
    !            failed memory allocation 'STOP'
    !            will be executed.
    !            Values of variable 'err'
    !   1) -1 -- Object built already
    !   2) -2 -- Invalid argument (any of them)
    !   3) -3 -- Floating-point arithmentic error
    !            (general error) (not in this scope)
    !   4) -4 -- Overflow
    !   5) -5 -- Underflow
    !   6) -6 -- Inexact
    !   7) -7 -- Denormal
    !   8) -8 -- Cancellation error (cadna)
    !=================================================!
    subroutine destroy(this,logging,filename,append,err)
          implicit none
          class(CSWSamples_t), intent(inout) :: this
          logical(I32P),       intent(in)    :: logging
          character(len=*),    intent(in)    :: filename
          logical(I32P),       intent(in)    :: append
          integer(I32P),       intent(inout) :: err
          ! Locals
          character(len=40)  :: sdate,stime
          character(len=256) :: emsg
          integer(I32P)      :: derr,size
          ! Start of executable statements
          ! Sanity check on err parameter
          if(err < 0) err = 0
          if(this%m_isbuilt == .true.) then
              if(logging == .true.) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:402, In->mod_coswsamples/destroy: CSWSamples_t already destroyed!!")
                  call log_shutdown()
              else
                  call DATE_AND_TIME(date=sdate,time=stime)
                  write(stderr,*) "===========================NON-FATAL=========================="
                  write(sdterr,*) " ( mod_coswsamples/destroy:402, CSWSample_t already destroyed!!)"
                  write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================NON-FATAL=========================="
              end if
              err = -1
              return
          end if
          size = this%m_size
          this%m_nechoes = 0
          this%m_sampID  = 0
          this%m_size    = 0
          this%m_scatnum = 0
          this%m_Ts = LAM_PINF
          deallocate(this%m_Vsamp,    &
                     this%m_Vsampavg, &
                     STAT=derr,       &
                     ERRMSG=emsg)
          if(derr /= 0) then
              if(logging == .true.) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:429, In->mod_coswsamples/destroy: Failed to deallocate allocatble arrays!!")
                  call log_shutdown()
              else
                  write(stderr,*) "===========================NON-FATAL=========================="
                  write(sdterr,*) " ( mod_coswsamples/destroy:429, Failed to deallocate allocatble arrays !!)"
                  write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================NON-FATAL=========================="
              end if
!DIR$         IF (SHOW_CALLSTACK .EQ. 1)
              call TRACEBACKQQ(STRING="FATAL-ERROR", USER_EXIT_CODE= -1)
!DIR$         ENDIF
              ERROR STOP "mod_coswsamples/destroy:429 -> [FATAL-ERROR]: Terminating execution!!"
          end if
          this%m_isbuilt = .false.
    end subroutine

    !=================================================!
    !  @function: pure get_nechoes
    !  @Purpose:
    !            getter
    !=================================================!
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_nechoes
!DIR$ ENDIF

    pure function get_nechoes(this) result(nechoes)
          implicit none
          class(CSWSamples_t), intent(in) :: this
          ! Locals
          integer(I32P) :: nechoes
          ! Start of executable statements
          nechoes = this%m_nechoes
    end function

    !=================================================!
    !  @function: pure get_sampID
    !  @Purpose:
    !            getter
    !=================================================!
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_sampID
!DIR$ ENDIF

    pure function get_sampID(this) result(sampID)
          implicit none
          class(CSWSamples_t), intent(in) :: this
          ! Locals
          integer(I32P) :: sampID
          ! Start of executable statemetns
          sampID = this%m_sampID
    end function

    !=================================================!
    !  @function: pure get_size
    !  @Purpose:
    !            getter
    !=================================================!
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_size
!DIR$ ENDIF

    pure function get_size(this) result(size)
          implicit none
          class(CSWSamples_t), intent(in) :: this
          ! Locals
          integer(I32P) :: size
          ! Start of executable statements
          size = this%m_size
    end function

    !=================================================!
    !  @function: pure get_scatnum
    !  @Purpose:
    !            getter
    !=================================================!
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_scatnum
!DIR$ ENDIF

    pure function get_scatnum(this) result(scatnum)
          implicit none
          class(CSWSamples_t), intent(in) :: this
          ! Locals
          integer(I32P) :: scatnum
          ! Start of executable statements
          scatnum = this%m_scatnum
    end function

    !=================================================!
    !  @function: pure get_Ts
    !  @Purpose:
    !            getter
    !=================================================!
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_Ts
!DIR$ ENDIF

    pure function get_Ts(this) result(Ts)
          implicit none
          class(CSWSamples_t), intent(in) :: this
          ! Locals
          real(R64P) :: Ts
          ! Start of executable statements
          Ts = this%m_Ts
    end function

    !=================================================!
    !  @function: pure get_Vsamp
    !  @Purpose:
    !            getter
    !=================================================!
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_Vsamp
!DIR$ ENDIF

    pure function get_Vsamp(this) result(Vsamp)
          implicit none
          class(CSWSamples_t), intent(in) :: this
          ! Locals
          complex(R64P), allocatable, dimension(:) :: Vsamp
!DIR$     ATTRIBUTES ALIGN : 32 :: Vsamp
          ! Start of executable statements
          Vsamp = this%m_Vsamp
    end function

    !=================================================!
    !  @function: pure get_Vsampavg
    !  @Purpose:
    !            getter
    !=================================================!
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_Vsampavg
!DIR$ ENDIF

    pure function get_Vsampavg(this) result(Vsampavg)
          implicit none
          class(CSWSamples_t), intent(in) :: this
          ! Locals
          complex(R64P), allocatable, dimension(:) :: Vsampavg
!DIR$     ATTRIBUTES ALIGN : 32 :: Vsampavg
          ! Start of executable statements
          Vsampavg = this%m_Vsampavg
    end function

    !=================================================!
    !  @subroutine: read_samples
    !  @Purpose:
    !            read/write
    !=================================================!
    subroutine read_samples(this,form,unit,ioerr)
          implicit none
          class(CSWSamples_t), intent(in) :: this
          character(len=*),    intent(in) :: form
          integer(I32P),       intent(in) :: unit
          integer(I32P),       intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              READ(unit,*,iostat=ioerr) this
          case default
              READ(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine

    !=================================================!
    !  @subroutine: write_samples
    !  @Purpose:
    !            read/write
    !=================================================!
    subroutine write_samples(this,form,unit,ioerr)
          implicit none
          class(CSWSamples_t), intent(in) :: this
          character(len=*),    intent(in) :: form
          integer(I32P),       intent(in) :: unit
          integer(I32P),       intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              WRITE(unit,*,iostat=ioerr) this
          case default
              WRITE(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine

    !=================================================!
    !  @subroutine: compute_Vsamp
    !  @Purpose:
    !            Performs computation of weather radar
    !            signal samples and stores them in
    !            member array m_Vsamp
    !  @Warning
    !            Upon detection of non-fatal error
    !            variable 'err' will be set to -1
    !            Upon detection of fatal error like
    !            failed memory allocation 'STOP'
    !            will be executed.
    !            Values of variable 'err'
    !   1) -1 -- Object built already
    !   2) -2 -- Invalid argument (any of them)
    !   3) -3 -- Floating-point arithmentic error
    !            (general error) (in this case)
    !   4) -4 -- Overflow
    !   5) -5 -- Underflow
    !   6) -6 -- Inexact
    !   7) -7 -- Denormal
    !   8) -8 -- Cancellation error (cadna)
    !=================================================!
    subroutine compute_Vsamp(this,Ai,Wi,cexpterm,nsize,err,fpflags,verbose)
          implicit none
          use mod_constants, only : LAM_ISQRT2,LAM_ZC
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exception
!DIR$     ENDIF
          class(CSWSample_t),           intent(inout)    :: this
          complex(R64P), dimension(nsize), intent(in)    :: Ai
!DIR$     ASSUME_ALIGNED Ai:32
          complex(R64P), dimension(nsize), intent(in)    :: Wi
!DIR$     ASSUME_ALIGNED Wi:32
          complex(R64P), dimension(nsize), intent(in)    :: cexpterm
!DIR$     ASSUME_ALIGNED cexpterm:32
          integer(I32P),                   intent(in)    :: nsize
          integer(I32P),                   intent(inout) :: err
          logical(I32P), dimension(5),     intent(inout) :: fpflags
          logical(I32P),                   intent(in)    :: verbose
          ! Locals
          complex(R64P) :: tmp
          integer(I32P) :: i
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type) :: status_value
!DIR$     ENDIF
          ! Start of executable statements
          ! Sanity check on error and flags arguments
          if(ANY(fpflags) == .true.) then
              fpflags = .false.
          end if
          if(err < 0) err = 0
          if(nsize /= this%m_size) then
              err = -2
              return
          end if
          tmp = LAM_ZC
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_handling_mode(ieee_all,.false.)
          call ieee_set_flags(ieee_all,fpflags)
!DIR$     ENDIF
!DIR$     SIMD
          do i = 1, this%m_size
              tmp = tmp+Ai(i)*Wi(i)*cexpterm(i)
              tmp = LAM_ISQRT2*tmp
              this%m_Vsamp(i) = tmp
          end do
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fpflags)
          if(ANY(fpflags) == .true. ) then
              if(verbose == .true. ) then
                  WRITE(stderr,*) "=============================================================================="
                  WRITE(stderr,*) "  mod_coswsamples/compute_Vsamp:699 -- Floating-point exception(s) occurred!!"
                  WRITE(stderr,*) "==============================================================================="
              end if
              err = -3
              call ieee_set_status(status_value)
          end if
!DIR$     ENDIF
    end subroutine

    !=================================================!
    !  @subroutine: compute_Vsampavg
    !  @Purpose:
    !            Performs computation of weather radar
    !            signal samples averaged over frequency cycle
    !            and stores them in member array mVsampavg.
    !
    !  @Warning
    !            Upon detection of non-fatal error
    !            variable 'err' will be set to -1
    !            Upon detection of fatal error like
    !            failed memory allocation 'STOP'
    !            will be executed.
    !            Values of variable 'err'
    !   1) -1 -- Object built already
    !   2) -2 -- Invalid argument (any of them)
    !   3) -3 -- Floating-point arithmentic error
    !            (general error) (in this case)
    !   4) -4 -- Overflow
    !   5) -5 -- Underflow
    !   6) -6 -- Inexact
    !   7) -7 -- Denormal
    !   8) -8 -- Cancellation error (cadna)
    !=================================================!
    subroutine compute_Vsampavg(this,Ai,CAk,Wi,CWk,cexpterm,nsize,err,fpflags,verbose)
          implicit none
          use mod_constants, only : LAM_HR64P,LAM_ZC
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exception
!DIR$     ENDIF
          class(CSWSample_t),              intent(inout) :: this
          complex(R64P), dimension(nsize), intent(in)    :: Ai,CAk
!DIR$     ASSUME_ALIGNED Ai:32
!DIR$     ASSUME_ALIGNED CAk:32
          complex(R64P), dimension(nsize), intent(in)    :: Wi,CWk
!DIR$     ASSUME_ALIGNED Wi:32
!DIR$     ASSUME_ALIGNED CWk:32
          complex(R64P), dimension(nsize), intent(in)    :: cexpterm
!DIR$     ASSUME_ALIGNED cexpterm:32
          integer(I32P),                   intent(in)    :: nsize
          integer(I32P),                   intent(inout) :: err
          logical(I32P), dimension(5),     intent(in)    :: fpflags
          logical(I32P),                   intent(in)    :: verbose
          ! Locals
          complex(R64P) :: tmp1,tmp2
          integer(I32P) :: i
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type) :: status_value
!DIR$     ENDIF
          ! Start of executable statements
          ! Sanity check on input arguments
          if(ANY(fpflags) == .true.) then
              fpflags = .true.
          end if
          if(err < 0) err = 0
          if(nsize /= this%m_size) then
              err = -2
              return
          end if
          tmp1 = LAM_ZC
          tmp2 = LAM_ZC
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_handling_mode(ieee_all,.false.)
          call ieee_set_flags(ieee_all,fpflags)
!DIR$     ENDIF
!DIR$     SIMD
          do i = 1, this%m_size
              tmp1 = tmp1+Ai(i)*CAk(i)*Wi(i)*CWk(i)*cexpterm(i)
              tmp1 = tmp1*LAM_HR64P
              this%m_Vsampavg(i) = tmp1
          end do
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fpflags)
          if(ANY(fpflags) == .true. ) then
              if(verbose == .true. ) then
                  WRITE(stderr,*) "=============================================================================="
                  WRITE(stderr,*) " mod_coswsamples/compute_Vsampavg:788 -- Floating-point exception(s) occurred!!"
                  WRITE(stderr,*) "==============================================================================="
              end if
              err = -3
              call ieee_set_status(status_value)
          end if
!DIR$     ENDIF
    end subroutine

    !==============================================
    !               Module operators
    !==============================================

    !==============================================
    !   subroutine: assignment (=)
    !==============================================
    subroutine assign_samples(this,other)
          implicit none
          type(CSWSamples_t), intent(inout) :: this
          type(CSWSamples_t), intent(in)    :: other
          ! Locals
          character(len=40) :: sdate,stime
          ! Start of executable statements
          if(LOC(this) == LOC(other)) then
               write(stderr,*) "===========================NON-FATAL=========================="
               write(sdterr,*) " ( mod_coswsamples/assignment(=):814, Attempted self_assignment!)"
               write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
               write(stderr,*) "===========================NON-FATAL=========================="
               return
          end if
          this%m_nechoes  = other%m_nechoes
          this%m_sampID   = other%m_sampID
          this%m_size     = other%m_size
          this%m_scatnum  = other%m_scatnum
          this%m_Ts       = other%m_Ts
          this%m_Vsamp    = other%m_Vsamp
          this%m_Vsampavg = other%m_Vsampavg
          this%m_isbuilt  = other%m_isbuilt
    end subroutine

    !======================================================60
    ! function: samples_neq_samples i.e. overloaded
    !           operator (/=)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function samples_neq_samples(s1,s2) result(neq)
          implicit none
          use module_helper_fields_equality, only : Pair1D_t
          type(CSWSamples_t), intent(in) :: s1,s2
          ! Locals
          type(Pair1D_t) :: neq
          ! Start of executable statements
          neq%x = s1%m_Vsamp    /= s2%m_Vsamp
          neq%y = s2%m_Vsampavg /= s2%m_Vsampavg
    end function

    !======================================================60
    ! function: samples_eq_samples i.e. overloaded
    !           operator (==)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function samples_eq_samples(s1,s2) result(eq)
          implicit none
          use module_helper_fields_equality, only : Pair1D_t
          type(CSWSamples_t), intent(in) :: s1,s2
          ! Locals
          type(Pair1D_t) :: eq
          ! Start of executable statements
          eq%x = s1%m_Vsamp    == s2%m_Vsamp
          eq%y = s1%m_Vsampavg == s2%m_Vsampavg
    end function

    !======================================================60
    ! function: samples_gt_samples i.e. overloaded
    !           operator (>)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function samples_gt_samples(s1,s2) result(gt)
          implicit none
          use module_helper_fields_equality, only : Pair1D_t
          type(CSWSamples_t), intent(in) :: s1,s2
          ! Locals
          type(Pair1D_t) :: gt
          ! Start of executable statements
          gt%x = s1%m_Vsamp    > s2%m_Vsamp
          gt%y = s2%m_Vsampavg > s2%m_Vsampavg
    end function

    !======================================================60
    ! function: samples_lt_samples i.e. overloaded
    !           operator (<)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function samples_lt_samples(s1,s2) result(lt)
          implicit none
          use module_helper_fields_equality, only : Pair1D_t
          type(CSWSamples_t), intent(in) :: s1,s2
          ! Locals
          type(Pair1D_t) :: lt
          ! Start of executable statements
          lt%x = s1%m_Vsamp    > s2%m_Vsamp
          lt%y = s2%m_Vsampavg > s2%m_Vsampavg
    end function

end module mod_coswsamples


PROGRAM fazi2stats

IMPLICIT NONE

CHARACTER(len=32) :: arg
INTEGER :: ngood,i
DOUBLE PRECISION :: mean_fazi,mean_dt,mean_dazi,std_fazi,std_dt,std_dazi,meansin,meancos,da
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: x,fazi,dt,sin_fazi,cos_fazi,dazi
DOUBLE PRECISION, PARAMETER :: pi180=0.017453292519943295769236907684886
DO i = 1, iargc()
  CALL getarg(i, arg)
       if(i==1) read(arg,'(i3)') ngood
!       if(i==2) read(arg,'(e3.1)') z
END DO

!No record if 0 good measuraments
if(ngood .eq.0) then
  !write(*,*),0d0,0d0,0d0,0d0
  stop
!No statistics if only 1 good measurament
else if(ngood .eq. 1) then
  read *,i,mean_fazi,mean_dt
  write(*,*), mean_fazi,0d0,mean_dt,0d0
  stop

else

ALLOCATE(x(ngood),fazi(ngood),dt(ngood),sin_fazi(ngood),cos_fazi(ngood),dazi(ngood))

do i=1,ngood
   read *,x(i),fazi(i),dt(i)
end do

!Convert degrees to radians and calculate sin and cos of fast azimuths
do i=1,ngood
   sin_fazi(i)=sin(2d0*fazi(i)*pi180)
   cos_fazi(i)=cos(2d0*fazi(i)*pi180)
end do

!Mean of sin(2*azi),cos(2*azi)
meansin=sum(sin_fazi)/ngood
meancos=sum(cos_fazi)/ngood
!Mean 2*phi azimuth in radians
mean_fazi = atan2(meansin,meancos)
!Convert phi to degrees
!do i=1,ngood
!   if(fazi(i) .gt. 90d0) fazi(i) = fazi(i) - 180d0
!end do
!mean_fazi = sum(fazi)/ngood!mean_fazi/2d0/pi180
mean_fazi = mean_fazi/2d0/pi180
!print *,mean_fazi
!Move to 0...180 range
call fix_deg_angle(mean_fazi)
if(mean_fazi .gt. 180) mean_fazi = mean_fazi -180

!Deviation from mean azimuth ( -90 < dazi < +90 )
do i=1,ngood
   call fix_deg_angle(fazi(i))
   da = fazi(i) - mean_fazi
!print *,da,fazi(i),mean_fazi
   if(da .gt. 0d0) then
      if(da .gt. 180d0) da = da - 180d0
      if(da .gt.  90d0) da = da - 180d0
   else
      if(da .lt.- 180d0) da = da + 180d0
      if(da .lt.  -90d0) da = da + 180d0
   end if
   dazi(i) = da
!print *,dazi(i)
end do

!Mean, std dev for diff_azi
!Mean of diff_azi = 0 --> stddev(dazi) = stddev(fazi)
call stats(dazi,ngood,mean_dazi,std_dazi)
std_fazi=std_dazi
!print *,mean_dazi
!Mean, std dev for dt
call stats(dt,ngood,mean_dt,std_dt)

!Write result to output file`
write(*,*),mean_fazi,std_fazi,mean_dt,std_dt

DEALLOCATE(x,fazi,dt,sin_fazi,cos_fazi,dazi)

stop

end if

END PROGRAM

subroutine fix_deg_angle(phi)

implicit none

DOUBLE PRECISION :: phi

do while(phi < 0 )
   phi = phi + 360
end do
do while(phi >360)
   phi = phi - 360
end do

end subroutine fix_deg_angle

subroutine stats(x,ngood,ave,sdev)

implicit none

INTEGER :: i,ngood,n
DOUBLE PRECISION :: ave,sdev,var,x(ngood),s

s=0d0
n=0
do i=1,ngood
   if(isnan(x(i))) then
     write(*,*) 'NaN measurament for i=', i
   else
      s = s + x(i)
      n = n + 1
   end if
end do

ave=s/n

s = 0d0; sdev=0d0; var=0d0
do i=1,ngood
   if(isnan(x(i))) then
     !write(*,*) 'NaN measurament for i=', i
   else
      s = x(i)-ave
      !dev = dev + abs(s)
      var = var + s*s
   end if
end do

var = var/(n-1)
sdev = sqrt(var)

end subroutine stats


        SUBROUTINE FOREGON(N,X,Y,F,RPAR,IPAR)
C --- RIGHT-HAND SIDE OF OREGO EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),F(N)
        F(1)=77.27D0*(Y(2)+Y(1)*(1.D0-8.375D-6*Y(1)-Y(2)))
        F(2)=(Y(3)-(1.D0+Y(1))*Y(2))/77.27D0
        F(3)=0.161D0*(Y(1)-Y(3))
        RETURN
        END
C
        SUBROUTINE JOREGON(N,X,Y,DFY,LDFY,RPAR,IPAR)
C --- JACOBIAN OF OREGO EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),DFY(LDFY,N)
        DFY(1,1)=77.27D0*(1.D0-2.D0*8.375D-6*Y(1)-Y(2))
        DFY(1,2)=77.27D0*(1.D0-Y(1))
        DFY(1,3)=0.D0
        DFY(2,1)=-Y(2)/77.27D0
        DFY(2,2)=-(1.D0+Y(1))/77.27D0
        DFY(2,3)=1.D0/77.27D0
        DFY(3,1)=.161D0
        DFY(3,2)=.0D0
        DFY(3,3)=-.161D0
        RETURN
        END


c fishpk34 from portlib                                  12/30/83
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                        f i s h p a k                          *
c     *                                                               *
c     *                                                               *
c     *     a package of fortran subprograms for the solution of      *
c     *                                                               *
c     *      separable elliptic partial differential equations        *
c     *                                                               *
c     *                  (version 3.1 , october 1980)                  *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *        john adams, paul swarztrauber and roland sweet         *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the national center for atmospheric research          *
c     *                                                               *
c     *                boulder, colorado  (80307)  u.s.a.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the national science foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c     this program illustrates the use of subroutine hstcsp to solve
c     the equation
c
c               (1/r**2)(d/dr)(r**2(du/dr)) +
c
c     (1/r**2*sin(theta))(d/dtheta)(sin(theta)(du/dtheta))
c
c                     = 12*(r*cos(theta))**2
c
c     on the rectangle 0 .lt. theta .lt. pi , 0 .lt. r .lt. 1
c     with the boundary conditions
c
c     u(theta,1) = cos(theta)**4 , o .le. theta .le. pi
c
c     and the solution unspecified on the remaining boundaries.
c     we will use 45 unknowns in the theta-interval and 15 unknowns
c     in the r-interval.
c
      program thstcsp
      dimension       f(47,16)   ,bdd(45)    ,w(615)     ,theta(45)  ,
     1                r(15)      ,cost(45)
      dimension bda(1), bdb(1), bdc(1)
c
c     note that from dimension statement we get that idimf = 47  and
c     that w is dimensioned according to the statement in the
c     description of w.
c
      idimf = 47
      a = 0.
      b = pimach(dum)
c
c     note that b is set to pi using the function pimach as required.
c
      m = 45
      mbdcnd = 9
      dt = (b-a)/float(m)
c
c     define grid points theta(i) and cos(theta(i))
c
      do 101 i=1,m
         theta(i) = a+(float(i)-0.5)*dt
         cost(i) = cos(theta(i))
  101 continue
      c = 0.
      d = 1.
      n = 15
      nbdcnd = 5
      dr = (d-c)/float(n)
c
c     define grid points r(j)
c
      do 102 j=1,n
         r(j) = c+(float(j)-0.5)*dr
  102 continue
c
c     define boundary array bdd.  bda, bdb, and bdc are dummy
c     variables in this example.
c
      do 103 i=1,m
         bdd(i) = cost(i)**4
  103 continue
      elmbda = 0.
c
c     define right side f
c
      do 105 i=1,m
         do 104 j=1,n
            f(i,j) = 12.*(r(j)*cost(i))**2
  104    continue
  105 continue
      intl = 0
      call hstcsp (intl,a,b,m,mbdcnd,bda,bdb,c,d,n,nbdcnd,bdc,bdd,
     1             elmbda,f,idimf,pertrb,ierror,w)
c
c     compute discretization error.  the exact solution is
c
c     u(theta,r) = (r*cos(theta))**4
c
      err = 0.
      do 107 i=1,m
         do 106 j=1,n
            z = abs(f(i,j)-(r(j)*cost(i))**4)
            if (z .gt. err) err = z
  106    continue
  107 continue
      print 1001 , ierror,err,w(1)
      stop
c
 1001 format (1h1,20x,25hsubroutine hstcsp example///
     1        10x,46hthe output from the ncar control data 7600 was//
     2        32x,10hierror = 0/
     3        18x,34hdiscretization error = 5.58432e-03/
     4        12x,32hrequired length of w array = 583//
     5        10x,32hthe output from your computer is//
     6        32x,8hierror =,i2/18x,22hdiscretization error =,e12.5/
     7        12x,28hrequired length of w array =,f4.0)
c
      end
c     compute discretization error.  the exact solution is


subroutine utility(values,ncols,gamma,util)
integer, INTENT(IN) :: ncols
REAL, INTENT(IN) :: values(1,ncols), gamma
REAL, INTENT(OUT) :: util(1,ncols)
  util = (values**(1-gamma))/(1-gamma)
end subroutine


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     a program for testing the scalar laplacian routines
!
!     (1) set a scalar field s as poly in x, y, z restricted to sphere
!
!     (2) compute scalar laplacian in array sclp
!
!     (3) compare (2) with analytic scalar laplacian in sclpe
!
!     (4) compute the inverse  of (2) and compare with (1)
!
program tslap

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack, only: &
        ip, & ! Integer precision
        wp, & ! Working precision
        Sphere, &
        Regularsphere, &
        GaussianSphere

    ! Explicit typing only
    implicit none

    ! Dictionary
    class(Sphere), allocatable :: solver

    ! Test gaussian grid
    allocate (GaussianSphere :: solver)
    call test_scalar_laplacian_routines(solver)
    deallocate (solver)

    ! Test regular grid
    allocate (RegularSphere :: solver)
    call test_scalar_laplacian_routines(solver)
    deallocate (solver)

contains

    subroutine test_scalar_laplacian_routines(sphere_type)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: sphere_type

        ! Local variables
        integer(ip), parameter        :: NLATS = 15
        integer(ip), parameter        :: NLONS = 22
        integer(ip), parameter        :: NSYNTHS = 3
        integer(ip)                   :: i, j, k ! Counters
        real(wp)                      :: original_scalar_function(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: exact_laplacian(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: approximate_scalar_function(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: approximate_laplacian(NLATS, NLONS, NSYNTHS)
        character(len=:), allocatable :: laplacian_error, inversion_error

        !  Set up workspace arrays
        select type(sphere_type)
            type is (GaussianSphere)

            !  Initialize gaussian sphere object
            sphere_type = GaussianSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (laplacian_error, source='     discretization error = 1.953993e-13')
            allocate (inversion_error, source='     discretization error = 6.661338e-16')

            type is (RegularSphere)

            ! Initialize regular sphere
            sphere_type = RegularSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (laplacian_error, source='     discretization error = 1.003642e-13')
            allocate (inversion_error, source='     discretization error = 8.881784e-16')
        end select

        !
        !  test all analysis and synthesis subroutines
        !    set scalar field as polynomial in x, y, z
        !    restricted to the sphere
        !
        associate (&
            se => original_scalar_function, &
            sclpe => exact_laplacian, &
            radial => sphere_type%unit_vectors%radial &
           )
            do k=1, NSYNTHS
                do j=1, NLONS
                    do i=1, NLATS
                        associate (&
                            x => radial(i, j)%x, &
                            y => radial(i, j)%y, &
                            z => radial(i, j)%z &
                           )
                            select case (k)
                                case(1)
                                    se(i, j, k) = x + y
                                    sclpe(i, j, k) = -2.0_wp * (x + y)
                                case(2)
                                    se(i, j, k) = x + z
                                    sclpe(i, j, k) = -2.0_wp * (x + z)
                                case(3)
                                    se(i, j, k) = y + z
                                    sclpe(i, j, k) = -2.0_wp * (y + z)
                            end select
                        end associate
                    end do
                end do
            end do
        end associate

        !
        !  Compute scalar laplacian
        !
        do k = 1, NSYNTHS
            associate (&
                se => original_scalar_function(:, :, k), &
                sclp => approximate_laplacian(:, :, k) &
               )
                call sphere_type%get_laplacian(se, sclp)
            end associate
        end do

        !
        !  Compute discretization error in sclp
        !
        associate (&
            sclp => approximate_laplacian, &
            sclpe => exact_laplacian &
           )
            associate (err2 => maxval(abs(sclp - sclpe)))
                !
                !  Print earlier output from platform with 64-bit floating point
                !    arithmetic followed by the output from this computer
                !
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     test scalar laplacian routines *** TEST RUN *** '
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     grid type = '//sphere_type%grid%grid_type
                write (stdout, '(a)') '     scalar laplacian approximation'
                write (stdout, '(2(a, i3))') '     nlat = ', NLATS, ' nlon = ', NLONS
                write (stdout, '(a)') '     Previous 64 bit floating point arithmetic result '
                write (stdout, '(a)') laplacian_error
                write (stdout, '(a)') '     The output from your computer is: '
                write (stdout, '(a, 1pe15.6)') '     discretization error = ', err2
                write (stdout, '(a)') ''
            end associate
        end associate
        !
        !  invert scalar laplacian
        !
        do k = 1, NSYNTHS
            associate (&
                sclpe => exact_laplacian(:, :, k), &
                s => approximate_scalar_function(:, :, k) &
               )
                call sphere_type%invert_laplacian(sclpe, s)
            end associate
        end do

        !  Compare s with se
        associate (&
            s => approximate_scalar_function, &
            se => original_scalar_function &
           )
            associate (err2 => maxval(abs(s - se)))
                !
                !  Print earlier output from platform with 64-bit floating point
                !    arithmetic followed by the output from this computer
                !
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     tslap *** TEST RUN *** '
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     grid type = '//sphere_type%grid%grid_type
                write (stdout, '(a)') '     scalar laplacian inversion'
                write (stdout, '(2(a, i3))') '     nlat = ', NLATS, ' nlon = ', NLONS
                write (stdout, '(a)') '     Previous 64 bit floating point arithmetic result '
                write (stdout, '(a)') inversion_error
                write (stdout, '(a)') '     The output from your computer is: '
                write (stdout, '(a, 1pe15.6)') '     discretization error = ', err2
                write (stdout, '(a)') ''
            end associate
        end associate

        !  Release memory
        deallocate (laplacian_error)
        deallocate (inversion_error)
        call sphere_type%destroy()

    end subroutine test_scalar_laplacian_routines

end program tslap


!
!*******************************************************************************
!
real(kind=8) function random_32(iseed_32)
!
!*******************************************************************************
!
!  Discussion:
!
!  FORTRAN 90 function to return 32-bit pseudo-random numbers with a large
!  period
!  Based on a modification of the linear congruential method
!
!      r(i+1) = mod(A*ran(i),M)
!
!  A = 2946716567, M = 2^63-1
!
!  where the mod operation is computing using Schrage's algorithm based
!  on an approximate factorization
!
!  M = A*Q + R
!
!  Q = [M/A} = 3130050626 and R = mod(M,A) = 1671854155
!
!  Then
!
!  mod(A*Y,M) = A*mod(Y,Q) - R*[Y/Q]      if >= 0
!               A*mod(Y,Q) - R*[Y/Q] + M  if < 0
!
!  The generator is augmented with Marsaglia shift operartors for a
!  64-bit random number generator
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   implicit none
   integer, parameter :: int32 = selected_int_kind(9)
   integer(kind=int32), intent(inout) :: iseed_32
   integer(kind=int32), save :: A, M, Q, R
   integer(kind=int32), save :: kk
   real(kind=8), save :: AM
   integer(kind=int32), save :: i1 = -1_int32, i2 = -1_int32
!----------------------------------------------------------
   if(iseed_32 <= 0_int32 .or. i2 < 0_int32)then              !   Initialize the seed
      M = 2147483647_int32
      A = 16807_int32
      Q = 127773_int32
      R = 2836_int32
      AM = nearest(1.0d0,-1.0d0)/M
      i2 = ior(ieor(888889999_int32,abs(iseed_32)),1_int32)
      i1 = ieor(777755555_int32, abs(iseed_32))
      iseed_32 = abs(iseed_32) + 1
   end if

   i1 = ieor(i1,ishft(i1,13))                  !  Apply Marasglia shift sequence
   i1 = ieor(i1,ishft(i1,-17))
   i1 = ieor(i1,ishft(i1,5))
   kk = i2/Q                                   !  Compute mod using Schrage's algorithm
   i2 = A*(i2 - kk*Q) - R*kk
   if(i2 < 0)i2 = i2 + M

   random_32 = AM*ior(iand(M,ieor(i1,i2)),1_int32)      !  Combine generators
   return
end function random_32


SUBROUTINE geom_freesurf(iel,nxe,fixed_seep,fixed_down,down,              &
  width,angs,surf,coord,num)
!
! This subroutine forms the coordinates and steering vector
! for 4-node quads numbering in the x-direction
! (Laplace's equation, variable mesh, 1-freedom per node).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::width(:),angs(:),surf(:),down
 REAL(iwp),INTENT(OUT)::coord(:,:)
 INTEGER,INTENT(IN)::iel,nxe,fixed_seep,fixed_down
 INTEGER,INTENT(OUT)::num(:)
 REAL(iwp)::angr(SIZE(angs)),pi,b1,b2,tan1,tan2,fac1,fac2,zero=0.0_iwp,   &
   pt5=0.5_iwp,one=1.0_iwp,small=0.0001_iwp,d180=180.0_iwp
 INTEGER::ip,iq
 pi=ACOS(-one)
 angr=angs*pi/d180
 iq=(iel-1)/nxe+1
 ip=iel-(iq-1)*nxe
 num(1)=iq*(nxe+1)+ip
 num(2)=(iq-1)*(nxe+1)+ip
 num(3)=num(2)+1
 num(4)=num(1)+1
 IF(iq<=fixed_seep+1)THEN
   b1=(surf(ip)-down)/real(fixed_seep+1)
   b2=(surf(ip+1)-down)/real(fixed_seep+1)
   coord(1,2)=down+(fixed_seep+1-iq)*b1
   coord(2,2)=down+(fixed_seep+2-iq)*b1
   coord(3,2)=down+(fixed_seep+2-iq)*b2
   coord(4,2)=down+(fixed_seep+1-iq)*b2
 ELSE
   b1=real(fixed_down+fixed_seep-iq)/real(fixed_down-1)
   b2=real(fixed_down+fixed_seep-iq+1)/real(fixed_down-1)
   coord(1,2)=down*b1
   coord(2,2)=down*b2
   coord(3,2)=coord(2,2)
   coord(4,2)=coord(1,2)
 END IF
 IF(ABS(angr(ip)-pi*pt5)<small)THEN
   fac1=zero
 ELSE
   tan1=TAN(angr(ip))
   fac1=one/tan1
 END IF
 IF(ABS(angr(ip+1)-pi*pt5)<small)THEN
   fac2=zero
 ELSE
   tan2=TAN(angr(ip+1))
   fac2=one/tan2
 END IF
 coord(1,1)=width(ip)+coord(1,2)*fac1
 coord(2,1)=width(ip)+coord(2,2)*fac1
 coord(3,1)=width(ip+1)+coord(3,2)*fac2
 coord(4,1)=width(ip+1)+coord(4,2)*fac2
RETURN
END SUBROUTINE geom_freesurf


c*************************************************************************
c                            UTIL_HILLS1.F
c*************************************************************************
c This subroutine calculates the hill's sphere for the planets
c
c             Input:
c                 msun          ==>  mass of sun (real scalar)
c                 mpl           ==>  mass of sun (real scalar)
c                 xh,yh,zh      ==>  position of pl in helio coord
c                                    (real scalars)
c                 vxh,vyh,vzh   ==>  velocity of pl in helio coord
c                                    (real scalars)
c             Output:
c                  rhill        ==>  the radius of planet's hill's sphere
c                                    (real scalar)
c
c
c Remarks: Based on util_hill
c Authors:  Hal Levison
c Date:    1/8/97
c Last revision:

      subroutine util_hills1(msun,mpl,xh,yh,zh,vxh,vyh,vzh,rhill)

      include '../swift.inc'

c...  Inputs:
      real*8 msun,mpl,xh,yh,zh
      real*8 vxh,vyh,vzh

c...  Outputs
      real*8 rhill

c...  Internals
      real*8 mu,energy,ap,r,v2

c-----
c...  Executable code

      mu = msun*mpl/(msun+mpl)
      r = sqrt( xh*xh + yh*yh + zh*zh )
      v2 =  vxh*vxh + vyh*vyh + vzh*vzh
      energy =-1.0d0*msun*mpl/r + 0.5*mu*v2
      ap = -1.0d0*msun*mpl/(2.0d0*energy)
      rhill = ap * (((mu/msun)/3.0)**(0.3333333333d0))

      return
      end                       ! util_hills1

c---------------------------------------------------


      subroutine soltmxmn(month,day,dtsec,dtlocal,tmax,tmin,rlat,
     +                          rsmin,rsmax,rgl,xlai,sfsl,solardt)
c
c--------------------------------------------------------------------------------
c  Estimation incomming short wave solar radiation from Bristow & Campbell (1984)
c  relationship for daily total radiation: Rg=So * Ktrs, in cal/(cm2*day)
c  where Ktrs is the atmosphere transmissivity, dimensionless:
c     Ktrs = A(1-EXP(-B*(tmax-tmin)**C)); A, B, & C parameters: A=0.75, B=0.004
c     (summer, May-October) or =0.01 (winter, Noevmber-April), and C=2.4
c  So is the clear sky solar irradiance on the horisontal plane (Dingman):
c     So = 2*RISC *Eo *(cos(lat)cos(dlt)sin(rot*Trs)/rot+sin(lat)sin(dlt)Trs)
c     RISC is the solar constant = 117.54 cal/(cm2*hr), Eo is the eccentricity
c     correction, lat is the latitude, dlt is the sun declinantion, rot is the
c     angular velocity of the earth's rotation =0.2618 radian/hr, and Trs is
c     a half of the daylight time in hrs
c  Estmated daily radiation Rg then converted into time interval instantenious
c  radiation values using sun angle at a specific time interval
c   solardt() - time interval average radiation, W/m2
c   rgx() - time interval factors to distribute hourly average radiation
c   tnoon - local noon time
c   dtlocal - difference between local and Z time
c   sfsl - is daily sum of canopy resistance factors to solar radiation which
c          will be used to distribute daily ET demand
c--------------------------------------------------------------------------------
c
      parameter (A = 0.75, BSM = 0.004, BWT = 0.01, C = 2.4)
      parameter (ROTV = 0.2618, RISC = 117.54)
      parameter (TNOON = 12.0)

      real solardt(144),rgx(144)
      integer dtlocal

c  calculate atmospheric transmissivity, radj
      if(month .ge. 5 .and. month .le. 10) then
       B=BSM
      else
       B=BWT
      endif
      radj=A*(1.0-EXP(-B*(tmax-tmin)**C))

c get sun rise/set
      call sunrset(month,day,rlat,rise,set,sin_term,
     +                                     cos_term,reldst)

c  getting hourly average daily solar radiation, cal/(cm2*hr)
      trs=TNOON-rise
      trmis=2*(cos_term*sin(ROTV*trs)/ROTV+sin_term*trs)
      solar=RISC*reldst*trmis*radj

c loop throuugh day by each time interval
      ntnoon=TNOON*3600/dtsec+0.001
      ndhr=24*3600/dtsec+0.001
      srg=0.0
      ind=0
      rgx(ndhr)=0.0
      do i=1,ntnoon
       time=i*dtsec/3600.
       stime=time-TNOON
       if(time .le. rise) then
        rgx(i)=0.0
        rgx(ndhr-i)=0.0
       else
        rgx(i)=sin_term+cos_term*cos(ROTV*stime)
        rgx(ndhr-i)=rgx(i)
       endif
       srg=srg+2*rgx(i)
      enddo
      srg=srg-rgx(ntnoon)

      ist=24-dtlocal
      sfsl=0.0
      do i=1,ndhr
cc  time interval radiation in cal/(cm2*dt)
       solarx=solar*rgx(i)/srg
cc  time interval radiation in W/m2
       if(i .le. ist) then
        k=i+dtlocal
       else
        k=i-ist
       endif
       solardt(k)=41840*solarx/dtsec
cc  calculate daily total radiation term of canopy resistance
       fx=0.55*2.0*solardt(k)/(rgl*xlai)
       sfsl=sfsl+(rsmin/rsmax+fx)/(1.0+fx)
      enddo

      return
      end


! Subroutine GEOMAG
!
! Excerpted from the IRI package, Stan Solomon, 6/1988.  Original name was
! GMAG, which was changed to avoid conflict when used at the same time
! as IRI.  Labeled common /CONST/ which contained only the degree/radian
! conversion factor was changed to a data statement.  Longitude range
! from -180 to 180.
!
! Minor refactor to f90, SCS, 2016.
!
! CALCULATES GEOMAGNETIC LONGITUDE (MLONG) AND LATITUDE (MLAT)
! FROM GEOGRAFIC LONGITUDE (LONG) AND LATITUDE (LATI) FOR ART=0
! AND REVERSE FOR ART=1. ALL ANGLES IN DEGREE.
! LATITUDE:-90 TO 90. LONGITUDE:0 TO 360 EAST.
!
    SUBROUTINE GEOMAG(ART,LONG,LATI,MLONG,MLAT)
      INTEGER ART
      REAL MLONG,MLAT,LONG,LATI
      DATA FAKTOR/.0174532952/
      ZPI=FAKTOR*360.
      CBG=11.4*FAKTOR
      CI=COS(CBG)
      SI=SIN(CBG)
      IF(ART.NE.0) THEN
        CBM=COS(MLAT*FAKTOR)
        SBM=SIN(MLAT*FAKTOR)
        CLM=COS(MLONG*FAKTOR)
        SLM=SIN(MLONG*FAKTOR)
        SBG=SBM*CI-CBM*CLM*SI
        LATI=ASIN(SBG)
        CBG=COS(LATI)
        SLG=(CBM*SLM)/CBG
        CLG=(SBM*SI+CBM*CLM*CI)/CBG
        IF(CLG.GT.1.) CLG=1.
        LONG=ACOS(CLG)
        IF(SLG.LT.0.0) LONG=ZPI-ACOS(CLG)
        LATI=LATI/FAKTOR
        LONG=LONG/FAKTOR
        LONG=LONG-69.8
        IF(LONG.LT.-180.0) LONG=LONG+360.0
        IF(LONG.GT. 180.0) LONG=LONG-360.0
      ELSE
        YLG=LONG+69.8
        CBG=COS(LATI*FAKTOR)
        SBG=SIN(LATI*FAKTOR)
        CLG=COS(YLG*FAKTOR)
        SLG=SIN(YLG*FAKTOR)
        SBM=SBG*CI+CBG*CLG*SI
        MLAT=ASIN(SBM)
        CBM=COS(MLAT)
        SLM=(CBG*SLG)/CBM
        CLM=(-SBG*SI+CBG*CLG*CI)/CBM
        IF(CLM.GT.1.) CLM=1.
        MLONG=ACOS(CLM)
        IF(SLM.LT..0) MLONG=ZPI-ACOS(CLM)
        MLAT=MLAT/FAKTOR
        MLONG=MLONG/FAKTOR
        IF(MLONG.LT.-180.0) MLONG=MLONG+360.0
        IF(MLONG.GT. 180.0) MLONG=MLONG-360.0
      ENDIF
      RETURN
    END SUBROUTINE GEOMAG


      FUNCTION DKLS(NP,I,L,R,Z)
C-----
C    THIS ROUTINE CALCULATES THE SINGLE PRECISION INTEGRALS FOR
C    AXISYMMETRIC SOLIDS IN EMG
C
C   INPUT
C     NP = NUMBER OF POINTS (3 OR 4)
C     I,L= THE INTEGRAL DESIRED (I SERIES STARTS WITH -1)
C     R  = RADIUS ARRAY (NP LONG)
C     Z  = Z-CORD ARRAY (NP LONG)
C
C   OUTPUT
C     DKL = DESIRED INTEGRAL
C
C-----
      INTEGER NAM(2)
      REAL  R(3),Z(3)
      DATA EPS /.01/, NAM /4HDKLS ,1H  /
      DATA ZERO, ONE, TWO / 0., 1., 2. /
C
      DKLS= ZERO
      L1 = L+1
      L2 = L + 2
      DL1 = L1
      K  = I+1
C
C  . LOOP ON NUMBER OF POINTS...
      IF (R(1).LE.ZERO) GO TO 300
       DO 200 M = 1,NP
      J = M+1
      IF (M.EQ.NP) J = 1
      RA = R(M)
      RB = R(J)
      ZA = Z(M)
      ZB = Z(J)
      DR = RB-RA
      DZ = ZB-ZA
C
C  . TEST IF RADIUS IS .LE. 0 (DRIVER SHOULD FIND THIS)...
      IF (RB.LE.ZERO) GO TO 300
      GKL = ZERO
      PR = RA+RB
      AR = PR / TWO
C
C  . CHECK FOR APPROXIMATION, DR/AVE(R)...
      IF (ABS(DR/AR) .LT. EPS) GO TO 70
C
      A = ZA*DR - RA*DZ
      BETA = A/DR
C
C  . CHECK FOR BETA .EQ. 0 CASE...
      IF ( ABS (BETA / AR ) .GT. EPS ) GO TO 10
C
      IF (DZ.EQ.ZERO) GO TO 200
      LK = L + K + 1
      AR = LK
      GKL = (DZ/DR)**L1 * (RA**LK-RB**LK) / (DL1*AR)
       GO TO 200
C
C  . GENERAL CASE...
   10 RAK = RA**K
      RBK = RB**K
      IF ( K ) 300,20,30
C
C  . GENERAL CASE, K.EQ.0, CONSTANT TERM...
   20 GKL = ALOG(RA/RB)/DL1
       GO TO 40
C
C  . GENERAL CASE, CONSTANT TERM...
   30 AR = K * L1
      GKL = (RAK - RBK) / AR
C
C  . GENERAL CASE, SUMMATION...
   40 IF (DZ.EQ.ZERO) GO TO 65
      LFACT = 1
C  . CALCULATE FACTORIAL (L+1)...
       DO 50 J = 2,L
   50 LFACT = LFACT * J
      FACTL = LFACT
      JFACT = 1
      AJ  = ONE
      DZJ = ONE
      LMJF= LFACT * L1
       DO 60 J = 1,L1
      JFACT = JFACT * J
C  . CALCULATE (L+1-J) FACTORIAL IN LMJF...
      LMJF = LMJF / (L2-J)
      FACT = FACTL / FLOAT (JFACT*LMJF)
      DFACT = K + J
      DFACT = FACT / DFACT
      AJ  = AJ * A
      RAK = RAK * RA
      RBK = RBK * RB
      DZJ = DZJ * DZ
   60 GKL = GKL + (DFACT * DZJ * (RAK-RBK)) / AJ
C-----
   65 GKL = GKL * BETA**L1
       GO TO 200
C
C  . APPROXIMATE CODE...
   70 CONTINUE
      IF (DR.EQ.ZERO) GO TO 200
      DZJ = L1 * L2
      RBK = ZB**L1
      J = K - 1
      GKL = -DR * AR**J * RBK / DL1
C
      IF (DZ.EQ.ZERO) GO TO 200
      GKL = GKL + (((2.*RA+RB)/3.)**J *DR*ABS(ZA**L2 - RBK*ZB))/(DZJ*DZ)
C
  200 DKLS= DKLS+ GKL
C-----
C
C  . ALL DONE
C
  210 CONTINUE
      RETURN
C
C  . ERROR...
C
  300 CALL MESAGE (-7,K,NAM)
       GO TO 210
      END