module lambert

implicit none

double precision, parameter :: pi = 3.1415926535897931d0

type lambertresult
    double precision, dimension(3) :: v0
    double precision, dimension(3) :: v
end type lambertresult

contains

type(lambertresult) function lambertsolver(k, r0, r, tof, short, numiter, rtol)
    double precision, intent(in) :: k
    double precision, dimension(:), intent(in) :: r0
    double precision, dimension(:), intent(in) :: r
    double precision, intent(in) :: tof
    logical, intent(in), optional :: short
    integer, intent(in), optional :: numiter
    double precision, intent(in), optional :: rtol

    logical :: short_
    integer :: numiter_
    double precision :: rtol_

    double precision :: norm_r0, norm_r, cos_dnu
    double precision :: a, psi, psi_low, psi_up
    double precision :: y, xi, tof_new, g, gdot
    integer :: t_m, counter
    double precision, dimension(3) :: f, v, v0

    short_ = .true.
    if (present(short)) short_ = short
    numiter_ = 35
    if (present(numiter)) numiter_ = numiter
    rtol_ = 1e-8
    if (present(rtol)) rtol_ = rtol

    if (short_) then
        t_m = 1
    else
        t_m = -1
    end if

    norm_r0 = norm2(r0)
    norm_r = norm2(r)
    cos_dnu = dot_product(r0, r) / (norm_r0 * norm_r)

    a = t_m * sqrt(norm_r * norm_r0 * (1 + cos_dnu))

    if (a == 0d0) then
        write(*,*) "Cannot compute orbit, phase angle is 180 degrees"
        stop 1
    end if

    psi = 0d0
    psi_low = -4 * pi
    psi_up = 4 * pi

    counter = 0
    do while (counter < numiter_)
        y = norm_r0 + norm_r + a * (psi * c3(psi) - 1) / sqrt(c2(psi))
        if (a > 0d0 .and. y < 0d0) then
            do while (y < 0d0)
                psi_low = psi
                psi = (0.8d0 * (1d0 / c3(psi)) * &
                    (1d0 - (norm_r0 + norm_r) * sqrt(c2(psi)) / a))
                y = norm_r0 + norm_r + a * (psi * c3(psi) - 1) / sqrt(c2(psi))
            end do
        end if
        xi = sqrt(y / c2(psi))
        tof_new = (xi**3 * c3(psi) + A * sqrt(y)) / sqrt(k)

        if (abs((tof_new - tof) / tof) < rtol_) then
            exit
        else
            counter = counter + 1
            if (tof_new <= tof) then
                psi_low = psi
            else
                psi_up = psi
            end if
            psi = (psi_up + psi_low) / 2
        end if
    end do

    if (counter > numiter_) then
        write(*,*) "Maximum number of iterations reached."
        stop 1
    end if

     f = 1 - y / norm_r0
     g = a * sqrt(y / k)
     gdot = 1 - y / norm_r

     v0 = (r - f * r0) / g
     v = (gdot * r - r0) / g
     lambertsolver = lambertresult(v0, v)
end function lambertsolver

double precision function c2(psi)
    double precision, intent(in) :: psi

    double precision :: eps
    double precision :: delta
    integer :: k

    eps = 1.0
    if (psi > eps) then
        c2 = (1 - cos(sqrt(psi))) / psi
    else if (psi < -eps) then
        c2 = (cosh(sqrt(-psi)) - 1) / (-psi)
    else
        c2 = 1d0 / 2d0
        delta = (-psi) / gamma(2d0 + 2d0 + 1d0)
        k = 1
        do while (c2 + delta /= c2)
            c2 = c2 + delta
            k = k + 1
            delta = (-psi)**k / gamma(2 * k + 2d0 + 1d0)
        end do
    end if
end function c2

double precision function c3(psi)
    double precision, intent(in) :: psi

    double precision :: eps
    double precision :: delta
    integer :: k

    eps = 1.0
    if (psi > eps) then
        c3 = (sqrt(psi) - sin(sqrt(psi))) / (psi * sqrt(psi))
    else if (psi < -eps) then
        c3 = (sinh(sqrt(-psi)) - sqrt(-psi)) / (-psi * sqrt(-psi))
    else
        c3 = 1d0 / 6d0
        delta = (-psi) / gamma(2d0 + 3d0 + 1d0)
        k = 1
        do while (c3 + delta /= c3)
            c3 = c3 + delta
            k = k + 1
            delta = (-psi) ** k / gamma(2 * k + 3d0 + 1d0)
        end do
    end if
end function c3

subroutine benchmark_lambert(times)
    integer, intent(in) :: times

    double precision, dimension(3) :: r
    double precision, dimension(3) :: r0
    double precision :: tof
    double precision, parameter :: mu = 3.986004418d5
    type(lambertresult) :: res

    double precision :: current, rate
    integer(kind=8) :: start, finish, irate
    double precision :: total, best, worst
    integer :: i

    r0 = [5000d0, 10000d0, 2100d0]
    r = [-14600d0, 2500d0, 7000d0]
    tof = 3600d0

    worst = -1d20
    best = 1d20
    total = 0d0
    call system_clock(count_rate=irate)
    rate = dble(irate)
    do i=1, times
        call system_clock(start)

        res = lambertsolver(mu, r0, r, tof)

        call system_clock(finish)
        current = (finish - start)/rate
        if (current < best .and. current > 0) then
            best = current
        end if
        if (current > worst) then
            worst = current
        end if
        total = total + current
    end do
    print *, total/times, best, worst
end subroutine benchmark_lambert

end module lambert


