c=======================================================================
c=======================================================================
c     SUBROUTINES FOR RANDOM SEQUENTIAL BARYCENTER ARRAYS
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=======================================================================
c=======================================================================

c=======================================================================
c=======================================================================
c=======================================================================
c     AUXILIARY FUNCTIONS/COMMON FUNCTIONS
c=======================================================================
c=======================================================================
c=======================================================================

c=======================================================================
       subroutine gennsba(maxn,maxr,mu0,sd0,mu1,sd1,sba)
c=======================================================================
c      Generates a 'normal' sequential barycenter array.
c
c      Alejandro Jara, 2010.
c=======================================================================
       implicit none

c+++++ Input
       integer maxn,maxr
       real*8 mu0,sd0,mu1,sd1

c+++++ Output
       real*8 sba(maxn,maxr)

c+++++ Internal working space
       integer i,j,nn
       real*8 rnorm,rtnorm,ll,uu
       logical linf,lsup

c+++++ Algorithm

       if(sd0.eq.0.d0)then
          sba(1,1)=mu0
         else
          sba(1,1)=rnorm(mu0,sd0)
       end if

       do i=2,maxn

          call rchkusr()

          nn=(2**(i-1))-1
          do j=1,nn
             sba(i,2*j)=sba(i-1,j)
          end do

          nn=2**(i-1)
          do j=1,nn
             if(j.eq.1)then
                linf=.true.
                lsup=.false.
                ll=0.d0
                uu=sba(i-1,j)
                sba(i,2*j-1)=rtnorm(mu1,sd1,ll,uu,linf,lsup)
              else if(j.eq.nn)then
                linf=.false.
                lsup=.true.
                ll=sba(i-1,j-1)
                uu=0.d0
                sba(i,2*j-1)=rtnorm(mu1,sd1,ll,uu,linf,lsup)
              else
                linf=.false.
                lsup=.false.
                ll=sba(i-1,j-1)
                uu=sba(i-1,j)
                sba(i,2*j-1)=rtnorm(mu1,sd1,ll,uu,linf,lsup)
             end if
          end do
       end do

       return
       end

c=======================================================================
       subroutine discrsba(maxn,maxr,maxc,sba,f,theta,w)
c=======================================================================
c      Computes the weights and point masses from a RSBA.
c
c      Alejandro Jara, 2010.
c=======================================================================
       implicit none

c+++++ Input
       integer maxn,maxr,maxc
       real*8 sba(maxn,maxr)

c+++++ External working space
       real*8 f(maxn-1,maxc-1)

c+++++ Output
       real*8 theta(maxc)
       real*8 w(maxc)

c+++++ Internal working space
       integer count,i,j,nn
       real*8 ll,uu

c+++++ Algorithm

       f(1,1)=(sba(2,3)-sba(2,2))/(sba(2,3)-sba(2,1))

       do i=2,maxn-1

          call rchkusr()

          nn=(2**(i-1))-1
          do j=1,nn
             f(i,2*j)=f(i-1,j)
          end do

          nn=2**(i-1)
          do j=1,nn
             if(j.eq.1)then
                ll=0.0
                uu=f(i-1,j)
              else if(j.eq.nn)then
                ll=f(i-1,j-1)
                uu=1.0
              else
                ll=f(i-1,j-1)
                uu=f(i-1,j)
             end if
             f(i,2*j-1)=ll+(uu-ll)*
     &                     exp(
     &                       log(sba(i+1,4*j-1)-sba(i+1,4*j-2))-
     &                       log(sba(i+1,4*j-1)-sba(i+1,4*j-3)))
          end do
       end do

       w(1)=f(maxn-1,1)
       w(maxc)=1.d0-f(maxn-1,maxc-1)

       do i=2,maxc-1
          w(i)=f(maxn-1,i)-f(maxn-1,i-1)
       end do

       count=1
       do i=1,maxc
          theta(i)=sba(maxn,count)
          count=count+2
       end do

       return
       end

c=======================================================================
      integer function ceil(x)
c=======================================================================
c     Ceiling function.
c
c     Alejandro Jara, 2010.
c=======================================================================
      implicit none
      real*8 x
      ceil=x
      if(ceil.lt.x) ceil=ceil+1
      end

c=======================================================================
      subroutine isweight(x,out)
c=======================================================================
c     Determines whether a barycenter just modifies the weights
c     (out=1) or the atoms as well (out=0).
c
c     Alejandro Jara, 2010.
c=======================================================================
      implicit none
      integer x,y,ceil,out

      y=ceil(x/2.d0)*2
      out=0
      if(y.eq.x) out=1
      return
      end

c=======================================================================
      subroutine rsbauclus(nrec,y,maxn,maxc,w,theta,sigma2,prob,
     &                     ccluster,cstrt,ss)
c=======================================================================
c      Update the cluster indicators.
c
c      Alejandro Jara, 2010.
c=======================================================================
      implicit none

c++++ Input
      integer maxn,maxc,nrec
      real*8 y(nrec)
      real*8 w(maxc)
      real*8 theta(maxc)
      real*8 sigma2(maxc)

c++++ External working space
      real*8 prob(maxc)

c++++ Output
      integer ccluster(maxc)
      integer cstrt(maxc,nrec)
      integer ss(nrec)

c++++ Internal working space
      integer i,ind,j
      real*8 dnrm

c++++ Algorithm

      do i=1,maxc
         ccluster(i)=0
      end do

      do i=1,nrec
         call rchkusr()

         do j=1,maxc
            prob(j)=w(j)*dnrm(y(i),theta(j),sqrt(sigma2(j)),0)
         end do
         call simdisc(prob,maxc,maxc,ind)

         ss(i)=ind
         ccluster(ss(i))=ccluster(ss(i))+1
         cstrt(ss(i),ccluster(ss(i)))=i
      end do

      return
      end

c=======================================================================
      subroutine rsbauclus2(nrec,y,maxn,maxc,w,theta,sigma2,prob,
     &                      ccluster,cstrt,ss)
c=======================================================================
c      Update the cluster indicators.
c
c      Alejandro Jara, 2010.
c=======================================================================
      implicit none

c++++ Input
      integer maxn,maxc,nrec
      real*8 y(nrec)
      real*8 w(maxc)
      real*8 theta(maxc)
      real*8 sigma2

c++++ External working space
      real*8 prob(maxc)

c++++ Output
      integer ccluster(maxc)
      integer cstrt(maxc,nrec)
      integer ss(nrec)

c++++ Internal working space
      integer i,ind,j
      real*8 dnrm

c++++ Algorithm

      do i=1,maxc
         ccluster(i)=0
      end do

      do i=1,nrec
         call rchkusr()

         do j=1,maxc
            prob(j)=w(j)*dnrm(y(i),theta(j),sqrt(sigma2),0)
         end do
         call simdisc(prob,maxc,maxc,ind)

         ss(i)=ind
         ccluster(ss(i))=ccluster(ss(i))+1
         cstrt(ss(i),ccluster(ss(i)))=i
      end do

      return
      end

c=======================================================================
      subroutine rsbaukvar(nrec,y,maxn,maxc,ccluster,cstrt,ss,theta,
     &                     tau1,tau2,
     &                     sigma2)
c=======================================================================
c     Updates the kernel variances.
c
c     Alejandro Jara, 2010.
c=======================================================================
      implicit none

c++++ Input
      integer maxn,maxc,nrec
      integer ccluster(maxc)
      integer cstrt(maxc,nrec)
      integer ss(nrec)
      real*8 y(nrec)
      real*8 theta(maxc)
      real*8 tau1,tau2

c++++ Output
      real*8 sigma2(maxc)

c++++ Internal working space
      integer i,ind,j,nr,ns
      real*8 rgamma,sse,tmp1

c++++ Algorithm

      do i=1,maxc
         call rchkusr()

         ns=ccluster(i)
         sse=0.d0

         if(ns.gt.0)then
            do j=1,ns
               tmp1=y(cstrt(i,j))-theta(i)
               sse=sse+tmp1*tmp1
            end do
         end if
         sigma2(i)=1.d0/rgamma(0.5d0*(tau1+dble(ns)),
     &                         0.5d0*(tau2+sse))
      end do

      return
      end

c=======================================================================
      subroutine rsbaukvar2(nrec,y,maxn,maxc,ccluster,cstrt,ss,theta,
     &                      tau1,tau2,
     &                      sigma2)
c=======================================================================
c     Updates the kernel variance.
c
c     Alejandro Jara, 2010.
c=======================================================================
      implicit none

c++++ Input
      integer maxn,maxc,nrec
      integer ccluster(maxc)
      integer cstrt(maxc,nrec)
      integer ss(nrec)
      real*8 y(nrec)
      real*8 theta(maxc)
      real*8 tau1,tau2

c++++ Output
      real*8 sigma2

c++++ Internal working space
      integer i,ind,j,nr,ns
      real*8 rgamma,sse,tmp1

c++++ Algorithm

      do i=1,maxc
         call rchkusr()

         ns=ccluster(i)
         sse=0.d0

         if(ns.gt.0)then
            do j=1,ns
               tmp1=y(cstrt(i,j))-theta(i)
               sse=sse+tmp1*tmp1
            end do
         end if
      end do

      sigma2=1.d0/rgamma(0.5d0*(tau1+dble(nrec)),
     &                   0.5d0*(tau2+sse))

      return
      end

c=======================================================================
      subroutine rsbaugamma(maxc,sigma2,
     &                      tau1,taus1,taus2,
     &                      tau2)
c=======================================================================
c      Update the gamma hyperparameter for the kernel variances.
c
c      Alejandro Jara, 2010.
c=======================================================================
      implicit none

c++++ Input
      integer maxc
      real*8 sigma2(maxc)
      real*8 tau1,taus1,taus2

c++++ Output
      real*8 tau2

c++++ Internal working space
      integer i
      real*8 tmp1,rgamma

c++++ Algorithm

      tmp1=0.d0
      do i=1,maxc
         call rchkusr()
         tmp1=tmp1+1.d0/sigma2(i)
      end do

      tau2=rgamma(0.5d0*(dble(maxc)*tau1+taus1),
     &            0.5d0*(tmp1+taus2))

      return
      end

c=======================================================================
      subroutine rsbaposs(maxn,ii,ismean,nb,possv)
c=======================================================================
c     Determines the elements that need to be changed when
c     updating the elements of the last level of the barycenter array.
c     The output includes the vector of positions (possv),
c     how many levels need to be updated (nb) and whether
c     the barycenter corresponds to the mean (ismean=1) or not
c     (ismean=0).
c
c     Alejandro Jara, 2010.
c=======================================================================

      implicit none
c++++ Input
      integer maxn,ii

c++++ Output
      integer ismean,nb,possv(maxn)

c++++ Internal working space
      integer i,ind,jj,nr,out

c++++ Algorithm

      out=0
      nb=0
      ismean=0
      do i=1,maxn
         possv(i)=0
      end do

      possv(maxn)=ii
      i=0
      do while(out.eq.0.and.i.lt.(maxn-1))
         i=i+1
         jj=possv(maxn-i+1)
         call isweight(jj,ind)
         if(ind.eq.0)then
            out=1
           else
            nb=nb+1
            possv(maxn-i)=int(jj/2)
         end if
      end do

      if(nb.eq.(maxn-1))ismean=1
      return
      end

c=======================================================================
      subroutine rsbawlogpost(ii,cind,xx,sigma2c,isw,ism,
     &                        nrec,y,
     &                        maxn,maxc,w,
     &                        ccluster,cstrt,
     &                        mu0,sigma20,mu1,sigma21,
     &                        out)
c=======================================================================
      implicit none
c++++ Input
      integer cind,ii,maxn,maxc,nrec,isw,ism
      integer ccluster(maxc)
      integer cstrt(maxc,nrec)
      real*8 xx,sigma2c,w(maxc)
      real*8 mu0,sigma20,mu1,sigma21
      real*8 y(nrec)

c++++ Output
      real*8 out

c++++ Internal working space
      integer i,ns
      real*8 dnrm

