subroutine interpweights(lon_i, lat_i,nx,ny, lon_o, lat_o,imax, jmax, r1, r2, r3, r4, i1, j1,topo)
  implicit none
  integer, intent(in) :: nx, ny, imax, jmax
  real, intent(in), dimension(ny,nx) :: lon_i, lat_i
  integer, intent(in), dimension(ny,nx) ::  topo
  real, intent(in), dimension(imax,jmax) :: lon_o, lat_o
  integer, intent(inout), dimension(imax,jmax) :: i1, j1
  real, intent(inout), dimension(imax,jmax) :: r1, r2, r3, r4
  real :: rsum, x,y, rx, ry
  integer :: i,j

  do j=1,jmax
     do i=1, imax

        ! For h-points
        x=(lon_o(i,j) - lon_i(1,1))/(lon_i(1,2)-lon_i(1,1)) + 1.0

        y=(lat_o(i,j) - lat_i(1,1))/(lat_i(2,1)-lat_i(1,1)) + 1.0

        ! Beware of negative x values! (Longitude wrap in global grids)
        if (x.lt.0.0) x=x+nx
!!$
        i1(i,j)=ifix(x)
        j1(i,j)=ifix(y)

        rx=(x-ifix(x))
        ry=(y-ifix(y))

        r1(i,j) = (1.0-rx)*(1.0-ry)
        r2(i,j) =      rx *(1.0-ry)
        r3(i,j) =      rx *     ry
        r4(i,j) = (1.0-rx)*     ry

!!$        ! Check for landpoints!
!!$        r1(i,j) = r1(i,j)*real(topo(j1(i,j),i1(i,j)))
!!$        r2(i,j) = r2(i,j)*real(topo(j1(i,j),i1(i,j)+1))
!!$        r3(i,j) = r3(i,j)*real(topo(j1(i,j)+1,i1(i,j)+1))
!!$        r4(i,j) = r4(i,j)*real(topo(j1(i,j)+1,i1(i,j)))
!!$
!!$        rsum = r1(i,j) + r2(i,j) + r3(i,j) + r4(i,j)
!!$        if (rsum.gt.0.0) then
!!$           rsum=1.0/rsum
!!$           r1(i,j) = r1(i,j)*rsum
!!$           r2(i,j) = r2(i,j)*rsum
!!$           r3(i,j) = r3(i,j)*rsum
!!$           r4(i,j) = r4(i,j)*rsum
!!$        end if

     end do
  end do

end subroutine interpweights


module sta2dfft

use stafft

