    module solver_preparation

    use custom_precision

    implicit none

    private

    integer                                     :: irow, icol, i

    interface serialise_grid_nodes
    procedure serialise_grid_nodes_sp
    procedure serialise_grid_nodes_dp
    end interface

    interface map_vector_components_to_grid
    procedure map_vector_components_to_grid_sp
    procedure map_vector_components_to_grid_dp
    end interface

    interface fill_coefficient_matrix_poisson
    procedure fill_coefficient_matrix_poisson_sp
    procedure fill_coefficient_matrix_poisson_dp
    end interface

    interface fill_coefficient_matrix_poisson_dirichlet_left
    procedure fill_coefficient_matrix_poisson_dirichlet_left_sp
    procedure fill_coefficient_matrix_poisson_dirichlet_left_dp
    end interface

    interface fill_coefficient_matrix_poisson_neumann_right
    procedure fill_coefficient_matrix_poisson_neumann_right_sp
    procedure fill_coefficient_matrix_poisson_neumann_right_dp
    end interface

    interface fill_coefficient_matrix_poisson_dirichlet_bottom
    procedure fill_coefficient_matrix_poisson_dirichlet_bottom_sp
    procedure fill_coefficient_matrix_poisson_dirichlet_bottom_dp
    end interface

    interface fill_coefficient_matrix_poisson_dirichlet_top
    procedure fill_coefficient_matrix_poisson_dirichlet_top_sp
    procedure fill_coefficient_matrix_poisson_dirichlet_top_dp
    end interface

    public get_linear_index
    public serialise_grid_nodes
    public map_vector_components_to_grid
    public fill_coefficient_matrix_poisson
    public fill_coefficient_matrix_poisson_dirichlet_left
    public fill_coefficient_matrix_poisson_neumann_right
    public fill_coefficient_matrix_poisson_dirichlet_bottom
    public fill_coefficient_matrix_poisson_dirichlet_top

    contains

    !#####################################
    pure function get_row_id(i, stride) result(irow)
    integer, intent(in)         :: i, stride
    integer                     :: irow

    irow = mod(i, stride)
    end function get_row_id

    !#####################################
    pure function get_column_id(i, stride) result(icol)
    integer, intent(in)         :: i, stride
    integer                     :: icol

    icol = 1 + i / stride
    end function get_column_id

    !#####################################
    pure function get_linear_index(irow, icol, stride) result(id)
    integer, intent(in)         :: irow, icol, stride
    integer                     :: id

    id = (icol - 1) * stride + irow
    end function get_linear_index

    !#####################################
    subroutine serialise_grid_nodes_sp(grid, vector, nrows, ncols)
    real(SP), allocatable, intent(in)           :: grid(:,:)
    real(SP), allocatable, intent(inout)        :: vector(:)
    integer, intent(in)                         :: nrows, ncols

    i = 1
    do icol = 1, ncols
        do irow = 1, nrows
            vector(i) = grid(irow, icol)
            i = i + 1
        end do
    end do
    end subroutine serialise_grid_nodes_sp

    !#####################################
    subroutine serialise_grid_nodes_dp(grid, vector, nrows, ncols)
    real(DP), allocatable, intent(in)           :: grid(:,:)
    real(DP), allocatable, intent(inout)        :: vector(:)
    integer, intent(in)                         :: nrows, ncols

    i = 1
    do icol = 1, ncols
        do irow = 1, nrows
            vector(i) = grid(irow, icol)
            i = i + 1
        end do
    end do
    end subroutine serialise_grid_nodes_dp

    !#####################################
    subroutine map_vector_components_to_grid_sp(vector, n, grid, nrows, ncols)
    real(SP), allocatable, intent(in)           :: vector(:)
    real(SP), allocatable, intent(inout)        :: grid(:,:)
    integer, intent(in)                         :: n, nrows, ncols

    do i = 1, n
        irow = get_row_id(i, nrows)
        icol = get_column_id(i, nrows)
        grid(irow, icol) = vector(i)
    end do
    end subroutine map_vector_components_to_grid_sp

    !#####################################
    subroutine map_vector_components_to_grid_dp(vector, n, grid, nrows, ncols)
    real(DP), allocatable, intent(in)           :: vector(:)
    real(DP), allocatable, intent(inout)        :: grid(:,:)
    integer, intent(in)                         :: n, nrows, ncols

    do i = 1, n
        irow = get_row_id(i, nrows)
        icol = get_column_id(i, nrows)
        grid(irow, icol) = vector(i)
    end do
    end subroutine map_vector_components_to_grid_dp

    !#####################################
    subroutine fill_coefficient_matrix_poisson_sp(mat, nrows, ncols, dx, dy)
    real(SP), allocatable, intent(inout)        :: mat(:,:)
    integer, intent(in)                         :: nrows, ncols
    real(SP), intent(in)                        :: dx, dy

    real(SP)                                    :: dx2, dy2
    integer                                     :: k, n

    dx2 = dx * dx
    dy2 = dy * dy
    mat(:,:) = 0.
    n = nrows * ncols

    do icol = 2, ncols - 1
        do irow = 2, nrows - 1
            k = get_linear_index(irow, icol, nrows)
            mat(k, k) = -((2. / dx2) + (2. / dy2))

            mat(k, k - 1) = 1. / dy2
            mat(k, k + 1) = 1. / dy2

            mat(k, k - nrows) = 1. / dx2
            mat(k, k + nrows) = 1. / dx2
        end do
    end do
    end subroutine fill_coefficient_matrix_poisson_sp

    !#####################################
    subroutine fill_coefficient_matrix_poisson_dp(mat, nrows, ncols, dx, dy)
    real(DP), allocatable, intent(inout)        :: mat(:,:)
    integer, intent(in)                         :: nrows, ncols
    real(DP), intent(in)                        :: dx, dy

    real(DP)                                    :: dx2, dy2
    integer                                     :: k, n

    dx2 = dx * dx
    dy2 = dy * dy
    mat(:,:) = 0.d0
    n = nrows * ncols

    do icol = 2, ncols - 1
        do irow = 2, nrows - 1
            k = get_linear_index(irow, icol, nrows)
            mat(k, k) = -((2.d0 / dx2) + (2.d0 / dy2))

            mat(k, k - 1) = 1.d0 / dy2
            mat(k, k + 1) = 1.d0 / dy2

            mat(k, k - nrows) = 1.d0 / dx2
            mat(k, k + nrows) = 1.d0 / dx2
        end do
    end do
    end subroutine fill_coefficient_matrix_poisson_dp

    !#####################################
    subroutine fill_coefficient_matrix_poisson_dirichlet_left_sp(mat, nrows, ncols)
    real(SP), allocatable, intent(inout)        :: mat(:,:)
    integer, intent(in)                         :: nrows, ncols

    integer                                     :: k

    icol = 1
    do irow = 1, nrows
        k = get_linear_index(irow, icol, nrows)
        mat(k, k) = 1.
    end do
    end subroutine fill_coefficient_matrix_poisson_dirichlet_left_sp

    !#####################################
    subroutine fill_coefficient_matrix_poisson_dirichlet_left_dp(mat, nrows, ncols)
    real(DP), allocatable, intent(inout)        :: mat(:,:)
    integer, intent(in)                         :: nrows, ncols

    integer                                     :: k

    icol = 1
    do irow = 1, nrows
        k = get_linear_index(irow, icol, nrows)
        mat(k, k) = 1.d0
    end do
    end subroutine fill_coefficient_matrix_poisson_dirichlet_left_dp

    !#####################################
    subroutine fill_coefficient_matrix_poisson_neumann_right_sp(mat, nrows, ncols, dx, dy)
    real(SP), allocatable, intent(inout)        :: mat(:,:)
    integer, intent(in)                         :: nrows, ncols
    real(SP), intent(in)                        :: dx, dy

    integer                                     :: k
    real(SP)                                    :: dx2, dy2

    dx2 = dx * dx
    dy2 = dy *dy

    icol = ncols
    do irow = 2, nrows - 1
        k = get_linear_index(irow, icol, nrows)
        mat(k, k) = -(7. / (2. * dx2) + (2. / dy2))
        mat(k, k - 1) = 1. / dy2
        mat(k, k + 1) = 1. / dy2
        mat(k, k - nrows) = 4. / dx2
        mat(k, k + nrows) = -1. / (2. * dx2)
    end do
    end subroutine fill_coefficient_matrix_poisson_neumann_right_sp

    !#####################################
    subroutine fill_coefficient_matrix_poisson_neumann_right_dp(mat, nrows, ncols, dx, dy)
    real(DP), allocatable, intent(inout)        :: mat(:,:)
    integer, intent(in)                         :: nrows, ncols
    real(DP), intent(in)                        :: dx, dy

    integer                                     :: k
    real(DP)                                    :: dx2, dy2

    dx2 = dx * dx
    dy2 = dy *dy

    icol = ncols
    do irow = 2, nrows - 1
        k = get_linear_index(irow, icol, nrows)
        mat(k, k) = -(7.d0 / (2.d0 * dx2) + (2.d0 / dy2))
        mat(k, k - 1) = 1.d0 / dy2
        mat(k, k + 1) = 1.d0 / dy2
        mat(k, k - nrows) = 4.d0 / dx2
        mat(k, k + nrows) = -1.d0 / (2.d0 * dx2)
    end do
    end subroutine fill_coefficient_matrix_poisson_neumann_right_dp

    !#####################################
    subroutine fill_coefficient_matrix_poisson_dirichlet_bottom_sp(mat, nrows, ncols)
    real(SP), allocatable, intent(inout)        :: mat(:,:)
    integer, intent(in)                         :: nrows, ncols

    integer                                     :: k

    irow = 1
    do icol = 1, ncols
        k = get_linear_index(irow, icol, nrows)
        mat(k, k) = 1.
    end do
    end subroutine fill_coefficient_matrix_poisson_dirichlet_bottom_sp

    !#####################################
    subroutine fill_coefficient_matrix_poisson_dirichlet_bottom_dp(mat, nrows, ncols)
    real(DP), allocatable, intent(inout)        :: mat(:,:)
    integer, intent(in)                         :: nrows, ncols

    integer                                     :: k

    irow = 1
    do icol = 1, ncols
        k = get_linear_index(irow, icol, nrows)
        mat(k, k) = 1.d0
    end do
    end subroutine fill_coefficient_matrix_poisson_dirichlet_bottom_dp

    !#####################################
    subroutine fill_coefficient_matrix_poisson_dirichlet_top_sp(mat, nrows, ncols)
    real(SP), allocatable, intent(inout)        :: mat(:,:)
    integer, intent(in)                         :: nrows, ncols

    integer                                     :: k

    irow = nrows
    do icol = 1, ncols
        k = get_linear_index(irow, icol, nrows)
        mat(k, k) = 1.
    end do
    end subroutine fill_coefficient_matrix_poisson_dirichlet_top_sp

    !#####################################
    subroutine fill_coefficient_matrix_poisson_dirichlet_top_dp(mat, nrows, ncols)
    real(DP), allocatable, intent(inout)        :: mat(:,:)
    integer, intent(in)                         :: nrows, ncols

    integer                                     :: k

    irow = nrows
    do icol = 1, ncols
        k = get_linear_index(irow, icol, nrows)
        mat(k, k) = 1.d0
    end do
    end subroutine fill_coefficient_matrix_poisson_dirichlet_top_dp

    end module solver_preparation


! chk_random_number --
!     Check: does the compiler initialise the random number generator with a fixed seed or not?
!
!     Note:
!     The program has to be run twice, to see if the random numbers start with the same
!     sequence or not. The first run writes a file with the ten random numbers that were
!     generated, the second run reads that file and compares these numbers with the new ones.
!
!     Problem: random_seed is not sufficient to guarantee a new series.
!
program chk_random_number
    implicit none

    real, dimension(10) :: rnd, new_rnd
    logical             :: exists

    !call random_seed

    inquire( file = 'chk_random_number.bin', exist = exists )

    if ( .not. exists ) then
        !
        ! First run: write a file with random numbers
        !
        call random_number( rnd )
        open( 10, file = 'chk_random_number.bin', form = 'unformatted' )
        write( 10 ) rnd
        close( 10 )
    else
        !
        ! Second run: read the file with random numbers and check with the current ones
        !
        call random_number( new_rnd )
        open( 10, file = 'chk_random_number.bin', form = 'unformatted' )
        read( 10 ) rnd
        close( 10, status = 'delete' )

        write( *, '(a)' ) 'Random number generation:'
        write( *, '(a)' ) '    Probing the actual behaviour of the implementation'

        if ( all( rnd == new_rnd ) ) then
            write( *, '(a)' ) '    The second run gives the same random numbers'
            write( *, '(a)' ) '    Use random_seed if a new series is required'

            !
            ! Check if a simple call to random_seed is enough to reinitialise
            ! it arbitrarily
            !
            call random_seed
            call random_number( rnd )
            if ( all( rnd == new_rnd ) ) then
                write( *, '(a)' ) '    Note:'
                write( *, '(a)' ) '        You need to construct a new seed explicitly!'
            else
                write( *, '(a)' ) '        (A simple call to random_seed suffices)'
            endif
        else
            write( *, '(a)' ) '    The second run gives different random numbers'
            write( *, '(a)' ) '    Use random_seed to retrieve the seed and initialise'
            write( *, '(a)' ) '    to the same series'
        endif
    endif
end program chk_random_number


