!--------------------------------------------------------------------
!
!
! PURPOSE
!
! This program solves nonlinear Schrodinger equation in 3 dimensions
! i*u_t+Es*|u|^2u+u_{xx}+u_{yy}+u_{zz}=0
! using a second order time spectral splitting scheme
!
! The boundary conditions are u(x=0,y,z)=u(2*Lx*\pi,y,z),
!       u(x,y=0,z)=u(x,y=2*Ly*\pi,z), u(x,y,z=0)=u(x,y,z=2*Lz*\pi)
! The initial condition is u=exp(-x^2-y^2)
!
! .. Parameters ..
!  Nx                           = number of modes in x - power of 2 for FFT
!  Ny                           = number of modes in y - power of 2 for FFT
!  Nz                           = number of modes in z - power of 2 for FFT
!  Nt                           = number of timesteps to take
!  Tmax                         = maximum simulation time
!  plotgap                      = number of timesteps between plots
!  pi = 3.14159265358979323846264338327950288419716939937510d0
!  Lx                           = width of box in x direction
!  Ly                           = width of box in y direction
!  Lz                           = width of box in z direction
!  ES                           = +1 for focusing and -1 for defocusing
! .. Scalars ..
!  i                            = loop counter in x direction
!  j                            = loop counter in y direction
!  k                            = loop counter in z direction
!  n                            = loop counter for timesteps direction
!  allocatestatus       = error indicator during allocation
!  start                        = variable to record start time of program
!  finish                       = variable to record end time of program
!  count_rate           = variable for clock count rate
!  dt                           = timestep
!  modescalereal        = Number to scale after backward FFT
!  myid                         = Process id
!  ierr                         = error code
!  p_row                        = number of rows for domain decomposition
!  p_col                        = number of columns for domain decomposition
!  filesize                     = total filesize
!  disp                         = displacement to start writing data from
!  ind                          = index in array to write
!  plotnum                      = number of plot to save
!  numberfile           = number of the file to be saved to disk
! .. Arrays ..
!  u                            = approximate solution
!  v                            = Fourier transform of approximate solution
!  pot                          = potential
! .. Vectors ..
!  kx                           = fourier frequencies in x direction
!  ky                           = fourier frequencies in y direction
!  kz                           = fourier frequencies in z direction
!  x                            = x locations
!  y                            = y locations
!  z                            = z locations
!  time                         = times at which save data
!  name_config          = array to store filename for data to be saved
! .. Special Structures ..
!  decomp                       = contains information on domain decomposition
!                                       see http://www.2decomp.org/ for more information
!
! REFERENCES
!
! ACKNOWLEDGEMENTS
!
! ACCURACY
!
! ERROR INDICATORS AND WARNINGS
!
! FURTHER COMMENTS
! Check that the initial iterate is consistent with the
! boundary conditions for the domain specified
!--------------------------------------------------------------------
! External routines required
!
! External libraries required
! 2DECOMP&FFT    -- Domain decomposition and Fast Fourier Library
!                       (http://www.2decomp.org/index.html)
! MPI library

PROGRAM main
  USE decomp_2d
  USE decomp_2d_fft
  USE decomp_2d_io
  USE MPI
  ! coprocessing:
  use NLSadaptor_module
  ! Declare variables
  IMPLICIT NONE
  INTEGER(kind=4), PARAMETER      ::  Nx=2**5
  INTEGER(kind=4), PARAMETER      ::  Ny=2**5
  INTEGER(kind=4), PARAMETER      ::  Nz=2**5
  INTEGER(kind=4), PARAMETER      ::  Nt=50
  INTEGER(kind=4), PARAMETER      ::  plotgap=10
  REAL(kind=8), PARAMETER ::&
       pi=3.14159265358979323846264338327950288419716939937510d0
  REAL(kind=8), PARAMETER ::  Lx=2.0d0,Ly=2.0d0,Lz=2.0d0
  REAL(kind=8), PARAMETER ::  Es=1.0d0
  REAL(kind=8)    ::  dt=0.10d0/Nt
  COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE      ::  kx,ky,kz
  REAL(kind=8),    DIMENSION(:), ALLOCATABLE      ::  x,y,z
  COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE  ::  u,v,pot
  REAL(kind=8),    DIMENSION(:), ALLOCATABLE      ::  time
  REAL(kind=8) :: modescalereal
  INTEGER(kind=4) ::  i,j,k,n,AllocateStatus
  INTEGER(kind=4) :: myid,numprocs,ierr
  TYPE(DECOMP_INFO)       ::  decomp
  INTEGER(kind=MPI_OFFSET_KIND) :: filesize, disp
  INTEGER(kind=4) ::  p_row=0, p_col=0
  INTEGER(kind=4) ::  start, finish, count_rate, ind, plotnum
  CHARACTER*100   ::      name_config,numberfile
  ! initialisation of 2DECOMP&FFT
  CALL MPI_INIT(ierr)
  CALL MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
  CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
  ! do automatic domain decomposition
  CALL decomp_2d_init(Nx,Ny,Nz,p_row,p_col)
  ! get information about domain decomposition choosen
  CALL decomp_info_init(Nx,Ny,Nz,decomp)
  ! initialise FFT library
  CALL decomp_2d_fft_init
  CALL system_clock(start,count_rate)
  ALLOCATE(u(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       v(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       pot(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       kx(1:Nx),ky(1:Ny),kz(1:Nz),&
       x(1:Nx),y(1:Ny),z(1:Nz),&
       time(1:1+Nt/plotgap),stat=AllocateStatus)
  IF (AllocateStatus .ne. 0) STOP

  IF (myid.eq.0) THEN
     PRINT *,'allocated space'
  END IF

  modescalereal=1.0d0/REAL(Nx,KIND(0d0))
  modescalereal=modescalereal/REAL(Ny,KIND(0d0))
  modescalereal=modescalereal/REAL(Nz,KIND(0d0))

  ! setup fourier frequencies and grid points
  DO i=1,1+Nx/2
     kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
  END DO
  kx(1+Nx/2)=0.0d0
  DO i = 1,Nx/2 -1
     kx(i+1+Nx/2)=-kx(1-i+Nx/2)
  END DO
  DO i=1,Nx
     x(i)=(-1.0d0 + 2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)))*pi*Lx
  END DO
  DO j=1,1+Ny/2
     ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
  END DO
  ky(1+Ny/2)=0.0d0
  DO j = 1,Ny/2 -1
     ky(j+1+Ny/2)=-ky(1-j+Ny/2)
  END DO
  DO j=1,Ny
     y(j)=(-1.0d0 + 2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)))*pi*Ly
  END DO
  DO k=1,1+Nz/2
     kz(k)= cmplx(0.0d0,1.0d0)*REAL(k-1,kind(0d0))/Lz
  END DO
  kz(1+Nz/2)=0.0d0
  DO k = 1,Nz/2 -1
     kz(k+1+Nz/2)=-kz(1-k+Nz/2)
  END DO
  DO k=1,Nz
     z(k)=(-1.0d0 + 2.0d0*REAL(k-1,kind(0d0))/REAL(Nz,kind(0d0)))*pi*Lz
  END DO

  IF (myid.eq.0) THEN
     PRINT *,'Setup grid and fourier frequencies'
  END IF

  DO k=decomp%xst(3),decomp%xen(3)
     DO j=decomp%xst(2),decomp%xen(2)
        DO i=decomp%xst(1),decomp%xen(1)
           u(i,j,k)=exp(-1.0d0*(x(i)**2 +y(j)**2+z(k)**2))
        END DO
     END DO
  END DO

  ! write out using 2DECOMP&FFT MPI-IO routines
  name_config(1:) = './data/u'
  plotnum=0
  WRITE(numberfile,'(i0)') 10000000+plotnum
  name_config = name_config//numberfile
  ind=index(numberfile,' ') -1
  name_config=name_config//'.datbin'
  CALL decomp_2d_write_one(1,u,name_config)

  CALL decomp_2d_fft_3d(u,v,DECOMP_2D_FFT_FORWARD)
  IF (myid.eq.0) THEN
     PRINT *,'Got initial data, starting timestepping'
  END IF
  time(1)=0
  ! coprocessing:
  call coprocessorinitialize("pipeline.py", 11)
  DO n=1,Nt
     ! Use Strang splitting
     DO k=decomp%zst(3),decomp%zen(3)
        DO j=decomp%zst(2),decomp%zen(2)
           DO i=decomp%zst(1),decomp%zen(1)
              v(i,j,k)=exp(0.50d0*dt*&
                   (kz(k)*kz(k) + kx(i)*kx(i) + ky(j)*ky(j))&
                   *cmplx(0.0d0,1.0d0))*v(i,j,k)
           END DO
        END DO
     END DO

     CALL decomp_2d_fft_3d(v,u,DECOMP_2D_FFT_BACKWARD)

     DO k=decomp%xst(3),decomp%xen(3)
        DO j=decomp%xst(2),decomp%xen(2)
           u(decomp%xst(1):decomp%xen(1),j,k)=&
                u(decomp%xst(1):decomp%xen(1),j,k)*modescalereal
           pot(decomp%xst(1):decomp%xen(1),j,k)=&
                Es*u(decomp%xst(1):decomp%xen(1),j,k)&
                *conjg(u(decomp%xst(1):decomp%xen(1),j,k))
           u(decomp%xst(1):decomp%xen(1),j,k)=&
                exp(cmplx(0.0d0,-1.0d0)*dt*&
                pot(decomp%xst(1):decomp%xen(1),j,k))&
                *u(decomp%xst(1):decomp%xen(1),j,k)
        END DO
     END DO
     CALL decomp_2d_fft_3d(u,v,DECOMP_2D_FFT_FORWARD)

     DO k=decomp%zst(3),decomp%zen(3)
        DO j=decomp%zst(2),decomp%zen(2)
           DO i=decomp%zst(1),decomp%zen(1)
              v(i,j,k)=exp(dt*&
                   (kx(i)*kx(i) +ky(j)*ky(j) +kz(k)*kz(k))&
                   *cmplx(0.0d0,0.50d0))*v(i,j,k)
           END DO
        END DO
     END DO
     IF (mod(n,plotgap)==0) THEN
        time(1+n/plotgap)=n*dt
        PRINT *,'time',n*dt
        name_config(1:)='./data/u'
        plotnum=plotnum+1
        WRITE(numberfile,'(i0)') 10000000+plotnum
        name_config=name_config//numberfile
        ind=index(numberfile,' ') -1
        name_config=name_config//'.datbin'
        ! write out using 2DECOMP&FFT MPI-IO routines
        CALL decomp_2d_write_one(1,u,name_config)
     END IF
     ! coprocessing:
     call NLSadaptor(Nx,Ny,Nz,decomp%xst(1),decomp%xen(1), &
             decomp%xst(2),decomp%xen(2),decomp%xst(3),decomp%xen(3), &
             n, n*dt, u)
  END DO
  ! coprocessing:
  call coprocessorfinalize()

  IF (myid.eq.0) THEN
     PRINT *,'Finished time stepping'
  END IF

  CALL system_clock(finish,count_rate)

  IF (myid.eq.0) THEN
     PRINT*,'Program took ',REAL(finish-start)/REAL(count_rate),'for execution'
  END IF

  IF (myid.eq.0) THEN
     ! Save times at which output was made in text format
     name_config = './data/tdata.dat'
     OPEN(unit=11,FILE=name_config,status="UNKNOWN")
     REWIND(11)
     DO j=1,1+Nt/plotgap
        WRITE(11,*) time(j)
     END DO
     CLOSE(11)
     ! Save x grid points in text format
     name_config = './data/xcoord.dat'
     OPEN(unit=11,FILE=name_config,status="UNKNOWN")
     REWIND(11)
     DO i=1,Nx
        WRITE(11,*) x(i)
     END DO
     CLOSE(11)
     ! Save y grid points in text format
     name_config = './data/ycoord.dat'
     OPEN(unit=11,FILE=name_config,status="UNKNOWN")
     REWIND(11)
     DO j=1,Ny
        WRITE(11,*) y(j)
     END DO
     CLOSE(11)
     ! Save z grid points in text format
     name_config = './data/zcoord.dat'
     OPEN(unit=11,FILE=name_config,status="UNKNOWN")
     REWIND(11)
     DO k=1,Nz
        WRITE(11,*) z(k)
     END DO
     CLOSE(11)
     PRINT *,'Saved data'
  END IF

  ! clean up
  CALL decomp_2d_fft_finalize
  CALL decomp_2d_finalize
  DEALLOCATE(u,v,pot,&
       kx,ky,kz,x,y,z,&
       time,stat=AllocateStatus)
  IF (AllocateStatus .ne. 0) STOP
  IF (myid.eq.0) THEN
     PRINT *,'Program execution complete'
  END IF
  CALL MPI_FINALIZE(ierr)
END PROGRAM main


module legendre_mod
    implicit none

