!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine linel(kode,mattyp,beta,emec,stre,elas,elconloc,
     &  iorien,orab,pgauss)
!
!     calculates stresses for linear elastic materials
!
      implicit none
!
      integer mattyp,j1,j2,j3,j4,j5,j6,j7,j8,j,jj,kel(4,21),
     &  iorien,i,kode
!
      real*8 beta(6),elas(21),stre(6),fxx,fyy,fzz,fxy,fxz,fyz,
     &  elconloc(*),emax,ya(3,3,3,3),orab(7,*),skl(3,3),e,un,
     &  um,um2,al,am1,pgauss(3),emec(6)
!
      kel=reshape((/1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3,
     &          1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,
     &          3,3,1,3,1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,
     &          1,2,2,3,1,3,2,3,2,3,2,3/),(/4,21/))
!
!     engineering strain
!
      fxx=emec(1)
      fyy=emec(2)
      fzz=emec(3)
      fxy=2.d0*emec(4)
      fxz=2.d0*emec(5)
      fyz=2.d0*emec(6)
!
      if(kode.eq.2) then
!
!        isotropic
!
         do i=1,2
            elas(i)=elconloc(i)
         enddo
!
         e=elas(1)
         un=elas(2)
         um2=e/(1.d0+un)
         al=un*um2/(1.d0-2.d0*un)
         um=um2/2.d0
         am1=al+um2
!
         stre(1)=am1*fxx+al*(fyy+fzz)-beta(1)
         stre(2)=am1*fyy+al*(fxx+fzz)-beta(2)
         stre(3)=am1*fzz+al*(fxx+fyy)-beta(3)
         stre(4)=um*fxy-beta(4)
         stre(5)=um*fxz-beta(5)
         stre(6)=um*fyz-beta(6)
!
         mattyp=1
!
      elseif((kode.eq.9).or.(kode.eq.21)) then
!
         if((kode.eq.9).and.(iorien.eq.0)) then
!
!           orthotropic
!
            do i=1,9
               elas(i)=elconloc(i)
            enddo
            do i=10,21
               elas(i)=0.d0
            enddo
!
            stre(1)=elas(1)*fxx+elas(2)*fyy+
     &           elas(4)*fzz-beta(1)
            stre(2)=elas(2)*fxx+elas(3)*fyy+
     &           elas(5)*fzz-beta(2)
            stre(3)=elas(4)*fxx+elas(5)*fyy+
     &           elas(6)*fzz-beta(3)
            stre(4)=elas(7)*fxy-beta(4)
            stre(5)=elas(8)*fxz-beta(5)
            stre(6)=elas(9)*fyz-beta(6)
!
            mattyp=2
!
         else
!
            do i=1,21
               elas(i)=elconloc(i)
            enddo
!
            mattyp=3
!
            if(iorien.ne.0) then
!
!              calculating the transformation matrix
!
               call transformatrix(orab(1,iorien),pgauss,skl)
!
!              transforming the elastic coefficients
!
               if(kode.eq.9) then
                  call orthotropic(elas,ya)
               else
                  call anisotropic(elas,ya)
               endif
!
               do jj=1,21
                  j1=kel(1,jj)
                  j2=kel(2,jj)
                  j3=kel(3,jj)
                  j4=kel(4,jj)
                  elas(jj)=0.d0
                  do j5=1,3
                     do j6=1,3
                        do j7=1,3
                           do j8=1,3
                              elas(jj)=elas(jj)+ya(j5,j6,j7,j8)*
     &                             skl(j1,j5)*skl(j2,j6)*skl(j3,j7)*
     &                             skl(j4,j8)
                           enddo
                        enddo
                     enddo
                  enddo
               enddo
!
!              determining the type: orthotropic or anisotropic
!
               emax=0.d0
               do j=1,21
                  emax=max(emax,dabs(elas(j)))
               enddo
               do j=7,9
                  if(dabs(elas(j)).gt.emax*1.d-10) then
                     emax=-1.d0
                     exit
                  endif
               enddo
               if(emax.ge.0.d0) then
                  do j=11,14
                     if(dabs(elas(j)).gt.emax*1.d-10) then
                        emax=-1.d0
                        exit
                     endif
                  enddo
               endif
               if(emax.ge.0.d0) then
                  do j=16,20
                     if(dabs(elas(j)).gt.emax*1.d-10) then
                        emax=-1.d0
                        exit
                     endif
                  enddo
               endif
               if(emax.ge.0.d0) then
                  elas(7)=elas(10)
                  elas(8)=elas(15)
                  elas(9)=elas(21)
!
                  do j=10,21
                     elas(j)=0.d0
                  enddo
c                  elas(10)=0.d0
c                  elas(15)=0.d0
c                  elas(21)=0.d0
!
                  mattyp=2
               endif
            endif
!
            if(mattyp.eq.2) then
!
!              orthotropic
!
               stre(1)=elas(1)*fxx+elas(2)*fyy+
     &              elas(4)*fzz-beta(1)
               stre(2)=elas(2)*fxx+elas(3)*fyy+
     &              elas(5)*fzz-beta(2)
               stre(3)=elas(4)*fxx+elas(5)*fyy+
     &              elas(6)*fzz-beta(3)
               stre(4)=elas(7)*fxy-beta(4)
               stre(5)=elas(8)*fxz-beta(5)
               stre(6)=elas(9)*fyz-beta(6)
            else
!
!              fully anisotropic
!
               stre(1)=elas(1)*fxx+
     &              elas(2)*fyy+
     &              elas(4)*fzz+
     &              elas(7)*fxy+
     &              elas(11)*fxz+
     &              elas(16)*fyz-beta(1)
               stre(2)=elas(2)*fxx+
     &              elas(3)*fyy+
     &              elas(5)*fzz+
     &              elas(8)*fxy+
     &              elas(12)*fxz+
     &              elas(17)*fyz-beta(2)
               stre(3)=elas(4)*fxx+
     &              elas(5)*fyy+
     &              elas(6)*fzz+
     &              elas(9)*fxy+
     &              elas(13)*fxz+
     &              elas(18)*fyz-beta(3)
               stre(4)=elas(7)*fxx+
     &              elas(8)*fyy+
     &              elas(9)*fzz+
     &              elas(10)*fxy+
     &              elas(14)*fxz+
     &              elas(19)*fyz-beta(4)
               stre(5)=elas(11)*fxx+
     &              elas(12)*fyy+
     &              elas(13)*fzz+
     &              elas(14)*fxy+
     &              elas(15)*fxz+
     &              elas(20)*fyz-beta(5)
               stre(6)=elas(16)*fxx+
     &              elas(17)*fyy+
     &              elas(18)*fzz+
     &              elas(19)*fxy+
     &              elas(20)*fxz+
     &              elas(21)*fyz-beta(6)
!
            endif
         endif
      endif
!
      return
      end


c rebin a spectrum from linear into log w space

      subroutine logrebin(spec,nsp,w0,dw,nslog,w0log,dwlog,slog)

      real spec(nsp), slog(nslog)
      real w0,dw,w0log,dwlog
      integer nsp,nslog

      include 'pcredshift.h'

c      wmin = w0 + 0.5*dw
c      wmax = w0 + (nsp+0.5)*dw

c  assume that the bins of both linear and log spectra
c  are centered on the appropriate wavelength values.
c  this means throwing around a lot of 0.5's to get the
c  bin boundary values.

      do i=1,nslog
         fsum = 0.0
         wtgood = 0.0
         wtbad = 0.0
c  boundaries of log bin
         w1 = 10**(w0log + (i-0.5)*dwlog)
         w2 = 10**(w0log + (i+0.5)*dwlog)
c  corresponding pixel coords in the linear spectrum
         r1 = (w1-w0)/dw
         r2 = (w2-w0)/dw
c compute what lin bin the log boundaries fall in
c         j1 = int( (w1-w0)/dw +0.5 )
c         j2 = int( (w2-w0)/dw +0.5 )
         j1 = int(r1+0.5)
         j2 = int(r2+0.5)
c if we're completely out of the region where there is data in
c the linear spectrum, bail
         if (j2 .lt. 1 .or. j1 .gt. nsp) go to 200

c just trimming to the min/max is not ideal but leave it for now
         j1 = min(max(j1,1),nsp)
         j2 = min(max(j2,1),nsp)
c         frac1 = (w1 - (w0+(j1-0.5)*dw)) / dw
c         frac2 = (w2 - (w0+(j2-0.5)*dw)) / dw
         frac1 = r1 - (j1-0.5)
         frac2 = r2 - (j2-0.5)
c I can't see how this would happen
c         if (frac1 .gt. 1.0 .or. frac2 .gt. 1.0) then
c            write(*,*) "warning in logrebin: ",
c     $           frac1,frac2,i,r1,r2,j1,j2
c         end if

c first handle the special case if the boundaries are
c in the same bin
         if (j1 .eq. j2) then
            if (spec(j1) .gt. bad) then
               wtgood = frac2 - frac1
               fsum = (frac2-frac1) * spec(j1)
            else
               wtbad = frac2-frac1
            end if
            go to 200
         end if

c Do the first, fractional pixel
c         if (j1 .ge. 1 .and. j1 .le. nsp .and. spec(j1) .gt. bad) then
         if (spec(j1) .gt. bad) then
            wtgood = wtgood + (1.-frac1)
            fsum = fsum + (1.-frac1) * spec(j1)
         else
            wtbad = wtbad + (1.-frac1)
         end if
c Loop through the whole pixels
         do j=j1+1,j2-1
c            if (j .ge. 1 .and. j .le. nsp .and. spec(j) .gt. bad) then
            if (spec(j) .gt. bad) then
               wtgood = wtgood + 1.
               fsum  = fsum + spec(j)
            else
               wtbad = wtbad + 1.
            end if
         end do
c Do the last, fractional pixel
c         if (j2 .ge. 1 .and. j2 .le. nsp .and. spec(j2) .gt. bad) then
         if (spec(j2) .gt. bad) then
            wtgood = wtgood + frac2
            fsum = fsum + frac2 * spec(j1)
         else
            wtbad = wtbad + frac2
         end if

 200     continue

c  conserve counts (photons) so don't use the weight to normalize
c  this approach has a problem if, say, one pixel is bad
c         slog(i) = fsum
c  so rather, we estimate the flux that belonged in this bin by scaling
c  total/good
         if (wtgood .gt. 1.e-3) then
            slog(i) = fsum * (wtgood + wtbad)/wtgood
         else
            slog(i) = badset
         end if

      end do

      return
      end


!
!
!
      subroutine eosrad(inputz,ieos,imu,dd,pp,eint,tt,enx,                  &
     &     cv,cp,gc,ge,errorkey)
!
!
!     GAMMA LAW EOS w/ or w/o RADIATION PRESSURE
!     EOS MODES:
!     (note: ieos = 1 : ideal gas w/ radiation pressure)
!     (note: ieos = 4 : ideal gas only, NO radiation pressure)
!
!
!     if inputz==1: take  DENS, COMPOSITION, ENERGY
!     updates TEMP, PRES, GAMMAC, GAMMAE
!
!     if inputz==2: takes DENS, TEMP, COMPOSITION
!     updates ENERGY, PRES, GAMMAC, GAMMAE
!
!     if inputz==3: takes TEMP, PRESS, COMPOSITION
!     returns DENS, ENERGY, GAMMAC, GAMMAE
!
      implicit none
      include 'dimen.inc'
      include 'constants.inc'
      include 'mpif.h'
      include 'mpicom.inc'
!
      integer*4 inputz
      integer*4 errorkey, ieos
!     INTERM. RESULT STORAGE VARS
      real*8 imu, dd, pp, eint, tt, gc, ge, cv, cp
      real*8 pgas, prad, enx
      real*8 const1, const2, const3
!     N-R Variables
      real*8 nr1, nr2, nrx, nry, nrdydx, nrtest
      integer*4 nrcnt
!
      errorkey = 0
      !
!     inputz=1:given (energy, density), update (temp, press)
!     [NOTE: uses N-R to solve for temp]
      if(inputz.eq.1) then
!
         if(ieos.eq.1) then
            nr1 = 1.5d0*gascon*dd*imu/arad
            nr2 = (eint*dd)/arad
            nrx = min(max(1.d0, tt), 1.d11)
            nry = nrx**4.d0 + nr1*nrx - nr2
            nrtest = 1.d0
            nrcnt = 1
            do while(abs(nrtest).gt.1.d-3)
               nrdydx = 4*nrx**3.0 + nr1
               nrx    = nrx - nry/nrdydx
               nrx = min(max(1.d0, nrx), 1d13)
               nry = nrx**4.d0 + nr1*nrx - nr2
               nrtest = -nry/nrdydx/nrx
               nrcnt = nrcnt +1
               if(nrcnt.gt.100) then
                  errorkey = 2
                  goto 666
               endif
            enddo
            tt = nrx
            pgas = imu*gascon*dd*tt
            prad = 1.d0/3.d0*arad*tt**4.d0
            pp = pgas + prad
         endif
         if(ieos.eq.4) then
            tt = eint/(1.5d0*gascon*imu)
            pgas = imu*gascon*dd*tt
            prad = 0.d0
            pp = pgas + prad
            enx = (pp/dd+eint)/tt
         endif
