program g
    use utilities
    use percolation
    implicit none

    character(len=:), allocatable :: filename
    integer :: num_samples, i, j, fileunit, L, firstindex, lastindex, num_sizes
    real(kind=dp), dimension(:), allocatable :: cluster_number_densities, sizes
    real(kind=dp) slope, const, tau

    num_samples = 1000

    do i = 4, 9
        L = 2**i
        call cluster_number_density(pc, L, num_samples, sizes, cluster_number_densities)
        num_sizes = size(sizes)

        filename = "tmp/g_" // stringfromint(i) // ".dat"
        open(unit=fileunit, file=filename, status="replace")
        do j = 1, num_sizes
            write(unit=fileunit,fmt=*) sizes(j), cluster_number_densities(j)
        end do
        close(unit=fileunit)
    end do

    firstindex = int(0.2*num_sizes + 0.5)
    lastindex  = int(0.8*num_sizes + 0.5)

    call linfit(log(sizes(firstindex:lastindex)), log(cluster_number_densities(firstindex:lastindex)), slope, const)

    tau = -slope

    filename = "tmp/g_9_approx.dat"
    open(unit=fileunit, file=filename, status="replace")
    do j = 1, num_sizes
        write(unit=fileunit, fmt=*) sizes(j), sizes(j)**slope * exp(const)
    end do
    close(unit=fileunit)

    filename = "tmp/g_9_tau.dat"
    open(unit=fileunit, file=filename, status="replace")
    write(unit=fileunit, fmt="(f0.3)") tau
    close(unit=fileunit)

end program g


    Program zgejsv_example

!     ZGEJSV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen
      Use lapack_interfaces, Only: ddisna, zgejsv
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: eps, serrbd
      Integer :: i, ifail, info, j, lda, ldu, ldv, lrwork, lwork, m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), cwork(:), u(:, :), v(:, :)
      Real (Kind=dp), Allocatable :: rcondu(:), rcondv(:), rwork(:), sva(:)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, epsilon, nint
!     .. Executable Statements ..
      Write (nout, *) 'ZGEJSV Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      ldu = m
      ldv = n
      lwork = 5*n + n*n + 1000
      lrwork = n + 2*m + 7
      Allocate (a(lda,n), rcondu(m), rcondv(m), sva(n), u(ldu,n), v(ldv,n), &
        cwork(lwork), rwork(lrwork), iwork(m+3*n+3))

!     Read the m by n matrix A from data file
      Read (nin, *)((a(i,j),j=1,n), i=1, m)

!     Compute the singular values and left and right singular vectors
!     of A (A = U*S*V^T, m.ge.n)
      Call zgejsv('E', 'U', 'V', 'R', 'N', 'N', m, n, a, lda, sva, u, ldu, v, &
        ldv, cwork, lwork, rwork, lrwork, iwork, info)

      If (info==0) Then

!       Compute the approximate error bound for the computed singular values
!       using the 2-norm, s(1) = norm(A), and machine precision, eps.
        eps = epsilon(1.0E0_dp)
        serrbd = eps*sva(1)

!       Print solution
        If (abs(rwork(1)-rwork(2))<2.0_dp*eps) Then
!         No scaling required
          Write (nout, '(1X,A)') 'Singular values'
          Write (nout, 100)(sva(j), j=1, n)
        Else
          Write (nout, '(/1X,A)') 'Scaled singular values'
          Write (nout, 100)(sva(j), j=1, n)
          Write (nout, '(/1X,A)') 'For true singular values, multiply by a/b,'
          Write (nout, 140) ' where a = ', rwork(1), ' and b = ', rwork(2)
        End If

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        Write (nout, *)
        Flush (nout)
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', m, n, u, ldu, &
          'Left singular vectors', ifail)

        Write (nout, *)
        Flush (nout)
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', n, n, v, ldv, &
          'Right singular vectors', ifail)

!       Call DDISNA to estimate reciprocal condition numbers for
!       the singular vectors.

        Call ddisna('Left', m, n, sva, rcondu, info)
        Call ddisna('Right', m, n, sva, rcondv, info)

!       Print the approximate error bounds for the singular values
!       and vectors.
        Write (nout, *)
        Write (nout, '(/1X,A)') &
          'Estimate of the condition number of column equilibrated A'
        Write (nout, 110) rwork(3)
        Write (nout, '(/1X,A)') &
          'Error estimates (as multiples of machine precision):'
        Write (nout, '(/1X,A)') '  for the singular values'
        Write (nout, 120) nint(serrbd/epsilon(1.0E0_dp))
        Write (nout, '(/1X,A)') '  for left singular vectors'
        Write (nout, 120)(nint(serrbd/rcondu(i)/epsilon(1.0E0_dp)), i=1, n)
        Write (nout, '(/1X,A)') '  for right singular vectors'
        Write (nout, 120)(nint(serrbd/rcondv(i)/epsilon(1.0E0_dp)), i=1, n)
      Else
        Write (nout, 130) 'Failure in ZGEJSV. INFO =', info
      End If

100   Format (3X, 8F8.4)
110   Format (4X, 1P, E11.2)
120   Format (4X, 6I4)
130   Format (1X, A, I4)
140   Format (1X, 2(A,1P,E13.5))
    End Program


program problem8
  implicit none
  integer                  :: i,j,temp1
  integer, parameter       :: window=13,n=1000
  integer*16, dimension(n) :: numbers
  integer*16               :: temp2,best=-1

  open(33,file='./data/problem8.dat')
  read(33,*) numbers

  do i=1,n

     temp1=(i+window-1)
     if (temp1 .le. n) then
        j=temp1
     else
        j=n
     end if

     temp2=product(numbers(i:j))
     if (temp2 .gt. best) then
        best=temp2
     end if

  end do

  print *, best

end program problem8