contains
    ! Computes the associated Legendre polynomials P_n^m,
    ! with m = m and n = 0, ..., n_max
    ! They include the Condon-Shortley phase
    subroutine associated_legendre(x, n_max, m, p_nm, p_nm_d)
        real(8), intent(in) :: x
        integer, intent(in) :: n_max
        integer, intent(in) :: m
        real(8), allocatable, intent(out) :: p_nm(:)
        real(8), allocatable, intent(out) :: p_nm_d(:)

        integer :: i
        real(8) :: theta
        real(8) :: parity_factor(0:n_max)
        real(8) :: dummy_array(n_max+1)
        integer :: n_array(0:n_max)

        allocate(p_nm(0:n_max))
        allocate(p_nm_d(0:n_max))

        if (x .le. -1d0 .or. x .ge. 1d0) then
            print *, "Error: associated_legendre argument (x) out of range"
            p_nm = 0d0
            p_nm_d = 0d0
            return
        end if

        if (x .lt. 0d0) then
            parity_factor = [((-1d0) ** (i + m), i=0,n_max)]
        else
            parity_factor = 1d0
        end if

        ! compute associated Legendre polynomial
        theta = acos(abs(x))
        call XDLEGF(0d0, n_max, m, m, theta, 3, p_nm, dummy_array)
        p_nm = p_nm * parity_factor

        ! compute first derivate using recurrence
        ! (x^2 - 1)(d/dx)p_nm(x) = n * x * p_nm(x) - (n + m) * p_{n-1, m}(x)
        n_array = [(i, i=0,n_max)]
        p_nm_d(1:n_max) = n_array(1:n_max) * x * p_nm(1:n_max)  &
                          - (n_array(1:n_max) + m) * p_nm(0:n_max-1)
        p_nm_d(0) = 0d0
        p_nm_d = p_nm_d / (x ** 2 - 1)

    end subroutine

end module


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!
!     4/97
!
!     a program for testing all theta derivative subroutines
!     vtses, vtsec, vtsgs, vtsgc
!
!
!     (1) first set a valid vector field (v, w) in terms of x, y, z
!         cartesian coordinates
!
!     (2) analytically compute (vt, wt) from (1)
!
!     (3) compute (vt, wt) using vtses, vtsec, vtsgs, vtsgc and compare with (2)
!
program tvts

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

    use spherepack

    ! Explicit typing only
    implicit none

    real(wp) :: cosp
    real(wp) :: cost
    real(wp) :: dlat
    real(wp) :: dphi
    real(wp) :: dxdt
    real(wp) :: dydt
    real(wp) :: dzdt
    real(wp) :: emz
    real(wp) :: err2v
    real(wp) :: err2w
    real(wp) :: ex
    real(wp) :: ey
    real(wp) :: ez
    integer(ip) :: i
    integer(ip) :: icase

    integer(ip) :: error_flag
    integer(ip) :: j
    integer(ip) :: k
    real(wp) :: phi
    real(wp) :: sinp
    real(wp) :: sint
    real(wp) :: theta
    real(wp) :: x
    real(wp) :: y
    real(wp) :: z
    real(wp), allocatable :: wsave(:)
    !
    !     set dimensions with parameter statements
    !
    integer(ip), parameter              :: NLAT= 25, NLON= 19, NT = 3, ITYP = 0
    real(wp), dimension(NLAT, NLAT, NT) :: br, bi, cr, ci
    real(wp), dimension(NLAT)           :: gaussian_latitudes, gaussian_weights
    real(wp), dimension(NLAT, NLON, NT) :: v, w, vt, wt, exact_vt, exact_wt

    write (stdout, '(/a/)') '     tvts *** TEST RUN *** '

    !  Print dimension variables
    call iout(NLAT, "nlat")
    call iout(NLON, "nlon")
    call iout(NT, "  nt")

    ! Set equally spaced colatitude and longitude grid increments
    dphi = TWO_PI/NLON
    dlat = PI/(NLAT-1)

    ! Compute nlat-many gaussian latitudinal points
    call compute_gaussian_latitudes_and_weights(NLAT, gaussian_latitudes, gaussian_weights, error_flag)
    call name("compute_gaussian_latitudes_and_weights")
    call iout(error_flag, "error_flag = ")
    call vecout(gaussian_latitudes, "gaussian_latitudes", NLAT)
    !
    !     test all theta derivative subroutines
    !
    do icase=1, 4

        call name("*****************************************")

        ! Set vector field v, w and compute theta derivatives in (exact_vt, exact_wt)
        do k=1, NT
            do j=1, NLON
                phi = real(j - 1, kind=wp) * dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, NLAT
                    select case (icase)
                        case(0:2)
                            theta = real(i - 1, kind=wp) * dlat
                        case default
                            theta = gaussian_latitudes(i)
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                       !
                       !    set x, y, z and their theta derivatives at colatitude theta and longitude p
                       !
                    x = sint*cosp
                    dxdt = cost*cosp
                    y = sint*sinp
                    dydt = cost*sinp
                    z = cost
                    dzdt = -sint
                    !
                    !     set (v, w) field corresponding to stream function
                    !     S = exp(y)+exp(-z) and velocity potential function
                    !     P = exp(x)+exp(z)
                    !
                    ex = exp(x)
                    ey = exp(y)
                    ez = exp(z)
                    emz = exp(-z)
                    w(i, j, k) =-ex*sinp+emz*sint+ey*cost*sinp
                    v(i, j, k) =-ey*cosp-ez*sint+ex*cost*cosp
                    !
                    !     set theta derivatives differentiating w, v above
                    exact_wt(i, j, k) = -ex*dxdt*sinp+emz*(-dzdt*sint+cost) &
                        +ey*sinp*(dydt*cost-sint)
                    exact_vt(i, j, k) = -ey*dydt*cosp-ez*(dzdt*sint+cost) &
                        +ex*cosp*(dxdt*cost-sint)
                end do
            end do
        end do

        select case (icase)
            case (1)

                call name("testing vtsec and initialize_vtsec")

                call initialize_vhaec(NLAT, NLON, wsave, error_flag)
                call name("initialize_vhaec")
                call iout(error_flag, "error_flag = ")

                call vhaec(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wsave, error_flag)
                call name("vhaec")
                call iout(error_flag, "error_flag = ")

                ! Now compute theta derivatives of v, w
                call initialize_vtsec(NLAT, NLON, wsave, error_flag)
                call name("initialize_vtsec")
                call iout(error_flag, "error_flag = ")
                call vtsec(NLAT, NLON, ITYP, NT, vt, wt, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wsave, error_flag)
                call name("vtsec")
                call iout(error_flag, "error_flag = ")
            case (2)

                call name("testing vtses and initialize_vtses")

                call initialize_vhaes(NLAT, NLON, wsave, error_flag)
                call name("initialize_vhaes")
                call iout(error_flag, "error_flag = ")

                call vhaes(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wsave, error_flag)
                call name("vhaes")
                call iout(error_flag, "error_flag = ")

                ! Now compute theta derivatives of v, w
                call initialize_vtses(NLAT, NLON, wsave, error_flag)
                call name("initialize_vtses")
                call iout(error_flag, "error_flag = ")

                call vtses(NLAT, NLON, ITYP, NT, vt, wt, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wsave, error_flag)
                call name("vtses")
                call iout(error_flag, "error_flag = ")
            case (3)

                call name("testing vtsgc and initialize_vtsgc")

                call initialize_vhagc(NLAT, NLON, wsave, error_flag)
                call name("initialize_vhagc")
                call iout(error_flag, "error_flag = ")

                call vhagc(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wsave, error_flag)
                call name("vhagc")
                call iout(error_flag, "error_flag = ")

                ! Now synthesize v, w from br, bi, cr, ci and compare with original
                call initialize_vtsgc(NLAT, NLON, wsave, error_flag)
                call name("initialize_vtsgc")
                call iout(error_flag, "error_flag = ")

                call vtsgc(NLAT, NLON, ITYP, NT, vt, wt, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wsave, error_flag)
                call name("vtsgc")
                call iout(error_flag, "error_flag = ")
            case (4)

                call name("testing vtsgs and initialize_vtsgs")

                call initialize_vhags(NLAT, NLON, wsave, error_flag)
                call name("initialize_vhags")
                call iout(error_flag, "error_flag = ")

                call vhags(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wsave, error_flag)
                call name("vhags")
                call iout(error_flag, "error_flag = ")

                call initialize_vtsgs(NLAT, NLON, wsave, error_flag)
                call name("initialize_vtsgs")
                call iout(error_flag, "error_flag = ")

                call vtsgs(NLAT, NLON, ITYP, NT, vt, wt, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wsave, error_flag)
                call name("vtsgs")
                call iout(error_flag, "error_flag = ")
        end select

        ! Compute discretization error in vt, wt
        err2v = norm2(vt- exact_vt)
        err2w = norm2(wt - exact_wt)

        ! Set and print least squares error in v, w
        call vout(err2v, "errv")
        call vout(err2w, "errw")
    end do

    ! Release memory
    deallocate (wsave)

end program tvts


module kernel

implicit none (type, external)

private
public :: phantom, gaussian2d

contains

pure function phantom(M, N, gensig)

real :: phantom(M, N)
integer, intent(in) :: M, N
real, intent(in) :: gensig

integer :: i, j

if (gensig >= 0) then
  phantom = gaussian2d(M, N, gensig)
else
  do j = 1,N
    do i = 1,M
      phantom(i, j) = i + (j-1)*M
    end do
  end do
endif

end function phantom

pure function gaussian2d(M, N, sigma)

real :: gaussian2d(M, N)
integer, intent(in) :: M, N
real, intent(in) :: sigma

integer :: x, y
real :: xx, yy

do y = 1, M
  do x = 1, N
    xx = x - real(N) / 2 - 0.5
    yy = y - real(M) / 2 - 0.5
    gaussian2d(y,x) = 2.0*exp(-0.5 * (xx**2 + yy**2) / sigma**2)
  end do
end do

end function gaussian2d

end module kernel


! Simple illustration of projection / test
! Prescribe a divergence free velocity field,
! polute it with prescribed divergence, then
! use a relaxation method to reconstruct
! the initial divergence free field.

! See e.g.

program smooth1

  implicit none

  ! declarations

  integer, parameter :: num = selected_real_kind(p=15)
  real(num), parameter :: pi = 4.0_num * ATAN(1.0_num)
  integer :: out_unit = 10

  logical :: verbose=.false.

  logical :: gsrb=.true.

  integer :: nx, ny
  integer :: ix,iy
  integer(num) :: step = 0
  integer(num) :: nsteps

  real(num) :: tol
  real(num) :: x_min, x_max
  real(num) :: y_min, y_max
  real(num) :: dx, dy
  real(num) :: L_phi ! discritised laplacian
  real(num) :: residual

  real(num), dimension(:), allocatable :: x, y

  real(num), dimension(:,:), allocatable :: u_orig !origional
  real(num), dimension(:,:), allocatable :: u_pol  !polluted
  real(num), dimension(:,:), allocatable :: u_reconstructed
  real(num), dimension(:,:), allocatable :: v_orig !origional
  real(num), dimension(:,:), allocatable :: v_pol  !polluted
  real(num), dimension(:,:), allocatable :: v_reconstructed
  real(num), dimension(:,:), allocatable :: phi
  real(num), dimension(:,:), allocatable:: D_pol ! numerical div of polluted velocity field
  real(num), dimension(:,:), allocatable:: D_reconstructed
  real(num) :: L2, old_L2

  ! simulation / domain / grid control parameters

  nsteps = int(1e6) ! max no of steps before crashing out
  nx = 128
  ny = nx ! currently hardcoded for dx = dy later in the code
  x_min = 0.0_num
  x_max = 1.0_num
  y_min = x_min !
  y_max = x_max
  tol = 1e-16_num !1e-16 appropriate if using L2-L2_old type condition

  ! array allocation and initialisation

  ! -- Grid

  allocate(x(0:nx+1))  ! cell center (cc) - counts from 1 to nx
  allocate(y(0:ny+1))  ! cell center (cc) - counts from 1 to ny
                        ! ONE GUARD CELL FOR THIS PROBLEM

  dx = (x_max - x_min) / REAL(nx,num)
  x(0) = x_min - dx/2.0_num
  do ix = 1, nx+1
    x(ix) = x(ix-1) + dx
  end do

  dy = (y_max - y_min) / REAL(ny,num)
  y(0) = y_min - dy/2.0_num
  do iy = 1, ny+1
    y(iy) = y(iy-1) + dy
  end do

  if (dy /= dx) then
    print *, 'Warning: dy /= dx set. Has not yet being generalised.'
    print *, 'Terminating'
    STOP
  end if

  ! -- Velocity

  allocate(u_orig(0:nx+1,0:ny+1))
  allocate(u_pol(0:nx+1,0:ny+1))
  allocate(u_reconstructed(0:nx+1,0:ny+1))
  allocate(v_orig(0:nx+1,0:ny+1))
  allocate(v_pol(0:nx+1,0:ny+1))
  allocate(v_reconstructed(0:nx+1,0:ny+1))

  do iy = 0, ny + 1
  do ix = 0, nx + 1

    u_orig(ix,iy) = - sin(1.0_num * pi * x(ix))**2 &
      & * sin(2.0_num * pi * y(iy))
    v_orig(ix,iy) =   sin(1.0_num * pi * y(iy))**2 &
      & * sin(2.0_num * pi * x(ix))

   u_pol(ix,iy) = u_orig(ix,iy) - &
     & 0.2_num * pi * cos(2.0_num * pi * y(iy)) &
     & * sin(2.0_num * pi * x(ix))
   v_pol(ix,iy) = v_orig(ix,iy) - &
     & 0.2_num * pi * sin(2.0_num * pi * y(iy)) &
     & * cos(2.0_num * pi * x(ix))

  end do
  end do

  ! -- initial guess on phi

  allocate(phi(0:nx+1,0:ny+1))
  phi = 0.0_num !gives an initial guess value in domanin + in ghosts
    !i.e. dont need a BC call before first relaxation iteration

  ! Calculate the numerical divergence of the polluted field

  allocate(D_pol(0:nx,0:ny))

  do iy = 1, ny
  do ix = 1, nx
    D_pol(ix,iy) = (u_pol(ix+1,iy) - u_pol(ix-1,iy)) / 2.0_num / dx + &
            & (v_pol(ix,iy+1) - v_pol(ix,iy-1)) / 2.0_num / dy
  end do
  end do

  ! Solve Poisson equation via relaxation for phi

  print *, 'begining relaxation to solve for phi.'
  print *, 'this can take a while, use VERBOSE if you want to monitor stepping'

  do
    step = step + 1

    ! if not using redblack order
    if (.not. gsrb) then
      do iy = 1, ny
      do ix = 1, nx
        phi(ix,iy) = 0.25_num * ( &
          & phi(ix+1,iy) + phi(ix-1,iy) + phi(ix,iy+1) + phi(ix,iy-1) &
          - dx**2 * D_pol(ix,iy) )
      end do
      end do

    else !use red black

      ! odd iteration
      do iy = 1, ny
      do ix = 1, nx
        if (modulo(ix+iy,2) == 1) then
          phi(ix,iy) = 0.25_num * ( &
            & phi(ix+1,iy) + phi(ix-1,iy) + phi(ix,iy+1) + phi(ix,iy-1) &
            - dx**2 * D_pol(ix,iy) )
        endif
      end do
      end do

      ! even iteration

      do iy = 1, ny
      do ix = 1, nx
        if (modulo(ix+iy,2) == 0) then
          phi(ix,iy) = 0.25_num * ( &
            & phi(ix+1,iy) + phi(ix-1,iy) + phi(ix,iy+1) + phi(ix,iy-1) &
            - dx**2 * D_pol(ix,iy) )
        endif
      end do
      end do

    endif

    ! Apply periodic boundary conditions on phi's ghost cells

    phi(0,:) = phi(nx,:)
    phi(nx+1,:) = phi(1,:)
    phi(:,0) = phi(:,ny)
    phi(:,ny+1) = phi(:,1)

    !residual = -1e6_num ! reset the maximum value of the residual to <0
    L2 = 0.0_num
    do iy = 1, ny
    do ix = 1, nx
      L_phi = (phi(ix+1,iy) - 2.0_num*phi(ix,iy) + phi(ix-1,iy)) &
        & / dx**2 + &
        & (phi(ix,iy+1) - 2.0_num*phi(ix,iy) + phi(ix,iy-1)) / dy**2

      !residual = max(residual, abs(D_pol(ix,iy) - L_phi))
      L2 = L2 + abs(D_pol(ix,iy)-L_phi)**2
    end do
    end do
      L2 = sqrt( L2 / REAL(nx*ny,num))