!
!
!
!     inputz=2:given (temp, density), update (energy,pressure)
      elseif(inputz.eq.2) then
         pgas = gascon*imu*dd*tt
         prad = 0.d0
         if(ieos.eq.1) then
            prad = arad/3.d0*tt**4.d0
         endif
         pp   = prad + pgas
         eint = (1.5d0*pgas + 3.d0*prad)/dd
         enx = (pp/dd+eint)/tt
!
!
!
!     inputz=3: given (temp,press), return (density,energy)
      elseif(inputz.eq.3) then
!
         dd   = pp/(gascon*imu*tt)
         ! print*,'eosrad(dd): ',dd
         ! dd   = (pp - arad/3.d0*tt**4.d0)/(gascon*imu*tt)
         pgas =  gascon*imu*dd*tt
         prad = 0.d0
         if(ieos.eq.1) then
            dd   = (pp - arad/3.d0*tt**4.d0)/(gascon*imu*tt)
            prad =  arad/3.d0*tt**4.d0
         endif
         pp = pgas+prad
         eint =  (1.5d0*pgas + 3.d0*prad)/dd
         enx = (pp/dd+eint)/tt
      endif
!
!
!     CALCULATE GAMMAS
      const1    = pgas/pp
      const2    = 4.d0/const1-3.d0
      const3    = (4.d0 - 3.d0*const1)/                                 &
     &     (16d0 - 1.5d0*const1*const1-12.d0*const1)
!
      gc = 1.d0/(1.d0/const1 - const2*const3)
      ge = pp/(eint*dd) + 1.d0
!
      cv = 1.5d0*gascon*imu*(8.d0-7.d0*const1)/const1
      cp = gascon*imu*(1.5d0 +                                          &
     &     (16.d0 - 12.d0*const1 - 3*const1**2.d0)/const1**2.d0)
!
!
!     SUCCESS/RETURN
      return
!
!
!
!     ERROR MESSAGES
 666  continue
      print*,'ERROR(eosrad.f): NR NON-CONVERGENCE'
      return
!
!
      end


      PROGRAM XSIM
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C*  VERSION 3.01  DECEMBER 1996                                        *
C*  * Replaced call to nonexistent function CDFSTN by call to DERF     *
C*                                                                     *
C*  VERSION 3.02  MARCH 1997                                           *
C*  * Changed random number seed                                       *
C*                                                                     *
C*  VERSION 3.03  JUNE 2000                                            *
C*  * Replaced RETURN statements by STOP                               *
C*                                                                     *
C***********************************************************************
C
C  Regional frequency analysis - world specified by its L-moments.
C  Includes calculation of heterogeneity measures.
C
C  Parameters of program:
C  SEED   - Seed for random-number generator.
C  NREP   - Number of simulated regions.
C  NSIM   - Number of simulations used by routine REGTST.  Set it to
C           zero if simulation of heterogeneity and goodness-of-fit
C           measures is not required.  N.B. Total number of simulated
C           regions is NREP*(NSIM+1): large values of NREP and NSIM will
C           need a lot of computing time!
C  NSITE  - Number of sites in region.
C  NMAX   - Maximum record length at any site.
C  RMED   - Correlation between each pair of sites.  At least 0, less
C           than 1.
C  NQ     - Number of quantiles to be estimated (their values are held
C           in array FVAL).
C  NQQ    - Number of empirical quantiles of the distribution of
C           quantile estimates to be found (their values are held in
C           array QUANT).
C  NGROUP - Number of groups in the histogram used to accumulate
C           empirical distribution of quantile estimates.  Include two
C           extra groups for points falling outside the range of the
C           histogram.
C  START  - Lower endpoint for the above histogram.
C  GRINT  - Group interval for the above histogram.
C  KPRINT - Flag for printing simulation results:
C            0 - no printing;
C            1 - print only regional averages;
C            2 - print results for all sites.
C  KOUT   - I/O stream number for printed output.  N.B. If NQ is larger
C           than 16, the output width will be greater than 133 columns;
C           the output stream must be able to accept these long records.
C
C  Arrays whose elements are set in DATA statements:
C  NREC   - Integer array of length NSITE.  Record lengths at each site.
C           No record length should exceed NMAX.
C  CV     - Array of length NSITE.  L-CVs at each site.
C  SKEW   - Array of length NSITE.  L-skewnesses at each site.
C  FVAL   - Array of length NQ.  Quantiles to be estimated.
C  QUANT  - Array of length NQQ.  Empirical quantiles to be estimated.
C           They should be in ascending order.
C
C  Arrays used to store the simulation results:
C  BIAS   - Array of dimension (NQ,NS,2).  BIAS(I,J,1) contains the
C           relative bias of the Ith quantile, and BIAS(I,J,2) the
C           relative bias of the Ith 'growth curve component'
C           (quantile divided by the mean), for site J.
C  RMSE   - Array of dimension (NQ,NS,2).  RMSE(I,J,1) contains the
C           relative RMSE of the Ith quantile, and RMSE(I,J,2) the
C           relative RMSE of the Ith growth curve component, for site J.
C  QEMP   - Array of dimension (NQQ,NQ,NS,2).  QEMP(L,I,J,1) contains
C           the Lth empirical quantile of the distribution of
C           (estimated quantile)/(true quantile) for the Ith quantile
C           at site J; QEMP(L,I,J,2) contains the corresponding quantity
C           for (estimated growth curve component)/(true growth curve
C           component).
C             The empirical quantile may lie outside the range of the
C           histogram used to accumulate the values -- this range being
C           from START to START+GRINT*(NGROUP-2).  In this case the
C           corresponding element of QEMP is unchanged from its initial
C           value, BIG as defined in a DATA statement below.
C              In arrays BIAS, RMSE, and QEMP, the elements for site NS
C           (where NS=NSITE+1) contain averages over all sites of the
C           corresponding array elements.  E.g. BIAS(I,NS,1) is the
C           average of BIAS(I,1,1), BIAS(I,2,1), ..., BIAS(1,NSITE,1).
C  HAVE   - Array of dimension 3.  Contains the average, over all
C           simulated regions, of the three heterogeneity statistics
C           calculated by routine REGTST.
C  ACCEPT - Array of dimension 4.  Contains the proportion of
C           simulations in which each of four distributions
C           (GLO = generalized logistic, GEV = generalized
C           extreme-value, LN3 = lognormal, PE3 = Pearson type III)
C           gave an acceptable fit to the simulated data, according to
C           the goodness-of-fit statistic calculated by routine REGTST.
C  CHOOSE - Array of dimension 4.  Contains the proportion of
C           simulations in which each of the above four distributions
C           gave the best fit to the simulated data.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (SEED=417935084D0,NREP=10000,NSIM=0)
      PARAMETER (NSITE=19,NMAX=100,RMED=0.64D0)
      PARAMETER (NQ=6,NQQ=2,NGROUP=302,START=0.5D0,GRINT=0.005D0)
      PARAMETER (KPRINT=2,KOUT=6)
C
      PARAMETER (NS=NSITE+1)
      CHARACTER*10 HAAB,HBIAS,HRMSE
      CHARACTER*12 NAMES(NSITE)
      INTEGER IHIST(NGROUP,NQ,NS,2),NREC(NSITE)
      DOUBLE PRECISION
     *  AAB(NQ,2),ACCEPT(4),BIAS(NQ,NS,2),CHOOSE(4),COR(NSITE,NSITE),
     *  CV(NSITE),DD(NSITE),FVAL(NQ),H(3),HAVE(3),PARA(5,NSITE),
     *  PPARA(5,6),PROB(1),QEMP(NQQ,NQ,NS,2),QUANT(NQQ),RMOM(5),
     *  RMSE(NQ,NS,2),RPARA(5),RRMOM(5),SKEW(NSITE),SMEAN(NSITE),
     *  SMOM(5,NSITE),TRUEAV(NQ),TRUEGC(NQ),TRUEP(3,NSITE),
     *  TRUEQ(NQ,NSITE),VBAR(3),VOBS(3),VSD(3),X(NMAX,NSITE),XX(NSITE),
     *  YY(NSITE),ZZZ(5)
      DATA HAAB/'  ABS.BIAS'/,HBIAS/'      BIAS'/,HRMSE/'      RMSE'/
      DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/
      DATA RTHALF/0.70710 67811 86547 524D0/
C
C         ZCRIT - Critical value for Z statistic
C         SMALL - A small number, used to avoid having to evaluate a
C                 quantile function at a value too close to 0 or 1.
C         BIG   - A large number, used to initialize array QEMP and
C                 variable ZMIN.
C
      DATA ZCRIT/1.645D0/,SMALL/1D-10/,BIG/1D10/
C
      DATA FVAL/0.01D0,0.1D0,0.5D0,0.9D0,0.99D0,0.999D0/
      DATA QUANT/0.05D0,0.95D0/
      DATA (NREC(ISITE),CV(ISITE),SKEW(ISITE),ISITE=1,NSITE)/
     *  98,  0.0978D0, 0.0279D0,
     *  59,  0.0992D0, 0.0279D0,
     *  90,  0.1006D0, 0.0279D0,
     *  61,  0.1020D0, 0.0279D0,
     *  65,  0.1034D0, 0.0279D0,
     *  86,  0.1047D0, 0.0279D0,
     *  78,  0.1061D0, 0.0279D0,
     *  72,  0.1075D0, 0.0279D0,
     *  67,  0.1089D0, 0.0279D0,
     *  99,  0.1103D0, 0.0279D0,
     *  49,  0.1117D0, 0.0279D0,
     *  61,  0.1131D0, 0.0279D0,
     *  69,  0.1145D0, 0.0279D0,
     *  73,  0.1159D0, 0.0279D0,
     *  70,  0.1172D0, 0.0279D0,
     *  66,  0.1186D0, 0.0279D0,
     *  59,  0.1200D0, 0.0279D0,
     *  74,  0.1214D0, 0.0279D0,
     *  82,  0.1228D0, 0.0279D0/
C
C         CALCULATE POPULATION PARAMETERS FOR EACH SITE
C
      NNMAX=0
      DO 10 ISITE=1,NSITE
      RMOM(1)=ONE
      RMOM(2)=CV(ISITE)
      RMOM(3)=SKEW(ISITE)
      CALL PELGNO(RMOM,TRUEP(1,ISITE))
      IF(NREC(ISITE).GT.NNMAX)NNMAX=NREC(ISITE)
   10 CONTINUE
      IF(NNMAX.GT.NMAX)GOTO 1000
C
C         CALCULATE POPULATION QUANTILES FOR EACH SITE
C
      DO 30 IQ=1,NQ
      SUMAV=ZERO
      SUMGC=ZERO
      DO 20 ISITE=1,NSITE
      Q=QUAGNO(FVAL(IQ),TRUEP(1,ISITE))
      TRUEQ(IQ,ISITE)=Q
      SUMAV=SUMAV+Q
      SUMGC=SUMGC+ONE/Q
   20 CONTINUE
      TRUEAV(IQ)=SUMAV/NSITE
      TRUEGC(IQ)=NSITE/SUMGC
   30 CONTINUE
C
C         PRINT DESCRIPTION OF WORLD
C
      IF(KPRINT.EQ.0)GOTO 80
      IF(NQ.GE.13)GOTO 50
      WRITE(KOUT,6000)NREP,SEED,(FVAL(IQ),IQ=1,NQ)
      DO 40 ISITE=1,NSITE
      WRITE(KOUT,6010)ISITE,(TRUEP(I,ISITE),I=1,3),
     *  CV(ISITE),SKEW(ISITE),NREC(ISITE),(TRUEQ(IQ,ISITE),IQ=1,NQ)
   40 CONTINUE
      WRITE(KOUT,6020)(TRUEAV(IQ),IQ=1,NQ)
      WRITE(KOUT,6030)(TRUEGC(IQ),IQ=1,NQ)
      GOTO 80
   50 CONTINUE
      WRITE(KOUT,6000)NREP,SEED
      DO 60 ISITE=1,NSITE
      WRITE(KOUT,6010)ISITE,(TRUEP(I,ISITE),I=1,3),
     *  CV(ISITE),SKEW(ISITE),NREC(ISITE)
   60 CONTINUE
      WRITE(KOUT,6040)(FVAL(IQ),IQ=1,NQ)
      DO 70 ISITE=1,NSITE
      WRITE(KOUT,6050)ISITE,(TRUEQ(IQ,ISITE),IQ=1,NQ)
   70 CONTINUE
      WRITE(KOUT,6060)(TRUEAV(IQ),IQ=1,NQ)
      WRITE(KOUT,6070)(TRUEGC(IQ),IQ=1,NQ)
   80 CONTINUE