!********************************************************************************
!   FPML_DRIVER: Driver Program for FPML
!   Author: Thomas R. Cameron, Davidson College
!   Last Modified: 1 November 2018
!********************************************************************************
! Loads polynomial stored in data_files and computes the roots of said polynomial
! and returns the results along with backward error and condtion numbers into
! data_files/results.dat. The polynomial should be stored with degree on first
! line, then subsequent lines should contain the coefficients from leading to
! constant.
!********************************************************************************
program fpml_driver
    use fpml
    implicit none
    ! read in variables
    character(len=32)                           :: arg, poly_file
    integer                                     :: flag
    real(kind=dp)                               :: aux
    ! testing variables
    integer                                     :: deg, i, clock_rate, clock_start, clock_stop
    ! method variables
    integer, parameter                          :: itmax=30
    integer, dimension(:), allocatable          :: conv
    real(kind=dp), dimension(:), allocatable    :: berr, cond
    complex(kind=dp), dimension(:), allocatable :: p, roots

    ! read in optional arguments
    call get_command_argument(1,arg,status=flag)
    if(flag==0) then
        ! load polynomial
        read(arg, '(A)') poly_file
        write(*,*) 'Starting: Running on '//poly_file
        open(unit=1,file="data_files/"//poly_file, err=10, status='OLD')
        read(1,*) deg
        allocate(p(deg+1), roots(deg), berr(deg), cond(deg), conv(deg))
        do i=1, deg+1
            read(1,*) aux
            p(i) = aux
        end do
        ! run main in fpml
        open(unit=2,file="data_files/results.dat")
        write(2,'(A)') 'root_real, root_imag, berr, cond'
        call system_clock(count_rate=clock_rate)
        call system_clock(count=clock_start)
        call main(p, deg, roots, berr, cond, conv, itmax)
        call system_clock(count=clock_stop)
        ! record time and other results
        write(*,'(A)', advance='no') 'Elapsed Time = '
        write(*,'(ES15.2)') dble(clock_stop-clock_start)/dble(clock_rate)
        do i=1,deg
            write(2,'(ES15.2)', advance='no') dble(roots(i))
            write(2,'(A)', advance='no') ','
            write(2,'(ES15.2)', advance='no') aimag(roots(i))
            write(2,'(A)', advance='no') ','
            write(2,'(ES15.2)', advance='no') berr(i)
            write(2,'(A)', advance='no') ','
            write(2,'(ES15.2)') cond(i)
        end do
        ! deallocate and close files
        deallocate(p, roots, berr, cond, conv)
        close(1)
        close(2)
        write(*,*) 'Finished: Results are located in data_files/results.dat.'
        return
        ! statement only for poly_file open error
        10  write(*,*) 'Warning: File does not exist.'
        return
    else
        ! poly1.dat
        write(*,*) 'Warning: No file was given; running on poly1.dat.'
        open(unit=1,file="data_files/poly1.dat", status='OLD')
        read(1,*) deg
        allocate(p(deg+1), roots(deg), berr(deg), cond(deg), conv(deg))
        do i=1, deg+1
            read(1,*) aux
            p(i) = aux
        end do
        ! run main in fpml
        open(unit=2,file="data_files/results.dat")
        write(2,'(A)') 'root_real, root_imag, berr, cond'
        call system_clock(count_rate=clock_rate)
        call system_clock(count=clock_start)
        call main(p, deg, roots, berr, cond, conv, itmax)
        call system_clock(count=clock_stop)
        ! record time and other results
        write(*,'(A)', advance='no') 'Elapsed Time = '
        write(*,'(ES15.2)') dble(clock_stop-clock_start)/dble(clock_rate)
        do i=1,deg
            write(2,'(ES15.2)', advance='no') dble(roots(i))
            write(2,'(A)', advance='no') ','
            write(2,'(ES15.2)', advance='no') aimag(roots(i))
            write(2,'(A)', advance='no') ','
            write(2,'(ES15.2)', advance='no') berr(i)
            write(2,'(A)', advance='no') ','
            write(2,'(ES15.2)') cond(i)
        end do
        ! deallocate and close files
        deallocate(p, roots, berr, cond, conv)
        close(1)
        close(2)
        write(*,*) 'Finished: Results are located in data_files/results.dat.'
        return
    end if
end program fpml_driver


program FIRDMAIN

  implicit none

  ! LOCAL SCALARS
  integer :: flag,ftype,i,me,mi,n,fcnt
  logical :: verbose
  real(8) :: epsfeas,epsopt,f,feas

  ! LOCAL ARRAYS
  real(8), allocatable :: l(:), u(:), x(:)

  n  = 2
  me = 0
  mi = 1

  allocate(x(n),l(n),u(n))

  x(1) = 30.0D0
  x(2) = 30.0D0

  l(1) = 0.0D+00
  l(2) = 0.0D+00
  u(1) = 1.0D+20
  u(2) = 1.0D+20

  verbose = .true.

  epsfeas = 1.0D-8
  epsopt  = 1.0D-4

  ftype = 2

  call fird(n,x,l,u,me,mi,evalf,evalc,evaljac,verbose,ftype, &
       epsfeas,epsopt,f,feas,fcnt,flag)

  deallocate(x,l,u)

contains

  !------------------------------------------------------------!
  ! SUBROUTINE EVALF                                           !
  !                                                            !
  ! Defines the objetive function.                             !
  !                                                            !
  !------------------------------------------------------------!

  subroutine evalf(n,x,f,flag)

    implicit none

    ! SCALAR ARGUMENTS
    integer :: flag,n
    real(8) :: f

    ! ARRAY ARGUMENTS
    real(8) :: x(n)

    intent(in ) :: n,x
    intent(out) :: f,flag

    ! Interface

    interface
       SUBROUTINE MVNDST( N, LOWER, UPPER, INFIN, CORREL, MAXPTS, &
            ABSEPS, RELEPS, ERROR, VAL, INFORM )

         integer :: N, INFORM, MAXPTS
         real(8) :: ABSEPS, RELEPS, VAL, ERROR

         integer :: INFIN(N)
         real(8) :: LOWER(N), UPPER(N), CORREL((N - 1) * N / 2)

         intent(in ) :: N, MAXPTS, INFIN, LOWER, UPPER, CORREL, &
                        ABSEPS, RELEPS
         intent(out) :: INFORM, VAL, ERROR

       end SUBROUTINE MVNDST
    end interface

    ! LOCAL SCALARS
    integer :: i,j
    real(8) :: error,val,releps,abseps

    ! LOCAL ARRAYS
    real(8) :: correl((n - 1) * n / 2),l(n),u(n)
    integer :: infty(n)
    real(8) :: SIG(n,n), A(n,n), B(n), MU(n)

    ! Mu

    MU(:) = (/ 180.0D0, 162.0D0 /)

    ! Matrix A

    A(:,1) = (/ 2.0D0, 3.0D0 /)
    A(:,2) = (/ 6.0D0, 3.0D0 /)

    ! Covariance Matrix

    SIG(:,1) = (/ 144.0D0, 80.0D0 /)
    SIG(:,2) = (/  80.0D0, 81.0D0 /)

    ! Affine transformation

    B(:) = (/ (1.0D0 / 12.0D0), (1.0D0 / 9.0D0) /)

    do i = 1,n
       u(i) = - MU(i)
       do j = 1,n
          u(i) = u(i) + A(i,j) * x(j)
       end do
       u(i) = B(i) * u(i)
    end do

    do i = 1, n
       infty(i) = 0
    end do

    ! This multiplication is for inserting ones in the diagonal

    do j = 1, n
       do i = j + 1, n
          correl(j + (i - 1) * (i - 2) / 2) = SIG(i,j) * B(i) * B(j)
       end do
    end do

    releps = 5.0D-05

    abseps = 0.0D0

    flag = 0

    call mvndst(n,l,u,infty,correl,5000 * n * n * n,abseps,releps, &
         error,f,flag)

    f = - f

  end subroutine evalf

  !------------------------------------------------------------!
  ! SUBROUTINE EVALC                                           !
  !                                                            !
  ! Defines the contraints.                                    !
  !                                                            !
  !------------------------------------------------------------!

  subroutine evalc(n,x,ind,c,flag)

  ! SCALAR ARGUMENTS
  integer :: flag,ind,n
  real(8) :: c

  ! ARRAY ARGUMENTS
  real(8) :: x(n)

  intent(in ) :: ind,n,x
  intent(out) :: c,flag

  flag = 0

  if ( ind .eq. 1 ) then
     c = 2.0D0 * x(1) + 3.0D0 * x(2) - 140.0D0
  else
     flag = 1
  end if

  end subroutine evalc

  !------------------------------------------------------------!
  ! SUBROUTINE EVALJAC                                         !
  !                                                            !
  ! Defines the Jacobian of the constraints.                   !
  !                                                            !
  !------------------------------------------------------------!

  subroutine evaljac(n,x,ind,jcvar,jcval,jcnnz,flag)

    ! SCALAR ARGUMENTS
    integer :: flag,ind,jcnnz,n

    ! ARRAY ARGUMENTS
    integer :: jcvar(n)
    real(8) :: jcval(n),x(n)

    intent(in ) :: ind,n,x
    intent(out) :: flag,jcnnz,jcval,jcvar

    flag = 0

    if ( ind .eq. 1 ) then
       jcnnz = 2
       jcvar(1) = 1
       jcval(1) = 2.0D0
       jcvar(2) = 2
       jcval(2) = 3.0D0
    else
       flag = 1
    end if

  end subroutine evaljac

end program FIRDMAIN


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C BenchIT - Performance Measurement for Scientific Applications
C Contact: developer@benchit.org
C
C $Id: matmul_f_core.f 1 2009-09-11 12:26:19Z william $
C $URL: svn+ssh://william@rupert.zih.tu-dresden.de/svn-base/benchit-root/BenchITv6/kernel/numerical/matmul/F77/MPI/0/MPI_F77/matmul_f_core.f $
C For license details see COPYING in the package base directory
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Kernel: Matrix multiply (Fortran 77) with MPI
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	SUBROUTINE matmul ( a, b, c, rowsa, colsa, rowsb, colsb)
	INTEGER colsa, rowsa, colsb, rowsb
	double precision a( rowsa, colsa)
	double precision b( rowsb, colsb)
	double precision c( rowsa, colsb)
	INTEGER i, j, k
	do 100 j=1,colsb
	   do 100 k=1,colsa
	      do 100 i=1,rowsa
		 c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END


c=======================================================================
c
c     Random Utilities Functions
c
c-----------------------------------------------------------------------
c
c        Fonctions List
c
c        RNV     : Generates an history with normal random
c        RUV     : Generates an history with uniform random
c        BVN     : Generates V(i) = mean(i) + std*N(0,1)
c        BMN     : Generates M(i,j) = mean(i,j) + std*N(0,1)
c        BCMN    : Generates M(i,j) = mean(i,j) + std(j)*N(0,1)
c        BMSN    : M(i,j) = mean(i,j) + std*N(0,1) with M'=M (size n*(n+1)/2)
c        IVXRN   : Initializes a vector V(i) = N(mean,std), i=1,...,n
c        IVXRNS  : Initializes a vector V(i) = a*e(i)/sum(e(i))
c                  with e(i)~N(mean,std)
c        IVXRU   : Initializes a vector V(i) = Uniform(mean,hint), i=1,...,n
c        IVXRUS  : Initializes a vector V(i) = a*e(i)/sum(e(i))
c                  with e(i)~U(mean,hint)
c        IMXRN   : Initializes a matrix X(i,j) = N(mean,std)
c        IMSXRN  : Initializes a matrix X(i,j) = N(mean,std) and X'= X (symmetric)
c        IMXRU   : Initializes a matrix X(i,j) = Uniform(mean,hint)
c        IMSXRU  : Initializes a matrix X(i,j) = Uniform(mean,hint)
c                  and X'= X (symmetric)
c
c=======================================================================
c
c     subroutine RNV
c
c     Generates an history with a normal random on a vector
c
c-----------------------------------------------------------------------
      SUBROUTINE RNV ( n, vect, nmes, std, mnorm )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : vector size size of the vector                  integer
c       vect   : vector(n)                                        double
c       nmes   : number of measures with normal noise            integer
c       std    : standard deviation (n)                           double
c
c     OUTPUT
c       mnorm  : matrix of initial vector with normal noise
c                     vectorized matrix(nmes*n)                   double
c
c     CALL
c       IVXRN  : Initializes a vector at a scalar
c                     random from a normal distribution
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n, nmes
      DOUBLE PRECISION vect(*), std(*), mnorm(nmes,*)
c
c     local variables
      INTEGER i
c
c-----------------------------------------------------------------------
c
      DO i = 1,n
         CALL IVXRN ( nmes, vect(i), std(i), mnorm(1,i) )
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine RUV
c
c     Generates an history with an uniform random on a vector
c
c-----------------------------------------------------------------------
      SUBROUTINE RUV ( n, vect, nmes, hint, munif )
c-----------------------------------------------------------------------
c
c     INPUT
c       n  : vector size                         integer
c       vect   : vector(nvect)                               double
c       nmes   : number of measures with normal noise       integer
c       hint   : half interval of the uniform distribution   double
c                     vector(nvect)                               double
c
c     OUTPUT
c       munif  : matrix of initial vector with uniform noise
c                     vectorized matrix(nmes*nvect)               double
c
c     CALL
c       IVXRU  : Initializes a vector at a scalar
c                     random from an uniform distribution
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n, nmes
      DOUBLE PRECISION vect(*), hint(*), munif(nmes,*)
c
c     local variables
      INTEGER i
c
c-----------------------------------------------------------------------
c
      DO i = 1,n
         CALL IVXRU ( nmes, vect(i), hint(i), munif(1,i) )
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine BVN
c
c     Generates a normal random: V(i) = mean(i) + std*N(0,1)
c
c-----------------------------------------------------------------------
      SUBROUTINE BVN ( n, mean, std, V )
c-----------------------------------------------------------------------
c
c     INPUT
c       n    : vector size                                       integer
c       mean : mean vector (n)                                    double
c       std  : standard deviation                                 double
c
c     OUTPUT
c       V  : random vector (n)                                    double
c
c     CALL
c       rn : generated normal deviate N(0,1)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n
      DOUBLE PRECISION std, mean(*), V(*)
c
c     local variables
      INTEGER i
      DOUBLE PRECISION rn
c
c     external function
      EXTERNAL rn
c
c-----------------------------------------------------------------------
c
      DO i = 1,n
         V(i) = mean(i) + std*rn()
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine BMN
c
c     Generates: M(i,j) = mean(i,j) + std*N(0,1)
c
c-----------------------------------------------------------------------
      SUBROUTINE BMN ( n, p, mean, std, M )
c-----------------------------------------------------------------------
c
c     INPUT
c       n    : number of rows                                    integer
c       p    : number of columns                                 integer
c       mean : mean matrix (n*p)                                  double
c       std  : standard deviation                                 double
c
c     OUTPUT
c       M    : random matrix (n*p)    double
c
c     CALL
c       rn   : generated normal deviate N(0,1)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n, p
      DOUBLE PRECISION std, mean(n,*), M(n,*)
c
c     local variables
      INTEGER i,j
      DOUBLE PRECISION rn
c
c     external function
      EXTERNAL rn
c
c-----------------------------------------------------------------------
c
      DO i = 1,n
         DO j = 1,p
            M(i,j) = mean(i,j) + std*rn()
         ENDDO
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine BCMN
c
c     Generates M(i,j) = mean(i,j) + std(j)*N(0,1)
c
c-----------------------------------------------------------------------
      SUBROUTINE BCMN ( n, p, mean, std, M )
c-----------------------------------------------------------------------
c
c     INPUT
c       n    : number of rows                                    integer
c       p    : number of columns                                 integer
c       mean : mean matrix (n*p)                                  double
c       std  : standard deviation vector (p)                      double
c
c     OUTPUT
c       M    : random matrix (n*p)                                double
c
c     CALL
c       rn   : generated normal deviate N(0,1)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n, p
      DOUBLE PRECISION std(*), mean(n,*), M(n,*)
c
c     local variables
      INTEGER i,j
      DOUBLE PRECISION rn, vol
c
c     external function
      EXTERNAL rn
c
c-----------------------------------------------------------------------
c
      DO i = 1,p
         vol = std(i)
         DO j = 1,n
            M(j,i) = mean(j,i) + vol*rn()
         ENDDO
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine BMSN
c
c     Generates M(i,j) = mean(i,j) + std*N(0,1) with M'=M
c
c-----------------------------------------------------------------------
      SUBROUTINE BMSN ( n, mean, std, M )
c-----------------------------------------------------------------------
c
c     INPUT
c       n    : matrix size                                       integer
c       mean : mean vestor (n*(n+1)/2)                            double
c       std  : standard deviation                                 double
c
c     OUTPUT
c       M    : random symmetric matrix (n*(n+1)/2)                double
c
c     CALL
c       rn   : generated normal deviate N(0,1)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n
      DOUBLE PRECISION std, mean(*), M(*)
c
c     local variables
      INTEGER i
      DOUBLE PRECISION rn
c
c     external function
      EXTERNAL rn
c
c-----------------------------------------------------------------------
c
      DO i = 1,n*(n+1)/2
        M(i) = mean(i) + std*rn()
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine IVXRN
c
c     Initializes a vector V(i) = N(mean,std), i=1,...,n
c
c-----------------------------------------------------------------------
      SUBROUTINE IVXRN ( n, mean, std, V )
c-----------------------------------------------------------------------
c
c     INPUT
c       n    : vector size                                       integer
c       mean : mean                                               double
c       std  : standard deviation                                 double
c
c     OUTPUT
c       V    : random vector (n)                                  double
c
c     CALL
c       rns  : generated normal deviate N(mean,std)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n
      DOUBLE PRECISION mean, std, V(*)
c
c     local variables
      INTEGER i
      DOUBLE PRECISION rns
c
c     external function
      EXTERNAL rns
c
c-----------------------------------------------------------------------
c
      DO i = 1,n
          V(i) = rns( mean, std )
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine IVXRNS
c
c     Initializes a vector V(i) = a*e(i)/sum(e(i)) with e(i)~N(0,1)
c
c-----------------------------------------------------------------------
      SUBROUTINE IVXRNS ( n, mean, std, value, V)
c-----------------------------------------------------------------------
c
c     INPUT
c       n     : vector size                                     integer
c       mean  : mean                                             double
c       std   : standard deviation                               double
c       value : value of the vector sum                          double
c
c     OUTPUT
c        V    : normal vector(n)                                 double
c
c     CALL
c       rns   : generated normal deviate N(mean,std)
c       PVX2  : scales a vector by a constant: a*V(n)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n
      DOUBLE PRECISION mean, std, value, V(*)
c
c     local variables
      INTEGER i
      DOUBLE PRECISION rns, sum
c
c     external functions
      EXTERNAL rns
c
c-----------------------------------------------------------------------
c
      sum = 0.
      DO i = 1,n
         V(i) = rns(mean,std)
         sum = sum + V(i)
      ENDDO
      sum = value / sum
      CALL PVX2 (n, V, sum)
      RETURN
      END
c
c=======================================================================
c
c     subroutine IVXRU
c
c     Initializes a vector V(i) = Uniform(mean,hint), i=1,...,n
c
c-----------------------------------------------------------------------
      SUBROUTINE IVXRU ( n, mean, hint, V )
c-----------------------------------------------------------------------
c
c     INPUT
c       n    : vector size                                       integer
c       mean : mean of the uniform distribution                   double
c       hint : half interval of the uniform distribution          double
c
c     OUTPUT
c       V    : uniform random vector (n)                          double
c
c     CALL
c       rus  : generates a single random Uniform deviate
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n
      DOUBLE PRECISION mean, hint, V(*)
c
c     local variables
      INTEGER i
      DOUBLE PRECISION rus
c
c     external function
      EXTERNAL rus
c
c-----------------------------------------------------------------------
c
      DO i = 1,n
         V(i) = rus( mean, hint )
      ENDDO
      RETURN
      END
c
c=======================================================================
c
c     subroutine IVXRUS
c
c     Initializes a vector V(i) = a*e(i)/sum(e(i)) with e(i)~U(mean,hint)
c
c-----------------------------------------------------------------------
      SUBROUTINE IVXRUS ( n, mean, hint, value, V )
c-----------------------------------------------------------------------
c
c     INPUT
c       n     : vector size                                      integer
c       mean  : mean                                              double
c       hint  : half interval of the uniform distribution         double
c       value : value of the vector sum                           double
c
c     OUTPUT
c       V     : random vector (n)                                 double
c
c     CALL
c       rus   : generates a single random Uniform deviate
c       PVX2  : scales a vector by a constant: a*V(n)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n
      DOUBLE PRECISION mean, hint, value, V(*)
c
c     local variables
      INTEGER i
      DOUBLE PRECISION rus, sum
c
c     external function
      EXTERNAL rus
c
c-----------------------------------------------------------------------
c
      sum = 0.
      DO i = 1,n
         V(i) = rus(mean,hint)
         sum = sum + V(i)
      ENDDO
      sum = value / sum
      CALL PVX2(n, V, sum)
      RETURN
      END
c
c=======================================================================
c
c     subroutine IMXRN
c
c     Returns a n-by-p matrix containing pseudo-random values
c     drawn from a Gaussian distribution
c
c     X(i,j) = Normal(mean,std)
c
c-----------------------------------------------------------------------
      SUBROUTINE IMXRN ( n, p, mean, std, X )
c-----------------------------------------------------------------------
c
c     INPUT
c       n    : number of rows                                    integer
c       p    : number of columns                                 integer
c       mean : mean                                               double
c       std  : standard deviation                                 double
c
c     OUTPUT
c       X    : Gaussian random matrix (n*p)                       double
c
c     CALL
c       rns  : generates a single Gaussian random deviate
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n, p
      DOUBLE PRECISION mean, std, X(n,*)
c
c     local variables
      INTEGER i,j
      DOUBLE PRECISION rns
c
c     external function
      EXTERNAL rns
c
c-----------------------------------------------------------------------
c
      DO i = 1,n
        DO j = 1,p
            X(i,j) = rns(mean,std)
        ENDDO
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine IMSXRN
c
c     Returns a symmetric matrix containing pseudo-random values
c     drawn from a Gaussian distribution
c
c     X(i,j) = N(mean,std) and X'= X (symmetric)
c
c-----------------------------------------------------------------------
      SUBROUTINE IMSXRN ( n, mean, std, X )
c-----------------------------------------------------------------------
c
c     INPUT
c       n    : matrix size                                       integer
c       mean : mean of the uniform distribution                   double
c       std  : standard deviation                                 double
c
c     OUTPUT
c       X    : Gaussian random symmetric matrix (n*(n+1)/2)       double
c
c     CALL
c       rns  : generates a single Gaussian random deviate
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n
      DOUBLE PRECISION mean, std, X(*)
c
c     local variables
      INTEGER i
      DOUBLE PRECISION rns
c
c     external function
      EXTERNAL rns
c
c-----------------------------------------------------------------------
c
      DO i = 1,n*(n+1)/2
        X(i) = rns(mean,std)
      ENDDO
c
      RETURN
      END

c
c=======================================================================
c
c     subroutine IMXRU
c
c     Returns an n-by-p matrix containing pseudo-random values
c     drawn from a uniform distribution
c
c     X(i,j) = Uniform(mean,hint)
c
c-----------------------------------------------------------------------
      SUBROUTINE IMXRU ( n, p, mean, hint, X )
c-----------------------------------------------------------------------
c
c     INPUT
c       n    : number of rows                                    integer
c       p    : number of columns                                 integer
c       mean : mean of the uniform distribution                   double
c       hint : half interval of the uniform distribution          double
c
c     OUTPUT
c       X    : Uniform random matrix (n*p)                        double
c
c     CALL
c       rus  : generates a single random Uniform deviate
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n, p
      DOUBLE PRECISION mean, hint, X(n,*)
c
c     local variables
      INTEGER i,j
      DOUBLE PRECISION rus
c
c     external function
      EXTERNAL rus
c
c-----------------------------------------------------------------------
c
      DO i = 1,n
        DO j = 1,p
            X(i,j) = rus(mean,hint)
        ENDDO
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine IMSXRU
c
c     Returns an symetric matrix containing pseudo-random values
c     drawn from a uniform distribution
c
c     X(i,j) = Uniform(mean,hint) and X'= X (symmetric)
c
c-----------------------------------------------------------------------
      SUBROUTINE IMSXRU ( n, mean, hint, X )
c-----------------------------------------------------------------------
c
c     INPUT
c       n    : matrix size                                       integer
c       mean : mean of the Uniform distribution                   double
c       hint : half interval of the Uniform distribution          double
c
c     OUTPUT
c       X    : random symmetric matrix (n*(n+1)/2)                double
c
c     CALL
c       rus  : generates a single random Uniform deviate
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n
      DOUBLE PRECISION mean, hint, X(*)
c
c     local variables
      INTEGER i
      DOUBLE PRECISION rus
c
c     external function
      EXTERNAL rus
c
c-----------------------------------------------------------------------
c
      DO i = 1,n*(n+1)/2
        X(i) = rus(mean,hint)
      ENDDO
c
      RETURN
      END


*DECK SINT
      SUBROUTINE SINT (N, X, WSAVE)
C***BEGIN PROLOGUE  SINT
C***PURPOSE  Compute the sine transform of a real, odd sequence.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A3
C***TYPE      SINGLE PRECISION (SINT-S)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine SINT computes the discrete Fourier sine transform
C  of an odd sequence X(I).  The transform is defined below at
C  output parameter X.
C
C  SINT is the unnormalized inverse of itself since a call of SINT
C  followed by another call of SINT will multiply the input sequence
C  X by 2*(N+1).
C
C  The array WSAVE which is used by subroutine SINT must be
C  initialized by calling subroutine SINTI(N,WSAVE).
C
C  Input Parameters
C
C  N       the length of the sequence to be transformed.  The method
C          is most efficient when N+1 is the product of small primes.
C
C  X       an array which contains the sequence to be transformed
C
C
C  WSAVE   a work array with dimension at least INT(3.5*N+16)
C          in the program that calls SINT.  The WSAVE array must be
C          initialized by calling subroutine SINTI(N,WSAVE), and a
C          different WSAVE array must be used for each different
C          value of N.  This initialization does not have to be
C          repeated so long as N remains unchanged.  Thus subsequent
C          transforms can be obtained faster than the first.
C
C  Output Parameters
C
C  X       For I=1,...,N
C
C               X(I)= the sum from K=1 to K=N
C
C                    2*X(K)*SIN(K*I*PI/(N+1))
C
C               A call of SINT followed by another call of
C               SINT will multiply the sequence X by 2*(N+1).
C               Hence SINT is the unnormalized inverse
C               of itself.
C
C  WSAVE   contains initialization calculations which must not be
C          destroyed between calls of SINT.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  RFFTF
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing definition of variable SQRT3 by using
C               FORTRAN intrinsic function SQRT instead of a DATA
C               statement.
C   881128  Modified by Dick Valent to meet prologue standards.
C   891009  Removed unreferenced statement label.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SINT
      DIMENSION X(*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  SINT
      SQRT3 = SQRT(3.)
      IF (N-2) 101,102,103
  101 X(1) = X(1)+X(1)
      RETURN
  102 XH = SQRT3*(X(1)+X(2))
      X(2) = SQRT3*(X(1)-X(2))
      X(1) = XH
      RETURN
  103 NP1 = N+1
      NS2 = N/2
      WSAVE(1) = 0.
      KW = NP1
      DO 104 K=1,NS2
         KW = KW+1
         KC = NP1-K
         T1 = X(K)-X(KC)
         T2 = WSAVE(KW)*(X(K)+X(KC))
         WSAVE(K+1) = T1+T2
         WSAVE(KC+1) = T2-T1
  104 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .NE. 0) WSAVE(NS2+2) = 4.*X(NS2+1)
      NF = NP1+NS2+1
      CALL RFFTF (NP1,WSAVE,WSAVE(NF))
      X(1) = .5*WSAVE(1)
      DO 105 I=3,N,2
         X(I-1) = -WSAVE(I)
         X(I) = X(I-2)+WSAVE(I-1)
  105 CONTINUE
      IF (MODN .NE. 0) RETURN
      X(N) = -WSAVE(N+1)
      RETURN
      END


      SUBROUTINE SBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK,
     $                   RESID )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            KD, LDU, LDVT, N
      REAL               RESID
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * ), S( * ), U( LDU, * ),
     $                   VT( LDVT, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  SBDT03 reconstructs a bidiagonal matrix B from its SVD:
*     S = U' * B * V
*  where U and V are orthogonal matrices and S is diagonal.
*
*  The test ratio to test the singular value decomposition is
*     RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS )
*  where VT = V' and EPS is the machine precision.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix B is upper or lower bidiagonal.
*          = 'U':  Upper bidiagonal
*          = 'L':  Lower bidiagonal
*
*  N       (input) INTEGER
*          The order of the matrix B.
*
*  KD      (input) INTEGER
*          The bandwidth of the bidiagonal matrix B.  If KD = 1, the
*          matrix B is bidiagonal, and if KD = 0, B is diagonal and E is
*          not referenced.  If KD is greater than 1, it is assumed to be
*          1, and if KD is less than 0, it is assumed to be 0.
*
*  D       (input) REAL array, dimension (N)
*          The n diagonal elements of the bidiagonal matrix B.
*
*  E       (input) REAL array, dimension (N-1)
*          The (n-1) superdiagonal elements of the bidiagonal matrix B
*          if UPLO = 'U', or the (n-1) subdiagonal elements of B if
*          UPLO = 'L'.
*
*  U       (input) REAL array, dimension (LDU,N)
*          The n by n orthogonal matrix U in the reduction B = U'*A*P.
*
*  LDU     (input) INTEGER
*          The leading dimension of the array U.  LDU >= max(1,N)
*
*  S       (input) REAL array, dimension (N)
*          The singular values from the SVD of B, sorted in decreasing
*          order.
*
*  VT      (input) REAL array, dimension (LDVT,N)
*          The n by n orthogonal matrix V' in the reduction
*          B = U * S * V'.
*
*  LDVT    (input) INTEGER
*          The leading dimension of the array VT.
*
*  WORK    (workspace) REAL array, dimension (2*N)
*
*  RESID   (output) REAL
*          The test ratio:  norm(B - U * S * V') / ( n * norm(A) * EPS )
*
* ======================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      REAL               BNORM, EPS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ISAMAX
      REAL               SASUM, SLAMCH
      EXTERNAL           LSAME, ISAMAX, SASUM, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, REAL
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      RESID = ZERO
      IF( N.LE.0 )
     $   RETURN
*
*     Compute B - U * S * V' one column at a time.
*
      BNORM = ZERO
      IF( KD.GE.1 ) THEN
*
*        B is bidiagonal.
*
         IF( LSAME( UPLO, 'U' ) ) THEN
*
*           B is upper bidiagonal.
*
            DO 20 J = 1, N
               DO 10 I = 1, N
                  WORK( N+I ) = S( I )*VT( I, J )
   10          CONTINUE
               CALL SGEMV( 'No transpose', N, N, -ONE, U, LDU,
     $                     WORK( N+1 ), 1, ZERO, WORK, 1 )
               WORK( J ) = WORK( J ) + D( J )
               IF( J.GT.1 ) THEN
                  WORK( J-1 ) = WORK( J-1 ) + E( J-1 )
                  BNORM = MAX( BNORM, ABS( D( J ) )+ABS( E( J-1 ) ) )
               ELSE
                  BNORM = MAX( BNORM, ABS( D( J ) ) )
               END IF
               RESID = MAX( RESID, SASUM( N, WORK, 1 ) )
   20       CONTINUE
         ELSE
*
*           B is lower bidiagonal.
*
            DO 40 J = 1, N
               DO 30 I = 1, N
                  WORK( N+I ) = S( I )*VT( I, J )
   30          CONTINUE
               CALL SGEMV( 'No transpose', N, N, -ONE, U, LDU,
     $                     WORK( N+1 ), 1, ZERO, WORK, 1 )
               WORK( J ) = WORK( J ) + D( J )
               IF( J.LT.N ) THEN
                  WORK( J+1 ) = WORK( J+1 ) + E( J )
                  BNORM = MAX( BNORM, ABS( D( J ) )+ABS( E( J ) ) )
               ELSE
                  BNORM = MAX( BNORM, ABS( D( J ) ) )
               END IF
               RESID = MAX( RESID, SASUM( N, WORK, 1 ) )
   40       CONTINUE
         END IF
      ELSE
*
*        B is diagonal.
*
         DO 60 J = 1, N
            DO 50 I = 1, N
               WORK( N+I ) = S( I )*VT( I, J )
   50       CONTINUE
            CALL SGEMV( 'No transpose', N, N, -ONE, U, LDU, WORK( N+1 ),
     $                  1, ZERO, WORK, 1 )
            WORK( J ) = WORK( J ) + D( J )
            RESID = MAX( RESID, SASUM( N, WORK, 1 ) )
   60    CONTINUE
         J = ISAMAX( N, D, 1 )
         BNORM = ABS( D( J ) )
      END IF
*
*     Compute norm(B - U * S * V') / ( n * norm(B) * EPS )
*
      EPS = SLAMCH( 'Precision' )
*
      IF( BNORM.LE.ZERO ) THEN
         IF( RESID.NE.ZERO )
     $      RESID = ONE / EPS
      ELSE
         IF( BNORM.GE.RESID ) THEN
            RESID = ( RESID / BNORM ) / ( REAL( N )*EPS )
         ELSE
            IF( BNORM.LT.ONE ) THEN
               RESID = ( MIN( RESID, REAL( N )*BNORM ) / BNORM ) /
     $                 ( REAL( N )*EPS )
            ELSE
               RESID = MIN( RESID / BNORM, REAL( N ) ) /
     $                 ( REAL( N )*EPS )
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of SBDT03
*
      END


      REAL FUNCTION BESSJ(N,X)
      IMPLICIT NONE
C----------------------------------------------------------------------
C Purpose: Calculates Jn(X)
C
C Parameters:
C
      INTEGER IACC
      PARAMETER(IACC=40)
      REAL BIGNO,BIGNI
      PARAMETER(BIGNO=1.0E+10,BIGNI=1.0E-10)
C
C Arguments:
C
      INTEGER N
      REAL X
C
C Local variables:
C
      REAL AX,TOX,BJM,BJ,BJP,SUM
      INTEGER J,JSUM,M,NN
C
C External functions:
C
      REAL BESSJ0,BESSJ1
      EXTERNAL BESSJ0,BESSJ1
C----------------------------------------------------------------------
      NN = ABS(N)
      IF(N.EQ.0)THEN
         BESSJ = BESSJ0(X)
      ELSEIF(NN.EQ.1)THEN
         BESSJ = BESSJ1(X)
      ELSE
         AX = ABS(X)
         IF(AX.EQ.0.0)THEN
            BESSJ = 0.0
         ELSEIF(AX.GT.FLOAT(NN))THEN
            TOX = 2.0/AX
            BJM = BESSJ0(AX)
            BJ = BESSJ1(AX)
            DO 10 J=1,NN-1
               BJP = FLOAT(J)*TOX*BJ - BJM
               BJM = BJ
               BJ = BJP
 10         CONTINUE
            BESSJ = BJ
         ELSE
            TOX = 2.0/AX
            M = 2*((NN+INT(SQRT(FLOAT(IACC*NN))))/2)
            BESSJ = 0.0
            JSUM = 0
            SUM = 0.0
            BJP =  0.0
            BJ = 1.0
            DO 20 J=M,1,-1
               BJM = FLOAT(J)*TOX*BJ - BJP
               BJP = BJ
               BJ = BJM
               IF(ABS(BJ).GT.BIGNO)THEN
                  BJ = BJ*BIGNI
                  BJP = BJP*BIGNI
                  BESSJ = BESSJ*BIGNI
                  SUM = SUM*BIGNI
               ENDIF
               IF(JSUM.NE.0)SUM = SUM + BJ
               JSUM = 1 - JSUM
               IF(J.EQ.NN)BESSJ = BJP
 20         CONTINUE
            SUM = 2.0*SUM - BJ
            BESSJ = BESSJ/SUM
         ENDIF
      ENDIF
      IF(MOD(NN,2).EQ.1)THEN
         IF(FLOAT(N)*X.LT.0.0)BESSJ = -BESSJ
      ENDIF
      RETURN
      END


c**********************************************************************
c
c     test program for fft routine
c     fourier transforms a cosine function
c
c     copyright daresbury laboratory 1998
c     author w.smith july 1998
c
c**********************************************************************

      implicit real*8 (a-h,o-z)

      parameter (ndiv=64)

      complex*16 aaa(ndiv),bbb(ndiv),wfft(ndiv)
      dimension key(ndiv)
      data tpi/6.2831853072d0/

c     set up the cosine function (with period 1/4 of window width)

      tpn=tpi/dble(ndiv)
      np1=ndiv+1
      np2=ndiv/2
      aaa(1)=(1.d0,0.d0)
      do i=1,np2
        arg=tpn*dble(4*i)
        aaa(i+1)=cmplx(cos(arg),0.d0)
        aaa(np1-i)=conjg(aaa(i+1))
      enddo

c     initialise the fft routine

      call fft(1,1,ndiv,key,aaa,wfft,bbb)

c     perform FT of function

      call fft(0,1,ndiv,key,aaa,wfft,bbb)

c     print result

      do i=1,ndiv

        write(*,'(i5,1p,2e12.4)')i,real(aaa(i)),real(bbb(i))

      enddo

      end
      subroutine fft(ind,isw,ndiv,key,aaa,wfft,bbb)
c***********************************************************************
c
c     fast fourier transform routine
c
c     copyright daresbury laboratory 1994
c
c     author w smith
c
c***********************************************************************

      implicit real*8(a-h,o-z)

      logical check
      complex*16 aaa(ndiv),bbb(ndiv),wfft(ndiv),ttt
      dimension key(ndiv)
      data tpi/6.2831853072d0/
   10 format(1h0,'error - number of points not a power of two')

c
c     check that array is of suitable length
      nt=1
      check=.true.
      do i=1,20
         nt=2*nt
         if(nt.eq.ndiv)then
            check=.false.
            nu=i
         endif
      enddo
      if(check)then
         write(*,10)
         stop
      endif

      if(ind.gt.0)then
c
c     set reverse bit address array

         do kkk=1,ndiv
            iii=0
            jjj=kkk-1
            do j=1,nu
               jj2=jjj/2
               iii=2*(iii-jj2)+jjj
               jjj=jj2
            enddo
            key(kkk)=iii+1
         enddo
c
c     initialise complex exponential factors

         np1=ndiv+1
         np2=ndiv/2
         tpn=tpi/dble(ndiv)
         wfft(1)=(1.d0,0.d0)
         do i=1,np2
            arg=tpn*dble(i)
            wfft(i+1)=cmplx(cos(arg),sin(arg))
            wfft(np1-i)=conjg(wfft(i+1))
         enddo

         return
      endif

c
c     take conjugate of exponentials if required

      if(isw.lt.0)then

         do i=1,ndiv
            wfft(i)=conjg(wfft(i))
         enddo

      endif

c
c     take copy input array

      do i=1,ndiv
         bbb(i)=aaa(i)
      enddo
c
c     perform fourier transform

      kkk=0
      np2=ndiv/2
      do l=1,nu

  100    do i=1,np2
            iii=key(kkk/np2+1)
            kk1=kkk+1
            k12=kk1+np2
            ttt=bbb(k12)*wfft(iii)
            bbb(k12)=bbb(kk1)-ttt
            bbb(kk1)=bbb(kk1)+ttt
            kkk=kkk+1
         enddo
         kkk=kkk+np2
         if(kkk.lt.ndiv)go to 100
         kkk=0
         np2=np2/2

      enddo
c
c     unscramble the fft using bit address array

      do kkk=1,ndiv
         iii=key(kkk)
         if(iii.gt.kkk)then
            ttt=bbb(kkk)
            bbb(kkk)=bbb(iii)
            bbb(iii)=ttt
         endif
      enddo
c
c     restore exponentials to unconjugated values if necessary

      if(isw.lt.0)then

         do i=1,ndiv
            wfft(i)=conjg(wfft(i))
         enddo

      endif

      return
      end


program Test

use maptran
use vallado
use assert, only:wp, assert_isclose

implicit none

!type(Ellipsoid), parameter :: spheroid = wgs84Ellipsoid

real(wp), parameter :: lat = 42, lon= -82, alt = 200, &
                       az = 33, el=70, rng= 1e3_wp, &
                       x0 = 660.675e3_wp, y0 = -4700.949e3_wp, z0 = 4245.738e3_wp, &
                       xl = 660.930e3_wp, yl = -4701.424e3_wp, zl = 4246.579e3_wp, & ! aer2ecef
                       er = 186.277521_wp, nr = 286.84222_wp, ur = 939.69262_wp, & ! aer2enu
                       lat1 = 42.0026_wp, lon1 = -81.9978_wp, alt1 = 1.1397e3_wp, & ! aer2geodetic
                       azi = 180.1_wp,  eli = 80._wp, &
                       ha = 45.482789587392013_wp

integer,parameter :: N = 3
real(wp), dimension(N), parameter :: alat = [42,52,62], &
                                     deg0 = [15,30,45], &
                                     aaz = [33,43,53]

type(time), parameter :: t0 = time(2014,4,6,8,0,0) ! UTC
real(wp), parameter ::  jd0 = 2456753.833333_wp

real(wp) :: lat2, lon2, alt2,lat3,lon3,alt3,lat4,lon4,alt4,&
            x1,y1,z1,x2,y2,z2,x3,y3,z3,&
            az2,el2,rng2,az3,el3,rng3,az4,el4,rng4,azrd,elrd,rae,dae,jd, &
            e1,n1,u1,e2,n2,u2,e3,n3,u3

real(wp), dimension(N) :: ax1, ay1, aaaz1, ax2, ay2, aaaz2, ax3,ay3,aaaz3, &
                          ae1, an1, au1, ae2,an2,au2, &
                          alat2,alon2,aalt2, alat3,alon3,aalt3, alat4,alon4,aalt4, &
                          aaz2, ael2, arng2, aaz3,ael3,arng3, aaz4,ael4,arng4

!print*,'Default WGS84 Ellipsoid:',spheroid

! --------- scalar degrees

call geodetic2ecef(lat,lon,alt, x1,y1,z1)
call assert_isclose([x1,y1,z1],[x0,y0,z0])

call aer2enu(az,el,rng, e1,n1,u1)
call assert_isclose([e1,n1,u1], [er,nr,ur])

call aer2ecef(az,el,rng,lat,lon,alt,x2,y2,z2)
call assert_isclose([x2,y2,z2],[xl,yl,zl])

call ecef2geodetic(x1,y1,z1,lat2,lon2,alt2)
call assert_isclose([lat2,lon2,alt2],[lat,lon,alt])

call enu2aer(e1,n1,u1, az2, el2, rng2)
call assert_isclose([az2,el2,rng2],[az,el,rng])

call ecef2aer(x2,y2,z2, lat,lon,alt, az3, el3, rng3)
call assert_isclose([az3,el3,rng3],[az,el,rng])

call aer2geodetic(az,el,rng,lat,lon,alt, lat3,lon3,alt3)
call assert_isclose([lat3,lon3,alt3],[lat1,lon1,alt1])

call geodetic2enu(lat3, lon3, alt3, lat, lon, alt, e2, n2, u2)
call assert_isclose([e2,n2,u2],[e1,n1,u1])

call geodetic2aer(lat3,lon3,alt3,lat,lon,alt, az4, el4, rng4)
call assert_isclose([az4,el4,rng4],[az,el,rng])

call enu2ecef(e1,n1,u1,lat,lon,alt, x3, y3, z3)
call assert_isclose([x3,y3,z3],[x2,y2,z2])

call enu2geodetic(e2,n2,u2,lat,lon,alt,lat4, lon4, alt4)
call assert_isclose([lat4,lon4,alt4],[lat3,lon3,alt3])

call ecef2enu(x3,y3,z3,lat,lon,alt, e3,n3,u3)
call assert_isclose([e3,n3,u3],[e1,n1,u1])

call assert_isclose(degrees(radians(deg0)), deg0)

! ------ scalar radians

call geodetic2ecef(radians(lat),radians(lon),alt, x1,y1,z1, deg=.false.)
call assert_isclose([x1,y1,z1],[x0,y0,z0])

call aer2enu(radians(az),radians(el),rng, e1,n1,u1, deg=.false.)
call assert_isclose([e1,n1,u1], [er,nr,ur])

call aer2ecef(radians(az),radians(el),rng, radians(lat),radians(lon),alt, x2,y2,z2, deg=.false.)
call assert_isclose([x2,y2,z2],[xl,yl,zl])

call ecef2geodetic(x1,y1,z1,lat2,lon2,alt2, deg=.false.)
call assert_isclose([degrees(lat2),degrees(lon2),alt2],[lat,lon,alt])

call enu2aer(e1,n1,u1, az2, el2, rng2, deg=.false.)
call assert_isclose([degrees(az2),degrees(el2),rng2],[az,el,rng], err_msg='enu2aer: rad')

call ecef2aer(x2,y2,z2, radians(lat),radians(lon),alt, az3,el3,rng3, deg=.false.)
call assert_isclose([degrees(az3),degrees(el3),rng3],[az,el,rng])

call aer2geodetic(radians(az),radians(el),rng, radians(lat),radians(lon),alt, lat3,lon3,alt3, deg=.false.)
call assert_isclose([degrees(lat3),degrees(lon3),alt3],[lat1,lon1,alt1], err_msg='aer2geodetic: rad')

call geodetic2enu(lat3,lon3,alt3, radians(lat),radians(lon),alt, e2,n2,u2, deg=.false.)
call assert_isclose([e2,n2,u2],[e1,n1,u1], err_msg='geodetic2enu: rad')

call geodetic2aer(lat3,lon3,alt3, radians(lat),radians(lon),alt, az4,el4,rng4, deg=.false.)
call assert_isclose([degrees(az4),degrees(el4),rng4],[az,el,rng], err_msg='geodetic2aer: rad')

call enu2ecef(e1,n1,u1, radians(lat),radians(lon),alt, x3,y3,z3, deg=.false.)
call assert_isclose([x3,y3,z3],[x2,y2,z2], err_msg='enu2ecef: rad')

call enu2geodetic(e2,n2,u2, radians(lat),radians(lon),alt, lat4,lon4,alt4, deg=.false.)
call assert_isclose([lat4,lon4,alt4],[lat3,lon3,alt3], err_msg='enu2geodetic: rad')

call ecef2enu(x3,y3,z3, radians(lat),radians(lon),alt, e3,n3,u3, deg=.false.)
call assert_isclose([e3,n3,u3],[e1,n1,u1], err_msg='ecef2enu: rad')

! --- array

call geodetic2ecef(alat,lon,alt,ax1,ay1,aaaz1)
call aer2enu(aaz, el, rng, ae1, an1, au1)
call aer2ecef(aaz, el, rng, lat,lon,alt, ax2, ay2, aaaz2)
call ecef2geodetic(ax1,ay1,aaaz1,alat2,alon2,aalt2)
call enu2aer(ae1,an1,au1, aaz2, ael2, arng2)
call ecef2aer(ax2,ay2,az2, lat,lon,alt, aaz3, ael3, arng3)
call aer2geodetic(aaz,el,rng,lat,lon,alt, alat3,alon3,aalt3)
call geodetic2enu(alat3, alon3, aalt3, lat, lon, alt, ae2, an2, au2)
call geodetic2aer(alat3,alon3, aalt3,lat,lon,alt, aaz4, ael4, arng4)
call enu2ecef(ae1,an1,au1,lat,lon,alt, ax3, ay3, aaaz3)
call enu2geodetic(ae2,an2,au2,lat,lon,alt,alat4, alon4, aalt4)

!-------- Vallado
jd = toJulian(t0)
! http://aa.usno.navy.mil/jdconverter?ID=AA&year=2014&month=4&day=6&era=1&hr=8&min=0&sec=0.0
call assert_isclose(jd, jd0, err_msg='toJulian')

call assert_isclose(toGST(jd), 5.4896448816_wp, err_msg='toGST')
call assert_isclose(toLST(radians(-148._wp), jd), 2.90658_wp, err_msg='toLST')

call azel2radec(azi,eli,lat,lon, jd, rae, dae)
call radec2azel(rae,dae,lat,lon,jd,azrd,elrd)
call assert_isclose([azi,eli],[azrd,elrd])
!------- Meeus
call assert_isclose(anglesep(35._wp,23._wp, 84._wp,20._wp), ha)

print *,'Maptran OK'
end program


SUBROUTINE Flux_2Linear(eNum)
   USE PrecTypes
   USE GlobalData
   IMPLICIT NONE

   ! -------------------------------------------------------------------------
   ! NAME:   Flux_2Linear
   ! PARENT: F_Poten2Linear
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Calculate nodal heat flux vector for a linear boundary element
   !         for two-dimensional steady-state heat conduction problems.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   INTEGER, INTENT(IN) :: eNum
   INTEGER :: i,j,k

   ! Variables used for integration of linear straight boundary elements
   REAL(dp) :: Lx, Ly, L
   REAL(dp) :: flux(2)
   INTEGER  :: n(2)

   ! Global node numbers defining this element
   n(1) = Sid(eNum,1)
   n(2) = Sid(eNum,2)

   ! Length of this straight boundary element
   Lx = x(n(2)) - x(n(1))
   Ly = y(n(2)) - y(n(1))
   L = sqrt(Lx*Lx + Ly*Ly)

   flux = 0.0_dp

   DO i=1,2 ! Counting the nodes
      IF(bccode(eNum,i) == 1)  flux(i) = bcval(eNum,i) * L * thickness(eNum)
   END DO

   Flinear_p(1,1) = flux(1)/3.0_dp
   Flinear_p(1,2) = flux(2)/6.0_dp
   Flinear_p(2,1) = flux(1)/6.0_dp
   Flinear_p(2,2) = flux(2)/3.0_dp

   RETURN
END SUBROUTINE Flux_2Linear


!!
!! Luke McCulloch
!! Incorporation of the trid subroutine into module form
!! September 2011
!! Rename to F90 file to support modules!
!!
MODULE Swafftridag

  USE precise, only : defaultp
 ! Implicit None
 ! Integer  :: n
  INTEGER, PARAMETER, PRIVATE :: WP=defaultp

Contains

      subroutine trid (a,b,c,r,u,nn)
      integer :: nn
      !Integer, parameter :: nn=n
      Integer, parameter :: nmax=500

!!$c
!!$c  routine to solve scalar tridiagonal matrics using the thomas
!!$c  algorithm.  a is the lower diagonal, b is the main diagonal,
!!$c  c is the upper diagonal, and r is the rhs.  solution returned in u.
!!$c  n is the number of elements in the main diagonal.
!!$c  Reference:
!!$c     Press, William H., Blannery Brian P., Teukolsky, Saul A.,
!!$c     and Vetterling, William T., Numerical Recipes: The Art of Scientific
!!$c     Computing, Cambridge University Press, Cambridge, MA, 1986, p. 40.
!!$
!!$c   Note that:
!!$c   indices for the lower diagonal (a) should range from 2 -> n (contains n-1 elements)
!!$c   indices for the main diagonal (b) should range from 1 -> n (contains n elements)
!!$c   indices for the upper diagonal (c) should range from 1 -> n-1 (contains n-1 elements)
!!$c   indices for the rhs should range from 1 -> n (contains n elements)
!!$c   note that a(1) and c(n) are undefined and are not referenced by the routine.

      Real(wp), dimension(nn) :: gam,a,b,c,r,u

!!$    Do i=j,nn
!!$       write(*,*) 'rhs', r(j)
!!$    End do
      print*
      if(b(1).eq.0.0) stop  'stopping...need to modify matrix'
      bet=b(1)
      u(1)=r(1)/bet
      do 11 j=2,nn
      gam(j)=c(j-1)/bet
      bet=b(j)-a(j)*gam(j)
      if(bet.eq.0.0) stop 'stopping....zero on the diagonal'
      u(j)=(r(j)-a(j)*u(j-1))/bet
   11 continue
      do 12 j=nn-1,1,-1
      u(j)=u(j)-gam(j+1)*u(j+1)
   12 continue
      return

!!$    Do i=j,N
!!$       write(*,*) 'U(j) in the swaff inv', U(j)
!!$    End do

 End Subroutine trid

End Module SwaffTridag


	FUNCTION PR_STDZ  ( pres, hght )
C************************************************************************
C* PR_STDZ								*
C*									*
C* This function computes a standard height used on upper-air charts.	*
C* For data below 500 mb, the standard height is the last three digits	*
C* of the height.  For data at and above 500 mb, the height is the	*
C* last three digits of the height in decameters.			*
C*									*
C* REAL PR_STDZ  ( PRES, HGHT )						*
C*									*
C* Input parameters:							*
C*	PRES		REAL		Pressure in millibars		*
C*	HGHT		REAL		Height in meters		*
C*									*
C* Output parameters:							*
C*	PR_STDZ		REAL		Abbreviated height		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 8/90						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( pres ) .or. ERMISS ( hght ) )  THEN
	    PR_STDZ = RMISSD
	    RETURN
	END IF
C
C*	Check for pressure below 500 mb.
C
	IF  ( pres .gt. 500 )  THEN
	    ihhh = NINT ( hght )
	    PR_STDZ = MOD ( ihhh, 1000 )
	  ELSE
	    ihhh = NINT ( hght / 10. )
	    PR_STDZ = MOD ( ihhh, 1000 )
	END IF
C*
	RETURN
	END


program gen_spectra

   use da_control
   use da_spectral
   use da_tracing

   implicit none

   integer, parameter  :: iunit = 11

   real, parameter     :: tolerance = 1.0e-6

   character(len=filename_len)        :: filename
   character*10        :: date, cvar, ctime
   integer             :: time, member               ! Loop counters.
   integer             :: i, j, k, n, m              ! Loop counters.
   integer             :: jts, jte                   ! start, end indices.
   integer             :: nt                         ! Number of times to process.
   integer             :: ne                         ! Number of ensemble members.
   integer             :: ni, nj, nk                 ! Dimensions read in.
   integer             :: max_wavenumber             ! Smallest scale required (ni/2 - 1).
   integer             :: index_k, index_start, index_end ! Array indexer.
   integer             :: inc                        ! Jump between elements of vector in array.
   integer             :: lenr                       ! FFT array dimension (at least inc*(n-1)+1).
   integer             :: lensav                     ! wsave dimension (n+int(log(real(ni)))+4).
   integer             :: lenwrk                     ! Dimension of work array.
   integer             :: ier                        ! FFT error flag.
   integer             :: count                      ! Counter
   integer             :: index_m, index_j           ! Array indices.
   integer             :: alp_size                   ! Ass. Leg. Pol. array size.
   integer             :: cv_size                    ! Complex control variable array size.

   logical             :: first_time                 ! True if first time through loop.
   logical             :: testing_spectral           ! Test spectral transform.
   real                :: pi_over_180                ! pi / 180
   real                :: diff_rms                   ! RMS error measure.

   real, allocatable   :: ps_prime(:,:)              ! Surface pressure perturbation.
   real, allocatable   :: t_prime(:,:,:)             ! Temperature perturbation.
   real, allocatable   :: psi_prime(:,:,:)           ! Streamfunction perturbation.
   real, allocatable   :: chi_prime(:,:,:)           ! Velocity Potential perturbation.
   real, allocatable   :: rh_prime(:,:,:)            ! Relative Humidity Perturbation.
   real, allocatable   :: height(:,:,:)              ! Geopotential height.
   real, allocatable   :: latitude(:,:)              ! Latitude (radians)
   real, allocatable   :: field(:,:)                 ! Gridpoint field to be decomposed.
   real, allocatable   :: field_out(:,:)             ! Output test field.

   real, allocatable   :: lat(:)                     ! Latitude (radians).
   real, allocatable   :: sinlat(:)                  ! sine(latitude).
   real, allocatable   :: coslat(:)                  ! cosine(latitude).
   real, allocatable   :: int_wgts(:)                ! Legendre integration weights.
   real, allocatable   :: lon(:)                     ! Longitude (radians).
   real, allocatable   :: sinlon(:)                  ! sine(longitude).
   real, allocatable   :: coslon(:)                  ! cosine(longitude).
   real, allocatable   :: wsave(:)                   ! Prime values for fast Fourier transform.
   real, allocatable   :: alp(:)                     ! Associated Legendre Polynomial.
   real, allocatable   :: power(:)                   ! Power spectrum (n).
   complex, allocatable:: cv(:)                      ! Control variable vector.
   complex, allocatable:: cv_out(:)                  ! Control variable vector copy for tests.

   if (trace_use) call da_trace_init
   if (trace_use) call da_trace_entry("gen_spectra")

   pi = 4.0 * atan(1.0)
   pi_over_180 = pi / 180.0
   gaussian_lats = .false.
   testing_spectral = .true.
   nt = 1
   ne = 1

!---------------------------------------------------------------------------------------------
!  gen_statistics2: Read standard fields, calculate regression coefficients, and create and
!  output "control variables".
!---------------------------------------------------------------------------------------------

!  Loop over times, ensemble members.

!---------------------------------------------------------------------------------------------
   write(6,'(a)')' [1] Read in perturbation fields.'
!---------------------------------------------------------------------------------------------

   open (iunit, file='/data2/hcshin/youn/DIFF63/GHMD_DIFF.2004030212_old', form='unformatted')

   read(iunit)date, ni, nj, nk
   write(6,'(a,a10)')' Date = ', date
   write(6,'(a,3i8)')' i, j, k dimensions are ', ni, nj, nk

   allocate( ps_prime(1:ni,1:nj) )
   allocate( t_prime(1:ni,1:nj,1:nk) )
   allocate( psi_prime(1:ni,1:nj,1:nk) )
   allocate( chi_prime(1:ni,1:nj,1:nk) )
   allocate( rh_prime(1:ni,1:nj,1:nk) )
   allocate( height(1:ni,1:nj,1:nk) )
   allocate( latitude(1:ni,1:nj) )

   read(iunit)ps_prime
   read(iunit)t_prime
   read(iunit)psi_prime
   read(iunit)chi_prime
   read(iunit)rh_prime
   read(iunit)height
   read(iunit)latitude ! Not currently used.

   filename = "psi"//"date"//"member"//"mode"
   open (iunit, file=filename, form='unformatted')
   write(iunit)ni, nj
   write(iunit)gaussian_lats
   write(iunit)psi_prime(1:ni,1:nj,1)
   close(iunit)

!  Calculate regression coefficients.

!  Calculate control variables.

!  Output vp(i,j,k) = vp^-1 vs(i,j,k).

!---------------------------------------------------------------------------------------------
!  gen_statistics3: Calculate Vertical Eigenvectors, Eigenvalues for a given variable.
!---------------------------------------------------------------------------------------------

!  Loop-over/distribute control variables.

!  Loop over times, ensemble members.

!  Read control variables

!  Calculate/accumulate Bv(j,k1,k2).

!  End loop over times, ensemble members.

!  Calculate E, L (v,j,k,k).

!  Loop over times, ensemble members:
!  Output v(i,j,m) = vv^-1 vp(i,j,k)

!---------------------------------------------------------------------------------------------
!  gen_statistics4: Calculate Power spectra for given 2D field.
!---------------------------------------------------------------------------------------------

!  Loop over/distribute variables, vertical modes:

!  Loop over times, ensemble members:

   cvar = 'psi'

   first_time = .true.

   do time = 1, nt
      write(ctime,'(i4)')time

      do member = 1, ne
!         write(cmember,'(i4)')member

!        Read 2D fields.
         filename = trim(cvar)//"date"//"member"//"mode"
         open (iunit, file=filename, form='unformatted')
         read(iunit)ni, nj
         read(iunit)gaussian_lats

         if ( first_time ) then ! Initialize
            allocate( field(1:ni,1:nj) )
            read(iunit)field

!---------------------------------------------------------------------------------------------
            write(6,'(a)')' Initialize spectral transforms.'
!---------------------------------------------------------------------------------------------

            inc = 1
            lenr = inc * (ni - 1 ) + 1
            lensav = ni + int(log(real(ni))) + 4
            lenwrk = ni

            allocate( lat(1:nj) )
            allocate( sinlat(1:nj) )
            allocate( coslat(1:nj) )
            allocate( int_wgts(1:nj) )
            allocate( lon(1:ni) )
            allocate( sinlon(1:ni) )
            allocate( coslon(1:ni) )
            allocate( wsave(1:lensav) )

            max_wavenumber =  ni / 2 - 1
            allocate ( power(0:max_wavenumber) )
            power(:) = 0.0

            alp_size = ( nj + 1 ) * ( max_wavenumber + 1 ) * ( max_wavenumber + 2 ) / 4
            allocate( alp( 1:alp_size) )

            call da_initialize_h( ni, nj, max_wavenumber, lensav, alp_size, &
                                  wsave, lon, sinlon, coslon, lat, sinlat, coslat, &
                                  int_wgts, alp )

            cv_size = ( max_wavenumber + 1 ) * ( max_wavenumber + 2 ) / 2
            allocate( cv( 1:cv_size) )

!           Test horizontal transforms:
            if ( testing_spectral ) then
               call da_test_spectral( ni, nj, max_wavenumber, inc, lenr, lensav, lenwrk, &
                             alp_size, cv_size, alp, wsave, int_wgts, field )
            end if
            first_time = .false.
         else ! Just read field
            read(iunit)field
         end if

!---------------------------------------------------------------------------------------------
         write(6,'(a)')' Perform gridpoint to spectral decomposition.'
!---------------------------------------------------------------------------------------------
         call da_vv_to_v_spectral( ni, nj, max_wavenumber, inc, lenr, lensav, lenwrk, &
                                   alp_size, cv_size, alp, wsave, int_wgts, field, cv )

!---------------------------------------------------------------------------------------------
         write(6,'(a)')' Calculate power spectra.'
!---------------------------------------------------------------------------------------------

         call da_calc_power( max_wavenumber, cv_size, cv, power )
         do n = 0, max_wavenumber
            write(6,'(i4,1pe15.5)')n, power(n)
         end do

      end do  ! End loop over ensemble members.
   end do     ! End loop over times.

   if (trace_use) call da_trace_exit("gen_spectra")
   if (trace_use) call da_trace_report

end program gen_spectra


module parameters_module

    implicit none

    ! Physics constants
    double precision, parameter :: PI = 3.141592654d0, g = 9.8d0
    double precision :: rho_air,rho(2)
    double precision :: r, one_minus_r,manning

    ! Algorithm settings
    double precision :: dry_tolerance
    integer :: eigen_method,inundation_method
    logical :: entropy_fix

    ! Initial condition settings
    integer :: init_type,wave_family
    double precision :: init_location,eta_left(2),eta_right(2)
    double precision :: u_left(2),u_right(2),epsilon,sigma,bathy_type
    double precision :: bathy_location,bathy_left,bathy_right
    double precision :: x0,basin_depth,x1,shelf_depth,shelf_slope

    ! Wind forcing settings
    integer, private :: wind_type
    double precision, private :: A,B,Pn,Pc,ramp_up_time,R_eye_init
    double precision, private :: hurricane_velocity,omega,N,t_length

contains

    ! ========================================================================
    !  Setup all parameters in the module
    ! ========================================================================
    subroutine setup_parameters(data_file)

        implicit none

        ! Input
        character(len=*), optional, intent(in) :: data_file

        ! Locals
        integer :: ios,i

        ! Open file
        if (present(data_file)) then
            call opendatafile(13,data_file)
        else
            call opendatafile(13,'problem.data')
        endif

        ! Physics constants
        read(13,*) rho_air
        read(13,*) rho
        r = rho(1) / rho(2)
        one_minus_r = 1.d0 - r
        read(13,*) manning
        read(13,*)

        ! Algorithm settings
        read(13,*) dry_tolerance
        read(13,*) eigen_method
        read(13,*) inundation_method
        read(13,*) entropy_fix
        read(13,*)

        ! Initial conditions
        read(13,*) init_type
        read(13,*) init_location
        read(13,*) wave_family
        read(13,*) eta_left
        read(13,*) eta_right
        read(13,*) u_left
        read(13,*) u_right
        read(13,*) epsilon
        read(13,*) sigma
        read(13,*)

        ! Bathymetry
        read(13,*) bathy_type
        if (bathy_type == 1) then
            read(13,*) bathy_location
            read(13,*) bathy_left
            read(13,*) bathy_right
        else if (bathy_type == 2) then
            read(13,*) x0
            read(13,*) basin_depth
            read(13,*) x1
            read(13,*) shelf_depth
            shelf_slope = (basin_depth - shelf_depth) / (x0 - x1)
        endif
        read(13,*)

        ! Wind settings
        read(13,*) wind_type
        select case(wind_type)
            case(0) ! No wind
            case(1) ! Constant wind
                read(13,*) A
            case(2) ! Hurricane wind
                read(13,*) A
                read(13,*) B
                read(13,*) Pn
                read(13,*) Pc
                read(13,*) ramp_up_time
                read(13,*) hurricane_velocity
                read(13,*) R_eye_init
            case(3) ! Oscillatory wind
                read(13,*) A
                read(13,*) N
                read(13,*) omega
                read(13,*) t_length
            case(4) ! Gaussian bump
                read(13,*) A
                read(13,*) hurricane_velocity
                read(13,*) R_eye_init
                read(13,*) sigma
            case default
                print *,"Invalid wind field type ", wind_type
                stop
        end select

    end subroutine setup_parameters

    ! Set wind speed based on parameters in this module
    subroutine set_wind(maxmx,mbc,mx,xlower,dx,t,wind)

        implicit none

        ! Input arguments
        integer, intent(in) :: maxmx,mbc,mx
        double precision, intent(in) :: xlower,dx,t

        ! Output
        double precision, intent(inout) :: wind(1-mbc:maxmx+mbc)

        ! Local variables
        integer :: i
        double precision :: x,L,time,C,R_eye,r

        ! Parse time input, if -99.d99 assume we are at the initial time step and
        ! use ramp_up_time as the initial time if we are trying to do a hurricane
        ! wind field and ramp up, otherwise leave t alone
        if (t == -99.d99) then
            if (wind_type == 2) then
                time = -ramp_up_time
            else
                time = 0.d0
            endif
        else
            time = t
        endif

        select case(wind_type)
            ! No wind
            case(0)
                wind = 0.d0
            ! Constant wind
            case(1)
                wind = A
            ! Hurricane wind
            case(2)
                ! Hurrican eye location
                R_eye = t * hurricane_velocity + R_eye_init

                ! Parameter constant
                C = 1.d1 * 1.d3**(B/2.d0) * sqrt(A*B*(Pn-Pc)/(rho_air))

                ! Set wind field
                do i=1-mbc,mx+mbc
                    ! Distance from center of storm
                    x = xlower + (i-0.5d0) * dx - R_eye
                    r = abs(x)
                    ! If sufficiently far from eye, calculate wind velocity
                    if (r >= 1.d-3) then
                        wind(i) = sign(1.d0,x) * C * sqrt(exp(-1.d3**B*A/r**B)/r**B)
                    endif
                enddo

                ! Ramp up
                if (t < 0.d0) then
                    wind = wind * exp(-(t/(ramp_up_time*0.45d0))**2)
                endif

            ! Oscillating wind field
            case(3)
                L = xlower + mx * dx
                do i=1-mbc,mx+mbc
                    x = xlower + (i-0.5d0) * dx
                    wind(i) = A * sin(PI*n*(x)/L) * sin(2*PI*omega/t_length*t)
                enddo
            ! Moving gaussian wind field
            case(4)
                R_eye = t * hurricane_velocity + R_eye_init
                do i=1-mbc,mx+mbc
                    x = xlower + (i-0.5d0) * dx - R_eye
                    wind(i) = A * exp(-((x-R_eye_init)/sigma)**2)
                enddo
        end select

    end subroutine set_wind

    double precision function wind_drag(wind_speed)

        implicit none

        ! Input
        double precision, intent(in) :: wind_speed

        if (wind_speed <= 11.d0) then
            wind_drag = 1.2d0
        else if ((wind_speed > 11.d0).and.(wind_speed <= 25.d0)) then
            wind_drag = 0.49d0 + 0.065d0 * wind_speed
        else
            wind_drag = 0.49 + 0.065d0 * 25.d0
        endif

        wind_drag = wind_drag * 10.d-3

    end function wind_drag

end module parameters_module

subroutine setprob()

    use parameters_module

    implicit none

    call setup_parameters()

end subroutine setprob


! { dg-do run }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } { "*" } { "" } }
!
! PR fortran/34427
!
! Check that namelists and the real values Inf, NaN, Infinity
! properly coexist with interceding line ends and spaces.
!
PROGRAM TEST
  IMPLICIT NONE
  real , DIMENSION(10) ::foo
  integer :: infinity
  integer :: numb
  NAMELIST /nl/ foo
  NAMELIST /nl/ infinity
  foo = -1.0
  infinity = -1

  open (10, status="scratch")

  write (10,'(a)') " &nl foo(1:6) = 5, 5, 5, nan, infinity"
  write (10,'(a)')
  write (10,'(a)')
  write (10,'(a)')
  write (10,'(a)')
  write (10,'(a)') "infinity"
  write (10,'(a)')
  write (10,'(a)')
  write (10,'(a)') "         "
  write (10,'(a)')
  write (10,'(a)')
  write (10,'(a)')
  write (10,'(a)')
  write (10,'(a)')
  write (10,'(a)')
  write (10,'(a)')
  write (10,'(a)')
  write (10,'(a)') "=1/"
  rewind (10)
  READ (10, NML = nl)
  CLOSE (10)
  if(infinity /= 1) call abort
  if(any(foo(1:3) /= [5.0, 5.0, 5.0]) .or. .not.isnan(foo(4)) &
     .or. (foo(5) <= huge(foo)) .or. any(foo(6:10) /= -1.0)) &
    call abort