!    print *, 'Step',step,'completed, residual error is',residual
!    print *, 'Step',step,'completed, L2 is',L2
!    print *, 'Step', step,'completed, |L2-old_l2| is',abs(L2-old_L2)

    if (verbose) &
      & print *, 'Step',step,'complete. L2 is',L2,'|L2-old_L2| is',abs(L2-old_L2),'tol is',tol

   !exit conditions
   !if ((step >= nsteps .and. nsteps >= 0) .or. (L2 <= tol)) exit
   ! alt, exit if the difference between L2 and L2 prev is small - might
   ! indicate convergence
    if ((step >= nsteps .and. nsteps >= 0) .or. (abs(L2-old_L2) <= tol)) exit
    old_L2 = L2

  end do

  print *, 'Relaxation completed in',step,'steps'
  print *, 'L2 norm on D(polluted velocity)- L(phi)',L2

  ! reconstruct velocity field

  print *, 'Reconstructing the velocity field'

  do iy = 1, ny
  do ix = 1, nx
    u_reconstructed(ix,iy) = u_pol(ix,iy) - &
      & (phi(ix+1,iy) - phi(ix-1,iy))/2.0_num/dx

    v_reconstructed(ix,iy) = v_pol(ix,iy) - &
      & (phi(ix,iy+1) - phi(ix,iy-1))/2.0_num/dy
  enddo
  enddo

  u_reconstructed(0,:) = u_reconstructed(nx,:)
  u_reconstructed(nx+1,:) = u_reconstructed(1,:)
  v_reconstructed(:,0) = v_reconstructed(:,ny)
  v_reconstructed(:,ny+1) = v_reconstructed(:,1)

  print *, 'Reconstruction complete'
!  print *, 'Maximum absolute difference between origional and', &
!    & ' reconstructed field is', &
!    & max(maxval(abs(u_orig-u_reconstructed)), &
!        & maxval(abs(v_orig-v_reconstructed)))

  ! calculate the l2 norm of difference between reconstructed and analytical
  ! field

  L2 = 0.0_num

  do ix = 1, nx
  do iy = 1, ny
    L2=  L2 + abs(u_orig(ix,iy)-u_reconstructed(ix,iy))**2 + &
      & abs(v_orig(ix,iy)-v_reconstructed(ix,iy))**2
  enddo
  enddo
  L2 = sqrt(L2 / REAL(2*nx*ny,num))

  print *,'L2 norm of velocity differences',L2

  ! calculate numerical divercence of reconstructed velocity field
  allocate(D_reconstructed(0:nx,0:ny))

  do iy = 1, ny
  do ix = 1, nx
    D_reconstructed(ix,iy) = (u_reconstructed(ix+1,iy) - u_reconstructed(ix-1,iy)) / 2.0_num / dx + &
            & (v_reconstructed(ix,iy+1) - v_reconstructed(ix,iy-1)) / 2.0_num / dy
  end do
  end do
  ! generate output

  print *,'Maximum divu before cleaning',maxval(abs(D_pol))
  print *,'Maximum divu after cleaning',maxval(abs(D_reconstructed))

  call execute_command_line("rm -rf *.dat *.png")
    !dont want to stream to existing files

  open(out_unit, file="x.dat", access="stream")
  write(out_unit) x(1:nx)
  close(out_unit)

  open(out_unit, file="y.dat", access="stream")
  write(out_unit) y(1:ny)
  close(out_unit)

  open(out_unit, file="u_orig.dat", access="stream")
  write(out_unit) u_orig(1:nx,1:ny)
  close(out_unit)

  open(out_unit, file="v_orig.dat", access="stream")
  write(out_unit) v_orig(1:nx,1:ny)
  close(out_unit)

  open(out_unit, file="u_pol.dat", access="stream")
  write(out_unit) u_pol(1:nx,1:ny)
  close(out_unit)

  open(out_unit, file="v_pol.dat", access="stream")
  write(out_unit) v_pol(1:nx,1:ny)
  close(out_unit)

  open(out_unit, file="u_rec.dat", access="stream")
  write(out_unit) u_reconstructed(1:nx,1:ny)
  close(out_unit)

  open(out_unit, file="v_rec.dat", access="stream")
  write(out_unit) v_reconstructed(1:nx,1:ny)
  close(out_unit)

  open(out_unit, file="d_pol.dat", access="stream")
  write(out_unit) D_pol(1:nx,1:ny)
  close(out_unit)
  open(out_unit, file="d_rec.dat", access="stream")
  write(out_unit) D_reconstructed(1:nx,1:ny)
  close(out_unit)

  call execute_command_line("python plot_smooth1.py")

end program


module matrix_module

    contains
    subroutine matrix_bits(a, b, c, a_t, n)
        implicit none

        integer, intent(in) :: n
        real, dimension(:,:), intent(in) :: a, b
        real, dimension(:,:), intent(out) :: c, a_t
        integer :: i, j, k

        do i = 1, n
            do j = 1, n
                c(i,j) = 0.
                do k = 1, n
                    c(i,j) = c(i,j)+a(i,k)*b(k,j)
                end do
            end do
        end do

        do i = 1, n
            do j = 1, n
                a_t(i,j) = a(j,i)
            end do
        end do
    end subroutine
end module

program ch2003
    ! Rank 2 and Higher Arrays as Parameters
    use matrix_module
    implicit none

    real, allocatable, dimension(:,:) :: one, &
        two, three, one_t
    integer :: i, n

    print *, 'input size of matrices'
    read *, n

    allocate(one(1:n,1:n))
    allocate(two(1:n,1:n))
    allocate(three(1:n,1:n))
    allocate(one_t(1:n,1:n))

    do i = 1, n
        print *, 'input row ', i, ' of one'
        read *, one(i,1:n)
    end do
    do i = 1, n
        print *, 'input row ', i, ' of two'
        read *, two(i,1:n)
    end do

    call matrix_bits(one,two,three,one_t,n)
    print *, ' matrix three:'
    do i = 1, n
        print *, three(i, 1:n)
    end do
    print *, ' matrix one_t:'
    do i = 1, n
        print *, one_t(i, 1:n)
    end do
end program


! $UWHPSC/codes/lapack/random/randomsys1.f90

program randomsys1
    implicit none
    integer, parameter :: nmax=1000
    real(kind=8), dimension(nmax) :: b, x
    real(kind=8), dimension(nmax,nmax) :: a
    real(kind=8) :: err
    integer :: i, info, lda, ldb, nrhs, n
    integer, dimension(nmax) :: ipiv

    ! initialize random number generator seed
    ! if you remove this, the same numbers will be generated each
    ! time you run this code.
    call init_random_seed()

    print *, "Input n ... "
    read *, n
    if (n<1 .or. n>nmax) then
        print *, "n must be positive and no greater than ",nmax
        stop
        endif
    call random_number(a(1:n,1:n))
    call random_number(x(1:n))
    b(1:n) = matmul(a(1:n,1:n),x(1:n)) ! compute RHS

    nrhs = 1 ! number of right hand sides in b
    lda = nmax  ! leading dimension of a
    ldb = nmax  ! leading dimension of b

    call dgesv(n, nrhs, a, lda, ipiv, b, ldb, info)

    ! Note: the solution is returned in b
    ! and a has been changed.

    ! compare computed solution to original x:
    print *, "         x          computed       rel. error"
    do i=1,n
        err = abs(x(i)-b(i))/abs(x(i))
        print '(3d16.6)', x(i),b(i),err
        enddo

end program randomsys1


\ Add a constant value to all elements of a matrix.
: matrix_s16>n  ( u a-addr -- )
   swap
   dup *
   0 do  \ &A
      dup @ s16>n
      over !
      cell+
   loop
   drop ;

\  	Initialize the memory block for matrix benchmarking: blksize &memblk seed
\   Parameters:
\     blksize - Size of memory to be initialized.
\     memblk - Pointer to memory block.
\     seed - Actual values chosen depend on the seed parameter.
\     p - pointers to <mat_params> containing initialized matrixes.
\   Returns:
\     Matrix dimensions.
\ ee_u32 core_init_matrix(ee_u32 blksize, void *memblk, ee_s32 seed, mat_params *p)
: core_init_matrix  ( u1 a-addr u2 -- )
   dup 0= if drop 1 then
   >r tuck ( &memblk blksize &memblk R: seed )
   2dup !  \ | N | ...
   cell+ dup 3 cells + swap  ( N &A a-addr )
   2dup !  \ | N | &A | ...
   cell+ >r
   over dup * cells  ( N &A size )
   2dup +  ( N &A size &B )
   swap over ( N &A &B size &B )
   dup r@ !  \ | N | &A | &B | ...
   + r> cell+ !  \ | N | &A | &B | &C | A11 ...
   rot dup * 1+ r> swap
   1 do  ( &A &B seed )
      i * $FFFF and
      dup i + $FFFF and
      rot 2dup ! cell+  ( &A seed val &B )
      i swap >r + $00FF and
      rot tuck ! cell+
      swap r> swap
   loop
   2drop drop ( &memblk )
   dup @ swap cell+  ( N a-addr )
   2dup cell+ @
   matrix_s16>n
   @ matrix_s16>n ;

\ Print s16 matrix of size u located at a-addr
: s16.matrix  ( u a-addr -- )
   over
   0 do  ( u a-addr )
      over
      0 do  ( a-addr )
         dup @
         s16.
         cell+
      loop
      cr
   loop
   2drop ;

\ Print s32 matrix of size u located at a-addr
: s32.matrix  ( u a-addr -- )
   over
   0 do  ( u a-addr )
      over
      0 do  ( a-addr )
         dup 2@
         s32.
         cell+ cell+
      loop
      cr
   loop
   2drop ;

\ Calculate a function that depends on the values of elements in the matrix: &C clipval N --
\ For each element, accumulate into a temporary variable.
\ As long as this value is under the parameter clipval,
\ add 1 to the result if the element is bigger then the previous.
\ Otherwise, reset the accumulator and add 10 to the result.
\ ee_s16 matrix_sum(ee_u32 N, MATRES *C, MATDAT clipval)
: matrix_sum  ( a-addr n1 u -- n2 )
   >r >r >r
   0 0 0 0 r> r> 0 r>
   dup *
   0 do  \ dprev dtmp &C clipval ret
      >r >r dup >r
      2@ d+ 2dup  \ dprev dtmp dtmp R: ret clipval &C
      r> r@ swap >r #-1  \ clipval is always negative
      d> if  \ dprev dtmp
         2drop 2drop
         r@ 2@ 0 0
         #10
      else
         2swap r@ 2@ 2swap
         d> if
            r@ 2@ 2swap #1
         else
            r@ 2@ 2swap 0
         then
      then
      r> cell+ cell+
      r> rot r> +
   loop
   >r 2drop 2drop 2drop r> ;