C
C         INITIALIZE CORRELATION MATRIX
C
      IF(KPRINT.GT.0)WRITE(KOUT,6080)RMED
      IF(RMED.EQ.ZERO.OR.NSITE.EQ.1)GOTO 140
      COR(1,1)=ONE
      DO 100 I=2,NSITE
      DO 90 J=1,I-1
   90 COR(I,J)=RMED
  100 COR(I,I)=ONE
C
C         CHOLESKY DECOMPOSITION OF CORRELATION MATRIX
C         FIRST COLUMN IS ALREADY CORRECT, BECAUSE COR(1,1)=1,
C         SO TRANSFORM ONLY THE SECOND AND SUBSEQUENT COLUMNS
C
      DO 130 I=2,NSITE
C
C         - DIAGONAL ELEMENTS
C
      SUM=ZERO
      DO 110 K=1,I-1
  110 SUM=SUM+COR(I,K)**2
      SUM=COR(I,I)-SUM
      COR(I,I)=DSQRT(SUM)
      IF(I.EQ.NSITE)GOTO 140
C
C         - OFF-DIAGONAL ELEMENTS
C
      DO 130 J=I+1,NSITE
      SUM=ZERO
      DO 120 K=1,I-1
  120 SUM=SUM+COR(I,K)*COR(J,K)
      COR(J,I)=(COR(J,I)-SUM)/COR(I,I)
  130 CONTINUE
C
  140 CONTINUE
C
C         INITIALIZE ARRAYS
C
      DO 150 IH=1,3
  150 HAVE(IH)=ZERO
      DO 160 IZ=1,4
      ACCEPT(IZ)=ZERO
  160 CHOOSE(IZ)=ZERO
      DO 190 IQ=1,NQ
      DO 190 IS=1,NS
      BIAS(IQ,IS,1)=ZERO
      BIAS(IQ,IS,2)=ZERO
      RMSE(IQ,IS,1)=ZERO
      RMSE(IQ,IS,2)=ZERO
      DO 170 IG=1,NGROUP
      IHIST(IG,IQ,IS,1)=0
  170 IHIST(IG,IQ,IS,2)=0
      DO 180 IQQ=1,NQQ
      QEMP(IQQ,IQ,IS,1)=BIG
  180 QEMP(IQQ,IQ,IS,2)=BIG
  190 CONTINUE
      NFAIL=0
      NWARN=0
      SSEED=SEED
C
C         START OF SIMULATION LOOP
C
      DO 400 IREP=1,NREP
C
      XSEED=SSEED
C
C         GENERATE INDEPENDENT UNIFORM RANDOM VARIATES
C
      DO 200 ISITE=1,NSITE
      CALL DURAND(SSEED,NNMAX,X(1,ISITE))
  200 CONTINUE
C
C         FOR CORRELATED DATA: TRANSFORM TO NORMAL, FORM CORRELATED
C         NORMAL VARIATES, TRANSFORM BACK TO UNIFORM
C
      IF(RMED.EQ.ZERO.OR.NSITE.EQ.1)GOTO 260
      DO 250 IX=1,NNMAX
      DO 210 ISITE=1,NSITE
      X(IX,ISITE)=QUASTN(X(IX,ISITE))
  210 CONTINUE
      DO 240 I=NSITE,1,-1
      SUM=COR(I,I)*X(IX,I)
      IF(I.EQ.1)GOTO 230
      DO 220 J=1,I-1
  220 SUM=SUM+COR(I,J)*X(IX,J)
  230 CONTINUE
      TEMP=HALF+HALF*DERF(SUM*RTHALF)
      IF(TEMP.EQ.ONE)TEMP=ONE-SMALL
      IF(TEMP.EQ.ZERO)TEMP=SMALL
      X(IX,I)=TEMP
  240 CONTINUE
  250 CONTINUE
  260 CONTINUE
C
C         TRANSFORM TO CORRECT MARGINAL DISTRIBUTION,
C         DIVIDE BY SAMPLE MEAN AND ORDER THE DATA
C
      DO 290 ISITE=1,NSITE
      N=NREC(ISITE)
      SUM=ZERO
      DO 270 I=1,N
      X(I,ISITE)=QUAGNO(X(I,ISITE),TRUEP(1,ISITE))
  270 SUM=SUM+X(I,ISITE)
      SMEAN(ISITE)=SUM/N
      DO 280 I=1,N
  280 X(I,ISITE)=X(I,ISITE)/SMEAN(ISITE)
      CALL SORT(X(1,ISITE),N)
  290 CONTINUE
C
C         CALCULATE L-MOMENT RATIOS
C
      DO 300 I=1,5
  300 RMOM(I)=ZERO
      NSY=0
      DO 310 ISITE=1,NSITE
      N=NREC(ISITE)
      NSY=NSY+N
      CALL SAMLMR(X(1,ISITE),N,SMOM(1,ISITE),5,ZERO,ZERO)
      DO 310 I=1,5
  310 RMOM(I)=RMOM(I)+N*SMOM(I,ISITE)
      DO 320 I=1,5
  320 RMOM(I)=RMOM(I)/NSY
C
C         CALCULATE HETEROGENEITY STATISTICS
C
      IF(NSIM.EQ.0)GOTO 350
      RSEED=XSEED
      NPROB=0
      JPRINT=0
      CALL REGTST(NSITE,NAMES,NREC,SMOM,ZERO,ZERO,RSEED,NSIM,NPROB,
     *   PROB,JPRINT,KOUT,RRMOM,DD,VOBS,VBAR,VSD,H,ZZZ,PPARA)
      DO 330 IH=1,3
  330 HAVE(IH)=HAVE(IH)+H(IH)
      ZMIN=BIG
      DO 340 IZ=1,4
      ZABS=DABS(ZZZ(IZ))
      IF(ZABS.LE.ZCRIT)ACCEPT(IZ)=ACCEPT(IZ)+ONE
      IF(ZABS.GE.ZMIN)GOTO 340
      ICHOOS=IZ
      ZMIN=ZABS
  340 CONTINUE
      CHOOSE(ICHOOS)=CHOOSE(ICHOOS)+1
  350 CONTINUE
C
C         ESTIMATE PARAMETERS
C
      IFAIL=0
      CALL PELGNO(RMOM,RPARA)
      IF(RPARA(2).LT.ZERO)IFAIL=2
      IF(IFAIL.EQ.0)GOTO 360
      NFAIL=NFAIL+1
      GOTO 390
  360 CONTINUE
C
C         COMPUTE QUANTILES ...
C
      DO 380 IQ=1,NQ
      GC=QUAGNO(FVAL(IQ),RPARA)
C
C         ... AND ACCUMULATE HISTOGRAMS, OF EMPIRICAL DISTRIBUTIONS
C             OF QUANTILE ESTIMATES ...
C
      QSUM=ZERO
      DO 370 ISITE=1,NSITE
      Q=GC*SMEAN(ISITE)/TRUEQ(IQ,ISITE)
      QSUM=QSUM+Q
      BIAS(IQ,ISITE,1)=BIAS(IQ,ISITE,1)+(Q-ONE)
      RMSE(IQ,ISITE,1)=RMSE(IQ,ISITE,1)+(Q-ONE)**2
      IG=(Q-START)/GRINT+2
      IF(IG.LT.1)IG=1
      IF(IG.GT.NGROUP)IG=NGROUP
      IHIST(IG,IQ,ISITE,1)=IHIST(IG,IQ,ISITE,1)+1
      Q=GC/TRUEQ(IQ,ISITE)
      BIAS(IQ,ISITE,2)=BIAS(IQ,ISITE,2)+(Q-ONE)
      RMSE(IQ,ISITE,2)=RMSE(IQ,ISITE,2)+(Q-ONE)**2
      IG=(Q-START)/GRINT+2
      IF(IG.LT.1)IG=1
      IF(IG.GT.NGROUP)IG=NGROUP
      IHIST(IG,IQ,ISITE,2)=IHIST(IG,IQ,ISITE,2)+1
  370 CONTINUE
C
C         ... OF THE 'AVERAGE FOR ALL SITES'
C
      Q=QSUM/NSITE
      IG=(Q-START)/GRINT+2
      IF(IG.LT.1)IG=1
      IF(IG.GT.NGROUP)IG=NGROUP
      IHIST(IG,IQ,NS,1)=IHIST(IG,IQ,NS,1)+1
C
C         ... AND OF THE 'GROWTH CURVE COMPONENT'
C
      Q=GC/TRUEGC(IQ)
      IG=(Q-START)/GRINT+2
      IF(IG.LT.1)IG=1
      IF(IG.GT.NGROUP)IG=NGROUP
      IHIST(IG,IQ,NS,2)=IHIST(IG,IQ,NS,2)+1
  380 CONTINUE
  390 CONTINUE
C
C         END OF SIMULATION LOOP
C
  400 CONTINUE
C
C         CALCULATE FINAL RESULTS FOR HET AND GOF STATISTICS
C
      IF(NSIM.EQ.0)GOTO 430
      DO 410 IH=1,3
  410 HAVE(IH)=HAVE(IH)/NREP
      IF(KPRINT.GT.0)WRITE(KOUT,6090)HAVE,NSIM
      DO 420 IZ=1,4
      ACCEPT(IZ)=ACCEPT(IZ)/NREP
  420 CHOOSE(IZ)=CHOOSE(IZ)/NREP
      IF(KPRINT.GT.0)WRITE(KOUT,6100)(ACCEPT(IZ),IZ=1,4)
      IF(KPRINT.GT.0)WRITE(KOUT,6110)(CHOOSE(IZ),IZ=1,4)
  430 CONTINUE
C
C         CALCULATE FINAL RESULTS FOR ESTIMATION
C
      IF(NREP.LE.1)STOP
      NOK=NREP-NFAIL
      DO 510 IQ=1,NQ
      DO 510 ITYPE=1,2
C
C         -  BIAS AND RMSE, SITE BY SITE ...
C
      DO 440 ISITE=1,NSITE
      BIAS(IQ,ISITE,ITYPE)=BIAS(IQ,ISITE,ITYPE)/NOK
      RMSE(IQ,ISITE,ITYPE)=DSQRT(RMSE(IQ,ISITE,ITYPE)/NOK)
  440 CONTINUE
C
C         - ... AND AVERAGED OVER ALL SITES
C
      BIAS(IQ,NS,ITYPE)=ZERO
      RMSE(IQ,NS,ITYPE)=ZERO
      AAB(IQ,ITYPE)=ZERO
      DO 450 ISITE=1,NSITE
      BIAS(IQ,NS,ITYPE)=BIAS(IQ,NS,ITYPE)+BIAS(IQ,ISITE,ITYPE)
      RMSE(IQ,NS,ITYPE)=RMSE(IQ,NS,ITYPE)+RMSE(IQ,ISITE,ITYPE)
      AAB(IQ,ITYPE)=AAB(IQ,ITYPE)+DABS(BIAS(IQ,ISITE,ITYPE))
  450 CONTINUE
      BIAS(IQ,NS,ITYPE)=BIAS(IQ,NS,ITYPE)/NSITE
      RMSE(IQ,NS,ITYPE)=RMSE(IQ,NS,ITYPE)/NSITE
      AAB(IQ,ITYPE)=AAB(IQ,ITYPE)/NSITE
C
C        - QUANTILES OF EMPIRICAL DISTRIBUTIONS OF ESTIMATORS
C
      DO 500 ISITE=1,NS
      IG=0
      SUM=ZERO
      DO 480 IQQ=1,NQQ
      CRIT=QUANT(IQQ)*NOK
      DO 460 IGG=1,NGROUP
      IF(SUM.GE.CRIT)GOTO 470
      IG=IG+1
      HH=IHIST(IG,IQ,ISITE,ITYPE)
      SUM=SUM+HH
  460 CONTINUE
  470 IF(IG.LE.1)GOTO 480
      IF(IG.GE.NGROUP)GOTO 490
      QEMP(IQQ,IQ,ISITE,ITYPE)=START+GRINT*(IG-ONE-(SUM-CRIT)/HH)
  480 CONTINUE
  490 CONTINUE
  500 CONTINUE
C
  510 CONTINUE
C
C         PRINT RESULTS
C
      IF(KPRINT.LE.0)GOTO 570
C
C         - HEADER LINES
C
      WRITE(KOUT,6120)NFAIL,NWARN
      WRITE(KOUT,6130)(FVAL(IQ),IQ=1,NQ)
C
C         - SITE BY SITE
C
      IF(KPRINT.EQ.1)GOTO 540
      DO 530 ISITE=1,NSITE
      WRITE(KOUT,6140)ISITE
      WRITE(KOUT,6170)HBIAS,(BIAS(IQ,ISITE,1),IQ=1,NQ)
      WRITE(KOUT,6170)HRMSE,(RMSE(IQ,ISITE,1),IQ=1,NQ)
      DO 520 IQQ=1,NQQ
      WRITE(KOUT,6180)QUANT(IQQ),(QEMP(IQQ,IQ,ISITE,1),IQ=1,NQ)
  520 CONTINUE
  530 CONTINUE
  540 CONTINUE