! ------------------------------------------------------------------------------------------------------
! Main file
! ------------------------------------------------------------------------------------------------------
! ------------------------------------------------------------------------------------------------------
! daan.camps [at] cs.kuleuven.be
! Nov. 2016
! v0.1
! ------------------------------------------------------------------------------------------------------
program radau_main
  use units
  use utilities
  use matrixrw
  use radau_common
  use radau_ad_mod
  use radau_sa_mod
  use radau_fx_mod

  implicit none

  include 'mpif.h'
  include 'dmumps_struc.h'
  include 'zmumps_struc.h'

  ! Radau variables
  ! ----------------------------------------------------------------------------------------------------
  integer		::	N, NNZ, NVEC, NS, HEVALS
  integer, allocatable	::	RI(:), CJ(:)
  real(wp)		::	HFX, HINIT, TEND, TFX, TSA, TAD
  real(wp), allocatable	::	A(:), YZERO(:), YFINAL_FX(:), YFINAL_SA(:), YFINAL_AD(:), YINT(:,:)
  integer, dimension(4)		::	STEPS

  ! OpenMPI variables
  integer ( kind = 4 ) 	::	ierr, color
  real ( kind = 8 ) 	::	wtime
  integer ( kind = 4 ) 	::	world_id, mumps_id
  integer ( kind = 4 ) 	::	world_size, mumps_rank
  integer		::	MUMPS_COMM
  integer i

  call MPI_INIT(ierr)
  call MPI_Comm_size ( MPI_COMM_WORLD, world_size, ierr )
  call MPI_Comm_rank( MPI_COMM_WORLD, world_id, ierr )

  ! Load Data
  ! ----------------------------------------------------------------------------------------------------
  call matrixread_tosparse('PROVIDE MATRIX FILENAME', N, NNZ, RI, CJ, A)
  call vectorread_todense('PROVIDE VECTOR FILENAME', NVEC, YZERO)
  if( N .ne. NVEC ) then
	call error('matvec dimensions incompatible')
  endif

  ! Integration parameters
  ! ----------------------------------------------------------------------------------------------------
  HINIT = 0.25
  HFX = 200
  TEND = 2592000
  HEVALS = 12

  ! Run methods
  ! ----------------------------------------------------------------------------------------------------
  allocate(YFINAL_FX(N))
  allocate(YFINAL_SA(N))
  allocate(YFINAL_AD(N))
  allocate(YINT(N,NS-1))
  write(*,*) ''
  write(*,*) '--------------------------------------------------------'
  write(*,*) ''
  call progress('CALLING FIXED STEP RADAU')
  wtime = MPI_Wtime ( )
  call radau_fx( A, RI, CJ, N, NNZ, YZERO, TEND, HFX, YFINAL_FX )
  TFX = MPI_Wtime ( ) - wtime

  write(*,*) ''
  write(*,*) '--------------------------------------------------------'
  write(*,*) ''
  call progress('CALLING SEMI ADAPTIVE STEP RADAU')
  wtime = MPI_Wtime()
  call radau_sa( A, RI, CJ, N, NNZ, YZERO, TEND, HINIT, HEVALS, YFINAL_SA)
  TSA = MPI_Wtime ( ) - wtime

  write(*,*) ''
  write(*,*) '--------------------------------------------------------'
  write(*,*) ''
  call progress('CALLING ADAPTIVE STEP RADAU')
  wtime = MPI_Wtime ( )
  call radau_ad( A, RI, CJ, N, NNZ, YZERO, TEND, HINIT, YFINAL_AD)
  TAD = MPI_Wtime ( ) - wtime

  write(*,*) ''
  write(*,*) '--------------------------------------------------------'
  write(*,*) ''
  ! FX WITH INTERMEDIATE RESULTS
  !NS = 4
  !STEPS(1:4) =  (/ 2, 5, 10, 50 /)
  !call radau_fx_int(A, RI, CJ, N, NNZ, YZERO, H, STEPS, NS, YINT, YFINAL_FX)

  ! Analyse results
  ! ----------------------------------------------------------------------------------------------------
  call progress('COMPARE RESULTS')
  write ( *, '(a,g14.6,a)' ) '  Elapsed wall clock time FX = ', TFX, ' seconds.'
  write ( *, '(a,g14.6,a)' ) '  Elapsed wall clock time SA = ', TSA, ' seconds.'
  write ( *, '(a,g14.6,a)' ) '  Elapsed wall clock time AD = ', TAD, ' seconds.'
  write(*,*) 'ABSOLUTE DIFFERENCE FX VS SA: ', NORM2(YFINAL_SA - YFINAL_FX)
  write(*,*) 'RELATIVE DIFFERENCE FX VS SA: ', NORM2(YFINAL_SA - YFINAL_FX)/NORM2(YFINAL_SA)
  write(*,*) 'ABSOLUTE DIFFERENCE FX VS AD: ', NORM2(YFINAL_AD - YFINAL_FX)
  write(*,*) 'RELATIVE DIFFERENCE FX VS AD: ', NORM2(YFINAL_AD - YFINAL_FX)/NORM2(YFINAL_AD)
  write(*,*) 'ABSOLUTE DIFFERENCE SA VS AD: ', NORM2(YFINAL_AD - YFINAL_SA)
  write(*,*) 'RELATIVE DIFFERENCE SA VS AD: ', NORM2(YFINAL_AD - YFINAL_SA)/NORM2(YFINAL_AD)

  write(*,*) ''
  write(*,*) '--------------------------------------------------------'
  write(*,*) ''
  call progress('WRITE RESULTS TO FILE')
  call matrixwrite('outputFX.dat', YFINAL_FX, N, 1)
  call matrixwrite('outputSA.dat', YFINAL_SA, N, 1)
  call matrixwrite('outputAD.dat', YFINAL_AD, N, 1)

  call MPI_FINALIZE(IERR)

end program


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine transformatrix(xab,p,a)
!
!     determines the transformation matrix a in a point p for a carthesian
!     (xab(7)>0) or cylindrical transformation (xab(7)<0)
!
      implicit none
!
      integer j
!
      real*8 xab(7),p(3),a(3,3),e1(3),e2(3),e3(3),dd
!
!
!
      if(xab(7).gt.0) then
!
!        carthesian transformation
!
         e1(1)=xab(1)
         e1(2)=xab(2)
         e1(3)=xab(3)
!
         e2(1)=xab(4)
         e2(2)=xab(5)
         e2(3)=xab(6)
!
         dd=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3))
         do j=1,3
            e1(j)=e1(j)/dd
         enddo
!
         dd=e1(1)*e2(1)+e1(2)*e2(2)+e1(3)*e2(3)
         do j=1,3
            e2(j)=e2(j)-dd*e1(j)
         enddo
!
         dd=dsqrt(e2(1)*e2(1)+e2(2)*e2(2)+e2(3)*e2(3))
         do j=1,3
            e2(j)=e2(j)/dd
         enddo
!
         e3(1)=e1(2)*e2(3)-e2(2)*e1(3)
         e3(2)=e1(3)*e2(1)-e1(1)*e2(3)
         e3(3)=e1(1)*e2(2)-e2(1)*e1(2)
!
      else
!
!        cylindrical coordinate system in point p
!
         e1(1)=p(1)-xab(1)
         e1(2)=p(2)-xab(2)
         e1(3)=p(3)-xab(3)
!
         e3(1)=xab(4)-xab(1)
         e3(2)=xab(5)-xab(2)
         e3(3)=xab(6)-xab(3)
!
         dd=dsqrt(e3(1)*e3(1)+e3(2)*e3(2)+e3(3)*e3(3))
!
         do j=1,3
            e3(j)=e3(j)/dd
         enddo
!
         dd=e1(1)*e3(1)+e1(2)*e3(2)+e1(3)*e3(3)
!
         do j=1,3
            e1(j)=e1(j)-dd*e3(j)
         enddo
!
         dd=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3))
!
!        check whether p belongs to the cylindrical coordinate axis
!        if so, an arbitrary vector perpendicular to the axis can
!        be taken
!
         if(dd.lt.1.d-10) then
c            write(*,*) '*WARNING in transformatrix: point on axis'
            if(dabs(e3(1)).gt.1.d-10) then
               e1(2)=1.d0
               e1(3)=0.d0
               e1(1)=-e3(2)/e3(1)
            elseif(dabs(e3(2)).gt.1.d-10) then
               e1(3)=1.d0
               e1(1)=0.d0
               e1(2)=-e3(3)/e3(2)
            else
               e1(1)=1.d0
               e1(2)=0.d0
               e1(3)=-e3(1)/e3(3)
            endif
            dd=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3))
         endif
!
         do j=1,3
            e1(j)=e1(j)/dd
         enddo
!
         e2(1)=e3(2)*e1(3)-e1(2)*e3(3)
         e2(2)=e3(3)*e1(1)-e1(3)*e3(1)
         e2(3)=e3(1)*e1(2)-e1(1)*e3(2)
!
      endif
!
!     finding the transformation matrix
!
      do j=1,3
         a(j,1)=e1(j)
         a(j,2)=e2(j)
         a(j,3)=e3(j)
      enddo
!
      return
      end


       PROGRAM HUBBLE