\ Multiply a matrix by a constant: N &C &A val
\ This could be used as a scaler for instance.
\ void matrix_mul_const(ee_u32 N, MATRES *C, MATDAT *A, MATDAT val)
: matrix_mul_const  ( u a-addr1 a-addr2 n -- )
   swap rot  \ N val &A &C
   >r rot r> swap  \ val &A &C N
   dup *
   0 do  \ val &A &C
      >r
      2dup @ m*
      r@ 2!
      cell+
      r> cell+ cell+
   loop
   2drop drop ;

\ Add a constant value to all elements of a matrix: N &A val
\ void matrix_add_const(ee_u32 N, MATDAT *A, MATDAT val)
: matrix_add_const  ( u a-addr n -- )
   swap
   rot dup *
   0 do  \ val &A
      2dup @ +
      over !
      cell+
   loop
   2drop ;

\ Multiply a matrix by a vector: N &C &A &B
\ This is common in many simple filters (e.g. fir where a vector of coefficients is applied to the matrix.)
\ void matrix_mul_vect(ee_u32 N, MATRES *C, MATDAT *A, MATDAT *B)
: matrix_mul_vect  ( u a-addr1 a-addr2 a-addr3 -- )
   rot >r rot >r  \ R: &C N
   tuck  \ &B0 &A &B
   r> r> swap  \ &B0 &A &B &C N
   dup
   0 do  \ &B0 &A &B &C N
      dup >r swap >r
      0 0 rot
      0 do  \ &A &B c  R: N &C
         >r >r
         over cell+ over cell+
         2swap @ swap @ m*
         r> r>
         d+
      loop
      r@ 2!
      drop over  \ reset &B
      r> cell+ cell+ r>
   loop
   2drop 2drop drop ;

\ Scalar product of A row by B column: &A &B N -- res
: scalar_product  ( a-addr1 a-addr2 u -- d )
   >r >r >r
   0 0 r> r> r> dup
   0 do  \ d &A &B N
      >r 2dup >r >r
      @ swap @ m* d+
      r> cell+
      r> r@ cells +
      r>
   loop
   2drop drop ;

\ Row by matrix multiplication: &A &B &C N --
: row_mul_matrix  ( a-addr1 a-addr2 a-addr3 u -- )
   dup
   0 do  \ &A &B &C N
      dup >r swap >r  \ R: N &C
      >r 2dup r> scalar_product
      r@ 2!
      cell+ r> cell+ cell+ r>
   loop
   2drop 2drop ;

\ Multiply a matrix by a matrix: &A &B &C N --
\ Basic code is used in many algorithms, mostly with minor changes such as scaling.
\ void matrix_mul_matrix(ee_u32 N, MATRES *C, MATDAT *A, MATDAT *B)
: matrix_mul_matrix  ( a-addr1 a-addr2 a-addr3 u -- )
   dup
   0 do  \ &A &B &C N
      dup
      0 do  \ &A &B &C N
         dup >r swap >r  \ R: N &C
         >r 2dup r> scalar_product
         r@ 2!
         cell+ r> cell+ cell+ r>
      loop
      tuck >r >r
      cells tuck -
      >r + r> r> r>
   loop
   2drop 2drop ;

: bit_extract  ( x1 u1 u2 -- x2 )
   >r rshift #-1 r> lshift invert and ;

\ Bitextract scalar product of A row by B column: &A &B N -- res
: scalar_product_bitextract  ( a-addr1 a-addr2 u -- d )
   >r >r >r
   0 0 r> r> r> dup
   0 do  \ d &A &B N
      >r 2dup >r >r
      @ swap @ m*
      drop dup #2 #4 bit_extract
      swap #5 #7 bit_extract
      m* d+
      r> cell+
      r> r@ cells +
      r>
   loop
   2drop drop ;

\ Multiply a matrix by a matrix, and extract some bits from the result: &A &B &C N --
\ Basic code is used in many algorithms, mostly with minor changes such as scaling.
\ void matrix_mul_matrix_bitextract(ee_u32 N, MATRES *C, MATDAT *A, MATDAT *B)
: matrix_mul_matrix_bitextract  ( a-addr1 a-addr2 a-addr3 u -- )
   dup
   0 do  \ &A &B &C N
      dup
      0 do  \ &A &B &C N
         dup >r swap >r  \ R: N &C
         >r 2dup r> scalar_product_bitextract
         r@ 2!
         cell+ r> cell+ cell+ r>
      loop
      tuck >r >r
      cells tuck -
      >r + r> r> r>
   loop
   2drop 2drop ;

: matrix_big  ( n1 -- n2 )
   $-1000 or ;

: p->n  ( a-addr -- u )
   @ ;
: p->a  ( a-addr1 -- a-addr2 )
   cell+ @ ;
: p->b  ( a-addr1 -- a-addr2 )
   cell+ cell+ @ ;
: p->c  ( a-addr1 -- a-addr2 )
   cell+ cell+ cell+ @ ;

\ Perform matrix manipulation: &p val -- crc
\ Parameters:
\ N - Dimensions of the matrix.
\ C - memory for result matrix.
\ A - input matrix
\ B - operator matrix (not changed during operations)
\ Returns:
\ A CRC value that captures all results calculated in the function.
\ In particular, crc of the value calculated on the result matrix
\ after each step by <matrix_sum>.
\ Operation:
\ 1 - Add a constant value to all elements of a matrix.
\ 2 - Multiply a matrix by a constant.
\ 3 - Multiply a matrix by a vector.
\ 4 - Multiply a matrix by a matrix.
\ 5 - Add a constant value to all elements of a matrix.
\ After the last step, matrix A is back to original contents.
\ ee_s16 matrix_test(ee_u32 N, MATRES *C, MATDAT *A, MATDAT *B, MATDAT val)
: matrix_test  ( a-addr n -- u )
   s16>n tuck  \ val &p val
   2dup >r dup p->n swap p->a r> matrix_add_const
   2dup >r dup p->n swap dup p->c swap p->a r> matrix_mul_const
   matrix_big  \ val &p clipval
   2dup over p->c swap rot p->n matrix_sum
   0 crc16 >r  \ R: crc
   over dup p->n swap dup p->c swap dup p->a swap p->b matrix_mul_vect
   2dup over p->c swap rot p->n matrix_sum
   r> crc16 >r  \ R: crc
   over dup p->a swap dup p->b swap dup p->c swap p->n matrix_mul_matrix
   2dup over p->c swap rot p->n matrix_sum
   r> crc16 >r  \ R: crc
   over dup p->a swap dup p->b swap dup p->c swap p->n matrix_mul_matrix_bitextract
   2dup over p->c swap rot p->n matrix_sum
   r> crc16 >r  \ R: crc
   drop dup p->n swap p->a rot negate matrix_add_const
   r> ;

\ Benchmark function: &p seed crc
\ Iterate <matrix_test> N times,
\ changing the matrix values slightly by a constant amount each time.
\ ee_u16 core_bench_matrix(mat_params *p, ee_s16 seed, ee_u16 crc)
: core_bench_matrix  ( a-addr n u1 -- u2 )
   >r matrix_test r> crc16 ;


program complex_03
implicit none

complex :: x
real :: a, b

x = (1.0,-3.0)
a = x%re
b = x%im
print *, a, b
print *, x%re, x%im
if (abs(x%re - 1) > 1e-5) error stop
if (abs(x%im - (-3)) > 1e-5) error stop

end program


! Mikayla Webber
! 4670 Numerical Analysis
! Homework Three Due 10/18/17

module secret

integer :: fcounter

end module secret

program WebberHomework3Question1
use secret
implicit none

integer :: i
integer :: n
double precision, allocatable, dimension(:) :: a
double precision, allocatable, dimension(:) :: xdata
double precision, allocatable, dimension(:) :: ydata

n = 10

open(unit=8, file='readTable.txt', status='old')
open(unit=9, file='resultTable.txt', status='replace')

read(8,*)	n
write(9,*) 	n

allocate(xdata(0:n), ydata(0:n), a(0:n))

do i = 0, n
	read(8,*) xdata(i), ydata(i)
	write(9,*) xdata(i), ydata(i)
	fcounter = (fcounter + 1)
end do

print*,'This program was ran this many times: ', fcounter

print*, 'Newtons Divided Difference Coefficients: '

call divdiff(n, xdata, ydata, a)

do i = 0, n
	print*, a(i)
end do

deallocate(xdata, ydata, a)

close(8)
close(9)

stop
end program WebberHomework3Question1

subroutine divdiff(n, xdata, ydata, a)

integer :: i
integer :: j
integer :: n
double precision :: a(0:n)
double precision :: xdata(0:n)
double precision :: ydata(0:n)
double precision, allocatable, dimension(:,:) :: T

allocate (T(0:n,0:n))

do i = 0, n
	T(i,0) = ydata(i)
end do

a(0) = ydata(0)

do i = 1, n
	do j = 1, n
		T(i,j) = ((T(i,(j - 1)) - T((i - 1),(j - 1))) / (xdata(i) - xdata(i - j)))
		if (i == j) then
			a(i) = T(i,j)
		end if
	end do
end do

deallocate(T)

end subroutine divdiff


PROGRAM Assignment1
IMPLICIT NONE

INTEGER:: i, j
INTEGER, PARAMETER :: m = 1050
REAL :: Prior(0:m), P(0:m), TauArray(0:m), DecayMeasurments(10), l(1), dtau, NormalisationConstant, Y(1), X(1)

dtau = 0.1; Prior=1.0/99.0; P = Prior

OPEN(10, FILE = 'bayes_data.txt') !Opening decay measurment times
  READ(10,'(f6.3)') DecayMeasurments !Reading 10 decay measurments to array
CLOSE(10)

DO i = 1, 1050
  TauArray(i) = REAL(i)*dtau !Creating tauarray, the possible half life times, in intervals of 0.1s
END DO

DO j = 1, 10
  DO i = 1, 1050

    P(i)=P(i)*exp(-DecayMeasurments(j)/TauArray(i))/TauArray(i)

  END DO
END DO

NormalisationConstant = (SUM(P) - 0.5*(P(0)+P(m)))*dtau !Calculating normalisation constant

DO i = 1, 1050
  P(i) = P(i)/NormalisationConstant!Normalising probability array
END DO

OPEN(11, FILE = 'Results.dat') !Creating file to print results in
DO i = 1,1050
  WRITE(11,*) 'p ''Results.dat'' u 1:2 w l'
  WRITE(11,*) TauArray(i), P(i) !Printing half life times are their respective probabaility to file
END DO
CLOSE(11)

WRITE(6,*) 'Results printed to file ''Results.dat''', SUM(P)

l = Maxloc(P); Y = P(l); X = TauArray(l)
WRITE(6,*) L

WRITE(6,*) 'Most probably half life is', X, 'with a probability of:', Y

END PROGRAM

Monte Carlo Method and Bayesian Statistics/Assignment1.f90


      SUBROUTINE SC2BAS(X,NDERIV,ISEG,NEWSEG, B,NB,P)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 SC2BAS Krogh  Declared all vars.
C>> 1994-10-20 SC2BAS Krogh  Changes to use M77CON
C>> 1987-12-09 SC2BAS Lawson Initial code.
c--S replaces "?": ?C2BAS
c
c          Given X in the segment ISEG, this subr evaluates at X the
c     four cubic B-spline basis functions that are not identically
c     zero throughout segment ISEG.
c          This is a reorganization of a set of three subroutines
c     SBAS1, SBAS2, & SBAS3 used in LIB*JPL$ from about 1970 on.
c     The reorganization improves portability and brings
c     conformance to Fortran 77.
c     More features are avalable from a similar subr in a package
c     due to Carl de Boor, however this subr is being preserved
c     for convenience of usage with some other JPL subrs --
c     particularly the size and interpretation of the B() array.
c          C. L. Lawson, JPL, 1984 July 9, July 1987.
c     ------------------------------------------------------------------
c               A R G U M E N T S
c
c     X  [in]  Argument at which basis fcns are to be evaluated.
c           Must satisfy B(ISEG) .le. X .le. B(ISEG+1)
c
c     NDERIV  [in]   = 0, 1, 2, or 3.  Indicates the order of derivative
c              to be computed.  0 selects function value,
c              1 selects 1st derivative, etc.
c
c     ISEG  [in] Index of current segment. Require 1 .le. ISEG .le. NB-1
c               Segment ISEG is the interval [B(ISEG), B(ISEG+1)].
c               The current X must be in this segment.
c
c     NEWSEG  [inout]  = .true. means ISEG is not the same as on
c             previous call.  In this case this subr will set new values
c             into U() and reset NEWSEG = .false.  The user prog must
c             set NEWSEG = .true. on the first call to this subr, and
c             on any subsequent call at which the user prog has set
c             ISEG to a new value.
c
c             = .false. means this subr can assume the values in U()
c             are correct for the current ISEG.
c
c     B()  [in]  Array of knots, including the left and right
c               endpoints.  Contains B(I), I = 1, NB.  Set by user.
c               Not changed by this subr.  Must be strictly increasing,
c               i.e. require B(i) .lt. B(i+1), i = 1, NB-1.
c
c     NB  [in]  Number of knots, including endpoints. The number
c               of degrees of freedom of the set of cubic splines
c               defined over this set of knots is NB+2.
c
c     P()  [out]  Array of length 4 into which this subr will store the
c             values of the 4 basis fcns that are not identically
c             zero over segment ISEG.  The indices of these basis
c             fcns are ISEG, ISEG+1, ISEG+2, & ISEG+3.  The values
c             will be stored in (P(i), i=1,4).
c     ------------------------------------------------------------------
c               IMPORTANT INTERNAL VARIABLES
c
c     U()       Array of length 8 in which this subr saves a scaled
c               record of the knots near the current segment.
c
c     SCALE  Scale factor for abcissas.  Computed as the reciprocal
c            of the average segment length.
c     ------------------------------------------------------------------
c
      integer NDERIV, ISEG, NB
      integer MB, IS, ISM4, IB1, IB2, IB, IU, NDP1, I, J, I2
      real             U(8), B(NB), P(4), C6, C18, C36, CS
      real             FLNSEG, H, SCALE, X, XS
      logical NEWSEG
      parameter(C6 = 6.0E0, C18 = 18.0E0, C36 = 36.0E0)
      save  U, SCALE