END PROGRAM TEST


! { dg-do compile }
!
! PR 46271: [F03] OpenMP default(none) and procedure pointers
!
! Contributed by Marco Restelli <mrestelli@gmail.com>

program test
  implicit none
  integer :: i
  real :: s(1000)
  procedure(f), pointer :: pf

  pf => f

  !$omp parallel do schedule(static) private(i) shared(s,pf) default(none)
  do i=1,1000
    call pf(real(i),s(i))
  enddo
  !$omp end parallel do

  write(*,*) 'Sum ',sum(s)
contains
  pure subroutine f(x,y)
    real, intent(in) :: x
    real, intent(out) :: y
    y = sin(x)*cos(x)
  end subroutine
end


module array_utils
    implicit none

    public :: sum_array

contains

    function sum_array(a) result(s)
        implicit none
        real(kind=8), intent(in), dimension(:) :: a
        real(kind=8) :: s
        integer :: i, n
        n = size(a)
        s = 0.0D00
        do i = 1, n
            s = s + a(i)
        end do
    end function sum_array

end module array_utils


 	SUBROUTINE GMERML ( mproj, np, xm, ym, anglr1, xl, yl, iret )
C************************************************************************
C* GMERML								*
C* 									*
C* This subroutine converts a point from map latitude/longitude		*
C* to intermediate coordinates for the general Mercator case.		*
C* See cylindrical class projection for the usual Mercator map.		*
C* 									*
C* GMERML  ( MPROJ, NP, XM, YM, ANGLR1, XL, YL, IRET )			*
C*									*
C* Input parameters:							*
C*	MPROJ		INTEGER		Projection type ( not used )	*
C*	NP		INTEGER		Number of points		*
C* 	XM(*)		REAL		Latitudes			*
C* 	YM(*)		REAL		Longitudes			*
C*	ANGLR1		REAL		Center longitude		*
C* 									*
C* Output parameters:							*
C* 	XL(*) 		REAL		X coordinates			*
C* 	YL(*) 		REAL		Y coordinates			*
C*	IRET		INTEGER		Return code			*
C** 									*
C* Log:									*
C* B. Doty/RDS		 4/87	GEMPLT 4				*
C* M. desJardins/GSFC	 1/88	Fixed missing data			*
C* M. desJardins/GSFC	 6/88	Documentation				*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		xm (*), ym (*), xl (*), yl (*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = NORMAL
C*
	DO  i = 1, np
	    IF  ( ( ERMISS ( xm (i) ) ) .or. ( ERMISS ( ym (i) ) ) )
     +        THEN
		xl (i) = RMISSD
		yl (i) = RMISSD
	      ELSE
		xmr = xm (i) * DTR
		ymr = ym (i) * DTR
		angdif = ymr - anglr1
		rrr1 = TAN ( xmr )
		rrr2 = COS ( angdif )
		IF  ( ( rrr1 .eq. 0.0 ) .and. (rrr2 .eq. 0.0) )  THEN
		    xl (i) = RMISSD
		    yl (i) = RMISSD
		  ELSE
		    b  = COS ( xmr ) * SIN ( angdif )
		    b1 = ( 1.0 + b ) / ( 1.0 - b )
		    xl (i) = 0.5 * LOG ( b1 )
		    yl (i) = ATAN2 ( rrr1 , rrr2 )
		END IF
	    END IF
	END DO
C*
	RETURN
	END


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pt_near_far( knf, n, c, gg, p, xnf )

!  Determine the point xnf in the specified ellipsoid E that is
!  closest (for knf=1) or furthest (for knf=2) from the specified point p.
!  The ellipsoid E is given by:
!  { x | norm(G^T * (x-c) ) <=1 ), where G is an n x n lower triangular
!  matrix.  The array gg contains the matrix G in packed format.

!  See ellu_pt_near_far for details

!  S.B. Pope  12/1/2006

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: knf, n
real(k_dp), intent(in)  :: c(n), gg((n*(n+1))/2), p(n)
real(k_dp), intent(out) :: xnf(n)

integer    :: i, j, k
real(k_dp) :: g(n,n)

!  unpack gg into g
k = 0
g = 0.d0
do j = 1, n
   do i = j, n
      k = k + 1
	  g(i,j) = gg(k)
   end do
end do

call ellu_pt_near_far( knf, n, c, g, p, xnf )

return
end subroutine ell_pt_near_far


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download

program sys_sim501

! See work from 13 October, 2003. Test to evaluate how to look_for_bias in
! prior ensemble distribution and observation in observation space.

use random_seq_mod, only : random_seq_type, init_random_seq, random_gaussian, &
   twod_gaussians, random_uniform

implicit none

type (random_seq_type) :: r
double precision :: correl, cov(2, 2), zero_2(2) = 0.0, correl_mean, correl_var
double precision :: q, alpha, alpha2, mean_abs_correl
double precision, allocatable :: pairs(:, :), sample_correl(:)
integer :: ens_size, n_samples, i, j, k

! Initialize repeatable random sequence
call init_random_seq(r)

! For now have a set of free parameters that may be too large
write(*, *) 'Input ensemble size'
read(*, *) ens_size
write(*, *) 'Input number of samples for statistics'
read(*, *) n_samples

! Allocate storage for sample from this correlation
allocate(pairs(2, ens_size), sample_correl(n_samples))

! Loop through 101 correlaton values
do k = 1, 101
   correl = (k - 1.0) * 0.01
   ! Generate the covariance matrix for this correlation
   cov(1, 1) = 1.0;    cov(2, 2) = 1.0
   cov(1, 2) = correl; cov(2, 1) = correl

   ! Loop for each sample size
   do j = 1, n_samples
      ! Loop to generate an ensemble size sample from this correl
      ! Generate a random sample of size ens_size from something with this correlation
      do i = 1, ens_size
         call twod_gaussians(r, zero_2, cov, pairs(:, i))
      end do

      ! Compute the sample correlation
      call comp_correl(pairs, ens_size, sample_correl(j))
      !!!   write(*, *) 'sample correl is ', sample_correl(j)
   end do

   ! Compute a mean and standard deviation of the sample correlations
   call sample_mean_var(sample_correl, n_samples, correl_mean, correl_var)
   q = sqrt(correl_var) / abs(correl_mean)
   write(*, *) 'correl mean and sd', correl_mean, sqrt(correl_var)
   write(*, *) 'ratio of sd to mean is ', q

   ! Also compute the mean of the absolute value of correl
   mean_abs_correl = sum(abs(sample_correl)) / n_samples
   write(*, *) 'correl, mean_abs_correl ', correl, mean_abs_correl

   ! Value of alpha (regression confidence factor) is computed as limit of
   ! group size m -> infinity from paper: alpha = 1 / (Q^2 + 1)
   alpha = 1.0 / (q**2 + 1)
   if(alpha < 0) alpha = 0.0
   ! Maybe I should really be doing this in limit of m = 1, single sample?
   alpha2 = 1.0 - q**2
   if(alpha2 < 0.0) alpha2 = 0.0
   write(*, *)  correl, alpha, alpha2
end do

end program sys_sim501

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

subroutine comp_correl(ens, n, correl)

implicit none

integer, intent(in) :: n
double precision, intent(in) :: ens(2, n)
double precision, intent(out) :: correl
double precision :: sum_x, sum_y, sum_xy, sum_x2, sum_y2

sum_x = sum(ens(2, :))
sum_y = sum(ens(1, :))
sum_xy = sum(ens(2, :) * ens(1, :))
sum_x2 = sum(ens(2, :) * ens(2, :))

! Computation of correlation
sum_y2 = sum(ens(1, :) * ens(1, :))

correl = (n * sum_xy - sum_x * sum_y) / &
   sqrt((n * sum_x2 - sum_x**2) * (n * sum_y2 - sum_y**2))

end subroutine comp_correl

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

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

subroutine sample_mean_var(x, n, mean, var)

implicit none

integer, intent(in) :: n
double precision, intent(in) :: x(n)
double precision, intent(out) :: mean, var

double precision :: sx, s_x2

sx = sum(x)
s_x2 = sum(x * x)
mean = sx / n
var = (s_x2 - sx**2 / n) / (n - 1)

end subroutine sample_mean_var


! { dg-do run }
!
! PR 40176:  Fortran 2003: Procedure pointers with array return value
!
! Original test case by Barron Bichon <barron.bichon@swri.org>
! Modified by Janus Weil <janus@gcc.gnu.org>

PROGRAM test_prog

  PROCEDURE(triple), POINTER :: f

  f => triple
  if (sum(f(2.,4.)-triple(2.,4.))>1E-3) call abort()

CONTAINS

  FUNCTION triple(a,b) RESULT(tre)
    REAL, INTENT(in) :: a, b
    REAL :: tre(2)
    tre(1) = 3.*a
    tre(2) = 3.*b
  END FUNCTION triple

END PROGRAM test_prog


! -*- f90 -*-
!#########################################
! SUBROUTINES TO COMPUTE CORRELATIONS
!#########################################

subroutine correlation(a,b,axis,dx,step,rlen,nx,ny,nz,r,corr)
   implicit none
   integer, intent (in) :: nx,ny,nz,axis,rlen,step
   double precision, intent (in) :: dx
   double precision, intent (in), dimension(nx,ny,nz) :: a,b
   double precision, intent (out),dimension(rlen)     :: r,corr
!f2py intent (in) nx,ny,nz,axis,rlen,step
!f2py intent (in) dx
!f2py intent (in) a,b
!f2py intent (out) r,corr
   integer :: ii,x,y,z,xx,yy,zz
   double precision :: sumab
!  double precision, dimension(nx,ny,nz) :: br

   ! We can work with total sums instead of means as nx*ny*nz
   ! cancels out in the final definition
!  sumab=sum(a*b)
    ! SELECT CASE (axis+1)
    !    CASE (1)
    !       print *, 'correlation along x'
    !    CASE (2)
    !       print *, 'correlation along y'
    !    CASE(3)
    !       print *, 'correlation along z'
    ! END SELECT

   do ii=0,rlen-1
   corr(ii+1) = 0.
   do z=1,nz; do y=1,ny; do x=1,nx
      SELECT CASE (axis+1)
         CASE (1)
            call roll_idx(x,nx,ii,xx); yy=y; zz=z
         CASE (2)
            xx=x; call roll_idx(y,ny,ii,yy); zz=z
         CASE(3)
            xx=x; yy=y; call roll_idx(z,nz,ii,zz)
      END SELECT
      corr(ii+1) = corr(ii+1)+a(x,y,z)*b(xx,yy,zz)
   enddo; enddo; enddo
!     call rollarr(b,axis+1,ii*step,br,nx,ny,nz)
!     corr(ii+1) = corr(ii+1)/sumab
      r(ii+1)    = ii*dx*step
   enddo
   corr(:)=corr(:)/corr(1)
end subroutine correlation


      INTEGER FUNCTION INDEXR( V, NE, TE, LF )
C
C         *INDEXR* FINDS THE INDEX OF THE ELEMENT OF TABLE TE THAT IS
C         JUST LESS THAN OR EQUAL TO V.
C
C         GLOSSARY
C     V  = VARIABLE
C     NE = NUMBER OF ELEMENTS IN TABLE TE
C     TE = TABLE OF ELEMENTS ARRANGED IN ASCENDING OR DESCENDING ORDER
C     LF = LOGICAL FLAG
C
C     DIMENSION TE(1 )
	real*8 TE(NE),v
	LOGICAL LF

c	do i=1,NE
c	write(*,*)TE(i)
c	enddo

C
C
C         ORDER TEST
      IF ( TE(1) .GT. TE(2) ) GO TO 7
C
C         EXTREME TESTS
      IF ( V .GE. TE(1) ) GO TO 1
      LF = .TRUE.
      I = 1
      GO TO 14
C
   1  IF ( V .LT. TE(NE) ) GO TO 2
      LF = .TRUE.
      I = NE
      GO TO 14
C
C         INITIALIZATIONS
   2  LF = .FALSE.
      ND = 1
C
   3  ND = ND + ND
      IF ( ND .GE. NE ) GO TO 4
      GO TO 3
C
   4  ND = ND / 2
      I = ND
C
C         BISECTION LOOP
   5  ND = ND / 2
      IF ( ND .LE. 0 ) GO TO 6
      J = MIN0( NE, I )
      IF ( V .GT. TE(J) ) I = I + ND
      IF ( V .LT. TE(J) ) I = I - ND
      GO TO 5
C
   6  IF ( I .GE. NE ) GO TO 14
      IF ( V .GT. TE(I+1) ) I = I + 1
      IF ( V .LT. TE(I) ) I = I - 1
C
      GO TO 14
C
C         EXTREME TESTS
   7  IF ( V .GE. TE(NE) ) GO TO 8
      LF = .TRUE.
      I = NE
      GO TO 14
C
   8  IF ( V .LT. TE(1) ) GO TO 9
      LF = .TRUE.
      I = 1
      GO TO 14
C
C         INITIALIZATIONS
   9  LF = .FALSE.
      ND = 1
C
  10  ND = ND + ND
      IF ( ND .GE. NE ) GO TO 11
      GO TO 10
C
  11  ND = ND / 2
      I = ND
C
C         BISECTION LOOP
  12  ND = ND / 2
      IF ( ND .LE. 0 ) GO TO 13
      J = MIN0( NE, I )
      IF ( V .GT. TE(J) ) I = I - ND
      IF ( V .LT. TE(J) ) I = I + ND
      GO TO 12
C
  13  IF ( I .GE. NE ) GO TO 14
      IF ( V .GT. TE(I-1) ) I = I - 1
      IF ( V .LT. TE(I) ) I = I + 1
      I = MAX0( 1, I - 1 )
C
  14  INDEXR = MIN0( NE - 1, I )
C
      RETURN
      END
C$  FINTRP
c     real*8 FUNCTION FINTRP ( MODE, X, X1, F1, X2, F2 )
C
C         *FINTRP* INTERPOLATES BETWEEN X1 AND X2 USING A FUNCTIONAL
C         FORM THAT DEPENDS UPON THE SPECIFIED MODE. MODES - -
C     1 = LINEAR - - A * X + B
C     2 = EXPONENTIAL - - A * EXP( B * X )
C     3 = POWER LAW - - A * X**B
C
c     GO TO ( 10, 20, 30 ), MODE
C
C         LINEAR INTERPOLATION
C
c 10  F = F1 + ( F1 - F2 ) * ( X - X1 ) / ( X1 - X2 )
c     GO TO 40
C
C         EXPONENTIAL INTERPOLATION
C
c 20  F = F1 * ( F1 / F2 )**( ( X - X1 ) / ( X1 - X2 ) )
c     GO TO 40
C
C         POWER LAW INTERPOLATION
C
c 30  IF ( X1 .LE. 0. ) GO TO 20
c     F = F1 * ( X / X1 )**( ALOG( F1 / F2 ) / ALOG( X1 / X2 ) )
C
c 40  FINTRP = F
C
c     RETURN
c     END


a = (/(i * i, i = 1, 10)/)


! Program to test the FORALL construct
program testforall
   implicit none
   integer, dimension (3, 3) :: a
   integer, dimension (3) :: b
   integer i

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/));

   forall (i=1:3)
      b(i) = sum (a(:, i))
   end forall

   if (b(1) .ne. 6) call abort
   if (b(2) .ne. 15) call abort
   if (b(3) .ne. 24) call abort
