c=======================================================================
       subroutine ldtfpdensity(nrec,ptf,pce,xtf,xce,y,
     &                         ngrid,npredden,npredmed,grid,
     &                         xtfpred,xcepred,
     &                         xtfpredm,xcepredm,quans,
     &                         maxm,ntprob,ntlr,a0b0,betacepm,
     &                         gprior,precce,
     &                         tau,alpha,betace,betatf,sigma2,
     &                         mcmc,nsave,seed,
     &                         cpo,densm,densl,densu,
     &                         qmm,qml,qmu,survmm,survml,survmu,
     &                         thetasave,randsave,
     &                         iflag,iflagtf,
     &                         nobsbc,obsbc,c0,
     &                         workm1,workvh1,workv1,
     &                         worksam,worksam2,worksam3,fs,
     &                         workm2,workvh2,
     &                         workv2,workv3,workv4,k,
     &                         prob,probc)
c=======================================================================
c     # 62 arguments
c
c     Subroutine `ldtfpdensity' to run a Markov chain for a
c     Linear Dependent Tailfree Process prior for
c     conditional density estimation.
c
c     Copyright: Alejandro Jara, 2011.
c
c     Version 1.0:
c
c     Last modification: 11-11-2011.
c
c     This program is free software; you can redistribute it and/or modify
c     it under the terms of the GNU General Public License as published by
c     the Free Software Foundation; either version 2 of the License, or (at
c     your option) any later version.
c
c     This program is distributed in the hope that it will be useful, but
c     WITHOUT ANY WARRANTY; without even the implied warranty of
c     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
c     General Public License for more details.
c
c     You should have received a copy of the GNU General Public License
c     along with this program; if not, write to the Free Software
c     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
c
c     The author's contact information:
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c---- Data -------------------------------------------------------------
c
c        nrec        :  integer giving the number of data points.
c        ptf         :  integer giving the number of predictors for
c                       the tailfree conditional probabilities.
c        ptf         :  integer giving the number of predictors for
c                       the median function.
c        xtf         :  real matrix giving the design matrix for
c                       the conditional talfree probabilities,
c                       xtf(nrec,ptf).
c        xce         :  real matrix giving the design matrix for
c                       the median function,
c                       xce(nrec,ptf).
c        y           :  real vector giving the responses, y(nrec).
c
c-----------------------------------------------------------------------
c
c---- Prediction -------------------------------------------------------
c
c        cband       :  integer value indicating whether the
c                       credible bands need to be computed or not.
c        ngrid       :  integer giving the number of grid points where
c                       the density estimates are evaluated.
c        npredden    :  integer giving the number of predictions for
c                       the conditional densities.
c        npredmed    :  integer giving the number of predictions for
c                       the quantile functions.
c        tband       :  integer indicating the type of credible
c                       band that need to be computed.
c        grid        :  real vector giving the grid, grid(ngrid).
c        xtfpred     :  real matrix giving the design matrix, for the
c                       conditional probabilities, used in the
c                       estimation of the conditional densities,
c                       xtfpred(npreden,ptf).
c        xcepred     :  real matrix giving the design matrix, for the
c                       median function, used in the
c                       estimation of the conditional densities,
c                       xcepred(npreden,ptf).
c        xtfpredm    :  real matrix giving the design matrix, for the
c                       conditional probabilities, used in the
c                       estimation of the quantile functions,
c                       xtfpredm(npredmed,ptf).
c        xcepredm    :  real matrix giving the design matrix, for the
c                       median function, used in the
c                       estimation of the quntile functions,
c                       xcepred(npredmed,ptf).
c        quans       :  real vector giving the quantile functions
c                       to be evaluated, quans(3).
c
c-----------------------------------------------------------------------
c
c---- Prior information ------------------------------------------------
c
c        a0b0        :  real vector giving the hyperparameters of the
c                       prior distribution for the precision parameter,
c                       alpha ~ Gamma(a0b0(1),a0b0(2)). If a0b0(1)<0
c                       the precision parameter is considered constant.
c        betapm      :  double precision vector giving the mean of the
c                       normal prior distribution for the median
c                       regression coefficients, betapm(pce).
c        maxm        :  integer giving the finite level of the
c                       dependent tailfree process.
c        precce      :  double precision matrix giving the precision
c                       matrix of the normal prior distribution for
c                       the median regression coefficients,
c                       precce(pce,pce).
c        ntprob      :  integer giving the number of final sets
c                       involved in the partition.
c        ntlr        :  integer giving the number of logistic
c                       regressions involved.
c        tau         :  real vector giving the values of hyperparameters
c                       of the inv-Gamma prior for sigma^{-2}, tau(2).
c        gprior      :  real matrix giving the common component of the
c                       covariance matrix for the tailfree logistic
c                       regression coefficients, gprior(ptf,ptf).
c
c-----------------------------------------------------------------------
c
c---- Current value of the parameters ----------------------------------
c
c        alpha       :  real giving the current value of the precision
c                       parameter of the DTFP.
c        betace      :  real vector giving the value of the median
c                       regression coefficients, betace(pce).
c        betatf      :  real matrix giving the value of the tailfree
c                       regression coefficients, betatf(ntlr,ptf).
c        sigma2      :  real giving the value of the centering
c                       variance.
c
c-----------------------------------------------------------------------
c
c---- MCMC parameters --------------------------------------------------
c
c        nburn       :  integer giving the number of burn-in scans.
c        ndisplay    :  integer giving the number of saved scans to be
c                       displayed on screen.
c        nskip       :  integer giving the thinning interval.
c        nsave       :  integer giving the number of scans to be saved.
c        nbase       :  integer giving the the number of scans where
c                       the baseline distribution and the precision
c                       parameter are sampled.
c        seed        :  integer vector giving the seeds for the random
c                       number generator, seed(2).
c
c-----------------------------------------------------------------------
c
c---- Output -----------------------------------------------------------
c
c        cpo         :  real giving the cpos and fsos, cpo(nrec,2).
c        densm       :  real matrix giving the posterior mean of the
c                       density, densm(npredden,ngrid).
c        densl       :  real matrix giving the lower limit of the
c                       HPD of the density, densu(npredden,ngrid).
c        densu       :  real matrix giving the upper limit of the
c                       HPD of the density, densu(npredden,ngrid).
c        qmm         :  real matrix giving the posterior mean of the
c                       quantile functions, qmm(npredmed,3).
c        qml         :  real matrix giving the lower limit of the
c                       HPD of the quantile functions,
c                       qml(npredmed,3).
c        qmu         :  real matrix giving the upper limit of the
c                       HPD of the quantile functions,
c                       qmu(npredmed,3).
c        randsave    :  real matrix containing the mcmc samples for
c                       the tailfree regression coefficients,
c                       randsave(nsave,(ntlr-1)*ptf).
c        survmm      :  real matrix giving the posterior mean of the
c                       survival functions, survmm(npredden,ngrid).
c        survml      :  real matrix giving the lower limit of the
c                       HPD of the survival functions,
c                       survml(npredden,ngrid).
c        survmu      :  real matrix giving the upper limit of the
c                       HPD of the survival functions,
c                       survmu(npredden,ngrid).
c        thetasave   :  real matrix containing the mcmc samples for
c                       the parameters, thetasave(nsave,pce+2)
c
c-----------------------------------------------------------------------
c
c---- Working space ----------------------------------------------------
c
c        c0          :  real matrix used to update the reg. coeff.,
c                       c0(ptf,ptf).
c        fs          :  real vector used to evaluate the conditional
c                       densities, fs(ngrid).
c        iflag       :  integer vector used to update reg. coeff.,
c                       iflag(pce).
c        iflagtf     :  integer vector used to update reg. coeff.,
c                       iflag(ptf).
c        k           :  integer vector, k(maxm).
c        nobsbc      :  integer vector giving the number of
c                       observations in each parition set,
c                       nobsbc(ntprob).
c        obsbc       :  integer matrix giving the
c                       observations in each partition set,
c                       obsbc(ntprob,nrec).
c        prob        :  real working vector, prob(2**maxm).
c        probc       :  real working vector, prob(2**maxm).
c        workm1      :  real matrix used to update the reg. coeff.,
c                       workm1(pce,pce).
c        workm2      :  real matrix used to update the reg. coeff.,
c                       workm2(ptf,ptf).
c        workmh1     :  real vector used to update the reg. coeff.,
c                       workmh1(pce*(pce+1)/2).
c        workmh2     :  real vector used to update the reg. coeff.,
c                       workmh2(ptf*(ptf+1)/2).
c        worksam     :  real vector used to comput HPD bands,
c                       worksam(nsave).
c        worksam2    :  real matrix used to comput HPD bands,
c                       worksam2(nsave,ngrid).
c        worksam3    :  real matrix used to comput HPD bands,
c                       worksam3(nsave,npredden).
c        workv1      :  real vector used to update the reg. coeff.,
c                       workv1(pce).
c        workv2      :  real vector used to update the reg. coeff.,
c                       workv2(ptf).
c        workv3      :  real vector used to update the reg. coeff.,
c                       workv3(ptf).
c        workv4      :  real vector used to update the reg. coeff.,
c                       workv4(ptf).
c
c=======================================================================

      implicit none
c++++ input
      integer nrec,ptf,pce
      real*8 xtf(nrec,ptf)
      real*8 xce(nrec,pce)
      real*8 y(nrec)

c++++ prediction
      integer ngrid,npredden,npredmed
      real*8 grid(ngrid)
      real*8 xtfpred(npredden,ptf)
      real*8 xcepred(npredden,pce)
      real*8 xtfpredm(npredmed,ptf)
      real*8 xcepredm(npredmed,pce)
      real*8 quans(3)

c++++ prior
      integer maxm,ntprob,ntlr
      real*8 a0b0(2)
      real*8 betacepm(pce)
      real*8 gprior(ptf,ptf)
      real*8 precce(pce,pce)
      real*8 tau(2),tau1,tau2

c++++ current value
      real*8 alpha
      real*8 betace(pce)
      real*8 betatf(ntlr,ptf)
      real*8 sigma2

c++++ mcmc
      integer mcmc(5),nburn,nskip,nsave,ndisplay

c++++ bands
      integer cband,tband

c++++ seeds
      integer seed1,seed2,seed(2)

c++++ output
      real*8 cpo(nrec,2)
      real*8 densm(npredden,ngrid)
      real*8 densl(npredden,ngrid)
      real*8 densu(npredden,ngrid)
      real*8 survmm(npredden,ngrid)
      real*8 survml(npredden,ngrid)
      real*8 survmu(npredden,ngrid)

      real*8 qmm(npredmed,3)
      real*8 qml(npredmed,3)
      real*8 qmu(npredmed,3)

      real*8 thetasave(nsave,pce+2)
      real*8 randsave(nsave,(ntlr-1)*ptf)

c++++ external working space - vector and matrices
      integer iflag(pce)
      integer iflagtf(ptf)
      integer nobsbc(ntprob)
      integer obsbc(ntprob,nrec)
      real*8 c0(ptf,ptf)
      real*8 workm1(pce,pce)
      real*8 workvh1(pce*(pce+1)/2)
      real*8 workv1(pce)

      real*8 worksam(nsave)
      real*8 worksam2(nsave,ngrid)
      real*8 worksam3(nsave,npredden)
      real*8 fs(ngrid)

      real*8 workm2(ptf,ptf)
      real*8 workvh2(ptf*(ptf+1)/2)
      real*8 workv2(ptf)
      real*8 workv3(ptf)
      real*8 workv4(ptf)

      integer k(maxm)

      real*8 prob(2**maxm)
      real*8 probc(2**maxm)

c++++ internal working space
      integer accept,acceptt
      integer i,ii,i1,j,jj,j1,k1,ll,l1,l2,mm
      integer d1,d2
      integer dispcount,iscan,isave
      integer ntot,n1,n2
      integer nscan,skipcount
      integer sprint
      real*8 alnorm
      real*8 alphac
      real*8 dnrm
      real*8 dinvnorm
      real*8 liminf
      real*8 limsup
      real*8 loglikn,logliko
      real*8 logpriorn,logprioro
      real*8 logcgkn,logcgko
      real*8 luni,lratio
      real*8 qqnum
      real*8 rbeta
      real*8 rgamma
      real*8 rtnorm
      real*8 rnorm
      real runif
      real*8 sigma2c
      real*8 tmp1,tmp2,tmp3
      real*8 uni
      real*8 ya
      real*8 yc

      logical ainf
      logical asup

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

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++++ initializing variables

      open(unit=1,file='dppackage_dftp1.out',status='unknown',
     &     form='unformatted')
      open(unit=2,file='dppackage_dftp2.out',status='unknown',
     &     form='unformatted')
      open(unit=3,file='dppackage_dftp3.out',status='unknown',
     &     form='unformatted')
      open(unit=4,file='dppackage_dftp4.out',status='unknown',
     &     form='unformatted')
      open(unit=5,file='dppackage_dftp5.out',status='unknown',
     &     form='unformatted')

      tau1=tau(1)
      tau2=tau(2)

      call loglikldtfp(maxm,ntlr,ntprob,nrec,pce,ptf,betace,betatf,y,
     &                 xce,xtf,sigma2,
     &                 nobsbc,obsbc,logliko,k)
      i1=1
      do i=2,maxm
         j1=2**(i-1)

         do j=1,j1
            k1=i1+j

            c0=gprior/(alpha*dble(i**2))

            ii=(k1-1)*2+1
            jj=(k1-1)*2+2
            n1=nobsbc(ii)
            n2=nobsbc(jj)
            ntot=n1+n2

            if(n1.gt.0.and.n2.gt.0)then

               call startlrcoefldtfp(5,k1,ii,jj,n1,n2,maxm,ntlr,
     &                               ntprob,nrec,ptf,obsbc,betatf,
     &                               xtf,c0,iflagtf,workv2,workm2,
     &                               workv3)
            end if
         end do
         i1=i1+j1
      end do

      call loglikldtfp(maxm,ntlr,ntprob,nrec,pce,ptf,betace,
     &                 betatf,y,xce,xtf,sigma2,
     &                 nobsbc,obsbc,logliko,k)

      nburn=mcmc(1)
      nskip=mcmc(2)
      ndisplay=mcmc(3)

      cband=mcmc(4)
      tband=mcmc(5)

      seed1=seed(1)
      seed2=seed(2)
      call setall(seed1,seed2)

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

      call cpu_time(sec0)
      sec00=0.d0

      do iscan=1,nscan

c++++++++++++++++++++++++++++++++++++++
c+++++++ baseline reg coefficients  +++
c++++++++++++++++++++++++++++++++++++++

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

         do i=1,pce

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

            evali=1
            xx0=betace(i)

            call logposldtfp(maxm,ntlr,ntprob,nrec,pce,
     &                       ptf,betace,betatf,y,xce,xtf,
     &                       sigma2,betacepm,precce,
     &                       nobsbc,obsbc,tmp1,k)

            uni=runif()
            re=-log(uni)
            logy=tmp1-re

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

            evali=evali+1
            betace(i)=llim
            call logposldtfp(maxm,ntlr,ntprob,nrec,pce,
     &                       ptf,betace,betatf,y,xce,xtf,
     &                       sigma2,betacepm,precce,
     &                       nobsbc,obsbc,gllim,k)

            evali=evali+1
            betace(i)=rlim
            call logposldtfp(maxm,ntlr,ntprob,nrec,pce,
     &                       ptf,betace,betatf,y,xce,xtf,
     &                       sigma2,betacepm,precce,
     &                       nobsbc,obsbc,grlim,k)

            do while(gllim.gt.logy)
               llim=llim-0.25d0
               evali=evali+1
               betace(i)=llim
               call logposldtfp(maxm,ntlr,ntprob,nrec,pce,
     &                       ptf,betace,betatf,y,xce,xtf,
     &                       sigma2,betacepm,precce,
     &                       nobsbc,obsbc,gllim,k)
            end do

            do while(grlim.gt.logy)
               rlim=rlim+0.25d0
               betace(i)=rlim
               call logposldtfp(maxm,ntlr,ntprob,nrec,pce,
     &                       ptf,betace,betatf,y,xce,xtf,
     &                       sigma2,betacepm,precce,
     &                       nobsbc,obsbc,grlim,k)
            end do

            xx1=llim+(rlim-llim)*dble(runif())
            betace(i)=xx1
            call logposldtfp(maxm,ntlr,ntprob,nrec,pce,
     &                       ptf,betace,betatf,y,xce,xtf,
     &                       sigma2,betacepm,precce,
     &                       nobsbc,obsbc,gxx1,k)

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

               xx1=llim+(rlim-llim)*dble(runif())
               betace(i)=xx1
               call logposldtfp(maxm,ntlr,ntprob,nrec,pce,
     &                       ptf,betace,betatf,y,xce,xtf,
     &                       sigma2,betacepm,precce,
     &                       nobsbc,obsbc,gxx1,k)
            end do
            betace(i)=xx1

         end do

c++++++++++++++++++++++++++++++++++++++
c+++++++ baseline variance          +++
c++++++++++++++++++++++++++++++++++++++

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

         evali=1
         xx0=sigma2

         call loglikldtfp(maxm,ntlr,ntprob,nrec,pce,ptf,betace,
     &                    betatf,y,xce,xtf,xx0,
     &                    nobsbc,obsbc,loglikn,k)
         if(tau1>0)then
            logpriorn=-(0.5d0*tau1+1.d0)*log(xx0)-0.5d0*tau2/xx0
          else
            logpriorn=-log(xx0)
         end if
         tmp1=loglikn+logpriorn

         uni=runif()
         re=-log(uni)
         logy=tmp1-re

         uwork=dble(runif())*0.05d0
         llim=xx0-uwork
         rlim=xx0+(0.05d0-uwork)

         if(llim.lt.0.00001d0)llim=0.00001d0

         evali=evali+1
         call loglikldtfp(maxm,ntlr,ntprob,nrec,pce,ptf,betace,
     &                    betatf,y,xce,xtf,llim,
     &                    nobsbc,obsbc,loglikn,k)
         if(tau1>0)then
            logpriorn=-(0.5d0*tau1+1.d0)*log(llim)-
     &                  0.5d0*tau2/llim
          else
            logpriorn=-log(llim)
         end if
         gllim=loglikn+logpriorn

         evali=evali+1
         call loglikldtfp(maxm,ntlr,ntprob,nrec,pce,ptf,betace,
     &                    betatf,y,xce,xtf,rlim,
     &                    nobsbc,obsbc,loglikn,k)
         if(tau1>0)then
            logpriorn=-(0.5d0*tau1+1.d0)*log(rlim)-
     &                  0.5d0*tau2/rlim
          else
            logpriorn=-log(rlim)
         end if
         grlim=loglikn+logpriorn

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

            if(llim.lt.0.00001d0)then
               llim=0.00001d0
               gllim=logy-1.d0
              else
               evali=evali+1

               call loglikldtfp(maxm,ntlr,ntprob,nrec,pce,ptf,
     &                          betace,betatf,y,
     &                          xce,xtf,llim,
     &                          nobsbc,obsbc,loglikn,k)
               if(tau1>0)then
                  logpriorn=-(0.5d0*tau1+1.d0)*log(llim)-
     &                        0.5d0*tau2/llim
                 else
                  logpriorn=-log(llim)
               end if
               gllim=loglikn+logpriorn
             end if
         end do

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

            evali=evali+1
            call loglikldtfp(maxm,ntlr,ntprob,nrec,pce,ptf,
     &                       betace,betatf,y,
     &                       xce,xtf,rlim,
     &                       nobsbc,obsbc,loglikn,k)
            if(tau1>0)then
               logpriorn=-(0.5d0*tau1+1.d0)*log(rlim)-
     &                     0.5d0*tau2/rlim
             else
               logpriorn=-log(rlim)
            end if
            grlim=loglikn+logpriorn
         end do

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

         evali=evali+1
         call loglikldtfp(maxm,ntlr,ntprob,nrec,pce,ptf,
     &                    betace,betatf,y,
     &                    xce,xtf,xx1,
     &                    nobsbc,obsbc,loglikn,k)
         if(tau1>0)then
           logpriorn=-(0.5d0*tau1+1.d0)*log(xx1)-
     &                 0.5d0*tau2/xx1
         else
           logpriorn=-log(xx1)
        end if
        gxx1=loglikn+logpriorn

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

           if(llim.lt.0.00001d0)llim=0.00001d0

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

           evali=evali+1

           call loglikldtfp(maxm,ntlr,ntprob,nrec,pce,ptf,
     &                      betace,betatf,y,
     &                      xce,xtf,xx1,
     &                      nobsbc,obsbc,loglikn,k)
           if(tau1>0)then
              logpriorn=-(0.5d0*tau1+1.d0)*log(xx1)-
     &                    0.5d0*tau2/xx1
            else
              logpriorn=-log(xx1)
           end if
           gxx1=loglikn+logpriorn
        end do

        sigma2=xx1

c        call dblepr("sigma2",-1,sigma2,1)

c+++++++++++++++++++++++++++++++++++++
c++++++ tf logistic regressions    +++
c+++++++++++++++++++++++++++++++++++++

        acceptt=0

        i1=1
        do i=2,maxm
           j1=2**(i-1)

           do j=1,j1

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

              k1=i1+j

              do d1=1,ptf
                 do d2=1,ptf
                    c0(d1,d2)=gprior(d1,d2)/
     &                        (alpha*real(i**2))
                 end do
              end do
              ii=(k1-1)*2+1
              jj=(k1-1)*2+2
              n1=nobsbc(ii)
              n2=nobsbc(jj)
              ntot=n1+n2

              if(ntot.gt.0)then

                 call updatelrcoefldtfpss(k1,ii,jj,n1,n2,maxm,
     &                               ntlr,ntprob,
     &                               nrec,ptf,obsbc,betatf,xtf,c0,
     &                               accept,iflagtf,workv2,workm2)

               else
                 accept=1
                 call updatelrcoefldtfp0(k1,maxm,ntlr,ntprob,
     &                                   ptf,betatf,c0,
     &                                   iflagtf,workv2,workv3,
     &                                   workm2,workvh2,workv4)
              end if

              acceptt=acceptt+accept

           end do
           i1=i1+j1
        end do

c+++++++++++++++++++++++++++++++++++++
c++++++ alpha                      +++
c+++++++++++++++++++++++++++++++++++++

        if(a0b0(1)>0)then

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

           i1=1
           tmp1=0.d0

           do i=2,maxm
              j1=2**(i-1)

              do j=1,j1
                 k1=i1+j

                 do d1=1,ptf
                    do d2=1,ptf
                       c0(d1,d2)=gprior(d1,d2)/
     &                        (dble(i**2))
                    end do
                 end do

                 call inverse(c0,ptf,iflagtf)
                 tmp2=0.d0
                 do ll=1,ptf
                    do mm=1,ptf
                       tmp2=tmp2+betatf(k1,ll)*c0(ll,mm)*betatf(k1,mm)
                    end do
                 end do
                 tmp1=tmp1+tmp2
              end do
              i1=i1+j1
           end do
           tmp1=0.5d0*tmp1
           alpha=rgamma(a0b0(1)+dble(ptf)*dble(ntlr-1),a0b0(2)+tmp1)

c           call dblepr("alpha",-1,alpha,1)
        end if

c++++++++++++++++++++++++++++++++
c++++++ save samples
c++++++++++++++++++++++++++++++++

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

c++++++++++++ regression coefficient information

              do i=1,pce
                 thetasave(isave,i)=betace(i)
              end do

c++++++++++++ centering variance

              thetasave(isave,pce+1)=sigma2

c++++++++++++ precision parameter

              thetasave(isave,pce+2)=alpha

c++++++++++++ tailfree regression coefficients

              mm=0
              do i=2,ntlr
                 do j=1,ptf
                    mm=mm+1
                    randsave(isave,mm)=betatf(i,j)
                 end do
              end do

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

              call densldtfp(maxm,ngrid,ntlr,ntprob,npredden,
     &                       pce,ptf,betace,
     &                       betatf,grid,xcepred,xtfpred,
     &                       sigma2,densl,densm,k)

              do i=1,npredden
                 write(1) (densl(i,j),j=1,ngrid)
              end do

c++++++++++++ survival function

              do i=1,npredden
                 do j=1,ngrid
                    tmp1=grid(j)
                    call cdfldtfp(i,tmp1,maxm,ntlr,npredden,
     &                            pce,ptf,betace,betatf,
     &                            sigma2,xtfpred,xcepred,
     &                            tmp3,k,prob,probc)
                    survmm(i,j)=survmm(i,j)+1.d0-tmp3
                    survml(i,j)=1.d0-tmp3
                 end do
                 write(2) (survml(i,j),j=1,ngrid)
              end do

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

              do i=1,nrec

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

                 call ldensldtfp(y(i),i,maxm,nrec,ntlr,ntprob,
     &                           pce,betace,xce,
     &                           ptf,betatf,xtf,
     &                           sigma2,tmp2,k)

                 cpo(i,1)=cpo(i,1)+1.d0/exp(tmp2)
                 cpo(i,2)=cpo(i,2)+exp(tmp2)
              end do

c++++++++++++ quantiles

              call quantileldtfp(maxm,ntlr,npredmed,pce,ptf,
     &                           betace,betatf,
     &                           sigma2,xtfpredm,xcepredm,
     &                           qmm,qml,k,prob,probc,quans)

              write(3) (qml(j,1),j=1,npredmed)
              write(4) (qml(j,2),j=1,npredmed)
              write(5) (qml(j,3),j=1,npredmed)

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

      end do

      do i=1,npredden
         do j=1,ngrid
            densm(i,j)=densm(i,j)/dble(nsave)
            survmm(i,j)=survmm(i,j)/dble(nsave)
         end do
      end do

      do i=1,npredmed
         do j=1,3
            qmm(i,j)=qmm(i,j)/dble(nsave)
         end do
      end do

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

      close(unit=1)
      close(unit=2)
      close(unit=3)
      close(unit=4)
      close(unit=5)

      if(cband.eq.1)then

      call hpddensregdtfp(nsave,npredden,ngrid,worksam,
     &                    worksam2,fs,densl,densu,tband)

      call hpddensregdtfps(nsave,npredden,ngrid,worksam,
     &                     worksam2,fs,survml,survmu,tband)

      call hpdldtfpq1(nsave,npredmed,worksam,worksam3,
     &                qml,qmu,tband)

      call hpdldtfpq2(nsave,npredmed,worksam,worksam3,
     &                qml,qmu,tband)

      call hpdldtfpq3(nsave,npredmed,worksam,worksam3,
     &                qml,qmu,tband)

      end if

      return
      end


!this program is the kernel for an optical propagation program.
!it does a series of 2d ffts followed by a multiplication.
!it is modeled after the AFWL program HELP or High Energy
!Laser Propagation.
!
!it does the 2d fft by first doing a collection of 1d ffts
!then a transpose followed by a second collection of 1d ffts.
!
!the sections of the program that are commented out represent
!different ways of doing the operations.  the most interesting
!addition is using the using the subroutine shuff to generate
!a nonuniform ordering for accessing the array.

!the routines four1 was taken from the book
!"numerical recipes in fortran, 1st addition."
!however, the authors of that book derived their routine
!from the routine fourn that was in the AFWL program HELP.
!the original routine, fourn, contained many additional
!options

!disclaimer:  for a production code you would most likely
!use a vendor supplied library to do the fft instead of a
!hand written one.

module ccm_numz
! basic real types
    integer, parameter:: b8 = selected_real_kind(10)
contains
     function ccm_time()
        implicit none
        integer i
        integer :: ccm_start_time(8) = (/(-100,i=1,8)/)
        real(b8) :: ccm_time,tmp
        integer,parameter :: norm(13)=(/  &
               0, 2678400, 5097600, 7776000,10368000,13046400,&
        15638400,18316800,20995200,23587200,26265600,28857600,31536000/)
        integer,parameter :: leap(13)=(/  &
               0, 2678400, 5184000, 7862400,10454400,13132800,&
        15724800,18403200,21081600,23673600,26352000,28944000,31622400/)
        integer :: values(8),m,sec
        save
        call date_and_time(values=values)
        if(mod(values(1),4) .eq. 0)then
           m=leap(values(2))
        else
           m=norm(values(2))
        endif
        sec=((values(3)*24+values(5))*60+values(6))*60+values(7)
        tmp=real(m,b8)+real(sec,b8)+real(values(8),b8)/1000.0_b8
        !write(*,*)"vals ",values
        if(values(1) .ne. ccm_start_time(1))then
            if(mod(ccm_start_time(1),4) .eq. 0)then
                tmp=tmp+real(leap(13),b8)
            else
                tmp=tmp+real(norm(13),b8)
            endif
        endif
        ccm_time=tmp
    end function
end module ccm_numz

program two_d_fft
        use ccm_numz
        implicit none
!       integer size
        integer,parameter:: size=1024
!        integer omp_get_max_threads
        integer i,j,k,ijk,isign,iseed
        real(b8),allocatable:: x(:)
        integer, allocatable:: index(:)
        complex(b8), allocatable:: a(:,:)
!        complex(b8) :: a(size,size)
!        complex(b8), allocatable:: temp(:)
        complex(b8) tmp
        complex(b8) factor
        real(b8) gen,fft1,fft2,trans,totf,fact
        real(b8) t0,t1,t2,t3,t4,t5
        integer OMP_GET_MAX_THREADS
        interface
            subroutine shuff(index,m,n)
              dimension index(:)
              integer m,n
            end subroutine
        end interface
        factor=size
        factor=1.0_b8/(factor)
        iseed=-12345
        isign=1
        gen=0
        fft1=0
        fft2=0
        trans=0
        totf=0
        fact=0
!       read(12,*)size
        allocate(a(size,size))
        allocate(x(size),index(size))
        call shuff(index,size,8)
!       dummy=ran1(iseed)
!       write(*,*)"dummy=",dummy
        t0=ccm_time ()
        do j=1,size
           call random_number(x)
           do i=1,size
                a(i,j)=cmplx(x(i),0.0_b8)
           enddo
        enddo
        write(*,'(("(",g20.10,",",g20.10,")"))')a(size/2+1,size-2)

!        do 10 ijk=1,20  ! change to 4 to run faster
        do 10 ijk=1,20
            t1=ccm_time ()
!$OMP PARALLEL DO SCHEDULE (RUNTIME)
            do i=1,size
                 call four1(a(:,i),size,isign)
                !call four1(a(i,:),size,isign)
            enddo
!$OMP END PARALLEL DO
            t2=ccm_time ()
!$OMP PARALLEL DO SCHEDULE (RUNTIME) PRIVATE(i,j,k,tmp)
            do k=1,size
                i=k
! i=index(k)
                do j=i,size
! tmp=a(j,i)
! a(j,i)=a(i,j)
! a(i,j)=tmp
                    tmp=a(i,j)
                    a(i,j)=a(j,i)
                    a(j,i)=tmp
                enddo
! j=i
! temp(j:size)=a(i,j:size)
! a(i,j:size)=a(j:size,i)
! a(j:size,i)=temp(j:size)
            enddo
!$OMP END PARALLEL DO
            t3=ccm_time ()
!$OMP PARALLEL DO SCHEDULE (RUNTIME)
            do i=1,size
                 call four1(a(:,i),size,isign)
                !call four1(a(i,:),size,isign)
            enddo
!$OMP END PARALLEL DO
            t4=ccm_time ()
!$OMP PARALLEL DO SCHEDULE (RUNTIME)
            do j=1,size
            do i=1,size
                  a(i,j)=factor*a(i,j)
               enddo
            enddo
!$OMP END PARALLEL DO
            t5=ccm_time ()
            gen=gen+t1-t0
            fft1=fft1+t2-t1
            fft2=fft2+t4-t3
            trans=trans+t3-t2
            totf=totf+t5-t1
            fact=fact+t5-t4
            isign=isign*(-1)
            write(*,'(i3)',advance="no")ijk
    10  continue
        write(*,*)
        write(*,'(("(",g20.10,",",g20.10,")"))')a(size/2+1,size-2)
        write(*,*)"number of  transforms",ijk-1
        !write(*,'("generation time= ",f7.1)')gen
        write(*,'("      fft1 time= ",f9.4)')fft1
        write(*,'(" transpose time= ",f9.4)')trans
        write(*,'("      fft2 time= ",f9.4)')fft2
        write(*,'("   scaling time= ",f9.4)')fact
        write(*,'("    total time = ",f9.4)',advance="no")totf
        write(*,'(" for matrix of size",i6)')size
        write(*,*)"THREADS   = ",OMP_GET_MAX_THREADS()
        stop
end program two_d_fft

      subroutine four1(data,nn,isign)
      use ccm_numz
      implicit none
      integer i,j,isign,nn,n,m,mmax,istep
      real(b8), parameter :: two_pi = 6.283185307179586477_b8
      real(b8) wr,wi,wpr,wpi,wtemp,theta,tempr,tempi
      real(b8) data(16384)
      n=2*nn
      j=1
      do 11 i=1,n,2
        if(j.gt.i)then
          tempr=data(j)
          tempi=data(j+1)
          data(j)=data(i)
          data(j+1)=data(i+1)
          data(i)=tempr
          data(i+1)=tempi
        endif
        m=n/2
1       if ((m.ge.2).and.(j.gt.m)) then
          j=j-m
          m=m/2
        go to 1
        endif
        j=j+m
11    continue
      mmax=2
2     if (n.gt.mmax) then
        istep=2*mmax
        theta=two_pi/(isign*mmax)
        wpr=-2.0_b8*sin(0.5_b8*theta)**2
        wpi=sin(theta)
        wr=1.0_b8
        wi=0.0_b8
        do 13 m=1,mmax,2
          do 12 i=m,n,istep
            j=i+mmax
            tempr=(wr)*data(j)-(wi)*data(j+1)
            tempi=(wr)*data(j+1)+(wi)*data(j)
            data(j)=data(i)-tempr
            data(j+1)=data(i+1)-tempi
            data(i)=data(i)+tempr
            data(i+1)=data(i+1)+tempi
12        continue
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
13      continue
        mmax=istep
      go to 2
      endif
      return
      end

subroutine shuff(index,m,n)
    integer tens,ones
    dimension index(:)
    tens=n
    ones=1
    j=0
    k=1
    do while (j < m)
       j=j+1
       if(k.gt. m)then
         write(*,*)k,m
         stop
       endif
       index(k)=j
       k=k+tens
       if(k .gt. m)then
         ones=ones+1
         k=ones
       endif
    enddo
end subroutine shuff


Real Function omega(srt)
  Save
  pmass = 0.9383
  omass = 0.782
  tomega = 0.0084
  omega = 0.00000001
  If (srt<=2.68) Return
  esmin = 2.*0.9383 + omass - tomega/2.
  es = srt
  omega = 0.36*(es-esmin)/(1.25+(es-esmin)**2)
  Return
End Function omega


      DOUBLE PRECISION FUNCTION DT_DGAMRN(Alam,Eta)

C***********************************************************************
C Sampling from Gamma-distribution.                                    *
C       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
C Processed by S. Roesler, 6.5.95                                      *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION Alam , DT_RNDM , Eta , f , ONE , r , TINY9 , y ,
     &                 yyy , z , ZERO
      INTEGER i , n , ncou
      SAVE
      PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)

      ncou = 0
      n = INT(Eta)
      f = Eta - DBLE(n)
      IF ( f.EQ.ZERO ) THEN
         y = 0.0D0
      ELSE
 50      r = DT_RNDM(f)
         ncou = ncou + 1
         IF ( ncou.GE.11 ) THEN
            y = 0.0D0
         ELSE
            IF ( r.LT.f/(f+2.71828D0) ) THEN
               y = ONE - LOG(DT_RNDM(y)+TINY9)
               IF ( DT_RNDM(r).GT.y**(f-ONE) ) GOTO 50
            ELSE
               yyy = LOG(DT_RNDM(r)+TINY9)/f
               IF ( ABS(yyy).GT.50.0D0 ) THEN
                  y = 0.0D0
                  GOTO 100
               ELSE
                  y = EXP(yyy)
                  IF ( LOG(DT_RNDM(y)+TINY9).GT.-y ) GOTO 50
               END IF
            END IF
            IF ( n.EQ.0 ) GOTO 200
         END IF
      END IF
 100  z = 1.0D0
      DO i = 1 , n
         z = z*DT_RNDM(z)
      END DO
      y = y - LOG(z+TINY9)
 200  DT_DGAMRN = y/Alam

      END FUNCTION


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine sim2sd                         *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 1.4
!  Written by Gordon A. Fenton, DalTech, Nov 17, 1999
!  Latest Update: Oct 18, 2002
!
!  PURPOSE  simulates soil property fields for RSLOPE2D
!
!  DESCRIPTION
!  This routine simulates up to 6 soil property fields (cohesion, friction
!  angle, dilation angle, unit weight, elastic modulus, and Poisson's ratio
!  which are possibly intercorrelated. Individual fields are generated as
!  standard Gaussian random fields using the 2-D Local Average Subdivision
!  (LAS) algorithm. These fields are then combined to produce correlated
!  standard Gaussian fields using the Covariance Matrix Decomposition
!  approach. Finally the individual fields are transformed so that they
!  have the desired marginal distributions. These transformations are as
!  follows;
!
!	P(x,y) = mean + sd*G(x,y)		if normally distributed
!
!	P(x,y) = exp{ log-mean + log-sd*G(x,y) }if lognormally distributed
!
!	P(x,y) = a + 0.5*(b-a)*[ 1 + tanh((m + s*G(x,y))/2*pi) ]
!						if bounded
!
!  where P(x,y) is the desired random field (one of the soil properties)
!  G(x,y) is one of the standard correlated Gaussian fields, and (mean,sd)
!  and (a,b,m,s) are parameters of the distributions.
!
!  If the property is deterministic, the entire field is simply set to the
!  mean.
!
!  ARGUMENTS
!
!   istat	unit number connected to a file to which the input data is to
!		echoed if echo is true. (input)
!
!   iterm	unit number connected to the screen. If verbos is true, then
!		error and warning messages are also sent to the screen. (input)
!
!  verbos	logical flag which is true if error, warning, and progress
!		messages are allowed to be sent to the screen. (input)
!
!    cfld	real array of size at least (nrfx x nrfy) which will contain
!		the (optionally) random (locally averaged) cohesion field.
!		(output)
!
!  phifld	real array of size at least (nrfx x nrfy) which will contain
!		the (optionally) random (locally averaged) friction angle
!		field. Note that phifld may optionally contain the tan(phi)
!		field, as specified in the data file read by readsd. (output)
!
!  psifld	real array of size at least (nrfx x nrfy) which will contain
!		the (optionally) random (locally averaged) dilation angle
!		field. (output)
!
!  gamfld	real array of size at least (nrfx x nrfy) which will contain
!		the (optionally) random (locally averaged) unit weight field.
!		(output)
!
!    efld	real array of size at least (nrfx x nrfy) which will contain
!		the (optionally) random (locally averaged) elastic modulus
!		field. (output)
!
!    vfld	real array of size at least (nrfx x nrfy) which will contain
!		the (optionally) random (locally averaged) poisson's ratio
!		field. (output)
!
!	c	real vector of length at least 7 containing the parameters of
!		the soil cohesion. Notably,
!		   c(1) = mean cohesion,
!		   c(2) = cohesion standard deviation,
!		   c(3) = cohesion distribution type;
!			  = 0.0 if cohesion is deterministic (at mean value)
!			  = 1.0 if cohesion is normally distributed
!			  = 2.0 if cohesion is lognormally distributed (logn)
!			  = 3.0 if cohesion is bounded
!		   c(4) = lower bound (bounded), or mean of log-cohesion (logn)
!		   c(5) = upper bound (bounded), or sd of log-cohesion (logn)
!		   c(6) = m parameter (if bounded)
!		   c(7) = s parameter (if bounded)
!		If c is bounded, then c(1) and c(2) are ignored and the
!		parameters c(4) through c(7) completely describe the
!		distribution. (input)
!
!     phi	real vector of length at least 7 containing the parameters of
!		soil friction angle. See `c' for what the various elements of
!		phi contain. (input)
!
!     psi	real vector of length at least 7 containing the parameters of
!		soil dilation angle. See `c' for what the various elements of
!		psi contain. (input)
!
!     gam	real vector of length at least 7 containing the parameters of
!		soil unit weight. See `c' for what the various elements of
!		gam contain. (input)
!
!	e	real vector of length at least 7 containing the parameters of
!		soil elastic modulus. See `c' for what the various elements of
!		e contain. (input)
!
!	v	real vector of length at least 7 containing the parameters of
!		soil Poisson ratio. See `c' for what the various elements of
!		v contain. (input)
!
!	R	real array of size at least 6 x 6 which, on output, will
!		contain the correlation matrix between the 6 (possibly)
!		random soil properties.  Indexing into R is as follows;
!		  1 = cohesion
!		  2 = friction angle
!		  3 = dilation angle
!		  4 = unit weight
!		  5 = elastic modulus
!		  6 = Poisson's ratio
!		(input)
!
!   lxfld	logical flag which is true if more than one soil property
!		are cross-correlated. That is, if all soil properties are
!		independent, then lxfld is false. (input)
!
!     thx	real value giving the x-direction scale of fluctuation
!		(or, at least, this is a parameter of the covariance function).
!		(input)
!
!     thy	real value giving the y-direction scale of fluctuation
!		(or, at least, this is another parameter of the covariance
!		function). (input)
!
!     nrfx	integer giving the number of elements describing the soil
!		mass in the x-direction (horizontally). (input)
!
!     nrfy	integer giving the number of elements describing the soil
!		mass in the y-direction (vertically). (input)
!
!      dx	real value giving the physical size of an element in the
!		x-direction. (input)
!
!      dy	real value giving the physical size of an element in the
!		y-direction. (input)
!
!  dmpfld	logical flag which is true if a random field is to be
!		plotted to *.fld. (input)
!
!    nfld	integer giving the realization number of the random field
!		which is to be plotted to *.fld. (input)
!
!    jfld	integer denoting which random field is to be plotted;
!		 = 1 for the cohesion (c) field,
!		 = 2 for the friction angle (phi) field,
!		 = 3 for the dilation angle (psi) field,
!		 = 4 for the unit weight (gam) field,
!		 = 5 for the elastic modulus (psi) field,
!		 = 6 for the poisson ratio (psi) field,
!		(input)
!
!    ifld	unit number connected to the file to which the random field
!		plot is to be written in the event that dmpfld is true.
!		(input)
!
!     job	character string containing the main title of the run.
!		(input)
!
!    sub1	character string, which on output will contain the first
!		subtitle for this run. (output)
!
!    sub2	character string, which on output will contain the second
!		subtitle for this run. (output)
!
!  varfnc	character string containing the name of the covariance
!		function controlling the random fields. Possible covariance
!		functions are
!		`dlavx2' - 2-D exponentially decaying (Markov) model
!			   requires X- and Y-direction scales of fluctuation
!		`dlafr2' - 2-D isotropic fractional Gaussian noise model
!			   requires (H,delta) as parameters. In this case,
!			   thx is H, and delta is the minimum element
!			   dimension.
!		`dlsep2' - 2-D separable (1D x 1D) Markov model
!			   requires X- and Y-direction scales of fluctuation
!		`dlsfr2' - 2-D separable fractional Gaussian noise model
!			   requires (H_x,H_y,delta) as parameters. In this
!			   case, thx is H_x, thy is H_y, and delta is the
!			   minimum element dimension.
!		`dlspx2' - 2-D separable Gaussian decaying model
!			   requires X- and Y-direction scales of fluctuation
!		(input)
!
!   kseed	integer giving the seed to be used to initialize the
!		pseudo-random number generator. Subsequent runs using
!		the same seed will result in the same sequence of random
!		numbers. (input)
!
!   debug	logical flag which is true if debug information is to be
!		sent to the *.stt file. (input)
!
!  ltanfi	logical flag which is true if the phifld array contains the
!		tan(phi) field, rather than the phi field, where phi is the
!		friction angle. (input)
!
!  REVISION HISTORY:
!  1.1	the LAS generator now integrates the covariance function directly,
!	rather than using the variance function, see lvarfn (May 26/00)
!  1.2	eliminated lvarfn from common /dparam/ (May 26/01)
!  1.21	fixed truncated documentation above (Mar 1/02)
!  1.3	added ltanfi flag (used for title to pltfld) (Jun 13/02)
!  1.31	output error message if covariance function is unknown (Sep 9/02)
!  1.4	added data definition for twopi! (Oct 18/02)
!-----------------------------------------------------------------------
      subroutine sim2sd1(istat,iterm,verbos,cfld,phifld,psifld,gamfld,     &
                       efld,vfld,c,phi,psi,gam,e,v,R,lxfld,thx,thy,       &
                       nrfx,nrfy,dx,dy,dmpfld,nfld,jfld,ifld,job,sub1,    &
                       sub2,varfnc,kseed,debug,ltanfi)

      real cfld(nrfx,*), phifld(nrfx,*), psifld(nrfx,*)
      real gamfld(nrfx,*), efld(nrfx,*), vfld(nrfx,*)
      real c(*), phi(*), psi(*), gam(*), e(*), v(*), R(6,*), thx, thy
      integer nrfx, nrfy, nfld, ifld
      character*(*) job, sub1, sub2, varfnc
      logical verbos, dmpfld, debug, liid, shofld, lxfld, ltanfi
      real*8 dvar, dpb, dthx, dthy, dthz, ddx, ddy
      real*8 dlavx2, dlsep2, dlspx2, dlafr2, dlsfr2
      real*8 dmin1, dble
      save XL, YL, ienter, liid
      external dlavx2, dlsep2, dlspx2, dlafr2, dlsfr2
      common/dparam/ dvar, dpb, dthx, dthy, dthz
      data zero/0.0/, half/0.5/, one/1.0/, onept5/1.5/, twopt5/2.5/
      data twopi/6.2831853071795864769/
      data ienter/0/

   1  format(a,a)

!-------------------------------------- initialize ---------------------
!					compute required field size (once)
      ienter = ienter + 1
      if( ienter .eq. 1 ) then
         liid   = ((thx .eq. zero) .and. (thy .eq. zero))
         XL     = float(nrfx)*dx
         YL     = float(nrfy)*dy

         if( debug ) write(istat,1)'SIM2SD: setting field parameters...'

         if( .not. liid ) then
!						set variance fnc parameters
            dvar = 1.d0
            dthx = thx
            dthy = thy

            if( varfnc .eq. 'dlafr2' .or. varfnc .eq. 'dlsfr2' ) then
               dpb = dx
               if( dy .lt. dx ) dpb = dy
            endif
!						initialize LAS2G
            if( varfnc .eq. 'dlavx2' ) then
               call las2g(cfld,nrfx,nrfy,XL,YL,dlavx2,kseed,-1,istat)
            elseif( varfnc .eq. 'dlsep2' ) then
               call las2g(cfld,nrfx,nrfy,XL,YL,dlsep2,kseed,-1,istat)
            elseif( varfnc .eq. 'dlspx2' ) then
               call las2g(cfld,nrfx,nrfy,XL,YL,dlspx2,kseed,-1,istat)
            elseif( varfnc .eq. 'dlafr2' ) then
               call las2g(cfld,nrfx,nrfy,XL,YL,dlafr2,kseed,-1,istat)
            elseif( varfnc .eq. 'dlsfr2' ) then
               call las2g(cfld,nrfx,nrfy,XL,YL,dlsfr2,kseed,-1,istat)
            else
               if( verbos ) then
                  write(iterm,1)                                          &
                 '*** Error: unknown variance function name: ', varfnc
               endif
               write(istat,1)                                             &
                 '*** Error: unknown variance function name: ', varfnc
               stop
            endif
         endif
      endif
!					are we going to plot anything?
      shofld = dmpfld .and. (nfld .eq. ienter)

!					now produce 5 standard normal fields
!					for cohesion...
      if( c(3) .lt. half ) then			! cohesion is deterministic
         do 10 j = 1, nrfy
         do 10 i = 1, nrfx
            cfld(i,j) = zero			! we'll add mean back on later
  10     continue
      elseif( liid ) then			! white noise field
         do 20 j = 1, nrfy
         do 20 i = 1, nrfx
            cfld(i,j) = gausv(one)
  20     continue
      else					! generate standard normal RF
         if( varfnc .eq. 'dlavx2' ) then
            call las2g(cfld,nrfx,nrfy,XL,YL,dlavx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsep2' ) then
            call las2g(cfld,nrfx,nrfy,XL,YL,dlsep2,kseed,0,istat)
         elseif( varfnc .eq. 'dlspx2' ) then
            call las2g(cfld,nrfx,nrfy,XL,YL,dlspx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlafr2' ) then
            call las2g(cfld,nrfx,nrfy,XL,YL,dlafr2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr2' ) then
            call las2g(cfld,nrfx,nrfy,XL,YL,dlsfr2,kseed,0,istat)
         endif
      endif
!					for friction angle...
      if( phi(3) .lt. half ) then		! friction is deterministic
         do 30 j = 1, nrfy
         do 30 i = 1, nrfx
            phifld(i,j) = zero			! we'll add mean back on later
  30     continue
      elseif( liid ) then			! white noise field
         do 40 j = 1, nrfy
         do 40 i = 1, nrfx
            phifld(i,j) = gausv(one)
  40     continue
      else					! generate standard normal RF
         if( varfnc .eq. 'dlavx2' ) then
            call las2g(phifld,nrfx,nrfy,XL,YL,dlavx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsep2' ) then
            call las2g(phifld,nrfx,nrfy,XL,YL,dlsep2,kseed,0,istat)
         elseif( varfnc .eq. 'dlspx2' ) then
            call las2g(phifld,nrfx,nrfy,XL,YL,dlspx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlafr2' ) then
            call las2g(phifld,nrfx,nrfy,XL,YL,dlafr2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr2' ) then
            call las2g(phifld,nrfx,nrfy,XL,YL,dlsfr2,kseed,0,istat)
         endif
      endif
!					for dilation angle...
      if( psi(3) .lt. half ) then		! dilation is deterministic
         do 50 j = 1, nrfy
         do 50 i = 1, nrfx
            psifld(i,j) = zero			! we'll add mean back on later
  50     continue
      elseif( liid ) then			! white noise field
         do 60 j = 1, nrfy
         do 60 i = 1, nrfx
            psifld(i,j) = gausv(one)
  60     continue
      else					! generate standard normal RF
         if( varfnc .eq. 'dlavx2' ) then
            call las2g(psifld,nrfx,nrfy,XL,YL,dlavx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsep2' ) then
            call las2g(psifld,nrfx,nrfy,XL,YL,dlsep2,kseed,0,istat)
         elseif( varfnc .eq. 'dlspx2' ) then
            call las2g(psifld,nrfx,nrfy,XL,YL,dlspx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlafr2' ) then
            call las2g(psifld,nrfx,nrfy,XL,YL,dlafr2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr2' ) then
            call las2g(psifld,nrfx,nrfy,XL,YL,dlsfr2,kseed,0,istat)
         endif
      endif
!					for unit weight...
      if( gam(3) .lt. half ) then		! unit weight is deterministic
         do 62 j = 1, nrfy
         do 62 i = 1, nrfx
            gamfld(i,j) = zero			! we'll add mean back on later
  62     continue
      elseif( liid ) then			! white noise field
         do 64 j = 1, nrfy
         do 64 i = 1, nrfx
            gamfld(i,j) = gausv(one)
  64     continue
      else					! generate standard normal RF
         if( varfnc .eq. 'dlavx2' ) then
            call las2g(gamfld,nrfx,nrfy,XL,YL,dlavx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsep2' ) then
            call las2g(gamfld,nrfx,nrfy,XL,YL,dlsep2,kseed,0,istat)
         elseif( varfnc .eq. 'dlspx2' ) then
            call las2g(gamfld,nrfx,nrfy,XL,YL,dlspx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlafr2' ) then
            call las2g(gamfld,nrfx,nrfy,XL,YL,dlafr2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr2' ) then
            call las2g(gamfld,nrfx,nrfy,XL,YL,dlsfr2,kseed,0,istat)
         endif
      endif
!					for elastic modulus...
      if( e(3) .lt. half ) then		! modulus is deterministic
         do 70 j = 1, nrfy
         do 70 i = 1, nrfx
            efld(i,j) = zero			! we'll add mean back on later
  70     continue
      elseif( liid ) then			! white noise field
         do 80 j = 1, nrfy
         do 80 i = 1, nrfx
            efld(i,j) = gausv(one)
  80     continue
      else					! generate standard normal RF
         if( varfnc .eq. 'dlavx2' ) then
            call las2g(efld,nrfx,nrfy,XL,YL,dlavx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsep2' ) then
            call las2g(efld,nrfx,nrfy,XL,YL,dlsep2,kseed,0,istat)
         elseif( varfnc .eq. 'dlspx2' ) then
            call las2g(efld,nrfx,nrfy,XL,YL,dlspx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlafr2' ) then
            call las2g(efld,nrfx,nrfy,XL,YL,dlafr2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr2' ) then
            call las2g(efld,nrfx,nrfy,XL,YL,dlsfr2,kseed,0,istat)
         endif
      endif
!					for Poisson's ratio...
      if( v(3) .lt. half ) then		! ratio is deterministic
         do 90 j = 1, nrfy
         do 90 i = 1, nrfx
            vfld(i,j) = zero			! we'll add mean back on later
  90     continue
      elseif( liid ) then			! white noise field
         do 100 j = 1, nrfy
         do 100 i = 1, nrfx
            vfld(i,j) = gausv(one)
 100     continue
      else					! generate standard normal RF
         if( varfnc .eq. 'dlavx2' ) then
            call las2g(vfld,nrfx,nrfy,XL,YL,dlavx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsep2' ) then
            call las2g(vfld,nrfx,nrfy,XL,YL,dlsep2,kseed,0,istat)
         elseif( varfnc .eq. 'dlspx2' ) then
            call las2g(vfld,nrfx,nrfy,XL,YL,dlspx2,kseed,0,istat)
         elseif( varfnc .eq. 'dlafr2' ) then
            call las2g(vfld,nrfx,nrfy,XL,YL,dlafr2,kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr2' ) then
            call las2g(vfld,nrfx,nrfy,XL,YL,dlsfr2,kseed,0,istat)
         endif
      endif
!					combine for correlated fields...
      if( lxfld ) then
         do 110 j = 1, nrfy
         do 110 i = 1, nrfx
            vfld(i,j)   = R(1,6)*cfld(i,j)   + R(2,6)*phifld(i,j)         &
                       + R(3,6)*psifld(i,j) + R(4,6)*gamfld(i,j)          &
                       + R(5,6)*efld(i,j)   + R(6,6)*vfld(i,j)
            efld(i,j)   = R(1,5)*cfld(i,j)   + R(2,5)*phifld(i,j)         &
                       + R(3,5)*psifld(i,j) + R(4,5)*gamfld(i,j)          &
                       + R(5,5)*efld(i,j)
            gamfld(i,j) = R(1,4)*cfld(i,j)   + R(2,4)*phifld(i,j)         &
                       + R(3,4)*psifld(i,j) + R(4,4)*gamfld(i,j)
            psifld(i,j) = R(1,3)*cfld(i,j)   + R(2,3)*phifld(i,j)         &
                       + R(3,3)*psifld(i,j)
            phifld(i,j) = R(1,2)*cfld(i,j)   + R(2,2)*phifld(i,j)
 110     continue
      endif
!					plot the random field?
      if( shofld ) then
         if( jfld .eq. 1 ) then
            call pltfld( job, sub1, sub2, cfld, nrfx,nrfx,nrfy,XL,YL,     &
                     '(Underlying) Cohesion Field', ifld )
         elseif( jfld .eq. 2 ) then
            if( ltanfi ) then
               call pltfld( job,sub1,sub2,phifld,nrfx,nrfx,nrfy,XL,YL,    &
                        '(Underlying) Friction Angle Field', ifld )
            else
               call pltfld( job,sub1,sub2,phifld,nrfx,nrfx,nrfy,XL,YL,    &
                        '(Underlying) tan(Friction Angle) Field',ifld)
            endif
         elseif( jfld .eq. 3 ) then
            call pltfld( job, sub1, sub2, psifld,nrfx,nrfx,nrfy,XL,YL,    &
                     '(Underlying) Dilation Angle Field', ifld )
         elseif( jfld .eq. 4 ) then
            call pltfld( job, sub1, sub2, gamfld,nrfx,nrfx,nrfy,XL,YL,    &
                     '(Underlying) Unit Weight Field', ifld )
         elseif( jfld .eq. 5 ) then
            call pltfld( job, sub1, sub2, efld,nrfx,nrfx,nrfy,XL,YL,      &
                     '(Underlying) Elastic Modulus Field', ifld )
         elseif( jfld .eq. 6 ) then
            call pltfld( job, sub1, sub2, vfld,nrfx,nrfx,nrfy,XL,YL,      &
                     '(Underlying) Poisson''s Ratio Field', ifld )
         endif
      endif
!					convert to final fields
!					for cohesion...
      if( c(3) .lt. half ) then				! deterministic
         do 120 j = 1, nrfy
         do 120 i = 1, nrfx
            cfld(i,j) = c(1)
 120     continue
      elseif( c(3) .lt. onept5 ) then			! normal
         do 130 j = 1, nrfy
         do 130 i = 1, nrfx
            cfld(i,j) = c(1) + c(2)*cfld(i,j)
 130     continue
      elseif( c(3) .lt. twopt5 ) then			! lognormal
         do 140 j = 1, nrfy
         do 140 i = 1, nrfx
            cfld(i,j) = exp( c(4) + c(5)*cfld(i,j) )
 140     continue
      else						! bounded
         do 150 j = 1, nrfy
         do 150 i = 1, nrfx
            cfld(i,j) = c(4) + half*(c(5)-c(4))                           &
               *( one + tanh((c(6)+c(7)*cfld(i,j))/twopi) )
 150     continue
      endif
!					for friction angle...
      if( phi(3) .lt. half ) then			! deterministic
         do 160 j = 1, nrfy
         do 160 i = 1, nrfx
            phifld(i,j) = phi(1)
 160     continue
      elseif( phi(3) .lt. onept5 ) then			! normal
         do 170 j = 1, nrfy
         do 170 i = 1, nrfx
            phifld(i,j) = phi(1) + phi(2)*phifld(i,j)
 170     continue
      elseif( phi(3) .lt. twopt5 ) then			! lognormal
         do 180 j = 1, nrfy
         do 180 i = 1, nrfx
            phifld(i,j) = exp( phi(4) + phi(5)*phifld(i,j) )
 180     continue
      else						! bounded
         do 190 j = 1, nrfy
         do 190 i = 1, nrfx
            phifld(i,j) = phi(4) + half*(phi(5)-phi(4))                   &
                     *( one + tanh((phi(6)+phi(7)*phifld(i,j))/twopi) )
 190     continue
      endif
!					for dilation angle...
      if( psi(3) .lt. half ) then			! deterministic
         do 200 j = 1, nrfy
         do 200 i = 1, nrfx
            psifld(i,j) = psi(1)
 200     continue
      elseif( psi(3) .lt. onept5 ) then			! normal
         do 210 j = 1, nrfy
         do 210 i = 1, nrfx
            psifld(i,j) = psi(1) + psi(2)*psifld(i,j)
 210     continue
      elseif( psi(3) .lt. twopt5 ) then			! lognormal
         do 220 j = 1, nrfy
         do 220 i = 1, nrfx
            psifld(i,j) = exp( psi(4) + psi(5)*psifld(i,j) )
 220     continue
      else						! bounded
         do 230 j = 1, nrfy
         do 230 i = 1, nrfx
            psifld(i,j) = psi(4) + half*(psi(5)-psi(4))                   &
                     *( one + tanh((psi(6)+psi(7)*psifld(i,j))/twopi) )
 230     continue
      endif
!					for unit weight...
      if( gam(3) .lt. half ) then			! deterministic
         do 232 j = 1, nrfy
         do 232 i = 1, nrfx
            gamfld(i,j) = gam(1)
 232     continue
      elseif( gam(3) .lt. onept5 ) then			! normal
         do 234 j = 1, nrfy
         do 234 i = 1, nrfx
            gamfld(i,j) = gam(1) + gam(2)*gamfld(i,j)
 234     continue
      elseif( gam(3) .lt. twopt5 ) then			! lognormal
         do 236 j = 1, nrfy
         do 236 i = 1, nrfx
            gamfld(i,j) = exp( gam(4) + gam(5)*gamfld(i,j) )
 236     continue
      else						! bounded
         do 238 j = 1, nrfy
         do 238 i = 1, nrfx
            gamfld(i,j) = gam(4) + half*(gam(5)-gam(4))                   &
                     *( one + tanh((gam(6)+gam(7)*gamfld(i,j))/twopi) )
 238     continue
      endif
!					for elastic modulus...
      if( e(3) .lt. half ) then				! deterministic
         do 240 j = 1, nrfy
         do 240 i = 1, nrfx
            efld(i,j) = e(1)
 240     continue
      elseif( e(3) .lt. onept5 ) then			! normal
         do 250 j = 1, nrfy
         do 250 i = 1, nrfx
            efld(i,j) = e(1) + e(2)*efld(i,j)
 250     continue
      elseif( e(3) .lt. twopt5 ) then			! lognormal
         do 260 j = 1, nrfy
         do 260 i = 1, nrfx
            efld(i,j) = exp( e(4) + e(5)*efld(i,j) )
 260     continue
      else						! bounded
         do 270 j = 1, nrfy
         do 270 i = 1, nrfx
            efld(i,j) = e(4) + half*(e(5)-e(4))                           &
                     *( one + tanh((e(6)+e(7)*efld(i,j))/twopi) )
 270     continue
      endif
!					for Poisson's ratio...
      if( v(3) .lt. half ) then				! deterministic
         do 280 j = 1, nrfy
         do 280 i = 1, nrfx
            vfld(i,j) = v(1)
 280     continue
      elseif( v(3) .lt. onept5 ) then			! normal
         do 290 j = 1, nrfy
         do 290 i = 1, nrfx
            vfld(i,j) = v(1) + v(2)*vfld(i,j)
 290     continue
      elseif( v(3) .lt. twopt5 ) then			! lognormal
         do 300 j = 1, nrfy
         do 300 i = 1, nrfx
            vfld(i,j) = exp( v(4) + v(5)*vfld(i,j) )
 300     continue
      else						! bounded
         do 310 j = 1, nrfy
         do 310 i = 1, nrfx
            vfld(i,j) = v(4) + half*(v(5)-v(4))                           &
                     *( one + tanh((v(6)+v(7)*vfld(i,j))/twopi) )
 310     continue
      endif

      return
      end


module basics

    use, intrinsic :: iso_fortran_env

    private
    public                                    :: openfiles, closefiles, introduction, seedgen
                                      !rc     = LJ potential cut-off, unit L
                                      !dr_max = maximum deg. of rand. trans., unit L
    real, public                              :: rc, sigma, epsilon, dr_max
    real, public                              :: T, beta, density
    integer, public                           :: N, L
    integer, public                           :: nbin, total_mc_step
    integer, parameter, public                :: single=2

    real,    dimension(:,:), allocatable, public :: positions
    logical, dimension(:)  , allocatable, public :: cluster, moved
    real,    dimension(:)  , allocatable, public :: rbin
    integer, dimension(:)  , allocatable, public :: rhist

    integer, parameter, public                :: mrfile=10, Efile=11, grfile=12

    type, public :: potential_type
        real    :: potential_energy
        logical :: overlap=.false.

        contains
            procedure :: add_potential_type
            procedure :: substract_potential_type
            generic   :: operator(+) => add_potential_type
            generic   :: operator(-) => substract_potential_type
    end type potential_type

    type, public :: variable_type
        character(len=30)           :: nam
        real                        :: val

        !abstract interface
        !    subroutine func

        !    end subroutine
        !end interface

        integer, dimension(:), pointer :: array    => null() ! nrm: normalizer
        !procedure(func), pointer       :: function => null() ! avg: average value
        real                           :: add=0.0            ! msd: average squared value
        logical                        :: scalar = .TRUE.    ! err: estimated error
        real                           :: run_nrm, run_avg, run_msd, run_err
        real                           :: blk_nrm, blk_avg, blk_msd, blk_err
    end type variable_type

    type, public :: variable_ptr
        type(variable_type), pointer :: p
    end type variable_ptr

    contains

        subroutine introduction
            write(*,*) " "
            write(*,*) " "
            write(*,*) "*********************************************"
            write(*,*) "Monte-Carlo Simulation of Lennard-Jones Fluid"
            write(*,*) "*********************************************"
            write(*,*) " "
        end subroutine introduction

        function seedgen (pid) result (seedg)
            implicit none
            integer(kind=int64) :: seedg
            integer, intent(IN) :: pid
            integer :: s

            call system_clock(s)
            seedg = abs( mod((s*181)*((pid-83)*359), 104729) )
        end function seedgen

        function add_potential_type (a,b) result (c)
            implicit none
            type(potential_type)              :: c
            class(potential_type), intent(in) :: a,b

            c%potential_energy = a%potential_energy + b%potential_energy
        end function add_potential_type

        function substract_potential_type (a,b) result (c)
            implicit none
            type(potential_type)              :: c
            class(potential_type), intent(in) :: a,b

            c%potential_energy = a%potential_energy - b%potential_energy
        end function substract_potential_type

        subroutine openfiles
            open(mrfile, file='move_ratio.dat'  , status='new')
            open(Efile , file='total_energy.dat', status='new')
            open(grfile, file='radial.dat'      , status='new')

            write(Efile,  100) "BlockN", "/Energy/", "STD"
            write(mrfile, 100) "BlockN", "/MoveRatio/", "STD"
            write(grfile, 100) "BlockN", "/Distance/", "G(r)"
100         format (a13,a13,a13)
        end subroutine openfiles

        subroutine closefiles
            close(mrfile)
            close(Efile )
            close(grfile)
        end subroutine closefiles

end module basics


program rstest
  use flips

  ! This program tests flips_resize in different situations
  ! Single precision real version

  implicit none

  type(flips_z) :: s1, s2

  complex(dp), dimension(:), allocatable :: amat
  real(dp), dimension(:), allocatable :: tmat,erro
  complex(dp), dimension(:), allocatable :: meas,sol2
  real(dp), dimension(:), allocatable :: tvec
  logical, dimension(:), allocatable :: re
  complex(dp) :: diff
  real(dp) :: maxdiff
  real(dp) :: ts,te
  logical, dimension(:), allocatable :: remo

  write(*,*) 'Test 1: Marginalize 500 first unknowns from a 1000 unknowns problem'
  ! ********************************************************************

  write(*,*) '  Memory storage'

  ! Initialize s1
  call flips_init(s1,1000,1,buffersize=50)

  ! Create data
  allocate(amat(1000*1000),meas(1000),erro(1000),tmat(1000*1000),tvec(1000))
  call random_number(tmat)
  amat = tmat
  call random_number(tmat)
  amat = amat + (0.0,1.0)*tmat
  call random_number(tvec)
  meas = tvec
  call random_number(tvec)
  meas = meas + (0.0,1.0)*tvec
  call random_number(erro)
  erro = erro + 0.5

  ! Feed data in s1
  call flips_add(s1,1000,amat,meas,erro)

  call cpu_time(ts)
  ! Resize by marginalizing 500 first unknowns

  call flips_resize(s2,s1,newsize=500)
  call cpu_time(te)

  ! Solve both problems
  call flips_solve(s1)

  call flips_solve(s2)

!write(*,*) s1%solmat(501:505)
!write(*,*) s2%solmat(1:5)

  ! Compare results
  diff = sum(s2%solmat - s1%solmat(501:1000))/500
  maxdiff = maxval(abs(s2%solmat - s1%solmat(501:1000)))
  write(*,*) '    Mean diff:',diff
  write(*,*) '    Max abs diff:',maxdiff
  write(*,*) '    Resize time:',te-ts,'\n'

  call flips_kill(s1,.FALSE.)
  call flips_kill(s2,.FALSE.)
  deallocate(amat,meas,erro,tmat,tvec)

write(*,*) '  File storage'

  ! Initialize s1
  call flips_init(s1,1000,1,idnum=1,buffersize=50)

  ! Create data
  allocate(amat(1000*1000),meas(1000),erro(1000),tmat(1000*1000),tvec(1000),sol2(1000))
  call random_number(tmat)
  amat = tmat
  call random_number(tmat)
  amat = amat + (0.0,1.0)*tmat
  call random_number(tvec)
  meas = tvec
  call random_number(tvec)
  meas = meas + (0.0,1.0)*tvec
  call random_number(erro)
  erro = erro + 0.5

  ! Feed data in s1
  call flips_add(s1,1000,amat,meas,erro)

  call cpu_time(ts)
  ! Resize by marginalizing 500 first unknowns
  call flips_resize(s2,s1,newsize=500,idnum=2)
  call cpu_time(te)

  ! Solve both problems
  call flips_solve(s1)
  call flips_solve(s2)

  ! Read results from file
  read(113,pos=1) meas
  read(213,pos=1) sol2(1:500)

!write(*,*) meas(501:505)
!write(*,*) erro(1:5)

  ! Compare results
  diff = sum(sol2(1:500) - meas(501:1000))/500
  maxdiff = maxval(abs(sol2(1:500) - meas(501:1000)))
  write(*,*) '    Mean diff:',diff
  write(*,*) '    Max abs diff:',maxdiff
  write(*,*) '    Resize time:',te-ts,'\n'

  call flips_kill(s1,keepfiles=.FALSE.)
  call flips_kill(s2,keepfiles=.FALSE.)
  deallocate(amat,meas,erro,tmat,tvec,sol2)

write(*,*) 'Test 2: Remove last 500 unknowns from a 1000 unknowns problem'

 write(*,*) '  Memory storage'

  ! Initialize s1
  call flips_init(s1,1000,1,buffersize=50)

  ! Create data
  allocate(amat(1000*1000),meas(1000),erro(1000),tmat(1000*1000),tvec(1000),remo(1000))
  call random_number(tmat)
  amat = tmat
  call random_number(tmat)
  amat = amat + (0.0,1.0)*tmat
  call random_number(tvec)
  meas = tvec
  call random_number(tvec)
  meas = meas + (0.0,1.0)*tvec
  call random_number(erro)
  erro = erro + 0.5
  remo = .FALSE.
  remo(501:1000) = .TRUE.

  ! Feed data in s1
  call flips_add(s1,1000,amat,meas,erro)

  call cpu_time(ts)
  ! Resize by marginalizing last 500 unknowns
  call flips_resize(s2,s1,remove=remo)
  call cpu_time(te)

  ! Solve both problems
  call flips_solve(s1)
  call flips_solve(s2)

!write(*,*) s1%solmat(501:505)
!write(*,*) s2%solmat(1:5)

  ! Compare results
  diff = sum(s2%solmat - s1%solmat(1:500))/500
  maxdiff = maxval(abs(s2%solmat - s1%solmat(1:500)))
  write(*,*) '    Mean diff:',diff
  write(*,*) '    Max abs diff:',maxdiff
  write(*,*) '    Resize time:',te-ts,'\n'

  call flips_kill(s1,.FALSE.)
  call flips_kill(s2,.FALSE.)
  deallocate(amat,meas,erro,remo,tmat,tvec)

 write(*,*) '  File storage'

  ! Initialize s1
  call flips_init(s1,1000,1,idnum=1,buffersize=50)

  ! Create data
  allocate(amat(1000*1000),meas(1000),erro(1000),tmat(1000*1000),tvec(1000),remo(1000),sol2(1000))
  call random_number(tmat)
  amat = tmat
  call random_number(tmat)
  amat = amat + (0.0,1.0)*tmat
  call random_number(tvec)
  meas = tvec
  call random_number(tvec)
  meas = meas + (0.0,1.0)*tvec
  call random_number(erro)
  erro = erro + 0.5
  remo = .FALSE.
  remo(501:1000) = .TRUE.

  ! Feed data in s1
  call flips_add(s1,1000,amat,meas,erro)

  call cpu_time(ts)
  ! Resize by marginalizing last 500 unknowns
  call flips_resize(s2,s1,remove=remo,idnum=2)
  call cpu_time(te)

!write(*,*) '!!'

  ! Solve both problems
  call flips_solve(s1)

!write(*,*) 's1'

  call flips_solve(s2)

!write(*,*) 's2'
  ! Read results from file
  read(113,pos=1) meas
  read(213,pos=1) sol2(1:500)

!write(*,*) meas(501:505)
!write(*,*) erro(1:5)

  ! Compare results
  diff = sum(sol2(1:500) - meas(1:500))/500
  maxdiff = maxval(abs(sol2(1:500) - meas(1:500)))
  write(*,*) '    Mean diff:',diff
  write(*,*) '    Max abs diff:',maxdiff
  write(*,*) '    Resize time:',te-ts,'\n'

  call flips_kill(s1,.FALSE.)
  call flips_kill(s2,.FALSE.)
  deallocate(amat,meas,erro,remo,tmat,tvec)

end program rstest


      PROGRAM MAIN

C     RESULT REPORTING
C     CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(F18.15)"
      CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(E12.6)"

C     ----------------------------------------------
C     Variables and data for CNMTX
C     ----------------------------------------------
      INTEGER I
      DOUBLE PRECISION H(12), H_REF(12)
      DATA (H_REF(I),I=1,12) /
     .    15.35873641938967360D0,
     .    9.784941251812741214D0,
     .    -5.520740128266865554D0,
     .    3.575314211234633888D0,
     .    -13.93717453496387648D0,
     .    -9.167400321705855504D0,
     .    5.532815475865292321D0,
     .    9.558741883500834646D0,
     .    -10.22541212627272600D0,
     .    0.8367570529461261231D0,
     .    1.946355176475630611D0,
     .    -13.55702062247304696D0/

C     REPORT RESULTS
      PRINT *, '----------------------------------------'
      PRINT *, '> CNMTX Results'
      PRINT *, '----------------------------------------'

      CALL CNMTX(54964.0D0, H)
      DO 500 I = 1, 12
        WRITE(*, FMT1) DABS(H_REF(I)-H(I))
  500 CONTINUE

C     ALL DONE
      END


subroutine print_suffix(c)
    implicit none
    character(9) c, suffix
    integer n, r10, r100

    ! write (n, '(a)') nc
    read (c, '(i9)') n
    r10 = mod(n, 10)
    r100 = mod(n, 100)

    if (r100 == 11 .or. r100 == 12 .or. r100 == 13) then
      suffix = 'th'
    else if (r10 == 1) then
      suffix = 'st'
    else if (r10 == 2) then
      suffix = 'nd'
    else if (r10 == 3) then
      suffix = 'rd'
    else
      suffix = 'th'
    end if

    print '(a,a2)', trim(c), suffix
end subroutine

program main
    integer n
    character(9) arg
    do i = 1, iargc()
      call getarg(i, arg)
      call print_suffix(arg)
    end do
end program


*> \brief \b DLATM4
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLATM4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND,
*                          TRIANG, IDIST, ISEED, A, LDA )
*
*       .. Scalar Arguments ..
*       INTEGER            IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2
*       DOUBLE PRECISION   AMAGN, RCOND, TRIANG
*       ..
*       .. Array Arguments ..
*       INTEGER            ISEED( 4 )
*       DOUBLE PRECISION   A( LDA, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLATM4 generates basic square matrices, which may later be
*> multiplied by others in order to produce test matrices.  It is
*> intended mainly to be used to test the generalized eigenvalue
*> routines.
*>
*> It first generates the diagonal and (possibly) subdiagonal,
*> according to the value of ITYPE, NZ1, NZ2, ISIGN, AMAGN, and RCOND.
*> It then fills in the upper triangle with random numbers, if TRIANG is
*> non-zero.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] ITYPE
*> \verbatim
*>          ITYPE is INTEGER
*>          The "type" of matrix on the diagonal and sub-diagonal.
*>          If ITYPE < 0, then type abs(ITYPE) is generated and then
*>             swapped end for end (A(I,J) := A'(N-J,N-I).)  See also
*>             the description of AMAGN and ISIGN.
*>
*>          Special types:
*>          = 0:  the zero matrix.
*>          = 1:  the identity.
*>          = 2:  a transposed Jordan block.
*>          = 3:  If N is odd, then a k+1 x k+1 transposed Jordan block
*>                followed by a k x k identity block, where k=(N-1)/2.
*>                If N is even, then k=(N-2)/2, and a zero diagonal entry
*>                is tacked onto the end.
*>
*>          Diagonal types.  The diagonal consists of NZ1 zeros, then
*>             k=N-NZ1-NZ2 nonzeros.  The subdiagonal is zero.  ITYPE
*>             specifies the nonzero diagonal entries as follows:
*>          = 4:  1, ..., k
*>          = 5:  1, RCOND, ..., RCOND
*>          = 6:  1, ..., 1, RCOND
*>          = 7:  1, a, a^2, ..., a^(k-1)=RCOND
*>          = 8:  1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
*>          = 9:  random numbers chosen from (RCOND,1)
*>          = 10: random numbers with distribution IDIST (see DLARND.)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix.
*> \endverbatim
*>
*> \param[in] NZ1
*> \verbatim
*>          NZ1 is INTEGER
*>          If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
*>          be zero.
*> \endverbatim
*>
*> \param[in] NZ2
*> \verbatim
*>          NZ2 is INTEGER
*>          If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
*>          be zero.
*> \endverbatim
*>
*> \param[in] ISIGN
*> \verbatim
*>          ISIGN is INTEGER
*>          = 0: The sign of the diagonal and subdiagonal entries will
*>               be left unchanged.
*>          = 1: The diagonal and subdiagonal entries will have their
*>               sign changed at random.
*>          = 2: If ITYPE is 2 or 3, then the same as ISIGN=1.
*>               Otherwise, with probability 0.5, odd-even pairs of
*>               diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be
*>               converted to a 2x2 block by pre- and post-multiplying
*>               by distinct random orthogonal rotations.  The remaining
*>               diagonal entries will have their sign changed at random.
*> \endverbatim
*>
*> \param[in] AMAGN
*> \verbatim
*>          AMAGN is DOUBLE PRECISION
*>          The diagonal and subdiagonal entries will be multiplied by
*>          AMAGN.
*> \endverbatim
*>
*> \param[in] RCOND
*> \verbatim
*>          RCOND is DOUBLE PRECISION
*>          If abs(ITYPE) > 4, then the smallest diagonal entry will be
*>          entry will be RCOND.  RCOND must be between 0 and 1.
*> \endverbatim
*>
*> \param[in] TRIANG
*> \verbatim
*>          TRIANG is DOUBLE PRECISION
*>          The entries above the diagonal will be random numbers with
*>          magnitude bounded by TRIANG (i.e., random numbers multiplied
*>          by TRIANG.)
*> \endverbatim
*>
*> \param[in] IDIST
*> \verbatim
*>          IDIST is INTEGER
*>          Specifies the type of distribution to be used to generate a
*>          random matrix.
*>          = 1:  UNIFORM( 0, 1 )
*>          = 2:  UNIFORM( -1, 1 )
*>          = 3:  NORMAL ( 0, 1 )
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          On entry ISEED specifies the seed of the random number
*>          generator.  The values of ISEED are changed on exit, and can
*>          be used in the next call to DLATM4 to continue the same
*>          random number sequence.
*>          Note: ISEED(4) should be odd, for the random number generator
*>          used at present.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA, N)
*>          Array to be computed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          Leading dimension of A.  Must be at least 1 and at least N.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE DLATM4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND,
     $                   TRIANG, IDIST, ISEED, A, LDA )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2
      DOUBLE PRECISION   AMAGN, RCOND, TRIANG
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
      DOUBLE PRECISION   HALF
      PARAMETER          ( HALF = ONE / TWO )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IOFF, ISDB, ISDE, JC, JD, JR, K, KBEG, KEND,
     $                   KLEN
      DOUBLE PRECISION   ALPHA, CL, CR, SAFMIN, SL, SR, SV1, SV2, TEMP
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLARAN, DLARND
      EXTERNAL           DLAMCH, DLARAN, DLARND
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLASET
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, EXP, LOG, MAX, MIN, MOD, SQRT
*     ..
*     .. Executable Statements ..
*
      IF( N.LE.0 )
     $   RETURN
      CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
*
*     Insure a correct ISEED
*
      IF( MOD( ISEED( 4 ), 2 ).NE.1 )
     $   ISEED( 4 ) = ISEED( 4 ) + 1
*
*     Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
*     and RCOND
*
      IF( ITYPE.NE.0 ) THEN
         IF( ABS( ITYPE ).GE.4 ) THEN
            KBEG = MAX( 1, MIN( N, NZ1+1 ) )
            KEND = MAX( KBEG, MIN( N, N-NZ2 ) )
            KLEN = KEND + 1 - KBEG
         ELSE
            KBEG = 1
            KEND = N
            KLEN = N
         END IF
         ISDB = 1
         ISDE = 0
         GO TO ( 10, 30, 50, 80, 100, 120, 140, 160,
     $           180, 200 )ABS( ITYPE )
*
*        abs(ITYPE) = 1: Identity
*
   10    CONTINUE
         DO 20 JD = 1, N
            A( JD, JD ) = ONE
   20    CONTINUE
         GO TO 220
*
*        abs(ITYPE) = 2: Transposed Jordan block
*
   30    CONTINUE
         DO 40 JD = 1, N - 1
            A( JD+1, JD ) = ONE
   40    CONTINUE
         ISDB = 1
         ISDE = N - 1
         GO TO 220
*
*        abs(ITYPE) = 3: Transposed Jordan block, followed by the
*                        identity.
*
   50    CONTINUE
         K = ( N-1 ) / 2
         DO 60 JD = 1, K
            A( JD+1, JD ) = ONE
   60    CONTINUE
         ISDB = 1
         ISDE = K
         DO 70 JD = K + 2, 2*K + 1
            A( JD, JD ) = ONE
   70    CONTINUE
         GO TO 220
*
*        abs(ITYPE) = 4: 1,...,k
*
   80    CONTINUE
         DO 90 JD = KBEG, KEND
            A( JD, JD ) = DBLE( JD-NZ1 )
   90    CONTINUE
         GO TO 220
*
*        abs(ITYPE) = 5: One large D value:
*
  100    CONTINUE
         DO 110 JD = KBEG + 1, KEND
            A( JD, JD ) = RCOND
  110    CONTINUE
         A( KBEG, KBEG ) = ONE
         GO TO 220
*
*        abs(ITYPE) = 6: One small D value:
*
  120    CONTINUE
         DO 130 JD = KBEG, KEND - 1
            A( JD, JD ) = ONE
  130    CONTINUE
         A( KEND, KEND ) = RCOND
         GO TO 220
*
*        abs(ITYPE) = 7: Exponentially distributed D values:
*
  140    CONTINUE
         A( KBEG, KBEG ) = ONE
         IF( KLEN.GT.1 ) THEN
            ALPHA = RCOND**( ONE / DBLE( KLEN-1 ) )
            DO 150 I = 2, KLEN
               A( NZ1+I, NZ1+I ) = ALPHA**DBLE( I-1 )
  150       CONTINUE
         END IF
         GO TO 220
*
*        abs(ITYPE) = 8: Arithmetically distributed D values:
*
  160    CONTINUE
         A( KBEG, KBEG ) = ONE
         IF( KLEN.GT.1 ) THEN
            ALPHA = ( ONE-RCOND ) / DBLE( KLEN-1 )
            DO 170 I = 2, KLEN
               A( NZ1+I, NZ1+I ) = DBLE( KLEN-I )*ALPHA + RCOND
  170       CONTINUE
         END IF
         GO TO 220
*
*        abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1):
*
  180    CONTINUE
         ALPHA = LOG( RCOND )
         DO 190 JD = KBEG, KEND
            A( JD, JD ) = EXP( ALPHA*DLARAN( ISEED ) )
  190    CONTINUE
         GO TO 220
*
*        abs(ITYPE) = 10: Randomly distributed D values from DIST
*
  200    CONTINUE
         DO 210 JD = KBEG, KEND
            A( JD, JD ) = DLARND( IDIST, ISEED )
  210    CONTINUE
*
  220    CONTINUE
*
*        Scale by AMAGN
*
         DO 230 JD = KBEG, KEND
            A( JD, JD ) = AMAGN*DBLE( A( JD, JD ) )
  230    CONTINUE
         DO 240 JD = ISDB, ISDE
            A( JD+1, JD ) = AMAGN*DBLE( A( JD+1, JD ) )
  240    CONTINUE
*
*        If ISIGN = 1 or 2, assign random signs to diagonal and
*        subdiagonal
*
         IF( ISIGN.GT.0 ) THEN
            DO 250 JD = KBEG, KEND
               IF( DBLE( A( JD, JD ) ).NE.ZERO ) THEN
                  IF( DLARAN( ISEED ).GT.HALF )
     $               A( JD, JD ) = -A( JD, JD )
               END IF
  250       CONTINUE
            DO 260 JD = ISDB, ISDE
               IF( DBLE( A( JD+1, JD ) ).NE.ZERO ) THEN
                  IF( DLARAN( ISEED ).GT.HALF )
     $               A( JD+1, JD ) = -A( JD+1, JD )
               END IF
  260       CONTINUE
         END IF
*
*        Reverse if ITYPE < 0
*
         IF( ITYPE.LT.0 ) THEN
            DO 270 JD = KBEG, ( KBEG+KEND-1 ) / 2
               TEMP = A( JD, JD )
               A( JD, JD ) = A( KBEG+KEND-JD, KBEG+KEND-JD )
               A( KBEG+KEND-JD, KBEG+KEND-JD ) = TEMP
  270       CONTINUE
            DO 280 JD = 1, ( N-1 ) / 2
               TEMP = A( JD+1, JD )
               A( JD+1, JD ) = A( N+1-JD, N-JD )
               A( N+1-JD, N-JD ) = TEMP
  280       CONTINUE
         END IF
*
*        If ISIGN = 2, and no subdiagonals already, then apply
*        random rotations to make 2x2 blocks.
*
         IF( ISIGN.EQ.2 .AND. ITYPE.NE.2 .AND. ITYPE.NE.3 ) THEN
            SAFMIN = DLAMCH( 'S' )
            DO 290 JD = KBEG, KEND - 1, 2
               IF( DLARAN( ISEED ).GT.HALF ) THEN
*
*                 Rotation on left.
*
                  CL = TWO*DLARAN( ISEED ) - ONE
                  SL = TWO*DLARAN( ISEED ) - ONE
                  TEMP = ONE / MAX( SAFMIN, SQRT( CL**2+SL**2 ) )
                  CL = CL*TEMP
                  SL = SL*TEMP
*
*                 Rotation on right.
*
                  CR = TWO*DLARAN( ISEED ) - ONE
                  SR = TWO*DLARAN( ISEED ) - ONE
                  TEMP = ONE / MAX( SAFMIN, SQRT( CR**2+SR**2 ) )
                  CR = CR*TEMP
                  SR = SR*TEMP
*
*                 Apply
*
                  SV1 = A( JD, JD )
                  SV2 = A( JD+1, JD+1 )
                  A( JD, JD ) = CL*CR*SV1 + SL*SR*SV2
                  A( JD+1, JD ) = -SL*CR*SV1 + CL*SR*SV2
                  A( JD, JD+1 ) = -CL*SR*SV1 + SL*CR*SV2
                  A( JD+1, JD+1 ) = SL*SR*SV1 + CL*CR*SV2
               END IF
  290       CONTINUE
         END IF
*
      END IF
*
*     Fill in upper triangle (except for 2x2 blocks)
*
      IF( TRIANG.NE.ZERO ) THEN
         IF( ISIGN.NE.2 .OR. ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
            IOFF = 1
         ELSE
            IOFF = 2
            DO 300 JR = 1, N - 1
               IF( A( JR+1, JR ).EQ.ZERO )
     $            A( JR, JR+1 ) = TRIANG*DLARND( IDIST, ISEED )
  300       CONTINUE
         END IF
*
         DO 320 JC = 2, N
            DO 310 JR = 1, JC - IOFF
               A( JR, JC ) = TRIANG*DLARND( IDIST, ISEED )
  310       CONTINUE
  320    CONTINUE
      END IF
*
      RETURN
*
*     End of DLATM4
*
      END