c     ------------------------------------------------------------------
      MB=NB
c                     The following statement does a type conversion.
      FLNSEG=MB-1
      IF( NEWSEG ) THEN
         NEWSEG = .FALSE.
         SCALE = FLNSEG / (B(NB) - B(1))
         IS=ISEG
         ISM4=IS-4
         IB1=max(1,IS-3)
         IB2=min(MB,IS+4)
C                               COPY PART OF B() INTO U()
             DO 20 IB=IB1,IB2
             IU=IB-ISM4
   20        U(IU)=SCALE*B(IB)
C                               ADJOIN ARTIFICIAL SEGMENTS AT LEFT END
         IU=IB1-ISM4-1
         IF(IU .NE. 0) THEN
            H=U(IU+2)-U(IU+1)
   30       U(IU)=U(IU+1)-H
            IU=IU-1
            IF(IU .GT. 0) GO TO 30
         END IF
C                               ADJOIN ARTIFICIAL SEGMENTS AT RIGHT END
         IU=IB2-ISM4+1
         IF(IU .LE. 8) THEN
            H=U(IU-1)-U(IU-2)
   50       U(IU)=U(IU-1)+H
            IU=IU+1
            IF(IU .LE. 8) GO TO 50
         END IF
      END IF
c     ------------------------------------------------------------------
      NDP1=NDERIV+1
      XS=X*SCALE
      GO TO (70,90,110,130),NDP1
   70     DO 80 I=1,4
   80     P(I)= (XS-U(I))**3
      CS= C6
      GO TO 150
   90     DO 100 I=1,4
  100     P(I)=(XS-U(I))**2
      CS= C18 * SCALE
      GO TO 150
  110     DO 120 I=1,4
  120     P(I)= XS-U(I)
      CS= C36 * SCALE**2
      GO TO 150
  130     DO 140 I=1,4
  140     P(I)= C36
      CS= SCALE**3
  150 CONTINUE
C
C                            COMPUTE FOURTH DIVIDED DIFFERENCES
C
          DO 170 J=1,4
               DO 160 I=1,3
               I2=I+J
  160          P(I)=(P(I+1)-P(I))/(U(I2)-U(I))
  170     P(4)=     -P(4)/(U(J+4)-U(4))
C
          DO 180 I=1,4
  180     P(I)=P(I)*CS
      return
      end


module m_ranvar3
contains
subroutine ranvar3(ens,ave,var,n_var,n_ens)
! Return ensemble variance vector
!
  implicit none
  integer             :: j
  integer,intent(in)  :: n_var,n_ens
  real(8),intent(in)  :: ens(n_var,n_ens)
  real(8),intent(in)  :: ave(n_var)
  real(8),intent(out) :: var(n_var)
!
  var(:)=0.d0
  do j=1,n_ens
    var(:)=var(:)+(ens(:,j)-ave(:))*(ens(:,j)-ave(:))
  enddo
  var(:)=var(:)/dble(n_ens-1)
!
end subroutine ranvar3
end module


!>
!! \brief This module contains mathematical constants
!!
!! Module for Capreole / C2-Ray (f90)
!!
!! Author: Garrelt Mellema
!!
!! Date: 2003-12-09
!!
!! This module is also accepted by the F compiler (Dec 9, 2003)
!<
module mathconstants

  use precision, only: dp

  implicit none

  private

  !> the number pi
  real(kind=dp),public,parameter :: pi=3.141592654

end module mathconstants


! { dg-do compile }

! Emit a diagnostic for too small PUT array at compile time
! See PR fortran/37159

! Possible improvement:
! Provide a separate testcase for systems that support REAL(16),
! to test the minimum size of 12 (instead of 8).
!
! Updated to check for arrays of unexpected size,
! this also works for -fdefault-integer-8.
!

PROGRAM random_seed_1
  IMPLICIT NONE

  ! Find out what the's largest kind size
  INTEGER, PARAMETER :: k1 = kind (0.d0)
  INTEGER, PARAMETER :: &
    k2 = max (k1, selected_real_kind (precision (0._k1) + 1))
  INTEGER, PARAMETER :: &
    k3 = max (k2, selected_real_kind (precision (0._k2) + 1))
  INTEGER, PARAMETER :: &
    k4 = max (k3, selected_real_kind (precision (0._k3) + 1))

  INTEGER, PARAMETER :: nbytes = MERGE(48, 32, k4 == 16)

  ! '+1' to avoid out-of-bounds warnings
  INTEGER, PARAMETER    :: n = nbytes / KIND(n) + 1
  INTEGER, DIMENSION(n) :: seed

  ! Get seed, array too small
  CALL RANDOM_SEED(GET=seed(1:(n-2)))  ! { dg-error "too small" }

  ! Get seed, array bigger than necessary
  CALL RANDOM_SEED(GET=seed(1:n))

  ! Get seed, proper size
  CALL RANDOM_SEED(GET=seed(1:(n-1)))

  ! Put too few bytes
  CALL RANDOM_SEED(PUT=seed(1:(n-2)))  ! { dg-error "too small" }

  ! Put too many bytes
  CALL RANDOM_SEED(PUT=seed(1:n))

  ! Put the right amount of bytes
  CALL RANDOM_SEED(PUT=seed(1:(n-1)))
END PROGRAM random_seed_1


program compare_floats ! from urbanjost
implicit none
! below might test as equal
! real :: A(3)=[1.0,2.0,3.0], B(3)=[1.0,2.0,2.9999999999999]
real :: A(3)=[1.0,2.0,3.0], B(3)=[1.0,2.0,2.999999] ! this should be close enough
real :: tolerance=0.00001  ! just a sample tolerance
if (all(A==B)) then  ! testing for exact matches can be problematic
   write(*,*) "A and B are equal"
else if (all(abs(A-B) < tolerance)) then
   write(*,*) "A and B are close enough to equal"
else
   write(*,*) "A and B are NOT equal"
end if
! output: A and B are close enough to equal
end program compare_floats


function func(x,tt)
real::g,l,x,tt
g=9.80665
l=1.0
func=-(g/l)*sin(x)
end

program uno
implicit none
REAL,ALLOCATABLE,DIMENSION(:)::x,v,t
integer::n,i
real::func,xo,vo,a,b,h,VNmid,to

a=0.
b=10.
to=0.
vo=0.
xo=0.523599
n=1000

open (10, FILE='intfuncDKD.dat', STATUS='UNKNOWN')
h=(b-a)/float(n)
allocate(v(n+1),x(n+1),t(n+1))
do i=0,n
t(i)=to+h*i
end do
x(0)=xo
v(0)=vo
do i=0,n
VNmid=v(i)+func(x(i),t(i))*(h/2.)
x(i+1)=x(i)+VNmid*h
v(i+1)=VNmid+func(x(i+1),t(i))*(h/2)
write(10,*) i,x(i),v(i),t(i)
end do
close(10)
return
end program


!! R501 type-declaration-stmt
!    is declaration-type-spec [ [ , attr-spec ] ... :: ] entity-decl-list

! intrinsic-type-spec, no attrs, w/ double colon
integer :: x
integer y
integer, pointer :: xptr
integer, pointer, allocatable :: yptr

! test entity_decl_list
real :: a,b

! intrinsic-type-spec with kind-selector
integer(kind=4) :: m

! intrinsic-type-spec with char-selector
10 Character(kind=1, len=10) :: string

! From NOTE 5.1

REAL A (10)
LOGICAL, DIMENSION (5, 5) :: MASK1, MASK2
COMPLEX :: CUBE_ROOT = (-0.5, 0.866)
INTEGER, PARAMETER :: SHORT = SELECTED_INT_KIND (4)
INTEGER (SHORT) K     !  Range at least -9999 to 9999.
REAL (KIND (0.0D0)) A
REAL (KIND = 2) B
COMPLEX (KIND = KIND (0.0D0)) :: C
CHARACTER (LEN = 10, KIND = 2)  A
CHARACTER B, C *20
TYPE (PERSON) :: CHAIRMAN
TYPE(NODE), POINTER :: HEAD => NULL ( )
TYPE (humongous_matrix (k=8, d=1000)) :: mat

end


module commondata
    implicit none

    integer, parameter :: total_nx=201,total_ny=201
    integer :: nx, ny
    real(8), parameter :: Reynolds=1000.0d0
    real(8), parameter :: rho0=1.0d0
    real(8), parameter :: U0=0.1d0
    real(8), parameter :: tauf=U0*dble(total_nx)/Reynolds*3.0d0+0.5d0

    integer :: itc
    integer, parameter :: itc_max=INT(50000000)

    real(8) :: errorU
    real(8), parameter :: eps=1e-6

    real(8) :: xp(0:total_nx+1), yp(0:total_ny+1)
    real(8), allocatable :: u(:,:), v(:,:)
    real(8), allocatable :: rho(:,:)
    real(8), allocatable :: up(:,:), vp(:,:)

    real(8), allocatable :: f(:,:,:), f_post(:,:,:)

    real(8) :: omega(0:8)
    integer :: ex(0:8), ey(0:8)
    data ex/0, 1, 0, -1,  0, 1, -1, -1,  1/
    data ey/0, 0, 1,  0, -1, 1,  1, -1, -1/
    real(8) :: Uwall = U0

    real(8), parameter :: Snu=1.0d0/tauf, Sq=8.0d0*(2.0d0*tauf-1.0d0)/(8.0d0*tauf-1.0d0)

    ! mpi data
    integer :: rc, rank, num_process
    integer :: dims(0:1) = (0, 0), coords(0:1)
    logical :: periods(0:1)
    data periods/2*.false./
    integer :: comm2d, rank2d
    integer :: row_x, column_y
    integer :: nbr_left, nbr_right, nbr_top, nbr_bottom
    integer :: cnr_top_left, cnr_top_right, cnr_bottom_left, cnr_bottom_right
end module commondata


SUBROUTINE dgauleg(x1,x2,x,w,n)

! Code converted using TO_F90 by Alan Miller
! Date: 2002-05-14  Time: 13:40:52

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

REAL*8, INTENT(IN OUT)                   :: x1
REAL*8, INTENT(IN OUT)                   :: x2
REAL*8, INTENT(OUT)                      :: x(n)
REAL*8, INTENT(OUT)                      :: w(n)
INTEGER, INTENT(IN)                      :: n

REAL*8, PARAMETER :: eps=3.d-14
INTEGER :: i,j,m
REAL*8 p1,p2,p3,pp,xl,xm,z,z1

m=(n+1)/2
z1=huge(1.0)
xm=0.5D0*(x2+x1)
xl=0.5D0*(x2-x1)
DO  i=1,m
  z=COS(3.141592654D0*(i-.25D0)/ (n+.5D0))
  DO WHILE (ABS(z-z1) > eps)
    p1=1.d0
    p2=0.d0
    DO  j=1,n
      p3=p2
      p2=p1
      p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j
    END DO
    pp=n*(z*p1-p2)/(z*z-1.d0)
    z1=z
    z=z1-p1/pp
  END DO
  x(i)=xm-xl*z
  x(n+1-i)=xm+xl*z
  w(i)=2.d0*xl/((1.d0-z*z)*pp*pp)
  w(n+1-i)=w(i)
END DO
RETURN
END SUBROUTINE dgauleg