C
C         - 'AVERAGE FOR ALL SITES' AND 'GROWTH CURVE COMPONENT'
C
      WRITE(KOUT,6150)
      WRITE(KOUT,6170)HAAB,(AAB(IQ,1),IQ=1,NQ)
      WRITE(KOUT,6170)HBIAS,(BIAS(IQ,NS,1),IQ=1,NQ)
      WRITE(KOUT,6170)HRMSE,(RMSE(IQ,NS,1),IQ=1,NQ)
      DO 550 IQQ=1,NQQ
  550 WRITE(KOUT,6180)QUANT(IQQ),(QEMP(IQQ,IQ,NS,1),IQ=1,NQ)
      WRITE(KOUT,6160)
      WRITE(KOUT,6170)HAAB,(AAB(IQ,2),IQ=1,NQ)
      WRITE(KOUT,6170)HBIAS,(BIAS(IQ,NS,2),IQ=1,NQ)
      WRITE(KOUT,6170)HRMSE,(RMSE(IQ,NS,2),IQ=1,NQ)
      DO 560 IQQ=1,NQQ
  560 WRITE(KOUT,6180)QUANT(IQQ),(QEMP(IQQ,IQ,NS,2),IQ=1,NQ)
  570 CONTINUE
C-----------------------------------------------------------------------
C  NOTE -- The section of the program between the dashed lines is
C  included for interest only, and is not an integral part of the
C  simulation.  It shows how Table 6.2 of Hosking and Wallis (1997) is
C  derived from the simulation results for the 'growth curve component'.
C
C         SET REGIONAL L-MOMENTS FOR 'NORTH CASCADES' REGION
C         AND ESTIMATE PARAMETERS OF REGIONAL LOGNORMAL DISTRIBUTION
C
      RMOM(1)=ONE
      RMOM(2)=0.1103D0
      RMOM(3)=0.0279D0
      CALL PELGNO(RMOM,RPARA)
C
C         COMPUTE AND PRINT THE ENTRIES FOR THE TABLE
C
      WRITE(KOUT,9010)
      DO 900 IQ=1,NQ
      Q=QUAGNO(FVAL(IQ),RPARA)
      RMS=RMSE(IQ,NS,2)
      ERRLOW=Q/QEMP(2,IQ,NS,2)
      ERRHI =Q/QEMP(1,IQ,NS,2)
      WRITE(KOUT,9020)FVAL(IQ),Q,RMS,ERRLOW,ERRHI
  900 CONTINUE
 9010 FORMAT(//' Hosking and Wallis (1997), Table 6.2'//
     *  '        F      qhat(F)     RMSE      Error bounds')
 9020 FORMAT(1X,5F10.3)
C-----------------------------------------------------------------------
C
C         THE END
C
      STOP
C
 1000 WRITE(6,7000)
      STOP
C
 6000 FORMAT(' REGIONAL LOGNORMAL SIMULATIONS    NREP=',I6,
     *  '  SEED=',F12.0////' SITE     XI   ALPHA       K',
     *  '    L-CV  L-SKEW   N',:,'    QUANTILES .....'/49X,12F8.4)
 6010 FORMAT(1X,I3,5F8.4,I4,12F8.3)
 6020 FORMAT(9X,'AVERAGE FOR ALL SITES (ARITHMETIC MEAN)',12F8.3)
 6030 FORMAT(9X,'REGIONAL GROWTH CURVE (HARMONIC MEAN)  ',12F8.3)
 6040 FORMAT(/' SITE   QUANTILES .....'/4X,16F8.4)
 6050 FORMAT(1X,I3,16F8.3)
 6060 FORMAT(' AVERAGE FOR ALL SITES (ARITHMETIC MEAN)'/4X,16F8.3)
 6070 FORMAT(' REGIONAL GROWTH CURVE (HARMONIC MEAN)  '/4X,16F8.3)
 6080 FORMAT(//' INTER-SITE CORRELATION=',F6.2)
 6090 FORMAT(//' AVERAGE HETEROGENEITY MEASURES',3F8.2,
     *  '   (BASED ON',I6,' SIMULATIONS)')
 6100 FORMAT(' DISTRIBUTIONS ACCEPTED:',
     *  ' GLO',F7.4,', GEV',F7.4,', LN3',F7.4,', PE3',F7.4)
 6110 FORMAT(' DISTRIBUTIONS CHOSEN  :',
     *  ' GLO',F7.4,', GEV',F7.4,', LN3',F7.4,', PE3',F7.4)
 6120 FORMAT(//' L-MOMENT ESTIMATION OF LOGNORMAL DISTRIBUTION ',10X,
     *  'FAILURES:',I6,8X,'WARNINGS:',I6)
 6130 FORMAT(/9X,'F',5X,16F7.4)
 6140 FORMAT(/22X,'SITE',I3,' QUANTILES')
 6150 FORMAT(/20X,'AVERAGE FOR ALL SITES')
 6160 FORMAT(/20X,'GROWTH CURVE COMPONENT')
 6170 FORMAT(A10,5X,16F7.3)
 6180 FORMAT(1X,F5.3,' PT.',5X,16F7.3)
 7000 FORMAT('*** ERROR *** PROGRAM XSIM   : NMAX PARAMETER TOO SMALL')
      END


      SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
     $                   WORK, LWORK, RWORK, IWORK, INFO )
*
*  -- LAPACK driver routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
      DOUBLE PRECISION   RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   RWORK( * ), S( * )
      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  ZGELSD computes the minimum-norm solution to a real linear least
*  squares problem:
*      minimize 2-norm(| b - A*x |)
*  using the singular value decomposition (SVD) of A. A is an M-by-N
*  matrix which may be rank-deficient.
*
*  Several right hand side vectors b and solution vectors x can be
*  handled in a single call; they are stored as the columns of the
*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
*  matrix X.
*
*  The problem is solved in three steps:
*  (1) Reduce the coefficient matrix A to bidiagonal form with
*      Householder tranformations, reducing the original problem
*      into a "bidiagonal least squares problem" (BLS)
*  (2) Solve the BLS using a divide and conquer approach.
*  (3) Apply back all the Householder tranformations to solve
*      the original least squares problem.
*
*  The effective rank of A is determined by treating as zero those
*  singular values which are less than RCOND times the largest singular
*  value.
*
*  The divide and conquer algorithm makes very mild assumptions about
*  floating point arithmetic. It will work on machines with a guard
*  digit in add/subtract, or on those binary machines without guard
*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
*  without guard digits, but we know of none.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A. M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A. N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrices B and X. NRHS >= 0.
*
*  A       (input) COMPLEX*16 array, dimension (LDA,N)
*          On entry, the M-by-N matrix A.
*          On exit, A has been destroyed.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,M).
*
*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
*          On entry, the M-by-NRHS right hand side matrix B.
*          On exit, B is overwritten by the N-by-NRHS solution matrix X.
*          If m >= n and RANK = n, the residual sum-of-squares for
*          the solution in the i-th column is given by the sum of
*          squares of elements n+1:m in that column.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,M,N).
*
*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The singular values of A in decreasing order.
*          The condition number of A in the 2-norm = S(1)/S(min(m,n)).
*
*  RCOND   (input) DOUBLE PRECISION
*          RCOND is used to determine the effective rank of A.
*          Singular values S(i) <= RCOND*S(1) are treated as zero.
*          If RCOND < 0, machine precision is used instead.
*
*  RANK    (output) INTEGER
*          The effective rank of A, i.e., the number of singular values
*          which are greater than RCOND*S(1).
*
*  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK. LWORK must be at least 1.
*          The exact minimum amount of workspace needed depends on M,
*          N and NRHS. As long as LWORK is at least
*              2 * N + N * NRHS
*          if M is greater than or equal to N or
*              2 * M + M * NRHS
*          if M is less than N, the code will execute correctly.
*          For good performance, LWORK should generally be larger.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  RWORK   (workspace) DOUBLE PRECISION array, dimension at least
*             10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
*             (SMLSIZ+1)**2
*          if M is greater than or equal to N or
*             10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +
*             (SMLSIZ+1)**2
*          if M is less than N, the code will execute correctly.
*          SMLSIZ is returned by ILAENV and is equal to the maximum
*          size of the subproblems at the bottom of the computation
*          tree (usually about 25), and
*             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
*
*  IWORK   (workspace) INTEGER array, dimension (LIWORK)
*          LIWORK >= 3 * MINMN * NLVL + 11 * MINMN,
*          where MINMN = MIN( M,N ).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value.
*          > 0:  the algorithm for computing the SVD failed to converge;
*                if INFO = i, i off-diagonal elements of an intermediate
*                bidiagonal form did not converge to zero.
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
*       California at Berkeley, USA
*     Osni Marques, LBNL/NERSC, USA
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      COMPLEX*16         CZERO
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
     $                   LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM,
     $                   MNTHR, NRWORK, NWORK, SMLSIZ
      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLABAD, DLASCL, DLASET, XERBLA, ZGEBRD, ZGELQF,
     $                   ZGEQRF, ZLACPY, ZLALSD, ZLASCL, ZLASET, ZUNMBR,
     $                   ZUNMLQ, ZUNMQR
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, ZLANGE
      EXTERNAL           ILAENV, DLAMCH, ZLANGE
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DCMPLX, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments.
*
      INFO = 0
      MINMN = MIN( M, N )
      MAXMN = MAX( M, N )
      MNTHR = ILAENV( 6, 'ZGELSD', ' ', M, N, NRHS, -1 )
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
         INFO = -7
      END IF
*
      SMLSIZ = ILAENV( 9, 'ZGELSD', ' ', 0, 0, 0, 0 )
*
*     Compute workspace.
*     (Note: Comments in the code beginning "Workspace:" describe the
*     minimal amount of workspace needed at that point in the code,
*     as well as the preferred amount for good performance.
*     NB refers to the optimal block size for the immediately
*     following subroutine, as returned by ILAENV.)
*
      MINWRK = 1
      IF( INFO.EQ.0 ) THEN
         MAXWRK = 0
         MM = M
         IF( M.GE.N .AND. M.GE.MNTHR ) THEN
*
*           Path 1a - overdetermined, with many more rows than columns.
*
            MM = N
            MAXWRK = MAX( MAXWRK, N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1,
     $               -1 ) )
            MAXWRK = MAX( MAXWRK, NRHS*ILAENV( 1, 'ZUNMQR', 'LC', M,
     $               NRHS, N, -1 ) )
         END IF
         IF( M.GE.N ) THEN
*
*           Path 1 - overdetermined or exactly determined.
*
            MAXWRK = MAX( MAXWRK, 2*N+( MM+N )*
     $               ILAENV( 1, 'ZGEBRD', ' ', MM, N, -1, -1 ) )
            MAXWRK = MAX( MAXWRK, 2*N+NRHS*
     $               ILAENV( 1, 'ZUNMBR', 'QLC', MM, NRHS, N, -1 ) )
            MAXWRK = MAX( MAXWRK, 2*N+( N-1 )*
     $               ILAENV( 1, 'ZUNMBR', 'PLN', N, NRHS, N, -1 ) )
            MAXWRK = MAX( MAXWRK, 2*N+N*NRHS )
            MINWRK = MAX( 2*N+MM, 2*N+N*NRHS )
         END IF
         IF( N.GT.M ) THEN
            IF( N.GE.MNTHR ) THEN
*
*              Path 2a - underdetermined, with many more columns
*              than rows.
*
               MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
               MAXWRK = MAX( MAXWRK, M*M+4*M+2*M*
     $                  ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
               MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS*
     $                  ILAENV( 1, 'ZUNMBR', 'QLC', M, NRHS, M, -1 ) )
               MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )*
     $                  ILAENV( 1, 'ZUNMLQ', 'LC', N, NRHS, M, -1 ) )
               IF( NRHS.GT.1 ) THEN
                  MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS )
               ELSE
                  MAXWRK = MAX( MAXWRK, M*M+2*M )
               END IF
               MAXWRK = MAX( MAXWRK, M*M+4*M+M*NRHS )
            ELSE
*
*              Path 2 - underdetermined.
*
               MAXWRK = 2*M + ( N+M )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
     $                  -1, -1 )
               MAXWRK = MAX( MAXWRK, 2*M+NRHS*
     $                  ILAENV( 1, 'ZUNMBR', 'QLC', M, NRHS, M, -1 ) )
               MAXWRK = MAX( MAXWRK, 2*M+M*
     $                  ILAENV( 1, 'ZUNMBR', 'PLN', N, NRHS, M, -1 ) )
               MAXWRK = MAX( MAXWRK, 2*M+M*NRHS )
            END IF
            MINWRK = MAX( 2*M+N, 2*M+M*NRHS )
         END IF
         MINWRK = MIN( MINWRK, MAXWRK )
         WORK( 1 ) = DCMPLX( MAXWRK, 0 )
         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            INFO = -12
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGELSD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         GO TO 10
      END IF
*
*     Quick return if possible.
*
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         RANK = 0
         RETURN
      END IF
*
*     Get machine parameters.
*
      EPS = DLAMCH( 'P' )
      SFMIN = DLAMCH( 'S' )
      SMLNUM = SFMIN / EPS
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
*
*     Scale A if max entry outside range [SMLNUM,BIGNUM].
*
      ANRM = ZLANGE( 'M', M, N, A, LDA, RWORK )
      IASCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