end program


!==============================================================================!
  subroutine Factorize_Number(i, number, factrs)
!------------------------------------------------------------------------------!
!   Splits the number into it's primal factors. ( 30 = 5 x 3 x 2 ).            !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  integer :: number, factrs(128)
!-----------------------------------[Locals]-----------------------------------!
  integer :: i, j, primes(15)
!==============================================================================!
  data primes /47,43,41,37,31,29,23,19,17,13,11, 7, 5, 3, 2/
!------------------------------------------------------------------------------!
!   For example if factor is called with number = 30 it will split it          !
!   into 5,3 and 2, and make the following output:                             !
!   i=3, factrs(1)=5, factrs(2)=3, factrs(3)=2                                 !
!   See also: Divide                                                           !
!------------------------------------------------------------------------------!

  i=0
  do j=1,15

1   if( mod(number,primes(j)) == 0 ) then
      number = number/primes(j)
      i = i + 1
      factrs(i) = primes(j)
      goto 1
    endif

  end do

  end subroutine Factorize_Number


        program orbits

        implicit none

        integer*4 i,n
        integer j
        integer ilun,olun
        real*8  r0(3),r1(3)
        real*8  f0(3),f1(3),a0(3),a1(3)
        real*8  v0(3),v1(3)
        real*8  m0,m1
        real*8  dt
        real*8  g
        real*8  neg
        integer n3,incx

        data g  / 6.67384E-11 /
        data n3,neg,incx /3,-1.0,1/
        data ilun,olun /5,6/
        common /consts/ G