program arraysort
    ! README
    ! This program sorts a nxn array in ascending order by row or by column.
    ! There is code repetition that can be removed b/w row sorting and column sorting to reduce size of code,
    ! however, it doesnt affect the speed of the program as these lie in condiitonals.

    ! code populates randomly a nxn array called arr, then construct an empty array of nxn called temp and n called temp2. temp is the new array and
    ! temp2 stores the index of max values in arr as it gets updated (on every loop, these max values are removed from arr)

        implicit none
        integer :: n,i,j
        character :: a
        real, dimension(:,:), allocatable :: arr1,temp
        integer, dimension(:), allocatable :: temp2
        print*, "Give n for nxn matrix, and choose whether to sort by row(r) or column(c)"
        read ('(I4,A1)'), n,a
        allocate (arr1(n,n), temp(n,n), temp2(n))
        call random_number(arr1)
        print*, "---------------------RANDOM ARRAY IS: ----------------------------------"
        do i=1,n
            print*, arr1(i,:)
        end do
        if (a == 'c' .or. a =='c') then
            print*, " ----------------------sorting by column------------------------------"
            do i=1,n
                temp2 = maxloc(arr1,1)
                temp(i,:) = maxval(arr1,dim=1)
                do j=1,n
                    arr1(temp2(j),j) =0    !this is fine since our values are between 0 and 1, otherwise it could be set to minimum value in whole arr
                end do
            end do
        else if (a == 'r' .or. a == 'R') then
            print*, "--------------------------sorting by row ---------------------------------"
            do i=1,n
                temp2 = maxloc(arr1,2)
                temp(:,i) = maxval(arr1,dim=2)
                do j=1,n
                    arr1(j,temp2(j)) =0
                end do
            end do
        else
            print*, "check output"; stop
        end if
        do i=1,n
            print*, temp(i,:)
        end do

    end program arraysort


program lrnz2
implicit none
integer:: i
integer,parameter::n=10000
real*8,dimension(1:3):: y0,y01
real*8,dimension(n+1)::tout
real*8,dimension(1:3,n+1)::f,f1
real*8::ti,tmax,h,r

write(*,*) 'Enter the value of r: '
read(*,*) r

!initial condition
do i=1,3
  y0(i)=6.0d0
end do

y01(1)=6.0d0
y01(2)=6.01d0
y01(3)=6.0d0

ti=0.0d0
tmax=25.0d0

!time step
h= tmax/n

!plot curve
call rkit(y0,ti,h,r,n,tout,f)
call rkit(y01,ti,h,r,n,tout,f1)

open(12, file="lorentz_curve1.plt")
write(12,*)'variables ="t","x","x1"'

do i=1,n+1
  write(12,*) tout(i),f(1,i),f1(1,i)
end do
close(12)

open(13, file="lorentz_curve2.plt")
write(13,*)'variables ="t","y","y1"'

do i=1,n+1
  write(13,*) tout(i),f(2,i),f1(2,i)
end do
close(13)

open(14, file="lorentz_curve3.plt")
write(14,*)'variables ="t","z","z1"'

do i=1,n+1
  write(14,*) tout(i),f(3,i),f1(3,i)
end do
close(14)

end

!array of differential equations/functions

subroutine funcs(yin,t,r,f)
implicit none
real*8,dimension(1:3)::yin
real*8::t,r
real*8,dimension(1:3)::f

f(1) = 10.0d0 *(yin(2)- yin(1))
f(2) = (r*yin(1)) - yin(2) - (yin(1)*yin(3))
f(3) = (yin(1)*yin(2))-((8.0d0/3.0d0)*yin(3))

end

subroutine rk4(yin,ti,h,r,f)
implicit none
real*8,dimension(1:3)::yin
real*8::h,r,ti
real*8,dimension(1:3)::f
real*8,dimension(1:3)::k1,k2,k3,k4,yout

call funcs(yin,ti,r,yout)
k1 = h*yout

call funcs(yin+k1/2.0d0,ti+h/2.0d0,r,yout)
k2 = h*yout

call funcs(yin+k2/2.0d0,ti+h/2.0d0,r,yout)
k3 = h*yout

call funcs(yin+k3,ti+h,r,yout)
k4 = h*yout

f = yin + ((k1+2.0d0*(k2+k3)+k4)/6.0d0)

end

subroutine rkit(y0,ti,h,r,n,tout,f)
implicit none
integer::i,n
real*8,dimension(1:3)::y0
real*8,dimension(1:3,n+1)::f
real*8::h,ti,r
real*8,dimension(n+1)::tout

tout(1) = ti
f(:,1) = y0(2)

do i = 2,n+1
tout(i) = tout(i-1) + h
call rk4(f(:,i-1),tout(i-1),h,r,f(:,i))
end do