*        Scale matrix norm up to SMLNUM
*
         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
         IASCL = 1
      ELSE IF( ANRM.GT.BIGNUM ) THEN
*
*        Scale matrix norm down to BIGNUM.
*
         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
         IASCL = 2
      ELSE IF( ANRM.EQ.ZERO ) THEN
*
*        Matrix all zero. Return zero solution.
*
         CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
         CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
         RANK = 0
         GO TO 10
      END IF
*
*     Scale B if max entry outside range [SMLNUM,BIGNUM].
*
      BNRM = ZLANGE( 'M', M, NRHS, B, LDB, RWORK )
      IBSCL = 0
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
*        Scale matrix norm up to SMLNUM.
*
         CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 1
      ELSE IF( BNRM.GT.BIGNUM ) THEN
*
*        Scale matrix norm down to BIGNUM.
*
         CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 2
      END IF
*
*     If M < N make sure B(M+1:N,:) = 0
*
      IF( M.LT.N )
     $   CALL ZLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
*
*     Overdetermined case.
*
      IF( M.GE.N ) THEN
*
*        Path 1 - overdetermined or exactly determined.
*
         MM = M
         IF( M.GE.MNTHR ) THEN
*
*           Path 1a - overdetermined, with many more rows than columns
*
            MM = N
            ITAU = 1
            NWORK = ITAU + N
*
*           Compute A=Q*R.
*           (RWorkspace: need N)
*           (CWorkspace: need N, prefer N*NB)
*
            CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
     $                   LWORK-NWORK+1, INFO )
*
*           Multiply B by transpose(Q).
*           (RWorkspace: need N)
*           (CWorkspace: need NRHS, prefer NRHS*NB)
*
            CALL ZUNMQR( 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAU ), B,
     $                   LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
*           Zero out below R.
*
            IF( N.GT.1 ) THEN
               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
     $                      LDA )
            END IF
         END IF
*
         ITAUQ = 1
         ITAUP = ITAUQ + N
         NWORK = ITAUP + N
         IE = 1
         NRWORK = IE + N
*
*        Bidiagonalize R in A.
*        (RWorkspace: need N)
*        (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB)
*
         CALL ZGEBRD( MM, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
     $                INFO )
*
*        Multiply B by transpose of left bidiagonalizing vectors of R.
*        (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB)
*
         CALL ZUNMBR( 'Q', 'L', 'C', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
*        Solve the bidiagonal least squares problem.
*
         CALL ZLALSD( 'U', SMLSIZ, N, NRHS, S, RWORK( IE ), B, LDB,
     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
     $                IWORK, INFO )
         IF( INFO.NE.0 ) THEN
            GO TO 10
         END IF
*
*        Multiply B by right bidiagonalizing vectors of R.
*
         CALL ZUNMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
      ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
     $         MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
*
*        Path 2a - underdetermined, with many more columns than rows
*        and sufficient workspace for an efficient algorithm.
*
         LDWORK = M
         IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
     $       M*LDA+M+M*NRHS ) )LDWORK = LDA
         ITAU = 1
         NWORK = M + 1
*
*        Compute A=L*Q.
*        (CWorkspace: need 2*M, prefer M+M*NB)
*
         CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
     $                LWORK-NWORK+1, INFO )
         IL = NWORK
*
*        Copy L to WORK(IL), zeroing out above its diagonal.
*
         CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
         CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, WORK( IL+LDWORK ),
     $                LDWORK )
         ITAUQ = IL + LDWORK*M
         ITAUP = ITAUQ + M
         NWORK = ITAUP + M
         IE = 1
         NRWORK = IE + M
*
*        Bidiagonalize L in WORK(IL).
*        (RWorkspace: need M)
*        (CWorkspace: need M*M+4*M, prefer M*M+4*M+2*M*NB)
*
         CALL ZGEBRD( M, M, WORK( IL ), LDWORK, S, RWORK( IE ),
     $                WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
     $                LWORK-NWORK+1, INFO )
*
*        Multiply B by transpose of left bidiagonalizing vectors of L.
*        (CWorkspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*
         CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, M, WORK( IL ), LDWORK,
     $                WORK( ITAUQ ), B, LDB, WORK( NWORK ),
     $                LWORK-NWORK+1, INFO )
*
*        Solve the bidiagonal least squares problem.
*
         CALL ZLALSD( 'U', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB,
     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
     $                IWORK, INFO )
         IF( INFO.NE.0 ) THEN
            GO TO 10
         END IF
*
*        Multiply B by right bidiagonalizing vectors of L.
*
         CALL ZUNMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
     $                WORK( ITAUP ), B, LDB, WORK( NWORK ),
     $                LWORK-NWORK+1, INFO )
*
*        Zero out below first M rows of B.
*
         CALL ZLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
         NWORK = ITAU + M
*
*        Multiply transpose(Q) by B.
*        (CWorkspace: need NRHS, prefer NRHS*NB)
*
         CALL ZUNMLQ( 'L', 'C', N, NRHS, M, A, LDA, WORK( ITAU ), B,
     $                LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
      ELSE
*
*        Path 2 - remaining underdetermined cases.
*
         ITAUQ = 1
         ITAUP = ITAUQ + M
         NWORK = ITAUP + M
         IE = 1
         NRWORK = IE + M
*
*        Bidiagonalize A.
*        (RWorkspace: need M)
*        (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
*
         CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
     $                INFO )
*
*        Multiply B by transpose of left bidiagonalizing vectors.
*        (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB)
*
         CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAUQ ),
     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
*        Solve the bidiagonal least squares problem.
*
         CALL ZLALSD( 'L', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB,
     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
     $                IWORK, INFO )
         IF( INFO.NE.0 ) THEN
            GO TO 10
         END IF
*
*        Multiply B by right bidiagonalizing vectors of A.
*
         CALL ZUNMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
      END IF
*
*     Undo scaling.
*
      IF( IASCL.EQ.1 ) THEN
         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
     $                INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
     $                INFO )
      END IF
      IF( IBSCL.EQ.1 ) THEN
         CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
      ELSE IF( IBSCL.EQ.2 ) THEN
         CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
      END IF
*
   10 CONTINUE
      WORK( 1 ) = DCMPLX( MAXWRK, 0 )
      RETURN
*
*     End of ZGELSD
*
      END


module integrate_sde
  !  This module will provide the routines necessary to
  !  integrate a stochastic differential equation.
  use precision
  use globals
  use rand_num_gen
  use basis_change
  use operators
  implicit none

contains
  function gauss_rand_num(num_vars,nstep) result(dW)

    !  This subroutine specifies the gaussian random numbers for use
    !  in the stochastic integration process.  The random numbers have
    !  variance 1, and average 0
    !
    !  This routine was motivated by the routine given in Numerical Recipes
    !
    !  num_vars is the number of variables in the stochastic integration
    !  nstep is the number of integration steps requiring random numbers
    !  dW are the random numbers in the required form
    !  loop1 and loop2 loop over num_vars and nstep respectively
    !  tmp_ran1 and tmp_ran2 are two temporary random numbers

    integer(idp), intent(in) :: nstep
    integer(isp), intent(in) :: num_vars
    type(gauss) :: dW
    integer(idp) :: loop1, loop2
    real(fdp) :: tmp_ran1, tmp_ran2
    allocate(dW%num(0:num_vars,nstep))

    dW%num=dble(0)
    do loop1=0,num_vars
       do loop2=1,nstep-1,2
          tmp_ran1=random_num()
          tmp_ran2=random_num()

          dW%num(loop1,loop2)=sqrt(-2*log(tmp_ran1))*cos(2*pi*tmp_ran2)
          dW%num(loop1,loop2+1)=sqrt(-2*log(tmp_ran1))*sin(2*pi*tmp_ran2)
       end do
       if ((nstep/2)*2 /= nstep) then
          dW%num(loop1,nstep)=sqrt(-2*log(random_num()))*cos(2*pi*random_num())
       end if
    end do
  end function gauss_rand_num

  function integrate(initial, ti, tf, nstep) result(y)

    !  This function carries out the integration of the function f,
    !  given its derivatives as defined in the function func_derivs,
    !  from ti to tf, with nstep number of integration steps.
    !
    !  initial is the initial condition for integration
    !  ti and tf define the integration period
    !  nstep is the number of steps in the integration
    !  y is the result of the integration
    !  tmpy is a temporary wave function used for changing basis
    !  det_component is the deterministic component of integration
    !  stoc_component is the stochastic component of integration
    !  dW are the random numbers for integration of stochastic component
    !  tmp_det_comp is the co-efficients of the deterministic component
    !  tmp_stoc_comp is the co-efficients of the stochastic component
    !  loop is the current integration step
    !  dt is the time step
    !  ave is a variable of the average of the tail of the wave function
    !  ea is the expectation value <y|a|y>

    integer(idp), intent(in) :: nstep
    real(fdp), intent(in) :: ti, tf
    type(wave_fn), intent(in) :: initial
    type(wave_fn) :: y, tmpy, det_component, stoc_component
    type(gauss) :: dW
    complex(cdp), dimension(:), allocatable :: tmp_det_comp, tmp_stoc_comp
    integer(idp) :: loop
    real(fdp) :: dt, ave
    complex(cdp) :: ea

    allocate(y%co_eff(0:initial%in_basis%n))
    y%co_eff=initial%co_eff
    y%in_basis=initial%in_basis

    dt=(tf-ti)/dble(nstep)
    loop=0
    ea=y%in_basis%alpha
    open(unit=1,file="y.dat")

    !
    !  The integration process
    !
    do while (loop < nstep)

       !
       !  Integration loop while the wave function is localised
       !

       do while ((loop < nstep) .and. (abs(y%in_basis%alpha-ea) < 1) .and. (ave < 1.0d-6))
          dW=gauss_rand_num(y%in_basis%n,1)
          !
          !  Compute the derivatives
          !
          det_component = det_deriv(y)
          stoc_component = stoc_deriv(y)
          allocate(tmp_det_comp(0:y%in_basis%n), tmp_stoc_comp(0:y%in_basis%n))
          !
          !  Integrate
          !
          tmp_det_comp = -I*dt* det_component%co_eff

          tmp_stoc_comp = stoc_component%co_eff *dW%num(:,1)*sqrt(dt)
          y%co_eff=y%co_eff + tmp_det_comp
          y%co_eff = y%co_eff / normalisation(y)
          loop=loop+1
          ea=y.a.y
          if ((loop/100)*100==loop) then
             write(1,'(e15.7,e15.7)') ea

          end if
          deallocate(dW%num, tmp_det_comp, tmp_stoc_comp, det_component%co_eff, stoc_component%co_eff)
          !
          !  Compute the average of the last five co-efficients
          !
          ave=sum(abs(y%co_eff(y%in_basis%n-5:y%in_basis%n)))/5

       end do

       !
       !  Move basis to be centered about the wave function
       !
       tmpy%in_basis%n=y%in_basis%n
       tmpy%in_basis%alpha=ea
       allocate(tmpy%co_eff(0:tmpy%in_basis%n))
       tmpy%co_eff=cmplx(0)

       write(*,*) 'Before change ',y.a.y
       call change_basis(y,tmpy)
       write(*,*) 'Changed Basis at step ', loop
       write(*,*) 'After change ',tmpy.a.tmpy

       deallocate(y%co_eff)
       y%in_basis=tmpy%in_basis

       allocate(y%co_eff(0:y%in_basis%n))
       y%co_eff=tmpy%co_eff
       deallocate(tmpy%co_eff)
    end do
    close(1)
  end function integrate

  function det_deriv(y) result(tmpy)

    !  This function returns the deterministic derivatives used in the
    !  integration process
    !
    !  y is the wave function to take the derivative of
    !  tmpy is the derivative of y
    !  loop is  a dummy variable to loop over
    !  n is the size of the basis
    !  alpha is the centre of the basis
    !  calpha is the conjugate of alpha
    !  aalpha is alpha*calpha

    type(wave_fn), intent(in) :: y
    type(wave_fn) :: tmpy
    integer(idp) :: loop, n
    complex(cdp) :: alpha, calpha
    real(fdp) :: aalpha
    tmpy%in_basis = y%in_basis
    alpha=y%in_basis%alpha
    calpha=conjg(alpha)
    aalpha=real(calpha*alpha)
    n=tmpy%in_basis%n
    allocate(tmpy%co_eff(0:tmpy%in_basis%n))
    !
    !  Computes the derivative according to the Hamiltonian
    !
    do loop=1,n-1
       tmpy%co_eff(loop)=(loop+0.5d0+aalpha)*y%co_eff(loop) + calpha*sqrt(dble(loop+1))*y%co_eff(loop+1) + alpha*sqrt(dble(loop))*y%co_eff(loop-1)
    end do
    tmpy%co_eff(0)=(0.5d0+aalpha)*y%co_eff(0) + calpha*y%co_eff(1)
    tmpy%co_eff(n)=(0.5d0+aalpha)*y%co_eff(n) + alpha*sqrt(dble(n))*y%co_eff(n-1)
  end function det_deriv

  function stoc_deriv(y) result(tmpy)

    !  This function returns the stochastic component used in the
    !  integration process
    !
    !  y is the wave function to take the derivative of
    !  tmpy is the derivative of y

    type(wave_fn), intent(in) :: y
    type(wave_fn) :: tmpy

    allocate(tmpy%co_eff(0:y%in_basis%n))
    tmpy%in_basis = y%in_basis
    tmpy%co_eff = cmplx(0)
  end function stoc_deriv