c++++ Algorithm

      out=0.d0
      do i=1,maxc
         out=out+dble(ccluster(i))*log(w(i))
      end do

      if(ism.eq.1)then
         out=out+dnrm(xx,mu0,sqrt(sigma20),1)
       else
         out=out+dnrm(xx,mu1,sqrt(sigma21),1)
      end if

      if(isw.eq.0)then
         ns=ccluster(cind)

         if(ns.gt.0)then
            do i=1,ns
               out=out+
     &         dnrm(y(cstrt(cind,i)),xx,sqrt(sigma2c),1)
            end do
         end if
      end if

      return
      end

c=======================================================================
      subroutine rsbauba(nrec,y,
     &                   maxn,maxr,maxc,
     &                   mu0,mu1,sigma20,sigma21,
     &                   ccluster,cstrt,sigma2,
     &                   f,possv,
     &                   sba,theta,w)
c=======================================================================
c      Update the RSBA parameters.
c
c      Alejandro Jara, 2010.
c=======================================================================

      implicit none

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

c++++ Prior
      integer maxn,maxr,maxc
      real*8 mu0,sigma20
      real*8 mu1,sigma21

c++++ Current state of the chain (cluster info)
      integer ccluster(maxc)
      integer cstrt(maxc,nrec)
      real*8 sigma2(maxc)

c++++ External working space
      integer possv(maxn)
      real*8 f(maxn-1,maxc-1)

c++++ Input/Output (RSBA elements)
      real*8 sba(maxn,maxr)
      real*8 theta(maxc)
      real*8 w(maxc)

c++++ Internal working space
      integer cind
      integer i,isw,ism,j,k,nb,ns
      real*8 tmp1

c++++ RNG and distributions
      real runif

c++++ Working space slice sampling
      integer evali
      real*8 rexpo,re,uwork
      real*8 logy,xx0,xx1,llim,rlim
      real*8 grlim,gllim,gxx0,gxx1

c++++ Algorithm

      cind=0

      do i=1,maxr

         call rchkusr()

         call isweight(i,isw)
         call rsbaposs(maxn,i,ism,nb,possv)

         if(isw.eq.0)cind=cind+1

         if(ism.eq.0.or.(ism.eq.1.and.sigma20.gt.0.d0))then
            evali=1
            xx0=sba(maxn,i)
            re=rexpo(1.d0)
            logy=-re

            call rsbawlogpost(i,cind,xx0,sigma2(cind),isw,ism,
     &                        nrec,y,
     &                        maxn,maxc,w,
     &                        ccluster,cstrt,
     &                        mu0,sigma20,mu1,sigma21,
     &                        tmp1)

            logy=logy+tmp1
            uwork=dble(runif())*0.25d0
            llim=xx0-uwork
            rlim=llim+0.25d0

            if(i.eq.1)then
               if(rlim.gt.sba(maxn,i+1))rlim=sba(maxn,i+1)
              else if(i.eq.maxr)then
               if(llim.lt.sba(maxn,i-1))llim=sba(maxn,i-1)
              else
               if(llim.lt.sba(maxn,i-1))llim=sba(maxn,i-1)
               if(rlim.gt.sba(maxn,i+1))rlim=sba(maxn,i+1)
            end if

            evali=evali+1
            sba(maxn,i)=llim
            if(nb.gt.0)then
               do j=1,nb
                  k=maxn-j
                  sba(k,possv(k))=llim
               end do
            end if
            call discrsba(maxn,maxr,maxc,sba,f,theta,w)

            call rsbawlogpost(i,cind,llim,sigma2(cind),isw,ism,
     &                        nrec,y,
     &                        maxn,maxc,w,
     &                        ccluster,cstrt,
     &                        mu0,sigma20,mu1,sigma21,
     &                        gllim)

            evali=evali+1
            sba(maxn,i)=rlim
            if(nb.gt.0)then
               do j=1,nb
                  k=maxn-j
                  sba(k,possv(k))=rlim
               end do
            end if
            call discrsba(maxn,maxr,maxc,sba,f,theta,w)

            call rsbawlogpost(i,cind,rlim,sigma2(cind),isw,ism,
     &                        nrec,y,
     &                        maxn,maxc,w,
     &                        ccluster,cstrt,
     &                        mu0,sigma20,mu1,sigma21,
     &                        grlim)

            do while(gllim.gt.logy)
               llim=llim-0.25d0

               if(i.gt.1.and.llim.lt.sba(maxn,i-1))then
                  llim=sba(maxn,i-1)
                  gllim=logy-1.d0
                else
                  evali=evali+1
                  sba(maxn,i)=llim
                  if(nb.gt.0)then
                     do j=1,nb
                        k=maxn-j
                        sba(k,possv(k))=llim
                     end do
                  end if
                  call discrsba(maxn,maxr,maxc,sba,f,theta,w)

                  call rsbawlogpost(i,cind,llim,sigma2(cind),
     &                              isw,ism,
     &                              nrec,y,
     &                              maxn,maxc,w,
     &                              ccluster,cstrt,
     &                              mu0,sigma20,mu1,sigma21,
     &                              gllim)
               end if
            end do

            do while(grlim.gt.logy)
               rlim=rlim+0.25d0

               if(i.lt.maxr.and.rlim.gt.sba(maxn,i+1))then
                  rlim=sba(maxn,i+1)
                  grlim=logy-1.d0
                else
                  evali=evali+1
                  sba(maxn,i)=rlim
                  if(nb.gt.0)then
                     do j=1,nb
                        k=maxn-j
                        sba(k,possv(k))=rlim
                     end do
                  end if
                  call discrsba(maxn,maxr,maxc,sba,f,theta,w)

                  call rsbawlogpost(i,cind,rlim,sigma2(cind),
     &                              isw,ism,
     &                              nrec,y,
     &                              maxn,maxc,w,
     &                              ccluster,cstrt,
     &                              mu0,sigma20,mu1,sigma21,
     &                              grlim)
               end if
            end do

            xx1=llim+(rlim-llim)*dble(runif())
            evali=evali+1

            sba(maxn,i)=xx1
            if(nb.gt.0)then
               do j=1,nb
                  k=maxn-j
                  sba(k,possv(k))=xx1
               end do
            end if
            call discrsba(maxn,maxr,maxc,sba,f,theta,w)

            call rsbawlogpost(i,cind,xx1,sigma2(cind),isw,ism,
     &                        nrec,y,
     &                        maxn,maxc,w,
     &                        ccluster,cstrt,
     &                        mu0,sigma20,mu1,sigma21,
     &                        gxx1)

            do while(gxx1.lt.logy)
               if(xx1.gt.xx0)rlim=xx1
               if(xx1.lt.xx0)llim=xx1

               if(i.eq.1)then
                  if(rlim.gt.sba(maxn,i+1))rlim=sba(maxn,i+1)
                 else if(i.eq.maxr)then
                  if(llim.lt.sba(maxn,i-1))llim=sba(maxn,i-1)
                 else
                  if(llim.lt.sba(maxn,i-1))llim=sba(maxn,i-1)
                  if(rlim.gt.sba(maxn,i+1))rlim=sba(maxn,i+1)
               end if

               xx1=llim+(rlim-llim)*dble(runif())

               sba(maxn,i)=xx1
               if(nb.gt.0)then
                  do j=1,nb
                     k=maxn-j
                     sba(k,possv(k))=xx1
                  end do
               end if
               call discrsba(maxn,maxr,maxc,sba,f,theta,w)

               call rsbawlogpost(i,cind,xx1,sigma2(cind),isw,ism,
     &                           nrec,y,
     &                           maxn,maxc,w,
     &                           ccluster,cstrt,
     &                           mu0,sigma20,mu1,sigma21,
     &                           gxx1)

c               call intpr("evaluation c#",-1,evali,1)
c               call dblepr("xx1",-1,xx1,1)
c               call dblepr("gxx1",-1,gxx1,1)
            end do

         end if

      end do

      return
      end

c=======================================================================
       subroutine lposth1msba(maxn,maxr,mu1,sigma21,sba,m1,s1,lpost)
c=======================================================================
c      Computes the log posterior for the mean of the normal
c      measure of the conditional means in a 'normal' sequential
c      barycenter array.
c
c      Alejandro Jara, 2011.
c=======================================================================
       implicit none

c+++++ Input
       integer maxn,maxr
       real*8 mu1,sigma21
       real*8 sba(maxn,maxr)
       real*8 m1,s1

c+++++ Output
       real*8 lpost

c+++++ Internal working space
       integer i,j,nn
       real*8 ll,uu,xx
       real*8 tmp1,tmp2,tmp3,tmp4
       real*8 cdfnorm,dnrm
       real*8 sd1

c+++++ Algorithm

       sd1=dsqrt(sigma21)
       lpost=0.d0

       do i=2,maxn

          call rchkusr()

          do j=1,nn
             xx=sba(i,2*j-1)
             tmp1=dnrm(xx,mu1,sd1,0)

             if(j.eq.1)then
                uu=sba(i-1,j)
                tmp2=cdfnorm(uu,mu1,sd1,1,0)
                lpost=lpost+dlog(tmp1/tmp2)

              else if(j.eq.nn)then
                ll=sba(i-1,j-1)
                tmp2=cdfnorm(ll,mu1,sd1,1,1)
                lpost=lpost+dlog(tmp1/tmp2)
              else
                ll=sba(i-1,j-1)
                uu=sba(i-1,j)
                tmp2=cdfnorm(ll,mu1,sd1,1,0)
                tmp3=cdfnorm(uu,mu1,sd1,1,0)
                tmp4=tmp3-tmp2
                lpost=lpost+dlog(tmp1/tmp4)
             end if
          end do
       end do

       lpost=lpost+dnrm(mu1,m1,s1,1)

       return
       end

c=======================================================================
       subroutine lposth1ssba(maxn,maxr,mu1,sigma21,sba,tauh1,
     &                        tauh2,lpost)
c=======================================================================
c      Computes the log posterior for the variance of the normal
c      measure of the conditional means in a 'normal' sequential
c      barycenter array.
c
c      Alejandro Jara, 2011.
c=======================================================================
       implicit none

c+++++ Input
       integer maxn,maxr
       real*8 mu1,sigma21
       real*8 sba(maxn,maxr)
       real*8 tauh1,tauh2

c+++++ Output
       real*8 lpost

c+++++ Internal working space
       integer i,j,nn
       real*8 ll,uu,xx
       real*8 tmp1,tmp2,tmp3,tmp4
       real*8 cdfnorm,dnrm
       real*8 sd1
c+++++ Algorithm

       lpost=0.d0
       sd1=dsqrt(sigma21)

       do i=2,maxn

          call rchkusr()

          do j=1,nn
             xx=sba(i,2*j-1)
             tmp1=dnrm(xx,mu1,sd1,0)

             if(j.eq.1)then
                uu=sba(i-1,j)
                tmp2=cdfnorm(uu,mu1,sd1,1,0)
                lpost=lpost+dlog(tmp1/tmp2)

              else if(j.eq.nn)then
                ll=sba(i-1,j-1)
                tmp2=cdfnorm(ll,mu1,sd1,1,1)
                lpost=lpost+dlog(tmp1/tmp2)
              else
                ll=sba(i-1,j-1)
                uu=sba(i-1,j)
                tmp2=cdfnorm(ll,mu1,sd1,1,0)
                tmp3=cdfnorm(uu,mu1,sd1,1,0)
                tmp4=tmp3-tmp2
                lpost=lpost+dlog(tmp1/tmp4)
             end if
          end do
       end do

       xx=sigma21
       tmp1=-(0.5d0*tauh1+1.d0)*dlog(xx)-0.5d0*tauh2/xx
       lpost=lpost+tmp1
       return
       end

c=======================================================================
       subroutine gennsbad(nrec,y,maxn,maxr,mu0,sd0,mu1,sd1,sba)
c=======================================================================
c      Generates a 'normal' sequential barycenter array from the data.
c
c      Alejandro Jara, 2011.
c=======================================================================
       implicit none

c+++++ Input
       integer maxn,maxr,nrec
       real*8 mu0,sd0,mu1,sd1
       real*8 y(nrec)

c+++++ Output
       real*8 sba(maxn,maxr)

c+++++ Internal working space
       integer i,ii,j,nn
       integer count
       real*8 rnorm,rtnorm,ll,uu
       real*8 tmp1
       logical linf,lsup

