c=======================================================================
      subroutine ptmdensityp(ngrid,nrec,nvar,y,
     &                       ab,nlevel,murand,sigmarand,jfr,m0,s0,nu0,
     &                       tinv,
     &                       mcmcvec,nsave,tune1,tune2,tune3,
     &                       acrate,cpo,f,randsave,thetasave,
     &                       cpar,mu,sigma,
     &                       grid1,grid2,
     &                       iflag,whicho,whichn,limw,
     &                       linf,lsup,narea,mass,massi,
     &                       parti,pattern,patterns,
     &                       s,sigmainv,sigmainvc,
     &                       ybar,z,zc,zwork,vv,
     &                       workmh,workh1,workh2,workm1,workm2,
     &                       muc,sigmac,propv,propv1,propv2,
     &                       seed)
c=======================================================================
c
c     Subroutine `ptmdensityp' to run a Markov chain for Density
c     estimation using a Multivariate Mixture of Finite Polya Trees prior.
c     The Multivariate Finite Polya Tree is centered in a multivariate
c     N(mu,sigma) distribution. The Jeffery's prior is used for mu and
c     sigma.
c
c     Copyright: Alejandro Jara, 2006-2010.
c
c     Version 2.0:
c
c     Last modification: 25-01-2010.
c
c     Changes and Bug fixes:
c
c     Version 1.0 to Version 2.0:
c          - Centering parameters can be fixed.
c          - Proper prior can be used on the centering parameters.
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        nvar        :  integer giving the number of variables.
c        y           :  real matrix giving the response variables,
c                       y(nrec,nvar).
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        nlevel      :  integer giving the number of binary partitions
c                       in each margin of the Multivariate
c                       Finite Polya tree prior.
c        jfr         :  integer vector indicating whether Jeffery's
c                       prior is used for the centering parameters.
c        m0          :  real vector giving the mean of the normal prior
c                       for the centering mean.
c        s0          :  real matrix giving the precision of the normal
c                       prior for the centering mean.
c        nu0         :  integer giving the prior degrees of freedom
c                       for the centering covariance matrix.
c        tinv        :  real matrix giving the scale matrix for the
c                       inv-wishart prior for the centering covariance
c                       matrix.
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                       covariance matrix 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 matrix giving the density estimate at the
c                       grid, f(ngrid,ngrid) (only in bivariate case).
c        cpo         :  real vector giving the cpos, cpo(nrec).
c        randsave    :  real matrix containing the mcmc samples from
c                       the posterior predictive distribution,
c                       randsave(nsave,nvar).
c        thetasave   :  real matrix containing the mcmc samples for
c                       the parameters,
c                       thetasave(nsave,nvar+nvar*(nvar+1)/2+1).
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 vector giving the current value of the
c                       baseline means, mu(nvar)
c        sigma       :  real matrix giving the he current value of the
c                       baseline covariance matrix, sigma(nvar,nvar).
c
c-----------------------------------------------------------------------
c
c---- Working space ----------------------------------------------------
c
c        binaryrep   :  integer function to compute a number based
c                       on its binary representation.
c        countern    :  index.
c        countero    :  index.
c        cparc       :  real giving the value of the candidate
c                       for the precision parameter.
c        detlogl     :  real giving the log of the determinat of a
c                       matrix.
c        detloglc    :  real giving the log of the determinat of a
c                       matrix.
c        detlog1     :  real giving the log of the determinat of a
c                       matrix.
c        detlog2     :  real giving the log of the determinat of a
c                       matrix.
c        detlog3     :  real giving the log of the determinat of a
c                       matrix.
c        dispcount   :  index.
c        dlnrm       :  density of a log-normal distribution.
c        dnrm        :  density of a normal distribution.
c        evali       :  integer indicator.
c        evali2      :  integer indicator.
c        final       :  integer indicator.
c        grid1       :  real vector giving the grid where the density
c                       estimate is evaluated for first coordinate,
c                       grid1(ngrid).
c        grid2       :  real vector giving the grid where the density
c                       estimate is evaluated for second coordinate,
c                       grid2(ngrid).
c        i           :  index.
c        i1          :  index.
c        iflag       :  integer vector used to invert the baseline
c                       covariance matrix, iflag(nvar).
c        ihmssf      :  integer function to evaluate the position of an
c                       element in a matrix based on a half-stored
c                       version.
c        isave       :  index.
c        iscan       :  index.
c        j           :  index.
c        j1          :  index.
c        je2         :  index.
c        k           :  index.
c        k1          :  index.
c        k2          :  index.
c        l           :  index.
c        limw        :  real vector giving the limits of partitions,
c                       limw(nvar).
c        linf        :  real vector giving the limits of partitions,
c                       linf(nvar).
c        logcgko     :  real working variable.
c        logcgkn     :  real working variable.
c        loglikec    :  real working variable.
c        loglikeo    :  real working variable.
c        logpriorc   :  real working variable.
c        logprioro   :  real working variable.
c        lsup        :  real vector giving the limits of partitions,
c                       lsup(nvar).
c        mass        :  real vector giving the probabilities in each
c                       partitio area, mass(narea).
c        massi       :  integer vector giving the number of observation
c                       in each element of the partition, massi(narea).
c        muc         :  real vector giving the candidate value of the
c                       baseline means, muc(nvar)
c        narea       :  integer giving the total number of areas per
c                       partitio, narea=2**nvar.
c        nint        :  integer indicator.
c        nscan       :  index.
c        nu          :  real working variable.
c        ok          :  integer indicator.
c        parti       :  integer vector giving the partition,
c                       parti(nvar).
c        pattern     :  integer vector giving the pattern of an observation,
c                       pattern(nvar).
c        patterns    :  integer vector giving the pattern of an observation,
c                       patterns(nvar).
c        pprn        :  index.
c        prob        :  real working variable.
c        propv       :  real working matrix, propv(nvar,nvar).
c        propv1      :  real working matrix, propv1(nvar,nvar).
c        propv2      :  real working matrix, propv2(nvar,nvar).
c        quan        :  real working variable.
c        ratio       :  real working variable.
c        rgamma      :  real gamma random number generator.
c        rtlnorm     :  real truncated log normal random number generator.
c        rtnorm      :  real truncated normal random number generator.
c        runif       :  real uniform random number generator.
c        s           :  real matrix giving the sample variance, s(nvar,nvar).
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 matrix giving the candidate value of the
c                       baseline covariance matrix, sigmac(nvar,nvar).
c        sigmainv    :  real matrix giving the inverse of the current
c                       value of the baseline covariance matrix,
c                       sigmainv(nvar,nvar).
c        sigmainvc   :  real matrix giving the inverse of the candidate
c                       value of the baseline covariance matrix,
c                       sigmainvc(nvar,nvar).
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        vv          :  real working vector, vv(nvar).
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        workh1      :  real working vector, workh1(nvar*(nvar+1)/2)
c        workh2      :  real working vector, workh2(nvar*(nvar+1)/2)
c        workm1      :  real working matrix, workm1(nvar,nvar)
c        workm2      :  real working matrix, workm2(nvar,nvar)
c        workmh      :  real working vector, workmh(nvar*(nvar+1)/2)
c        ybar        :  real vector giving the sample mean, ybar(nvar).
c        z           :  real matrix giving the current value of the
c                       standarized observations, z(nrec,nvar).
c        zc          :  real matrix giving the candidate value of the
c                       standarized observations, zc(nrec,nvar).
c        zwork       :  real working vector, zwork(nvar).
c
c=======================================================================

      implicit none

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

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

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

c+++++Stored output
      real*8 acrate(3)
      real*8 cpo(nrec)
      real*8 f(ngrid,ngrid)
      real*8 randsave(nsave,nvar)
      real*8 thetasave(nsave,nvar+nvar*(nvar+1)/2+1)

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

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

c+++++Working space - Density
      real*8 grid1(ngrid),grid2(ngrid)

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

c+++++Working space - General
      integer binaryrep
      integer countero,countern
      integer evali,evali2
      integer final
      integer i,i1,j,j1,je2,k,k1,k2,l
      integer iflag(nvar)
      integer ihmssf
      integer narea,nint,ok,pattern(nvar),patterns(nvar)
      integer massi(narea)
      integer parti(nvar)
      integer pprn,sprint
      integer whicho(nrec),whichn(nrec)
      real*8 detlogl,detloglc,detlog1,detlog2,detlog3
      real*8 limw(nvar),linf(nvar),lsup(nvar)
      real*8 mass(narea)
      real*8 prob
      real*8 quan
      real*8 s(nvar,nvar)
      real*8 sigmainv(nvar,nvar),sigmainvc(nvar,nvar)
      real*8 tmp1,tmp2
      real*8 ybar(nvar)
      real*8 z(nrec,nvar),zc(nrec,nvar)
      real*8 zwork(nvar)
      real*8 vv(nvar)
      real*8 workmh(nvar*(nvar+1)/2)
      real*8 workh1(nvar*(nvar+1)/2),workh2(nvar*(nvar+1)/2)
      real*8 workm1(nvar,nvar)
      real*8 workm2(nvar,nvar)

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(nvar),sigmac(nvar,nvar)
      real*8 propv(nvar,nvar),propv1(nvar,nvar),propv2(nvar,nvar)
      real*8 ratio,nu

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

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

      ca=ab(1)
      cb=ab(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

      do i=1,nvar
         parti(i)=0
         ybar(i)=0.d0
         do j=1,nvar
            s(i,j)=0.d0
         end do
      end do

      do i=1,nrec
         do j=1,nvar
            ybar(j)=ybar(j)+y(i,j)
         end do
      end do

      do i=1,nvar
         ybar(i)=ybar(i)/dble(nrec)
      end do

      do i=1,nrec
         do j=1,nvar
            do k=1,nvar
               s(j,k)=s(j,k)+(y(i,j)-ybar(j))*(y(i,k)-ybar(k))
            end do
         end do
      end do

      do i=1,nvar
         do j=1,nvar
            s(i,j)=s(i,j)/dble(nrec)
         end do
      end do

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

      logliko=0.d0

      do i=1,nvar
         do j=1,nvar
            propv(i,j)=sigma(i,j)
         end do
      end do
      call invdet(propv,nvar,sigmainv,detlogl,iflag,vv)

      do i=1,nvar
         do j=1,nvar
            propv(i,j)=0.d0
         end do
      end do
      call cholesky(nvar,sigma,workmh)

      do i=1,nvar
         do j=1,i
            sigmainv(i,j)=workmh(ihmssf(i,j,nvar))
         end do
      end do
      call inverse(sigmainv,nvar,iflag)

      do i=1,nrec

         do j=1,nvar
            z(i,j)=y(i,j)-mu(j)
         end do

         do j=1,nvar
            tmp1=0.d0
            do k=1,nvar
               tmp1=tmp1+sigmainv(j,k)*z(i,k)
            end do
            zwork(j)=tmp1
         end do

         do j=1,nvar
            z(i,j)=zwork(j)
         end do

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

c+++++++ first observation
         if(i.eq.1)then
            logliko=-0.5d0*detlogl
            do j=1,nvar
               logliko=logliko+dnrm(z(i,j),0.d0, 1.d0, 1)
            end do

c+++++++ following observations
          else

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

            countero=0

            do j=1,nvar
               if(z(i,j).le.quan)then
                  linf(j)=-999.d0
                  lsup(j)=quan
                  parti(j)=1
                else
                  linf(j)=quan
                  lsup(j)=999.d0
                  parti(j)=2
               end if
            end do

            do l=1,i-1
               final=1
               do j=1,nvar
                  if(z(l,j).gt.lsup(j).or.z(l,j).lt.linf(j))then
                    final=0
                  end if
               end do

               if(final.eq.1)then
                  countero=countero+1
                  whicho(countero)=l
               end if
            end do

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

            if(countero.eq.0) go to 1

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

               do k=1,nvar
                  k1=2*(parti(k)-1)+1
                  k2=2*(parti(k)-1)+2
                  quan=invcdfnorm(dble(k1)*prob,0.d0,1.d0,1,0)

                  if(z(i,k).le.quan)then
                    parti(k)=k1
                    lsup(k)=quan
                   else
                    parti(k)=k2
                    linf(k)=quan
                  end if
               end do

               countern=0
               do l=1,countero
                  final=1
                  do k=1,nvar
                     if(z(whicho(l),k).gt.lsup(k).or.
     &                  z(whicho(l),k).lt.linf(k)    )then

                        final=0
                     end if
                  end do

                  if(final.eq.1)then
                    countern=countern+1
                    whichn(countern)=whicho(l)
                  end if
               end do

               logliko=logliko+
     &              log((2.d0**nvar)*cpar*dble(je2)+
     &                  dble((2.d0**nvar)*countern))-
     &              log((2.d0**nvar)*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-0.5d0*detlogl
            do j=1,nvar
               logliko=logliko+dnrm(z(i,j),0.d0, 1.d0, 1)
            end do

         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

            do i=1,nvar
               do j=1,nvar
                  propv(i,j)=tune1*s(i,j)/dble(nrec)
               end do
            end do

            call rmvnorm(nvar,mu,propv,workmh,vv,muc)

            loglikn=0.d0

            do i=1,nrec

               do j=1,nvar
                  zc(i,j)=y(i,j)-muc(j)
               end do

               do j=1,nvar
                  tmp1=0.d0
                  do k=1,nvar
                     tmp1=tmp1+sigmainv(j,k)*zc(i,k)
                  end do
                  zwork(j)=tmp1
               end do

               do j=1,nvar
                  zc(i,j)=zwork(j)
               end do

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

c+++++++++++++ first observation
               if(i.eq.1)then
                  loglikn=-0.5d0*detlogl
                  do j=1,nvar
                     loglikn=loglikn+dnrm(zc(i,j),0.d0, 1.d0, 1)
                  end do

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

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

                  countero=0

                  do j=1,nvar
                     if(zc(i,j).le.quan)then
                        linf(j)=-999.d0
                        lsup(j)=quan
                        parti(j)=1
                      else
                        linf(j)=quan
                        lsup(j)=999.d0
                        parti(j)=2
                     end if
                  end do

                  do l=1,i-1
                     final=1
                     do j=1,nvar
                        if(zc(l,j).gt.lsup(j).or.zc(l,j).lt.linf(j))then
                          final=0
                        end if
                     end do

                     if(final.eq.1)then
                        countero=countero+1
                        whicho(countero)=l
                     end if
                  end do

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

                  if(countero.eq.0) go to 2

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

                     do k=1,nvar
                        k1=2*(parti(k)-1)+1
                        k2=2*(parti(k)-1)+2
                        quan=invcdfnorm(dble(k1)*prob,0.d0,1.d0,1,0)

                        if(zc(i,k).le.quan)then
                          parti(k)=k1
                          lsup(k)=quan
                         else
                          parti(k)=k2
                          linf(k)=quan
                        end if
                     end do

                     countern=0
                     do l=1,countero
                        final=1
                        do k=1,nvar
                           if(zc(whicho(l),k).gt.lsup(k).or.
     &                        zc(whicho(l),k).lt.linf(k)    )then

                              final=0
                           end if
                        end do

                        if(final.eq.1)then
                          countern=countern+1
                          whichn(countern)=whicho(l)
                        end if
                     end do

                     loglikn=loglikn+
     &                 log((2.d0**nvar)*cpar*dble(je2)+
     &                  dble((2.d0**nvar)*countern))-
     &                 log((2.d0**nvar)*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-0.5d0*detlogl
                  do j=1,nvar
                     loglikn=loglikn+dnrm(zc(i,j),0.d0, 1.d0, 1)
                  end do

               end if

            end do

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

            logpriorn=0.d0
            logprioro=0.d0

            if(jfr(1).eq.0)then
               do i=1,nvar
                  do j=1,nvar
                     logpriorn=logpriorn+(muc(i)-m0(i))*
     &                                    s0(i,j)    *
     &                                   (muc(j)-m0(j))

                     logprioro=logprioro+(mu(i)-m0(i))*
     &                                    s0(i,j)    *
     &                                   (mu(j)-m0(j))
                  end do
               end do

               logpriorn=-0.5d0*logpriorn
               logprioro=-0.5d0*logprioro
            end if

            ratio=loglikn-logliko+logpriorn-logprioro

            if(log(dble(runif())).lt.ratio)then
               do i=1,nvar
                  mu(i)=muc(i)
               end do
               do i=1,nrec
                  do j=1,nvar
                     z(i,j)=zc(i,j)
                  end do
               end do
               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

c++++++++++ Candidate generating kernel

            nu=dble(nrec)*tune2

            do i=1,nvar
               do j=1,nvar
                  sigmac(i,j)=(nu-dble(nvar+1))*sigma(i,j)
               end do
            end do

            call riwishart(nvar,int(nu),sigmac,sigmainvc,workm2,vv,
     &                     workh1,workh2,iflag)

            do i=1,nvar
               do j=1,nvar
                  propv1(i,j)=sigma(i,j)
               end do
            end do
            call invdet(propv1,nvar,sigmainv,detlog1,iflag,vv)

            do i=1,nvar
               do j=1,nvar
                  propv2(i,j)=sigmac(i,j)
               end do
            end do
            call invdet(propv2,nvar,propv,detlog2,iflag,vv)

            logcgkn=0.d0
            logcgkn=-(nu+dble(nvar+1))*detlog1
            logcgkn=logcgkn+nu*detlog2

            tmp2=0.d0
            do i=1,nvar
               do j=1,nvar
                  tmp1=0.d0
                  do k=1,nvar
                     tmp1=tmp1+(nu-dble(nvar+1))*
     &                          sigmac(i,k)*sigmainv(k,j)
                  end do
                  if(i.eq.j)tmp2=tmp2+tmp1
               end do
            end do
            logcgkn=logcgkn-tmp2
            logcgkn=logcgkn/dble(2)

            logcgko=0.d0
            logcgko=-(nu+dble(nvar+1))*detlog2
            logcgko=logcgko+nu*detlog1

            tmp2=0.d0
            do i=1,nvar
               do j=1,nvar
                  tmp1=0.d0
                  do k=1,nvar
                     tmp1=tmp1+(nu-dble(nvar+1))*
     &                          sigma(i,k)*sigmainvc(k,j)
                  end do
                  if(i.eq.j)tmp2=tmp2+tmp1
               end do
            end do
            logcgko=logcgko-tmp2
            logcgko=logcgko/dble(2)

c++++++++++ End candidate generating kernel

            loglikn=0.d0

            do i=1,nvar
               do j=1,nvar
                  propv(i,j)=sigmac(i,j)
               end do
            end do
            call invdet(propv,nvar,sigmainvc,detloglc,iflag,vv)

            do i=1,nvar
               do j=1,nvar
                propv(i,j)=0.d0
               end do
            end do
            call cholesky(nvar,sigmac,workmh)

            do i=1,nvar
               do j=1,i
                  sigmainvc(i,j)=workmh(ihmssf(i,j,nvar))
               end do
            end do
            call inverse(sigmainvc,nvar,iflag)

            do i=1,nrec

               do j=1,nvar
                  zc(i,j)=y(i,j)-mu(j)
               end do

               do j=1,nvar
                  tmp1=0.d0
                  do k=1,nvar
                     tmp1=tmp1+sigmainvc(j,k)*zc(i,k)
                  end do
                  zwork(j)=tmp1
               end do

               do j=1,nvar
                  zc(i,j)=zwork(j)
               end do

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

c+++++++++++++ first observation
               if(i.eq.1)then
                  loglikn=-0.5d0*detloglc
                  do j=1,nvar
                     loglikn=loglikn+dnrm(zc(i,j),0.d0, 1.d0, 1)
                  end do

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

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

                  countero=0

                  do j=1,nvar
                     if(zc(i,j).le.quan)then
                        linf(j)=-999.d0
                        lsup(j)=quan
                        parti(j)=1
                      else
                        linf(j)=quan
                        lsup(j)=999.d0
                        parti(j)=2
                     end if
                  end do

                  do l=1,i-1
                     final=1
                     do j=1,nvar
                        if(zc(l,j).gt.lsup(j).or.zc(l,j).lt.linf(j))then
                          final=0
                        end if
                     end do

                     if(final.eq.1)then
                        countero=countero+1
                        whicho(countero)=l
                     end if
                  end do

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

                  if(countero.eq.0) go to 3

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

                     do k=1,nvar
                        k1=2*(parti(k)-1)+1
                        k2=2*(parti(k)-1)+2
                        quan=invcdfnorm(dble(k1)*prob,0.d0,1.d0,1,0)

                        if(zc(i,k).le.quan)then
                          parti(k)=k1
                          lsup(k)=quan
                         else
                          parti(k)=k2
                          linf(k)=quan
                        end if
                     end do

                     countern=0
                     do l=1,countero
                        final=1
                        do k=1,nvar
                           if(zc(whicho(l),k).gt.lsup(k).or.
     &                        zc(whicho(l),k).lt.linf(k)    )then

                              final=0
                           end if
                        end do

                        if(final.eq.1)then
                          countern=countern+1
                          whichn(countern)=whicho(l)
                        end if
                     end do

                     loglikn=loglikn+
     &                log((2.d0**nvar)*cpar*dble(je2)+
     &                   dble((2.d0**nvar)*countern))-
     &                log((2.d0**nvar)*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-0.5d0*detloglc
                  do j=1,nvar
                     loglikn=loglikn+dnrm(zc(i,j),0.d0, 1.d0, 1)
                  end do

               end if

            end do

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

            logprioro= -(dble(nvar+1)/dble(2))*(detlog2 - detlog1)
            logprioro=0.d0

            if(jfr(2).eq.0)then
               call diwishart(nvar,nu0,sigmac,tinv,workm1,workm2,
     &                        vv,iflag,logpriorn)

               call diwishart(nvar,nu0,sigma,tinv,workm1,workm2,
     &                        vv,iflag,logprioro)

            end if

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

            if(log(dble(runif())).lt.ratio)then
               do i=1,nvar
                  do j=1,nvar
                     sigma(i,j)=sigmac(i,j)
                     sigmainv(i,j)=sigmainvc(i,j)
                  end do
               end do
               do i=1,nrec
                  do j=1,nvar
                     z(i,j)=zc(i,j)
                  end do
               end do
               detlogl=detloglc
               logliko=loglikn
               acrate(2)=acrate(2)+1.d0
             else
               do i=1,nvar
                  do j=1,nvar
                     propv(i,j)=sigma(i,j)
                  end do
               end do

               call invdet(propv,nvar,sigmainv,detlogl,iflag,vv)

               do i=1,nvar
                  do j=1,nvar
                     propv(i,j)=sigma(i,j)
                  end do
               end do
               call cholesky(nvar,sigma,workmh)

               do i=1,nvar
                  do j=1,i
                     sigmainv(i,j)=workmh(ihmssf(i,j,nvar))
                  end do
               end do
               call inverse(sigmainv,nvar,iflag)
            end if

         end if

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

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

            cparc=exp(rnorm(log(cpar),tune3*1.d0))
            logcgkn=dlnrm(cpar ,log(cparc),tune3*1.d0,1)
            logcgko=dlnrm(cparc,log(cpar ),tune3*1.d0,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)

            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=-0.5d0*detlogl
                  do j=1,nvar
                     loglikn=loglikn+dnrm(z(i,j),0.d0, 1.d0, 1)
                  end do

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

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

                  countero=0

                  do j=1,nvar
                     if(z(i,j).le.quan)then
                        linf(j)=-999.d0
                        lsup(j)=quan
                        parti(j)=1
                      else
                        linf(j)=quan
                        lsup(j)=999.d0
                        parti(j)=2
                     end if
                  end do

                  do l=1,i-1
                     final=1
                     do j=1,nvar
                        if(z(l,j).gt.lsup(j).or.z(l,j).lt.linf(j))then
                          final=0
                        end if
                     end do

                     if(final.eq.1)then
                        countero=countero+1
                        whicho(countero)=l
                     end if
                  end do

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

                  if(countero.eq.0) go to 4

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

                     do k=1,nvar
                        k1=2*(parti(k)-1)+1
                        k2=2*(parti(k)-1)+2
                        quan=invcdfnorm(dble(k1)*prob,0.d0,1.d0,1,0)

                        if(z(i,k).le.quan)then
                          parti(k)=k1
                          lsup(k)=quan
                         else
                          parti(k)=k2
                          linf(k)=quan
                        end if
                     end do

                     countern=0
                     do l=1,countero
                        final=1
                        do k=1,nvar
                           if(z(whicho(l),k).gt.lsup(k).or.
     &                        z(whicho(l),k).lt.linf(k)    )then

                              final=0
                           end if
                        end do

                        if(final.eq.1)then
                          countern=countern+1
                          whichn(countern)=whicho(l)
                        end if
                     end do

                     loglikn=loglikn+
     &                 log((2.d0**nvar)*cparc*dble(je2)+
     &                     dble((2.d0**nvar)*countern))-
     &                 log((2.d0**nvar)*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-0.5d0*detlogl
                  do j=1,nvar
                     loglikn=loglikn+dnrm(z(i,j),0.d0, 1.d0, 1)
                  end do

               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
               do i=1,nvar
                  thetasave(isave,i)=mu(i)
               end do

c+++++++++++++ sigma
               k1=0
               do i=1,nvar
                  do j=i,nvar
                     k1=k1+1
                     thetasave(isave,nvar+k1)=sigma(i,j)
                  end do
               end do

c+++++++++++++ c parameter

               thetasave(isave,nvar+k1+1)=cpar

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

               do i=1,nrec

                  loglikn=0.d0

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

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

                  countero=0

                  do j=1,nvar
                     if(z(i,j).le.quan)then
                        linf(j)=-999.d0
                        lsup(j)=quan
                        parti(j)=1
                      else
                        linf(j)=quan
                        lsup(j)=999.d0
                        parti(j)=2
                     end if
                  end do

                  do l=1,nrec
                     final=1
                     if(l.ne.i)then
                     do j=1,nvar
                        if(z(l,j).gt.lsup(j).or.z(l,j).lt.linf(j))then
                          final=0
                        end if
                     end do

                     if(final.eq.1)then
                        countero=countero+1
                        whicho(countero)=l
                     end if
                     end if
                  end do

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

                  if(countero.eq.0) go to 5

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

                     do k=1,nvar
                        k1=2*(parti(k)-1)+1
                        k2=2*(parti(k)-1)+2
                        quan=invcdfnorm(dble(k1)*prob,0.d0,1.d0,1,0)

                        if(z(i,k).le.quan)then
                          parti(k)=k1
                          lsup(k)=quan
                         else
                          parti(k)=k2
                          linf(k)=quan
                        end if
                     end do

                     countern=0
                     do l=1,countero
                        final=1
                        do k=1,nvar
                           if(z(whicho(l),k).gt.lsup(k).or.
     &                        z(whicho(l),k).lt.linf(k)    )then

                              final=0
                           end if
                        end do

                        if(final.eq.1)then
                          countern=countern+1
                          whichn(countern)=whicho(l)
                        end if
                     end do

                     loglikn=loglikn+
     &                log((2.d0**nvar)*cpar*dble(je2)+
     &                    dble((2.d0**nvar)*countern))-
     &                log((2.d0**nvar)*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-0.5d0*detlogl
                  do j=1,nvar
                     loglikn=loglikn+dnrm(z(i,j),0.d0, 1.d0, 1)
                  end do

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

c+++++++++++++ sample from the predictive distribution

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

               countero=0

               do i=1,narea
                  massi(i)=0
                  mass(i)=0.d0
               end do

               do l=1,nrec
                  do j=1,nvar
                     evali=1
                     if(z(l,j).le.quan)evali=0
                     pattern(j)=evali
                     zwork(j)=z(l,j)
                  end do
                  evali=binaryrep(nvar,pattern)
                  massi(evali)=massi(evali)+1
               end do

               do i=1,narea
                  mass(i)=(cpar+dble(massi(i)))/
     &                    ((2**nvar)*cpar+dble(nrec))
               end do

               call simdisc(mass,narea,narea,evali)
               evali2=evali
               call binaryrepinv(nvar,evali2,patterns)

               do l=1,nrec
                  final=1
                  do j=1,nvar
                     evali=1
                     if(z(l,j).le.quan)evali=0
                     pattern(j)=evali
                     if(pattern(j).ne.patterns(j))final=0
                  end do

                  if(final.eq.1)then
                     countero=countero+1
                     whicho(countero)=l
                  end if
               end do

               do i=1,nvar
                  if(patterns(i).eq.0)then
                    linf(i)=-999.d0
                    lsup(i)=quan
                    parti(i)=1
                   else
                    linf(i)=quan
                    lsup(i)=999.d0
                    parti(i)=2
                  end if
               end do

               if(countero.eq.0) go to 6

               ok=1
               j=2
               countern=0

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

                  do k=1,nvar

                     k1=2*(parti(k)-1)+1
                     k2=2*(parti(k)-1)+2
                     quan=invcdfnorm(dble(k1)*prob,0.d0,1.d0,1,0)

                     limw(k)=quan

                     if(quan.gt.lsup(k).or.quan.lt.linf(k))then
                        call intpr("j",-1,j,1)
                        call dblepr("linf",-1,linf,nvar)
                        call dblepr("lsup",-1,lsup,nvar)
                        call dblepr("limw",-1,limw,nvar)
                        call rexit("Errors in limits")
                     end if
                  end do

                  do k=1,narea
                     massi(k)=0
                     mass(k)=0.d0
                  end do

                  do l=1,countero
                     do k=1,nvar
                        evali=1
                        if(z(whicho(l),k).le.limw(k))evali=0
                        pattern(k)=evali
                     end do
                     evali=binaryrep(nvar,pattern)
                     massi(evali)=massi(evali)+1
                  end do

                  do l=1,narea
                     mass(l)=(cpar*dble(je2)+dble(massi(l)))/
     &                   ((2**nvar)*cpar*dble(je2)+dble(countero))
                  end do

                  call simdisc(mass,narea,narea,evali)
                  evali2=evali
                  call binaryrepinv(nvar,evali2,patterns)

                  countern=0
                  do l=1,countero
                     final=1
                     do k=1,nvar
                        evali=1
                        if(z(whicho(l),k).le.limw(k))evali=0
                        pattern(k)=evali
                        if(pattern(k).ne.patterns(k))final=0
                     end do
                     if(final.eq.1)then
                        countern=countern+1
                        whichn(countern)=whicho(l)
                     end if
                  end do

                  do k=1,nvar
                     if(patterns(k).eq.0)then
                       parti(k)=2*(parti(k)-1)+1
                       lsup(k)=limw(k)
                      else
                       parti(k)=2*(parti(k)-1)+2
                       linf(k)=limw(k)
                     end if
                  end do

                  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

               do k=1,nvar
                  if(linf(k).ge.lsup(k))then
                     call intpr("j",-1,j,1)
                     call dblepr("linf",-1,linf,nvar)
                     call dblepr("lsup",-1,lsup,nvar)
                     call rexit("Errors in limits")
                  end if
               end do

               do i=1,nvar
                  zwork(i)=rtnorm(0.d0,1.d0,linf(i),
     &                            lsup(i),.false.,.false.)
               end do

               do i=1,nvar
                  do j=1,nvar
                     propv(i,j)=sigma(i,j)
                  end do
               end do

               call cholesky(nvar,propv,workmh)

               do i=1,nvar
                  do j=1,nvar
                     propv(i,j)=0.d0
                  end do
               end do

               do i=1,nvar
                  do j=1,i
                     propv(i,j)=workmh(ihmssf(i,j,nvar))
                  end do
               end do

               do j=1,nvar
                  tmp1=0.d0
                  do k=1,nvar
                     tmp1=tmp1+propv(j,k)*zwork(k)
                  end do
                  randsave(isave,j)=mu(j)+tmp1
               end do

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

               if(nvar.eq.2)then
                  do i1=1,ngrid
                     do j1=1,ngrid

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

                        loglikn=0.d0

                        vv(1)=grid1(i1)
                        vv(2)=grid2(j1)

                        do j=1,nvar
                           vv(j)=vv(j)-mu(j)
                        end do

                        do j=1,nvar
                           tmp1=0.d0
                           do k=1,nvar
                              tmp1=tmp1+sigmainv(j,k)*vv(k)
                           end do
                           zwork(j)=tmp1
                        end do

                        do j=1,nvar
                           vv(j)=zwork(j)
                        end do

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

                        countero=0

                        do j=1,nvar
                           if(vv(j).le.quan)then
                              linf(j)=-999.d0
                              lsup(j)=quan
                              parti(j)=1
                            else
                              linf(j)=quan
                              lsup(j)=999.d0
                              parti(j)=2
                           end if
                        end do

                        do l=1,nrec
                           final=1
                           do j=1,nvar
                              if(z(l,j).gt.lsup(j).or.
     &                           z(l,j).lt.linf(j))then
                                 final=0
                              end if
                           end do

                           if(final.eq.1)then
                              countero=countero+1
                              whicho(countero)=l
                           end if
                        end do

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

                        if(countero.eq.0) go to 7

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

                           do k=1,nvar
                              k1=2*(parti(k)-1)+1
                              k2=2*(parti(k)-1)+2
                              quan=invcdfnorm(dble(k1)*prob,
     &                             0.d0,1.d0,1,0)

                              if(vv(k).le.quan)then
                                parti(k)=k1
                                lsup(k)=quan
                               else
                                parti(k)=k2
                                linf(k)=quan
                              end if
                           end do

                           countern=0
                           do l=1,countero
                              final=1
                              do k=1,nvar
                                 if(z(whicho(l),k).gt.lsup(k).or.
     &                              z(whicho(l),k).lt.linf(k)    )then

                                    final=0
                                 end if
                              end do

                              if(final.eq.1)then
                                countern=countern+1
                                whichn(countern)=whicho(l)
                              end if
                           end do

                           loglikn=loglikn+
     &                       log((2.d0**nvar)*cpar*dble(je2)+
     &                           dble((2.d0**nvar)*countern))-
     &                       log((2.d0**nvar)*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

7                       continue

                        loglikn=loglikn-0.5d0*detlogl
                        do j=1,nvar
                           loglikn=loglikn+dnrm(vv(j),0.d0, 1.d0, 1)
                        end do

                        f(i1,j1)=f(i1,j1)+exp(loglikn)

                     end do
                  end do
               end if

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
         do j=1,ngrid
            f(i,j)=f(i,j)/dble(nsave)
         end do
      end do

      return
      end


!-------------------------------------------------------------------------------------------------------------------------------
! This module contains all the filters
MODULE Filters
!...............................................................................................................................

    IMPLICIT NONE

CONTAINS

    !-------------------------------------------------------------------------------------------------------------------------------
    ! Discrete time Low-Pass Filter
    REAL FUNCTION LPFilter(InputSignal, DT, CornerFreq, iStatus, reset, inst)
    !...............................................................................................................................

		IMPLICIT NONE

			! Inputs

		REAL(4), INTENT(IN)			:: InputSignal
		REAL(4), INTENT(IN)			:: DT						! time step [s]
		REAL(4), INTENT(IN)			:: CornerFreq				! corner frequency [rad/s]
		INTEGER(4), INTENT(IN)		:: iStatus					! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
		INTEGER(4), INTENT(INOUT)	:: inst						! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
		LOGICAL(4), INTENT(IN)		:: reset					! Reset the filter to the input signal

			! Local

        REAL(4), DIMENSION(99), SAVE	:: InputSignalLast		! Input signal the last time this filter was called. Supports 99 separate instances.
        REAL(4), DIMENSION(99), SAVE	:: OutputSignalLast	! Output signal the last time this filter was called. Supports 99 separate instances.

			! Initialization

		IF ((iStatus == 0) .OR. reset) THEN
			OutputSignalLast(inst) = InputSignal
			InputSignalLast(inst) = InputSignal
		ENDIF

			! Body

		LPFilter = (DT*CornerFreq*InputSignal + DT*CornerFreq*InputSignalLast(inst) - (DT*CornerFreq-2.0)*OutputSignalLast(inst))/(DT*CornerFreq+2.0)

			! Save signals for next time step

		InputSignalLast(inst)  = InputSignal
		OutputSignalLast(inst) = LPFilter
		inst = inst + 1

    END FUNCTION LPFilter
    !-------------------------------------------------------------------------------------------------------------------------------
    ! Discrete time second order Low-Pass Filter
    REAL FUNCTION SecLPFilter(InputSignal, DT, CornerFreq, Damp, iStatus, reset, inst)
    !...............................................................................................................................

        IMPLICIT NONE

			! Inputs

        REAL(4), INTENT(IN)   		:: InputSignal
		REAL(4), INTENT(IN) 		:: DT						! time step [s]
		REAL(4), INTENT(IN)    		:: CornerFreq				! corner frequency [rad/s]
		REAL(4), INTENT(IN)    		:: Damp						! Dampening constant
        INTEGER(4), INTENT(IN)		:: iStatus					! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER(4), INTENT(INOUT)	:: inst						! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
		LOGICAL(4), INTENT(IN)		:: reset					! Reset the filter to the input signal

			! Local

        REAL(4), DIMENSION(99), SAVE :: InputSignalLast1	! Input signal the last time this filter was called. Supports 99 separate instances.
		REAL(4), DIMENSION(99), SAVE :: InputSignalLast2	! Input signal the next to last time this filter was called. Supports 99 separate instances.
        REAL(4), DIMENSION(99), SAVE :: OutputSignalLast1	! Output signal the last time this filter was called. Supports 99 separate instances.
        REAL(4), DIMENSION(99), SAVE :: OutputSignalLast2	! Output signal the next to last time this filter was called. Supports 99 separate instances.

			! Initialization

        IF ((iStatus == 0) .OR. reset )  THEN
            OutputSignalLast1(inst)  = InputSignal
            OutputSignalLast2(inst)  = InputSignal
            InputSignalLast1(inst)   = InputSignal
            InputSignalLast2(inst)   = InputSignal
        ENDIF

			! Body

        SecLPFilter = 1/(4+4*DT*Damp*CornerFreq+DT**2*CornerFreq**2) * ( (8-2*DT**2*CornerFreq**2)*OutputSignalLast1(inst) &
						+ (-4+4*DT*Damp*CornerFreq-DT**2*CornerFreq**2)*OutputSignalLast2(inst) + (DT**2*CornerFreq**2)*InputSignal &
							+ (2*DT**2*CornerFreq**2)*InputSignalLast1(inst) + (DT**2*CornerFreq**2)*InputSignalLast2(inst) )

			! Save signals for next time step

        InputSignalLast2(inst)   = InputSignalLast1 (inst)
        InputSignalLast1(inst)   = InputSignal
        OutputSignalLast2(inst)  = OutputSignalLast1 (inst)
        OutputSignalLast1(inst)  = SecLPFilter
		inst = inst + 1

    END FUNCTION SecLPFilter
    !-------------------------------------------------------------------------------------------------------------------------------
    ! Discrete time High-Pass Filter
    REAL FUNCTION HPFilter( InputSignal, DT, CornerFreq, iStatus, reset, inst)
    !...............................................................................................................................

        IMPLICIT NONE

			! Inputs

        REAL(4), INTENT(IN)		:: InputSignal
		REAL(4), INTENT(IN)		:: DT						! time step [s]
		REAL(4), INTENT(IN)		:: CornerFreq				! corner frequency [rad/s]
        INTEGER, INTENT(IN)		:: iStatus					! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER, INTENT(INOUT)	:: inst						! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
		LOGICAL(4), INTENT(IN)	:: reset					! Reset the filter to the input signal

			! Local

		REAL(4)							:: K						! Constant gain
        REAL(4), DIMENSION(99), SAVE	:: InputSignalLast		! Input signal the last time this filter was called. Supports 99 separate instances.
        REAL(4), DIMENSION(99), SAVE	:: OutputSignalLast	! Output signal the last time this filter was called. Supports 99 separate instances.

			! Initialization

        IF ((iStatus == 0) .OR. reset)  THEN
            OutputSignalLast(inst) = InputSignal
            InputSignalLast(inst) = InputSignal
        ENDIF

        K = 2.0 / DT

			! Body

        HPFilter = K/(CornerFreq + K)*InputSignal - K/(CornerFreq + K)*InputSignalLast(inst) - (CornerFreq - K)/(CornerFreq + K)*OutputSignalLast(inst)

			! Save signals for next time step

        InputSignalLast(inst)   = InputSignal
        OutputSignalLast(inst)  = HPFilter
		inst = inst + 1

    END FUNCTION HPFilter
    !-------------------------------------------------------------------------------------------------------------------------------
    ! Discrete time inverted Notch Filter with descending slopes, G = CornerFreq*s/(Damp*s^2+CornerFreq*s+Damp*CornerFreq^2)
    REAL FUNCTION NotchFilterSlopes(InputSignal, DT, CornerFreq, Damp, iStatus, reset, inst)
    !...............................................................................................................................

        IMPLICIT NONE

			! Inputs

		REAL(4), INTENT(IN)     :: InputSignal
		REAL(4), INTENT(IN)     :: DT						! time step [s]
		REAL(4), INTENT(IN)     :: CornerFreq				! corner frequency [rad/s]
		REAL(4), INTENT(IN)     :: Damp						! Dampening constant
		INTEGER, INTENT(IN)		:: iStatus					! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
		INTEGER, INTENT(INOUT)	:: inst						! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
		LOGICAL(4), INTENT(IN)	:: reset					! Reset the filter to the input signal

			! Local

		REAL(4), DIMENSION(99), SAVE :: InputSignalLast1	! Input signal the last time this filter was called. Supports 99 separate instances.
		REAL(4), DIMENSION(99), SAVE :: InputSignalLast2	! Input signal the next to last time this filter was called. Supports 99 separate instances.
		REAL(4), DIMENSION(99), SAVE :: OutputSignalLast1	! Output signal the last time this filter was called. Supports 99 separate instances.
		REAL(4), DIMENSION(99), SAVE :: OutputSignalLast2	! Output signal the next to last time this filter was called. Supports 99 separate instances.

			! Initialization

		IF ((iStatus == 0) .OR. reset) THEN
			OutputSignalLast1(inst)  = InputSignal
			OutputSignalLast2(inst)  = InputSignal
			InputSignalLast1(inst)   = InputSignal
			InputSignalLast2(inst)   = InputSignal
		ENDIF

			! Body

		NotchFilterSlopes = 1.0/(4.0+2.0*DT*Damp*CornerFreq+DT**2.0*CornerFreq**2.0) * ( (8.0-2.0*DT**2.0*CornerFreq**2.0)*OutputSignalLast1(inst) &
						+ (-4.0+2.0*DT*Damp*CornerFreq-DT**2.0*CornerFreq**2.0)*OutputSignalLast2(inst) + &
							(2.0*DT*Damp*CornerFreq)*InputSignal + (-2.0*DT*Damp*CornerFreq)*InputSignalLast2(inst) )

			! Save signals for next time step

		InputSignalLast2(inst)   = InputSignalLast1(inst)
		InputSignalLast1(inst)   = InputSignal			!Save input signal for next time step
		OutputSignalLast2(inst)  = OutputSignalLast1(inst)		!Save input signal for next time step
		OutputSignalLast1(inst)  = NotchFilterSlopes
		inst = inst + 1

	END FUNCTION NotchFilterSlopes
	!-------------------------------------------------------------------------------------------------------------------------------
	! Discrete time Notch Filter, G = (s^2 + 2*omega*betaNum*s + omega^2)/(s^2 + 2*omega*betaDen*s + omega^2)
	REAL FUNCTION NotchFilter(InputSignal, DT, omega, betaNum, betaDen, iStatus, reset, inst)
	!...............................................................................................................................

		IMPLICIT NONE

			! Inputs

		REAL(4), INTENT(IN)     :: InputSignal
		REAL(4), INTENT(IN)     :: DT						! time step [s]
		REAL(4), INTENT(IN)     :: omega					! corner frequency [rad/s]
		REAL(4), INTENT(IN)     :: betaNum					! Dampening constant in numerator of filter transfer function
		REAL(4), INTENT(IN)     :: betaDen					! Dampening constant in denominator of filter transfer function
		INTEGER, INTENT(IN)		:: iStatus					! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
		INTEGER, INTENT(INOUT)	:: inst						! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
		LOGICAL(4), INTENT(IN)	:: reset					! Reset the filter to the input signal

			! Local
		REAL(4)							:: K, P1, P2, P3, P4, P5	! Constant gain
		REAL(4), DIMENSION(99), SAVE	:: InputSignalLast1			! Input signal the last time this filter was called. Supports 99 separate instances.
		REAL(4), DIMENSION(99), SAVE	:: InputSignalLast2			! Input signal the next to last time this filter was called. Supports 99 separate instances.
		REAL(4), DIMENSION(99), SAVE	:: OutputSignalLast1		! Output signal the last time this filter was called. Supports 99 separate instances.
		REAL(4), DIMENSION(99), SAVE	:: OutputSignalLast2		! Output signal the next to last time this filter was called. Supports 99 separate instances.

			! Initialization

		IF ((iStatus == 0) .OR. reset) THEN
			OutputSignalLast1(inst)  = InputSignal
			OutputSignalLast2(inst)  = InputSignal
			InputSignalLast1(inst)   = InputSignal
			InputSignalLast2(inst)   = InputSignal
		ENDIF

		K = 2/DT
		P1 = (K**2 + 2*omega*BetaNum*K + omega**2)/(K**2 + 2*omega*BetaDen*K + omega**2)
		P2 = (2*omega**2 - 2*K**2)  / (K**2 + 2*omega*BetaDen*K + omega**2);
		P3 = (K**2 - 2*omega*BetaNum*K + omega**2) / (K**2 + 2*omega*BetaDen*K + omega**2)
		P4 = (2*omega**2 - 2*K**2)  / (K**2 + 2*omega*BetaDen*K + omega**2)
		P5 = (K**2 - 2*omega*BetaDen*K + omega**2)/ (K**2 + 2*omega*BetaDen*K + omega**2)

			! Body

		NotchFilter = P1*InputSignal + P2*InputSignalLast1(inst) + P3*InputSignalLast2(inst) - P4*OutputSignalLast1(inst) - P5*OutputSignalLast2(inst)

			! Save signals for next time step

		InputSignalLast2(inst)   = InputSignalLast1(inst)
		InputSignalLast1(inst)   = InputSignal			!Save input signal for next time step
		OutputSignalLast2(inst)  = OutputSignalLast1(inst)		!Save input signal for next time step
		OutputSignalLast1(inst)  = NotchFilter
		inst = inst + 1

	END FUNCTION NotchFilter
	!-------------------------------------------------------------------------------------------------------------------------------
	END MODULE Filters


program fact
    implicit none

    !variables
    integer, parameter :: long = selected_int_kind(31)
    integer (kind=long):: i, n, res

    !datos de entrada
    res = 1
    print*, "Ingrese n entero:"
    read*, n

    !opearciones
    do i=1,n,1
        res = res * i
        print*, i, res
    end do

    end program


	FUNCTION PR_PMSL  ( pres, tmpc, dwpc, selv )
C************************************************************************
C* PR_PMSL								*
C*									*
C* This function computes PMSL from PRES, TMPC, DWPC, and SELV.  The	*
C* following equation is used:						*
C*									*
C*    PMSL = PRES * EXP ( ( GRAVTY * SELV ) / ( RDGAS * TVAVE ) )	*
C*									*
C*         TVAVE = avg virtual temp between station and sea level	*
C*               = TVRK + ( DELTV / 2 )					*
C*         DELTV = GAMUSD * SELV / 1000					*
C*									*
C* Wallace and Hobbs.							*
C*									*
C* REAL PR_PMSL  ( PRES, TMPC, DWPC, SELV )				*
C*									*
C* Input parameters:							*
C*	PRES		REAL	 	Station pressure in millibars	*
C*	TMPC		REAL	 	Temperature in Celsius		*
C*	DWPC		REAL	 	Dewpoint in Celsius		*
C*	SELV		REAL	 	Station elevation in meters	*
C*									*
C* Output parameters:							*
C*	PR_PMSL		REAL		Mean sea level pressure	in mb	*
C**									*
C* Log:									*
C* I. Graffman/RDS	11/84	Original source				*
C* G. Huffman/GSC       7/88	Revise 					*
C************************************************************************
        INCLUDE    'GEMPRM.PRM'
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing inputs.
C
	IF  ( ERMISS ( pres ) .or. ERMISS ( tmpc ) .or.
     +	      ERMISS ( dwpc ) .or. ERMISS ( selv ) )  THEN
	    PR_PMSL = RMISSD
	    RETURN
	END IF
C
C*	Calculate virtual temperature.
C
	tv = PR_TVRK  ( tmpc, dwpc, pres )
C
C*	Deltv and tvave.
C
	deltv = selv * GAMUSD / 1000.
	tvave = tv + ( deltv / 2. )
C
C*	Compute.
C
	PR_PMSL = pres * EXP ( ( GRAVTY * selv ) / (RDGAS * tvave) )
C*
	RETURN
	END


      SUBROUTINE ARCPTS (NUMPTS, XMID,YMID,RAD, ANG1, ANGINC, XA,YA,ZA)

C  ARCPTS fills in an array with points on an arc in x and y, on
C  an oblique plane (z = (x+y)/2)

C  Input parameters:
C    NUMPTS    : number of points to fill in
C    XMID,YMID : center of circle
C    RAD       : radius of circle
C    ANG1      : first angle
C    ANGINC    : angle increment
C  Output parameters:
C    XA,YA,ZA  : arc points returned

      INTEGER    NUMPTS, IX

      REAL       ANG, ANG1, ANGINC, XMID,YMID,RAD, XA(*),YA(*),ZA(*)

      ANG = ANG1
      DO 100 IX = 1,NUMPTS
         XA(IX) = XMID + RAD*COS(ANG)
         YA(IX) = YMID + RAD*SIN(ANG)
         ZA(IX) = 0.5*XA(IX) + 0.5*YA(IX)
         ANG = ANG + ANGINC
100   CONTINUE

      END


c     ==================================
      double precision function qtrue(x,y,z,t)
c     ==================================
      implicit double precision (a-h,o-z)
      common /cparam/ ubar,vbar,wbar

      x0 = x - ubar*t
      y0 = y - vbar*t
      z0 = z - wbar*t

c     # evaluate desired initial data at (x0,y0,z0):

c linear test function to see if ghost cell interpolation exact
      qtrue = 1.d0*x0 + 2.0d0*y0 + 3.d0*z0
      !qtrue = 1.d0*x0
      !if (x0 .lt. xupper/2) then
      !    qtrue = 1.d0
      !else
      !    qtrue = 2.d0
      !endif

      return
      end


module constants
	implicit none
	save
	!
	!FLOATING POINT
	integer, 		parameter 	:: 	dp 				= kind(0.d0)
	real(dp),		parameter	:: 	fp_acc			= 1e-14_dp
	real(dp),		parameter	::	real_0			= 0.0_dp
	complex(dp),	parameter	:: 	cmplx_0			= cmplx(real_0,real_0,dp)
	!		~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	!
	!MATHEMATICAL
	real(dp), 		parameter 	::	PI_dp 			= 4 * atan (1.0_dp)
	complex(dp),	parameter 	::	i_dp 			= cmplx(0.0_dp, 1.0_dp, dp)
	!		~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	!
	!PHYSICAL
	real(dp),		parameter 	::	aUtoAngstrm 	= 0.52917721092_dp, &			!	Bohr 			->	Angstroem
									aUtoEv	 		= 27.211385_dp					!	Hartree			->	eV
	real(dp),		parameter	::	aUtoTesla		= 235051.76_dp					!	mag.Field(au,si)->	Tesla
	real(dp),		parameter	::	speedOfLight	= 137.035999_dp 				!	in atomic units
	real(dp),		parameter	::	kBoltz_Eh_K		= 8.6173303_dp * 1e-5_dp / aUtoEv 		!kBoltz from wiki: kB	=	8.6173303(50)×10−5	eV⋅K−1
	real(dp),		parameter	::	T_room			= 300.0_dp
	!		~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
end module constants


    Program dgelqf_example

!     DGELQF Example Program Text

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

!     .. Use Statements ..
      Use blas_interfaces, Only: dtrsm
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgelqf, dormlq
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: one = 1.0E0_dp
      Real (Kind=dp), Parameter :: zero = 0.0E0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, lda, ldb, lwork, m, n, nrhs
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:, :), tau(:), work(:)
!     .. Executable Statements ..
      Write (nout, *) 'DGELQF Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, nrhs
      lda = m
      ldb = n
      lwork = 64*n
      Allocate (a(lda,n), b(ldb,nrhs), tau(n), work(lwork))

!     Read A and B from data file

      Read (nin, *)(a(i,1:n), i=1, m)
      Read (nin, *)(b(i,1:nrhs), i=1, m)

!     Compute the LQ factorization of A
      Call dgelqf(m, n, a, lda, tau, work, lwork, info)

!     Solve L*Y = B, storing the result in B
      Call dtrsm('Left', 'Lower', 'No transpose', 'Non-Unit', m, nrhs, one, a, &
        lda, b, ldb)

!     Set rows (M+1) to N of B to zero

      If (m<n) Then
        b(m+1:n, 1:nrhs) = zero
      End If

!     Compute minimum-norm solution X = (Q**T)*B in B
      Call dormlq('Left', 'Transpose', n, nrhs, m, a, lda, tau, b, ldb, work, &
        lwork, info)

!     Print minimum-norm solution(s)

      Write (nout, *)
      Flush (nout)

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, nrhs, b, ldb, &
        'Minimum-norm solution(s)', ifail)

    End Program


! { dg-do run }
! { dg-options "-ffrontend-optimize" }
! Do not move common functions out of implicit DO loop constructors.
program test
  integer, parameter :: N = 4
  integer, parameter :: dp=kind(1.d0)
  real(kind=dp), parameter :: pi=4*atan(1._dp)
  real(kind=dp), parameter :: eps = 1.e-14_dp
  real(kind=dp) :: h1(0:N-1), h2(0:N-1)
  integer i

  i = 1
  h1 = [(cos(2*pi*mod(i*k,N)/N),k=0,N/2), &
       & (sin(2*pi*mod(i*k,N)/N),k=1,N/2-1)]
  h2 = (/ 1._dp, 0._dp, -1._dp, 1._dp /)
  if (any(abs(h1 - h2) > eps)) STOP 1
end program test


program gauss_ppal

use gaussb_interface
use sistub_interface
use datasissim_interface
use residuo_interface

implicit none

real, dimension(:,:), allocatable :: a
real, dimension(:,:), allocatable :: a_copia
real, dimension(:), allocatable :: b
real, dimension(:), allocatable :: b_copia
real, dimension(:), allocatable :: u
real, dimension(:), allocatable :: r

real :: deter

integer :: n, i, j

print*
print*, 'Introduce o orde do sistema: '
read*, n
print*

print*
print*, 'O orde introduce e: ', n
print*

allocate(a(n,n), a_copia(n,n), b(n), b_copia(n), u(n), r(n))

u = 0

call datasissim(a, b)

a_copia = a

b_copia = b

call gaussb(a, b, deter)

write(*,*) 'Matriz A:'

do i = 1,n
  print*, a(i,:)
end do

call sistub(a, b, u)

call residuo(a_copia, b_copia, u, r)

print*,
print*, 'Vector u (Solucion): '
print*,

print*,
print*, u
print*,

if (allocated(a)) deallocate(a)

if (allocated(a_copia)) deallocate(a_copia)

if (allocated(b)) deallocate(b)

if (allocated(b_copia)) deallocate(b_copia)

if (allocated(u)) deallocate(u)

if(allocated(r)) deallocate(r)

end program


real*8 function SHMagPowerL(c, a, r, l)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function will compute the dimensionless power for
!	degree l of the magnetic field evaluated at radius R,
!	given the Schmidt seminormalized spherical harmonic
!	coefficients c(i, l, m) of the magnetic potential evaluated
!	at radius A.
!
!	Power(l) = (a/r)^(2l+4) (l+1) Sum_{m=0}^l ( C1lm**2 + C2lm**2 )
!
!	Calling Parameters
!		c	Schmidt seminormalized spherical harmonic coefficients of the
!			magnetic potential evaluated at radius A, dimensioned as (2, lmax+1, lmax+1).
!		a	Reference radius of the magnetic potential spherical harmonic coefficients.
!		r	Radius to evaluate the magnetic field.
!		l	Spherical harmonic degree to compute power.
!
!	Written by Mark Wieczorek, March 2008.
!
!	Copyright (c) 2008, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none

	real*8, intent(in) :: c(:,:,:)
	real*8, intent(in) :: a, r
	integer, intent(in) :: l
	integer i, m, l1, m1

	l1 = l+1

	if (size(c(:,1,1)) < 2 .or. size(c(1,:,1)) < l1 .or. size(c(1,1,:)) < l1) then
		print*, "SHMagPowerL --- Error"
		print*, "C must be dimensioned as (2, L+1, L+1) where L is ", l
		print*, "Input array is dimensioned ", size(c(:,1,1)),  size(c(1,:,1)), size(c(1,1,:))
		stop
	endif

	SHMagPowerL = 0.0d0

	do m = 0, l
		m1 = m+1
		do i=1, 2
			SHMagPowerL = SHMagPowerL + c(i, l1, m1)**2
		enddo
	enddo

	SHMagPowerL = SHMagPowerL * dble(l+1) * (a/r)**(2*l+4)

end function SHMagPowerL

subroutine SHMagPowerSpectrum(c, a, r, lmax, spectra)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function will compute the dimensionless power spectrum
!	of the magnetic field evaluated at radius R,
!	given the Schmidt seminormalized spherical harmonic
!	coefficients c(i, l, m) of the magnetic potential evaluated
!	at radius A.
!
!	Power(l) = (a/r)^(2l+4) (l+1) Sum_{m=0}^l ( C1lm**2 + C2lm**2 )
!
!	Calling Parameters
!		IN
!			c	Schmidt seminormalized spherical harmonic coefficients of the
!				magnetic potential evaluated at radius A, dimensioned as
!				(2, lmax+1, lmax+1).
!			a	Reference radius of the magnetic potential spherical harmonic
!				coefficients.
!			r	Radius to evaluate the magnetic field.
!			lmax	Maximum spherical harmonic degree to compute power of.
!		OUT
!			spectra	Array of length (lmax+1) containing the power spectra of c.
!
!	Written by Mark Wieczorek, March 2008.
!
!	Copyright (c) 2008, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(in) :: c(:,:,:)
	real*8, intent(in) :: a, r
	integer, intent(in) :: lmax
	real*8, intent(out) ::	spectra(:)
	integer i, m, l1, m1, l

	if (size(c(:,1,1)) < 2 .or. size(c(1,:,1)) < lmax+1 .or. size(c(1,1,:)) < lmax+1) then
		print*, "SHMagPowerSpectrum --- Error"
		print*, "C must be dimensioned as (2, LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned ", size(c(:,1,1)),  size(c(1,:,1)), size(c(1,1,:))
		stop
	elseif (size(spectra) < lmax+1) then
		print*, "SHMagPowerSpectrum --- Error"
		print*, "SPECTRA must be dimensioned as (LMAX+1) where LMAX is ", lmax
		print*, "Input vector has dimension ", size(spectra)
		stop
	endif

	spectra = 0.0d0

	do l=0, lmax
		l1 = l+1

		do m = 0, l
			m1 = m+1

			do i=1, 2
				spectra(l1) = spectra(l1) + c(i, l1, m1)**2
			enddo
		enddo

		spectra(l1) = spectra(l1) * dble(l+1) * (a/r)**(2*l+4)
	enddo

end subroutine SHMagPowerSpectrum


c$$$      subroutine get_a_not_hex(xc,anot)
c$$$
c$$$      include "common.h"
c$$$
c$$$      dimension xc(npro,nenl,nsd), anot(npro,nenl,nsd)
c$$$
c$$$
c$$$      do i = 1, nsd
c$$$
c$$$         anot(:,1,i) = pt125*(xc(:,1,i)+xc(:,2,i)+xc(:,3,i)+xc(:,4,i)
c$$$     &        +xc(:,5,i)+xc(:,6,i)+xc(:,7,i)+xc(:,8,i))
c$$$
c$$$         anot(:,2,i) = pt125*(-xc(:,1,i)+xc(:,2,i)+xc(:,3,i)-xc(:,4,i)
c$$$     &        -xc(:,5,i)+xc(:,6,i)+xc(:,7,i)-xc(:,8,i))
c$$$
c$$$         anot(:,3,i) = pt125*(-xc(:,1,i)-xc(:,2,i)+xc(:,3,i)+xc(:,4,i)
c$$$     &        -xc(:,5,i)-xc(:,6,i)+xc(:,7,i)+xc(:,8,i))
c$$$
c$$$         anot(:,4,i) = pt125*(-xc(:,1,i)-xc(:,2,i)-xc(:,3,i)-xc(:,4,i)
c$$$     &        +xc(:,5,i)+xc(:,6,i)+xc(:,7,i)+xc(:,8,i))
c$$$
c$$$         anot(:,5,i) = pt125*(xc(:,1,i)-xc(:,2,i)+xc(:,3,i)-xc(:,4,i)
c$$$     &        +xc(:,5,i)-xc(:,6,i)+xc(:,7,i)-xc(:,8,i))
c$$$
c$$$         anot(:,6,i) = pt125*(xc(:,1,i)+xc(:,2,i)-xc(:,3,i)-xc(:,4,i)
c$$$     &        -xc(:,5,i)-xc(:,6,i)+xc(:,7,i)+xc(:,8,i))
c$$$
c$$$         anot(:,7,i) = pt125*(xc(:,1,i)-xc(:,2,i)-xc(:,3,i)+xc(:,4,i)
c$$$     &        -xc(:,5,i)+xc(:,6,i)+xc(:,7,i)-xc(:,8,i))
c$$$
c$$$         anot(:,8,i) = pt125*(-xc(:,1,i)+xc(:,2,i)-xc(:,3,i)+xc(:,4,i)
c$$$     &        +xc(:,5,i)-xc(:,6,i)+xc(:,7,i)-xc(:,8,i))
c$$$
c$$$      enddo
c$$$
c$$$      return
c$$$      end

      subroutine get_coeff_tet(xc,anot)

      use spebc
      include "common.h"

      dimension xc(nelint,nenl,nsd), anot(nelint,nenl,nsd)

      do i = 1, nsd

         anot(:,1,i) = xc(:,4,i)
         anot(:,2,i) = xc(:,1,i)-xc(:,4,i)
         anot(:,3,i) = xc(:,2,i)-xc(:,4,i)
         anot(:,4,i) = xc(:,3,i)-xc(:,4,i)

      enddo

      return
      end


      SUBROUTINE NEWTON1(T,A_IN,A_OUT,NLOOP,NF)
C     Author: R.K. Ellis

c---  calculate a_out using nloop beta-function evolution
c---  with nf flavours, given starting value as-in
c---  given as_in and logarithmic separation between
c---  input scale and output scale t.
c---  Evolution is performed using Newton's method,
c---  with a precision given by tol.

      IMPLICIT NONE
      INTEGER NLOOP,NF
      REAL*8 T,A_IN,A_OUT,AS,TOL,F2,F3,F,FP,DELTA
      REAL*8 B0(0:6),C1(0:6),C2(0:6),DEL(0:6)
      PARAMETER(TOL=5D-4)
C---     B0=(11.-2.*NF/3.)/4./PI
      DATA B0/
     &   0.8753521870054244D0,0.822300539308126D0,0.7692488916108274D0,
     &   0.716197243913529D0,0.6631455962162306D0,0.6100939485189321D0,
     &   0.5570423008216338D0/
C---     C1=(102.D0-38.D0/3.D0*NF)/4.D0/PI/(11.D0-2.D0/3.D0*NF)
      DATA C1/
     &   0.7379001906987874D0,0.6879600765907734D0,0.631131670881654D0,
     &   0.5658842421045168D0,0.4901972247230377D0,0.4013472477969535D0,
     &   0.2955734657420913D0/
C---     C2=(2857.D0/2.D0-5033*NF/18.D0+325*NF**2/54)
C---     /16.D0/PI**2/(11.D0-2.D0/3.D0*NF)
      DATA C2/
     &   0.8223710842788609D0,0.7077616059424726D0,0.5852293127502415D0,
     &   0.4530135791786467D0,0.3087903795366415D0,0.1494273313710745D0,
     &  -0.02940123632478559D0/
C---     DEL=SQRT(4*C2-C1**2)  (DEL(6) imaginary, set equal to zero
      DATA DEL/
     &   1.656800424215946D0,1.535499057891964D0,1.393768296744871D0,
     &   1.221404659092302D0,0.9974307991136014D0,0.660779624511916D0,
     &   0D0/

      DATA F,FP/0d0,1d0/
      F2(AS)=1D0/AS+C1(NF)*LOG((C1(NF)*AS)/(1D0+C1(NF)*AS))
      F3(AS)=1D0/AS+0.5D0*C1(NF)
     & *LOG((C2(NF)*AS**2)/(1D0+C1(NF)*AS+C2(NF)*AS**2))
     & -(C1(NF)**2-2D0*C2(NF))/DEL(NF)
     & *ATAN((2D0*C2(NF)*AS+C1(NF))/DEL(NF))

      IF ((NF .lt. 0) .or. (NF .gt. 6)
     & .or. ((NF.eq.6) .and. (NLOOP.gt.2))
     & .or. (NLOOP.lt.1)) then
          write(6,*) 'unimplemented value of NF/NLOOP in newton1.f'
          write(6,*) 'NF,NLOOP=',NF,NLOOP
          STOP
      ENDIF

      A_OUT=A_IN/(1D0+A_IN*B0(NF)*T)
      IF (NLOOP .EQ. 1) RETURN
      A_OUT=A_IN/(1D0+B0(NF)*A_IN*T+C1(NF)*A_IN*LOG(1D0+A_IN*B0(NF)*T))
      IF (A_OUT .LT. 0D0) AS=0.3D0
 30   AS=A_OUT

      IF (NLOOP .EQ. 2) THEN
          F=B0(NF)*T+F2(A_IN)-F2(AS)
          FP=1D0/(AS**2*(1D0+C1(NF)*AS))
      ELSEIF (NLOOP .EQ. 3) THEN
          F=B0(NF)*T+F3(A_IN)-F3(AS)
          FP=1D0/(AS**2*(1D0+C1(NF)*AS+C2(NF)*AS**2))
      ELSE
          WRITE(6,*) 'Unimplemented value of NLOOP in newton1'
          stop
      ENDIF
      A_OUT=AS-F/FP
      DELTA=ABS(F/FP/AS)
      IF (DELTA .GT. TOL) GO TO 30
      RETURN
      END


***************************************************************************
*      Pratical method for determing the minimum embedding dimension      *
*                     if a scalar time series                             *
*           L. Cao, Physica D, 110 (1 & 2), 43-52, 1997.                  *
*                                                                         *
*   Notices:   This program is ONLY used for your researches.             *
*                                                                         *
*	                                Liangyue Cao       March,1997.    *
***************************************************************************
      dimension x(100000),v(50),a(50),ya(50)
      double precision  v,v0,vij
      integer d, tau

***************************************************************************
*     ndp  is the number of data points used for your calculation;
*     ndp  should be smaller than 100000;
*     tau  is the time-delay used for phase space reconstructions;
*     maxd is the maximum dimension which you want to test;
*     maxd should be smaller than 50.
***************************************************************************
      Ndp=10000  		! Number of data points
      tau=15 			! Time delay value
      maxd=10			! Maximum embedding dimension
      open(9,file='measurement.dat')              ! Data file
      open(10,file='E1.dat')
      open(11,file='E2.dat')             ! Result file
      read(9,*) (x(i),i=1,ndp)
      do d=1,maxd
	a(d)=0.
	ya(d)=0.
	ng=ndp-d*tau
	do i=1,ng
	  v0=1.e+30
	  do j=1,ng
	    if(j.eq.i) go to 20
	    do k=1,d
	      v(k)=abs(x(i+(k-1)*tau)-x(j+(k-1)*tau))
            enddo
	    if (d.eq.1) go to 50
	    do k=1,d-1
	      v(k+1)=max(v(k),v(k+1))
            enddo
 50	    vij=v(d)
	    if (vij.lt.v0.and.vij.ne.0.) then
	        n0=j
	        v0=vij
	    endif
 20	    continue
          enddo
	  a(d)=a(d)+max(v0,abs(x(i+d*tau)-x(n0+d*tau)))/v0
	  ya(d)=ya(d)+abs(x(i+d*tau)-x(n0+d*tau))
        enddo
 	a(d)=a(d)/float(ng)
 	ya(d)=ya(d)/float(ng)
	if (d.ge.2) then
	    write(11,*) d-1,ya(d)/ya(d-1)
	    write(10,*) d-1, a(d)/a(d-1)
            write(*,*) d-1,'   E1=', a(d)/a(d-1),
     $             '    E2=', ya(d)/ya(d-1)
	endif
      enddo
      close(10)
      close(11)
      call system("xmgrace E2.dat")
      end