end module integrate_sde


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C       Written by: Anshuk Attri
C
C       Contact: contact@anshukattri.in
C       Website: www.anshukattri.in/research
C       GITHUB: github.com/aa-tree/
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        SUBROUTINE XPP_2BODY_WITHPERT(VTIME, VDIM, VSTATE, OSTATE)

        IMPLICIT NONE

        INCLUDE 'common.dat'

        INTEGER VDIM
        REAL*8 VTIME
        REAL*8 VSTATE(VDIM), OSTATE(VDIM)

        INTEGER I,J
        REAL*8 MU_J
        REAL*8, DIMENSION(6) :: RJI, RJ
        REAL*8, DIMENSION(3) :: RTEMP
        REAL*8 LTIME, TEMP_MOD
C
C       X' is V, which is taken from the input state vector
C
        OSTATE(1)=VSTATE(4)
        OSTATE(2)=VSTATE(5)
        OSTATE(3)=VSTATE(6)
        OSTATE(4)=0.0D0
        OSTATE(5)=0.0D0
        OSTATE(6)=0.0D0

C
C FOR BODY 2
C
C
C        CALL GET_VEC_MOD(RTEMP, TEMP_MOD)
        DO J=1,MMAX

            IF(LIST_I(J,1) .NE. IBC) THEN

                DO I=1,3

                    CALL SPKEZ(LIST_I(J,1), VTIME, 'J2000', 'NONE', IBC,
     &RJ, LTIME)

                    CALL GET_MU(LIST_I(J,1), MU_J)

                    IF(MU_J .NE. 0) THEN

                        RJI=VSTATE(I)-RJ(I)

                        CALL GET_VEC_MOD(RJI, TEMP_MOD)

                        IF(TEMP_MOD .NE. 0) THEN

                            RTEMP(I)=(-1.0D0*MU_J*RJI(I))
                            RTEMP(I)=RTEMP(I)/(TEMP_MOD)**3.0D0
                            OSTATE(I+3)=OSTATE(I+3)+RTEMP(I)

                        END IF

                    ELSE

                    END IF
                END DO

            END IF
        END DO

        RETURN
        END


program main
    use std
    implicit none

    type(Equation_) :: eq

    call eq%setup(QuadraticEquation=.true.,a=1.0d0, b=8.0d0, c=1.0d0)
    call eq%solve()
end program


      subroutine DIMQL(A, LDA, N, EVAL, WORK, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DIMQL  Krogh  Changes to use M77CON
c>> 1992-04-24 DIMQL  CLL   Minor edits
c>> 1991-10-23 DIMQL  Krogh Initial version, converted from EISPACK.
c
c     This subroutine is a slight modification of the EISPACK subroutine
c     IMTQL2 (dated August 1983) which computes the eigenvalues and
c     eigenvectors of a real symmetric tridiagonal matrix.
c     IMTQL2 was in turn a translation of the ALGOL procedure, IMTQL2,
c     Num. Math. 12, 377-383(1968) by Martin and Wilkinson as modified
c     in Num. Math. 15, 450(1970) by Dubrelle.  Handbook for Auto.
c     Comp., vol.ii-linear algebra, 241-248(1971).
c
c     On input
c     LDA  must be set to the row dimension of the two-dimensional array
c          A as declared in the calling program dimension statement.
c     N    is the order of the matrix.
c     EVAL contains the diagonal elements of the input matrix.
c     WORK contains the subdiagonal elements of the input matrix
c          in its last n-1 positions.  e(1) is arbitrary.
c     A    contains the transformation matrix produced in the
c          reduction to tridiagonal form.  if the eigenvectors
c          of the tridiagonal matrix are desired, A must contain
c          the identity matrix.
c
c     On output
c     A    contains the eigenvectors.
c     EVAL contains the eigenvalues in ascending order.  If an
c          error exit is made, the eigenvalues are correct but
c          unordered for indices 1,2,...,IERR-1.
c     WORK used for working storage.
c     IERR is set to:
c          zero  for normal return,
c          J     if the J-th eigenvalue has not been determined after 30
c                iterations.
c     ------------------------------------------------------------------
c--D replaces "?": ?IMQL
c     ------------------------------------------------------------------
      integer N, LDA, IERR
      integer I, J, K, L, M
      double precision A(LDA,N), EVAL(N), WORK(N)
      double precision F, G, B, C, P, R, S, TST1, TST2
c
c     ------------------------------------------------------------------
c
      IERR = 0
c
      do 600 I = 2, N
         WORK(I-1) = WORK(I)
  600 continue
c
      WORK(N) = 0.0D0
c
      do 740 L = 1, N
         J = 0
c     .......... look for small sub-diagonal element ..........
  605    do 610 M = L, N
            if (M .eq. N) go to 620
            TST1 = abs(EVAL(M)) + abs(EVAL(M+1))
            TST2 = TST1 + abs(WORK(M))
            if (TST2 .eq. TST1) go to 620
  610    continue
c
  620    P = EVAL(L)
         if (M .ne. L) then
            if (J .eq. 30) then
c                   .......... set error -- no convergence to an
c                              eigenvalue after 30 iterations ..........
               call ERMSG('DIMQL',L, 0,
     1'ERROR NO. is index of eigenvalue causing convergence failure.',
     2           '.')
               IERR = L
               return
            end if
            J = J + 1
c        .......... form shift ..........
            G = (EVAL(L+1) - P) / (2.0D0 * WORK(L))
            if (abs(G) .gt. 1.0D0) then
               R = G * sqrt(1.0D0 + 1.0D0 / G ** 2)
            else
               R = sign(sqrt(1.0D0 + G ** 2), G)
            end if
            G = EVAL(M) - P + WORK(L) / (G + R)
            S = 1.0D0
            C = 1.0D0
            P = 0.0D0
            do 700 I = M-1, L, -1
               F = S * WORK(I)
               B = C * WORK(I)
               if (abs(F) .gt. abs(G)) then
                  R = abs(F) * sqrt(1.D0 + (G / F)**2)
               else if (G .ne. 0.0D0) then
                  R = abs(G) * sqrt(1.D0 + (F / G)**2)
               else
c        .......... recover from underflow ..........
                  WORK(I+1) = 0.0D0
                  EVAL(I+1) = EVAL(I+1) - P
                  WORK(M) = 0.0D0
                  go to 605
               end if
               WORK(I+1) = R
               S = F / R
               C = G / R
               G = EVAL(I+1) - P
               R = (EVAL(I) - G) * S + 2.0D0 * C * B
               P = S * R
               EVAL(I+1) = G + P
               G = C * R - B
c        .......... form vector ..........
               do 680 K = 1, N
                  F = A(K,I+1)
                  A(K,I+1) = S * A(K,I) + C * F
                  A(K,I) = C * A(K,I) - S * F
  680          continue
c
  700       continue
c
            EVAL(L) = EVAL(L) - P
            WORK(L) = G
            WORK(M) = 0.0D0
            go to 605
         end if
  740 continue
c     .......... order eigenvalues and eigenvectors ..........
      do 800 I = 1, N - 1
         K = I
         P = EVAL(I)
c
         do 760 J = I+1, N
            if (EVAL(J) .lt. P) then
               K = J
               P = EVAL(J)
            end if
  760    continue
c
         if (K .ne. I) then
            EVAL(K) = EVAL(I)
            EVAL(I) = P
c
            do 780 J = 1, N
               P = A(J,I)
               A(J,I) = A(J,K)
               A(J,K) = P
  780       continue
         end if
c
  800 continue
c
      return
      end


Module sp_hnfs
  implicit none
  integer, parameter:: dp=selected_real_kind(15,307)
  integer, parameter:: sp=selected_real_kind(6,37)
  integer, parameter:: si=selected_int_kind(1) ! very short integer -10..10 range
  integer, parameter:: li=selected_int_kind(18) ! Big integer -10^18..10^18 range
CONTAINS
  SUBROUTINE bct_6_7_15_18(n,spHNFs)
    integer, intent(in) :: n
    integer, allocatable, intent(out) :: spHNFs(:,:,:)

    integer, pointer :: diagonals(:,:) => null()
    integer :: a,b,c,d,e,f
    integer :: nds, i, nhnfs, status, j, k, z
    integer(li) :: total_hnfs
    integer, allocatable :: temp_HNFs(:,:,:)

    real(dp) :: gamma21,gamma13,beta12,gamma12
    integer, allocatable :: es(:)

    call get_HNF_diagonals(n,diagonals)

    nds = size(diagonals,2)
    nhnfs = 0
    total_hnfs = 0

    do i = 1,nds
       total_hnfs = total_hnfs + diagonals(2,i)*diagonals(3,i)**2
    end do

    allocate(temp_HNFs(3,3,total_hnfs),STAT=status)
    if (status/=0) stop "Failed to allocate memory in bct_6_7_15_18."

    do i =1,nds
      a = diagonals(1,i)
      c = diagonals(2,i)
      f = diagonals(3,i)

      if (MOD(f,c)==0)then
        if (MOD(f,2)==0)then
           allocate(es(2))
           es = (/0,(f/2)/)
        else
           allocate(es(1))
           es = (/0/)
        end if
        do j=1,size(es)
          e = es(j)
          if(MOD(e,c)==0)then
            gamma21 = -c+e*e/real(c)
            if(MOD(gamma21,real(f))==0)then
              do d=0,f-1
                gamma13 = a+2*d
                if(MOD(gamma13,f)==0)then
                  do b=0,c-1
                    beta12 = b-d
                    if(MOD(beta12,c)==0)then
                      gamma12 = -b+d-(beta12*e/real(c))
                      if(MOD(gamma12,real(f))==0)then
                        nhnfs = nhnfs + 1
                        temp_HNFs(:,:,nhnfs) = reshape((/a, b, d, &
                           0, c, e, &
                           0, 0, f/),(/3,3/))
                      end if
                    end if
                  end do
                end if
              end do
            end if
          end if
        end do
      deallocate(es)
      endif
    end do

    allocate(spHNFs(3,3,nhnfs))

    spHNFs(:,:,1:nhnfs) = temp_HNFs(:,:,1:nhnfs)

  end SUBROUTINE bct_6_7_15_18

  SUBROUTINE basecm_10_14_17_27_37_39_41(n,spHNFs)
    integer, intent(in) :: n
    integer, allocatable, intent(out) :: spHNFs(:,:,:)

    integer, pointer :: diagonals(:,:) => null()
    integer :: a,b,c,d,e,f
    integer :: nds, i, nhnfs, status, j, k, z
    integer(li) :: total_hnfs
    integer, allocatable :: temp_HNFs(:,:,:)

    integer :: gamma11
    integer, allocatable :: es(:)

    call get_HNF_diagonals(n,diagonals)

    nds = size(diagonals,2)
    nhnfs = 0
    total_hnfs = 0

    do i = 1,nds
       total_hnfs = total_hnfs + diagonals(2,i)*diagonals(3,i)**2
    end do

    allocate(temp_HNFs(3,3,total_hnfs),STAT=status)
    if (status/=0) stop "Failed to allocate memory in basecm_14."

    do i =1,nds
       a = diagonals(1,i)
       c = diagonals(2,i)
       f = diagonals(3,i)

       if (MOD(f,2)==0) then
          allocate(es(2))
          es = (/0,f/2/)
       else
          allocate(es(1))
          es = (/0/)
       end if

       do j=1,size(es)
         do d=0,f-1
           e = es(j)
           gamma11 = -1*a + 2*d
           if (MOD(gamma11,f)==0) then
             do b=0,c-1
               nhnfs = nhnfs + 1
               temp_HNFs(:,:,nhnfs) = reshape((/ a, b, d, &
               0, c, e, &
               0, 0, f/),(/3,3/))
             end do
            end if
          end do
        end do
       deallocate(es)
    end do

    allocate(spHNFs(3,3,nhnfs))

    spHNFs(:,:,1:nhnfs) = temp_HNFs(:,:,1:nhnfs)

  end SUBROUTINE basecm_10_14_17_27_37_39_41

  SUBROUTINE get_HNF_diagonals(detS, diagonals)
    integer, intent(in) :: detS
    integer, pointer :: diagonals(:,:)

    integer i, j, id, quotient, status
    integer :: tempDiag(3,detS*3)

    id = 0 ! Number of diagonals found
    do i = 1,detS ! Loop over possible first factors
       if (.not. mod(detS,i)==0) cycle
       quotient = detS/i
       do j = 1,quotient  ! Loop over possible second/third factors
          if (.not. mod(quotient,j)==0) cycle
          id = id + 1
          tempDiag(:,id) = (/i, j, quotient/j /) ! Construct the factor triplet
       enddo
    enddo
    allocate(diagonals(3,id),STAT=status)
    if(status/=0) stop "Allocation failed in get_HNF_diagonals"
    diagonals = tempDiag(:,1:id)
  END SUBROUTINE get_HNF_diagonals
END Module sp_hnfs

program int_spHNFs
use sp_hnfs
  integer :: n = 9999, arrSize,i = 1
  integer, allocatable :: spHNFs(:,:,:)

  call bct_6_7_15_18(n,spHNFs)
  arrSize = size(spHNFs,3)
  open (unit = 1, file = 'int_sphnfs.txt', form='formatted')
  write(*,*), arrSize
  do i = 1,arrSize
    write(1,*), spHNFs(1:3,1,i)
    write(1,*), spHNFs(1:3,2,i)
    write(1,*), spHNFs(1:3,3,i)
  enddo
  close(1)

END program int_spHNFs


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id$
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE R1F3KB (IDO,L1,CC,IN1,CH,IN2,WA1,WA2)
      REAL       CC(IN1,IDO,3,L1)    ,CH(IN2,IDO,L1,3),
     1           WA1(IDO)   ,WA2(IDO)
C
      ARG=2.*4.*ATAN(1.0)/3.
      TAUR=COS(ARG)
      TAUI=SIN(ARG)
      DO 101 K=1,L1
         CH(1,1,K,1) = CC(1,1,1,K)+2.*CC(1,IDO,2,K)
         CH(1,1,K,2) = CC(1,1,1,K)+(2.*TAUR)*CC(1,IDO,2,K)
     1   -(2.*TAUI)*CC(1,1,3,K)
         CH(1,1,K,3) = CC(1,1,1,K)+(2.*TAUR)*CC(1,IDO,2,K)
     1   +2.*TAUI*CC(1,1,3,K)
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
        CH(1,I-1,K,1) = CC(1,I-1,1,K)+(CC(1,I-1,3,K)+CC(1,IC-1,2,K))
        CH(1,I,K,1) = CC(1,I,1,K)+(CC(1,I,3,K)-CC(1,IC,2,K))
        CH(1,I-1,K,2) = WA1(I-2)*
     1 ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))-
     * (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))
     2                   -WA1(I-1)*
     3 ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))+
     * (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))
            CH(1,I,K,2) = WA1(I-2)*
     4 ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))+
     8 (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))
     5                  +WA1(I-1)*
     6 ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))-
     8 (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))
              CH(1,I-1,K,3) = WA2(I-2)*
     7 ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))+
     8 (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))
     8   -WA2(I-1)*
     9 ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))-
     8 (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))
            CH(1,I,K,3) = WA2(I-2)*
     1 ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))-
     8 (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))
     2                 +WA2(I-1)*
     3 ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))+
     8 (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))
  102    CONTINUE
  103 CONTINUE
      RETURN
      END