module statistics_module
use system_module, only : dp, PRINT_VERBOSE, PRINT_NORMAL, print, current_verbosity, operator(//)
implicit none
private

public :: mean, variance

public :: mean_var_decorrelated_err
interface mean_var_decorrelated_err
   module procedure mean_var_decorrelated_err_r1
end interface mean_var_decorrelated_err

contains

subroutine mean_var_decorrelated_err_r1(A, m, v, decorrelated_err, decorrelation_t)
   real(dp) :: A(:)
   real(dp), optional :: m, v, decorrelated_err, decorrelation_t

   integer :: bin_i, bin_size, n_bins, N
   real(dp) :: A_mean, A_var, Nr, A_decorrelation_t
   real(dp), allocatable :: binned_means(:)
   real(dp) :: binned_means_var
   real(dp) :: p_d_t, pp_d_t
   logical :: found_max

   N = size(A)
   Nr = N

   A_mean = mean(A)
   if (present(m)) m = A_mean
   if (present(v) .or. present(decorrelation_t) .or. present(decorrelated_err)) A_var = variance(A, A_mean)
   if (present(v)) v = A_var

   found_max = .false.
   p_d_t = -HUGE(1.0_dp)
   pp_d_t = HUGE(1.0_dp)
   if (present(decorrelation_t) .or. present(decorrelated_err)) then
      bin_size = 1
      do while (bin_size <= N)
	 n_bins = N/bin_size
	 allocate(binned_means(n_bins))
	 do bin_i=1, n_bins
	    binned_means(bin_i) = mean(A((bin_i-1)*bin_size+1:(bin_i-1)*bin_size+bin_size))
	 end do
	 binned_means_var = variance(binned_means, mean(binned_means))
	 deallocate(binned_means)
	 A_decorrelation_t = binned_means_var*real(bin_size,dp)/A_var
	 call print("bin_size " // bin_size // " decorrelation_t " // A_decorrelation_t, PRINT_VERBOSE)
	 if (A_decorrelation_t < p_d_t .and. p_d_t > pp_d_t) then
	    if (.not. found_max) then
	       if (present(decorrelation_t)) decorrelation_t = A_decorrelation_t
	       if (present(decorrelated_err)) decorrelated_err = sqrt(binned_means_var/real(n_bins,dp))
	       found_max = .true.
	    endif
	    if (current_verbosity() <= PRINT_NORMAL) exit
	 endif
	 pp_d_t = p_d_t
	 p_d_t = A_decorrelation_t
	 if (bin_size == 1) then
	    bin_size = bin_size * 2
	 else
	    bin_size = bin_size * 1.5
	 endif
      end do
   end if

end subroutine mean_var_decorrelated_err_r1

function mean(A)
   real(dp), intent(in) :: A(:)
   real(dp) :: mean

   mean = sum(A)/real(size(A),dp)
end function mean

function variance(A, A_mean)
   real(dp), intent(in) :: A(:), A_mean
   real(dp) :: variance

   variance = sum((A-A_mean)**2)/real(size(A),dp)
end function variance

end module statistics_module


*=======================================================================
* File:    gumbel.F
* Author:  Alex Stivala
* Created: July 2010
*
* Functions to compute z-score and p-value from tableau matching score,
* according to Gumbel distribution parameters.
* See thesis Ch. 6 (s6.2.2) and Ortiz et al (2002),
* Abagyan & Batalov (1997), Versetr0m & Taylor (2006),
* Kolbeck et al (2006), Levitt & Gerstein (1998).
*
* This file contains double precision functions zgumbel and pvgumbel
*
* $Id: rdtabd.F 2969 2009-11-22 01:29:39Z astivala $
*=======================================================================

      double precision function pvgumbel(z)

      implicit none
*
* pvgumbel - compute p-value from Gumbel distribution
*
*     .. Scalar Arguments ..
      double precision z
*
*
* Arguments
* =========
*
* z (input) DOUBLE PRECISION
*        Gumbel z-score from pvgumbel to compute pvalue for
*
* Return value
* ============
*     p-value computed for x according to Gumbel(a,b) distribution
*
*=======================================================================
*

*     .. Parameters ..
      double precision pi
      parameter(pi=3.141592653589793D0)
*     Euler-Mascheroni constant
      double precision egamma
      parameter(egamma = 0.5772156649015328606d0)
*     ..
*     .. Local Scalars ..
*     ..
*     .. Local Arrays ..
*     ..
*     .. Intrinsic Functions ..
      intrinsic sqrt,exp
*     ..
*     .. External Subroutines and Functions ..
*     ..
*     .. Executable Statements ..
*
      pvgumbel = 1.0d0-exp(-1.0d0*exp(-1.0d0*(z*pi/sqrt(6.0d0)+egamma)))
      end

*=======================================================================

*=======================================================================

      double precision function zgumbel(x)

      implicit none
*
* zgumbel - compute Z-score from Gumbel distribution
*
*
*  The Gumbel distribution parameters a and b are estimated by MLE
*  for structures in different folds (see thesis ch.6 (s6.2.2)
*  for query200 in ASTRAL SCOP 1.75 95% nr.
*
*     .. Scalar Arguments ..
      double precision x
*
*
* Arguments
* =========
*
* x  (input) DOUBLE PRECISION
*        Tableau matching score to compute z-score for
*
* Return value
* ============
*     Z-score computed for x according to Gumbel(a,b) distribution
*
*=======================================================================
*

*     .. Parameters ..
      double precision pi
      parameter(pi=3.141592653589793D0)
*     Euler-Mascheroni constant
      double precision egamma
      parameter(egamma = 0.5772156649015328606d0)
*     Gumbel distribution location parameter
      double precision a
      parameter(a = 0.4731609844614057d0)
*     Gumbel distribution scale parameter
      double precision b
      parameter(b = 0.44602089192192d0)
*     ..
*     .. Local Scalars ..
      double precision mu
      double precision sigma
*     ..
*     .. Local Arrays ..
*     ..
*     .. Intrinsic Functions ..
      intrinsic sqrt
*     ..
*     .. External Subroutines and Functions ..
*     ..
*     .. Executable Statements ..
*
      mu = a + b * egamma
      sigma = (pi / sqrt(6.0d0)) * b
      zgumbel  = (x - mu) / sigma
      end


module mod_QCG
    implicit none
    integer,parameter:: ik=selected_int_kind(11)
    integer,parameter:: rk=selected_real_kind(11, 11)
    !QCG parameters
    integer(kind=ik),parameter:: qcg_m=11, qcg_a=11, qcg_b=1, qcg_c=5
    integer(kind=ik):: qcg_seed

contains
    subroutine seed_qcg(seed)
        implicit none
        integer(kind=ik), intent(in):: seed
        qcg_seed=seed
    end subroutine seed_qcg

    real(rk) function rand_qcg()
        implicit none
        qcg_seed=mod(qcg_a*qcg_seed**2+qcg_b*qcg_seed+qcg_c, qcg_m)
        rand_qcg=real(qcg_seed, rk)/real(qcg_m, rk)
    end function rand_qcg
end module

program ex2p1
    use mod_QCG
    implicit none
    integer(kind=ik)::i
    real(kind=rk)::x0, x
    !Set seed
    call seed_qcg(int(345343, ik))

    !First value
    x0=rand_qcg()
    print*, x0
    i=1
    do
        x=rand_qcg()
        print*,x
        if (x==x0) exit
        i=i+1
    end do
    print*, "QCG repeat interval:",i
end program ex2p1


	FUNCTION PR_HGSF  ( hgml )
C************************************************************************
C* PR_HGSF								*
C*									*
C* This function computes HGFT from HGML.  The following equation is	*
C* used:								*
C*									*
C*               HGFT = HGML * 5280	    				*
C*									*
C* REAL PR_HGSF  ( HGML )						*
C*									*
C* Input parameters:							*
C*	HGML		REAL	 	Height in statute miles 	*
C*									*
C* Output parameters:							*
C*	PR_HGSF		REAL		Height in feet          	*
C**									*
C* Log:									*
C* S. Schotz    	10/89	Original source				*
C* J. Whistler/SSAI	 7/91	Changed hght to hgml in ERMISS check	*
C************************************************************************
        INCLUDE    'GEMPRM.PRM'
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing values.
C
	IF  ( ERMISS ( hgml ) )  THEN
	    PR_HGSF = RMISSD
	  ELSE
	    PR_HGSF = hgml * 5280.
	END IF
C*
	RETURN
	END


      SUBROUTINE FTEST(DATA1,N1,DATA2,N2,F,PROB)
      DIMENSION DATA1(N1),DATA2(N2)
      CALL AVEVAR(DATA1,N1,AVE1,VAR1)
      CALL AVEVAR(DATA2,N2,AVE2,VAR2)
      IF(VAR1.GT.VAR2)THEN
        F=VAR1/VAR2
        DF1=N1-1
        DF2=N2-1
      ELSE
        F=VAR2/VAR1
        DF1=N2-1
        DF2=N1-1
      ENDIF
      PROB = BETAI(0.5*DF2,0.5*DF1,DF2/(DF2+DF1*F))
     *    +(1.-BETAI(0.5*DF1,0.5*DF2,DF1/(DF1+DF2/F)))
      RETURN
      END


!{\src2tex{textfont=tt}}
!!****f* ABINIT/sg_fft
!! NAME
!! sg_fft
!!
!! FUNCTION
!! Calculates the discrete fourier transform
!! ftarr(i1,i2,i3)=exp(ris*i*2*pi*(j1*i1/n1+j2*i2/n2+j3*i3/n3)) arr(j1,j2,j3)
!!
!! COPYRIGHT
!! Copyright by Stefan Goedecker, Ithaca, NY USA, July 14, 1993
!! Copyright (C) 1998-2001 ABINIT group (DCA, XG)
!! This file is distributed under the terms of the
!! GNU General Public License, see ~ABINIT/Infos/copyright
!! or http://www.gnu.org/copyleft/gpl.txt .
!!
!! INPUTS
!!  arr(2,nd1,nd2,nd3)=input complex array with alternating real and imaginary
!!   elements; data resides in 2*n1*n2*n3 of this array, spread out.
!!  fftcache=size of the cache (kB)
!!  nd1,nd2,nd3=memory dimension of arr and ftarr
!!  n1,n2,n3=physical dimension of the transform
!!  ris=(real(dp)) sign of exponential in transform
!!
!! OUTPUT
!!  ftarr(2,nd1,nd2,nd3)=working space for transform and contains output
!!
!! SIDE EFFECTS
!!
!! NOTES
!!  ndi must always be greater or equal to ni.  Recommended choice for nd1
!!  and nd2 is: ni for ni=odd or ni+1 for ni=even (hence 2*(ni/2)+1);
!!  nd3 should always be n3.  Note that choosing nd1 or nd2 larger than
!!  the recommended value can severely degrade efficiency of this routine.
!!  Avoiding even ndi for nd1 and nd2 avoids cache conflicts on cache machines.
!!  Each of n1,n2,n3 must be a
!!  product of the prime factors 2,3,5. If two ni s are equal
!!  it is recommended to place them behind each other.
!!  The largest any of these may be is set by parameter "mg" below.
!!  This fft is particularly efficient for cache architectures.
!!  Note that the meaning of fftcache has changed from the original
!!  ncache of SG (that was the maximum number of COMPLEX*16 in the cache)
!!
!! TODO
!! Use latex for the equation above
!!
!! PARENTS
!!      ccfft
!!
!! SOURCE

 subroutine sg_fft(fftcache,nd1,nd2,nd3,n1,n2,n3,arr,ftarr,ris)

 use basis_defs
 implicit none

!Arguments ------------------------------------
 integer :: fftcache,nd1,nd2,nd3,n1,n2,n3
 real(dp) :: ris
 real(dp) :: arr(2,nd1,nd2,nd3),ftarr(2,nd1,nd2,nd3)

!Local variables-------------------------------
!mfac sets maximum number of factors (5, 4, 3, or 2) which may be
!contained within any n1, n2, or n3
!mg sets the maximum 1 dimensional fft length (any one of n1, n2, or n3)
 integer, parameter :: mfac=11,mg=2048
 integer :: ic,i2,nd13,nd23,n1i,n12,n2i,n23,n3i
 integer :: aft(mfac),bef(mfac),ind(mg),now(mfac)
 real(dp) :: trig(2,mg)
 character :: message*500

! *************************************************************************

!Check that dimension is not exceeded
 if (n1>mg.or.n2>mg.or.n3>mg) then
  write(message, '(a,a,a,a,3i10,a,i10,a)' ) ch10,&
&  ' sg_fft : BUG -',ch10,&
&  '  one of the dimensions n1,n2,n3=',n1,n2,n3,&
&  '  exceeds allowed dimension mg=',mg,ch10
!  call wrtout(06,message,'PERS')
!  call leave_new('PERS')
 endif

!transform along x direction
 call sg_ctrig(n1,trig,aft,bef,now,ris,ic,ind,mfac,mg)
 call sg_fftx(fftcache,mfac,mg,nd1,nd2,nd3,n2,n3,&
& arr,ftarr,trig,aft,now,bef,ris,ind,ic)

!transform along y direction
 if (n2/=n1)then
  call sg_ctrig(n2,trig,aft,bef,now,ris,ic,ind,mfac,mg)
 endif
 n1i=1 ; n3i=1
 call sg_ffty(fftcache,mfac,mg,nd1,nd2,nd3,n1i,n1,n3i,n3,&
& ftarr,arr,trig,aft,now,bef,ris,ind,ic)

!transform along z direction
 if (n3/=n2)then
  call sg_ctrig(n3,trig,aft,bef,now,ris,ic,ind,mfac,mg)
 endif

!$OMP PARALLEL DO SHARED(aft,arr,bef,fftcache,ftarr,ind,ic)&
!$OMP&SHARED(nd1,nd2,nd3,now,n1,n2,ris,trig)&
!$OMP&PRIVATE(i2)
  do i2=1,n2
   call sg_fftz(fftcache,mfac,mg,nd1,nd2,nd3,n1,i2,i2,arr,ftarr,&
&   trig,aft,now,bef,ris,ind,ic)
  enddo
!$OMP END PARALLEL DO

 end subroutine
!!***


!***********************************/
!	Name:局所時間刻み幅用の時間刻み計算プログラム
!	Alias:UCalcTimeWidth
!	Description:
!	Type:
!	Input:
!	Output:
!	Note:
!	Author:Akitaka Toyota
!	Date:2018.01.22
!	Update:
!	Other:
!***********************************/
subroutine JPUCalcTimeWidth(UG,CC)
use StructVar_Mod
use LoopVar_Mod
use ConstantVar_Mod, Gamma => SpecificOfHeatRatio, CFL => CourantFriedrichsLewyCondition
implicit none
    type(UnstructuredGrid),intent(in) :: UG
    type(CellCenter), intent(inout) :: CC
    type(CalcTimeWidthWithOMP) :: CTW

    do iCell = 1, UG%GI%RealCells
        CTW%AbsoluteVelocity2 = dot_product(CC%ConservedQuantity(2:4,iCell,1,1),CC%ConservedQuantity(2:4,iCell,1,1))/(CC%ConservedQuantity(1,iCell,1,1)**2) !速度L2ノルム

        if(Gamma*Gmin1*(CC%ConservedQuantity(5,iCell,1,1) / CC%ConservedQuantity(1,iCell,1,1) &
                            & - 0.5d0 * CTW%AbsoluteVelocity2) < 0.0d0) then
                write(6,*) "CalcTimeWidth, Error "
                write(6,*) iCell
                write(6,*) CC%ConservedQuantity(1,iCell,1,1),CC%ConservedQuantity(5,iCell,1,1)
                write(6,*) CTW%AbsoluteVelocity2
                !stop
        end if

        CTW%LocalSoundSpeed = sqrt(Gamma*Gmin1*(CC%ConservedQuantity(5,iCell,1,1) / CC%ConservedQuantity(1,iCell,1,1) &
                            & - 0.5d0 * CTW%AbsoluteVelocity2)) !局所音速

        CTW%AbsoluteVelocity = sqrt(CTW%AbsoluteVelocity2) !速度絶対値

        CC%TmpTimeWidth(iCell,1,1,1) = CFL*UG%InscribedCircle(iCell) / (CTW%LocalSoundSpeed + CTW%AbsoluteVelocity) !衝撃波が通過する速度(の半分くらい)
    end do

    do iCell = UG%GI%RealCells+1, UG%GI%AllCells
        CC%TmpTimeWidth(iCell,1,1,1) = CC%TmpTimeWidth(UG%VC%Cell(iCell,1),1,1,1)
    end do

    do iCell = 1, UG%GI%RealCells
        CC%TimeWidth(iCell,1,1) = 0.5d0*min(CC%TmpTimeWidth(iCell,1,1,1),CC%TmpTimeWidth(UG%Tri%Cell(iCell,1),1,1,1),&
                     &   CC%TmpTimeWidth(UG%Tri%Cell(iCell,2),1,1,1),CC%TmpTimeWidth(UG%Tri%Cell(iCell,3),1,1,1))
    end do

    return
end subroutine JPUCalcTimeWidth


!**********************************************************************
!    LICENSED MATERIALS - PROPERTY OF IBM                             *
!    "RESTRICTED MATERIALS OF IBM"                                    *
!                                                                     *
!    5765-422                                                         *
!    5765-C41                                                         *
!    (C) COPYRIGHT IBM CORP. 1995, 1997. ALL RIGHTS RESERVED.         *
!                                                                     *
!    U.S. GOVERNMENT USERS RESTRICTED RIGHTS - USE, DUPLICATION       *
!    OR DISCLOSURE RESTRICTED BY GSA ADP SCHEDULE CONTRACT WITH       *
!    IBM CORP.                                                        *
!**********************************************************************
	program image
        use putilities
        implicit none
!
!  This is a simple example program showing the real to complex
!  and complex to real Fourier transforms.
!
!  It well known that a the following correlation
!
!   C(x,y) = FTINV(H(u,v)*G(u,v))
!
!     where H is the 2-d Fourier transform of a target image h(x,y)
!           G is the complex conjugate of the 2-d Fourier transform of
!           a refererence image g(x,y)
!           and FTINV represents the 2d inverse Fourier transform
!   provides a measure of the similarity between the images. If the resulting
!   correlation has no peak the images have little in common. The size
!   and location of any peak in C(x,y) provides information on how similar
!   the target image is to the reference image and to any rotation or
!   scale changes of the reference image to the target image.
!
!   Subroutines call:
!      array_create   from the utilitity library
!      blacs_pinfo    from the blacs library
!      pcrft2         from pessl
!      prcft2         from pessl
!
       integer, parameter       :: xsize=1024, ysize=1024
       real(long_t), pointer    :: target_image(:,:), ref_image(:,:)
       real(long_t), pointer    :: correlation(:,:)
       complex(long_t), pointer :: target_xform(:,:), ref_xform(:,:)
       complex(long_t), pointer :: correlation_xform(:,:)
       complex(long_t), pointer :: frow1(:),frow2(:),lrow1(:),lrow2(:)
       integer                  :: ip(40)
       integer                  :: desc(DESC_DIM)  ! dummy descriptor
       integer                  :: iam, nprocs, status, i, j

!
!  create interface block for all subroutines which follow
!
       INTERFACE

       subroutine unpack(xform,frow,lrow)
       use putilities
         complex(long_t), intent(out) :: frow(:), lrow(:)
         complex(long_t), intent(in)  :: xform(:,:)
       end subroutine unpack

       subroutine pack(xform,frow,lrow)
       use putilities
         complex(long_t), intent(in)  :: frow(:), lrow(:)
         complex(long_t), intent(out) :: xform(:,:)
       end subroutine pack

       subroutine filter(image)
       use putilities
       implicit none
       complex(long_t), intent(inout) :: image(:,:)
       end subroutine filter

       subroutine get_target_image(image)
       use putilities
       implicit none
       real(long_t), intent(inout) :: image(:,:)
       end subroutine get_target_image

       subroutine get_ref_image(image)
       use putilities
       implicit none
       real(long_t), intent(inout) :: image(:,:)
       end subroutine get_ref_image

       END INTERFACE

!
!  initialize system
!
       call blacs_pinfo(iam,nprocs)
       call initutils(status,npcs=nprocs)
!
!   check that the number of processors evenly divide ysize and xsize/2
!
       if ( xsize .ne. 2*nprocs*(xsize/(2*nprocs)) ) then
         if( iam.eq.0) then
           write(*,*)'2*nprocs must evenly divide xsize'
         endif
         call blacs_abort(p_context(),1)
       endif

       if ( ysize .ne. nprocs*(ysize/nprocs) ) then
         if( iam.eq.0) then
           write(*,*)'nprocs must evenly divide ysize'
         endif
         call blacs_abort(p_context(),1)
       endif

       if( status .ne. 0 ) then
         if(iam.eq.0)write(*,*) 'communication initilization failure'
         call blacs_abort(p_context(),1)
       endif

!
!  allocate data for images
!

       call array_create(target_image,desc,xsize,ysize,CREATE_BLOCK)
       call array_create(ref_image,desc,xsize,ysize,CREATE_BLOCK)
       call array_create(correlation,desc,xsize,ysize,CREATE_BLOCK)
       call array_create(target_xform,desc,ysize,xsize/2,CREATE_BLOCK)
       call array_create(ref_xform,desc,ysize,xsize/2,CREATE_BLOCK)
       call array_create(correlation_xform,desc,ysize,xsize/2,             &
     &                   CREATE_BLOCK)

!
!  get the target image
!
       call get_target_image(target_image)
!
!  use default values
!
       ip = 0

!
!      call 2d Fourier real to complex transform
!
       call pdrcft2(target_image,target_xform,xsize,ysize,1,1.d0,           &
     &              p_context(),ip)

       call filter(target_xform)

!
!  get the reference image
!
       call get_ref_image(ref_image)
!
!      call 2d Fourier real to complex transform
!
       call pdrcft2(ref_image,ref_xform,xsize,ysize,1,1.d0,                &
     &              p_context(),ip)

!
!      multiply the two xforms together to get the correlation xform
!

       if(iam .eq. 0 ) then
!
!  processor 0 will have the first and last column stored in
!  packed format
!
         allocate(frow1(ysize))
         allocate(frow2(ysize))
         allocate(lrow1(ysize))
         allocate(lrow2(ysize))

!
!   unpack target transform
!
         call unpack(target_xform,frow1,lrow1)
         call unpack(ref_xform,frow2,lrow2)

         do i = 1, ysize
           frow1(i) = frow1(i) * conjg(frow2(i))
           lrow1(i) = lrow1(i) * conjg(lrow2(i))
         enddo

         do j = 2, xsize/(2*nprocs)
           do i = 1, ysize
             correlation_xform(i,j) = target_xform(i,j) *                     &
     &                                conjg(ref_xform(i,j))
           enddo
         enddo

         call pack(correlation_xform,frow1,lrow1)
         deallocate(frow1)
         deallocate(frow2)
         deallocate(lrow1)
         deallocate(lrow2)

       else   ! My processor doesn't have the messy row

         do j = 1, xsize/(2*nprocs)
           do i = 1, ysize
             correlation_xform(i,j) = target_xform(i,j) *                     &
     &                                conjg(ref_xform(i,j))
           enddo
         enddo
       endif

!
!  correlation_xform now has the 2d transform of the image corrlation
!
       call pdcrft2(correlation_xform,correlation,xsize,ysize,                &
     &              -1, 1.d0/(xsize*ysize),p_context(),ip)

!
!  correlation now has the correlation array
!
       if(iam .eq. 0) then
         write(*,*)'The 1,1 correlation element is ', correlation(1,1)
       endif

!
! clean up space
!
       deallocate(target_image)
       deallocate(ref_image)
       deallocate(correlation)
       deallocate(target_xform)
       deallocate(ref_xform)
       deallocate(correlation_xform)
!
!  end blacs
!
       call exitutils(0)

!
!  end program
!
       stop
       end

!
!  subroutine to unpack row 1 and row n2/2 + 1 of a complex
!  transform in packed format
!
       subroutine unpack(xform,frow,lrow)
       use putilities
       implicit none
       complex(long_t), intent(out) :: frow(:), lrow(:)
       complex(long_t), intent(in)  :: xform(:,:)
!
!  input:
!      xform  :: the transform in packed format
!      frow   :: first row of transform in unpacked format
!      lrow   :: last row of transform in unpacked format
!  note: This routine should be only called from the first processor
!        since only processor 0 will have the packed row of the
!        transform
!
!
       integer                      :: ysize, i, j

       ysize = size(xform,1)
       if( size(frow) .ne. ysize .or. size(lrow) .ne. ysize) then
         write(*,*) 'size mismatch in unpack'
         call blacs_abort(p_context(),1)
       endif

!
!  unpack the first row
!  rows appear to be columns because the transformed array
!  is stored in transpose format
!
       frow(1) = real(xform(1,1))
       frow(ysize/2+1) = imag(xform(1,1))
       frow(2:ysize/2) = xform(2:ysize/2,1)
       frow(ysize/2+2:ysize) = conjg(frow(2:ysize/2))

!
!  unpack the last row
!
       lrow(1) = real(xform(ysize/2+1,1))
       lrow(ysize/2+1) = imag(xform(ysize/2+1,1))
       lrow(2:ysize/2) = xform(ysize/2+2:ysize,1)
       lrow(ysize/2+2:ysize) = conjg(lrow(2:ysize/2))
       return
       end subroutine unpack

!
!  subroutine to pack row 1 and row n2/2 + 1 of a complex
!  transform into packed format
!
       subroutine pack(xform,frow,lrow)
       use putilities
       implicit none
       complex(long_t), intent(in)  :: frow(:), lrow(:)
       complex(long_t), intent(out) :: xform(:,:)
!
!  input:
!      xform  :: the transform in packed format
!      frow   :: first row of transform in unpacked format
!      lrow   :: last row of transform in unpacked format
!  note: This routine should be only called from the first processor
!        since only processor 0 will have the packed row of the
!        transform
!
!
       integer                      :: ysize, i, j

       ysize = size(xform,1)
       if( size(frow) .ne. ysize .or. size(lrow) .ne. ysize) then
         write(*,*) 'size mismatch in unpack'
         call blacs_abort(p_context(),1)
       endif

!
!  pack the first row
!  rows appear to be columns because the transformed array
!  is stored in transpose format
!
       xform(1,1) = cmplx(real(frow(1)),real(frow(ysize/2+1)))
       xform(2:ysize/2,1) = frow(2:ysize/2)

!
!  pack the last row
!
       xform(ysize/2+1,1) = cmplx(real(lrow(1)),real(lrow(ysize/2+1)))
       xform(ysize/2+2:ysize,1) = lrow(2:ysize/2)
       return
       end subroutine pack

       subroutine get_target_image(image)
       use putilities
       implicit none
       real(long_t), intent(out)   :: image(:,:)
       integer i, j

!
!      get a target image
!

       image  =  0.d0

!
!  create a horizontal bar
!
       do  j = 1, size(image,2)
        do i = size(image,1)/3, size(image,1)/2
           image(i,j) = 1.d0
        enddo
       enddo
       return
       end subroutine get_target_image

       subroutine get_ref_image(image)
       use putilities
       implicit none
       real(long_t), intent(out)   :: image(:,:)
       integer i, j

!
!      get a reference image
!

       image  =  0.d0

!
!  create a horizontal bar
!
       do  j = 1, size(image,2)
        do i = size(image,1)/3, size(image,1)/2
           image(i,j) = 1.d0
        enddo
       enddo
       return
       end subroutine get_ref_image

       subroutine filter(image)
       use putilities
       implicit none
       complex(long_t), intent(inout) :: image(:,:)

!
!      apply any sort of image filter
!      in this case, we have a null routine
!

       return
       end subroutine filter


! !------------------------------------------------------------------
! module rand_fun

!   implicit none
!   private
!   integer  :: idum

!   public   :: set_seed, poidev, ran1

!   contains

!     subroutine set_seed(seed)
!       implicit none
!       integer :: seed
!       idum = seed
!     end subroutine set_seed

!    function poidev(xm)
!      implicit none
!      double precision poidev, xm, pi
!      parameter (pi=3.141592654d0)
!      double precision alxm, em, g, oldm, sq, t, y!, gammln, ran1
!      save alxm, g, oldm, sq
!       data oldm /-1./

!       if (xm .lt. 12) then
!         if(xm .ne. oldm) then
!           oldm = xm
!           g    = exp(-xm)
!         end if
!         em = -1.
!         t  = 1.
!  2      em = em + 1.
!         t  = t * ran1()
!         if( t .gt. g) goto 2
!       else
!         if(xm .ne. oldm)then
!           oldm = xm
!           sq   = sqrt(2.d0 * xm)
!           alxm = log(xm)
!           g    = xm * alxm - gammln( xm + 1.)
!         end if
!  1      y = tan(pi * ran1())
!         em = sq * y + xm
!         if(em .lt. 0.d0) goto 1
!         em = int(em)
!         t = 0.9d0*(1. + y**2.) * exp(em * alxm - gammln(em + 1.d0) - g)
!         if(ran1() .gt. t) goto 1
!       end if
!       poidev = em
!       return
!     end function poidev

!     FUNCTION gammln(xx)
!         implicit none
!         DOUBLE PRECISION gammln, xx
!         INTEGER j
!         DOUBLE PRECISION ser, stp, tmp, x, y, cof(6)
!         SAVE cof,stp
!         DATA cof, stp / 76.18009172947146d0, -86.50532032941677d0, 24.01409824083091d0, &
!              -1.231739572450155d0, 0.1208650973866179d-2, -0.5395239384953d-5, 2.5066282746310005d0/
!         x   = xx
!         y   = x
!         tmp = x + 5.5d0
!         tmp = (x + 0.5d0) * log(tmp) - tmp
!         ser = 1.000000000190015d0
!         do 11 j = 1, 6
!            y   = y + 1.d0
!            ser = ser +cof(j) / y
! 11         continue
!            gammln = real(tmp + log(stp * ser / x))
!            return
!         END function gammln

!         FUNCTION ran1()
!           implicit none
!           INTEGER IA,IM,IQ,IR,NTAB,NDIV
!           DOUBLE PRECISION ran1,AM,EPS,RNMX
!           PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836,&
!           NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
!           INTEGER j,k,iv(NTAB),iy
!           SAVE iv,iy
!           DATA iv /NTAB*0/, iy /0/
!           if (idum.le.0.or.iy.eq.0) then
!              idum=max(-idum,1)
!              do 11 j=NTAB+8,1,-1
!                 k=idum/IQ
!                 idum=IA*(idum-k*IQ)-IR*k
!                 if (idum.lt.0) idum=idum+IM
!                 if (j.le.NTAB) iv(j)=idum
! 11              continue
!                 iy=iv(1)
!              endif
!              k=idum/IQ
!              idum=IA*(idum-k*IQ)-IR*k
!              if (idum.lt.0) idum=idum+IM
!              j=1+iy/NDIV
!              iy=iv(j)
!              iv(j)=idum
!              ran1=min(AM*iy,RNMX)
!              return
!           END function ran1

!   end module rand_fun
! !----------------------------------------------------------------

! !------------------------------------------------------------------
! module rand_fun_real

!   implicit none
!   private
!   integer  :: idum

!   public   :: set_seed_real, poidev_real, ran1_real

!   contains

!     subroutine set_seed_real(seed)
!       implicit none
!       integer :: seed
!       idum = seed
!     end subroutine set_seed_real

!    function poidev_real(xm)
!      implicit none
!      real poidev_real, xm, pi
!      parameter (pi=3.141592654)
!      real alxm, em, g, oldm, sq, t, y!, gammln, ran1
!      save alxm, g, oldm, sq
!       data oldm /-1./

!       if (xm .lt. 12) then
!         if(xm .ne. oldm) then
!           oldm = xm
!           g    = exp(-xm)
!         end if
!         em = -1.
!         t  = 1.
!  2      em = em + 1.
!         t  = t * ran1_real()
!         if( t .gt. g) goto 2
!       else
!         if(xm .ne. oldm)then
!           oldm = xm
!           sq   = sqrt(2. * xm)
!           alxm = log(xm)
!           g    = xm * alxm - gammln_real( xm + 1.)
!         end if
!  1      y = tan(pi * ran1_real())
!         em = sq * y + xm
!         if(em .lt. 0.) goto 1
!         em = int(em)
!         t = 0.9*(1. + y**2.) * exp(em * alxm - gammln_real(em + 1.) - g)
!         if(ran1_real() .gt. t) goto 1
!       end if
!       poidev_real = em
!       return
!     end function poidev_real

!     FUNCTION gammln_real(xx)
!         implicit none
!         REAL gammln_real, xx
!         INTEGER j
!         DOUBLE PRECISION ser, stp, tmp, x, y, cof(6)
!         SAVE cof,stp
!         DATA cof, stp / 76.18009172947146d0, -86.50532032941677d0, 24.01409824083091d0, &
!              -1.231739572450155d0, 0.1208650973866179d-2, -0.5395239384953d-5, 2.5066282746310005d0/
!         x   = xx
!         y   = x
!         tmp = x + 5.5d0
!         tmp = (x + 0.5d0) * log(tmp) - tmp
!         ser = 1.000000000190015d0
!         do 11 j = 1, 6
!            y   = y + 1.d0
!            ser = ser +cof(j) / y
! 11         continue
!            gammln_real = real(tmp + log(stp * ser / x))
!            return
!         END function gammln_real

!         FUNCTION ran1_real()
!           implicit none
!           INTEGER IA,IM,IQ,IR,NTAB,NDIV
!           REAL ran1_real,AM,EPS,RNMX
!           PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836,&
!           NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
!           INTEGER j,k,iv(NTAB),iy
!           SAVE iv,iy
!           DATA iv /NTAB*0/, iy /0/
!           if (idum.le.0.or.iy.eq.0) then
!              idum=max(-idum,1)
!              do 11 j=NTAB+8,1,-1
!                 k=idum/IQ
!                 idum=IA*(idum-k*IQ)-IR*k
!                 if (idum.lt.0) idum=idum+IM
!                 if (j.le.NTAB) iv(j)=idum
! 11              continue
!                 iy=iv(1)
!              endif
!              k=idum/IQ
!              idum=IA*(idum-k*IQ)-IR*k
!              if (idum.lt.0) idum=idum+IM
!              j=1+iy/NDIV
!              iy=iv(j)
!              iv(j)=idum
!              ran1_real=min(AM*iy,RNMX)
!              return
!           END function ran1_real

!   end module rand_fun_real
! !----------------------------------------------------------------

! module rand
!   implicit none

!   public   :: funUniformSingle, funPoissonSingle

!   contains

!  !START Function definitions
! !Uniform function -- returns a standard uniform random variable
!   function funUniformSingle() result(randUni)
!     implicit none
!     real randUni
!     call random_seed
!     call random_number(randUni)
!   end function funUniformSingle

! !Poisson function -- returns a single Poisson random variable
!   function funPoissonSingle(lambda) result(randPoisson)
!     implicit none
!     real, intent(in) :: lambda !input
!     real :: exp_lambda !constant for terminating loop
!     real :: randUni !uniform variable
!     real :: prodUni !product of uniform variables
!     integer :: randPoisson !Poisson variable

!     !declare functions
!     real funUniformSingle

!     exp_lambda= exp(-lambda) !calculate constant

!     !initialize variables
!     randPoisson = -1
!     prodUni = 1
!     do while (prodUni > exp_lambda)
!        randUni = funUniformSingle() !generate uniform variable
!        prodUni = prodUni * randUni !update product
!        randPoisson = randPoisson + 1 !increase Poisson variable
!     end do
!   end function funPoissonSingle
! !END  Function definitions
! end module rand


! From:
!
!     http://icl.cs.utk.edu/lapack-for-windows/lapack/
!

program main

	integer, parameter :: n=2, lda=2, nrhs=1, ldb=2

	double precision :: a(lda,n), b(ldb,nrhs)

	integer :: ipiv(n), info, i, j

	a(1,1) = 1
	a(1,2) = 2
	a(2,1) = 3
	a(2,2) = 4

	b(1,1) = 5
	b(2,1) = 6

	print *, "Hello world"

	! Solve linear system a*x = b, for x
	call dgesv(n, nrhs, a, lda, ipiv, b, ldb, info)

	print *, "info = ", info
	print *, "a (factored) = ", a

	! Expected output: x = -4.0  4.5
	print *, "x = ", b

	print *, "done main"

end program main


    program demo_tan
    use, intrinsic :: iso_fortran_env, only : real_kinds, &
    & real32, real64, real128
    implicit none
    real(kind=real64) :: x = 0.165_real64
         write(*,*)x, tan(x)
    end program demo_tan


function our_noise(ips)

USE DFPORT

common/histo/istep,xconv(2000),xdir1,xdir2,dxdir
common/noise_1/a_rand(2),xmid(2)

our_noise=0

x = RAND()
do ii=1,istep-1
	x1=xdir1+dxdir*(ii-1)
	x2=xdir1+dxdir*ii
	if(x.lt.x1.or.x.ge.x2) cycle
	y1=xconv(ii)
	y2=xconv(ii+1)
	y=y1+((y2-y1)/(x2-x1))*(x-x1)
	!write(*,*)' y=',y
	goto 16
end do

write(*,*)' x=',x,' istep=',istep,' dxdir=',dxdir
write(*,*)' xconv(1)=',xconv(1),' xconv(istep)=',xconv(istep)
write(*,*)' xdir1=',xdir1,' xdir2=',xdir2
stop

16 continue

our_noise = xmid(ips) + y * a_rand(ips)

return
end


      PROGRAM TB0101

      IMPLICIT NONE

* DOUBLE PRECISION TABLE
      DOUBLE PRECISION  DH(15), D4(15), D5(15)
* SINGLE PRECISION TABLE
      REAL              SH(15), S4(15), S5(15)

* DUMMIES
      INTEGER I

* DATA DECLARATION
      DATA DH / 0.5D-0, 0.2D-0, 0.1D-0, 0.5D-1, 0.2D-1, 0.1D-1,
     $          0.5D-2, 0.2D-2, 0.1D-2, 0.5D-3, 0.2D-3, 0.1D-3,
     $          0.5D-4, 0.2D-4, 0.1D-4 /
      DATA SH / 0.5E-0, 0.2E-0, 0.1E-0, 0.5E-1, 0.2E-1, 0.1E-1,
     $          0.5E-2, 0.2E-2, 0.1E-2, 0.5E-3, 0.2E-3, 0.1E-3,
     $          0.5E-4, 0.2E-4, 0.1E-4 /

* FILE OF WRITTEN FILE
      OPEN (11, FILE = '01-01.txt')

*----------------------------------------------------------------------

* ERROR CALCULATION
      DO 10 I = 1, 15
*   SINGLE ERROR CALCULATION
        S4(I) = ( SIN(1.0E0 + SH(I)) - 2.0E0 * SIN(1.0E0)
     $            + SIN(1.0E0 - SH(I)) )
     $          / ( SH(I) * SH(I) ) + SIN(1.0E0)
        S5(I) = ( - SIN(1.0E0 - 2.0E0 * SH(I))
     $            + 16.0E0 * SIN(1.0E0 - SH(I))
     $            - 30.0E0 * SIN(1.0E0)
     $            + 16.0E0 * SIN(1.0E0 + SH(I))
     $            - SIN(1.0E0 + 2.0E0 * SH(I)) )
     $          / ( 12.0E0 * SH(I) * SH(I) ) + SIN(1.0E0)
*   DOUBLE ERROR CALCULATION
        D4(I) = ( DSIN(1.0D0 + DH(I)) - 2.0D0 * DSIN(1.0D0)
     $            + DSIN(1.0D0 - DH(I)) )
     $          / ( DH(I) * DH(I) ) + DSIN(1.0D0)
        D5(I) = ( - DSIN(1.0D0 - 2.0D0 * DH(I))
     $            + 16.0D0 * DSIN(1.0D0 - DH(I))
     $            - 30.0D0 * DSIN(1.0D0)
     $            + 16.0D0 * DSIN(1.0D0 + DH(I))
     $            - DSIN(1.0D0 + 2.0D0 * DH(I)) )
     $          / ( 12.0D0 * DH(I) * DH(I) ) + DSIN(1.0D0)

  10  CONTINUE

* DOUBLE ERROR TABLE

      WRITE (11,*)
      WRITE (11,35) '2nd Derivate Single Precision Error Table'
      WRITE (11,*)

      WRITE (11,15) '----------' , '---------------', '---------------'
      WRITE (11,15) '     h    ' , '        4-Point', '        5-Point'
      WRITE (11,15) '----------' , '---------------', '---------------'

      DO 20 I = 1, 15
        WRITE (11,25) SH(I), S4(I), S5(I)
  20  CONTINUE

      WRITE (11,15) '----------' , '---------------', '---------------'

* DOUBLE ERROR TABLE

      WRITE (11,*)
      WRITE (11,35) '2nd Derivate Double Precision Error Table'
      WRITE (11,*)

      WRITE (11,15) '----------' , '---------------', '---------------'
      WRITE (11,15) '     h    ' , '        4-Point', '        5-Point'
      WRITE (11,15) '----------' , '---------------', '---------------'

      DO 30 I = 1, 15
        WRITE (11,25) DH(I), D4(I), D5(I)
  30  CONTINUE

      WRITE (11,15) '----------' , '---------------', '---------------'

* FORMAT
  15  FORMAT (10A, 2(15A))
  25  FORMAT (F10.5, 2(3X, F12.8))
  35  FORMAT (50A)

      END PROGRAM TB0101


!---------------------------------------------------------------------------------------------------
!
!	filename = main.f90
!	authors = Edison Salazar
!		  Pedro Guarderas
!	date = 01/08/2013
!
!---------------------------------------------------------------------------------------------------

!---------------------------------------------------------------------------------------------------
!
! Main program
!
!---------------------------------------------------------------------------------------------------
program principal

  use atomic
  use consts
  use coupling
  use grid
  use linear
  use plotting
  use quad

!---------------------------------------------------------------------------------------------------
!
! Atomic parameters
!
!  m   : Total number of bases
!  n   : Number of orbitals by type
!  l   : Second Quantic numbers for every type of orbital
!  c   : Coefficients for the bases
!  nc  : Principal quantic number for all the base orbitals
!  e   : Coefficients for the base orbitals
!  ne  : Quantity of electrons for every orbital
!  d   : Quantity of coefficients for kind of orbital, starting in the second component
!
!---------------------------------------------------------------------------------------------------

  character( len = 100 ) :: infile
  integer :: n, m, Nr
  integer, allocatable :: d(:)
  double precision, allocatable :: l(:), c(:), nc(:), e(:), ne(:)
  double precision, allocatable :: DFT(:,:), T(:,:), y(:), p(:), r(:)
  double precision, dimension(3) :: Ct, W, J
  double precision :: Tapp

!---------------------------------------------------------------------------------------------------
! Reading parameters
  write(*,*) "Reading file with parameters"
  call getarg( 1, infile )

  open( unit = 10, file = infile )

  read( 10, * ) n
  read( 10, * ) m

  allocate( l(n), c(m), nc(m), e(m), ne(n), d(n+1), y(m) )

  read( 10, * ) l
  read( 10, * ) c
  read( 10, * ) nc
  read( 10, * ) e
  read( 10, * ) ne
  read( 10, * ) d

! Paramaters for homogeneous approximation
  Ct = (/ 3.26422D0, -0.02631D0, 0.000498D0 /)
  W = (/ 5.0D0/3.0D0, 4.0D0/3.0D0, 11.0D0/9.0D0 /)
  J = (/ 1.0D0, 2.0D0, 3.0D0 /)

!---------------------------------------------------------------------------------------------------
! Grid generations
  Nr = 1000
  write(*,*) "Building radial mesh with size: ", Nr
  allocate( r(Nr), p(Nr) )
  call grid_adap_exp( r, Nr, 5.0D0, 5.0D0 )
  !call grid_unif( r, Nr, 0.0D0, 5.0D0 )

!---------------------------------------------------------------------------------------------------
  write(*,*) "DFT computations"

  allocate( T(m,m), DFT(m,m) )

  write(*,*) "Building DFT matrices"
  call buildKS( DFT, T, nc, e, ne, l, d, n, m )

  write(*,*) "Computing exact kinetic energy"
  open( unit = 14, file = 'results.data' )
  call MatMulVec( y, T, c, m, m )
  write(14,*) "Exact integral of the kinetic energy T: ", scalar( y, c, m )

  write(*,*) "Computing exact density"
  call MatMulVec( y, DFT, c, m, m )
  write(14,*) "Exact integral of density: ", scalar( y, c, m )

  write(*,*) "Computing radial density"
  call radialDFT( p, r, Nr, c, nc, e, ne, d, n, m )

  write(*,*) "Computing Kinectic Energy approximation"
  call HomogeneousApprox( Tapp, Ct, W, J, p, r, Nr, 3 )
  write(14,*) "Kinectic Energy approximation: ",  Tapp
  close( unit = 14 )

!---------------------------------------------------------------------------------------------------
  write(*,*) "Writing results in *.data files"

  write(*,*) "Writing kinetic energy"
  open( unit = 15, file = "kinetic.data" )
  call WriteMatrix( 15, T, m, m )
  close( unit = 15 )

  write(*,*) "Writing density matrix"
  open( unit = 16, file = "density.data" )
  call WriteMatrix( 16, DFT, m, m )
  close( unit = 16 )

  write(*,*) "Writing radial grid"
  open( unit = 17, file = "radial_grid.data" )
  call WriteVector( 17, r, Nr )
  close( unit = 17 )

  write(*,*) "Writing radial density"
  open( unit = 18, file = "radial_density.data" )
  call WriteVector( 18, p, Nr )
  close( unit = 18 )

!---------------------------------------------------------------------------------------------------
  write(*,*) "Plotting"
  call contour( T, m, m, 0.0, real(m), 10, 0.0, real(m), 10, -446.843, 220.607, 10, 1 )
  call contour( DFT, m, m, 0.0, real(m), 10, 0.0, real(m), 10, 0.0, 3.0, 10, 1 )

!---------------------------------------------------------------------------------------------------
  deallocate( l, c, nc, e, ne, d )
  deallocate( T, DFT, y )
  deallocate( r, p )

  stop

end program principal


module problem_data

  use mfe_constants, only: wp
  private

  public :: c_of_u, u_of_c

  real(kind=wp), parameter, public :: D0 = 7.3e-8, D1 = 1.17e-7, ni = 7.12e18

  real(kind=wp), save, public :: mu, t_scale, u_scale, u_shift, c_min, c_max

  contains

   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   !!
   !!  C_OF_U -- Compute c(u).
   !!
   !!  Using a Newton iteration, this routine inverts the function
   !!
   !!	U(C) = (C/MU + log(C/MU) - U_SHIFT) / U_SCALE.
   !!
   !!  This is done by writing
   !!
   !!	U_SCALE * U + U_SHIFT = (C/MU) + log(C/MU)
   !!
   !!  and then inverting the function y = x + log(x).
   !!
   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    function c_of_u (u) result (c)

      real(kind=wp), dimension(:), intent(in) :: u
      real(kind=wp), dimension(size(u)) :: c, y

      integer :: k
      integer, parameter :: NITR = 4

      y = u_scale * u + u_shift

      where (y < 1.0_wp)
        c = exp(y - 1.0_wp)
      elsewhere
        c = y
      end where

      y = y + 1.0_wp

      do k = 1, NITR
        c = c * (y - log(c)) / (1.0_wp + c)
      end do

      c = mu * c

    end function c_of_u

    function u_of_c (c) result (u)

      real(kind=wp), dimension(:), intent(in) :: c
      real(kind=wp), dimension(size(c)) :: u

      u = ((c/mu) + log(c/mu) - u_shift) / u_scale

    end function u_of_c

end module problem_data

module problem_init

  use mfe_constants, only: wp
  use problem_data
  use common_io
  private

  public :: read_problem_data

  contains

   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   !!
   !!  READ_PROBLEM_DATA
   !!
   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    subroutine read_problem_data ()

      call read_tagged_data (mu, "Transformation parameter MU")
      call read_tagged_data (c_min, "Minimum concentration (for transf)")
      call read_tagged_data (c_max, "Maximum concentration (for transf)")

      c_min = c_min / (2.0_wp * ni)
      c_max = c_max / (2.0_wp * ni)

    end subroutine read_problem_data

end module problem_init

module problem_pde

  use mfe_constants, only: wp
  use problem_data
  use local_arrays
  use local_laplacian
  private

  public :: pde_rhs

  contains

   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   !!
   !!  PDE_RHS --
   !!
   !!  RHS inner products for Kent Smith's arsenic diffusion problem,
   !!  using the transformation
   !!
   !!     USCF*U(x,T) + GAMMA = C(x,t)/MU + log(C(x,t)/MU)
   !!
   !!  where C(x,t) is the scaled concentration of arsenic, USCF is
   !!  the scaling factor for U and the scaled time T = t/TSCF.  The
   !!  equation for U is
   !!
   !!     dU/dT = TSCF*A(C)*Lapl(U) + (TSCF*USCF)*B(C)*|Grad(U)|**2
   !!
   !!  where
   !!
   !!     A(C) = N(C)*(D0 + D1*N(C))/sqrt(1 + C**2)
   !!
   !!              C*A'(C)        A(C)
   !!     B(C) = ---------- + -------------
   !!            (1 + C/MU)   (1 + C/MU)**2
   !!
   !!     N(C) = C + sqrt(1 + C**2)
   !!
   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    subroutine pde_rhs (t)

      real(kind=wp), intent(in) :: t

      real(kind=wp) :: fac
      real(kind=wp), dimension(2,nelt) :: visc
      real(kind=wp), dimension(nelt) :: b_phi_1, b_phi_2

      ! 3pt gaussian quadrature parameters
      real(kind=wp), parameter :: w1 = 0.2464717596168727_wp,  &
                                  w2 = 0.2222222222222222_wp,  &
                                  w3 = 0.03130601816090511_wp, &
                                  c1 = 0.8872983346207417_wp,  &
                                  c2 = 0.1127016653792583_wp

      fac = u_scale * t_scale

      b_phi_1 = w1 * b_of_u (c1 * u(1,:) % u + c2 * u(2,:) % u)  + &
                w2 * b_of_u (0.5_wp * (u(1,:) % u + u(2,:) % u)) + &
                w3 * b_of_u (c2 * u(1,:) % u + c1 * u(2,:) % u)

      b_phi_2 = w3 * b_of_u (c1 * u(1,:) % u + c2 * u(2,:) % u)  + &
                w2 * b_of_u (0.5_wp * (u(1,:) % u + u(2,:) % u)) + &
                w1 * b_of_u (c2 * u(1,:) % u + c1 * u(2,:) % u)

      r(1,:) % x = ((fac * dx * dudx**2) * b_phi_1) * n % x
      r(1,:) % u = ((fac * dx * dudx**2) * b_phi_1) * n % u

      r(2,:) % x = ((fac * dx * dudx**2) * b_phi_2) * n % x
      r(2,:) % u = ((fac * dx * dudx**2) * b_phi_2) * n % u

      visc(1,:) = t_scale * a_of_u (u(1,:) % u)
      visc(2,:) = t_scale * a_of_u (u(2,:) % u)

      call laplacian (coef=visc)

    end subroutine pde_rhs

    function a_of_u (u) result (a)

      real(kind=wp), dimension(:), intent(in) :: u
      real(kind=wp), dimension(size(u)) :: a

      real(kind=wp), dimension(size(u)) :: c, r

      c = c_of_u (u)
      r = sqrt(1.0_wp + c**2)
      a = (c + r) * (D0 + D1 * (c + r)) / r

    end function a_of_u

    function b_of_u (u) result (b)

      real(kind=wp), dimension(:), intent(in) :: u
      real(kind=wp), dimension(size(u)) :: b

      real(kind=wp), dimension(size(u)) :: c, r

      c = c_of_u (u)
      r = sqrt(1.0_wp + c**2)
      b = ( (c + r) * (D0 + D1 * (c + r)) / (1.0_wp + c/mu) + &
            (D0 + D1 * (c + r)**2 * (2.0_wp * r - c)) / (1.0_wp + c**2) ) &
          / (r * (1.0_wp + c/mu))

    end function b_of_u

end module problem_pde


! $UWHPSC/codes/mpi/matrix1norm1.f90
!
! Compute 1-norm of a matrix using mpi.
! Process 0 is the master that sets things up and then sends a column
! to each worker (Processes 1, 2, ..., num_procs - 1).
!
! This version assumes there are at least as many workers as columns.

program matrix1norm1

    use mpi

    implicit none

    integer :: i,j,jj,nrows,ncols,proc_num, num_procs,ierr,nerr
    integer, dimension(MPI_STATUS_SIZE) :: status
    real(kind=8) :: colnorm
    real(kind=8), allocatable, dimension(:,:) :: a
    real(kind=8), allocatable, dimension(:) :: anorm, colvect

    call MPI_INIT(ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, proc_num, ierr)

    nerr = 0
    if (proc_num==0) then
        print *, "Input nrows, ncols"
        read *, nrows, ncols
        if (ncols > num_procs-1) then
            print *, "*** Error, this version requires ncols < num_procs = ",&
                  num_procs
            nerr = 1
            endif
        allocate(a(nrows,ncols))  ! only master process 0 needs the matrix
        a = 1.d0  ! initialize to all 1's for this test
        allocate(anorm(ncols))    ! to hold norm of each column in MPI_RECV
        endif

    ! if nerr == 1 then all processes must stop:
    call MPI_BCAST(nerr, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)

    if (nerr == 1) then
        ! Note that error message already printed by Process 0
        ! All processes must execute the MPI_FINALIZE
        ! (Could also just have "go to 99" here.)
        call MPI_FINALIZE(ierr)
        stop
        endif

    call MPI_BCAST(nrows, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
    call MPI_BCAST(ncols, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)

    if (proc_num > 0) then
        allocate(colvect(nrows))   ! to hold a column vector sent from master
        endif

    ! -----------------------------------------
    ! code for Master (Processor 0):
    ! -----------------------------------------

    if (proc_num == 0) then

      do j=1,ncols
        call MPI_SEND(a(1,j), nrows, MPI_DOUBLE_PRECISION,&
                        j, j, MPI_COMM_WORLD, ierr)
        enddo

      do j=1,ncols
        call MPI_RECV(colnorm, 1, MPI_DOUBLE_PRECISION, &
                        MPI_ANY_SOURCE, MPI_ANY_TAG, &
                        MPI_COMM_WORLD, status, ierr)
        jj = status(MPI_TAG)
        anorm(jj) = colnorm
        enddo

      print *, "Finished filling anorm with values... "
      print *, anorm
      print *, "1-norm of matrix a = ", maxval(anorm)
      endif

    ! -----------------------------------------
    ! code for Workers (Processors 1, 2, ...):
    ! -----------------------------------------
    if (proc_num /= 0) then

        if (proc_num > ncols) go to 99   ! no work expected

        call MPI_RECV(colvect, nrows, MPI_DOUBLE_PRECISION,&
                      0, MPI_ANY_TAG, &
                      MPI_COMM_WORLD, status, ierr)

        j = status(MPI_TAG)   ! this is the column number
                              ! (should agree with proc_num)

        colnorm = sum(abs(colvect))

        call MPI_SEND(colnorm, 1, MPI_DOUBLE_PRECISION, &
                    0, j, MPI_COMM_WORLD, ierr)

        endif

99  continue   ! might jump to here if finished early
    call MPI_FINALIZE(ierr)

end program matrix1norm1


! this mod is used to find the x in Ax=b
! you should make sure that A is a stmmetrical matrix
MODULE cgm_mod
    IMPLICIT NONE
    PRIVATE
    PUBLIC:: CGM
CONTAINS
    SUBROUTINE CGM(A,b,x)
        INTEGER(8)::n,i,ii
        REAL(8),PARAMETER ::delta = 1.0E-5
        REAL(8)::alpha,oldnorm,beta
        REAL(8),DIMENSION(:,:),INTENT(IN):: A
        REAL(8),DIMENSION(:,:),INTENT(IN):: b
        REAL(8),DIMENSION(:,:),INTENT(INOUT)::x
        REAL(8),ALLOCATABLE::r(:,:)
        REAL(8),ALLOCATABLE::d(:,:)
        REAL(8),ALLOCATABLE::r1(:)
        REAL(8)::rtr(1,1),dtad(1,1)

        n=size(A,1)
        ALLOCATE(r(n,1))
        ALLOCATE(d(n,1))
        ALLOCATE(r1(n))

        !step 0:
        r=b-MATMUL(A,x)
        d=r
        r1(1:n)=r(1:n,1)
        DO i=0,n-1
            rtr=MATMUL(transpose(r),r)
            dtad=MATMUL(transpose(d),MATMUL(A,d))
            alpha=rtr(1,1)/dtad(1,1)
            x=x+alpha*d
            oldnorm=NORM2(r1)
            r=b-MATMUL(A,x)
            r1(1:n)=r(1:n,1)
            IF(NORM2(r1)<=delta .OR. i+1==n) EXIT
            beta=NORM2(r1)*NORM2(r1)/(oldnorm*oldnorm)
            d=r+beta*d
        END DO
        DEALLOCATE(r)
        DEALLOCATE(d)
        DEALLOCATE(r1)
    END SUBROUTINE CGM
END MODULE


      SUBROUTINE AF (F,N,A,B,C,C1,C2,C3,T1,T3,T5,JUMP)
C
C     THIS AREA INTEGRATION ROUTINE IS USED IN TRIM6, TRPLT1 AND TRSHL
C     IT COMPUTES THE F FUNCTION, AND CONSTANTS C1, C2, C3
C
C     FAC ARE THE FACTORIALS 1 THRU 36
C     B   IS  DISTANCE OF GRID POINT 1
C     A   IS  DISTANCE OF GRID POINT 3
C     C   IS  DISTANCE OF GRID POINT 5
C     T1  IS  ASSOCIATIVE VARIABLE AT GRID POINT 1
C     T3  IS  ASSOCIATIVE VARIABLE AT GRID POINT 3
C     T5  IS  ASSOCIATIVE VARIABLE AT GRID POINT 5
C     N   IS  DIMENSION OF AREA FUNCTION F
C
C
C
      REAL             F(N,N)
      DOUBLE PRECISION FAC(20), TEMP
      DATA FAC / 1.D0,1.D0, 2.D0,6.D0, 2.4D1,  1.2D2, 7.2D2, 5.04D3,
     1           4.032D4,       3.6288D5,     3.6288D6,     3.99168D7,
     2           4.790016D8,    6.227021D9,   8.7178291D10, 1.307674D12,
     3           2.092279D13,   3.556874D14,  6.402374D15,  1.216451D17/
C
      IF (JUMP .GT. 0) GO TO 30
      IF (N .GT. 18) STOP 'IN AF'
      DO 10 I=1,N
      DO 10 J=1,N
 10   F(I,J)=0.0
      DO 20 I=1,N
      I1=I
      DO 15 J=1,I
      TEMP = DBLE(C**J) * FAC(I1) / FAC(I+2)
      TEMP = DBLE(A**I1-(-B)**I1) * TEMP * FAC(J)
      F(I1,J) = SNGL(TEMP)
      I1=I1-1
 15   CONTINUE
 20   CONTINUE
      IF (JUMP .LT. 0) RETURN
C
 30   AB=A-B
      IF (A .EQ. B .AND. A .NE. 0.0) AB=A+B
      IF (AB .EQ. 0.0) CALL MESAGE (-37,0,0)
      C1=(T1*A-T3*B)/AB
      C2=(T3-T1)/AB
      C3=(T5-C1)/C
      RETURN
      END


5.
5.+3.
(5.+3.)*2.
5.+3.*2.
5.-3.
4.**3.


module lr_lib
 use ort_lib
 implicit none

 interface lr
  module procedure lr_d2
 end interface

 contains
 subroutine lr_d2(a,u,b,tol,maxr,err)
  implicit none
  double precision,intent(in) :: a(:,:)
  double precision,pointer :: u(:,:),b(:,:)
  double precision,intent(in),optional :: tol
  integer,intent(in),optional :: maxr
  double precision,intent(out),optional :: err
  character(len=*),parameter :: subnam='lr_d2'
  double precision,allocatable :: x(:,:),y(:,:),z(:,:),g(:,:),v(:)
  integer,allocatable :: q(:)
  integer :: m,n,mn,i,j,jj,ij(2),rmax,r,info
  double precision :: er,nrm,nr1,er1,zz,xx
  logical :: done
  double precision,external :: dnrm2
  integer,external :: idamax

  m=size(a,1); n=size(a,2); mn=min(m,n)
  if(present(maxr))then;if(maxr.ge.0)then;rmax=min(maxr,mn);else;rmax=mn;endif; else;rmax=mn;end if

  allocate(x(m,rmax),y(n,rmax),z(m,n),v(n),q(n), stat=info)
  if(info.ne.0)then;write(*,*)subnam,': not enough memory!';stop;endif

  call dcopy(m*n,a,1,z,1)
  nrm=dnrm2(m*n,a,1); er=nrm; nr1=-1.d0
  r=0; done=(r.ge.rmax)

  do while(.not.done)
!   ij=maxloc(abs(z)); i=ij(1); j=ij(2)
!...OMP parallel do shared(z,q,v,m,n)
   do jj=1,n
    q(jj)=idamax(m,z(1,jj),1); v(jj)=abs(z(q(jj),jj))
   end do
!...OMP END parallel do
   j=maxloc(v,1); i=q(j); zz=z(i,j); er1=dabs(zz)
   if(r.eq.0)nr1=er1
   r=r+1
   call dcopy(m,z(1,j),1,x(1,r),1); xx=dnrm2(m,x(1,r),1); call dscal(m,1.d0/xx,x(1,r),1)
   call dcopy(n,z(i,1),m,y(1,r),1); call dscal(n,xx/zz,y(1,r),1)
   call dger(m,n,-1.d0,x(1,r),1,y(1,r),1,z,m)
   er=dnrm2(m*n,z,1)
   done=r.eq.rmax
   if(present(tol))done=done.or.er.le.tol*nrm

   !write(*,'(i3,a,2i6,a,2e10.3)')r,' @ ',i,j,' er ',er/nrm,er1/nr1
  end do

  allocate(u(m,r),b(r,n),g(r,r), stat=info)
  if(info.ne.0)then;write(*,*)subnam,': not enough memory!';stop;endif

  call ort0(x(:,1:r),out=u,mat=g)
  call dgemm('n','t',r,n,r,1.d0,g,r,y,n,0.d0,b,r)
!-
!  call dcopy(m*n,a,1,z,1)
!  call dgemm('n','n',m,n,r,-1.d0,u,m,b,r,1.d0,z,m)
!  er=dnrm2(m*n,z,1)
!  write(*,*) 'truerr : ',er/nrm
!-
  deallocate(x,y,z,v,q,g)
  if(present(err))err=er/nrm
 end subroutine
end module


      program main

c*********************************************************************72
c
cc MAIN is the main program for BROWNIAN_MOTION_SIMULATION_PRB.
c
c  Discussion:
c
c    BROWNIAN_MOTION_SIMULATION_PRB tests the BROWNIAN_MOTION_SIMULATION library.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 September 2012
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer k
      parameter ( k = 40 )
      integer m_max
      parameter ( m_max = 3 )
      integer n
      parameter ( n = 1001 )

      double precision d
      double precision dsq(k,n)
      character * ( 80 ) header
      integer m
      integer seed
      double precision t
      double precision x(m_max,n)

      call timestamp ( )
      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'BROWNIAN_MOTION_SIMULATION_PRB'
      write ( *, '(a)' ) '  FORTRAN77 version'
      write ( *, '(a)' )
     &  '  Test the BROWNIAN_MOTION_SIMULATION library.'
c
c  Compute the path of a particle undergoing Brownian motion.
c
      do m = 1, 2

        d = 10.0D+00
        t = 1.0D+00
        seed = 123456789
        call brownian_motion_simulation ( m, n, d, t, seed, x )
        if ( m .eq. 1 ) then
          header = 'motion_1d'
        else if ( m .eq. 2 ) then
          header = 'motion_2d'
        end if
        call brownian_motion_display ( m, n, x, header )

      end do
c
c  Estimate the average displacement of the particle from the origin
c  as a function of time.
c
      do m = 1, 3

        d = 10.0D+00
        t = 1.0D+00
        seed = 123456789

        call brownian_displacement_simulation ( k, n, m, d, t, seed,
     &    dsq )
        if ( m .eq. 1 ) then
          header = 'displacement_1d'
        else if ( m .eq. 2 ) then
          header = 'displacement_2d'
        else if ( m .eq. 3 ) then
          header = 'displacement_3d'
        end if
        call brownian_displacement_display ( k, n, d, t, dsq, header )

      end do
c
c  Terminate.
c
      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'BROWNIAN_MOTION_SIMULATION_PRB'
      write ( *, '(a)' ) '  Normal end of execution.'
      write ( *, '(a)' ) ''
      call timestamp ( );

      return
      end


	SUBROUTINE FITSLOPE(X,Y,N,SLOPE,SUMSQ)
C
	DIMENSION X(1),Y(1),WT(2048)
C
	SUMSQ = 0.
	SXX = 0.
	SXY = 0.
	SYY = 0.
	DO J = 1,N
	  WT(J) = 1.
	  SXX =SXX + WT(J)*X(J)**2
	  SXY =SXY + WT(J)*X(J)*Y(J)
	  SYY =SYY + WT(J)*Y(J)**2
	ENDDO
C	SLOPE IS Y/X
	SLOPE = SXY/SXX
	SUMSQ = SXX*SLOPE**2 - 2.*SLOPE*SXY + SYY
	RETURN
	END


c=======================================================================
      subroutine ptdensityu(ngrid,nrec,y,
     &                      ab,murand,sigmarand,jfr,m0,s0,tau,
     &                      mcmcvec,nsave,tune1,tune2,tune3,
     &                      acrate,f,thetasave,cpo,
     &                      cpar,mu,sigma,
     &                      grid,seed,whicho,whichn)
c=======================================================================
c
c     Subroutine `ptdensityu' to run a Markov chain for univariate
c     density estimation using a Mixture of Polya Tree prior. The
c     Polya Tree is centered in a N(mu,sigma2) distribution.
c
c     Copyright: Alejandro Jara, 2006-2010.
c
c     Version 3.0:
c
c     Last modification: 25-01-2009.
c
c     Changes and Bug fixes:
c
c     Version 2.0 to Version 3.0:
c          - Centering parameters can be fixed.
c          - Proper prior can be used on the centering parameters.
c
c     Version 1.0 to Version 2.0:
c          - Uses vectors to keep the observations in each partition.
c
c     This program is free software; you can redistribute it and/or modify
c     it under the terms of the GNU General Public License as published by
c     the Free Software Foundation; either version 2 of the License, or (at
c     your option) any later version.
c
c     This program is distributed in the hope that it will be useful, but
c     WITHOUT ANY WARRANTY; without even the implied warranty of
c     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
c     General Public License for more details.
c
c     You should have received a copy of the GNU General Public License
c     along with this program; if not, write to the Free Software
c     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
c
c     The author's contact information:
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c---- Data -------------------------------------------------------------
c
c        ngrid       :  integer giving the size of the grid where
c                       the density estimate is evaluated.
c        nrec        :  integer giving the number of observations.
c        y           :  real vector giving the response variables,
c                       y(nrec).
c
c-----------------------------------------------------------------------
c
c---- Prior information ------------------------------------------------
c
c        ca, cb      :  real giving the hyperparameters of the prior
c                       distribution for the precision parameter,
c                       c ~ Gamma(ca,cb). If ca<0 the precision
c                       parameter is considered as a constant.
c        jfr         :  integer vector indicating whether Jeffery's
c                       prior is used for the centering parameters.
c        m0          :  real giving the mean of the normal prior
c                       for the centering mean.
c        s0          :  real giving the variance of the normal prior
c                       for the centering mean.
c        tau         :  real vector giving the hyperparameters of
c                       inverse gamma prior for the centering variance.
c
c-----------------------------------------------------------------------
c
c---- MCMC parameters --------------------------------------------------
c
c        nburn       :  integer giving the number of burn-in scans.
c        ndisplay    :  integer giving the number of saved scans to be
c                       displayed on screen.
c        nskip       :  integer giving the thinning interval.
c        nsave       :  integer giving the number of scans to be saved.
c        tune1       :  real giving the tuning parameter for MH of
c                       mean baseline.
c        tune2       :  real giving the tuning parameter for MH of
c                       variance baseline.
c        tune3       :  real giving the tuning parameter for MH of
c                       precision parameter.
c
c-----------------------------------------------------------------------
c
c---- Output -----------------------------------------------------------
c
c        acrate      :  real vector giving the MH acceptance rate,
c                       acrate(3).
c        f           :  real vector giving the density estimate at the
c                       grid, f(ngrid).
c        thetasave   :  real vector containing the mcmc sample for the
c                       parameters, betsave(nsave,3).
c        cpo         :  real giving the cpo, cpo(nrec).
c
c-----------------------------------------------------------------------
c
c---- Current value of the parameters ----------------------------------
c
c        cpar        :  real giving the current value of the precision
c                       parameter of the Polya Tree.
c        mu          :  real giving the current value of the
c                       baseline mean.
c        sigma       :  real giving the he current value of the
c                       baseline standard deviation.
c
c-----------------------------------------------------------------------
c
c---- Working space ----------------------------------------------------
c
c        cdfnorm     :  cdf of a normal distribution.
c        cparc       :  real giving the value of the candidate
c                       for the precision parameter.
c        dispcount   :  index.
c        dlnrm       :  density of a log-normal distribution.
c        dnrm        :  density of a normal distribution.
c        grid        :  real vector giving the grid where the density
c                       estimate is evaluated, grid(ngrid) .
c        i           :  index.
c        invcdfnorm  :  quantile function for a normal distribution.
c        isave       :  index.
c        iscan       :  index.
c        j           :  index.
c        je2         :  index.
c        k           :  index.
c        k1          :  index.
c        k2          :  index.
c        logcgkn     :  real working variable.
c        logcgko     :  real working variable.
c        loglikn     :  real working variable.
c        logliko     :  real working variable.
c        logpriorn   :  real working variable.
c        logprioro   :  real working variable.
c        muc         :  real giving the value of the candidate
c                       for the baseline mean.
c        nscan       :  index.
c        parti       :  index.
c        pprn        :  index.
c        quan        :  real working variable.
c        ratio       :  real working variable.
c        rbeta       :  real beta random number generator.
c        rtlnorm     :  real truncated log normal random number generator.
c        rnorm       :  real normal random number generator.
c        runif       :  real uniform random number generator.
c        s           :  real giving the sample variance.
c        sec         :  cpu time working variable.
c        sec0        :  cpu time working variable.
c        sec00       :  cpu time working variable.
c        sec1        :  cpu time working variable.
c        seed1       :  seed for random number generation.
c        seed2       :  seed for random number generation.
c        sigmac      :  real giving the value of the candidate
c                       for the baseline standard deviation.
c        sigma2      :  real giving the current value of
c                       the baseline variance.
c        sigma2c     :  real giving the value of the candidate
c                       for the baseline variance.
c        skipcount   :  index.
c        sprint      :  integer function to print on screen.
c        tmp1        :  real used to accumulate quantities.
c        tmp2        :  real used to accumulate quantities.
c        whicho      :  integer vector giving the observation in each
c                       partition, whicho(nrec).
c        whichn      :  integer vector giving the observation in each
c                       partition, whichn(nrec).
c        ybar        :  real giving the sample mean.
c
c=======================================================================
      implicit none

c+++++Data
      integer ngrid,nrec
      real*8 y(nrec)

c+++++Prior information
      real*8 ab(2),ca,cb
      integer murand,sigmarand,jfr(2)
      real*8 m0,s0
      real*8 tau(2)

c+++++MCMC parameters
      integer mcmcvec(3),nburn,nskip,nsave,ndisplay
      real*8 tune1,tune2,tune3

c+++++Stored output
      real*8 acrate(3),f(ngrid)
      real*8 thetasave(nsave,3)
      real*8 cpo(nrec)

c+++++Current values of the parameters
      real*8 cpar,mu,sigma

c+++++Working space - CPU time
      real*8 sec00,sec0,sec1,sec

c+++++Working space - Density
      real*8 grid(ngrid)

c+++++Working space - Distributions
      real*8 dnrm,dlnrm
      real*8 invcdfnorm

c+++++Working space - General
      integer countero,countern
      integer i,j,je2,k,k1,k2,l
      integer nint,ok,parti,pprn,sprint
      integer whicho(nrec),whichn(nrec)
      real*8 prob
      real*8 quan
      real*8 s,tmp1,tmp2,ybar

c+++++Working space - MCMC scans
      integer dispcount,isave,iscan,nscan,skipcount

c+++++Working space - MH steps
      real*8 cparc
      real*8 logcgkn,logcgko
      real*8 loglikn,logliko
      real*8 logpriorn,logprioro
      real*8 muc,sigma2,sigmac,sigma2c
      real*8 ratio

c+++++Working space - Random number generator
      integer seed(2),seed1,seed2
      real*8 rnorm,rtlnorm
      real runif

c++++ initialize variables
      nburn=mcmcvec(1)
      nskip=mcmcvec(2)
      ndisplay=mcmcvec(3)

      ca=ab(1)
      cb=ab(2)

      sigma2=sigma**2

c++++ set random number generator

      seed1=seed(1)
      seed2=seed(2)

      call setall(seed1,seed2)

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c++++ start the MCMC algorithm
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      isave=0
      skipcount=0
      dispcount=0
      nscan=nburn+(nskip+1)*(nsave)

      call cpu_time(sec0)
      sec00=0.d0

      ybar=0.d0
      s=0.d0
      do i=1,nrec
         ybar=ybar+y(i)
      end do
      ybar=ybar/dble(nrec)

      do i=1,nrec
         s=s+(y(i)-ybar)**2
      end do
      s=s/dble(nrec)

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c++++ First computation of loglikelihood (to reduce CPU time)
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      logliko=0.d0

      do i=1,nrec

c+++++++ check if the user has requested an interrupt
         call rchkusr()

c+++++++ first observation
         if(i.eq.1)then

            logliko=dnrm(y(1),mu, sigma, 1)

c+++++++ following observations
          else

            nint=2
            prob=1.d0/dble(nint)
            quan=invcdfnorm(prob,mu,sigma,1,0)

            countero=0

            if(y(i).le.quan) then
               parti=1
               do l=1,i-1
                  if(y(l).le.quan)then
                     countero=countero+1
                     whicho(countero)=l
                  end if
               end do
             else
               parti=2
               do l=1,i-1
                  if(y(l).gt.quan)then
                     countero=countero+1
                     whicho(countero)=l
                  end if
               end do
            end if

            logliko=logliko+
     &              log(2.d0*cpar+dble(2*countero))-
     &              log(2.d0*cpar+dble(i-1))

            if(countero.eq.0) go to 1

            ok=1
            j=2
            do while(ok.eq.1)
               nint=2**j
               je2=j**2
               prob=1.d0/dble(nint)

               k1=2*(parti-1)+1
               k2=2*(parti-1)+2
               quan=invcdfnorm(dble(k1)*prob,mu,sigma,1,0)

               if(y(i).le.quan)then
                 parti=k1
                 k=k1
                else
                 parti=k2
                 k=k2
               end if

               countern=0

               if(k.eq.1)then
                  do l=1,countero
                     if(y(whicho(l)).le.quan)then
                        countern=countern+1
                        whichn(countern)=whicho(l)
                     end if
                  end do
                else if(k.eq.nint)then
                  quan=invcdfnorm(dble(k-1)*prob,mu,sigma,1,0)
                  do l=1,countero
                     if(y(whicho(l)).gt.quan)then
                        countern=countern+1
                        whichn(countern)=whicho(l)
                     end if
                  end do
                else
                  tmp1=invcdfnorm(dble(k-1)*prob,mu,sigma,1,0)
                  tmp2=invcdfnorm(dble(k  )*prob,mu,sigma,1,0)

                  if(tmp1.ge.tmp2)then
                    call rexit("Error in the limits")
                  end if

                  do l=1,countero
                     if(y(whicho(l)).gt.tmp1.and.
     &                  y(whicho(l)).le.tmp2)then
                        countern=countern+1
                        whichn(countern)=whicho(l)
                     end if
                  end do
               end if

               logliko=logliko+
     &                  log(2.d0*cpar*dble(je2)+dble(2*countern))-
     &                  log(2.d0*cpar*dble(je2)+dble(  countero))

               if(countern.eq.0)then
                  ok=0
                else
                  countero=countern
                  do l=1,countern
                     whicho(l)=whichn(l)
                  end do
                  j=j+1
               end if
            end do

1           continue

            logliko=logliko+dnrm(y(i),mu,sigma,1)

         end if
      end do

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c++++ Scanning the posterior distribution
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      do iscan=1,nscan

c+++++++ check if the user has requested an interrupt
         call rchkusr()

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ Updating mu using a MH step                  +++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++

         if(murand.eq.1)then
            muc=rnorm(mu,tune1*sigma/sqrt(dble(nrec)))

            loglikn=0.d0

            do i=1,nrec

c+++++++++++++ check if the user has requested an interrupt
               call rchkusr()

c+++++++++++++ first observation
               if(i.eq.1)then

                  loglikn=dnrm(y(1),muc,sigma ,1)

c+++++++++++++ following observations
                 else

                  nint=2
                  prob=1.d0/dble(nint)
                  quan=invcdfnorm(prob,muc,sigma,1,0)

                  countero=0

                  if(y(i).le.quan) then
                     parti=1
                     do l=1,i-1
                        if(y(l).le.quan)then
                           countero=countero+1
                           whicho(countero)=l
                        end if
                     end do
                   else
                     parti=2
                     do l=1,i-1
                        if(y(l).gt.quan)then
                           countero=countero+1
                           whicho(countero)=l
                        end if
                     end do
                  end if

                  loglikn=loglikn+
     &                    log(2.d0*cpar+dble(2*countero))-
     &                    log(2.d0*cpar+dble(i-1))

                  if(countero.eq.0) go to 2

                  ok=1
                  j=2
                  do while(ok.eq.1)
                     nint=2**j
                     je2=j**2
                     prob=1.d0/dble(nint)

                     k1=2*(parti-1)+1
                     k2=2*(parti-1)+2
                     quan=invcdfnorm(dble(k1)*prob,muc,sigma,1,0)

                     if(y(i).le.quan)then
                       parti=k1
                       k=k1
                      else
                       parti=k2
                       k=k2
                     end if

                     countern=0

                     if(k.eq.1)then
                        do l=1,countero
                           if(y(whicho(l)).le.quan)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                        end do
                      else if(k.eq.nint)then
                        quan=invcdfnorm(dble(k-1)*prob,muc,sigma,1,0)
                        do l=1,countero
                           if(y(whicho(l)).gt.quan)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                        end do
                      else
                        tmp1=invcdfnorm(dble(k-1)*prob,muc,sigma,1,0)
                        tmp2=invcdfnorm(dble(k  )*prob,muc,sigma,1,0)

                        if(tmp1.ge.tmp2)then
                          call rexit("Error in the limits")
                        end if

                        do l=1,countero
                           if(y(whicho(l)).gt.tmp1.and.
     &                        y(whicho(l)).le.tmp2)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                        end do
                     end if

                     loglikn=loglikn+
     &                       log(2.d0*cpar*dble(je2)+dble(2*countern))-
     &                       log(2.d0*cpar*dble(je2)+dble(  countero))

                     if(countern.eq.0)then
                        ok=0
                      else
                        countero=countern
                        do l=1,countern
                           whicho(l)=whichn(l)
                        end do
                        j=j+1
                     end if
                  end do

2                 continue

                  loglikn=loglikn+dnrm(y(i),muc,sigma,1)

              end if
            end do

c++++++++++ acceptance step

            logpriorn=0.d0
            logprioro=0.d0

            if(jfr(1).eq.0)then
               logprioro=dnrm(mu, m0,sqrt(s0),1)
               logpriorn=dnrm(muc,m0,sqrt(s0),1)
            end if

            ratio=loglikn-logliko+logpriorn-logprioro

            if(log(dble(runif())).lt.ratio)then
               mu=muc
               logliko=loglikn
               acrate(1)=acrate(1)+1.d0
            end if

        end if

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ Updating sigma using a MH step               +++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++

         if(sigmarand.eq.1)then

            loglikn=0.d0

            sigma2c=rtlnorm(log(sigma2),tune2*0.1d0,0,0,.true.,.true.)
            sigmac=sqrt(sigma2c)

            logcgkn=dlnrm(sigma2 ,log(sigma2c),tune2*0.1d0,1)
            logcgko=dlnrm(sigma2c,log(sigma2 ),tune2*0.1d0,1)

            do i=1,nrec

c+++++++++++++ check if the user has requested an interrupt
               call rchkusr()

c+++++++++++++ first observation
               if(i.eq.1)then

                  loglikn=dnrm(y(1),mu,sigmac ,1)

c+++++++++++++ following observations
                else

                  nint=2
                  prob=1.d0/dble(nint)
                  quan=invcdfnorm(prob,mu,sigmac,1,0)

                  countero=0

                  if(y(i).le.quan) then
                     parti=1
                     do l=1,i-1
                        if(y(l).le.quan)then
                           countero=countero+1
                           whicho(countero)=l
                        end if
                     end do
                   else
                     parti=2
                     do l=1,i-1
                        if(y(l).gt.quan)then
                           countero=countero+1
                           whicho(countero)=l
                        end if
                     end do
                  end if

                  loglikn=loglikn+
     &                    log(2.d0*cpar+dble(2*countero))-
     &                    log(2.d0*cpar+dble(i-1))

                  if(countero.eq.0) go to 3

                  ok=1
                  j=2
                  do while(ok.eq.1)
                     nint=2**j
                     je2=j**2
                     prob=1.d0/dble(nint)

                     k1=2*(parti-1)+1
                     k2=2*(parti-1)+2
                     quan=invcdfnorm(dble(k1)*prob,mu,sigmac,1,0)

                     if(y(i).le.quan)then
                       parti=k1
                       k=k1
                      else
                       parti=k2
                       k=k2
                     end if

                     countern=0

                     if(k.eq.1)then
                        do l=1,countero
                           if(y(whicho(l)).le.quan)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                        end do
                      else if(k.eq.nint)then
                        quan=invcdfnorm(dble(k-1)*prob,mu,sigmac,1,0)
                        do l=1,countero
                           if(y(whicho(l)).gt.quan)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                        end do
                      else
                        tmp1=invcdfnorm(dble(k-1)*prob,mu,sigmac,1,0)
                        tmp2=invcdfnorm(dble(k  )*prob,mu,sigmac,1,0)

                        if(tmp1.ge.tmp2)then
                           call rexit("Error in the limits")
                        end if

                        do l=1,countero
                           if(y(whicho(l)).gt.tmp1.and.
     &                        y(whicho(l)).le.tmp2)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                        end do
                     end if

                     loglikn=loglikn+
     &                       log(2.d0*cpar*dble(je2)+dble(2*countern))-
     &                       log(2.d0*cpar*dble(je2)+dble(  countero))

                     if(countern.eq.0)then
                        ok=0
                      else
                        countero=countern
                        do l=1,countern
                           whicho(l)=whichn(l)
                        end do
                        j=j+1
                     end if
                  end do

3                 continue

                  loglikn=loglikn+dnrm(y(i),mu,sigmac,1)

               end if
            end do

c++++++++++ acceptance step

            logpriorn=-log(sigma2c)
            logprioro=-log(sigma2)

            if(jfr(2).eq.0)then
               logpriorn=-(0.5d0*tau(1)+1.d0)*log(sigma2c)-
     &                     0.5d0*tau(2)/sigma2c

               logprioro=-(0.5d0*tau(1)+1.d0)*log(sigma2)-
     &                     0.5d0*tau(2)/sigma2
            end if

            ratio=loglikn-logliko+logcgkn-logcgko+
     &            logpriorn-logprioro

            if(log(dble(runif())).lt.ratio)then
               sigma=sigmac
               sigma2=sigma2c
               logliko=loglikn
               acrate(2)=acrate(2)+1.d0
            end if

         end if

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ MH to update the c parameter                 +++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         if(ca.gt.0.d0)then

c++++++++++ sample candidates

            cparc=rtlnorm(log(cpar),tune3*0.2,0,0,.true.,.true.)
            logcgkn=dlnrm(cpar ,log(cparc),tune3*0.2,1)
            logcgko=dlnrm(cparc,log(cpar ),tune3*0.2,1)

c++++++++++ evaluate log-prior for candidate value of the parameters

            call dgamma2(cparc,ca,cb,logpriorn)

c++++++++++ evaluate log-prior for current value of parameters

            call dgamma2(cpar ,ca,cb,logprioro)

c++++++++++ evaluate log-likelihood

            do i=1,nrec

c+++++++++++++ check if the user has requested an interrupt
               call rchkusr()

c++++++++++ first observation
            if(i.eq.1)then

                 loglikn=dnrm(y(1),mu,sigma ,1)

c++++++++++ following observations
              else

                 nint=2
                 prob=1.d0/dble(nint)
                 quan=invcdfnorm(prob,mu,sigma,1,0)

                 countero=0

                 if(y(i).le.quan) then
                    parti=1
                    do l=1,i-1
                       if(y(l).le.quan)then
                          countero=countero+1
                          whicho(countero)=l
                       end if
                    end do
                  else
                    parti=2
                    do l=1,i-1
                       if(y(l).gt.quan)then
                          countero=countero+1
                          whicho(countero)=l
                       end if
                    end do
                 end if

                 loglikn=loglikn+
     &                   log(2.d0*cparc+dble(2*countero))-
     &                   log(2.d0*cparc+dble(i-1))

                 if(countero.eq.0) go to 4

                 ok=1
                 j=2
                 do while(ok.eq.1)
                    nint=2**j
                    je2=j**2
                    prob=1.d0/dble(nint)

                    k1=2*(parti-1)+1
                    k2=2*(parti-1)+2
                    quan=invcdfnorm(dble(k1)*prob,mu,sigma,1,0)

                    if(y(i).le.quan)then
                      parti=k1
                      k=k1
                     else
                      parti=k2
                      k=k2
                    end if

                    countern=0

                    if(k.eq.1)then
                       do l=1,countero
                          if(y(whicho(l)).le.quan)then
                             countern=countern+1
                             whichn(countern)=whicho(l)
                          end if
                       end do
                     else if(k.eq.nint)then
                       quan=invcdfnorm(dble(k-1)*prob,mu,sigma,1,0)
                       do l=1,countero
                          if(y(whicho(l)).gt.quan)then
                             countern=countern+1
                             whichn(countern)=whicho(l)
                          end if
                       end do
                     else
                       tmp1=invcdfnorm(dble(k-1)*prob,mu,sigma,1,0)
                       tmp2=invcdfnorm(dble(k  )*prob,mu,sigma,1,0)

                       if(tmp1.ge.tmp2)then
                         call rexit("Error in the limits")
                       end if

                       do l=1,countero
                          if(y(whicho(l)).gt.tmp1.and.
     &                       y(whicho(l)).le.tmp2)then
                             countern=countern+1
                             whichn(countern)=whicho(l)
                          end if
                       end do
                    end if

                    loglikn=loglikn+
     &                      log(2.d0*cparc*dble(je2)+dble(2*countern))-
     &                      log(2.d0*cparc*dble(je2)+dble(  countero))

                    if(countern.eq.0)then
                       ok=0
                     else
                       countero=countern
                       do l=1,countern
                          whicho(l)=whichn(l)
                       end do
                       j=j+1
                    end if
                 end do

4                continue

                 loglikn=loglikn+dnrm(y(i),mu,sigma,1)

            end if
            end do

c++++++++++ acceptance step
            ratio=loglikn+logpriorn-logliko-logprioro+
     &            logcgkn-logcgko

            if(log(dble(runif())).lt.ratio)then
               cpar=cparc
               acrate(3)=acrate(3)+1.d0
               logliko=loglikn
            end if

         end if

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ Save samples                                 +++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++

         if(iscan.gt.nburn)then
            skipcount=skipcount+1
            if(skipcount.gt.nskip)then
               isave=isave+1
               dispcount=dispcount+1

c+++++++++++++ mu
               thetasave(isave,1)=mu

c+++++++++++++ sigma
               thetasave(isave,2)=sigma

c+++++++++++++ c parameter
               thetasave(isave,3)=cpar

c+++++++++++++ cpo

               do i=1,nrec

c++++++++++++++++ check if the user has requested an interrupt
                  call rchkusr()

                  loglikn=0.d0

                  nint=2
                  tmp1=1.d0/dble(nint)
                  quan=invcdfnorm(tmp1,mu,sigma,1,0)

                  countero=0

                  if(y(i).le.quan)then
                      parti=1
                      do l=1,nrec
                         if(y(l).le.quan.and.l.ne.i)then
                            countero=countero+1
                            whicho(countero)=l
                         end if
                      end do
                    else
                      parti=2
                      do l=1,nrec
                         if(y(l).gt.quan.and.l.ne.i)then
                            countero=countero+1
                            whicho(countero)=l
                         end if
                      end do
                  end if

                  loglikn=loglikn+
     &                 log(2.d0*cpar+dble(2*countero))-
     &                 log(2.d0*cpar+dble(nrec-1))

                  if(countero.eq.0) go to 5

                  ok=1
                  j=2
                  do while(ok.eq.1)
                     nint=2**j
                     je2=j**2
                     prob=1.d0/dble(nint)

                     k1=2*(parti-1)+1
                     k2=2*(parti-1)+2
                     quan=invcdfnorm(dble(k1)*prob,mu,sigma,1,0)

                     if(y(i).le.quan)then
                       parti=k1
                       k=k1
                      else
                       parti=k2
                       k=k2
                     end if

                     countern=0

                     if(k.eq.1)then
                        do l=1,countero
                           if(y(whicho(l)).le.quan.and.
     &                        whicho(l).ne.i)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                        end do
                      else if(k.eq.nint)then
                        quan=invcdfnorm(dble(k-1)*prob,mu,sigma,1,0)
                        do l=1,countero
                           if(y(whicho(l)).gt.quan.and.
     &                        whicho(l).ne.i)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                        end do
                      else
                        tmp1=invcdfnorm(dble(k-1)*prob,mu,sigma,1,0)
                        tmp2=invcdfnorm(dble(k  )*prob,mu,sigma,1,0)

                        if(tmp1.ge.tmp2)then
                          call rexit("Error in the limits")
                        end if

                        do l=1,countero
                           if(whicho(l).ne.i)then
                           if(y(whicho(l)).gt.tmp1.and.
     &                        y(whicho(l)).le.tmp2)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                           end if
                        end do
                     end if

                     loglikn=loglikn+
     &                      log(2.d0*cpar*dble(je2)+dble(2*countern))-
     &                      log(2.d0*cpar*dble(je2)+dble(  countero))

                     if(countern.eq.0)then
                        ok=0
                      else
                        countero=countern
                        do l=1,countern
                           whicho(l)=whichn(l)
                        end do
                        j=j+1
                     end if
                  end do

5                 continue

                  loglikn=loglikn+dnrm(grid(i),mu,sigma,1)

                  cpo(i)=cpo(i)+1.d0/exp(loglikn)
               end do

c+++++++++++++ density

               do i=1,ngrid

c++++++++++++++++ check if the user has requested an interrupt
                  call rchkusr()

                  loglikn=0.d0

                  nint=2
                  tmp1=1.d0/dble(nint)
                  quan=invcdfnorm(tmp1,mu,sigma,1,0)

                  countero=0

                  if(grid(i).le.quan)then
                      parti=1
                      do l=1,nrec
                         if(y(l).le.quan)then
                            countero=countero+1
                            whicho(countero)=l
                         end if
                      end do
                    else
                      parti=2
                      do l=1,nrec
                         if(y(l).gt.quan)then
                            countero=countero+1
                            whicho(countero)=l
                         end if
                      end do
                  end if

                  loglikn=loglikn+
     &                 log(2.d0*cpar+dble(2*countero))-
     &                 log(2.d0*cpar+dble(  nrec))

                  if(countero.eq.0) go to 6

                  ok=1
                  j=2
                  do while(ok.eq.1)
                     nint=2**j
                     je2=j**2
                     prob=1.d0/dble(nint)

                     k1=2*(parti-1)+1
                     k2=2*(parti-1)+2
                     quan=invcdfnorm(dble(k1)*prob,mu,sigma,1,0)

                     if(grid(i).le.quan)then
                       parti=k1
                       k=k1
                      else
                       parti=k2
                       k=k2
                     end if

                     countern=0

                     if(k.eq.1)then
                        do l=1,countero
                           if(y(whicho(l)).le.quan)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                        end do
                      else if(k.eq.nint)then
                        quan=invcdfnorm(dble(k-1)*prob,mu,sigma,1,0)
                        do l=1,countero
                           if(y(whicho(l)).gt.quan)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                        end do
                      else
                        tmp1=invcdfnorm(dble(k-1)*prob,mu,sigma,1,0)
                        tmp2=invcdfnorm(dble(k  )*prob,mu,sigma,1,0)

                        if(tmp1.ge.tmp2)then
                          call rexit("Error in the limits")
                        end if

                        do l=1,countero
                           if(y(whicho(l)).gt.tmp1.and.
     &                        y(whicho(l)).le.tmp2)then
                              countern=countern+1
                              whichn(countern)=whicho(l)
                           end if
                        end do
                     end if

                     loglikn=loglikn+
     &                      log(2.d0*cpar*dble(je2)+dble(2*countern))-
     &                      log(2.d0*cpar*dble(je2)+dble(  countero))

                     if(countern.eq.0)then
                        ok=0
                      else
                        countero=countern
                        do l=1,countern
                           whicho(l)=whichn(l)
                        end do
                        j=j+1
                     end if
                  end do

6                 continue

                  loglikn=loglikn+dnrm(grid(i),mu,sigma,1)

                  f(i)=f(i)+exp(loglikn)

               end do

c+++++++++++++ print
               skipcount = 0
               if(dispcount.ge.ndisplay)then
                  call cpu_time(sec1)
                  sec00=sec00+(sec1-sec0)
                  sec=sec00
                  sec0=sec1
                  pprn=sprint(isave,nsave,sec)
                  dispcount=0
               end if
            end if
         end if
      end do

      do i=1,3
         acrate(i)=acrate(i)/dble(nscan)
      end do

      do i=1,nrec
         cpo(i)=dble(nsave)/cpo(i)
      end do

      do i=1,ngrid
         f(i)=f(i)/dble(nsave)
      end do

      return
      end