c+++++ Algorithm

       if(sd0.eq.0.d0)then
          sba(1,1)=mu0
         else
          tmp1=0.d0
          do ii=1,nrec
             tmp1=tmp1+y(ii)
          end do
          sba(1,1)=tmp1/dble(nrec)
       end if

       do i=2,maxn

          call rchkusr()

          nn=(2**(i-1))-1
          do j=1,nn
             sba(i,2*j)=sba(i-1,j)
          end do

          nn=2**(i-1)
          do j=1,nn
             if(j.eq.1)then
                linf=.true.
                lsup=.false.
                ll=0.d0
                uu=sba(i-1,j)

                tmp1=0.d0
                count=0
                do ii=1,nrec
                   if(y(ii).le.uu)then
                      tmp1=tmp1+y(ii)
                      count=count+1
                   end if
                end do

                if(count.gt.0)then
                   sba(i,2*j-1)=tmp1/dble(count)
                 else
                   sba(i,2*j-1)=
     &             rtnorm(mu1,sd1,ll,uu,linf,lsup)
                end if
              else if(j.eq.nn)then
                linf=.false.
                lsup=.true.
                ll=sba(i-1,j-1)
                uu=0.d0

                tmp1=0.d0
                count=0
                do ii=1,nrec
                   if(y(ii).gt.ll)then
                      tmp1=tmp1+y(ii)
                      count=count+1
                   end if
                end do

                if(count.gt.0)then
                   sba(i,2*j-1)=tmp1/dble(count)
                 else
                   sba(i,2*j-1)=
     &             rtnorm(mu1,sd1,ll,uu,linf,lsup)
                end if
              else
                linf=.false.
                lsup=.false.
                ll=sba(i-1,j-1)
                uu=sba(i-1,j)

                tmp1=0.d0
                count=0
                do ii=1,nrec
                   if(y(ii).gt.ll.and.y(ii).le.uu)then
                      tmp1=tmp1+y(ii)
                      count=count+1
                   end if
                end do

                if(count.gt.0)then
                   sba(i,2*j-1)=tmp1/dble(count)
                 else
                   sba(i,2*j-1)=
     &             rtnorm(mu1,sd1,ll,uu,linf,lsup)
                end if
             end if
          end do
       end do

       return
       end


! A simple routine to calculate the integral of a variable over the grid.
!
! This is intended to serve as the starting point for writing a more
! general analysis routine using the plotfile_module for BoxLib
! datasets.
!
! This particular routine is written for 2-d datasets only.  Extending
! it to 3-d (or 1-d) is straightfoward.

program fintgvar2d

  use f2kcli
  use bl_space, only: MAX_SPACEDIM
  use bl_constants_module, only: ZERO, HALF
  use bl_IO_module
  use plotfile_module
  implicit none

  ! pf is a plotfile object that will contain both the meta-data
  ! describing the layout of the boxes that make up the AMR levels and
  ! the actual data itself (although, not necessarily all of the data
  ! at any one time, to save memory).
  type(plotfile) pf

  integer :: unit
  integer :: f, i, j, ii, jj
  real(kind=dp_t) :: xx, yy
  integer :: rr, r1

  real(kind=dp_t) :: dx(MAX_SPACEDIM)

  ! the pointer p will point to the data for a single box in the
  ! computational domain.  Regardless of the dimensionality of the
  ! simulation, p will always have 4 indices (3 space + 1 component).
  real(kind=dp_t), pointer :: p(:,:,:,:)

  real(kind=dp_t) :: intg_val, dV

  integer :: varindex

  ! imask is an array that will be used to determine if we've already
  ! made use of data at a particular physical location (e.g. does a
  ! fine patch cover a coarser region -- if so, we want to use the
  ! finer-gridded data).  It should have the same dimensionality as
  ! the dataset.
  logical, allocatable :: imask(:,:)

  integer :: lo(MAX_SPACEDIM), hi(MAX_SPACEDIM)
  integer :: flo(MAX_SPACEDIM), fhi(MAX_SPACEDIM)

  integer :: narg, farg
  character(len=256) :: fname, varname

  unit = unit_new()

  !---------------------------------------------------------------------------
  ! parse the commandline optionns using the f2kcli module
  !---------------------------------------------------------------------------

  ! get the number of arguments
  narg = command_argument_count()
  if (narg==0) call print_usage_and_stop()    ! if no argument

  ! get a variable name from the first argument
  ! look for "--" pattern (e.g. --n3)
  farg = 1
  call get_command_argument(farg, value = fname)

  if (len(trim(fname))<3) &    ! no possibility for the pattern
     call print_usage_and_stop()

  if (fname(1:2)/='--') &      ! starting with other than --
     call print_usage_and_stop()

  varname = fname(3:len(trim(fname)))

  !---------------------------------------------------------------------------
  ! loop over the plotfiles for processing
  !---------------------------------------------------------------------------

  if (narg==1) call print_usage_and_stop()    ! if no plotfiles

  farg = farg + 1

  do f = farg, narg

     ! get the name of the plotfile
     call get_command_argument(f, value = fname)

     !------------------------------------------------------------------------
     ! build the plotfile object that contains the data describing
     ! the plotfile
     !------------------------------------------------------------------------
     call build(pf, fname, unit)

     ! make sure we are 2-d
     if (pf%dim /= 2) then
        print *, "ERROR: not a 2-d dataset"
        stop
     endif

     !------------------------------------------------------------------------
     ! figure out the variable indices from the plotfile
     !------------------------------------------------------------------------

     varindex = plotfile_var_index(pf, trim(varname))

     ! make sure we have the variable
     if (varindex < 0) then
        print *, "ERROR: variables not defined"
        stop
     endif

     !------------------------------------------------------------------------
     ! get the domain information and initialize the mask
     !------------------------------------------------------------------------

     ! get dx for the coarse level.
     dx = plotfile_get_dx(pf, 1)

     ! get the index bounds for the finest level.
     ! Note, lo and hi are ZERO-based indicies
     flo = lwb(plotfile_get_pd_box(pf, pf%flevel))
     fhi = upb(plotfile_get_pd_box(pf, pf%flevel))

     ! imask is a flag for each zone at the finest possible level.
     ! imask = .true. means that we have not output data at this
     ! physical location from any level of data.  Once we output data
     ! at this location, imask is set to .false.  As we loop over
     ! levels, we will compare to the finest level index space to
     ! determine if we've already output here
     allocate(imask(flo(1):fhi(1),flo(2):fhi(2)))
     imask(:,:) = .true.

     !------------------------------------------------------------------------
     ! loop over the data
     !------------------------------------------------------------------------

     ! We start at the finest grid, and if we haven't already used
     ! data from that physical location (according to imask), add to
     ! the integral
     intg_val = ZERO

     ! r1 is the refinement factor between the current level grid
     ! spacing and the FINEST level
     r1  = 1

     do i = pf%flevel, 1, -1

        ! rr is the factor between the COARSEST level grid spacing and
        ! the current level.  Here we are assuming the same refinement
        ! in each coordinate direction.
        rr = product(pf%refrat(1:i-1,1))

        ! loop over all the boxes at this level of refinment
        do j = 1, nboxes(pf, i)

           ! read in the data 1 patch at a time
           call fab_bind(pf, i, j)

           ! get the integer bounds of the current box, in terms of this
           ! level's index space
           lo = lwb(get_box(pf, i, j))
           hi = upb(get_box(pf, i, j))

           ! get a pointer to the current patch
           p => dataptr(pf, i, j)

           ! loop over all of the zones in the patch.  Here, xx is the
           ! x-coordinate of the zone center and yy is the y-coordinate of
           ! the zone center.
           do jj = lo(2), hi(2)
              yy = (jj + HALF)*dx(2)/rr

              do ii = lo(1), hi(1)
                 xx = (ii + HALF)*dx(1)/rr

                 ! Convert the cell-centered indices at the current
                 ! level into the corresponding RANGE on the finest
                 ! level, and test if we've used data in any of those
                 ! locations.  If we haven't then we use this level's
                 ! data.
                 if ( any(imask(ii*r1:(ii+1)*r1-1, &
                                jj*r1:(jj+1)*r1-1) ) ) then

                    ! weight the zone's data by its size
                    dV = (dx(1)/rr)*(dx(2)/rr)

                    ! calculate the integral by adding p*dV
                    intg_val = intg_val + p(ii,jj,1,varindex) * dV

                    ! mark this range of the domain as used in the mask
                    imask(ii*r1:(ii+1)*r1-1, &
                          jj*r1:(jj+1)*r1-1) = .false.
                 end if

              end do
           enddo

           ! delete this box's data to free memory
           call fab_unbind(pf, i, j)

        end do

        ! adjust r1 (refinement factor between the current level grid
        ! spacing and the FINEST level) for the next lowest level
        if ( i /= 1 ) r1 = r1*pf%refrat(i-1,1)
     end do

     !------------------------------------------------------------------------
     ! output the current file's data
     !------------------------------------------------------------------------
     print *, pf%tm, intg_val

     !------------------------------------------------------------------------
     ! clean-up
     !------------------------------------------------------------------------
     call destroy(pf)
     deallocate(imask)

  enddo  ! end loop over files

contains

  subroutine print_usage_and_stop()

     print *, " "
     print *, "Dump out the integral of a particular variable on the grid"
     print *, "(works only with 2-d datasets)"
     print *, " "
     print *, "usage: fintgvar2d --varname plotfile1 plotfile2 ..."
     print *, "(where varname is a variable to be integrated)"
     print *, " "
     stop

  end subroutine print_usage_and_stop

end program fintgvar2d