800     format(a5,f10.0,a5,f10.0,a5,f10.0)
801     format(i6,2(3(X,D18.9)))
802     format(a6,2(3(X,A18)))

900     format(3(F11.0))
901     format(X,E11.5)
902     format(X,F11.0,X,I6)

        read(ilun,900) (R0(I),I=1,3)
        read(ilun,900) (V0(I),I=1,3)
        read(ilun,901) m0

        read(ilun,900) (R1(I),I=1,3)
        read(ilun,900) (V1(I),I=1,3)
        read(ilun,901) m1

        read(ilun,902) dt,n

        write(olun,802) ' NUM ','X0','Y0','Z0','X1','Y1','Z1'

        do I=1,n
           call gravf(r0,m0,r1,m1,f0)

*          f1 = -f0
           call DCOPY(n3,f0,incx,f1,incx)
           call DSCAL(n3,neg,f1,incx)

*          a0 = f0 / m0
           call DCOPY(n3,f0,incx,a0,incx)
           call DSCAL(n3,1/m0,a0,incx)
*          a1 = f1 / m1
           call DCOPY(n3,f1,incx,a1,incx)
           call DSCAL(n3,1/m1,a1,incx)

           call DAXPY(n3,dt,a0,incx,v0,incx)
           call DAXPY(n3,dt,a1,incx,v1,incx)
           call DAXPY(n3,dt,v0,incx,r0,incx)
           call DAXPY(n3,dt,v1,incx,r1,incx)

           write(olun,801) I,(R0(J),J=1,3),(R1(J),J=1,3)
        enddo
        end

      subroutine gravf(a,am,b,bm,f)
      implicit none

      DOUBLE PRECISION DNRM2