C++:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C  Program HUBBLE
C  (From KING1)
C  Reads a profile and then fits a surface brightness profile (broadened
C  by the seeing function) following a modified Hubble law in density
C  (WARNING : Here I take the space density and not the surface brightness !)
C
C   Option 1 :
C   RHO=1/(1 + RAD/RC)**ETA
C   Option 2 :
C   RHO=1/(1 + (RAD/RC)**2)**ETA
C   Option 3 :
C   PHI=1/(1 + (RAD/RC)**2)**ETA
C
C   Fit in Log10(rad)/Log10(surf. brightness), output in Log10(rad)/Magnitude
C
C JLP Version of 18-11-86
C--:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
	PARAMETER (IDIM=1000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 RHO(IDIM),RAD(IDIM),RAD1(IDIM),
     1	S(IDIM),K(IDIM),SPLINE(IDIM),
     1	XC(2),Y(IDIM),RADIUS(IDIM),PROF(IDIM),
     1	WK(5000),LOGR(IDIM),LOGPROF(IDIM)
	REAL*4 X1PLOT(IDIM),X2PLOT(IDIM),Y1PLOT(IDIM),Y2PLOT(IDIM)
	REAL*4 X3PLOT(IDIM),Y3PLOT(IDIM)
	INTEGER IWK(5)
	CHARACTER NAME*60,COMMENTS*80,ANS*1
	CHARACTER CHAR1*30,CHAR2*30,TITLE*40,PLOTDEV*32
C
	COMMON/MODEL/S0,ETA,RHO,RAD
	COMMON/SPLINE/SPLINE,NCAP7,K
	COMMON/NAG/NSTART,LOGR,LOGPROF,ITERATION
	COMMON/CONSTANT/PI,PI1

C Common block with NEWPLOT
	COMMON /STR_OUTPUT/XOUT(200),YOUT(200),NOUT

	PI=3.14159265358979323846D0
	PI1=DSQRT(2.D0*PI)
10	FORMAT(A)
C
C  Reads the profile.
C
	PRINT *,' FORMAT OF THE INPUT FILE :'
	PRINT *,' 1. NPTS,X,Y   2. NPTS,X,Y,VNUMBER'
	READ(5,*) IFORMT
1022	PRINT *,' NAME OF THE PROFILE ?'
	READ(5,10) NAME
	PRINT *,' CONSTANT YOU WANT TO SUBTRACT TO THE INPUT PROFILE',
     1	' (SKY LEVEL) :'
	READ(5,*) SKY
	PRINT *,' ZEROPOINT FOR THE MAGNITUDES (/ARCSEC**2) :'
	READ(5,*) CMAG
	OPEN (9,FILE=NAME,STATUS='OLD',ERR=1022)
	READ(9,*)NBINS

	IF(IFORMT.EQ.1)THEN
	   DO I=1,NBINS
            READ (9,*,END=11) RADIUS(I),PROF(I)
	    PROF(I)=PROF(I)-SKY
	   END DO
	ELSE
	   DO I=1,NBINS
            READ (9,*,END=11) RADIUS(I),PROF(I),WORK
	    PROF(I)=PROF(I)-SKY
	   END DO
	ENDIF

	GO TO 111
11	NBINS=I-1
	PRINT *,' WARNING : LESS POINTS THAN EXPECTED !!!!'
111	PRINT 112,NBINS,RADIUS(1),RADIUS(NBINS)
112	FORMAT(2X,I5,' POINTS RECEIVED',/,' PROFILE FROM ',
     1	F12.3,' ARCSECONDS TO ',F12.3,' ARCSECONDS',/)

C  Gets the observed profile ready for the fit (conversion in Log/Log)

	DO I=1,NBINS
	LOGR(I)=DLOG10(RADIUS(I))
	  IF(PROF(I).LE.0.D0)THEN
	  NBINS=I-1
	  PRINT 113,RADIUS(I-1)
113	  FORMAT(' NEGATIVE VALUES !',/,
     1	' PROFILE TRONCATED AT R= ',F12.3,' ARCSECONDS',/)
	  GO TO 12
	  ENDIF
        LOGPROF(I)=DLOG10(PROF(I))
	END DO

12	DO J=1,NBINS
	X1PLOT(J)=LOGR(J)
	Y1PLOT(J)=-2.5D0*LOGPROF(J)+CMAG
	END DO
C
C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C
C  For a given value of ETA, use least squares to find the best values of
C  RCORE and E0 to fit the data over a given range.
C
C   Enter ETA plus guesses for E0 and RCORE
C
14	PRINT 15
15	FORMAT(' MENU :',/,
     1	' 1. RHO= (1+ R/RC)**(-ETA)',/,
     1	' 2. RHO= (1+ (R/RC)**2 )**(-ETA)',/,
     1	' 3. PHI= (1+ R/RC)**(-ETA)',/,
     1	' ENTER THE OPTION YOU WANT : ',$)
	READ(5,*) IOPT
	WRITE (6,334)
334	FORMAT(/' Enter sigma of seeing: ',$)
	READ (5,*) SIGMA
C
	WRITE (6,335)
335	FORMAT(/' Enter guesses for B0 and core radius: ',$)
	READ (5,*) B0,RCORE
	XC(1)=(CMAG-B0)/2.5
	XC(2)=DLOG10(RCORE)
	PRINT *,'XC(1) , XC(2) : ',XC(1),XC(2)
	WRITE (6,3355)
3355	FORMAT(' Enter value of ETA : ',$)
	READ (5,*) ETA
C
C Entering the limiting indices :
	PRINT *,' Do you want to display the input profile'
	PRINT *,' to enter the limiting points for the fit? (N)'
	READ(5,10) ANS

C Dislaying the profile in Log/Log
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')THEN
	CHAR1='LOG10(RADIUS)  (ARCSEC)'
	CHAR2='MAGNITUDE/ARCSEC**2'
	TITLE='ENTER STARTING AND ENDING POINTS FOR THE FIT'
	NOUT=0
	PRINT *,' Device: &xterm, ... ?'
	READ(5,10) PLOTDEV
	CALL DISPLAY1(X1PLOT,Y1PLOT,1,NBINS,CHAR1,CHAR2,TITLE,PLOTDEV)
	RSTART=DBLE(EXP(XOUT(1)))
	REND=DBLE(EXP(XOUT(2)))
	PRINT 331,RSTART,REND
331	FORMAT(' RSTART =',F12.3,'   REND =',F12.3,/)
	ENDIF

C Or entering the indices directly :
	IF(ANS.EQ.'N'.OR.NOUT.EQ.0)THEN
	WRITE (6,339)
339	FORMAT(' Enter start radius and end radius for fitting: ')
	READ (5,*) RSTART,REND
	ENDIF

C--------------------------------------------------------------
C Finding the indices corresponding to the radii :

	I=1
94	IF(RADIUS(I).GE.RSTART.OR.I.GE.NBINS) GOTO 95
	I=I+1
        GOTO 94
95	NSTART=I

	I=NBINS
96	IF(RADIUS(I).LE.REND.OR.I.LT.1)GOTO 97
	I=I-1
	GOTO 96
97	NEND=I

	PRINT *,' NSTART, NEND : ',NSTART,NEND

C-----------------------------------------------------------------
C Calculating the model

C Entering the number of points for the model
	PRINT *,' NUMBER OF POINTS FOR THE MODEL ? (MINI=100)'
	READ(5,*) NPTS

C Generates the radius array with a logarithmic scale
C From 0.01*RCORE TO 1000.*RCORE (or so...)

      DO I=1,NPTS
         WORK=-2.0D0+5.0D0*FLOAT(I)/FLOAT(NPTS)   ! Set up radius array.
         RAD(I)=10**WORK
      END DO
C
      PRINT *,' '
      PRINT *,' Calculating the model...'

      CALL HUBBLE1(NPTS,IOPT)

C Getting the model scaled to the guessed value of RCORE
	DO I=1,NPTS
	RAD1(I)=RAD(I)*RCORE
	END DO
C
C  Put the density through the Abel integral to get the surface brightness
C in scaled radii
	CALL PROJECT_ABEL(RAD1,RHO,S,NPTS)

C Normalization with the first few points (normalization in the center
C before broadening)
	CNORM=(S(2)+S(3)+S(4))/3.D0
	DO I=1,NPTS
	S(I)=S(I)/CNORM
	X2PLOT(I)=DLOG10(RAD1(I))
	Y2PLOT(I)=DLOG10(S(I))
	END DO
C
C   Broadens the surface brightness using the Hankel transform.
C in scaled radii

	CALL BROADEN(RAD1,S,NPTS,SIGMA)

C-----------------------------------------------------------------
	PRINT *,' DO YOU WANT TO DISPLAY THE MODEL'
	PRINT *,'   AND ITS BROADENED FORM ?(N)'
	READ(5,10) ANS

	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')THEN
	  DO I=1,NPTS
	  Y3PLOT(I)=DLOG10(S(I))
	  END DO
	 CHAR1='LOG10(RADIUS)  (ARCSEC)'
	 CHAR2='LOG10(SURF. BRIGHTNESS)'
	 PRINT *,' TITLE ?'
	 READ(5,10) TITLE
	 PRINT *,' DEVICE: &xterm, ... ?'
	 READ(5,10) PLOTDEV
         COMMENTS=' '
	 CALL DISPLAY2(X2PLOT,Y2PLOT,1,NPTS,X2PLOT,Y3PLOT,
     1	1,NPTS,CHAR1,CHAR2,TITLE,PLOTDEV,'L','L2',NAME,COMMENTS)
	ENDIF

C   Fits a spline to the surface density S of the calculated
C   profile as a function of RAD = LOG10(r/rcore).

999	PRINT *,' Calling Splinelogfit :'
	CALL SPLINELOGFIT(RAD,S,NPTS,SPLINE,NCAP7,K)

C   Now call minimization routine E04GEF (NAG).
C   M: number of points
C   N: number of parameters (here 2 : Io and Rc)
C   XC: parameters [ XC(1)=Io and XC(2)=Rc ]
C
	N=2
	LIWK=5		!LENTH OF IW
	LWK=5000	!LENTH OF WK
	IFAIL=1
	M=NEND-NSTART+1
	ITERATION=0
	PRINT *,' CALLING "E04GEF"'
	CALL E04GEF (M,N,XC,FSUMSQ,IWK,LIWK,WK,LWK,IFAIL)
	RMS=DSQRT(FSUMSQ/(M-N))
	WRITE (6,88) FSUMSQ,ITERATION,RMS
88	FORMAT (' FINAL SUM OF SQUARES = ',E12.5,/,
     1	' AFTER',I5,' ITERATIONS.  RMS =',E12.5)
C
	IF(IFAIL.NE.0) THEN
	WRITE (6,77) IFAIL
77	FORMAT (' ***** WARNING ***** : IFAIL =',I3)
	END IF
C
	WRITE (6,338)
338	FORMAT(' And the magic numbers are: ')
	B0=-2.5*XC(1)+CMAG
	WRITE (6,55) B0
55	FORMAT(' B0 = ',F11.4)
	RCORE=10.D0**XC(2)
	WRITE (6,66) RCORE
66	FORMAT(' RCORE = ',F11.4)
C
C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C DISPLAYS THE CURVES
C
	PRINT *,'NCAP7=',NCAP7

	DO I=1,NPTS
	X2PLOT(I)=DLOG10(RAD(I))+XC(2)
	Y2PLOT(I)=-2.5D0*DLOG10(S(I))+B0
	END DO
C
	PRINT *,' DO YOU WANT TO DISPLAY THE TWO CURVES ? (Y)'
	READ(5,10) ANS

	IF(ANS.NE.'N')THEN
	CHAR1='LOG10(RADIUS)  (ARCSEC)'
	CHAR2='MAGNITUDE/ARCSEC**2'
	PRINT *,'TITLE ?'
	READ(5,10) TITLE
	PRINT *,' DEVICE : TEKTRO, CIFER_T5, CANON ?'
	READ(5,10) PLOTDEV
        COMMENTS=' '
	CALL DISPLAY2(X1PLOT,Y1PLOT,1,NBINS,X2PLOT,Y2PLOT,
     1	1,NPTS,CHAR1,CHAR2,TITLE,PLOTDEV,'L','L2',NAME,COMMENTS)
	ENDIF

C
C   Stores the graph in an output file
C
	PRINT *,' DO YOU WANT TO STORE THE TWO CURVES (FILE)? (Y)'
	READ(5,10) ANS

	IF(ANS.NE.'N')THEN
	KCURVE=2
	CALL STORE_GRAPH(X1PLOT,Y1PLOT,1,NBINS,X2PLOT,Y2PLOT,
     1	1,NPTS,KCURVE)
	ENDIF
C***********************************************************************
C Displaying the residuals :
	DO I=NBINS,1,-1
	IF(RADIUS(I).LT.RAD(NPTS))GO TO 900
	END DO
900	NMAX=I-1

	DO I=1,NMAX
C Calling E02BBF (NAG):
	IFAIL=1
C Determining the image of LOG10(RADIUS(I)/RCORE) with E02BBF :
	X=X1PLOT(I)-XC(2)
	CALL E02BBF (NCAP7,K,SPLINE,X,RESULT,IFAIL)
	IF(IFAIL.NE.0)PRINT 576,IFAIL
576	FORMAT(' WARNING : IN E02BBF  IFAIL=',I3)
	WORK=-2.5D0*RESULT+B0
	Y2PLOT(I)=Y1PLOT(I)-WORK
	END DO

	PRINT *,' DO YOU WANT TO DISPLAY THE RESIDUALS ? (Y)'
	READ(5,10) ANS

	IF(ANS.NE.'N')THEN
	CHAR1='LOG10(RADIUS) (ARCSEC)'
	CHAR2='PROFILE-MODEL (MAG/ARCSEC**2)'
	DO I=1,NMAX
	Y3PLOT(I)=0.0
	END DO
	PRINT *,'TITLE ?'
	READ(5,10) TITLE
	PRINT *,' DEVICE : TEKTRO, CIFER_T5, CANON ?'
	READ(5,10) PLOTDEV
        COMMENTS=' '
	CALL DISPLAY2(X1PLOT,Y2PLOT,1,NMAX,X1PLOT,Y3PLOT,
     1	CHAR1,CHAR2,TITLE,PLOTDEV,'L','L1',NAME,COMMENTS)
	ENDIF

C
C   Stores the graph in an output file
C
	PRINT *,' DO YOU WANT TO STORE THE TWO CURVES (FILE)? (Y)'
	READ(5,10) ANS

	IF(ANS.NE.'N')THEN
	KCURVE=1
	CALL STORE_GRAPH(X1PLOT,Y2PLOT,1,NMAX,X1PLOT,Y2PLOT,
     1	1,NMAX,KCURVE)
	ENDIF

C***********************************************************************
	PRINT *,' DO YOU WANT ANOTHER TRY ? (Y)'
	READ(5,10) ANS
	IF(ANS.NE.'N'.AND.ANS.NE.'n') GO TO 14
C
	CLOSE(9)
	STOP
	END
C---------------------------------------------------------------------
      SUBROUTINE LSFUN2 (M,N,XC,FVECC,FJACC,LJC)
C---------------------------------------------------------------------
C     Subroutine to produce the function value and the first-order
C     partial derivatives of the function to be minimized by E04GEF
C
C	M: Number of points
C	N: Number of parameters
C	FVECC: Residuals
C	FJACC: Jacobian matrix
C	LOGR: Log10(radius) of the input profile
C	LOGPROF: Log10(input profile)
C------------------------------------------------------------------------
      PARAMETER (IDIM=1000)
      REAL*8 XC(N),SPLINE(IDIM),FVECC(M),
     +     FJACC(M,LJC),K(IDIM),S(5),X,
     +     LOGR(IDIM),LOGPROF(IDIM)
      INTEGER M,N,IFAIL,NCAP7,NSTART
C
      COMMON/SPLINE/SPLINE,NCAP7,K
      COMMON/NAG/NSTART,LOGR,LOGPROF,ITERATION
C
	ITERATION=ITERATION+1

	DO J=NSTART,NSTART+M-1
	X=LOGR(J)-XC(2)
C  i.e. X = LOG10( RAD/Rcore )

C Attempt to avoid a failure in E02BCF when X is outside of the
C boundaries...
	IF(X.LT.K(5).OR.X.GT.K(NCAP7-3))THEN
	PRINT *,' PB WITH E02BCF!! (TRY WITH MORE POINTS)'
	PRINT *,'J=',J,'X=',X,'LOGR(J)=',LOGR(J)
	FVECC(J-NSTART+1)=100.
	FJACC(J-NSTART+1,1)=-1.0D0
	FJACC(J-NSTART+1,2)=+1.0D0
	GO TO 637
	ENDIF

C Calling E02BCF (NAG)
	IFAIL=1
	LEFT=0
	CALL E02BCF (NCAP7,K,SPLINE,X,LEFT,S,IFAIL)
	IF(IFAIL.NE.0)PRINT 576,IFAIL
576	FORMAT(' WARNING : IN E02BCF  IFAIL=',I3)
	FVECC(J-NSTART+1)=LOGPROF(J)-XC(1)-S(1)
	FJACC(J-NSTART+1,1)=-1.0D0
	FJACC(J-NSTART+1,2)=S(2)

637	END DO
	RETURN
	END
C-----------------------------------------------------------------------
	SUBROUTINE HUBBLE1(NPTS,IOPT)
C-----------------------------------------------------------------------
C   Generates the array RHO of the space density
C   NPTS = number of points for the calculated profile
C
C   Option 1 :
C   RHO=1/(1 + RAD/RC)**ETA
C   Option 2 :
C   RHO=1/(1 + (RAD/RC)**2)**ETA
C   Option 3 :
C   PHI=1/(1 + (RAD/RC)**2)**ETA
C
C-----------------------------------------------------------------------
	PARAMETER (IDIM=1000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 RHO(IDIM),RAD(IDIM)
C
	COMMON/MODEL/B0,ETA,RHO,RAD

C   Option 1 :
C   RHO=1/(1 + RAD/RC)**ETA
	IF(IOPT.EQ.1)THEN
	DO I=1,NPTS
	RHO(I)=1.D0/((1.D0+RAD(I))**ETA)
	END DO
	ENDIF

C   Option 2 :
C   RHO=1/(1 + (RAD/RC)**2)**ETA
	IF(IOPT.EQ.2)THEN
	DO I=1,NPTS
	RHO(I)=1.D0/((1.D0+RAD(I)**2)**ETA)
	END DO
	ENDIF

C   Option 3 :
C   PHI=1/(1 + (RAD/RC)**2)**ETA
	IF(IOPT.EQ.3)THEN
	CTE1=3.D0-2.D0*(1.D0+ETA)
	DO I=1,NPTS
	RR2=RAD(I)*RAD(I)
	RHO(I)=(RR2*CTE1+3.D0)*((1.D0+RR2)**(-2.-ETA))
	END DO
	ENDIF

	RETURN
	END
C---------------------------------------------------------------------
c	include 'jlpsub:project.for'


      DOUBLE PRECISION FUNCTION GAUNT1(LP,L,LS,MP,M,MS)
!
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
!
!        Arguments
!
      INTEGER            L, LP, LS, M, MP, MS
!
!     ..................................................................
!
!        GAUNT computes the integral of
!           CONJG(Y(LP,MP))*Y(L,M)*Y(LS,MS) for LP+L+LS .LE. 23
!        using gaussian quadrature with N=12 as given by
!           M. Abramowitz and I.A. Stegun,
!           'Handbook of Mathematical Functions',
!           NBS Applied Mathematics Series 55 (1968), pages 887 and 916
!        written by Bruce Harmon based on suggestion by W. Rudge
!        Iowa State Sept.1973
!
!        extended by M. Weinert and E. Wimmer
!        Northwestern University March 1980
!
!     ..................................................................
!
      INTEGER            MAXDIM, N
      PARAMETER          (MAXDIM = 81, N = 6)
      DOUBLE PRECISION   ZERO
      PARAMETER          (ZERO = 0.0D+0)
!
!        Common blocks
!
      DOUBLE PRECISION   YR(N,MAXDIM)
      COMMON  /ASSLEG/   YR
      SAVE    /ASSLEG/
!
!        Local Scalars
!
      INTEGER            I, IL, ILP, ILS
      DOUBLE PRECISION   S
      DOUBLE PRECISION   W(N)
!
!        Data statements
!
      DATA W /0.24914704581340D+0, 0.23349253653836D+0, &
              0.20316742672307D+0, 0.16007832854335D+0, &
              0.10693932599532D+0, 0.04717533638651D+0/
!
      IL = L*(L+1) + M + 1
      ILP = LP*(LP+1) + MP + 1
      ILS = LS*(LS+1) + MS + 1
      S = ZERO
      DO 10 I = 1, N
         S = S + W(I)*YR(I,ILP)*YR(I,IL)*YR(I,ILS)
   10 CONTINUE
      GAUNT1 = S
!
      RETURN
!
!        End of 'GAUNT1'
!
      END


!*****************************************************************!
! This module implements exchange and LDA-correlation
! functional in case of yukawa screened interaction
!    2*exp(-lambda*r)/r
! Here units are implemented in Rydbergs.
! The relevant subroutines are:
!
!   subroutine ExchangeLDA(Ex, Vx, rs_1, lambda, N)
!      needs:
!         real*8 :: Ex(N), Vx(N), rs_1(N), lambda  ! rs_1==1/rs
!
!   subroutine CorrLDA(Ec, Vc, rsi, lambda, N)
!      needs:
!         real*8 :: Ec(N_, Vc(N), rsi(N), lambda  ! rsi=rs
!*****************************************************************!
subroutine ExchangeLDA(Ex, Vx, rs_1, lambda, N)
  IMPLICIT NONE
  REAL*8, intent(in) :: lambda
  REAL*8, intent(in) :: rs_1(N)
  REAL*8, intent(out):: Ex(N), Vx(N)
  INTEGER, intent(in):: N
  ! locals
  REAL*8 :: kf_rs, c0, pi
  REAL*8 :: xs(N), dEx(N)
  !
  pi = 4.*atan(1.)
  !
  kf_rs = (9*pi/4.)**(1./3.)
  c0 = (3./(2.*pi))*(9.*pi/4.)**(1./3.)
  xs(:) = rs_1(:)*(kf_rs/lambda)       ! kf/(rs*lambda)
  if (lambda.ne.0) then
     CALL fexchange(xs,Ex,dEx,N)
  else
     Ex(:)=1.0
     dEx(:)=0.0
  endif
  Ex(:) = -(c0*rs_1)*Ex(:)
  Vx(:) = 4./3.*Ex(:) - (c0/3.)*rs_1(:)*xs(:)*dEx(:)
end subroutine ExchangeLDA

SUBROUTINE fexchange(xs,ex,dex,N)
  !* Evaluating a function (and its derivative) for exchange energy, which has a formula
  !*  f(x) = 1-1/(6*x^2)-4/(3*x)*atan(2*x)+(1+1/(12*x^2))/(2*x^2)*log(1+4*x^2)
  !* df/dx = 2/(3*x^3) + 4/(3*x^2)*atan(2*x) - (1+6*x^2)/(6*x^5)*log(1+4*x^2)
  IMPLICIT NONE
  REAL*8, intent(in) :: xs(N)
  REAL*8, intent(out):: ex(N), dex(N)
  INTEGER, intent(in):: N
  ! locals
  INTEGER :: i
  integer, volatile :: iCopy
  REAL*8 :: x, x2, x3, at2, lg2
  do i=1,N
     x = xs(i)
     x2 = x*x
     x3 = x2*x
     iCopy = i  ! A fix for intel compiler bug, so that it does not optimize out the loop
     if (x<0.01) then
        ex(i) = 4.*x2/9.*(1-6*x2/5.)
        dex(i) = 8.*x/9.*(1-12*x2/5.)
     else
        at2 = atan(2*x)*4./(3.*x)
        lg2 = log(1+4.*x2)/(2.*x2)
        ex(i) = 1-1/(6.*x2) - at2+ (1.+1/(12.*x2))*lg2
        dex(i) = 2./(3.*x3) + at2/x - (1.+6*x2)/(3.*x3)*lg2
     end if
  end do
END SUBROUTINE fexchange

REAL*8 Function f1(coef,x,x2,x4,x6)
  IMPLICIT NONE
  REAL*8, intent(in) :: x, x2, x4, x6, coef(5)
  f1 = (x*coef(1)+x2*coef(2))/(1+x2*coef(3)+x4*coef(4)+x6*coef(5))
  return
END Function f1
REAL*8 Function f2(coef,x2,x3,x4)
  IMPLICIT NONE
  REAL*8, intent(in) :: x2, x3, x4, coef(4)
  ! locals
  f2 = (x2*coef(1)+x3*coef(2))/(1+x2*coef(3)+x4*coef(4))
  return
END Function f2
REAL*8 Function f3(coef,x2,x3,x4)
  IMPLICIT NONE
  REAL*8, intent(in) :: x2, x3, x4, coef(3)
  f3 = (x3*coef(1)+x4*coef(2))/(1+coef(3)*x2)
  return
END Function f3
REAL*8 Function f4(coef,x2,x4)
  IMPLICIT NONE
  REAL*8, intent(in) :: x2, x4, coef(2)
  f4 = x4*(coef(1)+coef(2)*x2)
  return
END Function f4

subroutine EcVc_reduce(rsi,lambda,A,C,N)
  IMPLICIT NONE
  INTEGER, intent(in):: N
  REAL*8, intent(in) :: rsi(N)
  REAL*8, intent(in) :: lambda
  REAL*8, intent(out):: A(N), C(N)
  !
  interface
     REAL*8 Function f1(coef,x,x2,x4,x6)
       REAL*8, intent(in) :: x, x2, x4, x6, coef(5)
     END Function f1
     REAL*8 Function f2(coef,x2,x3,x4)
       REAL*8, intent(in) :: x2, x3, x4, coef(4)
     END Function f2
     REAL*8 Function f3(coef,x2,x3,x4)
       REAL*8, intent(in) :: x2, x3, x4, coef(3)
     END Function f3
     REAL*8 Function f4(coef,x2,x4)
       REAL*8, intent(in) :: x2, x4, coef(2)
     END Function f4
  end interface
  ! locals
  INTEGER:: i
  REAL*8 :: coef1(5), coef2(4), coef3(3), coef4(2)
  REAL*8 :: cfs(4)
  REAL*8 :: x, x2, x3, x4, x6, rs, Br
  coef1 = (/0.12238912,  0.73648662,  0.96044695, -0.07501634,  0.00207808/)
  coef2 = (/0.05839362,  0.11969474,  0.10156124,  0.01594125/)
  coef3 = (/0.00827519,  0.00557133,  0.01725079/)
  coef4 = (/5.29134419e-04, 4.49628225e-06/)

  x=lambda
  x2=x*x
  x3=x*x2
  x4=x2*x2
  x6=x4*x2

  cfs(1)=exp(f1(coef1,x,x2,x4,x6))-1.
  cfs(2)=exp(f2(coef2,x2,x3,x4))-1.
  cfs(3)=exp(f3(coef3,x2,x3,x4))-1.
  cfs(4)=exp(f4(coef4,x2,x4))-1.

  !print *, 'cfs=', cfs
  do i=1,N
     rs=rsi(i)
     A(i)  = 1.0+rs*(cfs(1)+rs*(cfs(2)+rs*(cfs(3)+rs*cfs(4))))
     Br = rs*(cfs(1)+rs*(2*cfs(2)+rs*(3*cfs(3)+rs*4*cfs(4))))
     C(i) = 3*A(i)**2/Br
  enddo
end subroutine EcVc_reduce

SUBROUTINE  Gcor(GG,GGrs,rs, A,A1,B1,B2,B3,B4,P)
  IMPLICIT NONE
  REAL*8, intent(in)  :: rs, A, A1, B1, B2, B3, B4
  INTEGER, intent(in) :: P
  REAL*8, intent(out) :: GG, GGrs
  ! locals
  REAL*8 :: P1, Q0, RS12, RS32, RSP, Q1, Q2, Q3
  P1 = P + 1.
  Q0 = -2.*A*(1.+A1*rs)
  RS12 = sqrt(rs)
  RS32 = RS12**3
  RSP = rs**P
  Q1 = 2.*A*(B1*RS12+B2*rs+B3*RS32+B4*rs*RSP)
  Q2 = log(1.+1./Q1)
  GG = Q0*Q2
  Q3 = A*(B1/RS12+2.*B2+3.*B3*RS12+2.*B4*P1*RSP)
  GGRS = -2.*A*A1*Q2-Q0*Q3/(Q1**2+Q1)
END SUBROUTINE Gcor

subroutine CorLDA(Ec,Vc,rs)
  IMPLICIT NONE
  !  UNITS OF Rydberg
  !  UNIFORM-GAS CORRELATION OF PERDEW AND WANG 1991
  !  INPUT: SEITZ RADIUS (rs)
  !  OUTPUT: CORRELATION ENERGY PER ELECTRON (Ec) and POTENTIALS (Vc)
  !
  REAL*8, intent(out):: Ec, Vc
  REAL*8, intent(in) :: rs
  ! locals
  REAL*8 :: H2Ry, Ecrs
  H2Ry = 2.0    ! Conversion from Hartree to Rydberg
  CALL Gcor(Ec, Ecrs,    rs, 0.0310907D0,  0.21370D0,  7.5957D0, 3.5876D0, 1.6382D0, 0.49294D0, 1)
  Vc = Ec - rs*Ecrs/3.
  Vc = Vc*H2Ry  ! From Hartree to Rydbergs
  Ec = Ec*H2Ry  ! From Hartree to Rydbergs
end subroutine CorLDA

subroutine CorrLDA(Ec, Vc, rsi, lambda, N)
  IMPLICIT NONE
  INTEGER, intent(in):: N
  REAL*8, intent(in) :: rsi(N)
  REAL*8, intent(in) :: lambda
  REAL*8, intent(out):: Ec(N), Vc(N)
  !locals
  INTEGER :: i
  REAL*8 :: A(N), C(N)

  do i=1,N
     CALL CorLDA(Ec(i),Vc(i),rsi(i))
  enddo

  CALL EcVc_reduce(rsi,lambda,A,C,N)
  Vc(:) = Vc(:)/A(:)+Ec(:)/C(:)
  Ec(:) = Ec(:)/A(:)

end subroutine CorrLDA

! program exc
!   IMPLICIT NONE
!   REAL*8 :: rs(4), A(4), C(4), rs_1(4)
!   REAL*8 :: lambda, Ec, Vc
!   INTEGER:: i
!   REAL*8 :: rx, Ec1, Vc1, Ec2, Vc2, dr
!   REAL*8 :: Ecs(4), Vcs(4), Ecs1(4), Vcs1(4), Ecs2(4), Vcs2(4)
!   REAL*8 :: A0(4), C0(4), A1(4), C1(4), A2(4), C2(4), dA(4), dE(4), E0(4), Ex(4), Vx(4)
!   rs=(/1.5,2.5,3.5,4.5/)
!
!   lambda=1.5
!
!   dr=0.001
!
!   CALL EcVc_reduce(rs,lambda,A,C,4)
!   print *, A
!   print *, C
!
!   do i=1,4
!      rx=rs(i)
!      CALL CorLDA(Ec,Vc,rx)
!
!      CALL CorLDA(Ec1,Vc1,rx+dr)
!      CALL CorLDA(Ec2,Vc2,rx-dr)
!
!      Vc1 = Ec - 1./3.*rx*(Ec1-Ec2)/(2*dr)
!
!      print *, 'rx=', rx, 'Vc=', Vc, 'Ec=', Ec, 'Vapprox=', Vc1
!   enddo
!
!   CALL  CorrLDA(Ecs1, Vcs1, rs, 0.d0, 4)
!   print *, 'Vc0=', Vcs1
!   print *, 'Ec0=', Ecs1
!
!   CALL  CorrLDA(Ecs, Vcs, rs, lambda, 4)
!   print *, 'Vc=', Vcs
!   print *, 'Ec=', Ecs
!
!   print *, 'Vc_ratio=', Vcs/Vcs1
!
!   !CALL  CorrLDA(Ecs1, Vcs1, rs+dr, lambda, 4)
!   !CALL  CorrLDA(Ecs2, Vcs2, rs-dr, lambda, 4)
!   !Vcs1 = Ecs - 1./3.*rs*(Ecs1-Ecs2)/(2*dr)
!   !print *, 'Vapprox=', Vcs1
!
!
!
!   !CALL EcVc_reduce(rs,lambda,A0,C0,4)
!   !CALL EcVc_reduce(rs+dr,lambda,A1,C1,4)
!   !CALL EcVc_reduce(rs-dr,lambda,A2,C2,4)
!   !
!   !dA = (1/A1(:)-1/A2(:))/(2*dr)
!   !print *, 'dA=', dA
!   !print *, 'dA=', -3./(C0*rs)
!
!
!   !CALL  CorrLDA(Ecs1, Vcs1, rs+dr, lambda, 4)
!   !CALL  CorrLDA(Ecs2, Vcs2, rs-dr, lambda, 4)
!   !dE = (Ecs1-Ecs2)/(2*dr)
!   !print *, 'dE/dr=', dE
!   !
!   !do i=1,4
!   !   CALL CorLDA(Ec,Vc,rs(i))
!   !   CALL CorLDA(Ec1,Vc1,rs(i)+dr)
!   !   CALL CorLDA(Ec2,Vc2,rs(i)-dr)
!   !   dE(i) = (Ec1-Ec2)/(2*dr)
!   !   E0(i)=Ec
!   !enddo
!   !CALL EcVc_reduce(rs,lambda,A0,C0,4)
!   !dE(:) = dE(:)/A0(:)-3*E0(:)/(C0*rs)
!   !print *, 'dE/dr=', dE
!
!
!   rs_1=1./rs
!   CALL ExchangeLDA(Ex, Vx, rs_1, lambda, 4)
!   print *, 'Ex=', Ex
!   print *, 'Vx=', Vx
!
! end program exc


PROGRAM t_logistic
! Use the low infant birth weight data from Hosmer & Lemeshow

USE Logistic_Regression
IMPLICIT NONE

CHARACTER (LEN= 6)  :: vname(0:10) = (/  &
                       'Const.', 'Age   ', 'LWT   ', 'Race_2', 'Race_3', &
                       'Smoke?', 'PTL   ', 'HT    ', 'UI    ', 'FTV   ', &
                       'BWT   ' /)
INTEGER    :: iostatus, id, low, age, lwt, race, smoke, ptl, ht, ui, ftv,  &
              bwt, ncases, n(200), s(200), ndf, ier, i

REAL (dp)  :: x(200, 9), chisq, devnce, beta(0:9), se_beta(0:9), tail_prob

! Read the data file

OPEN(UNIT=8, FILE='birthwt.dat', STATUS='OLD')
ncases = 0
DO
  READ(8, *, IOSTAT=iostatus) id, low, age, lwt, race, smoke, ptl, ht, ui,  &
                              ftv, bwt
  IF (iostatus < 0) EXIT
  IF (iostatus > 0) CYCLE
  ncases = ncases + 1
  n(ncases) = 1
  s(ncases) = low
  x(ncases, 1) = age
  x(ncases, 2) = lwt
  x(ncases, 3:4) = 0.0_dp
  IF (race > 1) x(ncases, race+1) = 1.0_dp
  x(ncases, 5) = smoke
  x(ncases, 6) = ptl
  x(ncases, 7) = ht
  x(ncases, 8) = ui
  x(ncases, 9) = ftv
END DO

WRITE(*, *) 'NCASES = ', ncases
WRITE(*, *)

! Fit full model and report

CALL logistic(ncases, x, 9, s, n, chisq, devnce, ndf, beta, se_beta, ier)
IF (ier /= 0) THEN
  WRITE(*, *) 'Error number', ier
ELSE
  WRITE(*, '(a, f9.3, a, f9.3, a, i4, a)')  &
        ' Deviance = ', devnce, '   Chi-squared = ', chisq,   &
        ' with ', ndf, ' deg. of freedom'
  tail_prob = 1.0_dp - chi_squared(ndf, chisq)
  IF (tail_prob < 0.01_dp) THEN
    WRITE(*, *) '*** Significantly bad fit at the 1% level ***'
  END IF
  WRITE(*, '(a, g12.4/)') ' Chi-squared tail prob. = ', tail_prob
  WRITE(*, *) '        Coefficient   Std.error'
  DO i = 0, 9
    WRITE(*, '(" ", a6, "  ", 2g13.5)') vname(i), beta(i), se_beta(i)
  END DO

END IF

! Omit the last variable for which the coefficient is much smaller
! than its standard error.

WRITE(*, *)
CALL logistic(ncases, x, 8, s, n, chisq, devnce, ndf, beta, se_beta, ier)
IF (ier /= 0) THEN
  WRITE(*, *) 'Error number', ier
ELSE
  WRITE(*, '(a, f9.3, a, f9.3, a, i4, a)')  &
        ' Deviance = ', devnce, '   Chi-squared = ', chisq,   &
        ' with ', ndf, ' deg. of freedom'
  tail_prob = 1.0_dp - chi_squared(ndf, chisq)
  IF (tail_prob < 0.01_dp) THEN
    WRITE(*, *) '*** Significantly bad fit at the 1% level ***'
  END IF
  WRITE(*, '(a, g12.4/)') ' Chi-squared tail prob. = ', tail_prob
  WRITE(*, *) '        Coefficient   Std.error'
  DO i = 0, 8
    WRITE(*, '(" ", a6, "  ", 2g13.5)') vname(i), beta(i), se_beta(i)
  END DO

END IF

! Now drop variable 1 (age)

x(:,1:7) = x(:,2:8)
vname(1:7) = vname(2:8)
WRITE(*, *)
CALL logistic(ncases, x, 7, s, n, chisq, devnce, ndf, beta, se_beta, ier)
IF (ier /= 0) THEN
  WRITE(*, *) 'Error number', ier
ELSE
  WRITE(*, '(a, f9.3, a, f9.3, a, i4, a)')  &
        ' Deviance = ', devnce, '   Chi-squared = ', chisq,   &
        ' with ', ndf, ' deg. of freedom'
  tail_prob = 1.0_dp - chi_squared(ndf, chisq)
  IF (tail_prob < 0.01_dp) THEN
    WRITE(*, *) '*** Significantly bad fit at the 1% level ***'
  END IF
  WRITE(*, '(a, g12.4/)') ' Chi-squared tail prob. = ', tail_prob
  WRITE(*, *) '        Coefficient   Std.error'
  DO i = 0, 7
    WRITE(*, '(" ", a6, "  ", 2g13.5)') vname(i), beta(i), se_beta(i)
  END DO

END IF

STOP
END PROGRAM t_logistic


! ======================================================================
! NAME
!
!     EXPECTATION
!
! DESCRIPTION
!
!     EXPECTATION is a supporting program of GPECN1DTDPBC that computes
!     the expectation values of different physical quantities from its
!     output wave functions.
!
! AUTHOR
!
!     Marty Kandes, Ph.D.
!     Computational & Data Science Research Specialist
!     User Services Group
!     San Diego Supercomputer Center
!     University of California, San Diego
!
! COPYRIGHT
!
!     Copyright (c) 2010 - 2021 Martin Charles Kandes
!
! LICENSE
!
!     The MIT License (MIT)
!
! LAST UPDATED
!
!     Wednesday, April 11th, 2017
!
! ----------------------------------------------------------------------
      PROGRAM EXPECTATION
      IMPLICIT NONE

!     Parameter Declarations:
!     -----------------------
      REAL, PARAMETER :: PI = 3.1415926535897932384626433832795028841971E0

!     Input Variable and Array Declarations:
!     --------------------------------------
      INTEGER :: NUMBER_OF_GRID_POINTS
      INTEGER :: NUMBER_OF_TIME_STEPS
      INTEGER :: NUMBER_OF_TIME_STEPS_BEFORE_WRITE

      REAL :: RADIUS
      REAL :: ROTATION_RATE
      REAL :: GAMMA_FACTOR

      COMPLEX, ALLOCATABLE, DIMENSION(:) :: WAVEFUNCTION
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: EXTERNAL_POTENTIAL
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: NONLINEAR_COUPLING

!     Internal Variable and Array Declarations:
!     -----------------------------------------
      CHARACTER(80) :: BUFFER

      INTEGER :: CURRENT_GRID_POINT
      INTEGER :: CURRENT_TIME_STEP
      INTEGER :: CURRENT_FILE
      INTEGER :: LENGTH
      INTEGER :: INFO

      REAL :: ANGULAR_GRID_SPACING_SIZE
      REAL :: TIME_STEP_SIZE
      REAL :: L2NORM
      REAL :: ENERGY
      REAL :: ANGULAR_MOMENTUM
      REAL :: ANGULAR_POSITION

!     Input Variable Assignment Read from Command-line Arguments:
!     -----------------------------------------------------------
      CALL GET_COMMAND_ARGUMENT(1,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_GRID_POINTS

      CALL GET_COMMAND_ARGUMENT(2,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_TIME_STEPS

      CALL GET_COMMAND_ARGUMENT(3,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_TIME_STEPS_BEFORE_WRITE

      CALL GET_COMMAND_ARGUMENT(4,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) RADIUS

      CALL GET_COMMAND_ARGUMENT(5,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) ROTATION_RATE

      CALL GET_COMMAND_ARGUMENT(6,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) GAMMA_FACTOR

!     Allocate Arrays:
!     ----------------
      ALLOCATE(WAVEFUNCTION(NUMBER_OF_GRID_POINTS))
      ALLOCATE(EXTERNAL_POTENTIAL(NUMBER_OF_GRID_POINTS))
      ALLOCATE(NONLINEAR_COUPLING(NUMBER_OF_GRID_POINTS))

!     Internal Variable Assignment:
!     -----------------------------
      ANGULAR_GRID_SPACING_SIZE = 2.0E0*PI/FLOAT(NUMBER_OF_GRID_POINTS)
      TIME_STEP_SIZE = (RADIUS*ANGULAR_GRID_SPACING_SIZE)**2/(2.0E0*GAMMA_FACTOR)

!     Read Input Arrays from File:
!     ----------------------------
      OPEN(UNIT=999,ACTION='READ',FORM='UNFORMATTED')
      READ(UNIT=999) EXTERNAL_POTENTIAL
      CLOSE(UNIT=999)

      OPEN(UNIT=998,ACTION='READ',FORM='UNFORMATTED')
      READ(UNIT=998) NONLINEAR_COUPLING
      CLOSE(UNIT=998)

!     Initializations:
!     ----------------
      CURRENT_FILE = 1000

!     Main Program Loop:
!     ------------------
      DO CURRENT_TIME_STEP = 1, NUMBER_OF_TIME_STEPS+1, NUMBER_OF_TIME_STEPS_BEFORE_WRITE
         OPEN(UNIT=CURRENT_FILE,ACTION='READ',FORM='UNFORMATTED')
         READ(UNIT=CURRENT_FILE) WAVEFUNCTION
         CLOSE(UNIT=CURRENT_FILE)
         L2NORM = 0.0E0
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            L2NORM = L2NORM+ABS(WAVEFUNCTION(CURRENT_GRID_POINT))**2
         ENDDO
         L2NORM = L2NORM*RADIUS*ANGULAR_GRID_SPACING_SIZE
         ENERGY = 0.0E0
         ENERGY = ENERGY+REAL(CONJG(WAVEFUNCTION(1))*(WAVEFUNCTION(2)-CMPLX(2.0E0,0.0E0)*WAVEFUNCTION(1)+WAVEFUNCTION(NUMBER_OF_GRID_POINTS)))
         DO CURRENT_GRID_POINT = 2, NUMBER_OF_GRID_POINTS-1
            ENERGY = ENERGY+REAL(CONJG(WAVEFUNCTION(CURRENT_GRID_POINT))*(WAVEFUNCTION(CURRENT_GRID_POINT+1)-CMPLX(2.0E0,0.0E0)*WAVEFUNCTION(CURRENT_GRID_POINT)+WAVEFUNCTION(CURRENT_GRID_POINT-1)))
         ENDDO
         ENERGY = ENERGY+REAL(CONJG(WAVEFUNCTION(NUMBER_OF_GRID_POINTS))*(WAVEFUNCTION(1)-CMPLX(2.0E0,0.0E0)*WAVEFUNCTION(NUMBER_OF_GRID_POINTS)+WAVEFUNCTION(NUMBER_OF_GRID_POINTS-1)))
         ENERGY = -0.5E0*ENERGY/(RADIUS**2*ANGULAR_GRID_SPACING_SIZE**2)
         ENERGY = ENERGY+REAL(CMPLX(0.0E0,0.5E0*ROTATION_RATE/ANGULAR_GRID_SPACING_SIZE)*CONJG(WAVEFUNCTION(1))*(WAVEFUNCTION(2)-WAVEFUNCTION(NUMBER_OF_GRID_POINTS)))
         DO CURRENT_GRID_POINT = 2, NUMBER_OF_GRID_POINTS-1
            ENERGY = ENERGY+REAL(CMPLX(0.0E0,0.5E0*ROTATION_RATE/ANGULAR_GRID_SPACING_SIZE)*CONJG(WAVEFUNCTION(CURRENT_GRID_POINT))*(WAVEFUNCTION(CURRENT_GRID_POINT+1)-WAVEFUNCTION(CURRENT_GRID_POINT-1)))
         ENDDO
         ENERGY = ENERGY+REAL(CMPLX(0.0E0,0.5E0*ROTATION_RATE/ANGULAR_GRID_SPACING_SIZE)*CONJG(WAVEFUNCTION(NUMBER_OF_GRID_POINTS))*(WAVEFUNCTION(1)-WAVEFUNCTION(NUMBER_OF_GRID_POINTS-1)))
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            ENERGY = ENERGY+REAL(CONJG(WAVEFUNCTION(CURRENT_GRID_POINT))*EXTERNAL_POTENTIAL(CURRENT_GRID_POINT)*WAVEFUNCTION(CURRENT_GRID_POINT))
         ENDDO
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            ENERGY = ENERGY+REAL(CONJG(WAVEFUNCTION(CURRENT_GRID_POINT))*CONJG(WAVEFUNCTION(CURRENT_GRID_POINT))*CMPLX(0.5E0,0.0E0)*NONLINEAR_COUPLING(CURRENT_GRID_POINT)*WAVEFUNCTION(CURRENT_GRID_POINT)*WAVEFUNCTION(CURRENT_GRID_POINT))
         ENDDO
         ENERGY = ENERGY*RADIUS*ANGULAR_GRID_SPACING_SIZE
         ANGULAR_MOMENTUM = 0.0E0
         ANGULAR_MOMENTUM = ANGULAR_MOMENTUM+REAL(CONJG(WAVEFUNCTION(1))*CMPLX(0.0E0,-0.5E0/ANGULAR_GRID_SPACING_SIZE)*(WAVEFUNCTION(2)-WAVEFUNCTION(NUMBER_OF_GRID_POINTS)))
         DO CURRENT_GRID_POINT = 2, NUMBER_OF_GRID_POINTS-1
            ANGULAR_MOMENTUM = ANGULAR_MOMENTUM+REAL(CONJG(WAVEFUNCTION(CURRENT_GRID_POINT))*CMPLX(0.0E0,-0.5E0/ANGULAR_GRID_SPACING_SIZE)*(WAVEFUNCTION(CURRENT_GRID_POINT+1)-WAVEFUNCTION(CURRENT_GRID_POINT-1)))
         ENDDO
         ANGULAR_MOMENTUM = ANGULAR_MOMENTUM+REAL(CONJG(WAVEFUNCTION(NUMBER_OF_GRID_POINTS))*CMPLX(0.0E0,-0.5E0/ANGULAR_GRID_SPACING_SIZE)*(WAVEFUNCTION(1)-WAVEFUNCTION(NUMBER_OF_GRID_POINTS-1)))
         ANGULAR_MOMENTUM = ANGULAR_MOMENTUM*RADIUS*ANGULAR_GRID_SPACING_SIZE
         ANGULAR_POSITION = 0.0E0
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            ANGULAR_POSITION = ANGULAR_POSITION+REAL(CONJG(WAVEFUNCTION(CURRENT_GRID_POINT))*CMPLX(FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE,0.0E0)*WAVEFUNCTION(CURRENT_GRID_POINT))
         ENDDO
         ANGULAR_POSITION = ANGULAR_POSITION*RADIUS*ANGULAR_GRID_SPACING_SIZE
         WRITE(6,900) FLOAT(CURRENT_TIME_STEP-1)*TIME_STEP_SIZE, L2NORM, ENERGY, ANGULAR_MOMENTUM, ANGULAR_POSITION
         CURRENT_FILE = CURRENT_FILE + 1
      ENDDO

!     Format Statements:
!     ------------------
900   FORMAT(1X,5(F23.15))

!     Deallocate Arrays:
!     ------------------
      DEALLOCATE(WAVEFUNCTION)
      DEALLOCATE(EXTERNAL_POTENTIAL)
      DEALLOCATE(NONLINEAR_COUPLING)

      STOP
      ENDPROGRAM EXPECTATION


SUBROUTINE DKOGUL(F, G, H, TOL, C1, S1, C2, S2, F1, H1)
  IMPLICIT NONE

  DOUBLE PRECISION, INTENT(IN) :: F, G, H, TOL
  DOUBLE PRECISION, INTENT(OUT) :: C1, S1, C2, S2, F1, H1

  DOUBLE PRECISION :: D, E, ZETA, MU, MU2, RHO, RHO2, ALPHA, T1, T2, X, Q

  IF (ABS(G) .GT. F) THEN
     ! D = G + ((F + H) / G) * (F - H)
     D = C_FMA((F + H) / G, F - H, G)
     E = TWO * H
  ELSE
     D = (F - H) / G + G / (F + H)
     E = TWO * H / (F + H)
  END IF

  IF (ABS(D) .LE. E) THEN
     ZETA = D / E
     ! MU = ONE + ZETA * ZETA
     MU = C_FMA(ZETA, ZETA, ONE)
     RHO = SQRT(MU)
     ALPHA = ONE + ABS(ZETA) / RHO
     C1 = SQRT(HALF * ALPHA)
     S1 = SIGN(ONE / SQRT(TWO * ALPHA * MU), ZETA)
     T1 = SIGN(ONE / (ABS(ZETA) + RHO), ZETA)
  ELSE
     IF (ABS(D) * TOL .GT. E) THEN
        C1 = ONE
        T1 = (HALF * E) / D
        S1 = T1
        ZETA = ZERO
        ALPHA = TWO
     ELSE
        ZETA = E / D
        ! MU = ONE + ZETA * ZETA
        MU = C_FMA(ZETA, ZETA, ONE)
        RHO = SQRT(MU)
        ALPHA = ONE + ONE / RHO
        C1 = SQRT(HALF * ALPHA)
        S1 = ZETA / SQRT(TWO * ALPHA * MU)
        T1 = ZETA / (ONE + RHO)
     END IF
  END IF

  ! X = H * T1 + G
  X = C_FMA(H, T1, G)
  IF (ABS(X) .LE. F) THEN
     T2 = X / F
     ! MU2 = ONE + T2 * T2
     MU2 = C_FMA(T2, T2, ONE)
     RHO2 = SQRT(MU2)
     C2 = ONE / RHO2
     S2 = T2 / RHO2
     Q = SQRT(HALF * ALPHA * MU2)
  ELSE
     T2 = F / X
     ! MU2 = ONE + T2 * T2
     MU2 = C_FMA(T2, T2, ONE)
     RHO2 = SQRT(MU2)
     S2 = SIGN(ONE / RHO2, T2)
     C2 = ABS(T2) / RHO2
     Q = SQRT(HALF * ALPHA * MU2) / ABS(T2)
  END IF

  F1 = F * Q
  H1 = H / Q
END SUBROUTINE DKOGUL


! UM specific variable calculation module to interface with python
module variable

    implicit none

    real, parameter :: g=9.81, pi=3.14159, a=6378100

    contains

        subroutine calc_pv(u, v, theta, rho, r_theta, r_rho, r_u, r_v, sec_v_lat, tan_v_lat, sec_theta_lat, f3, &
                delta_lambda, delta_phi, nx, ny, nz, pv)
            !f2py integer, intent(hide) :: nx, ny, nz
            !f2py real, intent(in) :: u(nz, ny, nx)
            !f2py real, intent(in) :: v(nz, ny-1, nx)
            !f2py real, intent(in) :: theta(nz, ny, nx)
            !f2py real, intent(in) :: rho(nz, ny, nx)
            !f2py real, intent(in) :: r_theta(nz, ny, nx)
            !f2py real, intent(in) :: r_rho(nz, ny, nx)
            !f2py real, intent(in) :: r_u(nz, ny, nx)
            !f2py real, intent(in) :: r_v(nz, ny-1, nx)
            !f2py real, intent(in) :: sec_v_lat(ny-1, nx)
            !f2py real, intent(in) :: tan_v_lat(ny-1, nx)
            !f2py real, intent(in) :: sec_theta_lat(ny, nx)
            !f2py real, intent(in) :: f3(ny, nx)
            !f2py real, intent(in) :: delta_lambda, delta_phi
            !f2py real, intent(out) :: pv(nz, ny, nx)

            !-Input variables-
            ! Grid dimensions (ny-1 for v points having extra outer gridpoint)
            integer, intent(in) :: nx, ny, nz

            ! Wind field on staggered grid points
            real, intent(in) :: u(nz, ny, nx), v(nz, ny-1, nx)

            ! Potential temperature
            real, intent(in) :: theta(nz, ny, nx)

            ! Prognostic density (density * r^2)
            real, intent(in) :: rho(nz, ny, nx)

            ! Radius (a + z) at different grid points
            real, intent(in) :: r_theta(nz+1, ny, nx), r_rho(nz, ny, nx),                &
            r_u(nz, ny, nx), r_v(nz, ny-1, nx)

            ! Trigonometric functions at different grid points
            real, intent(in) :: sec_v_lat(ny-1, nx), tan_v_lat(ny-1, nx),                &
            sec_theta_lat(ny,nx)

            ! Vertical coriolis parameter at v-points
            real, intent(in) :: f3(ny, nx)

            ! Grid spacing
            real, intent(in) :: delta_lambda, delta_phi

            ! Potential Vorticity (output)
            real, intent(out) :: pv(nz, ny, nx)

            !-Local variables-
            integer :: i,j,k

            real :: recip_delta_lambda, recip_delta_phi, weight1(ny,nx), weight2(ny,nx)

            real :: r_pv(nz,ny,nx), r_pv_theta(nz,ny,nx)
            real :: dtheta_dr(ny,nx), du_dr(ny,nx) , dv_dr(ny,nx)
            real :: dtheta_dx(ny,nx), dtheta_dx_ave(nz,ny,nx)
            real :: du_dr_ave(ny,nx), dv_dr_ave(ny,nx)
            real :: dtheta_dy(ny,nx), dtheta_dy_ave(nz,ny,nx), dtheta_dr_ave(ny,nx)
            real :: x_term(ny,nx), y_term(ny,nx), z_term(ny,nx)
            real :: density(ny,nx), density_ave(ny,nx)

            !-START-
            ! Section 0. Initialisation
            recip_delta_lambda = 1.0/ delta_lambda
            recip_delta_phi = 1.0/ delta_phi

            ! Section 1. Calculate horizontal part of terms
            do k=1,nz
            ! calculate dtheta/dx and dtheta/dy
            dtheta_dx = d_dx(theta(k,:,:), recip_delta_lambda, sec_theta_lat, r_theta(k,:,:), ny, nx)
            dtheta_dx_ave(k, :, :) = average_y(dtheta_dx, ny, nx)

            dtheta_dy = d_dy(theta(k,:,:), recip_delta_phi, r_theta(k,:,:), ny, nx)
            dtheta_dy_ave(k, :, :) = average_x(dtheta_dy, ny, nx)

            ! Calculate altitude on theta levels
            r_pv(k,1:ny-1,:) = 0.5 * (r_u(k,2:ny,:) + r_u(k,1:ny-1,:))
            r_pv_theta(k,1:ny-1,:) = centre(r_theta(k,:,:), ny, nx)

            ! end loop over levels
            end do

            ! loop over model levels for rest of code.
            do k=1,nz
                ! Section 1.1 Calculate x_term and y_term.
                if (k == 1) then
                    x_term(:,:) = -dtheta_dx_ave(k,:,:)
                    y_term(:,:) = dtheta_dy_ave(k,:,:)

                else
                    weight1 = (r_pv_theta(k,:,:) - r_pv(k,:,:) ) / (r_pv_theta(k,:,:) - r_pv_theta(k-1,:,:))
                    weight2 = 1.0 - weight1

                    x_term = -(weight2 * dtheta_dx_ave(k-1,:,:) + weight1 * dtheta_dx_ave(k,:,:))
                    y_term = (weight2 * dtheta_dy_ave(k-1,:,:) + weight1 * dtheta_dy_ave(k,:,:))
                end if

                ! Section 1.2 Calculate z_term.
                do j=1,ny-1
                    do i=1,nx-1
                        z_term(j,i) = f3(j,i) + ((v(k,j,i+1)-v(k,j,i)) * recip_delta_lambda * sec_v_lat(j,i) + &
                                0.5 * (u(k,j+1,i) + u(k,j,i)) * tan_v_lat(j,i) - &
                                (u(k,j+1,i) - u(k,j,i)) * recip_delta_phi) / r_pv(k,j,i)
                    end do
                end do

                ! Section 2. Multiply horizontal terms by vertical terms and form full pv.
                if (k==1) then
                    ! Since theta gradient is un-defined use gradient from levels above.
                    dtheta_dr = (theta(k+1,:,:) - theta(k,:,:)) / (r_theta(k+1,:,:) - r_theta(k,:,:))
                else if (k/=2) then
                    ! no code required at level 2 since the value is the same as level 1.
                    ! calculate theta gradient.
                    dtheta_dr = (theta(k,:,:) - theta(k-1,:,:)) / (r_theta(k,:,:) - r_theta(k-1,:,:))
                end if
                ! Now average to required location.
                dtheta_dr_ave = centre(dtheta_dr, ny, nx)

                if (k==1) then
                    dv_dr(1:ny-1,:) = (v(k+1,:,:) - v(k,:,:)) / (r_v(k+1,:,:) - r_v(k,:,:))
                    du_dr = (u(k+1,:,:) - u(k,:,:)) / (r_u(k+1,:,:) - r_u(k,:,:))
                else if (k==nz) then
                    dv_dr(1:ny-1,:) = (v(k,:,:) - v(k-1,:,:)) / (r_v(k,:,:) - r_v(k-1,:,:))
                    du_dr = (u(k,:,:) - u(k-1,:,:)) / (r_u(k,:,:) - r_u(k-1,:,:))
                else
                    dv_dr(1:ny-1,:) = (v(k+1,:,:) - v(k-1,:,:)) / (r_v(k+1,:,:) - r_v(k-1,:,:))
                    du_dr = (u(k+1,:,:) - u(k-1,:,:)) / (r_u(k+1,:,:) - r_u(k-1,:,:))
                end if

                ! now average quantities
                du_dr_ave = average_y(du_dr, ny, nx)
                dv_dr_ave = average_x(dv_dr, ny, nx)

                ! convert rho to true density by removing factor of r squared.
                density = rho(k,:,:) / (r_rho(k,:,:) * r_rho(k,:,:))

                density_ave = centre(density, ny, nx)

                ! Calculate full PV.
                pv(k,:,:) = (x_term * dv_dr_ave + y_term * du_dr_ave + z_term * dtheta_dr_ave) / density_ave

                ! end loop over model levels
            end do
        end subroutine calc_PV

        subroutine hydrostatic_mass(P_surf, dlambda, phi, sigh, nx, ny, nz, mass)
            !f2py integer, intent(hide) :: nx, ny, nz
            !f2py real, intent(in) :: P_surf(ny, nx)
            !f2py real, intent(in) :: dlambda
            !f2py real, intent(in) :: phi(ny)
            !f2py real, intent(in) :: sigh(0:nz)
            !f2py real, intent(out) :: mass(nz, ny, nx)

            !-Input variables-
            ! Grid dimensions
            integer, intent(in) :: nx, ny, nz

            ! Surface pressure
            real, intent(in) :: P_surf(ny, nx)

            ! Longitude spacing (radians)
            real, intent(in) :: dlambda

            ! Latitude (radians)
            real, intent(in) :: phi(ny)

            ! Half sigma levels
            real, intent(in) :: sigh(0:nz)

            ! Mass in each gridbox
            real, intent(out) :: mass(nz, ny, nx)

            !-Local variables-
            integer :: i, j, k
            real :: dphi(ny)
            real :: rho_dz

            !-START-
            ! Calculate latitude spacing
            dphi(1) = (phi(2) + pi / 2.0) / 2.0
            do j = 2, ny - 1
                dphi(j) = (phi(j+1) - phi(j-1)) / 2.0
            end do
            dphi(ny) = (pi/2.0 - phi(ny-1)) / 2.0

            do k = 1, nz
                do j = 1, ny
                    do i = 1, nx
                        rho_dz = (sigh(k-1) - sigh(k)) * P_surf(j, i) / g
                        mass(k,j,i) = rho_dz * a**2 * cos(phi(j)) * dlambda * dphi(j)
                    end do
                end do
            end do
        end subroutine hydrostatic_mass

        ! da/dx = da/d(lambda) * (1/(r*cos(phi)))
        pure function d_dx(a, recip_dlambda, sec_lat, r, ny, nx)
            !-Input Variables-
            integer, intent(in) :: ny, nx
            ! Variable to differentiate
            real, intent(in) :: a(ny,nx)
            ! Grid spacing
            real, intent(in) :: recip_dlambda
            ! Grid spacing factor with latitude
            real, intent(in) :: sec_lat(ny,nx)
            ! Radius at grid points
            real, intent(in) :: r(ny,nx)

            !-Output Variables-
            real :: d_dx(ny, nx)

            !-START-
            d_dx(:, 1:nx-1) = (a(:, 2:nx) - a(:, 1:nx-1)) * recip_dlambda * sec_lat(:, 1:nx-1) * 2.0 / &
                    (r(:, 2:nx) + r(:, 1:nx-1))
        end function d_dx

        ! da/dy = da/d(phi) * (1/r)
        pure function d_dy(a, recip_dphi, r, ny, nx)
            !-Input Variables-
            integer, intent(in) :: ny, nx
            ! Variable to differentiate
            real, intent(in) :: a(ny,nx)
            ! Grid spacing
            real, intent(in) :: recip_dphi
            ! Radius at grid points
            real, intent(in) :: r(ny,nx)

            !-Output Variables-
            real :: d_dy(ny, nx)

            !-START-
            d_dy(1:ny-1, :) = (a(2:ny, :) - a(1:ny-1, :)) * recip_dphi * 2.0 / (r(2:ny, :) + r(1:ny-1, :))

        end function d_dy

        pure function average_x(a, ny, nx)
            !-Input Variables-
            integer, intent(in) :: ny, nx
            ! Variable to average
            real, intent(in) :: a(ny,nx)

            !-Output Variables-
            real :: average_x(ny, nx)

            !-START-
            average_x(:, 1:nx-1) = 0.5*(a(:, 2:nx) - a(:, 1:nx-1))

        end function average_x

        pure function average_y(a, ny, nx)
            !-Input Variables-
            integer, intent(in) :: ny, nx
            ! Variable to average
            real, intent(in) :: a(ny,nx)

            !-Output Variables-
            real :: average_y(ny, nx)

            !-START-
            average_y(1:ny-1, :) = 0.5*(a(2:ny, :) - a(1:ny-1, :))

        end function average_y

        pure function centre(x, ny, nx)
            ! Calculate values at the centre of grid boxes

            !-Input Variables-
            integer, intent(in) :: ny, nx
            ! Variable to differentiate
            real, intent(in) :: x(ny, nx)

            !-Output Variables-
            real :: centre(ny, nx)

            !-START-
            centre(1:ny-1, 1:nx-1) = 0.25 * (x(1:ny-1, 1:nx-1) + x(2:ny, 1:nx-1) + x(1:ny-1, 2:nx) + x(2:ny,2:nx))
        end function centre
end module variable


subroutine getiota(phipog, guu, guv, wint, lu, lv)

      use stel_kinds, only: dp
      use name0, only: czero
      use name1, only: nznt
      use scalars, only: ns
      use inputdat, only: ncurr
      use current, only: jv
      use profs, only: iotas

      implicit none

      real(kind=dp), intent(in)    :: phipog(ns, nznt)
      real(kind=dp), intent(in)    :: guu   (ns, nznt)
      real(kind=dp), intent(in)    :: guv   (ns, nznt)
      real(kind=dp), intent(in)    :: wint  (ns, nznt)
      real(kind=dp), intent(in)    :: lu    (ns, nznt)
      real(kind=dp), intent(inout) :: lv    (ns, nznt)

      integer       :: js, lk
      real(kind=dp) :: top, bot

      if (ncurr.ne.0) then

        ! zero-current algorithm from Hirshman & Hogan (1986) "ORMEC", Sec. 2.3

        do js = 2, ns

          top = jv(js) ! user-specified profile of enclosed toroidal current
          bot = czero

          do lk = 1, nznt
            top = top - wint(js,lk)*( guu(js,lk)*lv(js,lk) + guv(js,lk)*lu(js,lk) )
            bot = bot + wint(js,lk)*  guu(js,lk)*phipog(js,lk)
          end do

          iotas(js) = top/bot

        end do
      end if

      ! ADD IOTA TO LAMBDA (ON HALF MESH NOW)
      do js = 2, ns
        do lk = 1, nznt
          lv(js,lk) = lv(js,lk) + phipog(js,lk)*iotas(js)
        end do
      end do

      return
end


!###########################################################
!###########################################################
!###########################################################
SUBROUTINE get_rt_courant_coarse(dt)

! Determine the coarse RT timestep length set by the Courant condition
!-------------------------------------------------------------------------
  use amr_parameters
  use rt_parameters
  implicit none
  integer:: nx_loc
  real(dp):: dt, scale, dx
!-------------------------------------------------------------------------
  ! Mesh spacing at coarse level
  nx_loc=icoarse_max-icoarse_min+1
  scale=boxlen/dble(nx_loc)
  dx=0.5D0**levelmin*scale
  dt = rt_courant_factor*dx/3.d0/rt_c
END SUBROUTINE get_rt_courant_coarse
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine rt_hydro_refine(ug,um,ud,ok,nn)
  use amr_parameters
  use const
  use rt_parameters
  implicit none
  ! dummy arguments
  integer nn
  real(dp)::ug(1:nvector,1:nrtvar)
  real(dp)::um(1:nvector,1:nrtvar)
  real(dp)::ud(1:nvector,1:nrtvar)
  logical ::ok(1:nvector)

  integer::k,i
  real(dp)::dg,dm,dd,pg,pm,pd,vg,vm,vd,cg,cm,cd,error

  if(rt .and. rt_err_grad_n >= 0.) then !---------------------------------
     do i=1,nGroups
        ! RT-photon density
        do k=1,nn
           dg=ug(k,iGroups(i)); dm=um(k,iGroups(i)); dd=ud(k,iGroups(i))
           error=2.0d0*MAX( &
                & ABS((dd-dm)/(dd+dm+rt_floor_n)) , &
                & ABS((dm-dg)/(dm+dg+rt_floor_n)) )
           ok(k) = ok(k) .or. error > rt_err_grad_n
        end do
     end do
  end if

end subroutine rt_hydro_refine
!###########################################################
!###########################################################
!###########################################################
!###########################################################


	real*8 T1950,J2000,OBLIQ1950,pi,c,cinv,k,r_e_km,r_s_km,r_m_km
        real*8 emrat,km_per_au,dpr,rpd

        parameter (T1950 = 2433282.423357D0,
     1             J2000 = 2451545.0D0,
     1  	   OBLIQ1950 = 23.44578787D0,
     1	           pi = 3.1415926535897932d0,
     1	           c  = 173.1446327d0,
     1	           cinv = 1.d0/173.1446327d0,
     1	           k  = .01720209895d0,
     1             r_e_km = 6378.137d0,
     1             r_s_km = 696000d0,
     1             r_m_km = 1738d0,
     1             emrat = 81.30058827d0,
     1             km_per_au = 149597870.66d0,
     1             dpr = 180d0/pi,
     1             rpd = pi/180d0)

        real*8 zx,zy,zz

!       Saturn's Rings
        parameter (zx = -.0912836831D0)
        parameter (zy = -.0724471759D0)
        parameter (zz = -.9931861335D0)


: NEXT-FIBONACCI ( limit n1 n2 -- limit n2 n1+n2 )
    SWAP    ( limit n2 n1 )
    DUP     ( limit n2 n1 n1 )
    .       ( limit n2 n1 )
    OVER    ( limit n2 n1 n2 )
    +       ( limit n2 n1+n2 )
    DUP     ( limit n2 n1+n2 n1+n2 )
    3 PICK  ( limit n2 n1+n2 n1+n2 limit )
    < IF    ( limit n2 n1+n2 )
        RECURSE
    THEN
    EXIT    ( limit n2 n1+n2 )
;

: FIBONACCI ( limit -- )
    1 1                     ( limit 1 1 )
    NEXT-FIBONACCI          ( limit x y )
    DROP DROP DROP
    CR
;

1134903171 FIBONACCI


	FUNCTION PR_RELI  ( tmpc, dwpc )
C************************************************************************
C* PR_RELI								*
C*									*
C* This function computes RELI from TMPC and DWPC.  The following	*
C* equation is used:							*
C*									*
C*               RELI  =  VAPR / VAPSi * 100				*
C*									*
C*                     VAPR = vapor pressure				*
C*                          = PR_VAPR ( DWPC )				*
C*                    VAPSi = saturation vapor pressure wrt ice		*
C*                          = PR_VAPI ( TMPC )				*
C*									*
C* REAL PR_RELI  ( TMPC, DWPC )						*
C*									*
C* Input parameters:							*
C*	TMPC		REAL		Temperature in Celsius		*
C*	DWPC		REAL    	Dewpoint in Celsius		*
C*									*
C* Output parameters:							*
C*	PR_RELI		REAL		Relative humidity wrt ice (%)	*
C**									*
C* Log:									*
C* S. Chiswell/Unidata	1/07						*
C************************************************************************
        INCLUDE    'GEMPRM.PRM'
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( tmpc ) .or. ERMISS ( dwpc ) )  THEN
	    PR_RELI = RMISSD
	  ELSE
C
C*	    Find the vapor pressure .
C
	    e = PR_VAPR ( dwpc )
C
C*	    Find the saturated vapor pressure with respect to ice.
C
	    esi = PR_VAPI ( tmpc )
C
C*	    Calculate relative humidity with respect to ice
C
	    PR_RELI = ( e / esi ) * 100.
	END IF
C*
	RETURN
	END


    Program zuncsd_example

!     ZUNCSD 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 blas_interfaces, Only: zgemm
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp, &
        nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: zuncsd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Complex (Kind=dp), Parameter :: one = (1.0_dp, 0.0_dp)
      Complex (Kind=dp), Parameter :: zero = (0.0_dp, 0.0_dp)
      Integer, Parameter :: nin = 5, nout = 6, recombine = 1, reprint = 1
!     .. Local Scalars ..
      Integer :: i, ifail, info, info2, j, ldu, ldu1, ldu2, ldv, ldv1t, ldv2t, &
        ldx, ldx11, ldx12, ldx21, ldx22, lrwork, lwork, m, n11, n12, n21, n22, &
        p, q, r
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: u(:, :), u1(:, :), u2(:, :), v(:, :), &
        v1t(:, :), v2t(:, :), w(:, :), work(:), x(:, :), x11(:, :), x12(:, :), &
        x21(:, :), x22(:, :)
      Complex (Kind=dp) :: wdum(1)
      Real (Kind=dp) :: rwdum(1)
      Real (Kind=dp), Allocatable :: rwork(:), theta(:)
      Integer, Allocatable :: iwork(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: cmplx, cos, min, nint, real, sin
!     .. Executable Statements ..
      Write (nout, *) 'ZUNCSD Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, p, q

      r = min(min(p,q), min(m-p,m-q))

      ldx = m
      ldx11 = p
      ldx12 = p
      ldx21 = m - p
      ldx22 = m - p
      ldu = m
      ldu1 = p
      ldu2 = m - p
      ldv = m
      ldv1t = q
      ldv2t = m - q
      Allocate (x(ldx,m), u(ldu,m), v(ldv,m), theta(r), iwork(m), w(ldx,m))
      Allocate (x11(ldx11,q), x12(ldx12,m-q), x21(ldx21,q), x22(ldx22,m-q))
      Allocate (u1(ldu1,p), u2(ldu2,m-p), v1t(ldv1t,q), v2t(ldv2t,m-q))

!     Read (by column) and print unitary X from data file
!      (as, say, generated by a generalized singular value decomposition).

      Do i = 1, m
        Read (nin, *) x(1:m, i)
      End Do

!     Print general complex matrix using matrix printing routine nagf_file_print_matrix_complex_gen_comp.
!     ifail: behaviour on error exit
!            =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', 'N', m, m, x, &
        ldx, 'Bracketed', 'F7.4', '    Unitary matrix X', 'Integer', rlabs, &
        'Integer', clabs, 80, 0, ifail)
      Write (nout, *)

!     Compute the complete CS factorization of X:
!        X11 is stored in X(1:p,   1:q), X12 is stored in X(1:p,   q+1:m)
!        X21 is stored in X(p+1:m, 1:q), X22 is stored in X(p+1:m, q+1:m)
!        U1  is stored in U(1:p,   1:p), U2  is stored in U(p+1:m, p+1:m)
!        V1  is stored in V(1:q,   1:q), V2  is stored in V(q+1:m, q+1:m)
      x11(1:p, 1:q) = x(1:p, 1:q)
      x12(1:p, 1:m-q) = x(1:p, q+1:m)
      x21(1:m-p, 1:q) = x(p+1:m, 1:q)
      x22(1:m-p, 1:m-q) = x(p+1:m, q+1:m)

!     Workspace query first to get length of work array for complete CS
!     factorization routine zuncsd.
      lwork = -1
      lrwork = -1
      Call zuncsd('Yes U1', 'Yes U2', 'Yes V1T', 'Yes V2T', 'Column', &
        'Default', m, p, q, x, ldx, x(1,q+1), ldx, x(p+1,1), ldx, x(p+1,q+1), &
        ldx, theta, u, ldu, u(p+1,p+1), ldu, v, ldv, v(q+1,q+1), ldv, wdum, &
        lwork, rwdum, lrwork, iwork, info)
      lwork = nint(real(wdum(1)))
      lrwork = nint(rwdum(1))
      Allocate (work(lwork), rwork(lrwork))
!     Initialize all of  u, v to zero.
      u(1:m, 1:m) = zero
      v(1:m, 1:m) = zero

!     This is how you might pass partitions as sub-matrices
      Call zuncsd('Yes U1', 'Yes U2', 'Yes V1T', 'Yes V2T', 'Column', &
        'Default', m, p, q, x, ldx, x(1,q+1), ldx, x(p+1,1), ldx, x(p+1,q+1), &
        ldx, theta, u, ldu, u(p+1,p+1), ldu, v, ldv, v(q+1,q+1), ldv, work, &
        lwork, rwork, lrwork, iwork, info)
      If (info/=0) Then
        Write (nout, 110) 'Failure in ZUNCSD. info =', info
        Go To 100
      End If

!     Print Theta using real matrix printing routine nagf_file_print_matrix_real_gen
!     Note: U1, U2, V1T, V2T not printed since these may differ by a sign
!     change in columns of U1, U2 and corresponding rows of V1T, V2T.
      Write (nout, 120) 'Theta Component of CS factorization of X:'
      Flush (nout)
      ifail = 0
      Call nagf_file_print_matrix_real_gen('G', 'N', r, 1, theta, r, &
        '    Theta', ifail)
      Write (nout, *)
      Flush (nout)

!     And this is how you might pass partitions as separate matrices.
      Call zuncsd('Yes U1', 'Yes U2', 'Yes V1T', 'Yes V2T', 'Column', &
        'Default', m, p, q, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, &
        theta, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, work, lwork, rwork, &
        lrwork, iwork, info2)
      If (info/=0) Then
        Write (nout, 110) 'Failure in ZUNCSD. info =', info
        Go To 100
      End If

!     Reprint Theta using matrix printing routine nagf_file_print_matrix_real_gen.
      If (reprint/=0) Then
        Write (nout, 120) 'Components of CS factorization of X:'
        Flush (nout)
        ifail = 0
        Call nagf_file_print_matrix_real_gen('G', 'N', r, 1, theta, r, &
          '    Theta', ifail)
        Write (nout, *)
        Flush (nout)
      End If

      If (recombine/=0) Then
!       Recombining should return the original matrix
!       Assemble Sigma_p into X
        x(1:m, 1:m) = zero
        n11 = min(p, q) - r
        n12 = min(p, m-q) - r
        n21 = min(m-p, q) - r
        n22 = min(m-p, m-q) - r
!       Top Half
        Do j = 1, n11
          x(j, j) = one
        End Do
        Do j = 1, r
          x(j+n11, j+n11) = cmplx(cos(theta(j)), 0.0_dp, kind=dp)
          x(j+n11, j+n11+r+n21+n22) = cmplx(-sin(theta(j)), 0.0_dp, kind=dp)
        End Do
        Do j = 1, n12
          x(j+n11+r, j+n11+r+n21+n22+r) = -one
        End Do
!       Bottom half
        Do j = 1, n22
          x(p+j, q+j) = one
        End Do
        Do j = 1, r
          x(p+n22+j, j+n11) = cmplx(sin(theta(j)), 0.0_dp, kind=dp)
          x(p+n22+j, j+r+n21+n22) = cmplx(cos(theta(j)), 0.0_dp, kind=dp)
        End Do
        Do j = 1, n21
          x(p+n22+r+j, n11+r+j) = one
        End Do
!       multiply U * Sigma_p into w
        Call zgemm('n', 'n', m, m, m, one, u, ldu, x, ldx, zero, w, ldx)
!       form U * Sigma_p * V^T into u
        Call zgemm('n', 'n', m, m, m, one, w, ldx, v, ldv, zero, u, ldu)

!       Print recombined matrix using complex matrix printing routine nagf_file_print_matrix_complex_gen_comp.
        Write (nout, *)
        Flush (nout)
        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', 'N', m, m, u, &
          ldu, 'Bracketed', 'F7.4', &
          '    Recombined matrix X = U * Sigma_p * V^H', 'Integer', rlabs, &
          'Integer', clabs, 80, 0, ifail)
      End If
100   Continue

110   Format (1X, A, I4)
120   Format (/, 1X, A, /)
    End Program


c
c     1/976
c
c     a subroutine for testing all vector laplacian and its inverse
c
c     (1) first set the vector function (rotation about equator) using
c         v = cos(phi) and w = -cos(theta)*sin(phi)
c
c     (2) set vector laplacian ananlytically
c         vlap = -2.*cos(phi)=-2.*v, wlap = -2.*w
c         (i.e., L(v,w) = -2.*(v,w) so (v,w) is an eigenfunction for the
c         vector Laplacian with eigenvalue -2.
c
c     (3) compute the coefficients br,bi,cr,ci of (v,w) using vector analysis
c
c     (3) compute the vector laplacian of (v,w) using vlapec,vlapes,vlapgc,vlapgs
c
c     (4) compare (3) with (2)
c
c     (5) invert (4) and compare with (v,w)
c
      program tvlap
c
c     set dimensions with parameter statements
c
      parameter(nnlat=29 ,nnlon= 16, nnt = 1)
      parameter (mmdbc = (nnlon+2)/2)
      parameter (lleng= 5*nnlat*nnlat*nnlon,llsav=15*nnlat*nnlat*nnlon)
      parameter (lldwork = 4*nnlat*nnlat )
      double precision dwork(lldwork)
      dimension work(lleng),wsave(llsav)
      dimension br(mmdbc,nnlat,nnt),bi(mmdbc,nnlat,nnt)
      dimension cr(mmdbc,nnlat,nnt),ci(mmdbc,nnlat,nnt)
      dimension thetag(nnlat),dtheta(nnlat),dwts(nnlat)
      dimension v(nnlat,nnlon,nnt),w(nnlat,nnlon,nnt)
      dimension vlap(nnlat,nnlon,nnt),wlap(nnlat,nnlon,nnt)

      double precision dtheta, dwts
c
c     set dimension variables
c
      nlat = nnlat
      nlon = nnlon
      nmax = max0(nlat,nlon)
      mdbc = mmdbc

      lwork = lleng
      lsave = llsav
      nt = nnt
      call iout(nlat,4hnlat)
      call iout(nlon,4hnlon)
      call iout(nt,4h  nt)
      isym = 0
      ityp = 0
c
c     set equally spaced colatitude and longitude increments
c
      pi = 4.0*atan(1.0)
      dphi = (pi+pi)/nlon
      dlat = pi/(nlat-1)
c
c     compute nlat gaussian points in thetag
c
      ldwork = lldwork
      call gaqd(nlat,dtheta,dwts,dwork,ldwork,ier)
      do  i=1,nlat
	thetag(i) = dtheta(i)
      end do
      call name(4hgaqd)
      call iout(ier,4h ier)
      call vecout(thetag,4hthtg,nlat)
c
c     test all divergence and inverse divergence subroutines
c
      do icase=1,4
      call name(4h****)
      call name(4h****)
      call iout(icase,4hicas)
c
c     set vector field v,w
c
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    if (k.eq.1) then
	    v(i,j,k) = cosp
	    w(i,j,k) = -cost*sinp
	    vlap(i,j,k) = -2.0*v(i,j,k)
	    wlap(i,j,k) = -2.0*w(i,j,k)
	    end if
	  end do
	end do
      end do

      if (nmax.lt.10) then
      do kk=1,nt
      call iout(kk,4h**kk)
      call aout(v(1,1,kk),4h   v,nlat,nlon)
      call aout(w(1,1,kk),4h   w,nlat,nlon)
      call aout(vlap(1,1,kk),4hvlap,nlat,nlon)
      call aout(wlap(1,1,kk),4hwlap,nlat,nlon)
      end do
      end if

      if (icase.eq.1) then

      call name(4h**ec)
c
c     analyze vector field
c
      call vhaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhaec(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,mdbc,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvha )
      call iout(ierror,4hierr)

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,4h**kk)
c     call aout(br(1,1,kk),4h  br,nlat,nlat)
c     call aout(bi(1,1,kk),4h  bi,nlat,nlat)
c     call aout(cr(1,1,kk),4h  cr,nlat,nlat)
c     call aout(ci(1,1,kk),4h  ci,nlat,nlat)
c     end do
c     end if
c
c     compute vector laplacian
c

      call vhseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hvhsi)
      call iout(ierror,4hierr)

      call vlapec(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvlap )
      call iout(ierror,4hierr)

      else if (icase.eq.2) then

      call name(4h**es)
c
c     analyze vector field
c
      call vhaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhaes(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,cr,ci,mdbc,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvhae)
      call iout(ierror,4hierr)

      call vhsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvhsi)
      call iout(ierror,4hierr)

      call vlapes(nlat,nlon,isym,nt,vlap,wlap,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvlap )
      call iout(ierror,4hierr)

      else if (icase .eq.3 ) then

      call name(4h**gc)
c
c     analyze vector field
c
      call vhagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhagc(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,mdbc,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvha )
      call iout(ierror,4hierr)

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,4h**kk)
c     call aout(br(1,1,kk),4h  br,nlat,nlat)
c     call aout(bi(1,1,kk),4h  bi,nlat,nlat)
c     call aout(cr(1,1,kk),4h  cr,nlat,nlat)
c     call aout(ci(1,1,kk),4h  ci,nlat,nlat)
c     end do
c     end if
c
c     compute vector laplacian
c

      call vhsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hvhsi)
      call iout(ierror,4hierr)

      call vlapgc(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvlap )
      call iout(ierror,4hierr)

      else if (icase .eq. 4) then

      call name(4h**gs)