! This module performs FFTs in two directions on two dimensional arrays using
! the stafft library module to actually compute the FFTs. If FFTs in one
! direction only are required use the stafft module directly. The module can
! compute any combination of sine, cosine and full FFTs in each direction.
! Along with the usual forwards (physical -> Fourier space) and reverse
! (Fourier space -> physical) routines there are also routines for computing
! the first derivatives in either direction.
!
! The convention is that for each direction the array is dimensioned 1:nx or
! 1:ny for either the sine or full transforms. While the cosine transforms
! require the additional endpoint so 0:nx or 0:ny.
!
! The routines contained in this module are:
!
! init2dfft(nx,ny,lx,ly,xfactors,yfactors,xtrig,ytrig,kx,ky)
!          This routine initialises all the arrays needed for further
!          transforms. The integers nx and ny are the array dimensions. Then
!          lx and ly are the domain lengths - these are needed for the correct
!          scaling when computing derivatives. The arrays xfactors, yfactors,
!          xtrig and ytrig are needed to perform the various FFTs by the stafft
!          module (see there for further details. kx and ky are arrays to hold
!          the wavenumbers associated with each mode in the domain, and are
!          used in computing derivatives.
!
!          **If it is known at initialisation that no derivatives are required
!            it is possible just to pass 1.d0 for each of lx and ly, along with
!            dummy arrays for kx and ky since these are only needed for
!            computing the derviatives.**

implicit none

contains

!=====================================================================
subroutine init2dfft(nx,ny,lx,ly,xfactors,yfactors,xtrig,ytrig,kx,ky)

! This subroutine performs the initialisation work for all subsequent
! transform and derivative routines.
! It calls the initfft() routine from the supproting 1d FFT module for
! transforms in both x and y directions.
! The routine then defines the two wavenumber arrays, one in each direction.

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: lx,ly,kx(nx),ky(ny)

 !Local declarations:
double precision,parameter:: pi=3.141592653589793238462643383279502884197169399375105820974944592307816d0
double precision:: sc
integer:: k

!----------------------------------------------
call initfft(nx,xfactors,xtrig)
call initfft(ny,yfactors,ytrig)

if (lx .ne. 0.d0) then
   !Define x wavenumbers:
  sc=pi/lx
  do k=1,nx
    kx(k)=sc*dble(k)
  enddo
else
   !Catastrophic end to run if wave number definition fails:
  write(*,*) '**********************************************'
  write(*,*) ' Wavenumber array definition not possible.'
  write(*,*) ' Domain length in x equal to zero not allowed.'
  write(*,*) ' STOPPING...'
  write(*,*) '**********************************************'
  stop
endif

if (ly .ne. 0.d0) then
   !Define y wavenumbers:
  sc=pi/ly
  do k=1,ny
    ky(k)=sc*dble(k)
  enddo
else
   !Catastrophic end to run if wave number definition fails:
  write(*,*) '**********************************************'
  write(*,*) ' Wavenumber array definition not possible.'
  write(*,*) ' Domain length in y equal to zero not allowed.'
  write(*,*) ' STOPPING...'
  write(*,*) '**********************************************'
  stop
endif

return
end subroutine

!===================================================
! These routines are for arrays periodic in x and y.
!===================================================

subroutine ptospc(nx,ny,rvar,svar,xfactors,yfactors,xtrig,ytrig)
! Performs a physical -> spectral transform of a variable
! rvar(ny,nx) periodic in x and y, and returns the result
! (transposed) in svar(nx,ny).
! *** Note rvar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(ny,nx),svar(nx,ny)
 !Local declarations:
integer:: kx,iy

 !Carry out a full x transform first:
call forfft(ny,nx,rvar,xtrig,xfactors)

 !Transpose array:
do kx=1,nx
  do iy=1,ny
    svar(kx,iy)=rvar(iy,kx)
  enddo
enddo

 !Carry out a full y transform on transposed array:
call forfft(nx,ny,svar,ytrig,yfactors)

return
end subroutine

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

subroutine spctop(nx,ny,svar,rvar,xfactors,yfactors,xtrig,ytrig)
! Performs a spectral -> physical transform of a variable
! svar(nx,ny) periodic in x and y and returns the result
! (transposed) in rvar(ny,nx).
! *** Note svar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(ny,nx),svar(nx,ny)
 !Local declarations:
integer:: kx,iy

 !Carry out a full inverse y transform first:
call revfft(nx,ny,svar,ytrig,yfactors)

 !Transpose array:
do kx=1,nx
  do iy=1,ny
    rvar(iy,kx)=svar(kx,iy)
  enddo
enddo

 !Carry out a full inverse x transform:
call revfft(ny,nx,rvar,xtrig,xfactors)

return
end subroutine

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

subroutine xderiv(nx,ny,rkx,var,der)
! Computes der = d(var)/dx, spectrally, for a variable
! var(nx,ny) periodic in x and y.
! *** both var and der are spectral ***

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rkx(nx),var(nx,ny),der(nx,ny)
 !Local declarations:
integer:: nwx,nxp2,kx,ky,dkx,kxc

nwx=nx/2
nxp2=nx+2
 !Carry out differentiation by wavenumber multiplication:
do ky=1,ny
  der(1,ky)=0.d0
  do kx=2,nx-nwx
    dkx=2*(kx-1)
    kxc=nxp2-kx
    der(kx, ky)=-rkx(dkx)*var(kxc,ky)
    der(kxc,ky)= rkx(dkx)*var(kx ,ky)
  enddo
enddo

if (mod(nx,2) .eq. 0) then
  kxc=nwx+1
  do ky=1,ny
    der(kxc,ky)=0.d0
  enddo
endif

return
end subroutine

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

subroutine yderiv(nx,ny,rky,var,der)
! Computes der = d(var)/dy, spectrally, for a variable
! var(nx,ny) periodic in x and y.
! *** both var and der are spectral ***

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rky(ny),var(nx,ny),der(nx,ny)
 !Local declarations:
integer:: nwy,nyp2,kx,ky,kyc
double precision:: fac

nwy=ny/2
nyp2=ny+2
 !Carry out differentiation by wavenumber multiplication:
do kx=1,nx
  der(kx,1)=0.d0
enddo

do ky=2,ny-nwy
  kyc=nyp2-ky
  fac=rky(2*(ky-1))
  do kx=1,nx
    der(kx, ky)=-fac*var(kx,kyc)
    der(kx,kyc)= fac*var(kx ,ky)
  enddo
enddo

if (mod(ny,2) .eq. 0) then
  kyc=nwy+1
  do kx=1,nx
    der(kx,kyc)=0.d0
  enddo
endif

return
end subroutine

!===================================================
! These routines are for arrays periodic in x only.
!===================================================

subroutine ptospc_fc(nx,ny,rvar,svar,xfactors,yfactors,xtrig,ytrig)
! Performs a physical -> spectral transform of a variable
! rvar(0:ny,nx) periodic in x and represented by a cosine
! series in y and returns the result (transposed) in
! svar(nx,0:ny).
! *** Note rvar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(0:ny,nx),svar(nx,0:ny)
 !Local declarations:
integer:: kx,iy

 !Carry out a full x transform first:
call forfft(ny+1,nx,rvar,xtrig,xfactors)

 !Transpose array:
do kx=1,nx
  do iy=0,ny
    svar(kx,iy)=rvar(iy,kx)
  enddo
enddo

 !Carry out y cosine transform on transposed array:
call dct(nx,ny,svar,ytrig,yfactors)

return
end subroutine

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

subroutine ptospc_fs(nx,ny,rvar,svar,xfactors,yfactors,xtrig,ytrig)
! Performs a physical -> spectral transform of a variable
! rvar(ny,nx) periodic in x and represented by a sine series in y
! and returns the result (transposed) in svar(nx,ny).
! *** Note rvar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(ny,nx),svar(nx,ny)
 !Local declarations:
integer:: kx,iy

 !Carry out a full x transform first:
call forfft(ny,nx,rvar,xtrig,xfactors)

 !Transpose array:
do kx=1,nx
  do iy=1,ny-1
    svar(kx,iy)=rvar(iy,kx)
  enddo
  svar(kx,ny)=0.d0
enddo

 !Carry out y sine transform on transposed array:
call dst(nx,ny,svar,ytrig,yfactors)

return
end subroutine

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

subroutine spctop_fc(nx,ny,svar,rvar,xfactors,yfactors,xtrig,ytrig)
! Performs a spectral -> physical transform of a variable
! svar(nx,0:ny) periodic in x and represented by a cosine
! series in y and returns the result (transposed) in
! rvar(0:ny,nx)
! *** Note svar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(0:ny,nx),svar(nx,0:ny)
 !Local declarations:
integer:: kx,iy

 !Carry out y cosine transform first:
call dct(nx,ny,svar,ytrig,yfactors)

 !Transpose array:
do kx=1,nx
  do iy=0,ny
    rvar(iy,kx)=svar(kx,iy)
  enddo
enddo

 !Carry out a full inverse x transform:
call revfft(ny+1,nx,rvar,xtrig,xfactors)

return
end subroutine

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

subroutine spctop_fs(nx,ny,svar,rvar,xfactors,yfactors,xtrig,ytrig)
! Performs a spectral -> physical transform of a variable
! svar(nx,ny) periodic in x and represented by a sine series
! in y and returns the result (transposed) in rvar(ny,nx).
! *** Note svar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(ny,0:nx-1),svar(0:nx-1,ny)
 !Local declarations:
integer:: kx,iy

 !Carry out y sine transform first:
call dst(nx,ny,svar,ytrig,yfactors)

 !Transpose array:
do kx=0,nx-1
  do iy=1,ny-1
    rvar(iy,kx)=svar(kx,iy)
  enddo
  rvar(ny,kx)=0.d0
enddo

 !Carry out a full inverse x transform:
call revfft(ny,nx,rvar,xtrig,xfactors)

return
end subroutine

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

subroutine xderiv_fs(nx,ny,rkx,var,der)
! Computes der = d(var)/dx, spectrally, for a variable
! var(nx,ny) periodic in x and represented by a sine
! series in y.
! *** both var and der are spectral ***

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rkx(nx),var(nx,ny),der(nx,ny)
 !Local declarations:
integer:: nwx,nxp2,kx,ky,dkx,kxc

nwx=nx/2
nxp2=nx+2
 !Carry out differentiation by wavenumber multiplication:
do ky=1,ny-1
  der(1,ky)=0.d0
  do kx=2,nx-nwx
    dkx=2*(kx-1)
    kxc=nxp2-kx
    der(kx, ky)=-rkx(dkx)*var(kxc,ky)
    der(kxc,ky)= rkx(dkx)*var(kx ,ky)
  enddo
enddo

if (mod(nx,2) .eq. 0) then
  kxc=nwx+1
  do ky=1,ny-1
    der(kxc,ky)=0.d0
  enddo
endif

return
end subroutine

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

subroutine xderiv_fc(nx,ny,rkx,var,der)
! Computes der = d(var)/dx, spectrally, for a variable
! var(nx,0:ny) periodic in x and represented by a cosine
! series in y.
! *** both var and der are spectral ***

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rkx(nx),var(nx,0:ny),der(nx,0:ny)
 !Local declarations:
integer:: nwx,nxp2,kx,ky,dkx,kxc

nwx=nx/2
nxp2=nx+2
 !Carry out differentiation by wavenumber multiplication:
do ky=0,ny
  der(1,ky)=0.d0
  do kx=2,nx-nwx
    dkx=2*(kx-1)
    kxc=nxp2-kx
    der(kx, ky)=-rkx(dkx)*var(kxc,ky)
    der(kxc,ky)= rkx(dkx)*var(kx ,ky)
  enddo
enddo

if (mod(nx,2) .eq. 0) then
  kxc=nwx+1
  do ky=0,ny
    der(kxc,ky)=0.d0
  enddo
endif

return
end subroutine

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

subroutine yderiv_fs(nx,ny,rky,var,der)
! Computes der = d(var)/dy, spectrally, for a variable
! var(nx,ny) periodic in x and represented by a sine
! series in y.
! *** both var and der are spectral ***
! ==> der(nx,0:ny) changes to a cosine series in y

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rky(ny),var(nx,ny),der(nx,0:ny)
 !Local declarations:
integer:: kx,ky

 !Carry out differentiation by wavenumber multiplication:
do kx=1,nx
  der(kx,0)=0.d0
   !The above implies the mean value of der for every kx is 0.d0.
  der(kx,ny)=0.d0
   !der = 0 when ky = ny since var = 0 when ky = ny.
enddo
do ky=1,ny-1
  do kx=1,nx
    der(kx,ky)=rky(ky)*var(kx,ky)
  enddo
enddo

return
end subroutine

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

subroutine yderiv_fc(nx,ny,rky,var,der)
! Computes der = d(var)/dy, spectrally, for a variable
! var(nx,0:ny) periodic in x and represented by a cosine
! series in y.
! *** both var and der are spectral ***
! ==> der(nx,ny) changes to a sine series in y

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rky(ny),var(nx,0:ny),der(nx,ny)
 !Local declarations:
integer:: kx,ky

 !Carry out differentiation by wavenumber multiplication:
do kx=1,nx
  der(kx,ny)=0.d0
enddo
do ky=1,ny
  do kx=1,nx
    der(kx,ky)=-rky(ky)*var(kx,ky)
  enddo
enddo

return
end subroutine

!===================================================================
! These routines are for arrays periodic in neither x nor y.
!===================================================================

subroutine ptospc_cc(nx,ny,rvar,svar,xfactors,yfactors,xtrig,ytrig)
! Performs a physical -> spectral transform of a variable rvar(0:ny,0:nx)
! represented by a cosine series in x and a cosine series in y
! and returns the result (transposed) in svar(0:nx,0:ny).
! *** Note rvar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(0:ny,0:nx),svar(0:nx,0:ny)
 !Local declarations:
integer:: kx,iy

 !Carry out x cosine transform first:
call dct(ny+1,nx,rvar,xtrig,xfactors)

 !Transpose array:
do kx=0,nx
  do iy=0,ny
    svar(kx,iy)=rvar(iy,kx)
  enddo
enddo

 !Carry out y cosine transform on transposed array:
call dct(nx+1,ny,svar,ytrig,yfactors)

return
end subroutine

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

subroutine ptospc_cs(nx,ny,rvar,svar,xfactors,yfactors,xtrig,ytrig)
! Performs a physical -> spectral transform of a variable rvar(ny,0:nx)
! represented by a cosine series in x and a  sine  series in y
! and returns the result (transposed) in svar(0:nx,ny)
! *** Note rvar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(ny,0:nx),svar(0:nx,ny)
 !Local declarations:
integer:: kx,iy

 !Carry out x cosine transform first:
call dct(ny,nx,rvar,xtrig,xfactors)

 !Transpose array:
do kx=0,nx
  do iy=1,ny-1
    svar(kx,iy)=rvar(iy,kx)
  enddo
  svar(kx,ny)=0.d0
enddo

 !Carry out y sine transform on transposed array:
call dst(nx+1,ny,svar,ytrig,yfactors)

return
end subroutine

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

subroutine ptospc_sc(nx,ny,rvar,svar,xfactors,yfactors,xtrig,ytrig)
! Performs a physical -> spectral transform of a variable rvar(0:ny,nx)
! represented by a  sine  series in x and a cosine series in y
! and returns the result (transposed) in svar(nx,0:ny)
! *** Note rvar is destroyed on return. ***

implicit none

 !Argument declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(0:ny,nx),svar(nx,0:ny)
 !Local declarations
integer:: kx,iy

 !Carry out x sine transform first:
call dst(ny+1,nx,rvar,xtrig,xfactors)

 !Transpose array:
do kx=1,nx-1
  do iy=0,ny
    svar(kx,iy)=rvar(iy,kx)
  enddo
enddo
do iy=0,ny
  svar(nx,iy)=0.d0
enddo

 !Carry out y cosine transform on transposed array:
call dct(nx,ny,svar,ytrig,yfactors)

return
end subroutine

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

subroutine ptospc_ss(nx,ny,rvar,svar,xfactors,yfactors,xtrig,ytrig)
! Performs a physical -> spectral transform of a variable rvar(ny,nx)
! represented by a  sine  series in x and a  sine  series in y
! and returns the result (transposed) in svar(nx,ny).
! *** Note rvar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(ny,nx),svar(nx,ny)
 !Local declarations:
integer:: kx,iy

 !Carry out x sine transform first:
call dst(ny,nx,rvar,xtrig,xfactors)

 !Transpose array:
do kx=1,nx-1
  do iy=1,ny-1
    svar(kx,iy)=rvar(iy,kx)
  enddo
  svar(kx,ny)=0.d0
enddo
do iy=1,ny
  svar(nx,iy)=0.d0
enddo

 !Carry out y sine transform on transposed array:
call dst(nx,ny,svar,ytrig,yfactors)

return
end subroutine

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

subroutine spctop_cc(nx,ny,svar,rvar,xfactors,yfactors,xtrig,ytrig)
! Performs a spectral -> physical transform of a variable svar(0:nx,0:ny)
! represented by a cosine series in x and a cosine series in y
! and returns the result (transposed) in rvar(0:ny,0:nx)
! *** Note svar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(0:ny,0:nx),svar(0:nx,0:ny)
 !Local declarations:
integer:: kx,iy

 !Carry out y cosine transform first:
call dct(nx+1,ny,svar,ytrig,yfactors)

 !Transpose array:
do kx=0,nx
  do iy=0,ny
    rvar(iy,kx)=svar(kx,iy)
  enddo
enddo

 !Carry out x cosine transform on transposed array:
call dct(ny+1,nx,rvar,xtrig,xfactors)

return
end subroutine

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

subroutine spctop_cs(nx,ny,svar,rvar,xfactors,yfactors,xtrig,ytrig)
! Performs a spectral -> physical transform of a variable svar(0:nx,ny)
! represented by a cosine series in x and a  sine  series in y
! and returns the result (transposed) in rvar(ny,0:nx)
! *** Note svar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(ny,0:nx),svar(0:nx,ny)
 !Local declarations:
integer:: kx,iy

 !Carry out y sine transform first:
call dst(nx+1,ny,svar,ytrig,yfactors)

 !Transpose array:
do kx=0,nx
  do iy=1,ny-1
    rvar(iy,kx)=svar(kx,iy)
  enddo
  rvar(ny,kx)=0.d0
enddo

 !Carry out x cosine transform on transposed array:
call dct(ny,nx,rvar,xtrig,xfactors)

return
end subroutine

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

subroutine spctop_sc(nx,ny,svar,rvar,xfactors,yfactors,xtrig,ytrig)
! Performs a spectral -> physical transform of a variable svar(nx,0:ny)
! represented by a  sine  series in x and a cosine series in y
! and returns the result (transposed) in rvar(0:ny,nx)
! *** Note svar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(0:ny,nx),svar(nx,0:ny)
 !Local declarations:
integer:: kx,iy

 !Carry out y cosine transform first:
call dct(nx,ny,svar,ytrig,yfactors)

 !Transpose array:
do kx=1,nx-1
  do iy=0,ny
    rvar(iy,kx)=svar(kx,iy)
  enddo
enddo
do iy=0,ny
  rvar(iy,nx)=0.d0
enddo

 !Carry out x sine transform on transposed array:
call dst(ny+1,nx,rvar,xtrig,xfactors)

return
end subroutine

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

subroutine spctop_ss(nx,ny,svar,rvar,xfactors,yfactors,xtrig,ytrig)
! Performs a spectral -> physical transform of a variable svar(nx,ny)
! represented by a  sine  series in x and a  sine  series in y
! and returns the result (transposed) in rvar(ny,nx)
! *** Note svar is destroyed on return. ***

implicit none

 !Arguments declarations:
integer:: nx,ny,xfactors(5),yfactors(5)
double precision:: xtrig(2*nx),ytrig(2*ny)
double precision:: rvar(ny,nx),svar(nx,ny)
 !Local declarations:
integer:: kx,iy

 !Carry out y sine transform first:
call dst(nx,ny,svar,ytrig,yfactors)

 !Transpose array:
do kx=1,nx-1
  do iy=1,ny-1
    rvar(iy,kx)=svar(kx,iy)
  enddo
  rvar(ny,kx)=0.d0
enddo
do iy=1,ny
  rvar(iy,nx)=0.d0
enddo

 !Carry out x sine transform on transposed array:
call dst(ny,nx,rvar,xtrig,xfactors)

return
end subroutine

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

subroutine xderiv_ss(nx,ny,rkx,var,der)
! Computes der = d(var)/dx, spectrally, for a variable var(nx,ny)
! represented by a  sine  series in x and a  sine  series in y.
! The array rkx contains the x wavenumbers.
! *** both var and der are spectral ***
! ==> der(0:nx,ny) changes to a cosine series in x
! @@@ the mean value of der (0 wavenumber) is assumed to be 0

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rkx(nx),var(nx,ny),der(0:nx,ny)
 !Local declarations:
integer:: kx,ky

 !Carry out differentiation by wavenumber multiplication:
do ky=1,ny-1
  der(0 ,ky)=0.d0
   !The above implies the mean value of der for every ky is zero.
  do kx=1,nx-1
    der(kx,ky)=rkx(kx)*var(kx,ky)
  enddo
  der(nx,ky)=0.d0
   !der = 0 when kx = nx since var = 0 when kx = nx.
enddo

return
end subroutine

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

subroutine yderiv_ss(nx,ny,rky,var,der)
! Computes der = d(var)/dy, spectrally, for a variable var(nx,ny)
! represented by a  sine  series in x and a  sine  series in y.
! The array rky contains the y wavenumbers.
! *** both var and der are spectral ***
! ==> der(nx,0:ny) changes to a cosine series in y
! @@@ the mean value of der (0 wavenumber) is assumed to be 0

implicit none

 !Argument declarations:
integer:: nx,ny
double precision:: rky(ny),var(nx,ny),der(nx,0:ny)
 !Local declarations:
integer:: kx,ky

 !Carry out differentiation by wavenumber multiplication:
do kx=1,nx-1
  der(kx,0)=0.d0
   !The above implies the mean value of der for every kx is zero.
  der(kx,ny)=0.d0
   !der = 0 when ky = ny since var = 0 when ky = ny.
enddo
do ky=1,ny-1
  do kx=1,nx-1
    der(kx,ky)=rky(ky)*var(kx,ky)
  enddo
enddo

return
end subroutine

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

subroutine xderiv_cs(nx,ny,rkx,var,der)
! Computes der = d(var)/dx, spectrally, for a variable var(0:nx,ny)
! represented by a cosine series in x and a  sine  series in y.
! The array rkx contains the x wavenumbers.
! *** both var and der are spectral ***
! ==> der(nx,ny) changes to a sine series in x

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rkx(nx),var(0:nx,ny),der(nx,ny)
 !Local declarations:
integer:: kx,ky

 !Carry out differentiation by wavenumber multiplication:
do ky=1,ny-1
  do kx=1,nx-1
    der(kx,ky)=-rkx(kx)*var(kx,ky)
  enddo
  der(nx,ky)=0.d0
enddo

return
end subroutine

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

subroutine yderiv_cs(nx,ny,rky,var,der)
! Computes der = d(var)/dy, spectrally, for a variable var(0:nx,ny)
! represented by a cosine series in x and a  sine  series in y.
! The array rky contains the y wavenumbers.
! *** both var and der are spectral ***
! ==> der(0:nx,0:ny) changes to a cosine series in y
! @@@ the mean value of der (0 wavenumber) is assumed to be 0

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rky(ny),var(0:nx,ny),der(0:nx,0:ny)
 !Local declarations:
integer:: kx,ky

 !Carry out differentiation by wavenumber multiplication:
do kx=0,nx
  der(kx,0)=0.d0
   !The above implies the mean value of der for every kx is zero.
  der(kx,ny)=0.d0
   !der = 0 when ky = ny since var = 0 when ky = ny.
enddo
do ky=1,ny-1
  do kx=0,nx
    der(kx,ky)=rky(ky)*var(kx,ky)
  enddo
enddo

return
end subroutine

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

subroutine xderiv_sc(nx,ny,rkx,var,der)
! Computes der = d(var)/dx, spectrally, for a variable var(nx,0:ny)
! represented by a  sine  series in x and a cosine series in y.
! The array rkx contains the x wavenumbers.
! *** both var and der are spectral ***
! ==> der(0:nx,0:ny) changes to a cosine series in x
! @@@ the mean value of der (0 wavenumber) is assumed to be 0

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rkx(nx),var(nx,0:ny),der(0:nx,0:ny)
 !Local declarations:
integer:: kx,ky

 !Carry out differentiation by wavenumber multiplication:
do ky=0,ny
  der(0 ,ky)=0.d0
   !The above implies the mean value of der for every ky is zero.
  do kx=1,nx-1
    der(kx,ky)=rkx(kx)*var(kx,ky)
  enddo
  der(nx,ky)=0.d0
   !der = 0 when kx = nx since var = 0 when kx = nx.
enddo

return
end subroutine

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

subroutine yderiv_sc(nx,ny,rky,var,der)
! Computes der = d(var)/dy, spectrally, for a variable var(nx,0:ny)
! represented by a  sine  series in x and a cosine series in y.
! The array rky contains the y wavenumbers.
! *** both var and der are spectral ***
! ==> der(nx,ny) changes to a sine series in y

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rky(ny),var(nx,0:ny),der(nx,ny)
 !Local declarations:
integer:: kx,ky

 !Carry out differentiation by wavenumber multiplication:
do kx=1,nx-1
  der(kx,ny)=0.d0
enddo
do ky=1,ny-1
  do kx=1,nx-1
    der(kx,ky)=-rky(ky)*var(kx,ky)
  enddo
enddo

return
end subroutine

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

subroutine xderiv_cc(nx,ny,rkx,var,der)
! Computes der = d(var)/dx, spectrally, for a variable var(0:nx,0:ny)
! represented by a cosine series in x and a cosine series in y.
! The array rkx contains the x wavenumbers.
! *** both var and der are spectral ***
! ==> der(nx,0:ny) changes to a sine series in x

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rkx(nx),var(0:nx,0:ny),der(nx,0:ny)
 !Local declarations:
integer:: kx,ky

 !Carry out differentiation by wavenumber multiplication:
do ky=0,ny
  do kx=1,nx-1
    der(kx,ky)=-rkx(kx)*var(kx,ky)
  enddo
  der(nx,ky)=0.d0
enddo

return
end subroutine

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

subroutine yderiv_cc(nx,ny,rky,var,der)
! Computes der = d(var)/dy, spectrally, for a variable var(0:nx,0:ny)
! represented by a cosine series in x and a cosine series in y.
! The array rky contains the y wavenumbers.
! *** both var and der are spectral ***
! ==> der(0:nx,ny) changes to a sine series in y

implicit none

 !Arguments declarations:
integer:: nx,ny
double precision:: rky(ny),var(0:nx,0:ny),der(0:nx,ny)
 !Local declarations:
integer:: kx,ky

 !Carry out differentiation by wavenumber multiplication:
do kx=0,nx
  der(kx,ny)=0.d0
enddo
do ky=1,ny-1
  do kx=0,nx
    der(kx,ky)=-rky(ky)*var(kx,ky)
  enddo
enddo

return
end subroutine

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

end module


      SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          COMPZ
      INTEGER            INFO, LDZ, N
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * ), WORK( * ), Z( LDZ, * )
*     ..
*
*  Purpose
*  =======
*
*  SPTEQR computes all eigenvalues and, optionally, eigenvectors of a
*  symmetric positive definite tridiagonal matrix by first factoring the
*  matrix using SPTTRF, and then calling SBDSQR to compute the singular
*  values of the bidiagonal factor.
*
*  This routine computes the eigenvalues of the positive definite
*  tridiagonal matrix to high relative accuracy.  This means that if the
*  eigenvalues range over many orders of magnitude in size, then the
*  small eigenvalues and corresponding eigenvectors will be computed
*  more accurately than, for example, with the standard QR method.
*
*  The eigenvectors of a full or band symmetric positive definite matrix
*  can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to
*  reduce this matrix to tridiagonal form. (The reduction to tridiagonal
*  form, however, may preclude the possibility of obtaining high
*  relative accuracy in the small eigenvalues of the original matrix, if
*  these eigenvalues range over many orders of magnitude.)
*
*  Arguments
*  =========
*
*  COMPZ   (input) CHARACTER*1
*          = 'N':  Compute eigenvalues only.
*          = 'V':  Compute eigenvectors of original symmetric
*                  matrix also.  Array Z contains the orthogonal
*                  matrix used to reduce the original matrix to
*                  tridiagonal form.
*          = 'I':  Compute eigenvectors of tridiagonal matrix also.
*
*  N       (input) INTEGER
*          The order of the matrix.  N >= 0.
*
*  D       (input/output) REAL array, dimension (N)
*          On entry, the n diagonal elements of the tridiagonal
*          matrix.
*          On normal exit, D contains the eigenvalues, in descending
*          order.
*
*  E       (input/output) REAL array, dimension (N-1)
*          On entry, the (n-1) subdiagonal elements of the tridiagonal
*          matrix.
*          On exit, E has been destroyed.
*
*  Z       (input/output) REAL array, dimension (LDZ, N)
*          On entry, if COMPZ = 'V', the orthogonal matrix used in the
*          reduction to tridiagonal form.
*          On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
*          original symmetric matrix;
*          if COMPZ = 'I', the orthonormal eigenvectors of the
*          tridiagonal matrix.
*          If INFO > 0 on exit, Z contains the eigenvectors associated
*          with only the stored eigenvalues.
*          If  COMPZ = 'N', then Z is not referenced.
*
*  LDZ     (input) INTEGER
*          The leading dimension of the array Z.  LDZ >= 1, and if
*          COMPZ = 'V' or 'I', LDZ >= max(1,N).
*
*  WORK    (workspace) REAL array, dimension (4*N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit.
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*          > 0:  if INFO = i, and i is:
*                <= N  the Cholesky factorization of the matrix could
*                      not be performed because the i-th principal minor
*                      was not positive definite.
*                > N   the SVD algorithm failed to converge;
*                      if INFO = N+i, i off-diagonal elements of the
*                      bidiagonal factor did not converge to zero.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SBDSQR, SLASET, SPTTRF, XERBLA
*     ..
*     .. Local Arrays ..
      REAL               C( 1, 1 ), VT( 1, 1 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ICOMPZ, NRU
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
*
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ICOMPZ = 0
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ICOMPZ = 2
      ELSE
         ICOMPZ = -1
      END IF
      IF( ICOMPZ.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
     $         N ) ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SPTEQR', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( N.EQ.1 ) THEN
         IF( ICOMPZ.GT.0 )
     $      Z( 1, 1 ) = ONE
         RETURN
      END IF
      IF( ICOMPZ.EQ.2 )
     $   CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
*     Call SPTTRF to factor the matrix.
*
      CALL SPTTRF( N, D, E, INFO )
      IF( INFO.NE.0 )
     $   RETURN
      DO 10 I = 1, N
         D( I ) = SQRT( D( I ) )
   10 CONTINUE
      DO 20 I = 1, N - 1
         E( I ) = E( I )*D( I )
   20 CONTINUE
*
*     Call SBDSQR to compute the singular values/vectors of the
*     bidiagonal factor.
*
      IF( ICOMPZ.GT.0 ) THEN
         NRU = N
      ELSE
         NRU = 0
      END IF
      CALL SBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1,
     $             WORK, INFO )
*
*     Square the singular values.
*
      IF( INFO.EQ.0 ) THEN
         DO 30 I = 1, N
            D( I ) = D( I )*D( I )
   30    CONTINUE
      ELSE
         INFO = N + INFO
      END IF
*
      RETURN
*
*     End of SPTEQR
*
      END


C $Id$
************************************************************************
*                                                                      *
      subroutine ecp_up_k (m_min,m_max,k,j,l,n,ldQ,alpha,beta,
     &    gamma,Q_lo,Q_mid,Q_hi)
*                                                                      *
*   Perform upward recursion in k for k even, using 6.38:              *
*   2c Q^{k+2}_{m,m+j} = (k-j) Q^k_{m,m+j} + a Q^{k+1}_{m+1,m+j}       *
*                    + b Q^{k+1}_{m,m-1+j}                             *
*   = gamma [(gamma (k-j)/2 Q^k_{m,m+j} + alpha Q^{k+1}_{m+1,m+j}      *
*                    + beta Q^{k+1}_{m,m-1+j} ]                        *
*                                                                      *
*   Argument (status) - description                                    *
*                                                                      *
*   m_min (inp) - minimum value of m                                   *
*   m_max (inp) - maximum value of m                                   *
*   k (inp) - value of k                                               *
*   j (inp) - value of j                                               *
*   l (inp) - switches alpha and beta for different forms of recursion *
*             formula.                                                 *
*   n (inp) - number of functions                                      *
*   alpha (inp) -  a/2*sqrt(c)                                         *
*   beta (inp) -  b/2*sqrt(c)                                          *
*   gamma (inp) - 1/sqrt(c)                                            *
*   Q_mid (inp) - Q^{k+1}_{m+1,m}                                      *
*   Q_lo (inp) - Q^{k}_{m,m}                                           *
*   Q_hi (out) - Q^{k+2}_{m,m}                                         *
*                                                                      *
*   Written by K. G. Dyall                                             *
*                                                                      *
************************************************************************
      implicit none
      integer i,j,k,l,ldQ,m,m_min,m_max,n
      double precision two,fac,alpha(n),beta(n),gamma(n),
     &    Q_lo(ldQ,m_min:m_max),Q_mid(ldQ,m_min:m_max+1),
     &    Q_hi(ldQ,m_min:m_max)
*
      parameter (two = 2.0d00)
*
      fac = k-j
      fac = fac/two
C      write (6,'(/A,/)') 'upward_k_recursion'
C      write (6,*) 'k,j,m_min,m_max',k,j,m_min,m_max
      do m = m_min,m_max-j
C        write (6,*) 'm =',m
        do i = 1,n
          Q_hi(i,m) = gamma(i)*( gamma(i)*fac*Q_lo(i,m)
     &        + alpha(i)*Q_mid(i,m+l)+ beta(i)*Q_mid(i,m+1-l) )
C          write (6,'(1p4e20.10)') gamma(i),alpha(i),beta(i)
C          write (6,'(1p4e20.10)') Q_lo(i,m),Q_mid(i,m+l),Q_mid(i,m+1-l),
C     &        Q_hi(i,m)
        end do
      end do
*
      return
      end


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C        PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE HW3CRT TO
C     SOLVE THE HELMHOLTZ EQUATION
C
C     (D/DX)(DU/DX) + (D/DY)(DU/DY) + (D/DZ)(DU/DZ) - 3U
C
C       =  4X**2*(3-X**2):SIN(Y)*COS(Z)
C
C     ON THE PARALLELEPIPED 0 .LT. X .LT. 1, 0 .LT. Y .LT. 2*PI,
C     0 .LT. Z .LT. PI/2 WITH THE BOUNDARY CONDITIONS
C
C     U(0,Y,Z) = 0
C                           0 .LE. Y .LE. 2*PI , 0 .LE. Z .LE. PI/2
C     U(1,Y,Z) = SIN(Y)*COS(Z)
C
C     U PERIODIC IN Y,
C
C     U(X,Y,0) = X**4*SIN(Y)
C                           0 .LE. X .LE. 1 , 0 .LE. Y .LE. 2*PI
C     (DU/DX)(X,Y,PI/2) = -X**4*SIN(Y)
C
C     USING A FINITE DIFFERENCE GRID WITH PANEL WIDTHS
C
C     DELTAX (=DX) = 1/10 , DELTAY (=DY) = 1/40 , DELTAZ (=DZ) = 1/15.
C
C        THE EXACT SOLUTION OF THIS PROBLEM IS
C
C     U(X,Y,Z) = X**4*SIN(Y)*COS(Z) .
C
      DIMENSION       F(11,41,16),BDZF(11,41),W(370)     ,X(11)      ,
     1                Y(41)      ,Z(16)
C
C        FROM THE DESCRIPTION OF THE PROBLEM GIVEN ABOVE, WE DEFINE
C     THE FOLLOWING QUANTITIES
C
      ELMBDA = -3.
      XS = 0.
      XF = 1.
      LBDCND = 1
      YS = 0.
      PI = PIMACH(DUM)
      YF = 2.*PI
      MBDCND = 0
      ZS = 0.
      ZF = PI/2.
      NBDCND = 2
      L = 10
      M = 40
      N = 15
C
C     FROM THE DIMENSION STATEMENT ABOVE WE DEFINE
C
      LDIMF = 11
      MDIMF = 41
C
C     ALSO NOTE THAT W HAS BEEN DIMENSIONED
C        30+L+M+5*N+MAX(L,M,N)+7*(INT((L+1)/2)+INT((M+1)/2))
C      = 30+10+40+75+40+7*(5+20) = 370
C     WE DEFINE THE GRID POINTS FOR LATER USE.
C
      LP1 = L+1
      DX = (XF-XS)/FLOAT(L)
      DO 101 I=1,LP1
         X(I) = XS+FLOAT(I-1)*DX
  101 CONTINUE
      MP1 = M+1
      DY = (YF-YS)/FLOAT(M)
      DO 102 J=1,MP1
         Y(J) = YS+FLOAT(J-1)*DY
  102 CONTINUE
      NP1 = N+1
      DZ = (ZF-ZS)/FLOAT(N)
      DO 103 K=1,NP1
         Z(K) = ZS+FLOAT(K-1)*DZ
  103 CONTINUE
C
C     WE DEFINE THE ARRAY OF DERIVATIVE BOUNDARY VALUES.
C
      DO 105 I=1,LP1
         DO 104 J=1,MP1
            BDZF(I,J) = -X(I)**4*SIN(Y(J))
  104    CONTINUE
  105 CONTINUE
C
C     NOTE THAT FOR THIS EXAMPLE ALL OTHER BOUNDARY ARRAYS ARE
C     DUMMY VARIABLES.
C     WE DEFINE THE FUNCTION BOUNDARY VALUES IN THE F ARRAY.
C
      DO 107 J=1,MP1
         DO 106 K=1,NP1
            F(1,J,K) = 0.
            F(LP1,J,K) = SIN(Y(J))*COS(Z(K))
  106    CONTINUE
  107 CONTINUE
      DO 109 I=1,LP1
         DO 108 J=1,MP1
            F(I,J,1) = X(I)**4*SIN(Y(J))
  108    CONTINUE
  109 CONTINUE
C
C     WE NOW DEFINE THE VALUES OF THE RIGHT SIDE OF THE HELMHOLTZ
C     EQUATION.
C
      DO 112 I=2,L
         DO 111 J=1,MP1
            DO 110 K=2,NP1
               F(I,J,K) = 4.*X(I)**2*(3.-X(I)**2)*SIN(Y(J))*COS(Z(K))
  110       CONTINUE
  111    CONTINUE
  112 CONTINUE
C
C     CALL HW3CRT TO GENERATE AND SOLVE THE FINITE DIFFERENCE EQUATION.
C
      CALL HW3CRT (XS,XF,L,LBDCND,BDXS,BDXF,YS,YF,M,MBDCND,BDYS,BDYF,
     1             ZS,ZF,N,NBDCND,BDZS,BDZF,ELMBDA,LDIMF,MDIMF,F,
     2             PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR.  THE EXACT SOLUTION TO THE
C     PROBLEM IS
C
C        U(X,Y,Z) = X**4*SIN(Y)*COS(Z)
C
      ERR = 0.
      DO 115 I=1,LP1
         DO 114 J=1,MP1
            DO 113 K=1,NP1
               T = ABS(F(I,J,K)-X(I)**4*SIN(Y(J))*COS(Z(K)))
               IF (T .GT. ERR) ERR = T
  113       CONTINUE
  114    CONTINUE
  115 CONTINUE
      PRINT 1001 , IERROR,ERR
      STOP
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE HW3CRT EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 9.64802E-03//
     4        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     5        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5)
C
      END


      PROGRAM PRIMES4
C
C     PROGRAM TO PRINT THE FIRST N PRIMES (N.LE.10000)
C
      DIMENSION IP(10000)
      READ(*,*)N
      I=1
      J=1
      IP(1)=2
 10   I=I+2
      IS=SQRT(FLOAT(I))
      K=0
 15   K=K+1
      IF (I/IP(K)*IP(K).EQ.I) GOTO 10
      IF (IP(K).LE.IS) GOTO 15
      J=J+1
      IP(J)=I
      IF (J.LT.N) GOTO 10
      WRITE (*,30) (IP(I),I=1,N)
 30   FORMAT(10I8)
      END


	program isingtest2

	! COLLECTIVE PHENOMENA PROJECT - 2D ISING MODEL
	! Patrick Sánchez Galea
	! MC algorithm using the Metropolis method for the 2D Ising model.

	implicit none

	integer :: i, j, m, n		! dummy integers
	integer, allocatable :: A(:,:)	! spins' matrix
	integer :: L				! length of the lattice, # of spins
	integer :: newspin			! values of changed spin
	integer :: nscan, iscan		! number/current scans at different T
	integer :: nstep, istep		! MC-time and current pass number
	integer :: ntherm			! number of thermalization steps
	integer :: nvalues			! # of points after thermalization
	real :: T, beta			! T and 1/KT
	real :: minT, maxT, dT		! limit temperatures to scan, and step
	real :: dU				! change of energy between configs.
	real :: mag, mag_avg, mag2_avg	! magnetization, cumulative avg m/m2
	real :: energy, energy_avg, energy2_avg	! same than mag for energy
	real :: pa				! probability for the Wolff algorithm
	double precision u, dran_u, logran	! random number generator

	! read the input parameters from "parameters"
	open(unit=11, file='parameters', status='old', action='read')
	read(11,*); read(11,*) L
	read(11,*); read(11,*) nstep
	read(11,*); read(11,*) ntherm
	read(11,*); read(11,*) maxT
	read(11,*); read(11,*) minT
	read(11,*); read(11,*) dT
	!read(11,*); read(11,*) pa
	close(11)

	! open the output files
	open(unit=21,file='magnetization',status='replace',action='write')
	write(21,*) "temp      avg_mag      avg_mag2      susceptibility"
	open(unit=22, file='energy', status='replace', action='write')
	write(22,*) "temp      avg_energy      avg_energy2      Cv"

	! we use periodic bc, so we have the same first and last rows and columns
	allocate(A(L+2,L+2))
	nscan = int((maxT-minT)/dT) + 1
	call dran_ini(481992)

	! Initial configuration of the spins. Chosen to be random
	do i = 2, L +1
		do j =2, L +1
			if (dran_u() .le. 0.5d0) then
				A(i,j) = int(-1)
			else
				A(i,j) = int(1)
			endif
		enddo
	enddo
	do i = 1, L+2		! begin boundary conditions
		A(i,1) = A(i,L+1)
		A(i,L+2) = A(i,2)
	enddo
	do j = 1, L+2
		A(1,j) = A(L+1,j)
		A(L+2,j) = A(2,j)
	enddo			! end boundary conditions

	! Scan for the different temperatures
	temp_loop: do iscan = 1, nscan
		T = maxT-dT*(iscan-1)
		print*, "Program running for T = ", T

		! Initialization of the variables
		beta = 1.d0/T
		nvalues = 0
		mag_avg = 0.d0
		mag2_avg = 0.d0
		energy_avg = 0.d0
		energy2_avg = 0.d0
		pa = 1-dexp(-2.d0*beta)

		! Core of the MC algorithm
		MC_loop: do istep = 0, nstep

			!Choose a random spin to swap and compute dU
			m = nint((L-1)*dran_u() + 2)
			n = nint((L-1)*dran_u() + 2)
			call clustering(A, m, n, L, pa)

			! When the thermalization time is reached, start measuring
			! MC iteration when each spin is flipped once in average
			if (istep > ntherm) then
			  if (mod(istep,10) == 0) then
			    nvalues = nvalues + 1	! counter of steps to average
			    mag = sum(A(2:L+1,2:L+1))/(1.d0*L**2)
			    mag_avg = mag_avg + abs(mag)
			    mag2_avg = mag2_avg + mag**2
			    energy = 0.d0
			    do i = 2, L+1
			      do j = 2, L+1
			        energy = energy - A(m,n)*(A(m-1,n)+A(m+1,n)+
     * 			  		     A(m,n-1)+A(m,n+1))
			      enddo
			    enddo
			    energy = energy/(2*L**2)
			    energy_avg = energy_avg + energy
			    energy2_avg = energy2_avg + energy**2
			  endif
			endif

		enddo MC_loop
		! write the output files
		write(21,*) T,',',mag_avg/nvalues,',',
     *        mag2_avg/nvalues,
     *		',',beta*(mag2_avg/nvalues - (mag_avg/nvalues)**2)
		write(22,*) T,',',energy_avg/nvalues,',',
     *        energy2_avg/nvalues,',',(beta**2)*(energy2_avg/nvalues
     *        -(energy_avg/nvalues)**2)

	enddo temp_loop
	close(21)
	close(22)
	close(23)
	print*, "Program Complete"

	contains

	! Subroutine to form clusters : Wolff algorithm
	recursive subroutine clustering(A, m, n, L, pa)
	integer L, m, n, k, m2, n2
	real :: pa
	integer :: A(L+2,L+2)

	! print*, 'neighbor', m, n, A(m,n)
	A(m,n) = -A(m,n)	! flip the spin

	if (m==1 .or. m == L+2 .or. n == 1 .or. n == L+2) then	! boundary
		if (m == 1) m = L+1
		if (m == L+2) m = 2
		if (n == 1) n = L+1
		if (n == L+2) n = 2
		A(m,n) = -A(m,n)	! flip the symmetric spin
	endif

	do i = 1, L+2		! begin boundary conditions
		A(i,1) = A(i,L+1)
		A(i,L+2) = A(i,2)
	enddo
	do j = 1, L+2
		A(1,j) = A(L+1,j)
		A(L+2,j) = A(2,j)
	enddo			! end boundary conditions

	if (A(m-1,n) == -A(m,n)) then
		if (dran_u() .le. pa) call clustering(A,m-1,n,L,pa)
	endif
	if (A(m+1,n) == -A(m,n)) then
		if (dran_u() .le. pa) call clustering(A,m+1,n,L,pa)
	endif
	if (A(m,n-1) == -A(m,n)) then
		if (dran_u() .le. pa) call clustering(A,m,n-1,L,pa)
	endif
	if (A(m,n+1) == -A(m,n)) then
		if (dran_u() .le. pa) call clustering(A,m,n+1,L,pa)
	endif
	end subroutine clustering

	end program isingtest2


! a program to make a binary file to force unstructured swan4082 with idealized sea level
! z is positive up

!INPGRID WLEV UNSTRUCTURED EXC -99. NONSTAT 20070101_000000 1 HR 20070103_000000
!READINP WLEV 1. 'sealevel.bin' 1 0 UNF
!
program fake_sealevel
implicit none
real*4  :: amp = 2. !tidal amplitude in meters
real*4  :: period = 44712.0 !period of M2 tide in seconds
real*4  :: slev,time
integer :: Nverts  = 845 !number of nodes in the mesh
integer :: Nframes = 241 !number of hourly frames
integer :: i,ii

open(unit=33,file='sealevel.bin',form='unformatted')
time = 0.0
do i=1,nframes
  slev = amp*sin(time*2*3.14159/period)
  write(*,*)i,float(i)/24.,time,slev
  write(33)(slev,ii=1,Nverts)
  time = time + 3600
end do
close(33)

end program fake_sealevel


module CONSTANTS
! Description:
!    Contains physical constants used in the peogram and the SET_UNITS subroutine
!    to set the reference units for non-dimensionalization of the state vector.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    d.amato@upm.es
!
! ==============================================================================

use KINDS, only: dk,qk

! VARIABLES
implicit none

! Reference quantities for non-dimensionalization [km, 1/s].
real(qk)           ::  DU,TU

! Physical quantities.
! Earth.
real(qk),parameter     ::  REarth          = 6.37122E3_qk          ! [km]
real(qk),parameter     ::  smaEarth        = 1.49598023E8_qk       ! [km] = Astronomical unit
real(qk),parameter     ::  muEarth         = 3.98601E5_qk          ! [km^3/s^2]
real(qk),parameter     ::  J2Earth         = 1.08265E-3_qk         ! [-]
real(qk)               ::  wEarth                                  ! Earth angular velocity [rad/s]
real(qk)               ::  R_SoI                                   ! Earth sphere of influence radius [km]
! Sun.
real(qk),parameter     ::  muSun           = 1.32712428E11_qk      ! [km^3/s^2]
! Misc.
real(qk),parameter     ::  secsPerDay      = 86400._qk
real(qk),parameter     ::  pi    = 3.1415926535897932384626433832795027974814_qk
real(qk),parameter     ::  twopi = 6.2831853071795864769252867665590055949581_qk
real(qk)               ::  d2r

contains

subroutine SET_UNITS(r,mu)
! Description:
!    Computes reference quantities from a position vector and a gravitational
!    parameter.
! ==============================================================================

! VARIABLES
implicit none

! Arguments
real(qk),intent(IN)     ::  r(1:3)    ! Input Cartesian position [km, km/s].
real(qk),intent(IN)     ::  mu        ! Gravitational parameter  [km^3/s^2].

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

DU = sqrt(dot_product(r,r))
TU = SQRT(mu/DU**3)

END SUBROUTINE SET_UNITS

end module CONSTANTS


subroutine diff_center(N,dt,cnpar,posconc,h,Bcup,Bcdw, &
                       Yup,Ydw,nuY,Lsour,Qsour,Taur,Yobs,Yin,Yout)
use bio_MOD, only: Dirichlet, Neumann
IMPLICIT NONE

 !INPUT PARAMETERS:

!  number of vertical layers
   integer,  intent(in)               :: N

!  time step (s)
   real,    intent(in)                :: dt

!  "implicitness" parameter
   real,    intent(in)                :: cnpar

!  1: non-negative concentration, 0: else
   integer, intent(in)                :: posconc

!  layer thickness (m)
   real,    intent(in)                :: h(N)

!  type of upper BC
   integer,  intent(in)               :: Bcup

!  type of lower BC
   integer,  intent(in)               :: Bcdw

!  value of upper BC
   real,     intent(in)               :: Yup

!  value of lower BC
   real,     intent(in)               :: Ydw

!  diffusivity of Y
   real,    intent(in)                :: nuY(0:N)

!  linear source term
!  (treated implicitly)
   real,    intent(in)                :: Lsour(N)

!  constant source term
!  (treated explicitly)
   real, intent(in)                   :: Qsour(N)

!  relaxation time (s)
   real, intent(in)                :: Taur(N)

!  observed value of Y
   real, intent(in)                :: Yobs(N)
!
! !INPUT/OUTPUT PARAMETERS:
   real, intent(in)                :: Yin(N)
   real, intent(out)               :: Yout(N)

   real, dimension(N)              :: au,bu,cu,du
! !REVISION HISTORY:
!  Original author(s): Lars Umlauf
!
!EOP
!
! !LOCAL VARIABLES:
   integer                   :: i
   real                      :: a,c,l
!
!-----------------------------------------------------------------------
!BOC
!
!   Debug:
!   write(6,*) 'Yup    = ',Yup
!   write(6,*) 'Ydw    = ',Ydw

!  Initialize au, bu, cu, du
   au(:) = 0d0; bu(:) = 0d0; cu(:) = 0d0; du(:) = 0d0

!  set up matrix
   do i=2,N-1
      c     = 2.0*dt*nuY(i)  /(h(i)+h(i+1))/h(i)
      a     = 2.0*dt*nuY(i-1)/(h(i)+h(i-1))/h(i)
      l     =     dt*Lsour(i)

      cu(i) =-cnpar*c
      au(i) =-cnpar*a
      bu(i) = 1d0 + cnpar*(a + c) - l

      du(i) = (1d0 - (1d0-cnpar)*(a + c))*Yin(i)                  &
            + (1d0 - cnpar)*( a*Yin(i-1) + c*Yin(i+1) ) + dt*Qsour(i)
   enddo

!   set up upper boundary condition
   select case(Bcup)
   case(Neumann)
      a     = 2.0*dt*nuY(N-1)/(h(N)+h(N-1))/h(N)
      l     = dt*Lsour(N)

      au(N) =-cnpar*a
      if (posconc .eq. 1 .and. Yup.lt.0d0) then ! Patankar (1980) trick
         bu(N) =  1d0 - au(N) - l  - dt*Yup/Yin(N)/h(N)
         du(N) = Yin(N) + dt*Qsour(N)   &
               + (1d0 - cnpar)*a*(Yin(N-1)-Yin(N))
      else
       bu(N) =  1d0 - au(N) - l
       du(N) = Yin(N) + dt*(Qsour(N)+Yup/h(N))   &
             + (1d0 - cnpar)*a*(Yin(N-1)-Yin(N))
      endif
   case(Dirichlet)
      au(N) = 0d0
      bu(N) = 1d0
      du(N) = Yup
   case default
      write(6,*) 'Fatal error: invalid boundary condition type for upper boundary'
      stop  'diff_center.F90'
   end select

!   set up lower boundary condition
   select case(Bcdw)
   case(Neumann)
      c     = 2.0*dt*nuY(1)/(h(1)+h(2))/h(1)
      l     = dt*Lsour(1)

      cu(1) =-cnpar*c
      if (posconc.eq.1 .and. Ydw.lt.0d0) then ! Patankar (1980) trick
         bu(1) = 1d0 - cu(1) - l - dt*Ydw/Yin(1)/h(1)
         du(1) = Yin(1) + dt*(Qsour(1))   &
               + (1d0 - cnpar)*c*(Yin(2)-Yin(1))
      else
         bu(1) = 1d0 - cu(1) - l
         du(1) = Yin(1) + dt*(Qsour(1)+Ydw/h(1))   &
               + (1d0 - cnpar)*c*(Yin(2)-Yin(1))

      endif
   case(Dirichlet)
      cu(1) = 0d0
      bu(1) = 1d0
      du(1) = Ydw
   case default
      write(6,*) 'Fatal error: invalid boundary condition type for lower boundary'
      stop  'diff_center.F90'
   end select

!  relaxation to observed value
   if (minval(Taur).lt.1.E10) then
      do i=1,N
         bu(i)=bu(i)+dt/Taur(i)
         du(i)=du(i)+dt/Taur(i)*Yobs(i)
      end do
   end if

!  solve linear system
   call tridiagonal(N,au,bu,cu,du,1,N,Yout)

   return
end subroutine diff_center
!-----------------------------------------------------------------------


	SUBROUTINE ke_Nfilt_correction(kf,x,y,n,z,h0,q0,lun,nmag)

c	Compute apparent magnitude in nmag filters contained in array kf

c	Array declarations
	include 'filter.dec'
	include 'cosmo.dec'
	character*1024 aux
	integer kf(nmag)
	real x(n),y(n),f0(50),f1mag(50),f1magAB(50)
	data icall/0/
	save f0

c	Report cosmology, selected filters, etc.
	if (icall.eq.0) then
		icall=1
		write (lun,100)      h,omega,omega_lambda,q,clambda,tu,ttg,zf
		write (lun  ,'(a)') '# Meaning of printed variables (see Tables 5 and 6 of bc03.ps for details):'
		write (lun  ,'(a)') '#   z        = redshift (z=0 entry in table corresponds to a distance of 10 pc)'
		write (lun  ,'(a)') '#   ltt      = light travel time from z=0 to z in Gyr'
		write (lun  ,'(a)') '#   tz       = age of galaxy at redshit = z'
		write (lun  ,'(a)') '#   dm       = cosmological distance modulus in magnitude units'
		write (lun  ,'(a)') '#   m_ev     = apparent magnitude M_ev(z) + dm(z) in each filter (Vega system)'
		write (lun  ,'(a)') '#'
		write (lun+1,100)    h,omega,omega_lambda,q,clambda,tu,ttg,zf
		write (lun+1,'(a)') '# Meaning of printed variables (see Tables 5 and 6 of bc03.ps for details):'
		write (lun+1,'(a)') '#   z        = redshift (z=0 entry in table corresponds to a distance of 10 pc)'
		write (lun+1,'(a)') '#   ltt      = light travel time from z=0 to z in Gyr'
		write (lun+1,'(a)') '#   tz       = age of galaxy at redshit = z'
		write (lun+1,'(a)') '#   dm       = cosmological distance modulus in magnitude units'
		write (lun+1,'(a)') '#   m_ev     = apparent magnitude M_ev(z) + dm(z) in each filter (AB system)'
		write (lun+1,'(a)') '#'
		write (lun,'(a,19x,3x,50i9)') '# Filter:',(kf(i),i=1,nmag)
		write (lun+1,'(a,19x,3x,50i9)') '# Filter:',(kf(i),i=1,nmag)
		write (lun,101) ('   m_ev  ',i=1,nmag)
		write (lun+1,101) ('   m_ev  ',i=1,nmag)
		write (lun,102) ('   mag   ',i=1,nmag)
		write (lun+1,102) ('   ABmag ',i=1,nmag)
		write (aux,103) (i+4,i=1,nmag)
		l=largo(aux)
		aux(l:l)=' '
		l=largo(aux)
		write (lun,'(a)') aux(1:l)
		write (lun+1,'(a)') aux(1:l)
	endif
100     format ('# Cosmology: Ho = ',f4.0,2x,'Omega =',f5.2,2x,'Omega_lambda =',f5.2,2x,'qo = ',f7.4,2x,
     *          'Lambda =',1pE10.3,2x,'tu = ',0pf5.2,' Gyr',2x,'tg = ',f5.2,' Gyr', 2x,' zf = ',f6.2/'#')
101	format ('#  z      LTT     tz      dm      ',50a)
102	format ('#         Gyr     Gyr     mag     ',50a)
c103	format ('# (1)     (2)     (3)     (4)   ',50(5x,'(',i2,')'))
103	format ('# (1)     (2)     (3)     (4)        (',50(i2,')     ('))

c	Compute cosmological distance modulus.
	dm=dismod(h0,q0,z)

c	Compute light travel time from z=0 to z
	tl=tu-t(h0,q0,z,clambda)
	tz=ttg-tl

c	If z=0, compute zero points
	if (z.eq.0.) then
c		Compute zero points in filters in array kf(i)
		do i=1,nmag
		f0(i)=vega_0p_n(kf(i))
		enddo
	endif

c	Compute magnitudes at this redshift
	do i=1,nmag
c	Compute absolute magnitude in filters in array kf(i) (Vega system)
	f1_ev   = f0(i) - 2.5*alog10(filter_n(kf(i),x,y,n,z,kerr))
c	Compute absolute AB magnitude in filters in array kf(i)
	ABf1_ev = AB_mag(kf(i),x,y,n,z)
c	Compute apparent magnitudes
	f1mag(i)    = f1_ev   + dm
	f1magAB(i)  = ABf1_ev + dm
	enddo

c	Write results
	if (z.eq.0.) then
		write (lun,  108) z,tl,tz,dm,(f1mag(i),i=1,nmag)
		write (lun+1,108) z,tl,tz,dm,(f1magAB(i),i=1,nmag)
	else
		write (lun,  109) z,tl,tz,dm,(f1mag(i),i=1,nmag)
		write (lun+1,109) z,tl,tz,dm,(f1magAB(i),i=1,nmag)
	endif
108	format ('#',f5.3,3f8.3,3x,100f9.4)
109	format (f6.3,3f8.3,3x,100f9.4)
	return
	end


! ==============================================================
subroutine evec(maxnx,num_eqn,num_ghost,mx,q,auxl,auxr,evl,evr)
! ==============================================================
!
!	Calculation of left and right eigenvectors
!
!   On input, q contains the cell average state vector
!             maxnx contains the number of physical points
!               (without ghost cells)
!             num_ghost is the number of ghost cells
!             num_eqn the number of equations
!
!   On output, evl(i) and evr(i) contain left/right eigenvectors
!   at interface i-1/2

    implicit double precision (a-h,o-z)
    integer,          intent(in) :: maxnx, num_eqn, num_ghost, mx
    double precision, intent(in) :: q(num_eqn,maxnx+2*num_ghost)
    double precision, intent(out) :: evl(num_eqn,num_eqn,maxnx+2*num_ghost)
    double precision, intent(out) :: evr(num_eqn,num_eqn,maxnx+2*num_ghost)

!   local storage
!   ---------------
    common /cparam/ gamma
    integer :: mx2

    mx2 = size(q,2)

    gamma1 = gamma - 1.d0

    do i=2,mx2
        ! Compute velocity, speed and enthalpy
        rhsqrtl = dsqrt(q(1,i-1))
        rhsqrtr = dsqrt(q(1,i  ))
        pl = gamma1*(q(3,i-1) - 0.5d0*(q(2,i-1)**2)/q(1,i-1))
        pr = gamma1*(q(3,i  ) - 0.5d0*(q(2,i  )**2)/q(1,i  ))
        rhsq2 = rhsqrtl + rhsqrtr
        u = (q(2,i-1)/rhsqrtl + q(2,i)/rhsqrtr) / rhsq2
        enth = (((q(3,i-1)+pl)/rhsqrtl + (q(3,i)+pr)/rhsqrtr)) / rhsq2
        c2 = gamma1*(enth - 0.5d0*u**2)
        c = dsqrt(c2)

        ! Construct matrix of right eigenvectors
        !      _                     _
        !     |                       |
        !     |   1      1       1    |
        !     |                       |
        ! R = |  u-c     u      u+c   |
        !     |                       |
        !     |  H-uc   u^2/2   H+uc  |
        !     |_                     _|

        evr(1,1,i) = 1.d0
        evr(2,1,i) = u - c
        evr(3,1,i) = enth - u*c

        evr(1,2,i) = 1.d0
        evr(2,2,i) = u
        evr(3,2,i) = 0.5d0*u**2

        evr(1,3,i) = 1.d0
        evr(2,3,i) = u + c
        evr(3,3,i) = enth + u*c

        ! Construct matrix of left eigenvectors
        !
        ! gamma1 = gamma - 1
        !                          _                                       _
        !                         |                                         |
        !                         |  uc/gamma1+u^2/2    -c/gamma1-u     1   |
        !                         |                                         |
        ! R^{-1} =  gamma1/(2c^2) |  2(H-u^2)           2u             -2   |
        !                         |                                         |
        !                         |  -uc/gamma1+u^2/2   c/gamma1-u      1   |
        !                         |_                                       _|

        alpha = 0.5d0 * gamma1 / c**2

        evl(1,1,i) = (c*u/gamma1 + 0.5d0*u**2) * alpha
        evl(2,1,i) = 2.d0*(enth-u**2) * alpha
        evl(3,1,i) = (-c*u/gamma1 + 0.5d0*u**2) * alpha

        evl(1,2,i) = -(c/gamma1 + u) * alpha
        evl(2,2,i) = 2.d0*u * alpha
        evl(3,2,i) = (c/gamma1 - u) * alpha

        evl(1,3,i) = alpha
        evl(2,3,i) = -2.d0 * alpha
        evl(3,3,i) = alpha

    enddo

    return
end subroutine evec


! https://stackoverflow.com/questions/20006253/using-metis-libraries-in-fortran-code-the-basics
! http://glaros.dtc.umn.edu/gkhome/node/852

program test_PartMeshNodal1

    use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer
    use metis_interface, only: idx_t, METIS_SetDefaultOptions, METIS_PartMeshNodal, &
        METIS_MeshToNodal, METIS_Free, METIS_NOPTIONS, METIS_OK, METIS_OPTION_NUMBERING
    implicit none

    integer(idx_t), parameter :: ne = 3 ! number of elements
    integer(idx_t), parameter :: nn = 8 ! number of nodes
    integer(idx_t), parameter :: npel = 4 ! nodes per element

    integer(idx_t) :: eptr(ne+1)
    integer(idx_t) :: eind(ne*npel)
    integer(idx_t) :: epart(ne), npart(nn)
    integer(idx_t) :: options(0:METIS_NOPTIONS-1)
    integer(idx_t) :: ios, objval

    type(c_ptr) :: c_xadj, c_adjncy
    integer(idx_t), pointer :: xadj(:) => null(), adjncy(:) => null()

    write(*,'(A)') "TEST METIS_PartMeshNodal 1"

    ! 0---1---4---6
    ! | 0 | 1 | 2 |
    ! 3---2---5---7

    eptr = [0,4,8,12]
    eind = [0,1,2,3,1,4,5,2,4,6,7,5]

    ios = METIS_SetDefaultOptions(options)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_SetDefaultOptions failed with error: ", ios
        error stop 1
    end if
    options(METIS_OPTION_NUMBERING) = 0 ! C-style numbering

    ios = METIS_PartMeshNodal(ne,nn,eptr,eind,nparts=2_idx_t,options=options,&
        objval=objval,epart=epart,npart=npart)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_PartMeshNodal failed with error: ", ios
        error stop 1
    end if

    write(*,'(A,I0)') "objval = ", objval
    write(*,'(A,*(I1,:,1X))') "epart = ", epart
    write(*,'(A,*(I1,:,1X))') "npart = ", npart

    ios = METIS_MeshToNodal(ne,nn,eptr,eind,numflag=0_idx_t,xadj=c_xadj,adjncy=c_adjncy)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_MeshToNodal failed with error: ", ios
        error stop 1
    end if

    call c_f_pointer(c_xadj,xadj,shape=[nn+1]) ! size of adjacency list is one more than number of nodes
    call c_f_pointer(c_adjncy,adjncy,shape=[xadj(nn+1)]) ! size of edge list is in the last element of xadj

    write(*,'(A,*(I0,:,1X))') "xadj = ", xadj
    write(*,'(A,*(I1,:,1X))') "adjncy = ", adjncy

    ! call write_graph("test1.graph",xadj,adjncy,1)

    ios = METIS_Free(c_xadj); xadj => null()
    if (ios /= METIS_OK) then
        write(*,*) "METIS_Free failed with error: ", ios
        error stop 1
    end if
    ios = METIS_Free(c_adjncy); adjncy => null()
    if (ios /= METIS_OK) then
        write(*,*) "METIS_Free failed with error: ", ios
        error stop 1
    end if

end program


PROGRAM test_random0
!
!  Purpose:
!    Subroutine test the random number generator random0.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/22/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare variable types & definitions
REAL :: ave          ! Average of random numbers
INTEGER :: i         ! DO loop index
INTEGER :: iseed     ! Seed for random number sequence
INTEGER :: iseq      ! DO loop index
REAL :: ran          ! A random number
REAL :: sum          ! Sum of random numbers

! Get seed.
WRITE (*,*) 'Enter seed: '
READ (*,*) iseed

! Set seed.
CALL SEED ( iseed )

! Print out 10 random numbers.
WRITE (*,*) '10 random numbers: '
DO i = 1, 10
   CALL random0 ( ran )
   WRITE (*,'(3X,F16.6)') ran
END DO

! Average 5 consecutive 1000-value sequences.
WRITE (*,*) 'Averages of 5 consecutive 1000-sample sequences:'
DO iseq = 1, 5
   sum = 0.
   DO i = 1, 1000
      CALL random0 ( ran )
      sum = sum + ran
   END DO
   ave = sum / 1000.
   WRITE (*,'(3X,F16.6)') ave
END DO

END PROGRAM test_random0


program sblas
  use timers
  type(TimerType) :: vecaddTime,vecsumTime,trimvTime,totalTime

  integer i,j,n,m,k,nsteps
  parameter (n=1024*60,m=512)
  parameter (nsteps=1000)
  real*8 a(n),b(n),x(n),y(m),l(m,m)
  common /heap/ a,b,x,y,l
  real*8 res

  call TimerCreate(vecaddTime,"vecadd")
  call TimerCreate(vecsumTime,"vecsum")
  call TimerCreate(trimvTime,"trimv")
  call TimerCreate(totalTime,"total")

! Loop over whole program to get reasonable execution time
! (simulates a time-steping code)

  call TimerOn(totalTime)

  do k=1,nsteps

! 'Update' vector data

    call vector_update(n,x,a,b)

! vector addition operation

    call TimerOn(vecaddTime)
    call vecadd (n,x,a,b)
    call TimerOff(vecaddTime)

! sum operation

    call TimerOn(vecsumTime)
    call vecsum (n,res,x)
    call TimerOff(vecsumTime)

! 'Update' lower triangular matrix and y vector

    call matrix_update (m,y,l)

! triangular matrix times vector operation

    call TimerOn(trimvTime)
    call trimv (m,y,l,a)
    call TimerOff(trimvTime)

! end time-step loop
 end do

 call TimerOff(totalTime)

! print out some results

 print *,'x(1) = ',x(1),'x(n) = ', x(n)
 print *,'Sum of x() = ',res
 print *,'y(1) = ',y(1),'y(m) = ', y(m)

!  OUTPUT TIMING DATA

 call TimerPrint(vecaddTime)
 call TimerPrint(vecsumTime)
 call TimerPrint(trimvTime)
 call TimerPrint(totalTime)

end program sblas

! Subroutines

subroutine vector_update (n,x,a,b)

! .. Scalar arguments
  integer n

! .. Array arguments
  real*8 x(n),a(n),b(n)

! .. Local scalars
  integer i

! .. External functions

  do i=1,n
     x(i) = 0.
     a(i) = 3.142
     b(i) = 3.142
  end do

  return
end subroutine vector_update

subroutine matrix_update (m,y,l)

! .. Scalar arguments
  integer m

! .. Array arguments
  real*8 y(m),l(m,m)

! .. Local scalars
  integer i,j

! .. External functions

  do i=1,m
     y(i) = 0.
     do j=1,i
        l(j,i) = 2.
     end do
  end do

  return
end subroutine matrix_update

subroutine vecadd (n,x,a,b)
!
! .. Scalar arguments
  integer n

! .. Array arguments
  real*8 x(n),a(n),b(n)

! .. Local scalars
  integer i

! .. External functions

  do i=1,n
     x(i) = a(i) + b(i)
  end do
  return
end subroutine vecadd

subroutine vecsum (n,sum,a)

! .. Scalar arguments
  integer n
  real*8 sum

! .. Array arguments
  real*8 a(n)

! .. Local scalars
  integer i

  sum = 0.0
  do i=1,n
     sum = sum +a(i)
  end do
  return
end subroutine vecsum

subroutine trimv (m,y,l,a)

! .. Scalar arguments
  integer m

! .. Array arguments
  real*8 y(m),l(m,m),a(m)

! .. Local scalars
  integer i,j

! .. External functions

  do i=1,m
     do j=1,i
        y(i) = y(i) + l(j,i)*a(j)
     end do
  end do
  return
end subroutine trimv


MODULE FUN_xyzCOPLANAR
!!#### PURPOSE
!! Test for coplanarity between:
!! @ three points in R^2 <P3>
!! @ a plane and a point in R^2 <PnP>

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

!!#### EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_0_Rsp => c_0     !!((02-A-PAR_Constants_Rsp.f90))
USE PAR_Constants_Rdp,ONLY: c_0_Rdp => c_0     !!((02-A-PAR_Constants_Rdp.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_xyzPLANE,ONLY: xyzPLANE_P3             !!((06-B-FUN_xyzPLANE.f90))
USE FUN_xyzSDIST,ONLY: xyzSDIST_PnP            !!((06-B-FUN_xyzSDIST.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyzCOPLANAR_P4
 MODULE PROCEDURE xyzCOPLANAR_P4_Rsp
 MODULE PROCEDURE xyzCOPLANAR_P4_Rdp
END INTERFACE

INTERFACE xyzCOPLANAR_PnP
 MODULE PROCEDURE xyzCOPLANAR_PnP_Rsp
 MODULE PROCEDURE xyzCOPLANAR_PnP_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyzCOPLANAR_P4
PUBLIC :: xyzCOPLANAR_PnP

CONTAINS

PURE FUNCTION xyzCOPLANAR_P4_Rsp( P4 ) RESULT(COPLANAR)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-FUN_xyzCOPLANAR_P4.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzCOPLANAR_P4.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzCOPLANAR_P4_Rdp( P4 ) RESULT(COPLANAR)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-FUN_xyzCOPLANAR_P4.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzCOPLANAR_P4.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzCOPLANAR_PnP_Rsp( Pn , P ) RESULT(COPLANAR)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "07-B-FUN_xyzCOPLANAR_PnP.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzCOPLANAR_PnP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzCOPLANAR_PnP_Rdp( Pn , P ) RESULT(COPLANAR)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "07-B-FUN_xyzCOPLANAR_PnP.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzCOPLANAR_PnP.f90.bdy"
!!--end--
END FUNCTION

END MODULE


      PROGRAM TCGS
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C   SOLVER : CGS (d'après TEMPLATES)                 11.02.97
C
C   Utilise ILU0 & ILUTP
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C     -- Declarations ---------------------------------------
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      parameter(N = 100, NELEM = 5000, iwk= 10000)

      DIMENSION A(NELEM), IA(N+1), JA(NELEM),
     #          ALU(iwk),JLU(iwk), JU(N),
     #          B(N),X(N),iw(2*N),
     #          r(N),r2(N),p(N),p2(N),q(N),q2(N),u(N),v(N),
     #          iperm(2*N),xref(N)

      ierr=0

C     -- Chargement de la matrice A et du vecteur b ---------
      CALL loadmat(A,IA,JA,b,xref,ierr)

C     -- Paramètres du SYMMLQ -------------------------------
      epsilon = 1.0D-8
      it_max  = 800
      iflag   = 2
      ierr    = 0

C     -- Paramètres du préconditionneur ---------------------
      droptol = 0.0
      lfil    = 40
      permtol = 0.1
      mbloc   = N

      IF(iflag.EQ.1) THEN
         CALL ilu0(n, a, ja, ia, alu, jlu, ju, iw, ierr)
      ENDIF
      IF(iflag.EQ.2) THEN
         CALL ilutp(n,a,ja,ia,lfil,droptol,permtol,mbloc,alu,
     #              jlu,ju,iwk,r,iw,iperm,ierr)
      ENDIF
      WRITE(*,*)ierr
C
C     -- Appel de la sous-routine BICGSTAB -----------------
C
      CALL CGS(N, x, b, A, IA, JA, ALU, JLU, JU,
     #         epsilon,it_max,r,r2,p,p2,q,q2,v,u,
     #         IFLAG,ierr)
C
C     -- Permutation de la solution (si pivotage employé) --

      IF(IFLAG.EQ.2) THEN
         DO 101 i=1,N
            r(i)=x(iperm(n+i))
101      CONTINUE
         DO 102 i=1,N
            x(i)=r(i)
102      CONTINUE
      ENDIF

C     -- Sauvegarde du résultat vers MATLAB ----------------

      OPEN (UNIT = 1, FILE = 's_gmres.m', STATUS='UNKNOWN')
      DO 100 i = 1, N
         WRITE(1,*)'x(',i,')=',x(i),';'
100   CONTINUE
      CLOSE (UNIT = 1)

C     -- Visualisation de la solution ----------------------

      WRITE(*,*)
      WRITE(*,*)' <ENTER> pour voir la solution'
      READ(*,*)
      CALL VectAff2(N, x, xref)

      END


!****************************************************
!*             CLEAN
!*  Iterative Sine Wawe Fitting
!*
!*  Input:
!*       clean [options] [inputfile] [outputfile]
!*
!*  Options:
!*       -tday      Treat times as days (default)
!*       -tsec      Treat times as seconds
!*       -version   Print program version information
!*
!*  Written by
!*    Rasmus Handberg
!*    Department of Physics and Astronomy
!*    Aarhus University
!****************************************************

program clean
    use kind_defs
	use timeseries
	use FindMax
    implicit none
    integer :: N, i, j, k, err, Nclean
    real(dbl) :: nu_min, nu_max
    real(dbl) :: nu, numax, fmean, Amax, alpha, beta, phase
    character(200) :: buffer, inputfile = '', outputfile = ''
    logical :: bolUseWeights
	integer :: TimeType = 1 ! Default time type is days
   	real(dbl) :: t1, t2, ti
	integer :: nargs, iargc

    print *, "--------------------------------"
    print *, "             CLEAN              "
    print *, "  Iterative Sine Wave Fitting   "
    print *, "--------------------------------"

	! Extract parameters from command-line:
	nargs = iargc()
	do j = 1,nargs
		call getarg(j, buffer)
		select case (trim(buffer))
			case ("-tsec")
				TimeType = 0
			case ("-tday")
				TimeType = 1
			case ("-version")
				print *, "Current version:"
				print *, "$Revision: 119 $"
				print *, "$Date: 2016-02-09 09:57:56 +0100 (ti, 09 feb 2016) $"
				stop

			case default
				if (.not. buffer(1:1) == "-" .and. inputfile == "") then
					inputfile = trim(buffer)
				elseif (.not. buffer(1:1) == "-" .and. outputfile == "") then
					outputfile = trim(buffer)
				else
					print *, "UNKNOWN ARGUMENT: " // trim(buffer)
					stop
				endif
		end select
	enddo
	! If no files were given, ask for input and make output:
	if (inputfile == "") then
        print *, 'Enter input-file:'
        read '(a50)', inputfile
	endif
	if (outputfile == '') then
		j = scan(inputfile, '/', back=.true.)
		if (j /= 0) then
			outputfile = trim(inputfile(j+1:))
		else
			outputfile = trim(inputfile)
		endif
		j = scan(outputfile, '.', back=.true.)
		if (j > 1) then
			outputfile = trim(outputfile(1:j-1)) // '.clean'
		else
			outputfile = trim(outputfile) // '.clean'
		endif
	endif

    print *, "Reading data..."
    open(50, file=inputfile, status='old', action='read')
        ! New count:
        call CountData(50, N, bolUseWeights, 0)

        ! Allocate the data:
    	allocate(t(1:N), f(1:N), w(1:N), stat=err)
    	if (err /= 0) stop "Couldn''t allocate memory!"

    	! Ask to use the statistical weights:
		if (bolUseWeights) then
			print *, "Do you want to use the statistical weights? (1=yes,0=no)"
			read(*, '(i1)') j
			if (j == 0) bolUseWeights = .false.
		endif
		if (.not. quiet) then
			if (bolUseWeights) then
				print *, "Using weights"
			else
				print *, "Not using weights"
			endif
		endif

        ! Import the data:
        call ImportData(50, bolUseWeights, t, f, w, 0)
    close(50)

	! Convert time vector to seconds, based on the selected input:
	if (TimeType == 1) then
		t = t*86400_dbl
	endif

    ! Print information about series:
	call print_info(t)

    ! Select frequencies:
    print *, ''
    print *, 'min-frequency (microHz):'
    read *, nu_min
    print *, 'max-frequency (microHz):'
    read *, nu_max

    ! Number of points to clean:
    print *, ""
    print *, "Number of frequencies to clean:"
    read *, Nclean
	!print *, "Loop gain: (0-1)"
	!read *, gain
    print *, ""
    print *, "---------------------------------"
    !if (gain > 1.0 .or. gain <= 0.0) stop "Gain loop must be between 0 and 1."

	! Subtract mean:
	call cpu_time(t1)
	fmean = mean(f,w)
	f = f - fmean

    ! Open file to store frequencies:
    open(51, file='clean.log', action='write', position='append')
	! Write header to clean.dat file:
	write(51, '(a)') '#----------------------------------'
	write(51, '(a)') '# CLEAN'
	write(51, '(a)') '# ' // trim(inputfile)
	write(51, "('# min: ',f10.2,' microHz')") nu_min
	write(51, "('# max: ',f10.2,' microHz')") nu_max
	write(51, "('# Nclean: ',i7)") Nclean
	write(51, '(a)') '# Number, Power, Frequencies (microHz), Phase'
	write(51, '(a)') '#----------------------------------'
    do k = 1,Nclean
    	! Find maximum peak in spectrum:
    	call FindSpectrumMax(t, f, w, nu_min, nu_max, alpha, beta, numax)
		Amax = alpha**2 + beta**2

		! Write the progress:
		phase = atan2(alpha,beta)
		print '(i5,3f14.4)', k, Amax, numax, phase
		write(51,'(i5,3f14.4)') k, Amax, numax, phase

		! Clean the series with Iterativ Sine Fitting:
		f = f - alpha*sin(twopi_micro*numax*t) - beta*cos(twopi_micro*numax*t)

		! Save in file:
		open(52, file=outputfile, status='replace', action='write')
		do i = 1,N
			! TODO: Stuid to do this in the loop:
			if (TimeType == 1) then
				ti = t(i)/86400_dbl
			else
				ti = t(i)
			endif

			write(52, '(3ES22.12E3)') ti, f(i)+fmean, 1.0_dbl/sqrt(w(i))
		enddo
		close(52)
    enddo
	close(51)

	! Clean up memory:
	deallocate(t, f, w)

	call cpu_time(t2)
	print *, "---------------------------------"
    call print_time(t2-t1)
end program clean


!
!  (C) 2001 by Argonne National Laboratory.
!      See COPYRIGHT in top-level directory.
!
!**********************************************************************
!   pi.f - compute pi by integrating f(x) = 4/(1 + x**2)
!
!   Each node:
!    1) receives the number of rectangles used in the approximation.
!    2) calculates the areas of it's rectangles.
!    3) Synchronizes for a global summation.
!   Node 0 prints the result.
!
!  Variables:
!
!    pi  the calculated result
!    n   number of points of integration.
!    x           midpoint of each rectangle's interval
!    f           function to integrate
!    sum,pi      area of rectangles
!    tmp         temporary scratch space for global summation
!    i           do loop index
!****************************************************************************
      double precision function f( a )
      implicit none
      double precision a
          f = 4.d0 / (1.d0 + a*a)
          return
      end
!
!
!
      program main
      implicit none

      include 'mpif.h'
      include 'mpe_logf.h'

      double precision  PI25DT
      parameter        (PI25DT = 3.141592653589793238462643d0)

      double precision  mypi, pi, h, sum, x
      integer n, myid, numprocs, ii, idx
      double precision f
      external f

      integer event1a, event1b, event2a, event2b
      integer event3a, event3b, event4a, event4b
      integer ierr

      call MPI_Init( ierr )

      call MPI_Comm_rank( MPI_COMM_WORLD, myid, ierr )
      call MPI_Comm_size( MPI_COMM_WORLD, numprocs, ierr )
      write(6,*) "Process ", myid, " of ", numprocs, " is alive"

! Demonstrate the use of MPE_Log_state_eventIDs() and MPE_Log_solo_eventID()
! which replace the deprecated function MPE_Log_get_event_number.
!
      ierr = MPE_Log_get_state_eventIDs( event1a, event1b )
      ierr = MPE_Log_get_state_eventIDs( event2a, event2b )
      ierr = MPE_Log_get_solo_eventID( event3a )
      ierr = MPE_Log_get_solo_eventID( event3b )
      ierr = MPE_Log_get_state_eventIDs( event4a, event4b )

! Demonstrate the use MPE_Describe_event() to describe single-timestamped
! drawable, i.e. event.  Caution: One can use MPE_Describe_state() instead
! of 2 MPE_Dresribe_event() calls.  The difference is that one will see
! one state instead of 2 events.
      if ( myid .eq. 0 ) then
          ierr = MPE_Describe_state( event1a, event1b,
     &                               "User_Broadcast", "red" )
          ierr = MPE_Describe_state( event2a, event2b,
     &                               "User_Barrier", "blue" )
          ierr = MPE_Describe_event( event3a, "User_Compute_Start",
     &                               "orange" )
          ierr = MPE_Describe_event( event3b, "User_Compute_Final",
     &                               "orange" )
          ierr = MPE_Describe_state( event4a, event4b,
     &                               "User_Reduce", "green" )
          write(6,*) "event IDs are ", event1a, event1b, ", ",
     &                                 event2a, event2b, ", ",
     &                                 event3a, event3b, ", ",
     &                                 event4a, event4b
      endif

      if ( myid .eq. 0 ) then
!         write(6,98)
! 98      format('Enter the number of intervals: (0 quits)')
!         read(5,99) n
! 99      format(i10)
          n = 1000000
          write(6,*) 'The number of intervals =', n
!         check for quit signal
!         if ( n .le. 0 ) goto 30
      endif

      call MPI_Barrier( MPI_COMM_WORLD, ierr )

      do idx = 1, 5

          ierr = MPE_Log_event( event1a, 0, '' )
          call MPI_Bcast( n, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr )
          ierr = MPE_Log_event( event1b, 0, '' )

          call MPI_Pcontrol( 0, ierr )

          ierr = MPE_Log_event( event2a, 0, '' )
          call MPI_Barrier( MPI_COMM_WORLD, ierr )
          ierr = MPE_Log_event( event2b, 0, '' )

          call MPI_Pcontrol( 1, ierr )

          ierr = MPE_Log_event( event3a, 0, '' )
          h = 1.0d0/n
          sum  = 0.0d0
          do ii = myid+1, n, numprocs
              x = h * (dble(ii) - 0.5d0)
              sum = sum + f(x)
          enddo
          mypi = h * sum
          ierr = MPE_Log_event( event3b, 0, '' )

          ierr = MPE_Log_event( event4a, 0, '' )
          pi = 0.0d0
          call MPI_Reduce( mypi, pi, 1, MPI_DOUBLE_PRECISION, MPI_SUM,
     &                     0, MPI_COMM_WORLD, ierr )
          ierr = MPE_Log_event( event4b, 0, '' )

          if ( myid .eq. 0 ) then
              write(6, 97) pi, abs(pi - PI25DT)
 97           format('  pi is approximately: ', F18.16,
     +               '  Error is: ', F18.16)
          endif

      enddo
!     - Only GNU fortran does not flush stdout, so calling flush() is
!       absolutely needed with GNU compiler to get all stdout messages.
!     - XLF needs flush_() instead of flush() otherwise needs -qextname=flush
!     - Pathscale fortran compiler needs -intrinsic=G77{or PGI}.
!     call flush(6)

      call MPI_Finalize( ierr )

      end


chelp+
c       Code to generate FT of final 2D-Gaussian to be used
c       for convolving an image. The code deconvolves the input
c       psf. The intrinsic psf must be specified.
c                                          --wr, 22 Oct, 2020
c                                          Wasim.Raja@csiro.au
c
c INPUTS:
c     bmin_in = intrinsic psf BMIN (degrees)
c     bmaj_in = intrinsic psf BMAJ (degrees)
c     bpa_in  = intrinsic psf BPA  (degrees)
c
c     bmin    = final psf BMIN (degrees)
c     bmaj    = final psf BMAJ (degrees)
c     bpa     = final psf BPA  (degrees)
c
c     u       = Fourier coordinates corresponding to image coord x
c     v       = Fourier coordinates corresponding to image coord y
c
c     nx      = Number of pixels along x
c     ny      = Number of pixels along y
c
c OUTPUT:
c     g_final = Final array to be multiplied to FT(image) to get teh
c               convoution in the FT domain.
c     g_ratio = factor for flux scaling
c
chelp-
      subroutine gaussft(bmin_in, bmaj_in, bpa_in,
     -                    bmin, bmaj, bpa,
     -                    u, v, nx, ny,
     -                    g_final,g_ratio)
      implicit none
      integer*4, intent(in) :: nx, ny
      real*8, intent(out), dimension(nx,ny) :: g_final
      real*8, intent(out) :: g_ratio
      real*8, intent(in),dimension(nx) :: u
      real*8, intent(in),dimension(ny) :: v
      real*8, intent(in) :: bmin_in, bmaj_in, bpa_in
      real*8, intent(in) :: bmin, bmaj, bpa
      integer*4 ix, iy

      ! Local variables
      real*8 pi
      real*8 cos_bpa, sin_bpa, cos_bpa_in, sin_bpa_in
      real*8 u_cosbpa(nx),u_sinbpa(nx),u_cosbpa_in(nx),u_sinbpa_in(nx)
      real*8 v_cosbpa(ny),v_sinbpa(ny),v_cosbpa_in(ny),v_sinbpa_in(ny)
      real*8 g_amp, dg_amp
      real*8 g_arg, dg_arg
      real*8 ur, vr
      real*8 sx, sy, sx_in, sy_in
      real*8 deg2rad
      real*8 bmin_rad, bmaj_rad, bpa_rad
      real*8 bmin_in_rad, bmaj_in_rad, bpa_in_rad

      pi = acos(-1.0)
      deg2rad = pi/180.0
      !write(*,*)"pi: ",pi
      bmaj_in_rad = bmaj_in*deg2rad
      bmin_in_rad = bmin_in*deg2rad
      bpa_in_rad = bpa_in*deg2rad

      bmaj_rad = bmaj*deg2rad
      bmin_rad = bmin*deg2rad
      bpa_rad = bpa*deg2rad

      sx = bmaj_rad/(2*sqrt(2.0*log(2.0)))
      sy = bmin_rad/(2*sqrt(2.0*log(2.0)))
      sx_in = bmaj_in_rad/(2.0*sqrt(2.0*log(2.0)))
      sy_in = bmin_in_rad/(2.0*sqrt(2.0*log(2.0)))
      !write(*,*)"sx,sy,sx_in,sy_in: ",sx,sy,sx_in,sy_in

      do ix = 1,nx
        do iy = 1,ny
           g_final(ix,iy) = 0.0
        enddo
      enddo
      do ix=1,nx
         u_cosbpa(ix) = 0.0
         u_sinbpa(ix) = 0.0
         u_cosbpa_in(ix) = 0.0
         u_sinbpa_in(ix) = 0.0
      enddo
      do iy=1,ny
         v_cosbpa(iy) = 0.0
         v_sinbpa(iy) = 0.0
         v_cosbpa_in(iy) = 0.0
         v_sinbpa_in(iy) = 0.0
      enddo

      ! Store the constants to avoid unnecessary compute costs
      cos_bpa = cos(bpa_rad)
      sin_bpa = sin(bpa_rad)
      g_amp = sqrt(2.0*pi*sx*sy)

      cos_bpa_in = cos(bpa_in_rad)
      sin_bpa_in = sin(bpa_in_rad)
      dg_amp = sqrt(2.0*pi*sx_in*sy_in)

      g_ratio = g_amp/dg_amp
      !write(77,*)g_ratio

      !write(*,*)"cbpa, sbpa, g_amp: ",cos_bpa,sin_bpa, g_amp
      !write(*,*)"gratio: ",g_ratio

      do ix = 1,nx
          u_cosbpa(ix) = u(ix)*cos_bpa
          u_sinbpa(ix) = u(ix)*sin_bpa

          u_cosbpa_in(ix) = u(ix)*cos_bpa_in
          u_sinbpa_in(ix) = u(ix)*sin_bpa_in
      enddo

      do iy = 1,ny
          v_cosbpa(iy) = v(iy)*cos_bpa
          v_sinbpa(iy) = v(iy)*sin_bpa

          v_cosbpa_in(iy) = v(iy)*cos_bpa_in
          v_sinbpa_in(iy) = v(iy)*sin_bpa_in
      enddo

      do ix = 1,nx
         do iy = 1,ny
            ! Spectra of the Convolution kernel:

            ur = u_cosbpa(ix) - v_sinbpa(iy)
            vr = u_sinbpa(ix) + v_cosbpa(iy)
            g_arg = -2.0*pi**2 * ((sx * ur)**2 + (sy * vr)**2)

            ! Spectra of the De-convolution kernel:
            ur = u_cosbpa_in(ix) - v_sinbpa_in(iy)
            vr = u_sinbpa_in(ix) + v_cosbpa_in(iy)
            dg_arg = -2.0*pi**2 * ((sx_in*ur)**2 + (sy_in*vr)**2)

            g_final(ix,iy) = g_ratio * exp(g_arg - dg_arg)
         enddo
      enddo

      end