c=======================================================================
      subroutine ptlmp(maxm,mdzero,ngrid,nrec,p,x,y,
     &                 a0b0,betapm,betapv,tau,m0,s0,
     &                 mcmc,nsave,propv,mcmcad,
     &                 seed,
     &                 acrate,randsave,thetasave,cpo,f,
     &                 alpha,beta,mu,sigma2,v,
     &                 betac,iflag,vc,workm1,workm2,
     &                 workmh1,workv1,workv2,grid,whicho,whichn,xtx)
c=======================================================================
c     # arguments = 40.
c
c     Subroutine `ptlmp' to run a Markov chain in the
c     semiparametric linear regression model using a partially
c     specified Mixture of Polya trees.
c
c     Copyright: Alejandro Jara, 2006-2010.
c
c     Version 3.0:
c
c     Last modification: 20-08-2007.
c
c     Changes and Bug fixes:
c
c     Version 2.0 to Version 3.0:
c          - Allows for non median zero regression models.
c
c     Version 1.0 to Version 2.0:
c          - Uses vectors to keep the observations in each partition.
c
c     This program is free software; you can redistribute it and/or modify
c     it under the terms of the GNU General Public License as published by
c     the Free Software Foundation; either version 2 of the License, or (at
c     your option) any later version.
c
c     This program is distributed in the hope that it will be useful, but
c     WITHOUT ANY WARRANTY; without even the implied warranty of
c     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
c     General Public License for more details.
c
c     You should have received a copy of the GNU General Public License
c     along with this program; if not, write to the Free Software
c     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
c
c     The author's contact information:
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c---- Data -------------------------------------------------------------
c
c        maxm        :  integer giving the number of binary partitions
c                       in the Finite Polya tree prior.
c        mdzero      :  integer indicating whether a median zero is
c                       fitted or not.
c        ngrid       :  integer giving the size of the grid where
c                       the density estimate is evaluated.
c        nrec        :  integer giving the number of observations.
c        p           :  integer giving the number of fixed coefficients.
c        x           :  real matrix giving the design matrix for the
c                       fixed effects, x(nrec,p).
c        y           :  real vector giving the limits of the responses,
c                       y(nrec).
c
c-----------------------------------------------------------------------
c
c---- Prior information ------------------------------------------------
c
c        aa0, ab0    :  real giving the hyperparameters of the prior
c                       distribution for the precision parameter,
c                       alpha ~ Gamma(aa0,ab0). If aa0<0 the precision
c                       parameter is considered as a constant.
c        betapm      :  real vector giving the prior mean of regression
c                       coefficients, betapm(p).
c        betapv      :  real matrix giving the prior covariance of
c                       regression coefficients, betapv(p,p).
c        tau1, tau2  :  reals giving the hyperparameters of the prior
c                       distribution for the inverse of the
c                       variance of the normal baseline distribution,
c                       1/sigma ~ Gamma(tau1/2,tau2/2).
c        m0,s0       :
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        propv       :  real matrix giving the variance of the normal
c                       proposal for the mh algorithm, propv(p,p).
c        mcmcad      :  real vector keeping elements for adaptive MH,
c                       mcmcad(13).
c
c-----------------------------------------------------------------------
c
c---- Random numbers ---------------------------------------------------
c
c        seed1       :  seed for random number generation.
c        seed2       :  seed for random number generation.
c
c-----------------------------------------------------------------------
c
c---- Output -----------------------------------------------------------
c
c        acrate      :  real giving the MH acceptance rate, acrate(4).
c        cpo         :  real giving the cpo, cpo(nrec).
c        f           :  real vector giving the density estimate at the
c                       grid, f(ngrid).
c        randsave    :  real matrix containing the mcmc samples for
c                       the errors and prediction,
c                       randsave(nsave,nrec+1).
c        thetasave   :  real vector containing the mcmc sample for the
c                       regression parameters, betsave(nsave,p+2).
c
c-----------------------------------------------------------------------
c
c---- Current value of the parameters ----------------------------------
c
c        alpha       :  real giving the current value of the precision
c                       parameter of the Polya tree process.
c        beta        :  real vector giving the current value of the
c                       regression coefficients, beta(p).
c        mu          :  real giving the mean of the baseline
c                       distribution.
c        sigma2      :  real giving the current value of the variance
c                       of the baseline distribution.
c        v           :  real vector giving the current value of the
c                       errors, v(nrec).
c
c-----------------------------------------------------------------------
c
c---- Working space ----------------------------------------------------
c
c        alphac      :  real giving the candidate value of the precision
c                       parameter.
c        betac       :  real vector giving the candidate value of the
c                       candidate for regression parameters, betac(p).
c        denom       :  real working variable.
c        dispcount   :  index.
c        dlnrm       :  density of a lognormal normal distribution.
c        dnrm        :  density of a normal distribution.
c        grid        :  real vector giving the grid where the density
c                       estimate is evaluated, grid(ngrid).
c        i           :  index.
c        iflag       :  integer vector used to evaluate the prior
c                       distribution for the regression coefficients,
c                       iflag(p).
c        isave       :  index.
c        iscan       :  index.
c        j           :  index.
c        logcgko     :  real working variable.
c        logcgkn     :  real working variable.
c        loglikec    :  real working variable.
c        loglikeo    :  real working variable.
c        logpriorc   :  real working variable.
c        logprioro   :  real working variable.
c        nscan       :  index.
c        ratio       :  real working variable.
c        rgamma      :  real gamma random number generator.
c        runif       :  real uniform random number generator.
c        sd          :  real working variable.
c        sdc         :  real working variable.
c        sisgma2c    :  real working variable.
c        sprint      :  integer function to print on screen.
c        skipcount   :  index.
c        tmp1        :  real used to accumulate quantities.
c        vc          :  real vector giving the candidate value of the
c                       errors, vc(nrec).
c        vpred       :  real working variable.
c        whicho      :  integer vector giving the observation in each
c                       partitio, whicho(nrec).
c        whichn      :  integer vector giving the observation in each
c                       partitio, whichn(nrec).
c        workm1      :  real matrix used to update the fixed effects,
c                       workm1(p,p).
c        workm2      :  real matrix used to update the fixed effects,
c                       workm2(p,p).
c        workmh1     :  real vector used to update the fixed effects,
c                       workmh1(p*(p+1)/2).
c        workv1      :  real vector used to update the fixed effects,
c                       workv1(p).
c        workv2      :  real vector used to update the fixed effects,
c                       workv2(p).
c        xtx         :  real matrix used to update the fixed effects,
c                       xtx(p,p).
c
c=======================================================================

      implicit none

c+++++Partially specified Polya Trees parameter
      integer maxm,mdzero

c+++++Observed variables
      integer ngrid,nrec,p
      real*8 x(nrec,p),y(nrec)

c+++++Prior information
      real*8 a0b0(2),aa0,ab0,betapm(p),betapv(p,p)
      real*8 tau(2),tau1,tau2
      real*8 m0,s0

c+++++MCMC parameters
      integer mcmc(3),nburn,nskip,nsave,ndisplay
      real*8 propv(p,p)
      real*8 mcmcad(18)

c+++++Random numbers
      integer seed(2),seed1,seed2

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

c+++++Current values of the parameters
      real*8 alpha,beta(p),mu,sigma2,v(nrec)

c+++++External Working space
      integer iflag(p)
      integer whicho(nrec),whichn(nrec)
      real*8 betac(p)
      real*8 grid(ngrid)
      real*8 vc(nrec)
      real*8 workm1(p,p),workm2(p,p),workmh1(p*(p+1)/2)
      real*8 workv1(p),workv2(p)
      real*8 xtx(p,p)

c+++++Internal Working space
      integer dispcount
      integer i
      integer iscan
      integer isave
      integer j
      integer nscan
      integer sprint
      integer skipcount
      real*8 alphac
      real*8 dlnrm
      real*8 dnrm
      real*8 logcgkn,logcgko
      real*8 loglikec,loglikeo
      real*8 logpriorc,logprioro
      real*8 muc
      real*8 ratio
      real*8 rnorm
      real*8 sd,sdc
      real*8 theta,thetac
      real*8 tmp1
      real*8 vpred

      real runif

c+++++Adaptive MH
      integer acceptb
      real*8 logval
      real*8 maxa,maxb
      real*8 nscanp

c+++++Adaptive MH for beta
      integer skipb
      real*8 arateb
      real*8 counterb
      real*8 tune1

c+++++Adaptive MH for mu
      integer skipm
      real*8 aratemu(5),counterm
      real*8 pilogestmu(2)
      real*8 tune2(2)

c+++++Adaptive MH for sigma2
      integer skips
      real*8 aratesig(5),counters
      real*8 pilogestsig(2)
      real*8 tune3(2)

c+++++Adaptive MH for alpha
      integer skipa
      real*8 aratea(5),countera
      real*8 pilogesta(2)
      real*8 tune4(2)

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

c++++ initialize variables

      aa0=a0b0(1)
      ab0=a0b0(2)

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

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

      sd=sqrt(sigma2)

c++++ set random number generator
      seed1=seed(1)
      seed2=seed(2)

      call setall(seed1,seed2)

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c++++ start the MCMC algorithm
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

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

      maxa=100.d0
      maxb=100.d0

      arateb=0.d0
      skipb=0
      tune1=mcmcad(1)
      counterb=mcmcad(2)

      aratemu(1)=0.d0
      aratemu(2)=0.d0
      aratemu(3)=0.d0
      aratemu(4)=0.d0
      aratemu(5)=0.d0
      skipm=0
      tune2(1)=mcmcad(3)
      tune2(2)=mcmcad(4)
      counterm=mcmcad(5)
      pilogestmu(1)=mcmcad(6)
      pilogestmu(2)=mcmcad(7)

      aratesig(1)=0.d0
      aratesig(2)=0.d0
      aratesig(3)=0.d0
      aratesig(4)=0.d0
      aratesig(5)=0.d0
      skips=0
      tune3(1)=mcmcad(8)
      tune3(2)=mcmcad(9)
      counters=mcmcad(10)
      pilogestsig(1)=mcmcad(11)
      pilogestsig(2)=mcmcad(12)

      aratea(1)=0.d0
      aratea(2)=0.d0
      aratea(3)=0.d0
      aratea(4)=0.d0
      aratea(5)=0.d0
      skipa=0
      tune4(1)=mcmcad(13)
      tune4(2)=mcmcad(14)
      countera=mcmcad(15)
      pilogesta(1)=mcmcad(16)
      pilogesta(2)=mcmcad(17)

      nscanp=mcmcad(18)

      call cpu_time(sec0)
      sec00=0.d0

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

      loglikeo=0.d0

      do i=1,nrec
         call rchkusr()

         tmp1=0.d0
         do j=1,p
            tmp1=tmp1+x(i,j)*beta(j)
         end do
         v(i)=y(i)-tmp1
      end do

      call loglik_unippt(nrec,mdzero,maxm,alpha,mu,sigma2,v,
     &                   whicho,whichn,loglikeo)

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

      do iscan=1,nscan

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

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ MH to update the regression coefficients                   +++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

c+++++++ sample candidates
         do i=1,p
            do j=1,p
               xtx(i,j)=tune1*propv(i,j)
            end do
         end do

         call rmvnorm(p,beta,xtx,workmh1,workv1,betac)

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

         call dmvn(p,betac,betapm,betapv,logpriorc,workv1,workm1,
     &             workm2,workv2,iflag)

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

         call dmvn(p,beta,betapm,betapv,logprioro,workv1,workm1,
     &             workm2,workv2,iflag)

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

         loglikec=0.d0

         do i=1,nrec
            call rchkusr()
            tmp1=0.d0
            do j=1,p
               tmp1=tmp1+x(i,j)*betac(j)
            end do
            vc(i)=y(i)-tmp1
         end do

         call loglik_unippt(nrec,mdzero,maxm,alpha,mu,sigma2,vc,
     &                      whicho,whichn,loglikec)

c+++++++ acceptance step

         ratio=loglikec+logpriorc-loglikeo-logprioro

         if(log(dble(runif())).lt.ratio)then
            acrate(1)=acrate(1)+1.d0
            arateb=arateb+1.d0
            loglikeo=loglikec
            do i=1,p
               beta(i)=betac(i)
            end do
            do i=1,nrec
               v(i)=vc(i)
            end do
         end if

c+++++++ do adapting

         skipb = skipb + 1
         if(skipb.eq.100)then
            counterb=counterb+1.d0
            arateb=arateb/dble(100)

            if(p.eq.1)then
               if(arateb.gt.0.44d0)then
                  tune1=tune1+
     &                  min(0.01d0,1.d0/sqrt(counterb))
                 else
                  tune1=tune1-
     &                  min(0.01d0,1.d0/sqrt(counterb))
               end if
            end if

            if(p.gt.1)then
               if(arateb.gt.0.25d0)then
                  tune1=tune1+
     &                  min(0.01d0,1.d0/sqrt(counterb))
                 else
                  tune1=tune1-
     &                  min(0.01d0,1.d0/sqrt(counterb))
               end if
            end if

c++++++++++ prevent from getting to extreme
            if(tune1.gt.maxa)then
               tune1=maxa
            end if

            if(tune1.lt.0.0001d0)then
               tune1=0.0001d0
            end if

            arateb=0.d0
            skipb=0
         end if

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ MH to update mu                                            +++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

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

         if(s0.gt.0.d0)then

c++++++++++ candidate
            logval=log(1.d0+dabs(mu))
            tmp1=exp(
     &         (tune2(1)/2.d0)+
     &         (tune2(2)/2.d0)*(logval-pilogestmu(1))
     &              )
            muc=rnorm(mu,tmp1)

            logcgkn=dnrm(mu,muc,tmp1,1)

            logval=log(1.d0+dabs(muc))
            tmp1=exp(
     &         (tune2(1)/2.d0)+
     &         (tune2(2)/2.d0)*(logval-pilogestmu(1))
     &              )
            logcgko=dnrm(muc,mu,tmp1,1)

c++++++++++ prior
            logpriorc=dnrm(muc, m0, sqrt(s0),1)
            logprioro=dnrm(mu , m0, sqrt(s0),1)

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

            loglikec=0.d0

            call loglik_unippt(nrec,mdzero,maxm,alpha,muc,sigma2,v,
     &                         whicho,whichn,loglikec)

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

            ratio=loglikec+logpriorc-loglikeo-logprioro+
     &            logcgkn-logcgko

            acceptb=0

            if(log(dble(runif())).lt.ratio)then
               acceptb=1
            end if

            if(acceptb.eq.1)then
               acrate(2)=acrate(2)+1.d0
               aratemu(1)=aratemu(1)+1.d0
               mu=muc
               loglikeo=loglikec
            end if

            logval=log(1.d0+dabs(mu))
            pilogestmu(2)=pilogestmu(2)+logval

            if(logval.gt.pilogestmu(1))then
                aratemu(2)=aratemu(2)+1.d0
                if(acceptb.eq.1)then
                   aratemu(3)=aratemu(3)+1.d0
                end if
              else
                aratemu(4)=aratemu(4)+1.d0
                if(acceptb.eq.1)then
                   aratemu(5)=aratemu(5)+1.d0
                end if
            end if

            pilogestmu(1)=pilogestmu(2)/(dble(iscan)+nscanp)

c++++++++++ do adapting

            skipm = skipm + 1
            if(skipm.eq.100)then
               counterm=counterm+1.d0
               aratemu(1)=aratemu(1)/dble(100)

c+++++++++++++ adapt a.
               if(aratemu(1).gt.0.44d0)then
                  tune2(1)=tune2(1)+
     &                     min(0.01d0,1.d0/sqrt(counterm))
                 else
                  tune2(1)=tune2(1)-
     &                     min(0.01d0,1.d0/sqrt(counterm))
               end if

c+++++++++++++ adapt b.

               if(aratemu(3)*aratemu(4).lt.aratemu(5)*aratemu(2))
     &         then
                  tune2(2)=tune2(2)-
     &                     min(0.01d0,1.d0/sqrt(counterm))
                 else
                  tune2(2)=tune2(2)+
     &                     min(0.01d0,1.d0/sqrt(counterm))
               end if

c+++++++++++++ prevent a from getting to extreme
               if(tune2(1).gt.maxa)then
                  tune2(1)=maxa
               end if

               if(tune2(1).lt.-maxa)then
                  tune2(1)=-maxa
               end if

c+++++++++++++ prevent b from getting to extreme
               if(tune2(2).gt.maxb)then
                  tune2(2)=maxb
               end if

               if(tune2(2).lt.-maxb)then
                  tune2(2)=-maxb
               end if

c+++++++++++++ set accetptance rate in batch to zero
               aratemu(1)=0.d0
               aratemu(2)=0.d0
               aratemu(3)=0.d0
               aratemu(4)=0.d0
               aratemu(5)=0.d0
               skipm=0
            end if
         end if

c+++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ Sampling log-sigma : Gamma prior
c+++++++++++++++++++++++++++++++++++++++++++++++++

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

         if(tau1.gt.0.d0)then

c++++++++++ candidate

            theta=log(sqrt(sigma2))
            logval=log(1.d0+dabs(theta))
            tmp1=exp(
     &         (tune3(1)/2.d0)+
     &         (tune3(2)/2.d0)*(logval-pilogestsig(1))
     &              )
            thetac=rnorm(theta,tmp1)
            logcgkn=dnrm(theta,thetac,tmp1,1)

            logval=log(1.d0+dabs(thetac))
            tmp1=exp(
     &         (tune3(1)/2.d0)+
     &         (tune3(2)/2.d0)*(logval-pilogestsig(1))
     &              )
            logcgko=dnrm(thetac,theta,tmp1,1)

c++++++++++ likelihood
            sdc=exp(thetac)

            loglikec=0.d0

            call loglik_unippt(nrec,mdzero,maxm,alpha,mu,sdc**2,v,
     &                         whicho,whichn,loglikec)

c++++++++++ prior

            logpriorc=-tau1*thetac-tau2*exp(-2.d0*thetac)/2.d0
            logprioro=-tau1*theta-tau2*exp(-2.d0*theta)/2.d0

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

            ratio=loglikec+logpriorc-loglikeo-logprioro+
     &            logcgkn-logcgko

            acceptb=0

            if(log(dble(runif())).lt.ratio)then
               acceptb=1
            end if

            if(acceptb.eq.1)then
               acrate(3)=acrate(3)+1.d0
               aratesig(1)=aratesig(1)+1.d0
               sd=sdc
               sigma2=sd**2
               loglikeo=loglikec
            end if

            theta=log(sqrt(sigma2))
            logval=log(1.d0+dabs(theta))
            pilogestsig(2)=pilogestsig(2)+logval

            if(logval.gt.pilogestsig(1))then
                aratesig(2)=aratesig(2)+1.d0
                if(acceptb.eq.1)then
                   aratesig(3)=aratesig(3)+1.d0
                end if
              else
                aratesig(4)=aratesig(4)+1.d0
                if(acceptb.eq.1)then
                   aratesig(5)=aratesig(5)+1.d0
                end if
            end if

            pilogestsig(1)=pilogestsig(2)/(dble(iscan)+nscanp)

c++++++++++ do adapting

            skips = skips + 1
            if(skips.eq.100)then
               counters=counters+1.d0
               aratesig(1)=aratesig(1)/dble(100)

c+++++++++++++ adapt a.
               if(aratesig(1).gt.0.44d0)then
                  tune3(1)=tune3(1)+
     &                     min(0.01d0,1.d0/sqrt(counters))
                 else
                  tune3(1)=tune3(1)-
     &                     min(0.01d0,1.d0/sqrt(counters))
               end if

c+++++++++++++ adapt b.

               if(aratesig(3)*aratesig(4).lt.aratesig(5)*aratesig(2))
     &         then
                  tune3(2)=tune3(2)-
     &                     min(0.01d0,1.d0/sqrt(counters))
                 else
                  tune3(2)=tune3(2)+
     &                     min(0.01d0,1.d0/sqrt(counters))
               end if

c+++++++++++++ prevent a from getting to extreme
               if(tune3(1).gt.maxa)then
                  tune3(1)=maxa
               end if

               if(tune3(1).lt.-maxa)then
                  tune3(1)=-maxa
               end if

c+++++++++++++ prevent b from getting to extreme
               if(tune3(2).gt.maxb)then
                  tune3(2)=maxb
               end if

               if(tune3(2).lt.-maxb)then
                  tune3(2)=-maxb
               end if

c+++++++++++++ set accetptance rate in batch to zero
               aratesig(1)=0.d0
               aratesig(2)=0.d0
               aratesig(3)=0.d0
               aratesig(4)=0.d0
               aratesig(5)=0.d0
               skips=0
            end if
         end if

c++++++++++++++++++++++++++++++++++
c+++++++ Precision parameter
c++++++++++++++++++++++++++++++++++

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

         if(aa0.gt.0.d0)then

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

            theta=log(alpha)
            logval=log(1.d0+dabs(theta))
            tmp1=exp(
     &         (tune4(1)/2.d0)+
     &         (tune4(2)/2.d0)*(logval-pilogesta(1))
     &              )
            thetac=rnorm(theta,tmp1)
            alphac=exp(thetac)

            logcgkn=dlnrm(alpha,thetac,tmp1,1)

            logval=log(1.d0+dabs(thetac))
            tmp1=exp(
     &         (tune4(1)/2.d0)+
     &         (tune4(2)/2.d0)*(logval-pilogesta(1))
     &              )
            logcgko=dlnrm(alphac,theta,tmp1,1)

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

            call dgamma2(alphac,aa0,ab0,logpriorc)

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

            call dgamma2(alpha,aa0,ab0,logprioro)

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

            loglikec=0.d0

            call loglik_unippt(nrec,mdzero,maxm,alphac,mu,sigma2,v,
     &                         whicho,whichn,loglikec)

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

            ratio=loglikec+logpriorc-loglikeo-logprioro+
     &            logcgkn-logcgko

            acceptb=0

            if(log(dble(runif())).lt.ratio)then
               acceptb=1
            end if

            if(acceptb.eq.1)then
               acrate(4)=acrate(4)+1.d0
               aratea(1)=aratea(1)+1.d0
               alpha=alphac
               loglikeo=loglikec
            end if

            theta=log(alpha)
            logval=log(1.d0+dabs(theta))
            pilogesta(2)=pilogesta(2)+logval

            if(logval.gt.pilogesta(1))then
                aratea(2)=aratea(2)+1.d0
                if(acceptb.eq.1)then
                   aratea(3)=aratea(3)+1.d0
                end if
              else
                aratea(4)=aratea(4)+1.d0
                if(acceptb.eq.1)then
                   aratea(5)=aratea(5)+1.d0
                end if
            end if

            pilogesta(1)=pilogesta(2)/(dble(iscan)+nscanp)

c++++++++++ do adapting

            skipa = skipa + 1
            if(skipa.eq.100)then
               countera=countera+1.d0
               aratea(1)=aratea(1)/dble(100)

c+++++++++++++ adapt a.
               if(aratea(1).gt.0.44d0)then
                  tune4(1)=tune4(1)+
     &                     min(0.01d0,1.d0/sqrt(countera))
                 else
                  tune4(1)=tune4(1)-
     &                     min(0.01d0,1.d0/sqrt(countera))
               end if

c+++++++++++++ adapt b.

               if(aratea(3)*aratea(4).lt.aratea(5)*aratea(2))
     &         then
                  tune4(2)=tune4(2)-
     &                     min(0.01d0,1.d0/sqrt(countera))
                 else
                  tune4(2)=tune4(2)+
     &                     min(0.01d0,1.d0/sqrt(countera))
               end if

c+++++++++++++ prevent a from getting to extreme
               if(tune4(1).gt.maxa)then
                  tune4(1)=maxa
               end if

               if(tune4(1).lt.-maxa)then
                  tune4(1)=-maxa
               end if

c+++++++++++++ prevent b from getting to extreme
               if(tune4(2).gt.maxb)then
                  tune4(2)=maxb
               end if

               if(tune4(2).lt.-maxb)then
                  tune4(2)=-maxb
               end if

c+++++++++++++ set accetptance rate in batch to zero
               aratea(1)=0.d0
               aratea(2)=0.d0
               aratea(3)=0.d0
               aratea(4)=0.d0
               aratea(5)=0.d0
               skipa=0
            end if

         end if

c+++++++ save samples

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

c+++++++++++++ regression coefficient information
               do j=1,p
                  thetasave(isave,j)=beta(j)
               end do

c+++++++++++++ base line information
               thetasave(isave,p+1)=mu
               thetasave(isave,p+2)=sigma2

c+++++++++++++ precision parameter information
               thetasave(isave,p+3)=alpha

c+++++++++++++ errors and predictive information
               do j=1,nrec
                  randsave(isave,j)=v(j)
               end do

               call sampupptpred(maxm,mdzero,nrec,alpha,mu,
     &                           sigma2,v,
     &                           whicho,whichn,vpred)

               randsave(isave,nrec+1)=vpred

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

               do i=1,nrec
                  loglikec=0.d0

                  vpred=v(i)

                  call condupptprior(vpred,i,maxm,mdzero,nrec,alpha,
     &                               mu,sigma2,v,
     &                               whicho,whichn,loglikec)

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

c+++++++++++++ density estimate

               do i=1,ngrid

                  loglikec=0.d0

                  call gridupptprior(grid(i),maxm,mdzero,nrec,
     &                               alpha,mu,sigma2,v,
     &                               whicho,whichn,loglikec)
                  f(i)=f(i)+exp(loglikec)
               end do

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

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ post chain analysis                                +++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

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

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

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

      mcmcad(1)=tune1
      mcmcad(2)=counterb
      mcmcad(3)=tune2(1)
      mcmcad(4)=tune2(2)
      mcmcad(5)=counterm
      mcmcad(6)=pilogestmu(1)
      mcmcad(7)=pilogestmu(2)
      mcmcad(8)=tune3(1)
      mcmcad(9)=tune3(2)
      mcmcad(10)=counters
      mcmcad(11)=pilogestsig(1)
      mcmcad(12)=pilogestsig(2)
      mcmcad(13)=tune4(1)
      mcmcad(14)=tune4(2)
      mcmcad(15)=countera
      mcmcad(16)=pilogesta(1)
      mcmcad(17)=pilogesta(2)
      mcmcad(18)=dble(nscan)

      return
      end


  MODULE simple_phys_module

  implicit none

  private
  public :: testcase_simple_phys,get_avg_uvt

!-------------------------------------------------------------------------------
!
!   Simple physics parameterizations for certain test cases
!
!     see references below for more details
!
!-------------------------------------------------------------------------------

    !  large-scale divergence:
    real, parameter :: bigd    =  3.75e-6

    !  parameters for simple radiation scheme:
    real, parameter :: qcrit   =  0.008
    real, parameter :: f0      =  70.0
    real, parameter :: f1      =  22.0
    real, parameter :: kappa   =  85.0
    real, parameter :: alphaz  =  1.0
    real, parameter :: rhoi    =  1.12

  CONTAINS

      subroutine testcase_simple_phys(mh,rho0,rr0,rf0,th0,u0,v0,     &
                   zh,zf,dum1,dum2,dum3,dum4,dum5,dum6,              &
                   ufrc,vfrc,thfrc,qvfrc,ug,vg,dvdr,                 &
                   uavg,vavg,thavg,qavg,cavg,                        &
                   ua,va,tha,qa,uten1,vten1,thten1,qten,             &
                   frad,zir,ruh,ruf,rvh,rvf)
      use input
      use constants
      implicit none

      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: mh,rho0,rr0,rf0,th0
      real, intent(in), dimension(ib:ie+1,jb:je,kb:ke) :: u0
      real, intent(in), dimension(ib:ie,jb:je+1,kb:ke) :: v0
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: zh
      real, intent(in), dimension(ib:ie,jb:je,kb:ke+1) :: zf
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: dum1,dum2,dum3,dum4,dum5,dum6
      real, intent(inout), dimension(kb:ke) :: ufrc,vfrc
      real, intent(in), dimension(kb:ke) :: thfrc,qvfrc,ug,vg,dvdr
      real, intent(inout), dimension(kb:ke) :: uavg,vavg,thavg
      real, intent(inout), dimension(kb:ke,numq) :: qavg
      double precision, intent(inout), dimension(kb:ke,3+numq) :: cavg
      real, intent(in), dimension(ib:ie+1,jb:je,kb:ke) :: ua
      real, intent(in), dimension(ib:ie,jb:je+1,kb:ke) :: va
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: tha
      real, intent(in), dimension(ibm:iem,jbm:jem,kbm:kem,numq) :: qa
      real, intent(inout), dimension(ib:ie+1,jb:je,kb:ke) :: uten1
      real, intent(inout), dimension(ib:ie,jb:je+1,kb:ke) :: vten1
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: thten1
      real, intent(inout), dimension(ibm:iem,jbm:jem,kbm:kem,numq) :: qten
      real, intent(inout), dimension(ibr:ier,jbr:jer,kbr:ker) :: frad
      real, intent(inout), dimension(ibr:ier,jbr:jer) :: zir
      real, intent(in), dimension(ib:ie) :: ruh
      real, intent(in), dimension(ib:ie+1) :: ruf
      real, intent(in), dimension(jb:je) :: rvh
      real, intent(in), dimension(jb:je+1) :: rvf

      integer :: i,j,k,n
      real :: tem

!-----------------------------------------------------------------------
!     nonprecipitating stratoCu  (Stevens et al, 2005, MWR)
!     drizzling stratoCu  (Ackerman et al, 2009, MWR)

      IF( testcase.eq.4 .or. testcase.eq.5 )THEN

        ! simple radiation (Stevens et al 2005)
        call     simplerad(rho0,zh,zf,dum1,dum2,dum3,dum4,qa,frad,zir)

        !$omp parallel do default(shared)  &
        !$omp private(i,j,k)
        do k=1,nk
        do j=1,nj
        do i=1,ni
          thten1(i,j,k) = thten1(i,j,k)-(frad(i,j,k+1)-frad(i,j,k))*rdz*mh(i,j,k)  &
                                       /(cp*rhoi)
        enddo
        enddo
        enddo

      ENDIF

!-----------------------------------------------------------------------
!     hurricane boundary layer (Bryan et al, 2017, BLM)

      IF( testcase.eq.6 )THEN

        ! get domain averages:
        call     get_avg_uvt(uavg,vavg,thavg,cavg,th0,ua,va,tha,ruh,ruf,rvh,rvf)

        tem = 1.0/hurr_rad

        !  Mesoscale Tendency terms:
        !  (radial advection and centrifugal accel terms)

        !$omp parallel do default(shared)  &
        !$omp private(i,j,k)
        DO k=1,nk
          ufrc(k) = +uavg(k)*uavg(k)*tem  &
                    +vavg(k)*v0(1,1,k)*tem
          vfrc(k) = -uavg(k)*dvdr(k)  &
                    -uavg(k)*v0(1,1,k)*tem
        ENDDO

      ENDIF

!-----------------------------------------------------------------------
      !  Add tendencies:

    IF( testcase.ge.1 )THEN

      !$omp parallel do default(shared)  &
      !$omp private(i,j,k)
      DO k=1,nk
        do j=1,nj
        do i=1,ni+1
          uten1(i,j,k) = uten1(i,j,k) + ufrc(k)
        enddo
        enddo
        do j=1,nj+1
        do i=1,ni
          vten1(i,j,k) = vten1(i,j,k) + vfrc(k)
        enddo
        enddo
        do j=1,nj
        do i=1,ni
          thten1(i,j,k) = thten1(i,j,k) + thfrc(k)
        enddo
        enddo
        IF( imoist.eq.1 )THEN
          do j=1,nj
          do i=1,ni
            qten(i,j,k,nqv) = qten(i,j,k,nqv) + qvfrc(k)
          enddo
          enddo
        ENDIF
      ENDDO

    ENDIF

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

      end subroutine testcase_simple_phys

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine get_avg_uvt(uavg,vavg,thavg,cavg,th0,ua,va,tha,ruh,ruf,rvh,rvf)
      use input
      use mpi
      implicit none

      real, intent(inout), dimension(kb:ke) :: uavg,vavg,thavg
      double precision, intent(inout), dimension(kb:ke,3+numq) :: cavg
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: th0
      real, intent(in), dimension(ib:ie+1,jb:je,kb:ke) :: ua
      real, intent(in), dimension(ib:ie,jb:je+1,kb:ke) :: va
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: tha
      real, intent(in), dimension(ib:ie) :: ruh
      real, intent(in), dimension(ib:ie+1) :: ruf
      real, intent(in), dimension(jb:je) :: rvh
      real, intent(in), dimension(jb:je+1) :: rvf

      integer :: i,j,k,n
      real :: tem
      double precision :: temd

      ! 180612:  area-weighted average
      tem = dx*dy

      ! Get domain-averages:
      do k=1,nk
        !----
        do n=1,3
          cavg(k,n) = 0.0
        enddo
        !----
        do j=1,nj
        do i=1,ni
          cavg(k,1) = cavg(k,1) + ua(i,j,k)*tem*ruf(i)*rvh(j)
          cavg(k,2) = cavg(k,2) + va(i,j,k)*tem*ruh(i)*rvf(j)
          cavg(k,3) = cavg(k,3) + (th0(i,j,k)+tha(i,j,k))*tem*ruh(i)*rvh(j)
        enddo
        enddo
        !----
      enddo

      call MPI_ALLREDUCE(MPI_IN_PLACE,cavg(kb,1),(ke-kb+1)*3       ,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)

      temd = 1.0d0/( dble(maxx-minx)*dble(maxy-miny) )

      do k=1,nk
        uavg(k)  = cavg(k,1)*temd
        vavg(k)  = cavg(k,2)*temd
        thavg(k) = cavg(k,3)*temd
      enddo

      end subroutine get_avg_uvt

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine get_avg_uvtq(uavg,vavg,thavg,qavg,cavg,th0,ua,va,tha,qa,ruh,ruf,rvh,rvf)
      use input
      use mpi
      implicit none

      real, intent(inout), dimension(kb:ke) :: uavg,vavg,thavg
      real, intent(inout), dimension(kb:ke,numq) :: qavg
      double precision, intent(inout), dimension(kb:ke,3+numq) :: cavg
      real, intent(in), dimension(ib:ie,jb:je,kb:ke)   :: th0
      real, intent(in), dimension(ib:ie+1,jb:je,kb:ke) :: ua
      real, intent(in), dimension(ib:ie,jb:je+1,kb:ke) :: va
      real, intent(in), dimension(ib:ie,jb:je,kb:ke)   :: tha
      real, intent(in), dimension(ibm:iem,jbm:jem,kbm:kem,numq) :: qa
      real, intent(in), dimension(ib:ie) :: ruh
      real, intent(in), dimension(ib:ie+1) :: ruf
      real, intent(in), dimension(jb:je) :: rvh
      real, intent(in), dimension(jb:je+1) :: rvf

      integer :: i,j,k,n
      real :: tem
      double precision :: temd

      ! 180612:  area-weighted average
      tem = dx*dy

      ! Get domain-averages:
      do k=1,nk
        !----
        do n=1,(3+numq)
          cavg(k,n) = 0.0
        enddo
        !----
        do j=1,nj
        do i=1,ni
          cavg(k,1) = cavg(k,1) + ua(i,j,k)*tem*ruf(i)*rvh(j)
          cavg(k,2) = cavg(k,2) + va(i,j,k)*tem*ruh(i)*rvf(j)
          cavg(k,3) = cavg(k,3) + (th0(i,j,k)+tha(i,j,k))*tem*ruh(i)*rvh(j)
        enddo
        enddo
        !----
        do n=1,numq
        do j=1,nj
        do i=1,ni
          cavg(k,3+n) = cavg(k,3+n) + qa(i,j,k,n)*tem*ruh(i)*rvh(j)
        enddo
        enddo
        enddo
        !----
      enddo

      call MPI_ALLREDUCE(MPI_IN_PLACE,cavg(kb,1),(ke-kb+1)*(3+numq),MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)

      temd = 1.0d0/( dble(maxx-minx)*dble(maxy-miny) )

      do k=1,nk
        uavg(k)  = cavg(k,1)*temd
        vavg(k)  = cavg(k,2)*temd
        thavg(k) = cavg(k,3)*temd
        do n=1,numq
          qavg(k,n) = cavg(k,3+n)*temd
        enddo
      enddo

      end subroutine get_avg_uvtq

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine simplerad(rho0,zh,zf,dum1,dum2,qt  ,ql  ,qa,frad,zir)
      use input
      use constants
      implicit none

      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: rho0,zh
      real, intent(in), dimension(ib:ie,jb:je,kb:ke+1) :: zf
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: dum1,dum2,qt,ql
      real, intent(in), dimension(ibm:iem,jbm:jem,kbm:kem,numq) :: qa
      real, intent(inout), dimension(ibr:ier,jbr:jer,kbr:ker) :: frad
      real, intent(inout), dimension(ibr:ier,jbr:jer) :: zir

      integer :: i,j,k,n
      real :: fr1,fr2,fr3
      integer, dimension(ni,nj) :: kzi

      do j=1,nj
      do i=1,ni
        dum2(i,j,1) = 0.0
        dum1(i,j,nk+1) = 0.0
      enddo
      enddo

      do k=1,nk
        ! qt = total water mixing ratio
        ! ql = liquid water mixing ratio
        !----
        do j=1,nj
        do i=1,ni
          ql(i,j,k) = 0.0
        enddo
        enddo
        !----
        do n=nql1,nql2
        do j=1,nj
        do i=1,ni
          ql(i,j,k) = ql(i,j,k)+qa(i,j,k,n)
        enddo
        enddo
        enddo
        !----
        do j=1,nj
        do i=1,ni
          qt(i,j,k) = qa(i,j,k,nqv)+ql(i,j,k)
          if( qt(i,j,k) .gt. qcrit ) kzi(i,j) = k
          dum2(i,j,k+1) = dum2(i,j,k) + kappa*rho0(i,j,k)*ql(i,j,k)*(zf(i,j,k+1)-zf(i,j,k))
        enddo
        enddo
        !----
      enddo

      ! interpolate:
      do j=1,nj
      do i=1,ni
        k = kzi(i,j)
        zir(i,j) = zh(i,j,k) +(zh(i,j,k+1)-zh(i,j,k))  &
                             *(      qcrit-qt(i,j,k))  &
                             /(qt(i,j,k+1)-qt(i,j,k))
      enddo
      enddo

!!!      if( myid.eq.0 )then
!!!        i = 1
!!!        j = 1
!!!        k = kzi(i,j)
!!!        print *
!!!        print *,zh(i,j,k),zir(i,j),zh(i,j,k+1)
!!!        print *,qt(i,j,k),qcrit,qt(i,j,k+1)
!!!        print *
!!!      endif

      do k=nk+1,1,-1
      do j=1,nj
      do i=1,ni
        dum1(i,j,k) = dum1(i,j,min(nk+1,k+1))  &
                + kappa*rho0(i,j,k)*ql(i,j,k)*(zf(i,j,k+1)-zf(i,j,k))
        fr1 = f0*exp(-dum1(i,j,k))
        fr2 = f1*exp(-dum2(i,j,k))
        if( zf(i,j,k).lt.zir(i,j) )then
          fr3 = 0.0
        else
          fr3 = rhoi*cp*bigd*alphaz*( 0.25*((zf(i,j,k)-zir(i,j))**1.333333)  &
                                 +zir(i,j)*((zf(i,j,k)-zir(i,j))**0.333333)  )
        endif
        frad(i,j,k) = fr1+fr2+fr3
      enddo
      enddo
      enddo

      end subroutine simplerad

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

  END MODULE simple_phys_module


SUBROUTINE p96(input_file,output_file)
!-------------------------------------------------------------------------
! Program 9.6 Plane strain consolidation analysis of a Biot elastic-plastic
!             (Mohr-Coulomb) material using 8-node rectangular
!             quadrilaterals for displacements coupled to 4-node
!             rectangular quadrilaterals for pressures.
!             Freedoms numbered in order u-v-uw. Viscoplastic strain method.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,iel,iters,j,k,limit,loaded_nodes,ndim=2,ndof=16,nels,neq,     &
   nip=4,nlen,nlfp,nls,nn,nod=8,nodf=4,nodof=3,npri,nprops=7,np_types,    &
   nr,nres,nst=4,nstep,ntot=20,nxe,nye
 REAL(iwp)::coh,cons,ddt,det,dpore,dq1,dq2,dq3,dsbar,dt,dtim,d4=4.0_iwp,  &
   d180=180.0_iwp,e,f,lode_theta,one=1.0_iwp,phi,pi,psi,sigm,snph,        &
   start_dt=1.e15_iwp,theta,time,tol,tot_load,two=2.0_iwp,v,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
 LOGICAL::converged
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::nf(:,:),g(:),num(:),g_num(:,:),g_g(:,:),etype(:),   &
   kdiag(:),no(:)
 REAL(iwp),ALLOCATABLE::al(:),ans(:),bee(:,:),bdylds(:),bload(:),c(:,:),  &
   coord(:,:),dee(:,:),der(:,:),derf(:,:),deriv(:,:),derivf(:,:),devp(:), &
   disps(:),eld(:),eload(:),eps(:),erate(:),evp(:),evpt(:,:,:),flow(:,:), &
   funf(:),g_coord(:,:),jac(:,:),kay(:,:),ke(:,:),km(:,:),kc(:,:),kv(:),  &
   lf(:,:),loads(:),m1(:,:),m2(:,:),m3(:,:),newdis(:),oldis(:),phi0(:),   &
   phi1(:),points(:,:),prop(:,:),sigma(:),store_kc(:,:,:),stress(:),      &
   tensor(:,:,:),val(:,:),vol(:),volf(:,:),weights(:),x_coords(:),        &
   y_coords(:)
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(dee(nst,nst),points(nip,ndim),coord(nod,ndim),derivf(ndim,nodf),&
   jac(ndim,ndim),kay(ndim,ndim),der(ndim,nod),deriv(ndim,nod),           &
   derf(ndim,nodf),funf(nodf),bee(nst,ndof),km(ndof,ndof),eld(ndof),      &
   sigma(nst),kc(nodf,nodf),g_g(ntot,nels),ke(ntot,ntot),c(ndof,nodf),    &
   x_coords(nxe+1),phi0(nodf),y_coords(nye+1),vol(ndof),nf(nodof,nn),     &
   volf(ndof,nodf),g_coord(ndim,nn),g_num(nod,nels),num(nod),weights(nip),&
   phi1(nodf),store_kc(nodf,nodf,nels),tensor(nst+1,nip,nels),eps(nst),   &
   evp(nst),evpt(nst,nip,nels),bload(ndof),eload(ndof),erate(nst),g(ntot),&
   devp(nst),m1(nst,nst),m2(nst,nst),m3(nst,nst),flow(nst,nst),           &
   stress(nst),etype(nels),prop(nprops,np_types))
 READ(10,*)prop,cons
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords,dtim,nstep,theta,npri,nres
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq),ans(0:neq),bdylds(0:neq),disps(0:neq),  &
   newdis(0:neq),oldis(0:neq))
 READ(10,*)loaded_nodes
 ALLOCATE(no(loaded_nodes),val(loaded_nodes,ndim))
 READ(10,*)(no(i),val(i,:),i=1,loaded_nodes)
 READ(10,*)tol,limit,nlfp
 ALLOCATE(lf(2,nlfp))
 READ(10,*)lf
 nls=FLOOR(lf(1,nlfp)/dtim)
 IF(nstep>nls)nstep=nls
 ALLOCATE(al(nstep))
 CALL load_function(lf,dtim,al)
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'x')
   g(1:15:2)=nf(1,num(:))
   g(2:16:2)=nf(2,num(:))
   g(17:20)=nf(3,num(1:7:2))
   g_g(:,iel)=g
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   CALL fkdiag(kdiag,g)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 loads=zero
 disps=zero
 tensor=zero
 kv=zero
 CALL sample(element,points,weights)
!-----------------------global matrix assembly----------------------------
 elements_2: DO iel=1,nels
   kay=zero
   DO i=1,ndim
     kay(i,i)=prop(i,etype(iel))
   END DO
   CALL deemat(dee,prop(3,etype(iel)),prop(4,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   c=zero
   kc=zero
   gauss_points_1: DO i=1,nip
!-----------------------elastic solid contribution------------------------
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     tensor(1:2,i,iel)=cons
     tensor(4,i,iel)=cons
     tensor(5,i,iel)=zero
     CALL beemat(bee,deriv)
     vol(:)=bee(1,:)+bee(2,:)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
!-----------------------fluid contribution--------------------------------
     CALL shape_fun(funf,points,i)
     CALL shape_der(derf,points,i)
     derivf=MATMUL(jac,derf)
     kc=kc+MATMUL(MATMUL(TRANSPOSE(derivf),kay),derivf)*det*weights(i)*dtim
     DO k=1,nodf
       volf(:,k)=vol(:)*funf(k)
     END DO
     c=c+volf*det*weights(i)
   END DO gauss_points_1
   store_kc(:,:,iel)=kc
   CALL formke(km,kc,c,ke,theta)
   CALL fsparv(kv,ke,g,kdiag)
 END DO elements_2
 CALL sparin_gauss(kv,kdiag) !---factorise equations----
 pi=ACOS(-one)
 dt=start_dt
 DO i=1,np_types
   phi=prop(5,i)
   snph=SIN(phi*pi/d180)
   e=prop(3,i)
   v=prop(4,i)
   ddt=d4*(one+v)*(one-two*v)/(e*(one-two*v+snph**2))
   IF(ddt<dt)dt=ddt
 END DO
!-----------------------time stepping loop--------------------------------
 oldis=zero
 time=zero
 WRITE(11,'(/A,I5)')" Results at node",nres
 WRITE(11,'(A)')                                                          &
   "    time        load        x-disp      y-disp   porepressure iters"
 WRITE(11,'(5E12.4)')0.0,0.0,0.0,0.0,0.0
 time_steps: DO j=1,nstep
   time=time+dtim
   tot_load=SUM(al(1:j))
   ans=zero
   bdylds=zero
   evpt=zero
   newdis=zero
   elements_3: DO iel=1,nels
     g=g_g(:,iel)
     kc=store_kc(:,:,iel)
     phi0=disps(g(ndof+1:))   ! gather
     phi1=MATMUL(kc,phi0)
     ans(g(ndof+1:))=ans(g(ndof+1:))+phi1   ! scatter
   END DO elements_3
   ans(0)=zero
   iters=0
!-----------------------apply loading increment---------------------------
   DO i=1,loaded_nodes
     ans(nf(1:2,no(i)))=val(i,:)*al(j)
   END DO
!-----------------------plastic iteration loop----------------------------
   its: DO
     iters=iters+1
     loads=ans+bdylds
     CALL spabac_gauss(kv,loads,kdiag)
     WRITE(*,'(A,I6,A,I4)')" time step",j,"  iteration",iters
!-----------------------check plastic convergence-------------------------
     newdis=loads
     newdis(nf(3,:))=zero
     CALL checon(newdis,oldis,tol,converged)
     IF(iters==1)converged=.FALSE.
     IF(converged.OR.iters==limit)bdylds=zero
!-----------------------go round the Gauss Points ------------------------
     elements_4: DO iel=1,nels
       num=g_num(:,iel)
       coord=TRANSPOSE(g_coord(:,num))
       phi=prop(5,etype(iel))
       coh=prop(6,etype(iel))
       psi=prop(7,etype(iel))
       g=g_g(:,iel)
       eld=loads(g(1:ndof))
       bload=zero
       CALL deemat(dee,prop(3,etype(iel)),prop(4,etype(iel)))
       gauss_points_2: DO i=1,nip
       CALL shape_der(der,points,i)
         jac=MATMUL(der,coord)
         det=determinant(jac)
         CALL invert(jac)
         deriv=MATMUL(jac,der)
         CALL beemat(bee,deriv)
         eps=MATMUL(bee,eld)
         eps=eps-evpt(:,i,iel)
         sigma=MATMUL(dee,eps)
         stress=sigma+tensor(1:4,i,iel)
         CALL invar(stress,sigm,dsbar,lode_theta)
!-----------------------check whether yield is violated-------------------
         CALL mocouf(phi,coh,sigm,dsbar,lode_theta,f)
         IF(converged.OR.iters==limit)THEN
           devp=stress
         ELSE
           IF(f>=zero)THEN
             CALL mocouq(psi,dsbar,lode_theta,dq1,dq2,dq3)
             CALL formm(stress,m1,m2,m3)
             flow=f*(m1*dq1+m2*dq2+m3*dq3)
             erate=MATMUL(flow,stress)
             evp=erate*dt
             evpt(:,i,iel)=evpt(:,i,iel)+evp
             devp=MATMUL(dee,evp)
           END IF
         END IF
         IF(f>=zero)THEN
           eload=MATMUL(TRANSPOSE(bee),devp)
           bload=bload+eload*det*weights(i)
         END IF
         IF(converged.OR.iters==limit)THEN
!--------------update the Gauss Point stresses and porepressures----------
           tensor(1:4,i,iel)=stress
           dpore=zero
           CALL shape_fun(funf,points,i)
           DO k=1,nodf
             dpore=dpore+funf(k)*loads(g(k+ndof))
           END DO
           tensor(5,i,iel)=tensor(5,i,iel)+dpore
         END IF
       END DO gauss_points_2
!-----------------------compute the total bodyloads vector ---------------
       bdylds(g(1:ndof))=bdylds(g(1:ndof))+bload
     END DO elements_4
     bdylds(0)=zero
     IF(converged.OR.iters==limit)EXIT
   END DO its
   disps=disps+loads
   IF(j/npri*npri==j.OR.iters==limit)WRITE(11,'(5E12.4,I5)')              &
     time,tot_load,disps(nf(:,nres)),iters
   IF(iters==limit)EXIT
 END DO time_steps
 CALL dismsh(loads,nf,0.05_iwp,g_coord,g_num,argv,nlen,13)
 CALL vecmsh(loads,nf,0.05_iwp,0.1_iwp,g_coord,g_num,argv,nlen,14)

END SUBROUTINE p96


*> \brief \b CSPT03
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CSPT03( UPLO, N, A, AINV, WORK, LDW, RWORK, RCOND,
*                          RESID )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            LDW, N
*       REAL               RCOND, RESID
*       ..
*       .. Array Arguments ..
*       REAL               RWORK( * )
*       COMPLEX            A( * ), AINV( * ), WORK( LDW, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CSPT03 computes the residual for a complex symmetric packed matrix
*> times its inverse:
*>    norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
*> where EPS is the machine epsilon.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the upper or lower triangular part of the
*>          complex symmetric matrix A is stored:
*>          = 'U':  Upper triangular
*>          = 'L':  Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of rows and columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX array, dimension (N*(N+1)/2)
*>          The original complex symmetric matrix A, stored as a packed
*>          triangular matrix.
*> \endverbatim
*>
*> \param[in] AINV
*> \verbatim
*>          AINV is COMPLEX array, dimension (N*(N+1)/2)
*>          The (symmetric) inverse of the matrix A, stored as a packed
*>          triangular matrix.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (LDW,N)
*> \endverbatim
*>
*> \param[in] LDW
*> \verbatim
*>          LDW is INTEGER
*>          The leading dimension of the array WORK.  LDW >= max(1,N).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*>          RCOND is REAL
*>          The reciprocal of the condition number of A, computed as
*>          ( 1/norm(A) ) / norm(AINV).
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is REAL
*>          norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex_lin
*
*  =====================================================================
      SUBROUTINE CSPT03( UPLO, N, A, AINV, WORK, LDW, RWORK, RCOND,
     $                   RESID )
*
*  -- 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 ..
      CHARACTER          UPLO
      INTEGER            LDW, N
      REAL               RCOND, RESID
*     ..
*     .. Array Arguments ..
      REAL               RWORK( * )
      COMPLEX            A( * ), AINV( * ), WORK( LDW, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ICOL, J, JCOL, K, KCOL, NALL
      REAL               AINVNM, ANORM, EPS
      COMPLEX            T
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               CLANGE, CLANSP, SLAMCH
      COMPLEX            CDOTU
      EXTERNAL           LSAME, CLANGE, CLANSP, SLAMCH, CDOTU
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          REAL
*     ..
*     .. Executable Statements ..
*
*     Quick exit if N = 0.
*
      IF( N.LE.0 ) THEN
         RCOND = ONE
         RESID = ZERO
         RETURN
      END IF
*
*     Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
      EPS = SLAMCH( 'Epsilon' )
      ANORM = CLANSP( '1', UPLO, N, A, RWORK )
      AINVNM = CLANSP( '1', UPLO, N, AINV, RWORK )
      IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
         RCOND = ZERO
         RESID = ONE / EPS
         RETURN
      END IF
      RCOND = ( ONE/ANORM ) / AINVNM
*
*     Case where both A and AINV are upper triangular:
*     Each element of - A * AINV is computed by taking the dot product
*     of a row of A with a column of AINV.
*
      IF( LSAME( UPLO, 'U' ) ) THEN
         DO 70 I = 1, N
            ICOL = ( ( I-1 )*I ) / 2 + 1
*
*           Code when J <= I
*
            DO 30 J = 1, I
               JCOL = ( ( J-1 )*J ) / 2 + 1
               T = CDOTU( J, A( ICOL ), 1, AINV( JCOL ), 1 )
               JCOL = JCOL + 2*J - 1
               KCOL = ICOL - 1
               DO 10 K = J + 1, I
                  T = T + A( KCOL+K )*AINV( JCOL )
                  JCOL = JCOL + K
   10          CONTINUE
               KCOL = KCOL + 2*I
               DO 20 K = I + 1, N
                  T = T + A( KCOL )*AINV( JCOL )
                  KCOL = KCOL + K
                  JCOL = JCOL + K
   20          CONTINUE
               WORK( I, J ) = -T
   30       CONTINUE
*
*           Code when J > I
*
            DO 60 J = I + 1, N
               JCOL = ( ( J-1 )*J ) / 2 + 1
               T = CDOTU( I, A( ICOL ), 1, AINV( JCOL ), 1 )
               JCOL = JCOL - 1
               KCOL = ICOL + 2*I - 1
               DO 40 K = I + 1, J
                  T = T + A( KCOL )*AINV( JCOL+K )
                  KCOL = KCOL + K
   40          CONTINUE
               JCOL = JCOL + 2*J
               DO 50 K = J + 1, N
                  T = T + A( KCOL )*AINV( JCOL )
                  KCOL = KCOL + K
                  JCOL = JCOL + K
   50          CONTINUE
               WORK( I, J ) = -T
   60       CONTINUE
   70    CONTINUE
      ELSE
*
*        Case where both A and AINV are lower triangular
*
         NALL = ( N*( N+1 ) ) / 2
         DO 140 I = 1, N
*
*           Code when J <= I
*
            ICOL = NALL - ( ( N-I+1 )*( N-I+2 ) ) / 2 + 1
            DO 100 J = 1, I
               JCOL = NALL - ( ( N-J )*( N-J+1 ) ) / 2 - ( N-I )
               T = CDOTU( N-I+1, A( ICOL ), 1, AINV( JCOL ), 1 )
               KCOL = I
               JCOL = J
               DO 80 K = 1, J - 1
                  T = T + A( KCOL )*AINV( JCOL )
                  JCOL = JCOL + N - K
                  KCOL = KCOL + N - K
   80          CONTINUE
               JCOL = JCOL - J
               DO 90 K = J, I - 1
                  T = T + A( KCOL )*AINV( JCOL+K )
                  KCOL = KCOL + N - K
   90          CONTINUE
               WORK( I, J ) = -T
  100       CONTINUE
*
*           Code when J > I
*
            ICOL = NALL - ( ( N-I )*( N-I+1 ) ) / 2
            DO 130 J = I + 1, N
               JCOL = NALL - ( ( N-J+1 )*( N-J+2 ) ) / 2 + 1
               T = CDOTU( N-J+1, A( ICOL-N+J ), 1, AINV( JCOL ), 1 )
               KCOL = I
               JCOL = J
               DO 110 K = 1, I - 1
                  T = T + A( KCOL )*AINV( JCOL )
                  JCOL = JCOL + N - K
                  KCOL = KCOL + N - K
  110          CONTINUE
               KCOL = KCOL - I
               DO 120 K = I, J - 1
                  T = T + A( KCOL+K )*AINV( JCOL )
                  JCOL = JCOL + N - K
  120          CONTINUE
               WORK( I, J ) = -T
  130       CONTINUE
  140    CONTINUE
      END IF
*
*     Add the identity matrix to WORK .
*
      DO 150 I = 1, N
         WORK( I, I ) = WORK( I, I ) + ONE
  150 CONTINUE
*
*     Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
*
      RESID = CLANGE( '1', N, N, WORK, LDW, RWORK )
*
      RESID = ( ( RESID*RCOND )/EPS ) / REAL( N )
*
      RETURN
*
*     End of CSPT03
*
      END


C> \brief \b CGEQRF VARIANT: left-looking Level 3 BLAS version of the algorithm.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, LWORK, M, N
*       ..
*       .. Array Arguments ..
*       COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
*       ..
*
*  Purpose
*  =======
*
C>\details \b Purpose:
C>\verbatim
C>
C> CGEQRF computes a QR factorization of a real M-by-N matrix A:
C> A = Q * R.
C>
C> This is the left-looking Level 3 BLAS version of the algorithm.
C>
C>\endverbatim
*
*  Arguments:
*  ==========
*
C> \param[in] M
C> \verbatim
C>          M is INTEGER
C>          The number of rows of the matrix A.  M >= 0.
C> \endverbatim
C>
C> \param[in] N
C> \verbatim
C>          N is INTEGER
C>          The number of columns of the matrix A.  N >= 0.
C> \endverbatim
C>
C> \param[in,out] A
C> \verbatim
C>          A is COMPLEX array, dimension (LDA,N)
C>          On entry, the M-by-N matrix A.
C>          On exit, the elements on and above the diagonal of the array
C>          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
C>          upper triangular if m >= n); the elements below the diagonal,
C>          with the array TAU, represent the orthogonal matrix Q as a
C>          product of min(m,n) elementary reflectors (see Further
C>          Details).
C> \endverbatim
C>
C> \param[in] LDA
C> \verbatim
C>          LDA is INTEGER
C>          The leading dimension of the array A.  LDA >= max(1,M).
C> \endverbatim
C>
C> \param[out] TAU
C> \verbatim
C>          TAU is COMPLEX array, dimension (min(M,N))
C>          The scalar factors of the elementary reflectors (see Further
C>          Details).
C> \endverbatim
C>
C> \param[out] WORK
C> \verbatim
C>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
C>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C> \endverbatim
C>
C> \param[in] LWORK
C> \verbatim
C>          LWORK is INTEGER
C> \endverbatim
C> \verbatim
C>          The dimension of the array WORK. The dimension can be divided into three parts.
C> \endverbatim
C> \verbatim
C>          1) The part for the triangular factor T. If the very last T is not bigger
C>             than any of the rest, then this part is NB x ceiling(K/NB), otherwise,
C>             NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T
C> \endverbatim
C> \verbatim
C>          2) The part for the very last T when T is bigger than any of the rest T.
C>             The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB,
C>             where K = min(M,N), NX is calculated by
C>                   NX = MAX( 0, ILAENV( 3, 'CGEQRF', ' ', M, N, -1, -1 ) )
C> \endverbatim
C> \verbatim
C>          3) The part for dlarfb is of size max((N-M)*K, (N-M)*NB, K*NB, NB*NB)
C> \endverbatim
C> \verbatim
C>          So LWORK = part1 + part2 + part3
C> \endverbatim
C> \verbatim
C>          If LWORK = -1, then a workspace query is assumed; the routine
C>          only calculates the optimal size of the WORK array, returns
C>          this value as the first entry of the WORK array, and no error
C>          message related to LWORK is issued by XERBLA.
C> \endverbatim
C>
C> \param[out] INFO
C> \verbatim
C>          INFO is INTEGER
C>          = 0:  successful exit
C>          < 0:  if INFO = -i, the i-th argument had an illegal value
C> \endverbatim
C>
*
*  Authors:
*  ========
*
C> \author Univ. of Tennessee
C> \author Univ. of California Berkeley
C> \author Univ. of Colorado Denver
C> \author NAG Ltd.
*
C> \date December 2016
*
C> \ingroup variantsGEcomputational
*
*  Further Details
*  ===============
C>\details \b Further \b Details
C> \verbatim
C>
C>  The matrix Q is represented as a product of elementary reflectors
C>
C>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
C>
C>  Each H(i) has the form
C>
C>     H(i) = I - tau * v * v'
C>
C>  where tau is a real scalar, and v is a real vector with
C>  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
C>  and tau in TAU(i).
C>
C> \endverbatim
C>
*  =====================================================================
      SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
*  -- LAPACK computational routine (version 3.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, J, K, LWKOPT, NB,
     $                   NBMIN, NX, LBWORK, NT, LLWORK
*     ..
*     .. External Subroutines ..
      EXTERNAL           CGEQR2, CLARFB, CLARFT, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      REAL               SCEIL
      EXTERNAL           ILAENV, SCEIL
*     ..
*     .. Executable Statements ..

      INFO = 0
      NBMIN = 2
      NX = 0
      IWS = N
      K = MIN( M, N )
      NB = ILAENV( 1, 'CGEQRF', ' ', M, N, -1, -1 )

      IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
*        Determine when to cross over from blocked to unblocked code.
*
         NX = MAX( 0, ILAENV( 3, 'CGEQRF', ' ', M, N, -1, -1 ) )
      END IF
*
*     Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.:
*
*            NB=3     2NB=6       K=10
*            |        |           |
*      1--2--3--4--5--6--7--8--9--10
*                  |     \________/
*               K-NX=5      NT=4
*
*     So here 4 x 4 is the last T stored in the workspace
*
      NT = K-SCEIL(REAL(K-NX)/REAL(NB))*NB

*
*     optimal workspace = space for dlarfb + space for normal T's + space for the last T
*
      LLWORK = MAX (MAX((N-M)*K, (N-M)*NB), MAX(K*NB, NB*NB))
      LLWORK = SCEIL(REAL(LLWORK)/REAL(NB))

      IF ( NT.GT.NB ) THEN

          LBWORK = K-NT
*
*         Optimal workspace for dlarfb = MAX(1,N)*NT
*
          LWKOPT = (LBWORK+LLWORK)*NB
          WORK( 1 ) = (LWKOPT+NT*NT)

      ELSE

          LBWORK = SCEIL(REAL(K)/REAL(NB))*NB
          LWKOPT = (LBWORK+LLWORK-NB)*NB
          WORK( 1 ) = LWKOPT

      END IF

*
*     Test the input arguments
*
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGEQRF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
      IF( NB.GT.1 .AND. NB.LT.K ) THEN

         IF( NX.LT.K ) THEN
*
*           Determine if workspace is large enough for blocked code.
*
            IF ( NT.LE.NB ) THEN
                IWS = (LBWORK+LLWORK-NB)*NB
            ELSE
                IWS = (LBWORK+LLWORK)*NB+NT*NT
            END IF

            IF( LWORK.LT.IWS ) THEN
*
*              Not enough workspace to use optimal NB:  reduce NB and
*              determine the minimum value of NB.
*
               IF ( NT.LE.NB ) THEN
                    NB = LWORK / (LLWORK+(LBWORK-NB))
               ELSE
                    NB = (LWORK-NT*NT)/(LBWORK+LLWORK)
               END IF

               NBMIN = MAX( 2, ILAENV( 2, 'CGEQRF', ' ', M, N, -1,
     $                 -1 ) )
            END IF
         END IF
      END IF
*
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
*        Use blocked code initially
*
         DO 10 I = 1, K - NX, NB
            IB = MIN( K-I+1, NB )
*
*           Update the current column using old T's
*
            DO 20 J = 1, I - NB, NB
*
*              Apply H' to A(J:M,I:I+IB-1) from the left
*
               CALL CLARFB( 'Left', 'Transpose', 'Forward',
     $                      'Columnwise', M-J+1, IB, NB,
     $                      A( J, J ), LDA, WORK(J), LBWORK,
     $                      A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1),
     $                      IB)

20          CONTINUE
*
*           Compute the QR factorization of the current block
*           A(I:M,I:I+IB-1)
*
            CALL CGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ),
     $                        WORK(LBWORK*NB+NT*NT+1), IINFO )

            IF( I+IB.LE.N ) THEN
*
*              Form the triangular factor of the block reflector
*              H = H(i) H(i+1) . . . H(i+ib-1)
*
               CALL CLARFT( 'Forward', 'Columnwise', M-I+1, IB,
     $                      A( I, I ), LDA, TAU( I ),
     $                      WORK(I), LBWORK )
*
            END IF
   10    CONTINUE
      ELSE
         I = 1
      END IF
*
*     Use unblocked code to factor the last or only block.
*
      IF( I.LE.K ) THEN

         IF ( I .NE. 1 )   THEN

             DO 30 J = 1, I - NB, NB
*
*                Apply H' to A(J:M,I:K) from the left
*
                 CALL CLARFB( 'Left', 'Transpose', 'Forward',
     $                       'Columnwise', M-J+1, K-I+1, NB,
     $                       A( J, J ), LDA, WORK(J), LBWORK,
     $                       A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1),
     $                       K-I+1)
30           CONTINUE

             CALL CGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ),
     $                   WORK(LBWORK*NB+NT*NT+1),IINFO )

         ELSE
*
*        Use unblocked code to factor the last or only block.
*
         CALL CGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ),
     $               WORK,IINFO )

         END IF
      END IF

*
*     Apply update to the column M+1:N when N > M
*
      IF ( M.LT.N .AND. I.NE.1) THEN
*
*         Form the last triangular factor of the block reflector
*         H = H(i) H(i+1) . . . H(i+ib-1)
*
          IF ( NT .LE. NB ) THEN
               CALL CLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1,
     $                     A( I, I ), LDA, TAU( I ), WORK(I), LBWORK )
          ELSE
               CALL CLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1,
     $                     A( I, I ), LDA, TAU( I ),
     $                     WORK(LBWORK*NB+1), NT )
          END IF

*
*         Apply H' to A(1:M,M+1:N) from the left
*
          DO 40 J = 1, K-NX, NB

               IB = MIN( K-J+1, NB )

               CALL CLARFB( 'Left', 'Transpose', 'Forward',
     $                     'Columnwise', M-J+1, N-M, IB,
     $                     A( J, J ), LDA, WORK(J), LBWORK,
     $                     A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
     $                     N-M)

40       CONTINUE

         IF ( NT.LE.NB ) THEN
             CALL CLARFB( 'Left', 'Transpose', 'Forward',
     $                   'Columnwise', M-J+1, N-M, K-J+1,
     $                   A( J, J ), LDA, WORK(J), LBWORK,
     $                   A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
     $                   N-M)
         ELSE
             CALL CLARFB( 'Left', 'Transpose', 'Forward',
     $                   'Columnwise', M-J+1, N-M, K-J+1,
     $                   A( J, J ), LDA,
     $                   WORK(LBWORK*NB+1),
     $                   NT, A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
     $                   N-M)
         END IF

      END IF

      WORK( 1 ) = IWS
      RETURN
*
*     End of CGEQRF
*
      END


C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Common Public License.
C
C     $Id: basics.f,v 1.1 2002/05/02 18:52:15 andreasw Exp $
C
C     Some basic routines, e.g. obtain collocation points, compute values
C     of basis polynomials.
C
C ============================================================================
C
      SUBROUTINE INITD2N(NCOL)
C !DEC$ ATTRIBUTES DLLEXPORT :: INITD2N
C
C ============================================================================
C
C     Initialization of the COMMON block /COLCOM/ in DAE2NLP.INC.
C     This routine has to be called once at the beginning.
C
C     Author:  Andreas Waechter    03-25-02
C
C     Meaning of the variables in COLCOM:
C
C     RHO       values of the collocations (Radau points in [0,1])
C     COEF      coefficients of the polynomial basis Omega;
C                 it is COEF(NCOL-i+1,q) = Omega^{(i)}_q(0)
C                 where Omega_q(0) = 0 and Omega^{(i)}_q(rho_r) = delta_{q,r}
C     OMEGAQ    value of the polynomial Omega at the collocation points RHO
C     OMEGA1    valud of the polynomial Omega at 1.d0
C
      implicit none
      integer NCOL              ! number of collocation points
C
      include 'DAE2NLP.INC'
C !DEC$ ATTRIBUTES DLLEXPORT :: /DAENLP/
C
      character*80 line
      double precision dummy
      integer i
C
C     Set collocation points
C
      if( NCOL.eq.1 ) then
         RHO(1) = 1.d0
      elseif( NCOL.eq.2 ) then
         RHO(1) = 0.3333333333333333d+00
         RHO(2) = 0.1000000000000000d+01
      elseif( NCOL.eq.3 ) then
         RHO(1) = 0.1550510257216822d+00
         RHO(2) = 0.6449489742783178d+00
         RHO(3) = 0.1000000000000000d+01
      elseif( NCOL.eq.4 ) then
         RHO(1) = 0.8858795951270395d-01
         RHO(2) = 0.4094668644407347d+00
         RHO(3) = 0.7876594617608471d+00
         RHO(4) = 0.1000000000000000d+01
      elseif( NCOL.eq.5 ) then
         RHO(1) = 0.5710419611451768d-01
         RHO(2) = 0.2768430136381238d+00
         RHO(3) = 0.5835904323689168d+00
         RHO(4) = 0.8602401356562195d+00
         RHO(5) = 0.1000000000000000d+01
      elseif( NCOL.eq.6 ) then
         RHO(1) = 0.3980985705146874d-01
         RHO(2) = 0.1980134178736082d+00
         RHO(3) = 0.4379748102473861d+00
         RHO(4) = 0.6954642733536361d+00
         RHO(5) = 0.9014649142011736d+00
         RHO(6) = 0.1000000000000000d+01
      else
         write(line,100) NCOL
 100     format(
     1   'initd2n: Error:  Invalid number of collocation points:',i4)
         call C_OUT(2,0,1,line)
         stop
      endif
C
C     Compute coefficients for the basis polynomial Omega
C
      do i = 1, NCOL
         call DCOPY(NCOL, 0.d0, 0, COEF(1,i), 1)
         COEF(NCOL-i+1,i) = 1.d0
         call SOLVEVM(NCOL, RHO, COEF(1,i))
      enddo
C
C     Compute values of basis polynomials at collocations points and 1.d0
C
      call GETPOLY(0, 1.d0, NCOL, OMEGA1, dummy)
      do i = 1, NCOL
         call GETPOLY(0, RHO(i), NCOL, OMEGAQ(1,I), dummy)
      enddo
      return
      end

C ============================================================================
C
      subroutine GETPOLY(TASK, T, NCOL, OMEGA, PHI)
C
C ============================================================================
C
C     Get value of basis polynomials at given point
C
C     Author:  Andreas Waechter    03-25-02
C
      implicit none
C
      include 'DAE2NLP.INC'
C
      integer TASK              ! 0: only OMEGA
                                ! 1: both OMEGA and PHI
      double precision T        ! point within [0,1] at which polynamial is
                                ! to be computed
      integer NCOL              ! number of collocation points
      double precision OMEGA(NCOL)
              ! omega(q) = sum( COEF(ncol-j+1,q)/(j!) s^{j-1}, j=1,ncol )
              !          = Omega_q(s) / s
      double precision PHI(NCOL)
              ! theta(q) = sum( COEF(ncol-j+1,q)/((j-1)!) s^{j-1}, j=1,ncol )
              !          = Omega_q^{(1)}(s)
              !          = Theta_q (s)

      double precision tmp(NCOLD2NMAX), sum
      integer j, q

      do j = 1, NCOL
         tmp(j) = T/dble(NCOL+1-j)
      enddo
C
C     Compute OMEGAs
C
      do q = 1, NCOL
         sum = COEF(1,q)
         do j = 2, NCOL
            sum = sum*tmp(j-1) + COEF(j,q)
         enddo
         OMEGA(q)=sum
      enddo
C
C     Compute PHIs
C
      if( TASK.eq.1 ) then
         do q = 1, NCOL
            sum = COEF(1,q)
            do j = 2, NCOL
               sum = sum*tmp(j) + COEF(j,q)
            enddo
            PHI(q)=sum
         enddo
      endif

      return
      end

C ============================================================================
C
      subroutine SOLVEVM( NCOL, RHO, F )
C
C ============================================================================
C
C     Solving Vandermonde System for polynomial interpolation
C     (based on Algorithm 4.6.1 in Golub and van Loan)
C
C     Author:  Andreas Waechter    03-25-02
C
      implicit none
      integer NCOL               ! number of collocation points
      double precision RHO(NCOL) ! collocation points
      double precision F(NCOL)   ! In:  RHS  Out: Solution
C
C     Here we solve
C
C     sum(i=0..NCOL-1, F_out(NCOL+1-i) * RHO(j)**(i-1)/(i-1)!)
C      = F_in(NCOL+1-i)
C
      integer k, i
      do k = 1, NCOL-1
         do i = NCOL, k+1, -1
            F(NCOL+1-i) = (F(NCOL+1-i)-F(NCOL+2-i))/(RHO(i)-RHO(i-k))
         enddo
      enddo
      do k = NCOL-1, 1, -1
         do i = k, NCOL-1
            F(NCOL+1-i) = F(NCOL+1-i) - F(NCOL-i)*RHO(k)
         enddo
      enddo
C     correct the factorials
      i = 1
      do k = 2, NCOL-1
         i = i * k
         F(NCOL-k) = F(NCOL-k) * dble(i)
      enddo

      return
      end

C ============================================================================
C
      SUBROUTINE APPROX (TASK, NZ, NY, NU, NE, NCOL, COEF, W, U, TI,
     1     IELE, T, OMEGA, PHI, ZVAL, YVAL, UVAL)
C
C ============================================================================
C
C     A.Waechter, 9-15-00
C
C       evaluate Z (and maybe Y and U) on time T based interpolation in
C          element IELE; results in ZVAL, YVAL, UVAL
C
C   variables
C
C     TASK     1: compute Z at collocation point with basis-function values
C                 OMEGA
C              2: compute Z at T (OMEGA will be overwritten)
C              3: compute Z,Y,U at T (OMEGA, PHI will be overwritten)
C              4: compute dZ at T (OMEGA, PHI will be overwritten)
C                    (result in ZVAL)
C     COEF     from INITCOLCOM
C     TI       element boundaries
C     W        [Z at beinning of element, Zdot at first col point, Y at
C               first col point, ..., Zdot at last col point, Y at last col
C               point]
C     U        [U at first col point, .., U at last col point]
C     IELE     number of element in which T is
C
      implicit none
      integer TASK, NZ, NY, NU, NE, NCOL
      double precision COEF(*)
      double precision W(NZ+NCOL*(NZ+NY))
      double precision U(NCOL*NU)
      double precision TI(NE+1)
      integer IELE
      double precision T, OMEGA(NCOL), PHI(NCOL)
      double precision ZVAL(NZ)
      double precision YVAL(NY)
      double precision UVAL(NU)

      double precision s, del_t, sum
      integer task2, lw, lu, i, j
C
C     If necessary compute RK basis
C
      if( TASK.ne.1 ) then
         s = (T - TI(IELE))/(TI(IELE+1) - TI(IELE))
         if( TASK.eq.2 ) then
            task2 = 0
         else
            task2 = 1
         endif
         call GETPOLY(task2, s, NCOL, OMEGA, PHI)
      endif
C
C     Compute values of Z
C
      if( TASK.ne.4 ) then
         del_t = T - TI(IELE)
         do i = 1, NZ
            lw = NZ + i
            sum = 0.d0
            do j = 1, NCOL
               sum = sum + OMEGA(j)*W(lw)
               lw = lw + NZ+NY
            enddo
            ZVAL(i) = sum*del_t + W(i)
         enddo
      endif
C
C     Compute values of Y and U
C
      if( TASK.eq.3 ) then
         do i = 1, NY
            lw = NZ + NZ + i
            sum = 0.d0
            do j = 1, NCOL
               sum = sum + PHI(j)*W(lw)
               lw = lw + NZ+NY
            enddo
            YVAL(i) = sum
         enddo
         do i = 1, NU
            lu = i
            sum = 0.d0
            do j = 1, NCOL
               sum = sum + PHI(j)*U(lu)
               lu = lu + NU
            enddo
            UVAL(i) = sum
         enddo
      endif
C
C     Compute values of dZ
C
      if( TASK.eq.4 ) then
         do i = 1, NZ
            lw = NZ + i
            sum = 0.d0
            do j = 1, NCOL
               sum = sum + PHI(j)*W(lw)
               lw = lw + NZ+NY
            enddo
            ZVAL(i) = sum
         enddo
      endif

      return
      end


! ============================================================================
! Name        : parameter_copt_run.f90
! Author      : Kei Hasegawa, Kensuke Konishi
! Version     : 0.0.1
! Copyright   : It is Complicated.
! Description : Parameter set for 2dwave
! ============================================================================

module parameter_2dwave

  implicit none
! model
  character(len=32) :: modelfile = 'kmodel.csv'
  logical :: header_model = .true.
  namelist /structure/modelfile, header_model

! size of region
  double precision :: X_size = 8.d0
  double precision :: Y_size = 4.d0
! number of boxes in the region
  integer :: NX = 600
  integer :: NY = 300
  namelist/geometry/X_size, Y_size, NX, NY

! Information for source
  !location
  double precision :: X_source = 1.0d0
  double precision :: Y_source = 3.9d0

  logical :: source_type_single = .false.
  double precision :: vx = 1.d0
  double precision :: vy = 0.d0

  logical :: source_type_double_couple = .true.
  double precision :: mxx = 1.d0
  double precision :: mxy = 0.d0
  double precision :: myx = 0.d0
  double precision :: myy = 1.d0
  namelist/source/X_source, Y_source, source_type_single, source_type_double_couple, &
    vx,vy, mxx, mxy, myx, myy

!time length [s]
  double precision :: tlen = 10.d0
!central period of ricker function [s]
  double precision :: tp = 1.d0/ 6.5d0
!shift time [s]
!  double precision :: ts = 2.d0 * tp
  double precision :: ts = 2.d0 * 1 /6.5d0
  double precision :: CFL = 0.3d0
  double precision :: maxvp = 2.8d0
  namelist/computation/ tlen, tp, ts, CFL, maxvp

  logical :: use_Cerjan = .false.
  integer :: N_Cerjan = 5
  double precision :: dumping_rate_Cerjan = 0.0001d0
  namelist/cerjan/use_Cerjan, N_Cerjan, dumping_rate_Cerjan

  character(:), allocatable :: arg

  logical :: need_snapshot = .true.
  integer :: NT_snap = 100
  !should be four outputs (x y ux uy)
  character(12) :: snap_format = '(4G15.5)'
  logical :: need_waveform = .true.
  !should be three outputs (t ux uy)
  character(12) :: wave_format = '(3G15.5)'
!number of recievers
  integer :: num_rec
!recievers names and the locations (X,Y) are included  station
  character(len=32) :: recinfo = 'recinfo.csv'
  logical :: header_recinfo = .false.
  namelist/output/need_snapshot, NT_snap, snap_format, &
            need_waveform, wave_format, recinfo, header_recinfo

!----------------CPML settings-------------------------------------
  integer :: NX_CPML_lef, NX_CPML_rig, NY_CPML_btm
  double precision :: reflection_rate = 0.001d0
!  double precision :: source_freq = 1.1283791671d0 / tp
  double precision :: source_freq = 1.1283791671d0 *6.5
  integer :: NPOWER = 2
  namelist /cpml/NX_CPML_lef,NX_CPML_rig, NY_CPML_btm,reflection_rate,source_freq, NPOWER
!-----------CPML END--------------------------------------------------------
  contains

    subroutine read_parameter
      implicit none
      print *, 'Reading the input file'
      open (1, file=arg, status='old')
      read (1, structure)
      read (1, geometry)
      read (1, source)
      read (1, computation)
      read (1, cerjan)
      read (1, output)
      read (1, cpml)
      close (1)
    end subroutine read_parameter

    subroutine output_parameter
       write(*,structure)
       write(*,geometry)
       write(*,source)
       write(*,computation)
       write(*,cerjan)
       write(*,output)
       write(*,cpml)
    end subroutine output_parameter

    subroutine get_arguments
      integer :: i, length, status, nargs
      intrinsic :: command_argument_count, get_command_argument
      if (command_argument_count() > 1) stop 'Only one argument (input file name) is available'
      if (command_argument_count() == 0) stop 'Input file name is required'

      call get_command_argument(1, length = length, status = status)
      if (status == 0) then
        allocate (character(length) :: arg)
        call get_command_argument(1, arg, status = status)
        if (status == 0) print *, 'Input file is "', arg, '"'
!        deallocate (arg)
      end if
      if (status /= 0) stop 'Error on argument'
    end subroutine get_arguments

end module parameter_2dwave


subroutine fill_nmm_grid2(gin,nx,ny,gout,igtype,iorder)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    fill_nmm_grid2         fill holes in (wrf) nmm e-grid
!   prgmmr: parrish          org: np22                date: 2004-06-22
!
! abstract: creates an unstaggered A grid from the staggered E grid used
!           by the wrf nmm.  This is done by interpolation to fill the
!           holes in the E grid.  This is necessary because the gsi is
!           not yet able to work with anything other than unstaggered
!           grids.  This solution minimizes additional interpolation error
!           but doubles the number of grid points.  This routine will be
!           eliminated when the gsi has the capability to work directly
!           with staggered grids.
!
! program history log:
!   2004-06-22  parrish, document
!   2013-10-25  todling - reposition ltosi and others to commvars
!
!   input argument list:
!     gin      - input staggered E grid field over entire horizontal domain
!     nx,ny    - input grid dimensions
!     igtype   - =1, then (1,1) on staggered grid is at corner of grid
!                (mass point for nmm)
!              - =2, then (1,1) is staggered (wind point for nmm,
!                see illustration below)
!
!                   igtype=1:
!
!
!
!       ^   3             x     x     x     x
!       |
!       y   2                x     x     x     x
!
!           1             x     x     x     x
!
!                         1     2     3
!
!                           x -->
!
!                   igtype=2:
!
!
!
!       ^   3             x     x     x     x
!       |
!       y   2          x     x     x     x
!
!           1             x     x     x     x
!
!                         1     2     3
!
!                           x -->
!
!   output argument list
!     gout     - output filled grid  (reorganized for distibution to local domains)
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds, only: r_single,r_kind,i_kind
  use constants, only: zero_single
  use gridmod, only: iglobal,itotsub
  use general_commvars_mod, only: ltosj,ltosi,ltosj_s,ltosi_s

  implicit none

  integer(i_kind),intent(in   ) :: nx,ny,igtype,iorder
  real(r_single) ,intent(in   ) :: gin(nx,ny)
  real(r_single) ,intent(  out) :: gout(itotsub)

  real(r_single) b(2*nx-1,ny)
  integer(i_kind) i,im,ip,j,jm,jp
  real(r_single) fill,test

  fill=0.95_r_kind*huge(fill) ; test=0.95_r_kind*fill
  do j=1,ny
     do i=1,2*nx-1
        b(i,j)=fill
     end do
  end do

! First transfer all staggered points to appropriate
! points on filled output grid
  if(igtype==1) then
     do j=1,ny,2
        do i=1,nx
           b(2*i-1,j)=gin(i,j)
        end do
     end do
     do j=2,ny,2
        do i=1,nx-1
           b(2*i,j)=gin(i,j)
        end do
     end do
  else
     do j=1,ny,2
        do i=1,nx-1
           b(2*i,j)=gin(i,j)
        end do
     end do
     do j=2,ny,2
        do i=1,nx
           b(2*i-1,j)=gin(i,j)
        end do
     end do
  end if

!  Now fill in holes

! Top and bottom rows:
  do j=1,ny,ny-1
     do i=1,2*nx-1
        if(b(i,j)>test) then
           ip=i+1 ; if(ip>2*nx-1) ip=i-1
           im=i-1 ; if(im<1) im=i+1
           b(i,j)=0.5_r_single*(b(im,j)+b(ip,j))
        end if
     end do
  end do

! Left and right rows:
  do j=1,ny
     jp=j+1 ; if(jp>ny)   jp=j-1
     jm=j-1 ; if(jm<1) jm=j+1
     do i=1,2*nx-1,2*nx-2
        if(b(i,j)>test) b(i,j)=0.5_r_single*(b(i,jm)+b(i,jp))
     end do
  end do

! Interior points
  do j=1,ny
     jp=j+1 ; if(jp>ny) jp=j-1
     jm=j-1 ; if(jm<1) jm=j+1
     do i=1,2*nx-1
        if(b(i,j)>test) then
           ip=i+1 ; if(ip>2*nx-1) ip=i-1
           im=i-1 ; if(im<1)      im=i+1
           b(i,j)=0.25_r_single*(b(ip,j)+b(im,j)+b(i,jp)+b(i,jm))
        end if
     end do
  end do

! Reorganize for eventual distribution to local domains
  do i=1,itotsub
     gout(i)=zero_single
  end do
  if(iorder==1)then
     do i=1,itotsub
        gout(i)=b(ltosj_s(i),ltosi_s(i))
     end do
  else
     do i=1,iglobal
        gout(i)=b(ltosj(i),ltosi(i))
     end do
  endif

end subroutine fill_nmm_grid2


      implicit none
      include 'types.f'
      include 'qpconstants.f'
      complex(kind=qp) qpI1,qpI2,qpI3,qpI4,Ival(-2:0)
      double complex qlI1,qlI2,qlI3,qlI4,Ivald(-2:0)
      real(kind=qp)  p1sq,p2sq,p3sq,p4sq,s12,s23,
     . m1sq,m2sq,m3sq,m4sq,musq
      integer ep
      call qpinit
      call qlinit
      musq=1.1_qp
      m1sq=3._qp
      m2sq=5._qp
      m3sq=9._qp
      m4sq=1.3_qp
      p1sq=1.5_qp
      p2sq=-1.7_qp
      p3sq=2.3_qp
      p4sq=2.9_qp
      s12=37._qp
      s23=-15.7_qp

c      write(6,*) 'Tadpole'
c      Ivald(-2:0)=complex(0d0,0d0)
c      do ep=-1,0
c      Ival(ep)=qpI1(m1sq,musq,ep)
c      Ivald(ep)=qlI1(dble(m1sq),dble(musq),ep)
c      write(6,*) ep,Ival(ep)/Ivald(ep)
c      enddo

c      write(6,*) 'Bubble'
c      do ep=-1,0
c      Ival(ep)=qpI2(p1sq,m1sq,m2sq,musq,ep)
c      Ivald(ep)=qlI2(dble(p1sq),dble(m1sq),dble(m2sq),dble(musq),ep)
c      write(6,*) ep,Ival(ep)/Ivald(ep)
c      enddo

      write(6,*) 'Triangle'
      do ep=0,0
      Ival(ep)=
     & qpI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
      Ivald(ep)=qlI3(dble(p1sq),dble(p2sq),dble(p3sq),
     & dble(m1sq),dble(m2sq),dble(m3sq),dble(musq),ep)
      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

c      write(6,*) 'Box'
c      do ep=0,0
c      Ival(ep)=
c     . qpI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,musq,ep)
c      Ivald(ep)=qlI4(dble(p1sq),dble(p2sq),dble(p3sq),dble(p4sq),
c     & dble(s12),dble(s23),
c     & dble(m1sq),dble(m2sq),dble(m3sq),dble(m4sq),dble(musq),ep)

c      write(6,*) ep,Ival(ep)/Ivald(ep),Ivald(ep)
c      enddo

      write(6,*)
      write(6,*) 'Divergent integrals'
      write(6,*) 'Triangle 1'
      do ep=-2,0
      Ival(ep)=qpI3(zip,zip,p3sq,zip,zip,zip,musq,ep)
      Ivald(ep)=qlI3(0d0,0d0,dble(p3sq),0d0,0d0,0d0,dble(musq),ep)
      write(6,*)
     . ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Triangle 2'
      do ep=-2,0
      Ival(ep)=qpI3(zip,p2sq,p3sq,zip,zip,zip,musq,ep)
      Ivald(ep)=qlI3(0d0,dble(p2sq),dble(p3sq),
     & 0d0,0d0,0d0,dble(musq),ep)
      write(6,*)
     . ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Triangle 3'
      do ep=-2,0
      Ival(ep)=qpI3(zip,p2sq,p3sq,zip,zip,m3sq,musq,ep)
      Ivald(ep)=qlI3(0d0,dble(p2sq),dble(p3sq),
     & 0d0,0d0,dble(m3sq),dble(musq),ep)
      write(6,*)
     . ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Triangle 4'
      do ep=-2,0
      Ival(ep)=qpI3(zip,p2sq,m3sq,zip,zip,m3sq,musq,ep)
      Ivald(ep)=qlI3(0d0,dble(p2sq),dble(m3sq),
     & 0d0,0d0,dble(m3sq),dble(musq),ep)
      write(6,*)
     . ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Triangle 5'
      do ep=-2,0
      Ival(ep)=qpI3(zip,p2sq,m3sq,zip,zip,m3sq,musq,ep)
      Ivald(ep)=qlI3(0d0,dble(p2sq),dble(m3sq),
     & 0d0,0d0,dble(m3sq),dble(musq),ep)
      write(6,*)
     . ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Triangle 6'
      do ep=-2,0
      Ival(ep)=qpI3(m2sq,zip,m3sq,zip,m2sq,m3sq,musq,ep)
      Ivald(ep)=qlI3(dble(m2sq),0d0,dble(m3sq),
     & 0d0,dble(m2sq),dble(m3sq),dble(musq),ep)
      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box1'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,zip,zip,zip,s12,s23,zip,zip,zip,zip,musq,ep)
      Ivald(ep)=qlI4(0d0,0d0,0d0,0d0,
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,0d0,dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box2'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,zip,zip,p4sq,s12,s23,zip,zip,zip,zip,musq,ep)
      Ivald(ep)=qlI4(0d0,0d0,0d0,dble(p4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,0d0,dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box3'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,zip,zip,p4sq,s12,s23,zip,zip,zip,zip,musq,ep)
      Ivald(ep)=qlI4(0d0,0d0,0d0,dble(p4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,0d0,dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box4'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,p2sq,zip,p4sq,s12,s23,zip,zip,zip,zip,musq,ep)
      Ivald(ep)=qlI4(0d0,dble(p2sq),0d0,dble(p4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,0d0,dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box5'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,p2sq,p3sq,p4sq,s12,s23,zip,zip,zip,zip,musq,ep)
      Ivald(ep)=qlI4(0d0,dble(p2sq),dble(p3sq),dble(p4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,0d0,dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box6'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,zip,m4sq,m4sq,s12,s23,zip,zip,zip,m4sq,musq,ep)
      Ivald(ep)=qlI4(0d0,0d0,dble(m4sq),dble(m4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,dble(m4sq),dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box7'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,zip,m4sq,p4sq,s12,s23,zip,zip,zip,m4sq,musq,ep)
      Ivald(ep)=qlI4(0d0,0d0,dble(m4sq),dble(p4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,dble(m4sq),dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box8'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,zip,p3sq,p4sq,s12,s23,zip,zip,zip,m4sq,musq,ep)
      Ivald(ep)=qlI4(0d0,0d0,dble(p3sq),dble(p4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,dble(m4sq),dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box9'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,p2sq,p3sq,m4sq,s12,s23,zip,zip,zip,m4sq,musq,ep)
      Ivald(ep)=qlI4(0d0,dble(p2sq),dble(p3sq),dble(m4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,dble(m4sq),dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box10'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,p2sq,p3sq,p4sq,s12,s23,zip,zip,zip,m4sq,musq,ep)
      Ivald(ep)=qlI4(0d0,dble(p2sq),dble(p3sq),dble(p4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,dble(m4sq),dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box11'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,p2sq,p3sq,p4sq,s12,s23,zip,zip,zip,m4sq,musq,ep)
      Ivald(ep)=qlI4(0d0,dble(p2sq),dble(p3sq),dble(p4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,dble(m4sq),dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box12'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,m3sq,p3sq,p4sq,s12,s23,zip,zip,m3sq,m4sq,musq,ep)
      Ivald(ep)=qlI4(0d0,dble(m3sq),dble(p3sq),dble(p4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,dble(m3sq),dble(m4sq),dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box13'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,p2sq,p3sq,p4sq,s12,s23,zip,zip,m3sq,m4sq,musq,ep)
      Ivald(ep)=qlI4(0d0,dble(p2sq),dble(p3sq),dble(p4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,dble(m3sq),dble(m4sq),dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box14'
      do ep=-2,0
      Ival(ep)=
     .qpI4(zip,p2sq,p3sq,p4sq,s12,s23,zip,zip,zip,m4sq,musq,ep)
      Ivald(ep)=qlI4(0d0,dble(p2sq),dble(p3sq),dble(p4sq),
     & dble(s12),dble(s23),
     & 0d0,0d0,0d0,dble(m4sq),dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box15'
      do ep=-2,0
      Ival(ep)=
     .qpI4(m2sq,p2sq,p3sq,m4sq,s12,s23,zip,m2sq,zip,m4sq,musq,ep)
      Ivald(ep)=qlI4(dble(m2sq),dble(p2sq),dble(p3sq),dble(m4sq),
     & dble(s12),dble(s23),
     & 0d0,dble(m2sq),0d0,dble(m4sq),dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      write(6,*) 'Box16'
      do ep=-2,0
      Ival(ep)=
     . qpI4(m2sq,p2sq,p3sq,m4sq,s12,s23,zip,m2sq,m3sq,m4sq,musq,ep)
      Ivald(ep)=qlI4(dble(m2sq),dble(p2sq),dble(p3sq),dble(m4sq),
     & dble(s12),dble(s23),
     & 0d0,dble(m2sq),dble(m3sq),dble(m4sq),dble(musq),ep)

      write(6,*) ep,Ival(ep)/Ivald(ep)
      enddo

      stop
      end


      subroutine gg_h_z(p,z)
      implicit none
      include 'constants.f'
      include 'qcdcouple.f'
      include 'scale.f'
      include 'PR_new.f'
      include 'agq.f'
      integer is
      double precision z,p(mxpart,4),xl12,dot,ii_gg,ii_gq,tempgg,tempgq

      xl12=log(two*dot(p,1,2)/musq)

      do is=1,3
      tempgg=ason4pi*2d0*xn*ii_gg(z,xl12,is)
      tempgq=ason4pi*2d0*cf*ii_gq(z,xl12,is)
      Q1(g,g,g,is)=tempgg
      Q2(g,g,g,is)=tempgg

      Q1(g,q,g,is)=tempgq
      Q1(g,a,g,is)=tempgq

      Q2(g,q,g,is)=tempgq
      Q2(g,a,g,is)=tempgq
      enddo
      return
      end


      SUBROUTINE UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,
     1 RPL,DDSDDT,DRPLDE,DRPLDT,
     2 STRAN,DSTRAN,TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,CMNAME,
     3 NDI,NSHR,NTENS,NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,
     4 CELENT,DFGRD0,DFGRD1,NOEL,NPT,LAYER,KSPT,KSTEP,KINC)
C
      INCLUDE 'ABA_PARAM.INC'
C
      CHARACTER*80 CMNAME

      DIMENSION STRESS(NTENS),STATEV(NSTATV),
     1 DDSDDE(NTENS,NTENS),DDSDDT(NTENS),DRPLDE(NTENS),
     2 STRAN(NTENS),DSTRAN(NTENS),TIME(2),PREDEF(1),DPRED(1),
     3 PROPS(NPROPS),COORDS(3),DROT(3,3),DFGRD0(3,3),DFGRD1(3,3),
     4 JSTEP(4)
C     ELASTIC USER SUBROUTINE
      PARAMETER(ONE=1.0D0,TWO=2.0D0)
       E = PROPS(1)
        ANU = PROPS(2)
       ALAMDA = E*ANU/(ONE+ANU)/(ONE-TWO*ANU)
       AMU = E/(ONE+ANU)/2
         DO I=1,NTENS
          DO J=1,NTENS
          DDSDDE(I,J)=0.0D0
          ENDDO
         ENDDO
        DDSDDE(1,1)=(ALAMDA+TWO*AMU)
        DDSDDE(2,2)=(ALAMDA+TWO*AMU)
        DDSDDE(3,3)=(ALAMDA+TWO*AMU)
        DDSDDE(4,4)=AMU
        DDSDDE(5,5)=AMU
        DDSDDE(6,6)=AMU
        DDSDDE(1,2)=ALAMDA
        DDSDDE(1,3)=ALAMDA
        DDSDDE(2,3)=ALAMDA
        DDSDDE(2,1)=ALAMDA
        DDSDDE(3,1)=ALAMDA
        DDSDDE(3,2)=ALAMDA
         DO I=1,NTENS
          DO J=1,NTENS
          STRESS(I)=STRESS(I)+DDSDDE(I,J)*DSTRAN(J)
          ENDDO
         ENDDO
      RETURN
      END