c
c     analyze vector field
c
      call vhagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhags(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,mdbc,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvha )
      call iout(ierror,4hierr)

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,4h**kk)
c     call aout(br(1,1,kk),4h  br,nlat,nlat)
c     call aout(bi(1,1,kk),4h  bi,nlat,nlat)
c     call aout(cr(1,1,kk),4h  cr,nlat,nlat)
c     call aout(ci(1,1,kk),4h  ci,nlat,nlat)
c     end do
c     end if
c
c     compute vector laplacian
c

      call vhsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvhsi)
      call iout(ierror,4hierr)

      call vlapgs(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvlap )
      call iout(ierror,4hierr)

      end if

      if (nmax.lt.10) then
      do kk=1,nt
      call iout(kk,4h**kk)
      call aout(vlap(1,1,kk),4hvlap,nlat,nlon)
      call aout(wlap(1,1,kk),4hwlap,nlat,nlon)
      end do
      end if
c
c     compute "error" in vlap,wlap
c
      err2v = 0.0
      err2w =0.0
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	    if (k.eq.1) then
	      err2v = err2v+(vlap(i,j,k)+2.*v(i,j,k))**2
	      err2w = err2w+(wlap(i,j,k)+2.*w(i,j,k))**2
	    end if
	  end do
	end do
      end do