!*==slar1v.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the tridiagonal matrix LDLT - λI.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLAR1V + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
!                  PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
!                  R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
!
!       .. Scalar Arguments ..
!       LOGICAL            WANTNC
!       INTEGER   B1, BN, N, NEGCNT, R
!       REAL               GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
!      $                   RQCORR, ZTZ
!       ..
!       .. Array Arguments ..
!       INTEGER            ISUPPZ( * )
!       REAL               D( * ), L( * ), LD( * ), LLD( * ),
!      $                  WORK( * )
!       REAL             Z( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLAR1V computes the (scaled) r-th column of the inverse of
!> the sumbmatrix in rows B1 through BN of the tridiagonal matrix
!> L D L**T - sigma I. When sigma is close to an eigenvalue, the
!> computed vector is an accurate eigenvector. Usually, r corresponds
!> to the index where the eigenvector is largest in magnitude.
!> The following steps accomplish this computation :
!> (a) Stationary qd transform,  L D L**T - sigma I = L(+) D(+) L(+)**T,
!> (b) Progressive qd transform, L D L**T - sigma I = U(-) D(-) U(-)**T,
!> (c) Computation of the diagonal elements of the inverse of
!>     L D L**T - sigma I by combining the above transforms, and choosing
!>     r as the index where the diagonal of the inverse is (one of the)
!>     largest in magnitude.
!> (d) Computation of the (scaled) r-th column of the inverse using the
!>     twisted factorization obtained by combining the top part of the
!>     the stationary and the bottom part of the progressive transform.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>           The order of the matrix L D L**T.
!> \endverbatim
!>
!> \param[in] B1
!> \verbatim
!>          B1 is INTEGER
!>           First index of the submatrix of L D L**T.
!> \endverbatim
!>
!> \param[in] BN
!> \verbatim
!>          BN is INTEGER
!>           Last index of the submatrix of L D L**T.
!> \endverbatim
!>
!> \param[in] LAMBDA
!> \verbatim
!>          LAMBDA is REAL
!>           The shift. In order to compute an accurate eigenvector,
!>           LAMBDA should be a good approximation to an eigenvalue
!>           of L D L**T.
!> \endverbatim
!>
!> \param[in] L
!> \verbatim
!>          L is REAL array, dimension (N-1)
!>           The (n-1) subdiagonal elements of the unit bidiagonal matrix
!>           L, in elements 1 to N-1.
!> \endverbatim
!>
!> \param[in] D
!> \verbatim
!>          D is REAL array, dimension (N)
!>           The n diagonal elements of the diagonal matrix D.
!> \endverbatim
!>
!> \param[in] LD
!> \verbatim
!>          LD is REAL array, dimension (N-1)
!>           The n-1 elements L(i)*D(i).
!> \endverbatim
!>
!> \param[in] LLD
!> \verbatim
!>          LLD is REAL array, dimension (N-1)
!>           The n-1 elements L(i)*L(i)*D(i).
!> \endverbatim
!>
!> \param[in] PIVMIN
!> \verbatim
!>          PIVMIN is REAL
!>           The minimum pivot in the Sturm sequence.
!> \endverbatim
!>
!> \param[in] GAPTOL
!> \verbatim
!>          GAPTOL is REAL
!>           Tolerance that indicates when eigenvector entries are negligible
!>           w.r.t. their contribution to the residual.
!> \endverbatim
!>
!> \param[in,out] Z
!> \verbatim
!>          Z is REAL array, dimension (N)
!>           On input, all entries of Z must be set to 0.
!>           On output, Z contains the (scaled) r-th column of the
!>           inverse. The scaling is such that Z(R) equals 1.
!> \endverbatim
!>
!> \param[in] WANTNC
!> \verbatim
!>          WANTNC is LOGICAL
!>           Specifies whether NEGCNT has to be computed.
!> \endverbatim
!>
!> \param[out] NEGCNT
!> \verbatim
!>          NEGCNT is INTEGER
!>           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
!>           in the  matrix factorization L D L**T, and NEGCNT = -1 otherwise.
!> \endverbatim
!>
!> \param[out] ZTZ
!> \verbatim
!>          ZTZ is REAL
!>           The square of the 2-norm of Z.
!> \endverbatim
!>
!> \param[out] MINGMA
!> \verbatim
!>          MINGMA is REAL
!>           The reciprocal of the largest (in magnitude) diagonal
!>           element of the inverse of L D L**T - sigma I.
!> \endverbatim
!>
!> \param[in,out] R
!> \verbatim
!>          R is INTEGER
!>           The twist index for the twisted factorization used to
!>           compute Z.
!>           On input, 0 <= R <= N. If R is input as 0, R is set to
!>           the index where (L D L**T - sigma I)^{-1} is largest
!>           in magnitude. If 1 <= R <= N, R is unchanged.
!>           On output, R contains the twist index used to compute Z.
!>           Ideally, R designates the position of the maximum entry in the
!>           eigenvector.
!> \endverbatim
!>
!> \param[out] ISUPPZ
!> \verbatim
!>          ISUPPZ is INTEGER array, dimension (2)
!>           The support of the vector in Z, i.e., the vector Z is
!>           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
!> \endverbatim
!>
!> \param[out] NRMINV
!> \verbatim
!>          NRMINV is REAL
!>           NRMINV = 1/SQRT( ZTZ )
!> \endverbatim
!>
!> \param[out] RESID
!> \verbatim
!>          RESID is REAL
!>           The residual of the FP vector.
!>           RESID = ABS( MINGMA )/SQRT( ZTZ )
!> \endverbatim
!>
!> \param[out] RQCORR
!> \verbatim
!>          RQCORR is REAL
!>           The Rayleigh Quotient correction to LAMBDA.
!>           RQCORR = MINGMA*TMP
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (4*N)
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realOTHERauxiliary
!
!> \par Contributors:
!  ==================
!>
!> Beresford Parlett, University of California, Berkeley, USA \n
!> Jim Demmel, University of California, Berkeley, USA \n
!> Inderjit Dhillon, University of Texas, Austin, USA \n
!> Osni Marques, LBNL/NERSC, USA \n
!> Christof Voemel, University of California, Berkeley, USA
!
!  =====================================================================
      SUBROUTINE SLAR1V(N,B1,Bn,Lambda,D,L,Ld,Lld,Pivmin,Gaptol,Z,      &
     &                  Wantnc,Negcnt,Ztz,Mingma,R,Isuppz,Nrminv,Resid, &
     &                  Rqcorr,Work)
      IMPLICIT NONE
!*--SLAR1V234
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- 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 ..
      LOGICAL Wantnc
      INTEGER B1 , Bn , N , Negcnt , R
      REAL Gaptol , Lambda , Mingma , Nrminv , Pivmin , Resid , Rqcorr ,&
     &     Ztz
!     ..
!     .. Array Arguments ..
      INTEGER Isuppz(*)
      REAL D(*) , L(*) , Ld(*) , Lld(*) , Work(*)
      REAL Z(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E0,ONE=1.0E0)

!     ..
!     .. Local Scalars ..
      LOGICAL sawnan1 , sawnan2
      INTEGER i , indlpl , indp , inds , indumn , neg1 , neg2 , r1 , r2
      REAL dminus , dplus , eps , s , tmp
!     ..
!     .. External Functions ..
      LOGICAL SISNAN
      REAL SLAMCH
      EXTERNAL SISNAN , SLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS
!     ..
!     .. Executable Statements ..
!
      eps = SLAMCH('Precision')

      IF ( R==0 ) THEN
         r1 = B1
         r2 = Bn
      ELSE
         r1 = R
         r2 = R
      ENDIF

!     Storage for LPLUS
      indlpl = 0
!     Storage for UMINUS
      indumn = N
      inds = 2*N + 1
      indp = 3*N + 1

      IF ( B1==1 ) THEN
         Work(inds) = ZERO
      ELSE
         Work(inds+B1-1) = Lld(B1-1)
      ENDIF

!
!     Compute the stationary transform (using the differential form)
!     until the index R2.
!
      sawnan1 = .FALSE.
      neg1 = 0
      s = Work(inds+B1-1) - Lambda
      DO i = B1 , r1 - 1
         dplus = D(i) + s
         Work(indlpl+i) = Ld(i)/dplus
         IF ( dplus<ZERO ) neg1 = neg1 + 1
         Work(inds+i) = s*Work(indlpl+i)*L(i)
         s = Work(inds+i) - Lambda
      ENDDO
      sawnan1 = SISNAN(s)
      IF ( .NOT.(sawnan1) ) THEN
         DO i = r1 , r2 - 1
            dplus = D(i) + s
            Work(indlpl+i) = Ld(i)/dplus
            Work(inds+i) = s*Work(indlpl+i)*L(i)
            s = Work(inds+i) - Lambda
         ENDDO
         sawnan1 = SISNAN(s)
      ENDIF
!
      IF ( sawnan1 ) THEN
!        Runs a slower version of the above loop if a NaN is detected
         neg1 = 0
         s = Work(inds+B1-1) - Lambda
         DO i = B1 , r1 - 1
            dplus = D(i) + s
            IF ( ABS(dplus)<Pivmin ) dplus = -Pivmin
            Work(indlpl+i) = Ld(i)/dplus
            IF ( dplus<ZERO ) neg1 = neg1 + 1
            Work(inds+i) = s*Work(indlpl+i)*L(i)
            IF ( Work(indlpl+i)==ZERO ) Work(inds+i) = Lld(i)
            s = Work(inds+i) - Lambda
         ENDDO
         DO i = r1 , r2 - 1
            dplus = D(i) + s
            IF ( ABS(dplus)<Pivmin ) dplus = -Pivmin
            Work(indlpl+i) = Ld(i)/dplus
            Work(inds+i) = s*Work(indlpl+i)*L(i)
            IF ( Work(indlpl+i)==ZERO ) Work(inds+i) = Lld(i)
            s = Work(inds+i) - Lambda
         ENDDO
      ENDIF
!
!     Compute the progressive transform (using the differential form)
!     until the index R1
!
      sawnan2 = .FALSE.
      neg2 = 0
      Work(indp+Bn-1) = D(Bn) - Lambda
      DO i = Bn - 1 , r1 , -1
         dminus = Lld(i) + Work(indp+i)
         tmp = D(i)/dminus
         IF ( dminus<ZERO ) neg2 = neg2 + 1
         Work(indumn+i) = L(i)*tmp
         Work(indp+i-1) = Work(indp+i)*tmp - Lambda
      ENDDO
      tmp = Work(indp+r1-1)
      sawnan2 = SISNAN(tmp)

      IF ( sawnan2 ) THEN
!        Runs a slower version of the above loop if a NaN is detected
         neg2 = 0
         DO i = Bn - 1 , r1 , -1
            dminus = Lld(i) + Work(indp+i)
            IF ( ABS(dminus)<Pivmin ) dminus = -Pivmin
            tmp = D(i)/dminus
            IF ( dminus<ZERO ) neg2 = neg2 + 1
            Work(indumn+i) = L(i)*tmp
            Work(indp+i-1) = Work(indp+i)*tmp - Lambda
            IF ( tmp==ZERO ) Work(indp+i-1) = D(i) - Lambda
         ENDDO
      ENDIF
!
!     Find the index (from R1 to R2) of the largest (in magnitude)
!     diagonal element of the inverse
!
      Mingma = Work(inds+r1-1) + Work(indp+r1-1)
      IF ( Mingma<ZERO ) neg1 = neg1 + 1
      IF ( Wantnc ) THEN
         Negcnt = neg1 + neg2
      ELSE
         Negcnt = -1
      ENDIF
      IF ( ABS(Mingma)==ZERO ) Mingma = eps*Work(inds+r1-1)
      R = r1
      DO i = r1 , r2 - 1
         tmp = Work(inds+i) + Work(indp+i)
         IF ( tmp==ZERO ) tmp = eps*Work(inds+i)
         IF ( ABS(tmp)<=ABS(Mingma) ) THEN
            Mingma = tmp
            R = i + 1
         ENDIF
      ENDDO
!
!     Compute the FP vector: solve N^T v = e_r
!
      Isuppz(1) = B1
      Isuppz(2) = Bn
      Z(R) = ONE
      Ztz = ONE
!
!     Compute the FP vector upwards from R
!
      IF ( .NOT.sawnan1 .AND. .NOT.sawnan2 ) THEN
         DO i = R - 1 , B1 , -1
            Z(i) = -(Work(indlpl+i)*Z(i+1))
            IF ( (ABS(Z(i))+ABS(Z(i+1)))*ABS(Ld(i))<Gaptol ) THEN
               Z(i) = ZERO
               Isuppz(1) = i + 1
               EXIT
            ENDIF
            Ztz = Ztz + Z(i)*Z(i)
         ENDDO
      ELSE
!        Run slower loop if NaN occurred.
         DO i = R - 1 , B1 , -1
            IF ( Z(i+1)==ZERO ) THEN
               Z(i) = -(Ld(i+1)/Ld(i))*Z(i+2)
            ELSE
               Z(i) = -(Work(indlpl+i)*Z(i+1))
            ENDIF
            IF ( (ABS(Z(i))+ABS(Z(i+1)))*ABS(Ld(i))<Gaptol ) THEN
               Z(i) = ZERO
               Isuppz(1) = i + 1
               EXIT
            ENDIF
            Ztz = Ztz + Z(i)*Z(i)
         ENDDO
      ENDIF

!     Compute the FP vector downwards from R in blocks of size BLKSIZ
      IF ( .NOT.sawnan1 .AND. .NOT.sawnan2 ) THEN
         DO i = R , Bn - 1
            Z(i+1) = -(Work(indumn+i)*Z(i))
            IF ( (ABS(Z(i))+ABS(Z(i+1)))*ABS(Ld(i))<Gaptol ) THEN
               Z(i+1) = ZERO
               Isuppz(2) = i
               EXIT
            ENDIF
            Ztz = Ztz + Z(i+1)*Z(i+1)
         ENDDO
      ELSE
!        Run slower loop if NaN occurred.
         DO i = R , Bn - 1
            IF ( Z(i)==ZERO ) THEN
               Z(i+1) = -(Ld(i-1)/Ld(i))*Z(i-1)
            ELSE
               Z(i+1) = -(Work(indumn+i)*Z(i))
            ENDIF
            IF ( (ABS(Z(i))+ABS(Z(i+1)))*ABS(Ld(i))<Gaptol ) THEN
               Z(i+1) = ZERO
               Isuppz(2) = i
               EXIT
            ENDIF
            Ztz = Ztz + Z(i+1)*Z(i+1)
         ENDDO
      ENDIF
!
!     Compute quantities for convergence test
!
      tmp = ONE/Ztz
      Nrminv = SQRT(tmp)
      Resid = ABS(Mingma)*Nrminv
      Rqcorr = Mingma*tmp
!
!
!
!     End of SLAR1V
!
      END SUBROUTINE SLAR1V


      recursive subroutine dqawf(f,a,omega,integr,epsabs,result,
     *   abserr,neval,ier,limlst,lst,leniw,maxp1,lenw,iwork,work)
c***begin prologue  dqawf
c***date written   800101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a3a1
c***keywords  automatic integrator, special-purpose,fourier
c             integral, integration between zeros with dqawoe,
c             convergence acceleration with dqelg
c***author  piessens,robert ,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math & progr. div. - k.u.leuven
c***purpose  the routine calculates an approximation result to a given
c            fourier integral i=integral of f(x)*w(x) over (a,infinity)
c            where w(x) = cos(omega*x) or w(x) = sin(omega*x).
c            hopefully satisfying following claim for accuracy
c            abs(i-result).le.epsabs.
c***description
c
c        computation of fourier integrals
c        standard fortran subroutine
c        double precision version
c
c
c        parameters
c         on entry
c            f      - double precision
c                     function subprogram defining the integrand
c                     function f(x). the actual name for f needs to be
c                     declared e x t e r n a l in the driver program.
c
c            a      - double precision
c                     lower limit of integration
c
c            omega  - double precision
c                     parameter in the integrand weight function
c
c            integr - integer
c                     indicates which of the weight functions is used
c                     integr = 1      w(x) = cos(omega*x)
c                     integr = 2      w(x) = sin(omega*x)
c                     if integr.ne.1.and.integr.ne.2, the routine
c                     will end with ier = 6.
c
c            epsabs - double precision
c                     absolute accuracy requested, epsabs.gt.0.
c                     if epsabs.le.0, the routine will end with ier = 6.
c
c         on return
c            result - double precision
c                     approximation to the integral
c
c            abserr - double precision
c                     estimate of the modulus of the absolute error,
c                     which should equal or exceed abs(i-result)
c
c            neval  - integer
c                     number of integrand evaluations
c
c            ier    - integer
c                     ier = 0 normal and reliable termination of the
c                             routine. it is assumed that the requested
c                             accuracy has been achieved.
c                     ier.gt.0 abnormal termination of the routine.
c                             the estimates for integral and error are
c                             less reliable. it is assumed that the
c                             requested accuracy has not been achieved.
c            error messages
c                    if omega.ne.0
c                     ier = 1 maximum number of cycles allowed
c                             has been achieved, i.e. of subintervals
c                             (a+(k-1)c,a+kc) where
c                             c = (2*int(abs(omega))+1)*pi/abs(omega),
c                             for k = 1, 2, ..., lst.
c                             one can allow more cycles by increasing
c                             the value of limlst (and taking the
c                             according dimension adjustments into
c                             account). examine the array iwork which
c                             contains the error flags on the cycles, in
c                             order to look for eventual local
c                             integration difficulties.
c                             if the position of a local difficulty
c                             can be determined (e.g. singularity,
c                             discontinuity within the interval) one
c                             will probably gain from splitting up the
c                             interval at this point and calling
c                             appropriate integrators on the subranges.
c                         = 4 the extrapolation table constructed for
c                             convergence accelaration of the series
c                             formed by the integral contributions over
c                             the cycles, does not converge to within
c                             the requested accuracy.
c                             as in the case of ier = 1, it is advised
c                             to examine the array iwork which contains
c                             the error flags on the cycles.
c                         = 6 the input is invalid because
c                             (integr.ne.1 and integr.ne.2) or
c                              epsabs.le.0 or limlst.lt.1 or
c                              leniw.lt.(limlst+2) or maxp1.lt.1 or
c                              lenw.lt.(leniw*2+maxp1*25).
c                              result, abserr, neval, lst are set to
c                              zero.
c                         = 7 bad integrand behaviour occurs within
c                             one or more of the cycles. location and
c                             type of the difficulty involved can be
c                             determined from the first lst elements of
c                             vector iwork.  here lst is the number of
c                             cycles actually needed (see below).
c                             iwork(k) = 1 the maximum number of
c                                          subdivisions (=(leniw-limlst)
c                                          /2) has been achieved on the
c                                          k th cycle.
c                                      = 2 occurrence of roundoff error
c                                          is detected and prevents the
c                                          tolerance imposed on the k th
c                                          cycle, from being achieved
c                                          on this cycle.
c                                      = 3 extremely bad integrand
c                                          behaviour occurs at some
c                                          points of the k th cycle.
c                                      = 4 the integration procedure
c                                          over the k th cycle does
c                                          not converge (to within the
c                                          required accuracy) due to
c                                          roundoff in the extrapolation
c                                          procedure invoked on this
c                                          cycle. it is assumed that the
c                                          result on this interval is
c                                          the best which can be
c                                          obtained.
c                                      = 5 the integral over the k th
c                                          cycle is probably divergent
c                                          or slowly convergent. it must
c                                          be noted that divergence can
c                                          occur with any other value of
c                                          iwork(k).
c                    if omega = 0 and integr = 1,
c                    the integral is calculated by means of dqagie,
c                    and ier = iwork(1) (with meaning as described
c                    for iwork(k),k = 1).
c
c         dimensioning parameters
c            limlst - integer
c                     limlst gives an upper bound on the number of
c                     cycles, limlst.ge.3.
c                     if limlst.lt.3, the routine will end with ier = 6.
c
c            lst    - integer
c                     on return, lst indicates the number of cycles
c                     actually needed for the integration.
c                     if omega = 0, then lst is set to 1.
c
c            leniw  - integer
c                     dimensioning parameter for iwork. on entry,
c                     (leniw-limlst)/2 equals the maximum number of
c                     subintervals allowed in the partition of each
c                     cycle, leniw.ge.(limlst+2).
c                     if leniw.lt.(limlst+2), the routine will end with
c                     ier = 6.
c
c            maxp1  - integer
c                     maxp1 gives an upper bound on the number of
c                     chebyshev moments which can be stored, i.e. for
c                     the intervals of lengths abs(b-a)*2**(-l),
c                     l = 0,1, ..., maxp1-2, maxp1.ge.1.
c                     if maxp1.lt.1, the routine will end with ier = 6.
c            lenw   - integer
c                     dimensioning parameter for work
c                     lenw must be at least leniw*2+maxp1*25.
c                     if lenw.lt.(leniw*2+maxp1*25), the routine will
c                     end with ier = 6.
c
c         work arrays
c            iwork  - integer
c                     vector of dimension at least leniw
c                     on return, iwork(k) for k = 1, 2, ..., lst
c                     contain the error flags on the cycles.
c
c            work   - double precision
c                     vector of dimension at least
c                     on return,
c                     work(1), ..., work(lst) contain the integral
c                      approximations over the cycles,
c                     work(limlst+1), ..., work(limlst+lst) contain
c                      the error extimates over the cycles.
c                     further elements of work have no specific
c                     meaning for the user.
c
c***references  (none)
c***routines called  dqawfe,xerror
c***end prologue  dqawf
c
       double precision a,abserr,epsabs,f,omega,result,work
       integer ier,integr,iwork,last,leniw,lenw,limit,limlst,ll2,lvl,
     *  lst,l1,l2,l3,l4,l5,l6,maxp1,neval
c
       dimension iwork(leniw),work(lenw)
c
       external f
c
c         check validity of limlst, leniw, maxp1 and lenw.
c
c***first executable statement  dqawf
      ier = 6
      neval = 0
      last = 0
      result = 0.0d+00
      abserr = 0.0d+00
      if(limlst.lt.3.or.leniw.lt.(limlst+2).or.maxp1.lt.1.or.lenw.lt.
     *   (leniw*2+maxp1*25)) go to 10
c
c         prepare call for dqawfe
c
      limit = (leniw-limlst)/2
      l1 = limlst+1
      l2 = limlst+l1
      l3 = limit+l2
      l4 = limit+l3
      l5 = limit+l4
      l6 = limit+l5
      ll2 = limit+l1
      call dqawfe(f,a,omega,integr,epsabs,limlst,limit,maxp1,result,
     *  abserr,neval,ier,work(1),work(l1),iwork(1),lst,work(l2),
     *  work(l3),work(l4),work(l5),iwork(l1),iwork(ll2),work(l6))
c
c         call error handler if necessary
c
      lvl = 0
10    if(ier.eq.6) lvl = 1
      if(ier.ne.0) call xerror('abnormal return from dqawf',26,ier,lvl)
      return
      end