program main

    ! These modules are all in BoxLib/Src/F_BaseLib
    use boxlib
    use multifab_module
    use bl_IO_module

    ! These modules are all in this directory
    use constants
    use init_rhs_mod
    use init_coeffs_mod
    use cycle_tower_mod
    use solve_mod

    implicit none

    ! From inputs file
    integer          :: n_cells
    integer          :: max_boxsize
    integer          :: dim
    integer          :: s1
    integer          :: s2
    integer          :: v_bot
    integer          :: fmg_bot
    integer          :: max_iter
    integer          :: cycle_type
    integer          :: interp_type
    integer          :: verbose        ! verbose > 2 will print arrays, so be careful with large data sets
    logical          :: memory_verbose ! this controls the printing of the memory stats only and is set below
    integer          :: rhs_type
    integer          :: coeffs_type
    double precision :: eps

    ! Other local variables
    integer                       :: cyc, nlvl
    integer, allocatable          :: lo(:), hi(:)
    double precision              :: dx ! Grid spacing
    double precision, allocatable :: prob_lo(:), prob_hi(:) ! Problem domain
    logical, allocatable          :: is_periodic(:) ! Periodic boundary conditions
    type(cycle_tower)             :: ct ! Holds all information for multigrid solver
    type(box)                     :: bx
    type(boxarray)                :: ba
    type(layout)                  :: la
    type(multifab)                :: rhs, coeffs

    ! Dummy variables used to read inputs file
    integer :: un, farg, narg
    logical :: need_inputs_file, found_inputs_file
    character(len=128) :: fname

    ! Used to keep track of program run time
    double precision :: start_time, run_time, run_time_IOproc

    namelist /probin/ n_cells, max_boxsize, dim, s1, s2, v_bot, fmg_bot, max_iter, cycle_type, eps, &
                      interp_type, rhs_type, coeffs_type, verbose

    ! If running in parallel. this will print out the number of MPI processes
    ! and OpenMP threads
    call boxlib_initialize()

    memory_verbose = .false.

    ! parallel_wtime() returns the number of wallclock-time seconds since
    ! the program began
    start_time = parallel_wtime()

    ! Default values -- will be overwritten by inputs file
    n_cells = 64
    max_boxsize = 32
    dim = 2
    s1 = 2
    s2 = 2
    v_bot = 8
    fmg_bot = 40
    max_iter = 50
    cycle_type = 1
    eps = 1E-10
    interp_type = 1
    rhs_type = 1
    coeffs_type = 1
    verbose = 1

    ! Read inputs file and overwrite any default values
    narg = command_argument_count()
    need_inputs_file = .true.
    farg = 1
    if ( need_inputs_file .AND. narg >= 1 ) then
        call get_command_argument(farg, value = fname)
        inquire(file = fname, exist = found_inputs_file )
        if (found_inputs_file) then
            farg = farg + 1
            un = unit_new()
            open(unit=un, file = fname, status = 'old', action = 'read')
            read(unit=un, nml = probin)
            close(unit=un)
            need_inputs_file = .false.
        end if
    end if

    ! Easy way to modify one input at a time
    do while (farg <= narg)
        call get_command_argument(farg, value=fname)
        select case(fname)
            case('--n_cells')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) n_cells
            case('--max_boxsize')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) max_boxsize
            case('--dim')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) dim
            case('--s1')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) s1
            case('--s2')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) s2
            case('--v_bot')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) v_bot
            case('--fmg_bot')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) fmg_bot
            case('--max_iter')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) max_iter
            case('--cycle_type')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) cycle_type
            case('--eps')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) eps
            case('--interp_type')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) interp_type
            case('--verbose')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) verbose
            case('--rhs_type')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) rhs_type
            case('--coeffs_type')
                farg = farg + 1
                call get_command_argument(farg, value=fname)
                read(fname,*) coeffs_type
            case default
                print *, 'ERROR - Unknown input', fname
                stop
        end select
        farg = farg + 1
    end do

    ! Now that we have dim, we can allocate these
    allocate(lo(dim))
    allocate(hi(dim))
    allocate(is_periodic(dim))
    allocate(prob_lo(dim))
    allocate(prob_hi(dim))

    ! Physical problem is from (0,0) to (1,1), periodic on all sides
    prob_lo(:) = 0
    prob_hi(:) = 1.d0
    is_periodic(:) = .true.
    dx = (prob_hi(1)-prob_lo(1))/n_cells

    ! Create a box from (0,0) to (n_cells-1, n_cells-1)
    lo(:) = 0
    hi(:) = n_cells-1
    bx = make_box(lo,hi)

    ! Initialize the boxarray to be a single box
    call boxarray_build_bx(ba,bx)

    ! Overwrite the boxarray to respect max_boxsize
    call boxarray_maxsize(ba,max_boxsize)

    ! Build layout.  The third argument, bx, is the problem domain.
    call layout_build_ba(la,ba,bx,pmask=is_periodic)
    call destroy(ba)

    ! Build multifab for RHS and coefficients using same layout.
    call multifab_build(rhs,la,nc=1,ng=0)
    call multifab_build(coeffs,la,nc=1,ng=1)

    ! Fill them in
    call init_rhs(rhs,rhs_type,prob_lo,dx)
    call init_coeffs(coeffs,coeffs_type)

    ! Number of multigrid levels (each box coarsens down to 2x2)
    nlvl = nint(log(dble(max_boxsize))/log(2.d0))

    ! Build tower object
    call build_cycle_tower(ct,rhs,coeffs,la,dim,n_cells,dx,s1,s2,v_bot,fmg_bot,nlvl,max_iter,&
                           eps,cycle_type,interp_type,rhs_type,coeffs_type,verbose)

    if (parallel_IOProcessor()) then
        print *, 'MULTIGRID SOLVE'
    end if

    ! Solve using multigrid
    call solve(ct)

    ! Make sure to destroy everything or else you could leak memory
    call destroy_cycle_tower(ct)
    call destroy(la)
    deallocate(lo)
    deallocate(hi)
    deallocate(is_periodic)
    deallocate(prob_lo)
    deallocate(prob_hi)

    ! Deallocate temporary boxarrays and communication mappings
    call layout_flush_copyassoc_cache()

    ! Check for memory that should have been deallocated
    if (memory_verbose) then
        if (parallel_IOProcessor()) then
            print *, 'MEMORY STATS AT THE END OF PROGRAM'
            print *, ''
        end if
        call print(multifab_mem_stats(),    "    multifab")
        call print(fab_mem_stats(),         "         fab")
        call print(boxarray_mem_stats(),    "    boxarray")
        call print(layout_mem_stats(),      "      layout")
        call print(boxassoc_mem_stats(),    "    boxassoc")
        call print(fgassoc_mem_stats(),     "     fgassoc")
        call print(syncassoc_mem_stats(),   "   syncassoc")
        call print(copyassoc_mem_stats(),   "   copyassoc")
        call print(fluxassoc_mem_stats(),   "   fluxassoc")
    end if

    ! parallel_wtime() returns the number of wallclock-time seconds since the program began
    run_time = parallel_wtime() - start_time

    ! collect run_time from each processor and store the maximum
    call parallel_reduce(run_time_IOproc, run_time, MPI_MAX, proc=parallel_IOProcessorNode())

    if (parallel_IOprocessor()) then
        print *, 'Run time (sec) = ', run_time_IOproc
    end if

    call boxlib_finalize()

end program main


subroutine s_rmsd_fast_calc_rmsd_and_rotation(A,minScore,npro,E0,rmsd,rot,ireturn)
!
! This subroutine is part of the implementation of Quaternion Characteristic
! Polynomial (QCP) method, based on the code published by Naoto Hori at:
!
! https://github.com/naotohori/fQCP
!
! under BSD license. His code, in turn, is based on the C code written by Pu Liu
! and Douglas L. Theobald. The code bellow is improved and partially revised by
! Veselin Kolev <vesso.kolev@gmail.com>.
!
! To cite QCP:
!
! 1. Douglas L. Theobald (2005) "Rapid calculation of RMSD using a quaternion-based
!    characteristic polynomial." Acta Crystallographica A 61(4):478-480.
!
! 2. Pu Liu, Dmitris K. Agrafiotis, and Douglas L. Theobald (2010) "Fast
!    determination of the optimal rotational matrix for do_counted
!    superpositions." Journal of Computational Chemistry 31(7):1561-1563
!
! NOTE: Use double precision in the computations presented bellow. Eploying
!       single precision floating point data can turn the elements of the
!       rotation matrix "rot" into zeroes. That will result into total
!       failure of the coordinate super imposition.
!
! Author : Veselin Kolev <vesso.kolev@gmail.com>
! License: BSD
! Version: 2019011500
!
use iso_c_binding,only:C_INT,C_FLOAT,C_DOUBLE
!
implicit none
!
! Interface variables:
!
real(C_FLOAT),intent(in)   ::  A(9)
integer(C_INT),intent(in)  :: minScore
integer(C_INT),intent(in)  :: npro
real(C_FLOAT),intent(in)   :: E0
real(C_FLOAT),intent(out)  :: rmsd
real(C_FLOAT),intent(out)  :: rot(9)
integer(C_INT),intent(out) :: ireturn
!
! Local variables:
!
integer(C_INT)             :: i
real(C_DOUBLE)             :: Sxx
real(C_DOUBLE)             :: Sxy
real(C_DOUBLE)             :: Sxz
real(C_DOUBLE)             :: Syx
real(C_DOUBLE)             :: Syy
real(C_DOUBLE)             :: Syz
real(C_DOUBLE)             :: Szx
real(C_DOUBLE)             :: Szy
real(C_DOUBLE)             :: Szz
real(C_DOUBLE)             :: Szz2
real(C_DOUBLE)             :: Syy2
real(C_DOUBLE)             :: Sxx2
real(C_DOUBLE)             :: Sxy2
real(C_DOUBLE)             :: Syz2
real(C_DOUBLE)             :: Sxz2
real(C_DOUBLE)             :: Syx2
real(C_DOUBLE)             :: Szy2
real(C_DOUBLE)             :: Szx2
real(C_DOUBLE)             :: SyzSzymSyySzz2
real(C_DOUBLE)             :: Sxx2Syy2Szz2Syz2Szy2
real(C_DOUBLE)             :: Sxy2Sxz2Syx2Szx2
real(C_DOUBLE)             :: SxzpSzx
real(C_DOUBLE)             :: SyzpSzy
real(C_DOUBLE)             :: SxypSyx
real(C_DOUBLE)             :: SyzmSzy
real(C_DOUBLE)             :: SxzmSzx
real(C_DOUBLE)             :: SxymSyx
real(C_DOUBLE)             :: SxxpSyy
real(C_DOUBLE)             :: SxxmSyy
real(C_DOUBLE)             :: C(3)
real(C_DOUBLE)             :: mxEigenV
real(C_DOUBLE)             :: oldg
real(C_DOUBLE)             :: b
real(C_DOUBLE)             :: aa
real(C_DOUBLE)             :: delta
real(C_DOUBLE)             :: rms
real(C_DOUBLE)             :: qsqr
real(C_DOUBLE)             :: q1
real(C_DOUBLE)             :: q2
real(C_DOUBLE)             :: q3
real(C_DOUBLE)             :: q4
real(C_DOUBLE)             :: normq
real(C_DOUBLE)             :: a11
real(C_DOUBLE)             :: a12
real(C_DOUBLE)             :: a13
real(C_DOUBLE)             :: a14
real(C_DOUBLE)             :: a21
real(C_DOUBLE)             :: a22
real(C_DOUBLE)             :: a23
real(C_DOUBLE)             :: a24
real(C_DOUBLE)             :: a31
real(C_DOUBLE)             :: a32
real(C_DOUBLE)             :: a33
real(C_DOUBLE)             :: a34
real(C_DOUBLE)             :: a41
real(C_DOUBLE)             :: a42
real(C_DOUBLE)             :: a43
real(C_DOUBLE)             :: a44
real(C_DOUBLE)             :: a2
real(C_DOUBLE)             :: x2
real(C_DOUBLE)             :: y2
real(C_DOUBLE)             :: z2
real(C_DOUBLE)             :: xy
real(C_DOUBLE)             :: az
real(C_DOUBLE)             :: zx
real(C_DOUBLE)             :: ay
real(C_DOUBLE)             :: yz
real(C_DOUBLE)             :: ax
real(C_DOUBLE)             :: a1324_1423
real(C_DOUBLE)             :: a1224_1422
real(C_DOUBLE)             :: a1223_1322
real(C_DOUBLE)             :: a1124_1421
real(C_DOUBLE)             :: a1123_1321
real(C_DOUBLE)             :: a1122_1221
real(C_DOUBLE)             :: a3344_4334
real(C_DOUBLE)             :: a3244_4234
real(C_DOUBLE)             :: a3243_4233
real(C_DOUBLE)             :: a3143_4133
real(C_DOUBLE)             :: a3144_4134
real(C_DOUBLE)             :: a3142_4132
real(C_DOUBLE),parameter   :: evecprec=1.0e-6
real(C_DOUBLE),parameter   :: evalprec=1.0e-11

Sxx=dble(A(1))
Sxy=dble(A(2))
Sxz=dble(A(3))
Syx=dble(A(4))
Syy=dble(A(5))
Syz=dble(A(6))
Szx=dble(A(7))
Szy=dble(A(8))
Szz=dble(A(9))
!
Sxx2=Sxx*Sxx
Syy2=Syy*Syy
Szz2=Szz*Szz
!
Sxy2=Sxy*Sxy
Syz2=Syz*Syz
Sxz2=Sxz*Sxz
!
Syx2=Syx*Syx
Szy2=Szy*Szy
Szx2=Szx*Szx
!
SyzSzymSyySzz2=2*(Syz*Szy-Syy*Szz)
Sxx2Syy2Szz2Syz2Szy2=Syy2+Szz2-Sxx2+Syz2+Szy2
!
C(3)=-2*(Sxx2+Syy2+Szz2+Sxy2+Syx2+Sxz2+Szx2+Syz2+Szy2)
C(2)= 8*(Sxx*Syz*Szy+Syy*Szx*Sxz+Szz*Sxy*Syx-Sxx*Syy*Szz-&
         Syz*Szx*Sxy-Szy*Syx*Sxz)
!
SxzpSzx=Sxz+Szx
SyzpSzy=Syz+Szy
SxypSyx=Sxy+Syx
SyzmSzy=Syz-Szy
SxzmSzx=Sxz-Szx
SxymSyx=Sxy-Syx
SxxpSyy=Sxx+Syy
SxxmSyy=Sxx-Syy
!
Sxy2Sxz2Syx2Szx2=Sxy2+Sxz2-Syx2-Szx2
!
C(1)=Sxy2Sxz2Syx2Szx2*Sxy2Sxz2Syx2Szx2&
     +(Sxx2Syy2Szz2Syz2Szy2+SyzSzymSyySzz2)&
     *(Sxx2Syy2Szz2Syz2Szy2-SyzSzymSyySzz2)&
     +(-(SxzpSzx)*(SyzmSzy)+(SxymSyx)*(SxxmSyy-Szz))&
     *(-(SxzmSzx)*(SyzpSzy)+(SxymSyx)*(SxxmSyy+Szz))&
     +(-(SxzpSzx)*(SyzpSzy)-(SxypSyx)*(SxxpSyy-Szz))&
     *(-(SxzmSzx)*(SyzmSzy)-(SxypSyx)*(SxxpSyy+Szz))&
     +(+(SxypSyx)*(SyzpSzy)+(SxzpSzx)*(SxxmSyy+Szz))&
     *(-(SxymSyx)*(SyzmSzy)+(SxzpSzx)*(SxxpSyy+Szz))&
     +(+(SxypSyx)*(SyzmSzy)+(SxzmSzx)*(SxxmSyy-Szz))&
     *(-(SxymSyx)*(SyzpSzy)+(SxzmSzx)*(SxxpSyy-Szz))