c
c     set and print least squares error in vlap,wlap
c
      err2v = sqrt(err2v/(nt*nlat*nlon))
      err2w = sqrt(err2w/(nt*nlon*nlat))
      call vout(err2v,4herrv)
      call vout(err2w,4herrw)
c
c     now recompute (v,w) inverting (vlap,wlap) ivlap codes
c
      do kk=1,nt
      do j=1,nlon
      do i=1,nlat
      v(i,j,kk) = 0.0
      w(i,j,kk) = 0.0
      end do
      end do
      end do

      if (icase.eq.1) then

      call name(4h**ec)
c
c     analyze vector field (vlap,wlap)
c
      call vhaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhaec(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,
     +br,bi,cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvha )
      call iout(ierror,4hierr)

      call vhseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hvhsi)
      call iout(ierror,4hierr)

      call ivlapec(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name(4hivlp)
      call iout(ierror,4hierr)

      else if (icase.eq.2) then

      call name(4h**es)
c
c     analyze vector field (vlap,wlap)
c
      call vhaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhaes(nlat,nlon,isym,nt,vlap,wlap,nlat,nlon,
     +br,bi,cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvha )
      call iout(ierror,4hierr)

      call vhsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvhsi)
      call iout(ierror,4hierr)

      call ivlapes(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,pertrb,ierror)
      call name(4hivlp)
      call iout(ierror,4hierr)

      else if (icase .eq. 3) then

      call name(4h**gc)