*     real*8  vecmod

      real*8  a(3),b(3),am,bm,f(3)
      real*8  r,coef
      real*8  v(3)
      real*8  g
      integer n3,incx
      real*8  neg

      data n3,neg,incx /3,-1.0,1/
      common /consts/ g

*     v = a - b
      call DCOPY(n3,a,incx,v,incx)
      call DAXPY(n3,neg,b,incx,v,incx)
*      print *,v

*     r = mod(v)
      r = DNRM2(n3,v,incx)
      coef = (-g*am*bm) / r**3
*      print *,coef

*     f = coef * v
      call DCOPY(n3,v,incx,f,incx)
      call DSCAL(n3,coef,f,incx)
*      print *,f

      return
      end


       DIMENSION PHI(0:200)

       EXACT(R)=1.-(R+2)*EXP(-R)/2
       SOURCE(R)=-R*EXP(-R)/2
       H=.1
       NSTEP=20./H
       CONST=H**2/12

       SM=0.
       SZ=SOURCE(H)
       PHI(0)=0
       PHI(1)=EXACT(H)
*       PHI(1)=.95*PHI(1)

       DO 10 IR=1,NSTEP-1
          R=(IR+1)*H
          SP=SOURCE(R)

          PHI(IR+1)=2*PHI(IR)-PHI(IR-1)+CONST*(SP+10.*SZ+SM)
          SM=SZ
          SZ=SP