!
! Newton-Raphson
!
mxEigenV = dble(E0)
!
do i=1,50
   !
   oldg=mxEigenV
   x2=mxEigenV*mxEigenV
   b=(x2+C(3))*mxEigenV
   aa=b+C(2)
   delta=((aa*mxEigenV+C(1))/(2.0*x2*mxEigenV+b+aa))
   mxEigenV=mxEigenV-delta
   !
   if (abs(mxEigenV-oldg).lt.abs(evalprec*mxEigenV)) then
      exit
   end if
   !
end do
!
if (i.eq.50) then
   write(*,*) "More than",i,"iterations needed!"
endif
!
! the abs() is to guard against extremely small, but *negative* numbers due to floating point error
!
rms=sqrt(abs(2*(dble(E0)-mxEigenV)/npro))
rmsd=real(rms)
!
if ((minScore.gt.0).and.(rms.lt.minScore)) then
   ireturn=-1 ! Don't bother with rotation.
   return
endif
!
a11=SxxpSyy+Szz-mxEigenV
a12=SyzmSzy
a13=-SxzmSzx
a14=SxymSyx
!
a21=SyzmSzy
a22=SxxmSyy-Szz-mxEigenV
a23=SxypSyx
a24=SxzpSzx
!
a31=a13
a32=a23
a33=Syy-Sxx-Szz-mxEigenV
a34=SyzpSzy
!
a41=a14
a42=a24
a43=a34
a44=Szz-SxxpSyy-mxEigenV
!
a3344_4334=a33*a44-a43*a34
a3244_4234=a32*a44-a42*a34
a3243_4233=a32*a43-a42*a33
a3143_4133=a31*a43-a41*a33
a3144_4134=a31*a44-a41*a34
a3142_4132=a31*a42-a41*a32
!
q1= a22*a3344_4334-a23*a3244_4234+a24*a3243_4233
q2=-a21*a3344_4334+a23*a3144_4134-a24*a3143_4133
q3= a21*a3244_4234-a22*a3144_4134+a24*a3142_4132
q4=-a21*a3243_4233+a22*a3143_4133-a23*a3142_4132
!
qsqr=q1*q1+q2*q2+q3*q3+q4*q4
!
! The following code tries to calculate another column in the adjoint matrix when the norm of the
! current column is too small. Usually this block never becomes activated.
!
if (qsqr.lt.evecprec) then
   !
   q1= a12*a3344_4334-a13*a3244_4234+a14*a3243_4233
   q2=-a11*a3344_4334+a13*a3144_4134-a14*a3143_4133
   q3= a11*a3244_4234-a12*a3144_4134+a14*a3142_4132
   q4=-a11*a3243_4233+a12*a3143_4133-a13*a3142_4132
   !
   qsqr=q1*q1+q2*q2+q3*q3+q4*q4
   !
   if (qsqr.lt.evecprec) then
      !
      a1324_1423=a13*a24-a14*a23
      a1224_1422=a12*a24-a14*a22
      a1223_1322=a12*a23-a13*a22
      a1124_1421=a11*a24-a14*a21
      a1123_1321=a11*a23-a13*a21
      a1122_1221=a11*a22-a12*a21
      !
      q1= a42*a1324_1423-a43*a1224_1422+a44*a1223_1322
      q2=-a41*a1324_1423+a43*a1124_1421-a44*a1123_1321
      q3= a41*a1224_1422-a42*a1124_1421+a44*a1122_1221
      q4=-a41*a1223_1322+a42*a1123_1321-a43*a1122_1221
      !
      qsqr=q1*q1+q2*q2+q3*q3+q4*q4
      !
      if (qsqr.lt.evecprec) then
         !
         q1= a32*a1324_1423-a33*a1224_1422+a34*a1223_1322
         q2=-a31*a1324_1423+a33*a1124_1421-a34*a1123_1321
         q3= a31*a1224_1422-a32*a1124_1421+a34*a1122_1221
         q4=-a31*a1223_1322+a32*a1123_1321-a33*a1122_1221
         !
         qsqr=q1*q1+q2*q2+q3*q3+q4*q4
         !
         if (qsqr.lt.evecprec) then
            !
            ! if qsqr is still too small, return the identity matrix
            ! (that means no rotation of the atoms is reqiured)
            !
            rot(1)=1.0
            rot(5)=1.0
            rot(9)=1.0
            !
            rot(2)=0.0
            rot(3)=0.0
            rot(4)=0.0
            rot(6)=0.0
            rot(7)=0.0
            rot(8)=0.0
            !
            ireturn=0
            !
            return
            !
         end if
         !
      end if
      !
   end if
   !
end if
!
normq=sqrt(qsqr)
!
q1=q1/normq
q2=q2/normq
q3=q3/normq
q4=q4/normq
!
a2=q1*q1
x2=q2*q2
y2=q3*q3
z2=q4*q4
!
xy=q2*q3
az=q1*q4
zx=q4*q2
ay=q1*q3
yz=q3*q4
ax=q1*q2
!
rot(1)=real(a2+x2-y2-z2)
rot(2)=real(2*(xy+az))
rot(3)=real(2*(zx-ay))
!
rot(4)=real(2*(xy-az))
rot(5)=real(a2-x2+y2-z2)
rot(6)=real(2*(yz+ax))
!
rot(7)=real(2*(zx+ay))
rot(8)=real(2*(yz-ax))
rot(9)=real(a2-x2-y2+z2)
!
ireturn=1

end subroutine s_rmsd_fast_calc_rmsd_and_rotation