end


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
! ... file shallow.f90
!
!     program shallow solves the nonlinear shallow-water equations
!     on the sphere using spherepack software.
!
! ... required spherepack files
!
!     vtses.f90, dives.f90, vrtes.f90, grades.f90, type_SpherepackUtility.f90, type_RealPeriodicFastFourierTransform.f90,
!     vhaes.f90, vhses.f90, shaes.f90, shses.f90
!
!
!     the nonlinear shallow-water equations on the sphere are
!     solved using a spectral method based on the spherical
!     vector harmonics. the method is described in the paper:
!
! [1] p. n. swarztrauber, spectral transform methods for solving
!     the shallow-water equations on the sphere, p.n. swarztrauber,
!     monthly weather review, vol. 124, no. 4, april 1996, pp. 730-744.
!
!     this program implements test case 3 (steady nonlinear rotated flow)
!     in the paper:
!
! [2] d.l. williamson, j.b. drake, j.j. hack, r. jakob, and
!     p.n. swarztrauber, j. comp. phys., a standard test set
!     for numerical approximations to the shallow-water
!     equations in spherical geometry, j. comp. phys.,
!     vol. 102, no. 1, sept. 1992, pp. 211-224.
!
! definitions:
!
!
!     nlat          number of latitudes including poles
!     nlon          number of distinct longitudes
!     mmode         max wave number
!     omega         rotation rate of earth in radians per second
!     aa            radius of earth in meters
!     pzero         mean height of geopotential
!     uzero         maximum velocity
!     alpha         tilt angle of the rotated grid
!     ncycle        exit number
!     time          model time in seconds
!     dt            time step
!     lambda        longitude
!     theta         colatitude
!
!   the first dimension of the following two dimensional arrays
!   corresponds to the latitude index with values i=1, ..., nlat
!   where i=1 is the north pole and i=nlat is the south pole.
!   the second dimension is longitude with values j=1, ..., nlon
!   where j=1 corresponds to zero longitude and j=nlon corresponds
!   to 2pi minus 2pi/nlon.
!
!     u(i, j)       east longitudinal velocity component at t=time
!     v(i, j)       latitudinal velocity component at t=time
!     p(i, j)       +pzero = geopotential at t=time
!
!     unew(i, j)    east longitudinal velocity component at t=time+dt
!     vnew(i, j)    latitudinal velocity component at t=time+dt
!     pnew(i, j)    +pzero = geopotential at t=time+dt
!
!     uold(i, j)    east longitudinal velocity component at t=time-dt
!     vold(i, j)    latitudinal velocity component at t=time-dt
!     pold(i, j)    +pzero = geopotential at t=time-dt
!
!     divg(i, j)    divergence (d/dtheta (cos(theta) v)
!                                          + du/dlambda)/cos(theta)
!     vort(i, j)    vorticity  (d/dtheta (cos(theta) u)
!                                          - dv/dlambda)/cos(theta)
!
!     ut(i, j)      latitudinal derivative of longitudinal
!                  velocity component
!     vt(i, j)      latitudinal derivative of latitudinal
!                  velocity component
!
!     dudt(i, j)    time derivative of longitudinal velocity component
!     dvdt(i, j)    time derivative of latitudinal  velocity component
!     dpdt(i, j)    time derivative of geopotential
!
!     gpdl(i, j)    first component of the gradient of p(i, j)
!                  the longitudinal derivative of the geopotential
!                  divided by the cosine of the latitude
!
!     gpdt(i, j)    second component of the gradient of p(i, j)
!                  the latitudinal derivative of the geopotential
!
!     uxact(i, j)   the "exact" longitudinal veloctiy component
!     vxact(i, j)   the "exact" latitudinal  veloctiy component
!     uxact(i, j)   the "exact" geopotential
!
!     f(i, j)       the coriolis force on rotated grid
!
!   the following two dimensional arrays are nonzero in the triangle
!   n=1, ..., nlat and m less than or equal to n.
!
!     a(m, n), b(m, n)    spectral coefficients of the geopotential
!
!     br(m, n), bi(m, n)  spectral coefficients of the velocity
!     cr(m, n), ci(m, n)  vector [u(i, j), v(i, j)]
!
!
!     phlt(i)      the coefficients in the cosine series
!                  representation of the unrotated geopotential
!
program shallow

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

    use spherepack_precision, only: &
        wp, & ! working precision
        ip, & ! integer precision
        PI, &
        TWO_PI

    use type_ShallowWaterSolver, only: &
        ShallowwaterSolver

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter           :: NLON = 128 ! Number of longitudinal points
    integer(ip), parameter           :: NLAT = NLON/2+1 ! Number of latitudinal points
    integer(ip), parameter           :: NTRUNC = 42
    integer(ip), parameter           :: NMDIM = (NTRUNC+1)*(NTRUNC+2)/2
    integer(ip), parameter           :: nl = 91
    integer(ip)                      :: max_iter, mprint, i, j, ncycle
    integer(ip)                      :: temp_save_new, temp_save_now, old, now, new
    real(wp), dimension(NLON, NLAT)  :: uxact, vxact, pxact, u, v, p, f
    real(wp), dimension(NLON, NLAT)  :: ug, vg, pg, vrtg, divg, scrg1, scrg2
    real(wp)                         :: phlt(nl-2)
    real(wp)                         :: lhat, uhat, aa, uzero, pzero, HALF_PI, radian_unit, omega, alpha_in_degrees
    real(wp)                         :: alpha, fzero, dt, theta, sth
    real(wp)                         :: cth, cthclh, cthslh
    real(wp)                         :: clh, time, that, slh, htime
    real(wp)                         :: v2max, p2max, vmax, pmax
    real(wp), parameter              :: ZERO = 0.0_wp, HALF = 0.5_wp, ONE = 1.0_wp
    complex(wp), dimension(NMDIM)    :: vrtnm, divnm, pnm, scrnm
    complex(wp), dimension(NMDIM, 3) :: dvrtdtnm, ddivdtnm, dpdtnm
    type(ShallowWaterSolver)         :: solver
    character(len=:), allocatable    :: write_fmt

    write (stdout, '(/a)') '     shallow *** TEST RUN *** '

    !  Parameters for test
    HALF_PI = PI/2
    radian_unit = PI/180
    aa = 6.37122e+6_wp ! Earth radius
    omega = 7.292e-5_wp ! Rotation rate
    fzero = 2.0_wp * omega
    uzero = 40.0_wp
    pzero = 2.94e+4_wp
    alpha_in_degrees = 60.0_wp
    alpha = radian_unit * alpha_in_degrees
    dt = 300.0_wp ! Time step in seconds
    max_iter = nint(86400.0_wp * HALF/dt, kind=ip) ! Integration length in days
    mprint = max_iter/10

    !  Allocate memory. Setup spherical harmonic instance
    call solver%create(nlat=NLAT, nlon=NLON, ntrunc=NTRUNC, rsphere=aa)

    allocate (write_fmt, source=&
        '(a, i10, a, f10.2/, a, f10.0, a, i10/, a, i10, '&
        //'a, i10/, a, 1pe15.6, a, 1pe15.6, /a, 1pe15.6, a, 1pe15.6)')

    ! Compute the derivative of the unrotated geopotential
    ! p as a function of latitude
    block
        real(wp) :: cfn, dlath

        cfn = ONE / (nl - 1)
        dlath = PI / (nl - 1)
        do i=1, size(phlt)
            theta = real(i, kind=wp) * dlath
            uhat = solver%get_initial_velocity(uzero, HALF_PI-theta)
            phlt(i) = cfn * cos(theta) * uhat * (uhat/sin(theta) + aa*fzero)
        end do
    end block

    ! Compute sine transform of the derivative of the geopotential
    ! for the purpose of computing the geopotential by integration
    ! see equation (3.9) in reference [1] above
    call solver%sine_transform(phlt)

    ! Compute the cosine coefficients of the unrotated geopotential
    ! by the formal integration of the sine series representation
    do i=1, size(phlt)
        phlt(i) = -phlt(i)/i
    end do

    !     phlt(i) contains the coefficients in the cosine series
    !     representation of the unrotated geopotential that are used
    !     below to compute the geopotential on the rotated grid.
    !
    !     compute the initial values of  east longitudinal
    !     and latitudinal velocities u and v as well as the
    !     geopotential p and coriolis f on the rotated grid.
    block
        real(wp) :: cosa, sina, lambda_mesh, theta_mesh
        real(wp) :: lambda, cosl, sinl
        real(wp) :: sint, cost

        cosa = cos(alpha)
        sina = sin(alpha)
        lambda_mesh = TWO_PI/NLON
        theta_mesh = PI/(NLAT-1)

        do j=1, NLON
            lambda = real(j - 1, kind=wp) * lambda_mesh
            cosl = cos(lambda)
            sinl = sin(lambda)
            do i=1, NLAT
                !
                !     lambda is longitude, theta is colatitude, and pi/2-theta is
                !     latitude on the rotated grid. lhat and that are longitude
                !     and colatitude on the unrotated grid. see text starting at
                !     equation (3.10)
                !
                theta = real(i - 1, kind=wp) * theta_mesh
                sint = cos(theta)
                cost = sin(theta)
                sth = cosa*sint+sina*cost*cosl
                cthclh = cosa*cost*cosl-sina*sint
                cthslh = cost*sinl
                lhat = solver%atanxy(cthclh, cthslh)
                clh = cos(lhat)
                slh = sin(lhat)
                cth = clh*cthclh+slh*cthslh
                that = solver%atanxy(sth, cth)
                uhat = solver%get_initial_velocity(uzero, HALF_PI-that)
                pxact(j, i) = solver%cosine_transform(that, phlt)
                uxact(j, i) = uhat*(cosa*sinl*slh+cosl*clh)
                vxact(j, i) = uhat*(cosa*cosl*slh*sint-clh*sinl*sint+sina*slh*cost)
                f(j, i) = fzero*sth ! Coriolis
            end do
        end do
    end block

    vmax = ZERO
    pmax = ZERO
    v2max = ZERO
    p2max = ZERO

    do j=1, NLAT
        do i=1, NLON
            v2max = v2max + uxact(i, j)**2 + vxact(i, j)**2
            p2max = p2max + pxact(i, j)**2
            vmax = max(abs(uxact(i, j)), abs(vxact(i, j)), vmax)
            pmax = max(abs(pxact(i, j)), pmax)
        end do
    end do

    ! Initialize first time step
    u = uxact
    v = vxact
    p = pxact
    ug = u
    vg = v
    pg = p

    !  Compute spectral coeffs of initial vrt, div, p
    call solver%get_vrtdivspec(ug, vg, vrtnm, divnm)
    call solver%grid_to_spec(pg, pnm)

    ! Time step loop
    new = 1
    now = 2
    old = 3
    do ncycle=0, max_iter

        time = real(ncycle, kind=wp) * dt

        !  Inverse transform to get vort and phig on grid
        call solver%spec_to_grid(vrtnm, vrtg)
        call solver%spec_to_grid(pnm, pg)

        ! Compute u and v on grid from spectral coeffs of vort and div.
        call solver%get_uv(vrtnm, divnm, ug, vg)

        ! Calculate error statistics
        if (mod(ncycle, mprint) == 0) then

            call solver%spec_to_grid(divnm, divg)

            u = ug
            v = vg
            p = pg
            htime = time/3600.0_wp

            write (stdout, '(/a)') ' steady nonlinear rotated flow:'
            write (stdout, fmt=write_fmt) &
                ' cycle number              ', ncycle, &
                ' model time in  hours      ', htime, &
                ' time step in seconds      ', dt, &
                ' number of latitudes       ', NLAT, &
                ' number of longitudes      ', NLON, &
                ' max wave number           ', NTRUNC, &
                ' rotation rate        '     , omega, &
                ' mean height          '     , pzero, &
                ' maximum velocity     '     , uzero, &
                ' tilt angle           '     , alpha_in_degrees

            block
                real(wp) :: dvgm, dvmax, dpmax, evmax, epmax

                dvgm = ZERO
                dvmax = ZERO
                dpmax = ZERO
                evmax = ZERO
                epmax = ZERO

                do j=1, NLAT
                    do i=1, NLON
                        dvgm = max(dvgm, abs(divg(i, j)))
                        dvmax = dvmax+(u(i, j)-uxact(i, j))**2 + (v(i, j)-vxact(i, j))**2
                        dpmax = dpmax+(p(i, j)-pxact(i, j))**2
                        evmax = &
                            max(evmax, abs(v(i, j)-vxact(i, j)), abs(u(i, j)-uxact(i, j)))
                        epmax = max(epmax, abs(p(i, j)-pxact(i, j)))
                    end do
                end do

                dvmax = sqrt(dvmax/v2max)
                dpmax = sqrt(dpmax/p2max)
                evmax = evmax/vmax
                epmax = epmax/pmax

                write (stdout, fmt='(2(a, 1pe15.6)/, a, 1pe15.6)') &
                    ' max error in velocity', evmax, &
                    ' max error in geopot. ', epmax, &
                    ' l2 error in velocity ', dvmax, &
                    ' l2 error in geopot.  ', dpmax, &
                    ' maximum divergence   ', dvgm
            end block
        end if

        !  Compute right-hand sides of prognostic eqns
        scrg1 = ug * (vrtg + f)
        scrg2 = vg * (vrtg + f)

        call solver%get_vrtdivspec(scrg1, scrg2, ddivdtnm(:, new), dvrtdtnm(:, new))

        dvrtdtnm(:, new) = -dvrtdtnm(:, new)
        scrg1 = ug * (pg + pzero)
        scrg2 = vg * (pg + pzero)

        call solver%get_vrtdivspec(scrg1, scrg2, scrnm, dpdtnm(:, new))

        dpdtnm(:, new) = -dpdtnm(:, new)
        scrg1 = pg + HALF * (ug**2 + vg**2)

        call solver%grid_to_spec(scrg1, scrnm)

        associate (lap => solver%LAPLACIAN_COEFFICIENT_MULTIPLIERS)
            ddivdtnm(:, new) = ddivdtnm(:, new) - lap * scrnm
        end associate

        ! Update vrt and div with third-order adams-bashforth
        ! Forward Euler, then 2nd-order Adams-Bashforth time steps to start
        select case (ncycle)
            case (0)
                dvrtdtnm(:, now) = dvrtdtnm(:, new)
                dvrtdtnm(:, old) = dvrtdtnm(:, new)
                ddivdtnm(:, now) = ddivdtnm(:, new)
                ddivdtnm(:, old) = ddivdtnm(:, new)
                dpdtnm(:, now) = dpdtnm(:, new)
                dpdtnm(:, old) = dpdtnm(:, new)
            case (1)
                dvrtdtnm(:, old) = dvrtdtnm(:, new)
                ddivdtnm(:, old) = ddivdtnm(:, new)
                dpdtnm(:, old) = dpdtnm(:, new)
        end select

        vrtnm = vrtnm + dt * ( &
            (23.0_wp/12) * dvrtdtnm(:, new) &
            - (16.0_wp/12) * dvrtdtnm(:, now) &
            + (5.0_wp/12) * dvrtdtnm(:, old))

        divnm = divnm + dt*( &
            (23.0_wp/12) * ddivdtnm(:, new) &
            - (16.0_wp/12) * ddivdtnm(:, now) &
            + (5.0_wp/12) * ddivdtnm(:, old))

        pnm = pnm + dt*( &
            (23.0_wp/12) * dpdtnm(:, new) &
            - (16.0_wp/12) * dpdtnm(:, now) &
            + (5.0_wp/12) * dpdtnm(:, old))

        !  Switch indices
        temp_save_new = new
        temp_save_now = now
        new = old
        now = temp_save_new
        old = temp_save_now
    end do

    !  Release memory
    call solver%destroy()
    deallocate (write_fmt)

end program shallow


C     Gauss-Seidel Matrix solve method
      PROGRAM GAUSS_SEIDEL_TEST
        PARAMETER (E = 0.001)
        PARAMETER (N = 3)
        REAL A, B, X
        DIMENSION A(N,N), B(N), X(N)
        DATA A /1., -0.15, -0.4, 0.1, 1., -0.025, 0.225, 0.2, 1./,
     &       B /0.1, 0.9, 0.8/,
     &       X /N * 0/

        CALL GAUSS_SEIDEL(N, E, A, B, X)

C       Print results:
        PRINT 510, "A"
        DO 100 I = 1, N
          PRINT 520, (A(I, J), J = 1, N)
100     CONTINUE

        PRINT 500, "B"
        PRINT 520, (B(I), I = 1, N)

        PRINT 500, "X"
        PRINT 520, (X(I), I = 1, N)

500     FORMAT (1X, /A, 1X, "VECTOR:")
510     FORMAT (1X, /A, 1X, "MATRIX:")
520     FORMAT (100(1X, F6.3))
      END


      subroutine  near3 (xg, yg, zg, node)
!***********************************************************************
! $Id: near3.f,v 1.1 2006/05/17 15:23:22 zvd Exp $
!***********************************************************************
!  Copyright, 1993, 2005,  The  Regents of the University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!
! PURPOSE
!
! Determine the nearest node to a given set of x, y, z coordinates.
!
!***********************************************************************
!
! REVISION HISTORY
!
! This routine was origianally implemented in FEHM by G. Zyvoloski.
! Modified 16-Sep-05 for use with PLUMECALC V2.1 by Z. Dash
!
!***********************************************************************
!     DEFINITION of variables
!
!     Identifier      Type     Description
!
!     xg              real*8   x coordinate position
!     yg              real*8   y coordinate position
!     zg              real*8   z coordinate position
!     node            integer  number of node nearest to coordinate
!                                position
!     n_grid_points   integer  number of points (cells) in the grid
!     x, y, z         real*8   coordinates of each grid cell (center of
!                                cell), arrays of size n_grid_points
!     dismin          real*8   minimum distance between given
!                                coordinates and a node
!     dist            real*8   distance between given coordinates and
!                                node
!     i               integer  loop index
!
!***********************************************************************
!     PSEUDOCODE
!
!     BEGIN  near3
!
!     initialize minimum distance between nodes to a large value
!
!     FOR each node
!         compute the distance between the node and the given x,y
!            z coordinates
!
!         IF the distance between the current node and the coordinates
!            is less than the minimum distance
!            set minimum distance to current distance
!            set node to the current node
!         ENDIF
!
!     ENDFOR
!
!     END  near3
!
!***********************************************************************

      use comgrid
      implicit none

      real*8 dismin, dist, xg, yg, zg
      integer i, node

      dismin = 1.0d+10

      do i = 1, n_grid_points
         dist = sqrt((x(i) - xg)**2 + (y(i) - yg)**2 + (z(i) - zg)**2)
         if (dist .lt. dismin)  then
            dismin = dist
            node   =  i
         end if
      end do

      end


module funcs

implicit none

contains

pure real function avrg(alist)
  real, intent(in) :: alist(:)

  avrg = sum(alist) / real(size(alist))
end function avrg

elemental real function arctan(x)
  use, intrinsic :: ieee_arithmetic, only: ieee_value, ieee_quiet_nan

  real, intent(in) :: x
  real :: prevxp, presxp, term, y
  real :: nan
  real, parameter :: pi = 4.*atan(1.)
  integer :: i

  nan = ieee_value(0., ieee_quiet_nan)

  if (x < 0.) then
    arctan = nan
    return
  endif

  arctan = 0.

  if (x - 1. > 0.) then
    term = -1. / x
    arctan = pi/2
  else
    term = x
  endif

  prevxp = 1.
  y = term ** 2.

  do while(term-0.00005 >= 0. .or. -term - 0.00005 >= 0.)
    arctan = arctan + term
    presxp = prevxp + 2.

    term = -prevxp / presxp * y * term
    prevxp = presxp
  enddo

end function arctan

end module funcs


program Goldbach_Conjecture_100
implicit none
    integer :: i1 , j1 , o , i2 , j2 , n ,x=6

do while (x <= 100)
    do n = 2 , x/2
        j1 = sqrt(real(n))
        i1 = 2
        do while(i1<=j1 .and. mod(n,i1)/=0)
            i1 = i1 + 1
        end do

        if (i1>j1) then
            o = x - n
            j2 = sqrt(real(o))
            i2 = 2
            do while(i2<=j2 .and. mod(o,i2)/=0)
                i2 = i2 + 1
            end do

            if (i2>j2) then
                write(*,*) x,'=',n,'+',o
            end if
        end if
    end do
    x = x + 2
end do
end


      REAL FUNCTION US(RLATD)
C
C SPECIFIES ZONALLY SYMMETRIC U FIELD AS A FUNCTION OF LATITUDE
C (BUMP FUNCTION).  REQUIRES REAL FUNCTION BF2
C USED FOR TEST CASE 3 (SEE PAPER BY BROWNING ET AL.)
C
C CALLED BY: FU, INIT
C CALLS: BF2
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Common Blocks ----------------------------------------------------
C
C Constants
      INCLUDE 'consts.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C LATITUDE
      REAL RLATD
C
C------ Local Parameters -----------------------------------------------
C
      REAL PI
      PARAMETER (PI=3.141592653589793)
C
C------ Local Variables ------------------------------------------------
C
C     NORTH-SOUTH EXTENT OF FLOW FIELD
      REAL RLATE,RLATB
C     FLOW PROFILE TEMPORARIES
      REAL XE,X
C     MAX AMPLITUDE OF FLOW (12 DAY ROTATION SPEED)
      REAL UBAR
C
C----- External Functions ----------------------------------------------
C
C     AUXILIARY FUNCTION (SEE BELOW)
C
      EXTERNAL BF2
      REAL BF2
C
C----- Executable Statements -------------------------------------------
C
      UBAR  = (2.0*PI*A)/(12.0*24.0*3600.0)
      RLATB = -PI/6.
      RLATE =  PI/2.
      XE    = 3.0E-1
      X     = XE*(RLATD-RLATB)/(RLATE-RLATB)
      US    = UBAR*BF2(X)*BF2(XE-X)*EXP(4.0/XE)
      RETURN
      END


!*==HOURANGLE.spg  processed by SPAG 6.55Dc at 23:48 on  8 Aug 2008

!$author: fredfox $
!$date: 2002-09-09 16:09:16 $
!$revision: 1.5 $
!$source: /weru/cvs/weps/weps.src/util/solar/hourangle.for,v $

FUNCTION hourangle(latitude, dec, riseangle, degtorad, radtodeg)
IMPLICIT NONE
!*--HOURANGLE10
!INCLUDE 'p1unconv.inc'
!
!*** Start of declarations rewritten by SPAG
!
! PARAMETER definitions
!
REAL,PARAMETER :: dlat_rad_lim = 1.57079
!
! Dummy arguments
!
REAL :: dec,latitude,riseangle
REAL :: degtorad, hourangle, radtodeg
!! from p1unconv.inc in UPGM/WEPS
!parameter (degtorad = 0.017453293) !pi/180
!parameter (radtodeg = 57.2957795) !180/pi

!
! Local variables
!
REAL :: coshr,dec_rad,dlat_rad
!
!*** End of declarations rewritten by SPAG
!

!     + + + purpose + + +
!     this function calculates the hour angle (degrees)
!     of sunrise (-), sunset (+) based on the declination of the earth

!     + + + keywords + + +
!     sunrise sunset hourangle

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     latitude   - latitude of the site, degrees (north > 0, south < 0)
!     dec    - declination of earth with respect to the sun (degrees)
!     riseangle - angle of earths rotation where sunrise occurs
!                 this varies depending on whether you are calculating
!                 direct beam, civil twilight, nautical twilight or
!                 astronomical twilight hourangle

!     + + + local variables + + +

!      parameter( dlat_rad_lim = 1.570796327 ) ! pi/2

!     + + + local definitions + + +
!     coshr   - cosine of hour angle at sunrise
!     dlat_rad - latitude of site, converted to radians
!     dec_rad - declination of earth wrt the sun (radians)

!     + + + common blocks + + +

!     + + + end specifications + + +

!     convert to radians
dlat_rad = latitude*degtorad                  ! pi/2 minus a small bit
dec_rad = dec*degtorad

!     calculate the cosine of hour angle (h) at sunset
!     to get the sunrise hour angle, take the negative.
!     using the equation from "solar thermal energy systems,
!     howell, bannerot, vliet, 1982, page 51 equation 3-4)
!     modified to account for atmospheric refraction as in
!     noaa document (it just indicates that the sun is seen
!     before it physically is above the horizon)
!     ie. not at 90 degrees, but 90.833 degrees
!     this expression is undefined at 90 and -90 degrees. if
!     roundoff error pushes it beyond the answer flips. limit
!     set here to get correct answer at 90 and -90 degrees.
dlat_rad = max(-dlat_rad_lim,min(dlat_rad_lim,dlat_rad))
coshr = cos(riseangle*degtorad)/(cos(dlat_rad)*cos(dec_rad)) - tan(dlat_rad)    &
      & *tan(dec_rad)