c
c     analyze vector field (vlap,wlap)
c
      call vhagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhagc(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,
     +br,bi,cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvha )
      call iout(ierror,4hierr)

      call vhsgci(nlat,nlon,wsave,lsave,work,ldwork,ierror)
      call name(4hvhsi)
      call iout(ierror,4hierr)

      call ivlapgc(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name(4hivlp)
      call iout(ierror,4hierr)

      else if (icase .eq. 4) then

      call name(4h**gs)

c
c     analyze vector field (vlap,wlap)
c
      call vhagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhags(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,
     +br,bi,cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvha )
      call iout(ierror,4hierr)

      call vhsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvhsi)
      call iout(ierror,4hierr)

      call ivlapgs(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name(4hivlp)
      call iout(ierror,4hierr)

      end if

      if (nmax.lt.10) then
      do kk=1,nt
      call iout(kk,4h**kk)
      call aout(v(1,1,kk),4h   v,nlat,nlon)
      call aout(w(1,1,kk),4h   w,nlat,nlon)
      end do
      end if

c
c     compare this v,w with original
c
      err2v = 0.0
      err2w = 0.0
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    if (k.eq.1) then
	      ve = cosp
	      we = -cost*sinp
	    end if
	    err2v = err2v + (v(i,j,k)-ve)**2
	    err2w = err2w + (w(i,j,k)-we)**2
	  end do
	end do
      end do
      err2v = sqrt(err2v/(nlat*nlon*nt))
      err2w = sqrt(err2w/(nlat*nlon*nt))
      call vout(err2v,4herrv)
      call vout(err2w,4herrw)

c
c     end of icase loop
c
      end do
      end


      subroutine AVERAGEFACE(
     &           coarse
     &           ,icoarselo0
     &           ,icoarsehi0
     &           ,ncoarsecomp
     &           ,fine
     &           ,ifinelo0
     &           ,ifinehi0
     &           ,nfinecomp
     &           ,icrseBoxlo0
     &           ,icrseBoxhi0
     &           ,dir
     &           ,nRef
     &           ,refFactor
     &           ,irefBoxlo0
     &           ,irefBoxhi0
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer ncoarsecomp
      integer icoarselo0
      integer icoarsehi0
      REAL*8 coarse(
     &           icoarselo0:icoarsehi0,
     &           0:ncoarsecomp-1)
      integer nfinecomp
      integer ifinelo0
      integer ifinehi0
      REAL*8 fine(
     &           ifinelo0:ifinehi0,
     &           0:nfinecomp-1)
      integer icrseBoxlo0
      integer icrseBoxhi0
      integer dir
      integer nRef
      integer refFactor
      integer irefBoxlo0
      integer irefBoxhi0
      integer ic0
      integer ifine0
      integer var
      integer ii0
      REAL*8 crseSum, ref_scale
      ref_scale = ((1.0d0)/refFactor)**(1 -1)
      do var=0, ncoarsecomp-1
      do ic0 = icrseBoxlo0,icrseBoxhi0
         crseSum = 0
      do ii0 = irefBoxlo0,irefBoxhi0
         ifine0=ic0*nRef+ii0
            crseSum = crseSum + fine(ifine0,var)
      enddo
            coarse(ic0,var) = ref_scale*crseSum
      enddo
       enddo
       return
       end
      subroutine AVERAGEFACEHARMONIC(
     &           coarse
     &           ,icoarselo0
     &           ,icoarsehi0
     &           ,ncoarsecomp
     &           ,fine
     &           ,ifinelo0
     &           ,ifinehi0
     &           ,nfinecomp
     &           ,icrseBoxlo0
     &           ,icrseBoxhi0
     &           ,dir
     &           ,nRef
     &           ,refFactor
     &           ,irefBoxlo0
     &           ,irefBoxhi0
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer ncoarsecomp
      integer icoarselo0
      integer icoarsehi0
      REAL*8 coarse(
     &           icoarselo0:icoarsehi0,
     &           0:ncoarsecomp-1)
      integer nfinecomp
      integer ifinelo0
      integer ifinehi0
      REAL*8 fine(
     &           ifinelo0:ifinehi0,
     &           0:nfinecomp-1)
      integer icrseBoxlo0
      integer icrseBoxhi0
      integer dir
      integer nRef
      integer refFactor
      integer irefBoxlo0
      integer irefBoxhi0
      integer ic0
      integer ifine0
      integer var
      integer ii0
      REAL*8 crseSum, ref_scale
      ref_scale = ((1.0d0)/refFactor)**(1 -1)
      do var=0, ncoarsecomp-1
      do ic0 = icrseBoxlo0,icrseBoxhi0
         crseSum = 0
      do ii0 = irefBoxlo0,irefBoxhi0
         ifine0=ic0*nRef+ii0
            crseSum = crseSum + (1.0d0)/fine(ifine0,var)
      enddo
            coarse(ic0,var) = (1.0d0)/(ref_scale*crseSum)
      enddo
       enddo
       return
       end