!*****************************************************************************80
!
!! Sets up 1D mesh assuming quadratic spatial interpolation
!
!  Discussion:
!          Creates connectivity mesh assuming 1D discontinuous elements in a line
!
!  Parameters:
!  	      conn_matrix(max # elements, nodes per element)
! 	      global_coord(# elements, nodes per element)
!  Units: cm
!  If element is 1.0 ==> 1.0 cm
!
subroutine mesh_creation ( )

   USE global_parameters_M
   USE mesh_info_M
   USE flags_M

   use Mod_SetupOutputFiles

   implicit none

!---Dummy

!---Local
    integer :: i,j,ii

!---allocate arrays
    allocate( conn_matrix(num_elem, nodes_per_elem) , &
              global_coord(num_elem,nodes_per_elem) )
    allocate(elem_lengths(num_elem))

!---setup connectivity matrix
    do i=1, num_elem
        do j=1,nodes_per_elem
            conn_matrix(i,j) = j + (i-1)*nodes_per_elem
        end do
    end do

!---Setup element length array. assume all elements have the same size
    do i = 1, num_elem
        elem_lengths(i) = elem_size
    end do

!---Setup global coordinate array
    global_coord(1,1) = 0
    global_coord(1,2) = global_coord(1,1) + 0.5*elem_lengths(1)
    global_coord(1,3) = global_coord(1,2) + 0.5*elem_lengths(1)

    do i = 2, num_elem
        do j = 1, nodes_per_elem
            if ( j .eq. 1) then
                global_coord(i,j) = global_coord(i-1,3)
            else
                global_coord(i,j) = global_coord(i,j-1) + 0.5*elem_lengths(i)
            end if
        end do
    end do

!---Check to make sure dimensions are physical
    if(DEBUG .eqv. .TRUE.) then
        do i = 1, num_elem
            do j = 1, nodes_per_elem
                if( global_coord(i,j) < 0.0 ) then
                    write(outfile_unit, fmt=('(a)')), 'ERROR: global coordinate is negative'
                    write(outfile_unit, fmt=('(a,I6)')),'At element number: ',i

                    stop
                end if
            end do
        end do
    !---Write to outfile
        write(outfile_unit,fmt='(a19)'),'Connectivity Matrix'
        do j=1, num_elem
               write(outfile_unit,fmt='(a,1I6,a4,4I6)') 'Element:',j,' -->', &
                    (conn_matrix(j,i),i=1,nodes_per_elem)
        end do
        write(outfile_unit,fmt='(a)'),' '
        write(outfile_unit,fmt='(a24)'),'Global Coordinate Matrix'
        do j=1, num_elem
               write(outfile_unit,fmt='(12es14.3)')  &
                    (global_coord(j,i),i=1,nodes_per_elem)
        end do

    end if
!-------------------------------------------------------------------------------

end subroutine mesh_creation


program fobcopytest
  use flips

  implicit none

  ! Testing fobcopy_s (flips_copy)

  type(flips_s) :: fob1,fob2

  real(sp), dimension(10) :: arow, sol1,sol2,cov1,cov2
  real(sp), dimension(1) :: meas
  real(sp) :: err
  integer :: i

  call flips_init(fob1,10,1)

  do i = 1,20
     call random_number(arow)
     call random_number(meas)
     call random_number(err)

     err = err + 0.5

     call flips_add(fob1,1,arow,meas,err)

  end do

  call fobcopy_s(fob2,fob1)

write(*,*) '*'

  call flips_solve(fob1)
  call flips_solve(fob2)

  call flips_calc_cov(fob1,.FALSE.)
  call flips_calc_cov(fob2,.FALSE.)

  call flips_get('solu',fob1,sol1)
  call flips_get('solu',fob2,sol2)

  call flips_get('cova',fob1,cov1)
  call flips_get('cova',fob2,cov2)

  write(*,*) 'Solutions'
  write(*,*) sol1
  write(*,*) sol2

  write(*,*) 'Covariances'
  write(*,*) cov1
  write(*,*) cov2

  write(*,*) 'Residuals'
  write(*,*) fob1%residual
  write(*,*) fob2%residual

  call flips_kill(fob1)
  call flips_kill(fob2)

end program fobcopytest


!-------------------------------------------------------------------------------
! TODO:
!       * currently a sanity check on one train image:
!           * expand to full test with all data
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! uses sequential neural network as an autoencoder on MNIST dataset, which
! contains many flattened 28x28x1 grayscale pictures of handwritten digits
!
! CSV version of datset downloaded from:
! https://www.kaggle.com/oddrationale/mnist-in-csv
!
! train dimensions:
!   60000 images (rows),
!   785 variables (column 1 = label, other 784 columns are the 28x28 pixels)
!
! test dimensions:
!   10000 images (rows),
!   785 variables (column 1 = label, other 784 columns are the 28x28 pixels)
!
! labels in range [0,9], representing which digit is depicted,
! pixels in range [0, 255], where 0 = black and 255 = white
!-------------------------------------------------------------------------------
! compile: make autoenc
! run:     ./autoenc
!-------------------------------------------------------------------------------

program main
    use net_helper_procedures
    use sequential_neural_net
    implicit none

    class(SeqNN), pointer     :: snn
    real(kind=8), allocatable :: image(:,:,:), train_images(:,:,:,:), &
                                 test_images(:,:,:,:), train(:,:), test(:,:), &
                                 train_x(:,:), test_x(:,:), recos(:,:,:,:)
    integer                   :: train_rows, test_rows, variables, classes, &
                                 pixels, row, i

    train_rows = 1
    test_rows = 1
    variables = 785
    pixels = variables - 1
    classes = 10

    !===========================================================================
    !===========================================================================
    ! data processing
    !===========================================================================
    !===========================================================================

    !---------------------------------------------------------------------------
    ! read train data

    print *, '----------------------'
    print *, 'processing train data:'

    allocate(train(train_rows, variables))

    open(unit=1, form='formatted', file='mnist-in-csv/mnist_train.csv')
    read(unit=1, fmt=*) ! skip header line

    do row = 1, train_rows
        read(unit=1, fmt=*) train(row,:)
    end do

    close(unit=1)

    !---------------------------------------------------------------------------
    ! separate train labels from pixels
    train_x = train(:,2:) / 255 ! scale pixels to [0,1]

    deallocate(train)

    !---------------------------------------------------------------------------
    ! reshape train examples from dimension 1x784 to 28x28x1

    allocate(train_images(28,28,1,train_rows))

    do i = 1, train_rows
        ! 28x28x1 array filled column-major order
        image = reshape(train_x(i,:), [28,28,1])

        ! transpose gives "expected" row-major order
        image(:,:,1) = transpose(image(:,:,1))

        train_images(:,:,:,i) = image
    end do

    deallocate(train_x)

    print *, 'done'
    print *, '----------------------'

    !---------------------------------------------------------------------------
    ! read test data

    print *, '----------------------'
    print *, 'processing test data:'

    allocate(test(test_rows, variables))

    open(unit=2, form='formatted', file='mnist-in-csv/mnist_test.csv')
    read(unit=2, fmt=*) ! skip header line

    do row = 1, test_rows
        read(unit=2, fmt=*) test(row,:)
    end do

    close(unit=2)

    !---------------------------------------------------------------------------
    ! separate test labels from pixels
    test_x = test(:,2:) / 255 ! scale to [0,1]

    deallocate(test)

    !---------------------------------------------------------------------------
    ! reshape test examples from dimension 1x784 to 28x28x1

    allocate(test_images(28,28,1,test_rows))

    do i = 1, test_rows
        ! 28x28x1 array filled column-major order
        image = reshape(test_x(i,:), [28,28,1])

        ! transpose gives "expected" row-major order
        image(:,:,1) = transpose(image(:,:,1))

        test_images(:,:,:,i) = image
    end do

    deallocate(test_x, image)

    print *, 'done'
    print *, '----------------------'

    !===========================================================================
    !===========================================================================
    ! network usage
    !===========================================================================
    !===========================================================================

    !---------------------------------------------------------------------------
    ! create network

    snn => create_snn()

    !-----------------------------------------------------
    ! encoder layers
    call snn%snn_add_conv_layer(input_dims  = [28,28,1],&
                                kernels     = 12, &
                                kernel_dims = [5,5], &
                                stride      = [1,1], &
                                activ       = 'relu', &
                                padding     = 'valid')

    call snn%snn_add_conv_layer(kernels     = 12, &
                                kernel_dims = [5,5], &
                                stride      = [1,1], &
                                activ       = 'relu', &
                                padding     = 'valid')

    call snn%snn_add_conv_layer(kernels     = 12, &
                                kernel_dims = [5,5], &
                                stride      = [1,1], &
                                activ       = 'relu', &
                                padding     = 'valid')

    call snn%snn_add_conv_layer(kernels     = 12, &
                                kernel_dims = [6,6], &
                                stride      = [2,2], &
                                activ       = 'relu', &
                                padding     = 'valid')

    !-----------------------------------------------------
    ! decoder layers
    call snn%snn_add_conv_layer(kernels     = 12, &
                                kernel_dims = [6,6], &
                                stride      = [2,2], &
                                activ       = 'relu', &
                                padding     = 'full')

    call snn%snn_add_conv_layer(kernels     = 12, &
                                kernel_dims = [5,5], &
                                stride      = [1,1], &
                                activ       = 'relu', &
                                padding     = 'full')

    call snn%snn_add_conv_layer(kernels     = 12, &
                                kernel_dims = [5,5], &
                                stride      = [1,1], &
                                activ       = 'relu', &
                                padding     = 'full')

    call snn%snn_add_conv_layer(kernels     = 1, &
                                kernel_dims = [5,5], &
                                stride      = [1,1], &
                                activ       = 'relu', &
                                padding     = 'full')

    call snn%snn_summary()

    !---------------------------------------------------------------------------
    ! train network

    call snn%snn_fit(conv_input    = train_images, &
                     target_images = train_images, &
                     batch_size    = 1, &
                     epochs        = 1000, &
                     learn_rate    = 0.001, &
                     loss          = 'mse', &
                     verbose       = 2)

    !---------------------------------------------------------------------------
    ! "predict" reconstructions on TRAIN data for now; sanity check

    call snn%snn_predict_images(conv_input = train_images, &
                                res        = recos)

    !---------------------------------------------------------------------------
    ! store outputs (reconstruction) to file to visualize

    ! overwrite file (if it exists), start first row
    call write_array_2D(snn%cnn%output%a(:,:,1,1), &
                            'output-data/autoenc_reco.csv', .false.)

    do i = 2, size(test_images, dim=4)
        ! append remaining rows
        call write_array_2D(snn%cnn%output%a(:,:,1,i), &
                            'output-data/autoenc_reco.csv', .true.)
    end do

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

    deallocate(train_images, test_images)
    call deallocate_snn(snn)
end program


c=======================================================================
c
c     subroutine SHRINKAGECOV
c
c     Shrinkage cov. matrix estimator with Ledoit Wolf's method
c
c-----------------------------------------------------------------------
      SUBROUTINE shrinkagecov ( n, p, X, cov, dwork, shrinkcov, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : number of values (n > 1)                   integer
c            p      : number of asset(s) (n >= 1)                integer
c            X      : value(s) (n*p)                              double
c            cov    : covariance matrix (p*p)                     double
c
c     WORKSPACE
c            dwork  : vector ( p*(2*p+1) )                        double
c
c     OUTPUT
c            shrinkcov   : shrinkage covariance matrix (p*p)      double
c            info: array of dimension 1,diagnostic argument      integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, info
      DOUBLE PRECISION X(*), cov(*), shrinkcov(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
      integer pdf, pdshrink
c
c     local variables
      integer i,j
      double precision delta, corrmean, temp
c
c     external subroutines
      EXTERNAL shrinkageintensity, shrinkagetarget
c
c-----------------------------------------------------------------------
c
      info = 0
c
c     Double workspace

      pdf = 1
c
c     pointer for the shrinkage target needs p*p
      pdshrink = pdf + p*p
c     local workspace for shrinkage intensity needs p*(p+1)
c     so p*(2*p+1)
c

c     Total size of dwork array = p*(2*p+1)
c
c-----------------------------------------------------------------------
c
      call shrinkagetarget( p, cov, dwork(pdf), corrmean, info )
      if (info .lt. 0) then
        return
      endif

      call shrinkageintensity( n, p, X, cov, dwork(pdf), corrmean,
     &                         dwork(pdshrink), delta )

      do i = 1,p
        do j= 1,i-1
            temp = delta*dwork(pdf+(i-1)*p+j-1)+(1-delta)*cov((i-1)*p+j)
            shrinkcov((i-1)*p+j) = temp
            shrinkcov((j-1)*p+i) = temp
        enddo
        shrinkcov((i-1)*p+i) = cov((i-1)*p+i)
      enddo
c
      RETURN
      END


C SUBROUTINE CMPINV           (NEXT)
      SUBROUTINE CMPINV (A, B, C, D, N)
C
C     CMPINV - COMPLEX MATRIX OPERATION THAT FINDS INVERSE, C+ID, OF
C        A+IB WHERE A,B,C, AND D ARE REAL SQUARE MATRICES.  CMPINV
C        CALLS MATINV TO INVERT REAL MATRICES AND SQMULT TO MULTIPLY
C        SQUARE MATRICES IN ORDER TO COMPUTE THE COMPLEX INVERSE
C                      C=INV(A + B*(INV(A))*B)
C                      D=-C*B*(INV(A))
C        A, B, C, AND D ARE ALL REAL N BY N MATRICIES.
C        IF A IS SINGULAR, EXCHANGE A AND B (FACTOR OUT I) AND TRY AGAIN
C     THIS ROUTINE IS SHARE NO. ANL F103 BY B.S.GARBOW OF ARGONNE
C     NATIONAL LABORATORY, ARGONNE, ILLINOIS
C
      DIMENSION A (20, 20), B (20, 20), C (20, 20), D (20, 20)
C
      COMMON /PON /INDEX (20, 2), IPIVOT (20), PIVOT (20)
C
C.....INVERT -A.........................................................
      M = N
      L = 1
 100  IF (M .LT. 1) GO TO 160
      DO 105 I = 1, M
      IF (M .LT. 1) GO TO 165
      DO 105 J = 1, M
 105  D (I, J) = - A (I, J)
 165  CONTINUE
 160  CONTINUE
      CALL MATINV (D, M)
C.....CHECK IF INV(-A) EXISTS (IF NOT GO TO 6)..........................
      IF (M .LT. 1) GO TO 170
      DO 110 K = 1, M
      IF (IPIVOT (K) .NE. 1) GO TO 125
 110  CONTINUE
 170  CONTINUE
C.....COMPUTE C=INV(A - B*(INV(-A))*B)..................................
      CALL SQMULT (B, D, D, M)
      CALL SQMULT (D, B, C, M)
      IF (M .LT. 1) GO TO 175
      DO 115 I1 = 1, M
      IF (M .LT. 1) GO TO 180
      DO 115 J1 = 1, M
 115  C (I1, J1) = A (I1, J1) - C (I1, J1)
 180  CONTINUE
 175  CONTINUE
      CALL MATINV (C, M)
C.....CHECK IF C EXISTS (IF NOT GO TO 300)..............................
      IF (M .LT. 1) GO TO 185
      DO 120 K1 = 1, M
      IF (IPIVOT (K1) .NE. 1) GO TO 150
 120  CONTINUE
 185  CONTINUE
C.....COMPUTE D=C*B*(INV(-A))...........................................
      CALL SQMULT (C, D, D, M)
      IF(L.NE.2) GO TO 145
      GO TO 135
C.....A IS SINGULAR, INTERCHANGE A AND B AND TRY AGAIN..................
 125  IF (M .LT. 1) GO TO 190
      DO 130 I2 = 1, M
      IF (M .LT. 1) GO TO 195
      DO 130 J2 = 1, M
      TEMP = A (I2, J2)
      A (I2, J2) = B (I2, J2)
 130  B (I2, J2) = TEMP
 195  CONTINUE
 190  CONTINUE
C.....IF A AND B BOTH SINGULAR, GO TO 310...............................
      IF (L .EQ. 2) GO TO 155
      L = 2
      GO TO 100
C.....RE-INTERCHANGE A AND B, AND INTERCHANGE C AND D WITH SIGNS CHANGED
C     DUE TO THE -I FACTORED OUT WHEN A AND B ORIGINALLY INTERCHANGED...
 135  IF (M .LT. 1) GO TO 200
      DO 140 I3 = 1, M
      IF (M .LT. 1) GO TO 205
      DO 140 J3 = 1, M
      TEMP = A (I3, J3)
      A (I3, J3) = B (I3, J3)
      B (I3, J3) = TEMP
      TEMP = - C (I3, J3)
      C (I3, J3) = - D (I3, J3)
 140  D (I3, J3) = TEMP
 205  CONTINUE
 200  CONTINUE
 145  RETURN
C
C.....ERROR STOP - NO INVERSE EXISTS....................................
 150  WRITE (* , 1500)
1500  FORMAT ('0MATRIX C IN SUBROUTINE CMPINV DOES NOT EXIST.'//)
      STOP
C.....ERROR STOP - INVERSE CANNOT BE FOUND BY THIS METHOD...............
 155  WRITE (* , 1502)
1502  FORMAT ('0MATRICES A AND B BOTH SINGULAR IN SUBR CMPINV.'//)
      STOP
      END


********************************************************************
      SUBROUTINE initw(w,ndim,nf)
      implicit none
*     IMPORT/EXPORT
      integer  ndim,nf
      real     w(ndim,nf)
*     LOCAL
      integer  i,l
*     FUNCTIONS
      real    g05caf
      real    rand
*
      DO i=1,ndim
       DO l=1,nf
!        w(i,l) = g05caf()
 !        w(i,l) = rand()
       ENDDO
      ENDDO
*
      END
*****************************************************************************
      real FUNCTION l2nrm(f,ndim)
      implicit none
      integer i,ndim
      real    f(ndim),nrm
*
      nrm = 0.0
      DO i=1,ndim
       nrm = f(i)*f(i) + nrm
      ENDDO
      l2nrm = sqrt(nrm)
*
      END
*****************************************************************************
      real FUNCTION linrm(f,ndim)
      implicit none
      integer i,ndim
      real    f(ndim),nrm
*
      nrm = 0.0
      DO i=1,ndim
       IF ( abs(f(i)).GT.nrm ) nrm = abs(f(i))
      ENDDO
      linrm = nrm
*
      END
****************************************
      subroutine findex(row,i,j,k,XX)
      ! find variable XX and grid point (i,j,k) that
      ! correspond to row 'row' in matrix A
      implicit none
      include 'usr.com'
      integer row, i, j, k, XX
      IF (prec.eq.1) THEN
         call findex_interleaved_ordering(row,i,j,k,XX)
      ELSE
         call findex_block_ordering(row,i,j,k,XX)
      END IF
      end subroutine findex

****************************************
      subroutine findex_block_ordering(row,i,j,k,XX)
      ! find variable XX and grid point (i,j,k) that
      ! correspond to row 'row' in matrix A
      implicit none
      include 'usr.com'
      integer t, r, XX, row, i, j, k, nn
      nn = n*m*(l+la)
      if (row.LE.2*nn) then
         XX = 2 - mod(row,2) ! UU or VV
         r = (row + 2 - XX)/2
      elseif (row.LE.3*nn) then
         XX = WW
         r = mod(row-1,nn)+1
      elseif (row.LE.4*nn) then
         XX = PP
         r = mod(row-1,nn)+1
      elseif (row.LE.6*nn) then
         XX = 6 - mod(row,2) ! TT or SS
         r = (mod(row-1,2*nn)+1 +6 - XX)/2
      else
         STOP "error in findex (matetc.f): row > ndim "
      end if
      k = int((r-1)/(n*m))+1
      r = mod(r-1,n*m)+1
      j = int((r-1)/n)+1
      i = mod(r-1,n)+1
      end subroutine findex_block_ordering

****************************************
      subroutine findex_interleaved_ordering(row,i,j,k,XX)
      ! find variable XX and grid point (i,j,k) that
      ! correspond to row 'row' in matrix A
      implicit none
      include 'usr.com'
      integer t, r, XX, row, i, j, k

      XX = mod(row - 1, nun) + 1
      r = (row - XX)/nun
      t = mod(r, n*m)
      k = (r - t)/(n*m) + 1
      i = mod(t, n) + 1
      j = (t - i + 1)/n + 1
      end subroutine findex_interleaved_ordering

****************************************
      integer function find_row(i,j,k)
      implicit none
      include 'par.com'
      integer i,j,k
      find_row = nun*((k-1)*n*m+ n*(j-1) + i-1)
      WRITE(99,*) "use of find_row is prohibited, use find_row2 instead"
      STOP
      end function find_row

****************************************
      integer function find_row2(i,j,k,XX)
      ! find row in matrix A of variable XX at grid point (i,j,k)
      implicit none
!      include 'par.com'
      include 'usr.com'
      integer i,j,k,XX
!     functions
      integer find_row_interleaved_ordering, find_row_block_ordering
      IF (prec.eq.1) THEN
         find_row2 = find_row_interleaved_ordering(i,j,k,XX)
      ELSE
         find_row2 = find_row_block_ordering(i,j,k,XX)
      END IF
      end function find_row2

****************************************
      integer function find_row_block_ordering(i,j,k,XX)
      ! find row in matrix A of variable XX at grid point (i,j,k)
      implicit none
      include 'usr.com'
      integer i,j,k,XX
      select case (XX)
      case (UU:VV)
         find_row_block_ordering = 2*((k-1)*n*m + (j-1)*n + i-1) + XX
      case (WW)
         find_row_block_ordering = (k-1)*n*m + (j-1)*n + i + (WW-1)*n*m*(l+la)
      case (PP)
         find_row_block_ordering = (k-1)*n*m + (j-1)*n + i + (PP-1)*n*m*(l+la)
      case (TT:SS)
         find_row_block_ordering = 2*((k-1)*n*m + (j-1)*n + i-1) +(TT-1)*n*m*(l+la)+(XX-4)
      case default
         find_row_block_ordering = -1
      end select
      ! check dimensions
      if ((i>n).or.(i<1).or.(j>m).or.(j<1).or.(k>l+la).or.(k<1)) then
         find_row_block_ordering = -1
      end if
      end function find_row_block_ordering

****************************************
      integer function find_row_interleaved_ordering(i,j,k,XX)
      ! find row in matrix A of variable XX at grid point (i,j,k)
      implicit none
      include 'usr.com'
      integer i,j,k,XX
      find_row_interleaved_ordering = nun*((k-1)*n*m+ n*(j-1) + i-1)+XX
      ! check dimensions
      if ((i>n).or.(i<1).or.(j>m).or.(j<1).or.(k>l+la).or.(k<1)) then
         find_row_interleaved_ordering = -1
      end if
      end function find_row_interleaved_ordering

*******************************************************************************
      SUBROUTINE matAvec(v1,v2)
*     This multiplies sparse matrix A and vector v1 to vector v2
      USE m_mat
      implicit none
      include 'par.com'
!      include 'mat.com'
      real     v1(ndim),v2(ndim)
*     LOCAL
      integer  i,v
*
      v2 = 0.0
      DO i = 1,ndim
       DO v = begA(i),begA(i+1)-1
         v2(i) = coA(v)*v1(jcoA(v)) + v2(i)
       ENDDO
      ENDDO
*
      END
*******************************************************************************
      SUBROUTINE matBvec(v1,v2)
*     This multiplies sparse matrix B and vector v1 to vector v2
*     B is a diagonal matrix
      USE m_mat
      implicit none
      include 'par.com'
!      include 'mat.com'
      real     v1(ndim),v2(ndim)
*     LOCAL
      integer  i
*
      DO i = 1,ndim
       v2(i) = coB(i)*v1(i)
      ENDDO
*
      END
************************************************************************
      SUBROUTINE writematrhs(rl)
*     write the matrix A + rhs to a file
      USE m_mat
      implicit none
      include 'par.com'
!      include 'mat.com'
*     INPUT/OUTPUT
      real     rl(ndim)
*     LOCAL
      integer i
*
      open( 9,file='B.co')
      open(10,file='A.info')
      open(11,file='A.beg')
      open(12,file='A.jco')
      open(13,file='A.co')
      open(14,file='A.rl')
      write(10,*) ndim,begA(ndim+1)-1
      DO i=1,ndim+1
        write(11,*) begA(i)
      ENDDO
      DO i=1,begA(ndim+1)-1
        write(12,*) jcoA(i)
      ENDDO
      DO i=1,begA(ndim+1)-1
        write(13,*) coA(i)
      ENDDO
      DO i=1,ndim
        write( 9,*) coB(i)
        write(14,*) rl(i)
      ENDDO
      close( 9)
      close(10)
      close(11)
      close(12)
      close(13)
      close(14)
*     STOP
*
      END
*******************************************************
      subroutine writevector(ndim,x)
      implicit none
      integer ndim, i
      real x(1)
      open(10,file='A.sol', status='UNKNOWN')
*      print*, 'Vector'
      do i = 1, ndim
         write(10,*) x(i)
*         print '(A,I4,A,G10.10)', '[', i, '] = ', x(i)
      enddo
      close(10)
*      stop
      end
********************************************************
      subroutine writevectori(ndim,x)
      implicit none
      integer ndim, i
      integer x(1)
*      open(10,file='A.sol', status='UNKNOWN')
      print*, 'Vector'
      do i = 1, ndim
*         write(10,*) x(i)
         print '(A,I4,A,I8)', '[', i, '] = ', x(i)
      enddo
      close(10)
      end
********************************************************
      subroutine printmat( a, n)
      integer n, i, j
      real a(n,n)
      write(*,*) ' '
      do i = 1, n
         write(*,'(10(f10.4,x))') (a(i,j), j = 1, n)
      enddo
      write(*,*) ' '
      end


      SUBROUTINE fft_local(dat)
!  fft_local
!    Subroutine to interface with 'cftfax_g' and 'cfft99', Fourier transform
!    subroutines found in LIBSTELL/FFTpack.  'cftfax_g' conditions the vectors 'trigs' and
!    'ifax', while 'cfft99' does the actual transform.  See those subroutines for more
!    information.

!    Performs a 2D (two 1D) Fourier transform on the input data.  The data
!    should have the form dat(N1, N2, 2) where N1 and N2 are the number of
!    data points in the first and second direction, respectively, and
!    the final index separates the real (1) and imaginary (2) parts of the
!    data.

      USE stel_kinds, only: rprec

      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------

      REAL(rprec), DIMENSION(:,:,:) :: dat
      REAL(rprec), DIMENSION(:), ALLOCATABLE :: a, trigs, work
      INTEGER :: N, i, inc, jump, lot, isign, j
      INTEGER, DIMENSION(13) :: ifax

!-----------------------------------------------
!  Start of Executable Code
!-----------------------------------------------

      N=SIZE(dat,1)
      isign=-1  !Sign of exponent in transform
      lot=SIZE(dat,2)
      jump=N  !Number to skip between data vectors.  Since we only do
              !one transform at a time, it shouldn't matter, but it
              !seems to have problems for values larger than N
      inc=1   !Number of array spaces between value pairs

      ALLOCATE(a(2*N))
      ALLOCATE(trigs(2*N))
      ALLOCATE(work(lot*N))

      DO j=1, lot
         DO i=1, N
!  The values are stored in a 1-d array with alternating real and imaginary
!  parts.
            a(2*i-1)=dat(i,j,1)
            a(2*i)=dat(i,j,2)
         END DO

!  Do the transform
         CALL cftfax_g(N, ifax, trigs)
         CALL cfft99(a,work,trigs, ifax, inc, jump, N, 1, isign)

!  Put the new values back into the input/output array
         DO i=1, N
            dat(i,j,1)=a(2*i-1)
            dat(i,j,2)=a(2*i)
         END DO
      END DO

!  Reallocate to do the transform in the other index
      IF(ALLOCATED(a)) DEALLOCATE(a)
      ALLOCATE(a(2*lot))
      IF(ALLOCATED(trigs)) DEALLOCATE(trigs)
      ALLOCATE(trigs(2*lot))
      IF(ALLOCATED(work)) DEALLOCATE(work)
      ALLOCATE(work(lot*N))

      DO i=1, N
         DO j=1, lot
            a(2*j-1)=dat(i,j,1)
            a(2*j)=dat(i,j,2)
         END DO

         CALL cftfax_g(lot, ifax, trigs)
         CALL cfft99(a,work,trigs, ifax, inc, jump, lot, 1, isign)

         DO j=1, lot
            dat(i,j,1)=a(2*j-1)
            dat(i,j,2)=a(2*j)
         END DO
      END DO

      END SUBROUTINE fft_local


PROGRAM MAIN

  USE netcdf
  USE Blocked_Flow_Index_new

  IMPLICIT NONE

  INTEGER,PARAMETER :: xdim = 360         ! Setting x dimension parameter
  INTEGER,PARAMETER :: ydim = 181         ! setting y dimension parameter
  INTEGER :: NX,NY,NT                     !
  INTEGER :: tdim                         ! Time dimension
  INTEGER :: BISSEXTO                     ! Leap year parameter
  REAL,DIMENSION(xdim) :: lon             ! Longitude
  REAL,DIMENSION(ydim) :: lat             ! Latitude

  REAL,PARAMETER :: res = 1.0             ! grid resolution
  INTEGER,PARAMETER :: pers = 5           ! persistence for blocking events

  ! Allocatable variables index, difference, potential temperature, blocking
  REAL,ALLOCATABLE,DIMENSION(:,:,:) :: ind, dif, theta,theta4, blk, thetas4
  INTEGER,ALLOCATABLE,DIMENSION(:,:,:) :: thet

  CHARACTER(300) :: iofile, var, att                      ! Character variable
  INTEGER :: t, y, month, k, days, time1day               ! time dependence
  REAL ::   scale, offset                                 ! Netcdf library requirements

  INTEGER :: begin, final                                 ! Start and end dates
  CHARACTER(300) :: input_dir, output_dir, conf_file      ! Input and output folders

  conf_file = 'config_files/config.fortran.txt'
  CALL read_conf_file( conf_file, input_dir, output_dir, begin, final )  ! Getting some variables

  DO y = begin,final
    WRITE(*,'(A,1X,I4,A)') 'Doing year :',y,' ----------------------------> '
    k = 1

    IF( BISSEXTO(y) == 1 )THEN
      tdim = 366
    ELSE
      tdim = 365
    END IF

	DO month = 1,12
      IF( month < 10 )THEN
        WRITE(iofile,'(A,I4,A,I4,A,I1,A)') TRIM(input_dir),y,'/theta_2PVU_',y,'-0',month,'.nc'
      ELSE
        WRITE(iofile,'(A,I4,A,I4,A,I2,A)') TRIM(input_dir),y,'/theta_2PVU_',y,'-',month,'.nc'
      END IF

      WRITE(*,'(A,A)') 'Reading file: ',TRIM(iofile)

      SELECT CASE( month )
        CASE(1); days = 31
        CASE(2); days = 28
        CASE(3); days = 31
        CASE(4); days = 30
        CASE(5); days = 31
        CASE(6); days = 30
        CASE(7); days = 31
        CASE(8); days = 31
        CASE(9); days = 30
        CASE(10);days = 31
        CASE(11);days = 30
        CASE(12);days = 31
      END SELECT

      ! Verify for leap year
      IF( BISSEXTO(y) == 1 .and. month == 2)THEN
        days = 29
      END IF

      IF( month==1 ) ALLOCATE(theta(xdim,ydim,tdim*4))
      ALLOCATE(thet(xdim,ydim,days*4))

      NX = xdim; NY = ydim; NT = 4*days;
      var = 'pt';           CALL reader(iofile,var,thet)
      att = 'scale_factor'; CALL reader_att( iofile,att,var,scale )
      att = 'add_offset'  ; CALL reader_att( iofile,att,var,offset )

      theta(:,:,k:k+days-1) = thet(:,:,:) * scale + offset
      k = k+4*days;

      !write(*,*) theta(60,46,k-1)

      DEALLOCATE(thet)

      IF( month == 1 )THEN
        var = 'longitude';   CALL reader_dim( iofile,var,lon, xdim );
        var = 'latitude' ;   CALL reader_dim( iofile,var,lat, ydim );
      END IF

    END DO

    ALLOCATE(theta4(xdim,ydim,tdim))
    time1day = 4
    CALL DAILY_MEANS(theta, theta4, xdim, ydim, 4*tdim, time1day)

    NX = xdim; NY = ydim; NT = tdim;

    ! Computing the blocking index
    ALLOCATE(ind(NX,NY,NT)); ALLOCATE(dif(NX,NY,NT)); ALLOCATE(blk(NX,NY,NT)); ALLOCATE(thetas4(NX,NY,NT))

    ! Before evaluate the blockings compute smooth the data in n degrees
    CALL SMOOTH(theta4,thetas4, xdim, ydim, tdim, res)

    DO t = 1, tdim
      CALL PH_Index ( ind(:,:,t), dif(:,:,t), thetas4(:,:,t), xdim, ydim, res )
      CALL GLBI ( ind(:,:,t), xdim, ydim, res )
    END DO

    WRITE(*,*)
    WRITE(*,*) 'Wait -----> Searching for blockings'
    WRITE(*,*)

    ! Computing Blockings with pers days
    CALL BLOCKING (blk, ind, xdim, ydim, tdim, res, pers )

    ! Writing the outputs
    WRITE(iofile,'(A,i4,A)') TRIM(output_dir), y,'.blocked.nc'
    CALL write_netcdf( iofile,ind, lat, lon)
    WRITE(*,'(A,A)') 'Writing file: ',TRIM(iofile)

    WRITE(iofile,'(A,i4,A)') TRIM(output_dir), y,'.blocking.nc'
    CALL write_netcdf( iofile,blk, lat, lon)
    WRITE(*,'(A,A)') 'Writing file: ',TRIM(iofile)

    WRITE(iofile,'(A,i4,A)') TRIM(output_dir), y,'.gradient.nc'
    CALL write_netcdf( iofile,dif, lat, lon)
    WRITE(*,'(A,A)') 'Writing file: ',TRIM(iofile)

    WRITE(iofile,'(A,i4,A)') TRIM(output_dir), y,'.theta.nc'
    CALL write_netcdf( iofile,theta4, lat, lon)
    WRITE(*,'(A,A)') 'Writing file: ',TRIM(iofile)

    DEALLOCATE(ind); DEALLOCATE(blk); DEALLOCATE(dif); DEALLOCATE(theta);
    DEALLOCATE(theta4); DEALLOCATE(thetas4);

  END DO

   CONTAINS

   !_____________________________________________________________!
   SUBROUTINE read_conf_file( conf_file, input_dir, output_dir, begin, final)
       ! Subroutine to read configuration file

       CHARACTER(300), INTENT(IN)    :: conf_file
       CHARACTER(300), INTENT(INOUT) :: input_dir, output_dir
       INTEGER       , INTENT(INOUT) :: begin, final

       OPEN(10, file=conf_file )

       READ(10,'(a)') input_dir
       READ(10,'(a)') output_dir
       READ(10,'(i4)') begin
       READ(10,'(i4)') final

       CLOSE(10)

    END SUBROUTINE

   !_____________________________________________________________!
   SUBROUTINE reader(fname,varname,output)
      ! Subroutine to read the data from netcdf files

      CHARACTER(100),INTENT(in)                :: fname    ! file name
      CHARACTER(100),INTENT(in)                :: varname  ! variable to be readed
      INTEGER,DIMENSION(NX,NY,NT),INTENT(inout)   :: output   ! output variable
      INTEGER :: ncid,varid                                ! netCDF id and variables id

      !Open the file N90_NOWRITE tells netcdf wants read-only access to the file
      call check( nf90_open(trim(fname), NF90_NOWRITE, ncid) )
      call check( nf90_inq_varid(ncid,trim(varname),varid) )   !Get the varid
      call check( nf90_get_var(ncid, varid, output) )          !Read the data
      call check( nf90_close(ncid) )                           !Close the file

    END SUBROUTINE reader

    !_____________________________________________________________!
    SUBROUTINE reader_dim( fname,varname,output, sz )
      ! This subroutine is only used to return the latitude and longitude
      INTEGER,INTENT(in)                     :: sz       ! size of the variable
      CHARACTER(100),INTENT(in)              :: fname    ! file name
      CHARACTER(100),INTENT(in)              :: varname  ! variable to be readed
      REAL,DIMENSION(sz),INTENT(out)         :: output   ! output variable (lat or lon)
      INTEGER :: ncid,varid                              ! netCDF id and variables id

      call check( nf90_open(trim(fname), NF90_NOWRITE, ncid) )
      call check( nf90_inq_varid(ncid,trim(varname),varid) )   !Get the varid
      call check( nf90_get_var(ncid, varid, output) )          !Read the data
      call check( nf90_close(ncid) )                           !Close the file

    END SUBROUTINE reader_dim

    SUBROUTINE reader_att( fname,att,varname,output )
      ! this subroutine read the att of a netcdf file
      CHARACTER(len=100),INTENT(in)              :: fname    ! file name
      CHARACTER(len=100),INTENT(in)              :: att      ! variable to be readed
      REAL,INTENT(out)                       :: output   ! output variable (lat or lon)
      CHARACTER(100),INTENT(in)              :: varname  !
      INTEGER :: ncid,varid,attid, xtype,len             ! netCDF id and variables id

      call check( nf90_open(trim(fname), NF90_NOWRITE, ncid) )
      call check( nf90_inq_varid(ncid,trim(varname),varid) )

      call check( nf90_inquire_attribute(ncid,varid,trim(att),xtype,len,attid) )
      call check( nf90_get_att(ncid,varid,trim(att),output) )
      call check( nf90_close(ncid) )

    END SUBROUTINE reader_att

    !_____________________________________________________________!
    SUBROUTINE write_netcdf( file_out ,div, lat, lon)
      ! This subroutine writes the otput into a netcdf file

      REAL,DIMENSION(NX,NY,NT),INTENT(in) :: div
      REAL,DIMENSION(NX),INTENT(in)       :: lon
      REAL,DIMENSION(NY),INTENT(in)       :: lat
      INTEGER :: x_dimid, y_dimid,t_dimid, z_dimid, varid , ncid
      INTEGER,DIMENSION(3) :: dimids, step, start
      REAL,DIMENSION(NT) :: time
      INTEGER :: i, lat_varid, lon_varid, div_varid, t_varid, NTclear
      CHARACTER(len=100), INTENT(in) :: file_out

      CHARACTER(len = *), PARAMETER :: UNITS = "units"
      CHARACTER(len = *), PARAMETER :: DIV_UNITS = "do not matter"
      CHARACTER(len = *), PARAMETER :: LAT_UNITS = "degrees_north"
      CHARACTER(len = *), PARAMETER :: LON_UNITS = "degrees_east"
      CHARACTER(len = *), PARAMETER :: TIME_UNITS= "Running Steps"

      CHARACTER(len = *), PARAMETER :: AXIS = 'axis'
      CHARACTER(len = *), PARAMETER :: XAXIS = "X"
      CHARACTER(len = *), PARAMETER :: YAXIS = "Y"
      CHARACTER(len = *), PARAMETER :: TAXIS = "T"

      time(1) = 0.
      DO i = 2, NTclear
        time(i) = time(i-1)+(1./4.)
      END DO

      call check( nf90_create(TRIM(file_out), NF90_CLOBBER, ncid) )    ! Create a netcdf file

      ! Define the dimensions
      call check( nf90_def_dim( ncid,'lat',NY, y_dimid) )          ! Define the dimensions
      call check( nf90_def_dim( ncid,'lon',NX, x_dimid) )          ! Define the dimensions
      call check( nf90_def_dim( ncid,'time',NT, t_dimid) )

      dimids = (/ x_dimid,y_dimid,t_dimid/)                        ! IDs arrays

      ! Define the variables
      call check( nf90_def_var(ncid,'lat',NF90_DOUBLE,y_dimid,lat_varid) )
      call check( nf90_def_var(ncid,'lon',NF90_DOUBLE,x_dimid,lon_varid) )
      call check( nf90_def_var(ncid,'time',NF90_DOUBLE,t_dimid,t_varid) )
      call check( nf90_def_var(ncid,'blk',NF90_DOUBLE, dimids, div_varid ) )

      ! Assign units attributes to coordinate variables
      call check( nf90_put_att(ncid, lat_varid, UNITS, LAT_UNITS ) )
      call check( nf90_put_att(ncid, lon_varid, UNITS, LON_UNITS ) )
      call check( nf90_put_att(ncid, t_varid, UNITS, TIME_UNITS) )
      call check( nf90_put_att(ncid, div_varid, UNITS, DIV_UNITS) )

      call check( nf90_put_att(ncid, lat_varid, AXIS, YAXIS) )
      call check( nf90_put_att(ncid, lon_varid, AXIS, XAXIS) )
      call check( nf90_put_att(ncid, t_varid, AXIS, TAXIS) )

      ! End define mode
      call check( nf90_enddef(ncid) )

      ! Write coordinate variable data
      call check( nf90_put_var(ncid,lat_varid,lat) )
      call check( nf90_put_var(ncid,lon_varid,lon) )

      !Writing the data in the netcdf file
      step  = (/NX,NY,NT/)
      start = (/1,1,1/)
      call check( nf90_put_var(ncid,div_varid,div,start=start,count=step) )

      ! close the file
      call check( nf90_close(ncid) )

      write(*,*) 'Success file created'

    END SUBROUTINE write_netcdf

    !_____________________________________________________________!
    SUBROUTINE check(status)
       integer, intent(in) :: status

       if( status /= nf90_noerr )then
         write(*,*) trim(nf90_strerror(status))
         stop "Stopped"
       end if
     END SUBROUTINE check

END PROGRAM MAIN

INTEGER FUNCTION BISSEXTO( year )
  IMPLICIT NONE

  INTEGER,INTENT(in) :: year

  IF( mod(year,400) == 0 )THEN
    BISSEXTO = 1 ; RETURN
  ELSE IF( mod(year,4)==0 .and. mod(year,100)/=0 )THEN
    BISSEXTO = 1 ; RETURN
  ELSE
    BISSEXTO = 0 ; RETURN
  END IF

END FUNCTION