10     CONTINUE

       SLOPE=(PHI(NSTEP)-PHI(NSTEP-10))/(10*H)
       DO 20 IR=1,NSTEP
          R=IR*H
          PHI(IR)=PHI(IR)-SLOPE*R
          DIFF=EXACT(R)-PHI(IR)
          PRINT *, R,EXACT(R),PHI(IR),DIFF
20     CONTINUE

       STOP
       END


REAL A(3,5), B(5,3)
DATA ((A(I,J),I=1,3),J=1,5) /1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15/

DO I = 1, 3
   DO J = 1, 5
      B(J,I) = A(I,J)
   END DO
END DO


C     LAST UPDATE 10/12/92
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE SVBKSB(U,W,V,M,N,MP,NP,B,X)
      IMPLICIT NONE
C
C Purpose: Solves A.X = B for a vector X, where A is specified by the
C          arrays U,W,V as returned by SDVCMP. M and N are the logical
C          dimensions of A and will be equal for quare matrices. MP and
C          NP are the physical dimensions of A. B is the input right
C          hand side. X is the output solution vector. No input
C          quantities are destroyed so the routine may be called
C          sequentially wuth different B's. M must be greater or equal
C          to N; see SVDCMP.
C
      INTEGER M,N,MP,NP
      REAL U(MP,MP),V(NP,NP),W(NP),B(MP),X(NP)
C
C Calls   0:
C Called by: SVDFIT
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      INTEGER NMAX
      PARAMETER(NMAX=5000)
      REAL TMP(NMAX)
      REAL S
      INTEGER I,J,JJ
C
C---------------------------------------------------------------------
      DO 20 J=1,N
         S = 0.0
         IF(W(J).NE.0.0)THEN
            DO 10 I=1,M
               S = S + U(I,J)*B(I)
 10         CONTINUE
            S = S/W(J)
         ENDIF
         TMP(J) = S
 20   CONTINUE
      DO 40 J=1,N
         S = 0.0
         DO 30 JJ=1,N
            S = S + V(J,JJ)*TMP(JJ)
 30      CONTINUE
         X(J) = S
 40   CONTINUE
      RETURN
      END