!     check for artic circle conditions
IF (coshr.GE.1.0) THEN
  hourangle = 0.0                  !sunrise occurs at solar noon
ELSE IF (coshr.LE.-1.0) THEN
  hourangle = 180.0                !the sun is always above the horizon
ELSE
  hourangle = acos(coshr)*radtodeg
END IF

END FUNCTION hourangle


      COMPLEX FUNCTION ciagree(r, x, n)
C     Compute the index of agreement between two vectors.
C     Complex valued variant 11 April 1995
C     Robert Grumbine

      IMPLICIT none

      INTEGER n
      COMPLEX r(0:n), x(0:n)

      COMPLEX rbar, sr2, sx2, srx, spx
      INTEGER i

      sr2 = 0.0
      sx2 = 0.0
      srx = 0.0
      spx = 0.0
      rbar = 0.0

      DO i = 0, n
        rbar = rbar + r(i)
      ENDDO
      rbar = rbar / FLOAT (n)

      DO i = 0, n
          sr2 = sr2 + r(i)*CONJG(r(i))
          sx2 = sx2 + x(i)*CONJG(x(i))
          srx = srx + r(i)*x(i)
          spx = spx + (ABS(x(i)-rbar) + ABS(r(i)-rbar) )**2
      ENDDO

      IF (spx .NE. 0.0) THEN
        ciagree = 1.0 - (sx2 - 2.*srx + sr2) / spx
       ELSE
        ciagree = 0.0
      ENDIF

      RETURN
      END


SUBROUTINE asym_gauss ( npoints, hw1e, e_asym, wvlarr, specarr, specmod)

  ! =========================================================================
  !
  ! Convolves input spectrum with an asymmetric Gaussian slit function of
  ! specified HW1E (half-width at 1/e intensity) and asymmetry factor E_ASYM.
  !
  ! The asymetric Gaussian g(x) is defined as
  !                   _                                  _
  !                  |               x^2                  |
  !      g(x) =  EXP | - -------------------------------- |
  !                  |_   (hw1e * (1 + SIGN(x)*e_aym))^2 _|
  !
  ! g(x) becomes symmetric for E_ASYM = 0.
  !
  ! =========================================================================

  USE OMSAO_precision_module

  IMPLICIT NONE

  ! ===============
  ! Input variables
  ! ===============
  INTEGER (KIND=i4),                      INTENT (IN) :: npoints
  REAL    (KIND=r8),                      INTENT (IN) :: hw1e, e_asym
  REAL    (KIND=r8), DIMENSION (npoints), INTENT (IN) :: wvlarr, specarr

  ! ================
  ! Output variables
  ! ================
  REAL (KIND=r8), DIMENSION (npoints), INTENT (OUT) :: specmod

  ! ===============
  ! Local variables
  ! ===============
  INTEGER (KIND=i4)                      :: i, j, j1, j2, nslit, mslit, sslit, eslit, locerrstat
  REAL    (KIND=r8)                      :: delwvl, slitsum,  maxslit
  REAL    (KIND=r8), DIMENSION (npoints) :: slit, locwvl, locsli
  INTEGER (KIND=i4), DIMENSION (npoints) :: idx

  REAL (KIND=r8) :: signdp
  EXTERNAL signdp

  ! --------------------------------------------------------
  ! Initialize output variable (default for "no convolution"
  ! --------------------------------------------------------
  specmod(1:npoints) = specarr(1:npoints)

  ! -----------------------------------------------
  ! No Gaussian convolution if Halfwidth @ 1/e is 0
  ! -----------------------------------------------
  IF ( hw1e == 0.0_r8 ) RETURN

  ! --------------------------------------------------------------
  ! Find the number of spectral points that fall within a Gaussian
  ! slit function with values >= 0.001. Remember that we have an
  ! asymmetric Gaussian, so we create a wavelength array symmetric
  ! around 0. The spacing is provided by the equidistant WVLARR.
  ! --------------------------------------------------------------
  delwvl = wvlarr(2) - wvlarr(1) ; locsli = 0.0_r8
  DO i = -npoints/2, npoints/2
     j = MIN ( i + npoints/2 + 1, npoints )
     locwvl(j) = delwvl * REAL(i,KIND=r8)
     locsli(j) = &
          EXP(-(locwvl(j))**2 / ( hw1e * (1.0_r8 + signdp(locwvl(j))*e_asym) )**2)
  END DO

  ! ------------------------------------------------------------------------
  ! Find the array entries that mark the region of SLIT >= 0.0001*MAX(SLIT).
  ! We start by initializing the auxilliary IDX as IDX(n) = n. We then set
  ! all those entries to 0 that are outside the accepted minimum value of
  ! the slit function. The start and end indices simply follow as the
  ! minimum and maximum values of IDX where IDX /= 0.
  ! ------------------------------------------------------------------------
  maxslit = MAXVAL(locsli(1:npoints))
  sslit = 0 ; eslit = 0 ; idx = (/ (i, i = 1, npoints) /)
  WHERE ( locsli < 0.001_r8*maxslit )
     idx = 0
  END WHERE
  sslit = MINVAL(MINLOC( idx, MASK = (idx /= 0) ))
  eslit = MAXVAL(MAXLOC( idx, MASK = (idx /= 0) ))

  ! ----------------------------------------------------------
  ! Compute number of slit function points, and the final slit
  ! function array; the latter will be normalized to 1.
  ! ----------------------------------------------------------
  nslit = eslit - sslit + 1
  slit(1:nslit) = locsli(sslit:eslit)

  ! ------------------------------------------------------------------
  ! The original summation - now superceeded by the integration scheme
  ! ------------------------------------------------------------------
  !  slitsum = SUM(slit(1:nslit))
  ! ------------------------------------------------------------------

  ! ----------------------------------------------------------------
  ! Folding (a.k.a. integration) of solar spectrum and slit function
  ! ----------------------------------------------------------------
  CALL davint ( &
       locwvl(sslit:eslit), slit(1:nslit), nslit, locwvl(sslit), locwvl(nslit), &
       slitsum, locerrstat)
  IF ( slitsum > 0.0_r8 ) slit(1:nslit) = slit(1:nslit) / slitsum

  ! --------------------------------------------------------
  ! Find the maximum of the slit. Note that since we may be
  ! with an asymmetric Gaussian, the maximum must not always
  ! be in the center of the Gaussian function.
  ! --------------------------------------------------------
  mslit = MAXVAL( MAXLOC ( slit(1:nslit) ) )

  specmod(1:npoints) = 0.0_r8 !specarr(1:npoints)
  !IF ( slitsum > 0.0_r8 ) specmod(1:npoints) = specmod(1:npoints) / slitsum

  ! ---------------------------------------------------------------
  ! Convolve spectrum. First do the middle part, where we have full
  ! overlap coverage of the slit function. Again, remember the
  ! asymmetry of the Gaussian, which makes impossible a simple
  ! 50-50 division of the summation interval.
  ! ---------------------------------------------------------------

  ! Make a local copy of the NSLIT spectrum points to be convolved
  ! with the slit function. The spectrum points to be convolved are
  ! arranged such that the updated index corresponds to the maximum
  ! of the slit function (MSLIT). For simplicity we reflect the
  ! spectrum at the array end points.

  ! ----------------------------------------------------
  ! Loop over all points of the spectrum to be convolved
  ! ----------------------------------------------------
  specmod(1:npoints) = 0.0_r8 !specarr(1:npoints)
  DO i = 1, npoints
     locsli(1:nslit) = 0.0_r8
     ! First do the right half of the slit function
     DO j = mslit, nslit
        j1 = i+(j-mslit) ; IF ( j1 > npoints ) j1 = npoints - MOD(j1, npoints)
        locsli(j) = specarr(j1)
        idx(j) = j1
     END DO
     ! Now the left half of the slit function
     DO j = mslit-1, 1, -1
        j2 = i-((mslit-1)-j) - 1 ; IF ( j2 < 1 ) j2 = ABS(j2) + 2
        locsli(j) = specarr(j2)
        idx(j) = j2
     END DO
     specmod(i) = DOT_PRODUCT(slit(1:nslit), locsli(1:nslit))
     locsli(1:nslit) =locsli(1:nslit) * slit(1:nslit)

     CALL davint ( &
          locwvl(sslit:eslit), locsli(1:nslit), nslit, locwvl(sslit), locwvl(eslit), &
          specmod(i), locerrstat)
  END DO

  RETURN
END SUBROUTINE asym_gauss

SUBROUTINE gauss (wvlarr, specarr, specmod, npoints, hw1e)

  !     convolves input spectrum with gaussian slit function of specified
  !     hw1e (half-width at 1/e intensity).

  USE OMSAO_precision_module
  IMPLICIT NONE

  ! ===============
  ! Input variables
  ! ===============
  INTEGER (KIND=i4),                      INTENT (IN)    :: npoints
  REAL    (KIND=r8),                      INTENT (IN)    :: hw1e
  REAL    (KIND=r8), DIMENSION (npoints), INTENT (IN)    :: wvlarr, specarr

  ! ================
  ! Output variables
  ! ================
  REAL (KIND=r8), DIMENSION (npoints), INTENT (OUT) :: specmod

  ! ===============
  ! Local variables
  ! ===============
  INTEGER (KIND=i4)                      :: nhi, nlo, i, j, nslit
  REAL    (KIND=r8)                      :: emult, delwvl, slitsum, slit0
  REAL    (KIND=r8), DIMENSION (npoints) :: slit

  ! ----------------------------------------------------------------
  ! Initialization of output variable (default for "no convolution")
  ! ----------------------------------------------------------------
  specmod(1:npoints) = specarr(1:npoints)

  ! --------------------------------------
  ! No convolution if halfwidth @ 1/e is 0
  ! --------------------------------------
  IF ( hw1e == 0.0_r8 ) RETURN

  emult = -1.0_r8 / ( hw1e * hw1e )
  delwvl = wvlarr(2) - wvlarr(1)

  !     Apply slit function convolution

  !     Calculate slit function values out to 0.001 times x0 value,
  !     normalize so that sum = 1.

  slitsum = 1.0_r8  ;  slit0 = 1.0_r8
  i = 1  ;  nslit = 0
  numslit: DO WHILE ( nslit < npoints )
     slit (i) = EXP (emult * (delwvl * REAL(i,KIND=r8))**2)
     slitsum = slitsum + 2.0_r8 * slit (i)
     IF (slit (i) / slit0 <= 0.001_r8 .OR. i == npoints ) THEN
        nslit = i
        EXIT numslit
     END IF
     i = i + 1
  END DO numslit

  slit0 = slit0 / slitsum
  slit(1:nslit) = slit(1:nslit) / slitsum

  !     Convolve spectrum.  reflect at endpoints.
  specmod(1:npoints) = slit0 * specarr(1:npoints)
  DO i = 1, npoints
     DO j = 1, nslit
        nlo = MAXVAL( (/ 1, ABS(i - j) /) )
        nhi = i + j
        IF ( nhi > npoints ) nhi = MAXVAL ( (/ 1, 2*npoints-nhi /) )
        specmod(i) = specmod(i) + slit(j) * ( specarr(nlo) + specarr(nhi) )
     END DO
  END DO

  RETURN
END SUBROUTINE gauss