C NCLFORTSTART
      SUBROUTINE WAVELETI(N,Y,DT,MOTHER,PARAM,S0,DJ,JTOT,NPAD,NOISE,
     +                    ISIGTEST,SIGLVL,NADOF,WAVE,SCALE,PERIOD,COI,
     +                    DOF,FFTTHEOR,SIGNIF,GWS,YMEAN,YSD,LAG1,
     +                    CDELTA,PSI0,POWER,PHASE,R1)
      IMPLICIT NONE

C     wave = wavelet (y,mother \
C                    ,param,s0,dj,jtot,npad,noise,isigtest,siglvl,nadof)

C     return arguments:  all must be allocated in the C interface
C              JTOT must be calculated in the default case
C              wave(N,JTOT,2)   <=== fortran order
C              wave@scale(JTOT), wave@period(JTOT), wave@coi(N)
C              wave@dof(JTOT), wave@ffttheor(JTOT), wave@signif(JTOT)
C              wave@mean , wave@st_dev, wave@lag1

C                                             INPUT
      INTEGER N,MOTHER,JTOT,NPAD,NOISE,ISIGTEST
      DOUBLE PRECISION Y(N),DT,PARAM,S0,DJ,SIGLVL,NADOF(*)
C                                             OUTPUT: must be allocated
C                                                     in interface
      DOUBLE PRECISION WAVE(N,JTOT,2)
C                                             RETURN AS ATTRIBUTES
      DOUBLE PRECISION SCALE(JTOT),PERIOD(JTOT),COI(N),GWS(JTOT)
      DOUBLE PRECISION POWER(N,JTOT),PHASE(N,JTOT)
      DOUBLE PRECISION DOF(JTOT),FFTTHEOR(JTOT),SIGNIF(JTOT)
      DOUBLE PRECISION YMEAN,YSD,LAG1,CDELTA,PSI0,R1
C NCLEND
C                                             LOCAL and  AUTOMATIC
      DOUBLE COMPLEX CWAVE(N,JTOT)
      DOUBLE PRECISION YVAR,RAD
      INTEGER J,K
C
      YMEAN = 0.0D0
      YVAR = 0.0D0
      YSD = 0.0D0
      LAG1 = 0.0D0
      NADOF(1) = 0.0D0
      NADOF(2) = 0.0D0
C
      DO J = 1,JTOT
          SCALE(J) = 0.0D0
          FFTTHEOR(J) = 0.0D0
          SIGNIF(J) = 0.0D0
          PERIOD(J) = 0.0D0
      END DO

      DO K = 1,N
          COI(K) = 0.0D0
      END DO

      RAD = 4.D0*ATAN(1.)/180.d0

    1 DO J = 1,JTOT
          DO K = 1,N
              CWAVE(K,J) = (0.0D0,0.0D0)
              POWER(K,J) = 0.0D0
              PHASE(K,J) = 0.0D0
          END DO
      END DO
C                                             CALCULATE SOME STATS
      CALL STATSWAVE(N,Y,NOISE,YMEAN,YVAR,YSD,LAG1)
C                                             CALL USING COMPLEX
      CALL WAVELET(N,Y,DT,MOTHER,PARAM,S0,DJ,JTOT,NPAD,YMEAN,YVAR,
     +             CWAVE,SCALE,PERIOD,COI)
C                                             RETURN REALS to NCL
      DO J = 1,JTOT
        GWS(J) = 0.0D0
        DO K = 1,N
          WAVE(K,J,1) = DBLE(CWAVE(K,J))
          WAVE(K,J,2) = DIMAG(CWAVE(K,J))
          POWER(K,J)  = WAVE(K,J,1)**2 + WAVE(K,J,2)**2
          PHASE(K,J)  = ATAN2(DIMAG(CWAVE(K,J)),DBLE(CWAVE(K,J)))/RAD
          GWS(J) = GWS(J) + WAVE(K,J,1)**2 + WAVE(K,J,2)**2
        END DO
        GWS(J) = GWS(J)/DBLE(N)
      END DO
C                            NADOF could be used here
      IF (ISIGTEST.EQ.1) THEN
          DO J = 1,JTOT
              DOF(J) = N - SCALE(J)
          END DO
      ELSE
          IF (ISIGTEST.EQ.2) THEN
              DOF(1) = NADOF(1)
              DOF(2) = NADOF(2)
          END IF
      END IF

      R1 = LAG1
      IF (NOISE.EQ.0) THEN
          R1 = 0.0D0
      END IF

C                                             SIGNIFICANCE TESTING
      CALL WAVE_SIGNIF(ISIGTEST,N,Y,DT,MOTHER,PARAM,DJ,JTOT,SCALE,
     +                 PERIOD,R1,SIGLVL,DOF,FFTTHEOR,SIGNIF,YMEAN,
     +                 YVAR,CDELTA,PSI0)

      RETURN
      END

C -------- wavelet_default ----------------------------
C     SUBROUTINE WAVELETDF90 (N,Y,MOTHER)
C     INTEGER N, MOTHER
C     REAL    Y(N)
C     real, allocatable, dimension(:)     :: scale, period, coi
C     real, allocatable, dimension(:)     :: dof, ffttheor,signif
C     real, allocatable, dimension(:,:,:) :: wave

C                                             INPUT
C     INTEGER  N, MOTHER, JTOT, NPAD, NOISE, ISIGTEST
C     REAL  Y(N), DT, PARAM, S0, DJ, SIGLVL

C NCL: wave = wavelet_default (y, mother)

c     IF (MOTHER.LE.0 .OR. MOTHER.GT.2) THEN
c         PARAM = 6.0
c     ELSEIF (MOTHER.EQ.1) THEN
c         PARAM = 4.0
c     ELSEIF (MOTHER.EQ.2) THEN
c         PARAM = 2.0
c     END IF
C                                             DEFAULT/TYPICAL VALUES
C     DT = 1.0
c     S0 = 2.*DT
c     DJ = 0.25
c     JTOT = 1+(LOG2(N*DT/S0))/DJ
c     NPAD = N
c     NOISE= 1
c     ISIGTEST = 0
c     SIGLVL   = 0.05

c     ALLOCATE (COI(N), STAT=KER)

c     ALLOCATE (SCALE(JTOT), STAT=KER)
c     ALLOCATE (PERIOD(JTOT), STAT=KER)
c     ALLOCATE (DOF(JTOT), STAT=KER)
c     ALLOCATE (FFTTHEOR(JTOT), STAT=KER)
c     ALLOCATE (SIGNIF(JTOT), STAT=KER)

C     ALLOCATE (WAVE(N,JTOT,2), STAT=KER)

c     CALL WAVELETI(N, Y,DT,MOTHER,PARAM,S0,DJ,JTOT,NPAD,NOISE
c    1             ,ISIGTEST,SIGLVL
c    2             ,WAVE, SCALE, PERIOD, COI, DOF, FFTTHEOR
c    3             ,SIGNIF,YMEAN, YSD, LAG1)
C -----------------------------------------------------

      SUBROUTINE STATSWAVE (N, Y, NOISE, YMEAN, YVAR, YSD, LAG1)

      IMPLICIT NONE
      INTEGER  N, NOISE
      DOUBLE PRECISION  Y(N), YMEAN, YVAR, YSD, LAG1

      DOUBLE PRECISION  YTMP
      INTEGER K

      YMEAN = 0.0
      YVAR  = 0.0
      DO K=1,N
         YMEAN = YMEAN + Y(K)
         YVAR  = YVAR  + Y(K)*Y(K)
      END DO

      YTMP  = YMEAN*YMEAN/N
      YVAR  = MAX( (YVAR-YTMP)/N , 0.D0 ) ! prevent possible roundoff
      YMEAN = YMEAN/N

      DO K=1,N-1
         LAG1 = LAG1 + (Y(K+1)-YMEAN)*(Y(K)-YMEAN)
      END DO
      LAG1 = (LAG1/(N-1.))/YVAR

      YSD   = SQRT(YVAR)

      RETURN
      END

C -------------------------------------------------------
      SUBROUTINE WAVEJTOT(N,DT,S0,DJ,JTOT)
      DOUBLE PRECISION DT,S0,DJ
      INTEGER JTOT,N

C      JTOT = 1 + (LOG2(N*DT/S0))/DJ
      JTOT = 1 + ((LOG(N*DT/S0))/DJ)/LOG(2.D0)

      RETURN
      END

C****************************************************************************
C
C WAVEPACK:  routines to compute the wavelet transform of a time series,
C            and significance levels.
C
C Written by:   Christopher Torrence and Gilbert P. Compo
C
C Available from:  http://paos.colorado.edu/research/wavelets/
C
C Requires the following packages:   CFFTPACK, CHISQR
C
C Notes:
C
C  (1) All routines are written in single precision (DOUBLE PRECISION),
C      except for CHISQR, which requires double precision input.
C      Single precision should be sufficient for most applications.
C
C  (2) The CFFTPACK and CHISQR routines were not written by us,
C      and no guarentees are made as to their reliability or efficiency.
C
C  (3) No provision is made for output to files or to graphics packages.
C      The user is expected to call these routines from within
C      their own programs. See sample program "wavetest.f".
C
C  (4) Little error checking is done. Check your input carefully.
C      The programs are not completely ANSI compatible, so use caution.
C
C  (5) Time series are currently limited to 65535 points.
C
C
C Reference: Torrence, C. and G. P. Compo, 1998: A Practical Guide to
C            Wavelet Analysis. Bull. Amer. Meteor. Soc., 79, 61-78.
C
C Notice: Please acknowledge the use of this software in any publications:
C    ``Wavelet software was provided by C. Torrence and G. Compo,
C      and is available at URL: http://paos.colorado.edu/research/wavelets/''.
C
C  Copyright (C) 1998, Christopher Torrence
C This software may be used, copied, or redistributed as long as it is not
C sold and this copyright notice is reproduced on each copy made.  This
C routine is provided as is without any express or implied warranties
C whatsoever.
C
C
C Modified: November 1999 by Arjan van Dijk to include IMPLICIT NONE and
C           to convert all routines to DOUBLE precision.
C****************************************************************************

C****************************************************************************
C WAVELET: computes the wavelet transform of a time series,
C          with appropriate parameters.
C
C
C INPUTS:
C
C  n [INT] = the number of points in "y".
C
C  y [DOUBLE PRECISION] = the time series of length "n".
C
C  dt [DOUBLE PRECISION] = amount of time between each Y value, i.e. the sampling time.
C
C  mother [INT] = An integer giving the mother wavelet to use.
C                     0='Morlet'
C                     1='Paul'
C                     2='DOG' (derivative of Gaussian)
C                 If (mother<0 or >2) then default is 'Morlet'.
C
C  param [DOUBLE PRECISION] = mother wavelet parameter. If <0 then default is used.
C            For 'Morlet' this is k0 (wavenumber), default is 6.
C            For 'Paul' this is m (order), default is 4.
C            For 'DOG' this is m (m-th derivative), default is 2.
C
C
C  s0 [DOUBLE PRECISION] = the smallest scale of the wavelet.  Typically = 2*dt.
C         Note: for accurate reconstruction and variance computation
C             set s0=dt for Morlet; s0=dt/4 for Paul
C
C  dj [DOUBLE PRECISION] = the spacing between discrete scales. Typically = 0.25.
C         A smaller # will give better scale resolution, but be slower.
C
C  jtot [INT] = the # of scales.
C               Scales range from s0 up to s0*2^[(jtot-1)*dj],
C               Typically jtot=1+(LOG2(n dt/s0))/dj
C
C  npad [INT] = the total number of points (including padding) to
C               use for the wavelet transform. Typically this is some
C               power of 2. It must be greater or equal to "n".
C               If npad>n, then zeroes are padded onto the end
C               of the time series.
C
C
C OUTPUTS:
C
C  wave [DCMPLX(n,jtot)] = 2D array of the real & imaginary parts
C                   of the wavelet transform, versus time & scale.
C                   CABS(wave) gives the WAVELET amplitude,
C                   ATAN2(AIMAG(wave),DBLE(wave)) gives WAVELET phase.
C                   The WAVELET power spectrum is CABS(wave)**2.
C
C  scale [DOUBLE PRECISION(jtot)] = the wavelet scales that were used.
C
C  period [DOUBLE PRECISION(jtot)] = the "Fourier" periods (in time units) corresponding
C            to "scale".
C
C  coi [DOUBLE PRECISION(n)] = the e-folding factor used for the cone of influence.
C
C
C REQUIRES:   WAVE_FUNCTION, CFFTPACK
C
C  Copyright (C) 1998, Christopher Torrence and Gilbert P. Compo
C This software may be used, copied, or redistributed as long as it is not
C sold and this copyright notice is reproduced on each copy made.  This
C routine is provided as is without any express or implied warranties
C whatsoever.

      SUBROUTINE WAVELET (n,y,dt,mother,param,s0,dj,jtot,npad,ymean,
     &                    yvar,wave,scale,period,coi)
      IMPLICIT none

      INTEGER n,mother,jtot,npad
      DOUBLE PRECISION y(n),dt,param,s0,dj,scale(jtot),period(jtot),
     &  coi(n)
      DOUBLE COMPLEX wave(n,jtot)

      INTEGER i,j,k,nk
      DOUBLE PRECISION ymean,yvar,freq1,pi,period1,coi1

C** initialize work arrays
      PARAMETER (nk=65535)
      DOUBLE PRECISION wsave(4*nk+15),kwave(nk)
      DOUBLE COMPLEX yfft(nk),daughter(nk)

      pi = 4.D0*ATAN(1.D0)

      IF (npad.LT.n) THEN
        PRINT*,'**WAVELET: "npad" must be greater than or equal to "n"'
        RETURN
      END IF

      IF ((mother.LT.0).OR.(mother.GT.2)) mother = 0

C** find the time-series mean & remove it
c Don't need to calculate the mean here because it is being done in the
c NCL driver interface for wavelet.
c
c      ymean = 0.D0
c      DO 10 i=1,n
c        ymean = ymean + y(i)
c10    CONTINUE
c      ymean = ymean/n
      DO 15 i=1,n
        yfft(i) = y(i) - ymean
15    CONTINUE

C** if desired, pad with extra zeroes
      DO 20 i=n+1,npad
        yfft(i) = 0.D0
20    CONTINUE

C** find the FFT of the time series [Eqn(3)]
      CALL CFFTI(npad,wsave)
      CALL CFFTF(npad,yfft,wsave)
      DO 30 k=1,npad
        yfft(k) = yfft(k)/npad
30    CONTINUE

C** construct the wavenumber array [Eqn(5)]
      freq1 = 2.D0*pi/(DBLE(npad)*dt)
      kwave(1) = 0.D0
      DO 40 i=2,npad/2+1
        kwave(i) = (DBLE(i)-1.D0)*freq1
40    CONTINUE
      DO 50 i=npad/2+2,npad
        kwave(i) = -kwave(npad-i+2)
50    CONTINUE

c**----- Main wavelet loop
c      PRINT '(A8,2A12,/,5X,27("-"))','j','scale','period'
      DO 100 j=1,jtot
        scale(j) = s0*(2.D0**(DBLE(j-1)*dj))
        CALL WAVE_FUNCTION(npad,dt,mother,param,scale(j),
     &                   kwave,period1,coi1,daughter)
        period(j) = period1
C**    multiply the daughter by the time-series FFT
        DO 60 k=1,npad
          daughter(k) = daughter(k)*yfft(k)
60      CONTINUE
C**    inverse FFT [Eqn(4)]
        CALL CFFTB(npad,daughter,wsave)
C**    store the wavelet transform, discard zero-padding at end
        DO 70 i=1,n
          wave(i,j) = daughter(i)
70      CONTINUE
c        PRINT '(I8,2F12.3)',j,scale(j),period(j)
100   CONTINUE
c**----- end loop

C** construct the cone of influence
      DO 110 i=1,(n+1)/2
        coi(i) = coi1*dt*(DBLE(i)-1.D0)
        coi(n-i+1) = coi(i)
110   CONTINUE

      RETURN
      END

C****************************************************************************
C WAVE_FUNCTION: computes the daughter wavelets for a particular
C                wavelet function, with appropriate parameters.
C
C
C INPUTS:
C
C  nk [INT] = the number of points in "kwave"
C
C  dt [DOUBLE PRECISION] = amount of time between each Y value, i.e. the sampling time.
C
C  mother [INT] = An integer giving the mother wavelet to use.
C                     0='Morlet'
C                     1='Paul'
C                     2='DOG' (derivative of Gaussian)
C
C  param [DOUBLE PRECISION] = mother wavelet parameter. If <0 then default is used.
C            For 'Morlet' this is k0 (wavenumber), default is 6.
C            For 'Paul' this is m (order), default is 4.
C            For 'DOG' this is m (m-th derivative), default is 2.
C
C  scale1 [DOUBLE PRECISION] = the wavelet scale used to construct the daughter.
C
C  kwave [DOUBLE PRECISION(n)] = vector of wavenumbers, used to construct daughter.
C
C
C OUTPUTS:
C
C  period1 [DOUBLE PRECISION] = the "Fourier" period (in time units) that corresponds
C            to "scale1".
C
C  coi1 [DOUBLE PRECISION] = the e-folding factor used for the cone of influence.
C
C  daughter [DCMPLX(nk)] = real & imaginary parts of the wavelet function
C                         at "scale1" and "kwave".
C
C
C REQUIRES:   FACTORIAL, CHISQR
C
C
C Reference: Tables 1 & 2 in
C            Torrence, C. and G. P. Compo, 1998: A Practical Guide to
C            Wavelet Analysis. Bull. Amer. Meteor. Soc., 79, 61-78.
C
C  Copyright (C) 1998, Christopher Torrence and Gilbert P. Compo
C This software may be used, copied, or redistributed as long as it is not
C sold and this copyright notice is reproduced on each copy made.  This
C routine is provided as is without any express or implied warranties
C whatsoever.

      SUBROUTINE WAVE_FUNCTION (nk,dt,mother,param,scale1,
     &                          kwave,period1,coi1,daughter)
      IMPLICIT none

      INTEGER nk,mother
      DOUBLE PRECISION dt,kwave(nk),param,scale1,period1,coi1
      DOUBLE COMPLEX daughter(nk)

      DOUBLE PRECISION expnt,sk,pi,norm,fourier_factor
      INTEGER k,m,factorial
      DOUBLE PRECISION gamma

      pi = 4.D0*ATAN(1.D0)

      IF (mother.EQ.0) THEN
C*******************************************   Morlet wavelet
        IF (param.LT.0) param = 6.D0
        norm = SQRT(2.D0*pi*scale1/dt)*(pi**(-0.25D0))
        DO 10 k=1,nk/2+1
          expnt = -0.5D0*(scale1*kwave(k) - param)**2
          daughter(k) = DCMPLX(norm*EXP(expnt))
10      CONTINUE
         DO 20 k=nk/2+2,nk
          daughter(k) = DCMPLX(0.D0)
20      CONTINUE
        fourier_factor = (4.D0*pi)/(param + SQRT(2.D0+param**2))
        period1 = scale1*fourier_factor
        coi1 = fourier_factor/SQRT(2.D0)
      ELSE IF (mother.EQ.1) THEN
C*******************************************   Paul wavelet
        IF (param.LT.0) param = 4.D0
        m = INT(param)
        norm = SQRT(2.D0*pi*scale1/dt)*
     &         (2.D0**m/SQRT(DBLE(m*FACTORIAL(2*m-1))))
        DO 30 k=1,nk/2+1
          expnt = -scale1*kwave(k)
          daughter(k) = DCMPLX(norm*(scale1*kwave(k))**m*EXP(expnt))
30      CONTINUE
         DO 40 k=nk/2+2,nk
          daughter(k) = DCMPLX(0.D0)
40      CONTINUE
        fourier_factor = (4.D0*pi)/(2.D0*m + 1.D0)
        period1 = scale1*fourier_factor
        coi1 = fourier_factor*SQRT(2.D0)
      ELSE IF (mother.EQ.2) THEN
C*******************************************   DOG wavelet
        IF (param.LT.0) param = 2.D0
        m = INT(param)
        norm = SQRT(2.D0*pi*scale1/dt)*SQRT(1.D0/GAMMA(m+0.5D0))
        norm = -norm*(DCMPLX(0.D0,1.D0)**m)
        DO 50 k=1,nk
          sk = scale1*kwave(k)
          daughter(k) = norm*(sk**m)*EXP(-0.5D0*sk**2)
50      CONTINUE
        fourier_factor = 2.D0*pi*SQRT(2.D0/(2.D0*m+1.D0))
        period1 = scale1*fourier_factor
        coi1 = fourier_factor/SQRT(2.D0)
      ELSE
        stop
      END IF
      RETURN
      END

C****************************************************************************
C FACTORIAL: compute the factorial (n!) of an integer n
C  Copyright (C) 1998, Christopher Torrence
      FUNCTION FACTORIAL(n)
      IMPLICIT NONE
      INTEGER factorial,n,i

      factorial = 1
      DO 10 i=1,n
        factorial = factorial*i
10    CONTINUE
      END

C****************************************************************************
C WAVE_SIGNIF: computes the significance levels for a wavelet transform.
C
C
C INPUTS:
C
C  isigtest [INT] = 0, 1, or 2.
C
C          If 0, then just do a regular chi-square test,
C                i.e. Eqn (18) from Torrence & Compo.
C          If 1, then do a "time-average" test, i.e. Eqn (23).
C                In this case, DOF(j) should be set to NA, the number
C                of local wavelet spectra that were averaged together
C                at each scale. For the Global Wavelet Spectrum,
C                this would be dof(j)=N-scale(j),
C                where N is the number of points in your time series.
C          If 2, then do a "scale-average" test, i.e. Eqns (25)-(28).
C                In this case, "dof(1)" and "dof(2)" should be set to the
C                smallest (S1) and largest (S2) scales that were averaged
C                together, respectively.
C                e.g. if you scale-averaged scales between 2 and 8,
C                     then dof(1)=2.0 and dof(2)=8.0
C
C
C  n [INT] = the number of points in "y".
C
C  y [DOUBLE PRECISION] = the time series of length "n".
C
C  dt [DOUBLE PRECISION] = amount of time between each Y value, i.e. the sampling time.
C
C  mother [INT] = An integer giving the mother wavelet to use.
C                     0='Morlet'
C                     1='Paul'
C                     2='DOG' (derivative of Gaussian)
C
C  param [DOUBLE PRECISION] = mother wavelet parameter.
C
C  s0 [DOUBLE PRECISION] = the smallest scale of the wavelet.
C
C  dj [DOUBLE PRECISION] = the spacing between discrete scales.
C
C  jtot [INT] = the # of scales.
C
C  scale [DOUBLE PRECISION(jtot)] = the wavelet scales that were used.
C
C  period [DOUBLE PRECISION(jtot)] = the "Fourier" periods corresponding to "scale".
C
C  lag1 [DOUBLE PRECISION] = lag 1 Autocorrelation, used for signif levels.
C                Default is 0.0, which corresponds to white-noise.
C
C  siglvl [DOUBLE PRECISION] = significance level to use. Default is 0.05 (the "5%" level)
C
C  dof [DOUBLE PRECISION(jtot)] = degrees-of-freedom for signif test.
C     IF SIGTEST=0, then the input dof is ignored.
C     IF SIGTEST=1, then dof(j) = NA, the number of times averaged together.
C     IF SIGTEST=2, then dof(1)=S1, dof(2)=S2, the range of scales averaged.
C
C
C OUTPUTS:
C
C  dof [DOUBLE PRECISION(jtot)] = degrees-of-freedom that were actually used.
C     IF SIGTEST=0, then dof(j) = 2 (or 1 for the 'DOG')
C     IF SIGTEST=1, then dof(j) = degrees-of-freedom versus scale.
C     IF SIGTEST=2, then dof(1)=degrees-of-freedom, dof(2...jtot)=0.0
C
C  fft_theor [DOUBLE PRECISION(jtot)] = theoretical red-noise spectrum vs scale.
C     IF SIGTEST=2, then fft_theor(1) = the average spectrum from S1-->S2
C                        fft_theor(2...jtot) = 0.0
C
C  signif [DOUBLE PRECISION(jtot)] = significance levels vs scale.
C     IF SIGTEST=2, then signif(1) = the significance level
C                        signif(2...jtot) = 0.0
C
C  ymean [DOUBLE PRECISION] = the mean of the time series.
C
C  variance [DOUBLE PRECISION] = the variance of the time series.
C
C  Cdelta [DOUBLE PRECISION] = the constant "Cdelta" for the mother wavelet (Table 2).
C
C  psi0[DOUBLE PRECISION] = the constant 'psi(0)' for the mother wavelet (Table 2)
C
C REQUIRES:   CHISQR
C
C  Copyright (C) 1998, Christopher Torrence and Gilbert P. Compo
C This software may be used, copied, or redistributed as long as it is not
C sold and this copyright notice is reproduced on each copy made.  This
C routine is provided as is without any express or implied warranties
C whatsoever.

      SUBROUTINE WAVE_SIGNIF (isigtest,n,y,dt,mother,param,dj,jtot,
     &       scale,period,lag1,siglvl,dof,fft_theor,signif,
     &       ymean,variance,Cdelta,psi0)
      IMPLICIT none

      INTEGER isigtest,n,mother,jtot
      DOUBLE PRECISION y(n),dt,param,dj,scale(jtot),period(jtot)
      DOUBLE PRECISION lag1,siglvl,dof(jtot),fft_theor(jtot),
     &  signif(jtot)
      DOUBLE PRECISION ymean,variance,Cdelta,psi0

      INTEGER i,j,m,status,javg1,javg2,navg
      DOUBLE PRECISION pi,freq1,dofmin,gammafac,dj0,Savg,Smid
      DOUBLE PRECISION fft_theor1
      DOUBLE PRECISION chisqr,p,q,bound

      pi = 4.D0*ATAN(1.D0)

      IF (siglvl.LE.0.) siglvl = 0.05D0
      IF (lag1.LE.0.D0) lag1 = 0.D0

      Cdelta = -1.D0
      gammafac = -1.D0
      dj0 = -1.D0
      psi0 = -1.D0

      IF (mother.EQ.0) THEN
C*******************************************   Morlet wavelet
        dofmin = 2.D0
        IF (param.EQ.6.D0) THEN
          Cdelta = 0.776D0
          gammafac = 2.32D0
          dj0 = 0.60D0
          psi0 = pi**(-0.25D0)
        END IF
      ELSE IF (mother.EQ.1) THEN
C*******************************************   Paul wavelet
        m = INT(param)
        dofmin = 2.D0
        IF (m.EQ.4) THEN
          Cdelta = 1.132D0
          gammafac = 1.17D0
          dj0 = 1.5D0
          psi0 = 1.079D0
        END IF
      ELSE IF (mother.EQ.2) THEN
C*******************************************   DOG wavelet
        m = INT(param)
        dofmin = 1.D0
        IF (m.EQ.2) THEN
          Cdelta = 3.541D0
          gammafac = 1.43D0
          dj0 = 1.4D0
          psi0 = 0.867D0
        ELSE IF (m.EQ.6) THEN
          Cdelta = 1.966D0
          gammafac = 1.37D0
          dj0 = 0.97D0
          psi0 = 0.884D0
        END IF
      ELSE
        stop
      END IF

C** find the time-series variance
      ymean = 0.D0
      DO 10 i=1,n
        ymean = ymean + y(i)
10    CONTINUE
      ymean = ymean/n
      variance = 0.D0
      DO 15 i=1,n
        variance = variance + (y(i) - ymean)**2
15    CONTINUE
      variance = variance/(DBLE(n)) ! - 1.D0)

C** construct theoretical red(white)-noise power spectrum [Eqn(16)]
      DO 20 j=1,jtot
        freq1 = dt/period(j)
        fft_theor(j) = variance*(1.D0-lag1**2)/
     &                 (1.D0 - 2.D0*lag1*COS(freq1*2.D0*pi) + lag1**2)
20    CONTINUE

      q = DBLE(siglvl)
      p = 1d0 - q

      IF (isigtest.EQ.0) THEN
C*******************************************   no smoothing, dof=dofmin
C   see Eqn(18)
        DO 30 j=1,jtot
          dof(j) = dofmin
          CALL CDFCHI(2,p,q,chisqr,DBLE(dofmin),status,bound)
          signif(j) = fft_theor(j)*chisqr/dofmin
30      CONTINUE
      ELSE IF (isigtest.EQ.1) THEN
C***********************************   time-averaged, dof depend on scale
        IF (gammafac.LE.0.D0) THEN
        PRINT*,'**WAVE_SIGNIF: "gammafac" undefined for this wavelet'
          RETURN
        END IF
        DO 40 j=1,jtot
            IF (dof(j).LT.1.) dof(j) = 1.D0
C   see Eqn(23)
            dof(j) = dofmin*SQRT(1.D0+(dof(j)*dt/gammafac/scale(j))**2)
            IF (dof(j).LT.dofmin) dof(j) = dofmin
            CALL CDFCHI(2,p,q,chisqr,DBLE(dof(j)),status,bound)
            signif(j) = fft_theor(j)*chisqr/dof(j)
40      CONTINUE
       ELSE IF (isigtest.EQ.2) THEN
C***********************************   scale-averaged, dof depend on scale
        IF (Cdelta.LE.0.) THEN
          PRINT*,'**WAVE_SIGNIF: "Cdelta" and "dj0" '//
     &     'undefined for this wavelet'
          RETURN
        END IF
        javg1 = 0
        javg2 = 0
        DO 50 j=1,jtot
          IF ((scale(j).GE.dof(1)).AND.(javg1.EQ.0)) javg1 = j
          IF (scale(j).LE.dof(2)) javg2 = j
50      CONTINUE
        IF ((javg1.EQ.0).OR.(javg2.EQ.0).OR.(javg1.GT.javg2)) THEN
          PRINT*,'**WAVE_SIGNIF: Scales in "dof(1)" & "dof(2)" '//
     &     'are out of range.'
          RETURN
        END IF
        navg = javg2 - javg1 + 1
C   see Eqn(25)
        Savg = 0.D0
        DO 60 j=javg1,javg2
          Savg = Savg + 1.D0/scale(j)
60      CONTINUE
        Savg = 1.D0/Savg
C   see Eqn(27)
        fft_theor1 = 0.D0
        DO 70 j=javg1,javg2
          fft_theor1 = fft_theor1 + fft_theor(j)/scale(j)
70      CONTINUE
        fft_theor(1) = Savg*fft_theor1
C   see Eqn(28)
        Smid = EXP(0.5D0*(LOG(scale(javg1)) + LOG(scale(javg2))))
        dof(1) = (dofmin*navg*Savg/Smid)*SQRT(1 + (navg*dj/dj0)**2)
C   see Eqn(26)
        CALL CDFCHI(2,p,q,chisqr,DBLE(dof(1)),status,bound)
        signif(1)=(dj*dt/Cdelta/Savg)*fft_theor(1)*chisqr/dof(1)
        DO 80 j=2,jtot
          dof(j) = 0.D0
          fft_theor(j) = 0.D0
          signif(j) = 0.D0
80      CONTINUE
      ELSE
        stop
      END IF

      END


      program granular
c
c     El objetivo de este programa es simular colisiones inelásticas entre esferas duras.
c
      implicit none
                                                             !RECOMENDACIONES
      integer, parameter :: npart=100000
      integer, parameter :: npares=100*npart                !npart*100
      integer, parameter :: nchoques=10000000               !npart*100
      integer, parameter :: nmed=nchoques/100               !muchas medidas
      integer, parameter :: ninter=50                        !no muy alto < 100
      real*8, parameter    :: alfa=0.5d0

      real*8 vx(npart),vy(npart),vz(npart),vmax,h,modulo3
      real*8 suma,modulo2,sumax,sumay,sumaz,temp,maxwell,v2,v4,vv
      real*8 momentox,momentoy,momentoz,fi2,fi4,sumafi2,sumafi4,vsum(3)
      integer i,validos,ni,nj,j
      integer px(0:2*ninter),py(0:2*ninter),pz(0:2*ninter),p(0:2*ninter)
      real*8 vij(3),a,b,pi,mu2,mu4,delta,sonine

      print*,'-----PROGRAMA DE SIMULACION DE CHOQUES INELASTICOS-----'
      print*,'Parametros iniciales:'
      print*,'    numero de particulas:      ' ,npart
      print*,'    numero de choques:         ',nchoques
      print*,'    coeficiente de restitucion:  ',alfa

      pi=3.14159265358979323846d0

      open(14,file='vini.txt')
      open(15,file='vfin.txt')
      open(16,file='histograma.txt')
      open(17,file='maxwell.txt')

!CREAMOS VELOCIDADES ALEATORIAS Y LAS NORMALIZAMOS A UNA ESFERA

      ! CALL init_random_seed()

      do i=1,npart

        modulo2=2.d0

        do while (modulo2.gt.1.d0)

	      call random_number(vx(i))
          call random_number(vy(i))
          call random_number(vz(i))

          vx(i)=vx(i)*2.d0-1.d0
          vy(i)=vy(i)*2.d0-1.d0
          vz(i)=vz(i)*2.d0-1.d0

          modulo2=vx(i)**2+vy(i)**2+vz(i)**2

        end do

        modulo2=dsqrt(modulo2)

        vx(i)=vx(i)/modulo2
        vy(i)=vy(i)/modulo2
        vz(i)=vz(i)/modulo2

        modulo2=vx(i)**2+vy(i)**2+vz(i)**2
        !print*,modulo2

        write(14,*)vx(i), vy(i), vz(i)

      end do
      close(14)

!IMPONEMOS MOMENTO TOTAL NULO

      sumax=0.d0
      sumay=0.d0
      sumaz=0.d0

      do i=1,npart

        sumax=sumax+vx(i)
        sumay=sumay+vy(i)
        sumaz=sumaz+vz(i)

      end do

      momentox=sumax/npart
      momentoy=sumay/npart
      momentoz=sumaz/npart

c       Nuevas velocidades:
      sumax=0.d0
      sumay=0.d0
      sumaz=0.d0

      do i=1,npart

        vx(i)=vx(i)-momentox
        vy(i)=vy(i)-momentoy
        vz(i)=vz(i)-momentoz
        !print*, "vx",i,":",vx(i)
        !print*, "vy",i,":",vy(i)
        !print*, "vz",i,":",vz(i)
        sumax=sumax+vx(i)
        sumay=sumay+vy(i)
        sumaz=sumaz+vz(i)

      end do

      print*,"Momento nuevo:", sumax,sumay,sumaz

c-----------------------------------------------------------------------------
      CALL REESCALAR(vx,vy,vz,npart,temp)
c-----------------------------------------------------------------------------

      suma=0.d0

      do i=1,npart

        suma=vx(i)**2+vy(i)**2+vz(i)**2+suma

      end do

      suma=suma/npart
      temp=2d0*suma/3d0

      print*,'Temperatura tras el reescalado =',temp

!INICIALIZAMOS VARIALBES PARA LOS CHOQUES

      vmax=100.d0
      h=vmax/ninter
      v2=0.d0
      v4=0.d0
      validos=0

      do i=0,2*ninter

        p(i)=0
        px(i)=0
        py(i)=0
        pz(i)=0

      end do

      print*,'INICIANDO CHOQUES DE CALENTAMIENTO:'

c-----------------------------------------------------------------------------
      CALL CHOQUES (vx,vy,vz,npart,nchoques/2,ninter,h,alfa,temp,nmed,
     &validos,p,px,py,pz,v2,v4)
c-----------------------------------------------------------------------------

      print*,'Temperatura tras el calentamiento:',temp

c-----------------------------------------------------------------------------
      CALL REESCALAR(vx,vy,vz,npart,temp)
c-----------------------------------------------------------------------------

      print*,'Reescalamos:',temp

!SACAMOS LAS VARIALBES PARA HACER EL HISTOGRAMA

      vmax=0.d0

      do i=1,npart

        maxwell=4d0*pi*(1d0/(pi*temp**2))**(3d0/2d0)*(i*h)**2d0*
     &exp(-(i*h)**2/temp**2)

        if(modulo2.gt.vmax) then

          vmax=6*modulo2 !chapuza

        end if

      end do

!INICIALIZAMOS VARIALBES PARA LOS CHOQUES

      h=vmax/ninter
      v2=0.d0
      v4=0.d0
      validos=0

      do i=0,2*ninter

        p(i)=0
        px(i)=0
        py(i)=0
        pz(i)=0

      end do

      print*,'BUCLE DE MEDIDA: A CHOCAR!!!!'

      ni=int(nchoques/(npart*100))

      do i=1,ni

c-----------------------------------------------------------------------------
      CALL CHOQUES (vx,vy,vz,npart,npart*100,ninter,h,alfa,temp,nmed,
     &validos,p,px,py,pz,v2,v4)
c-----------------------------------------------------------------------------

      end do

      ni=mod(nchoques,(npart*100))

c-----------------------------------------------------------------------------
      CALL CHOQUES (vx,vy,vz,npart,ni,ninter,h,alfa,temp,nmed,
     &validos,p,px,py,pz,v2,v4)
c-----------------------------------------------------------------------------

      suma=0.d0

      do i=1,npart

        suma=vx(i)**2+vy(i)**2+vz(i)**2+suma

      end do
      suma=suma/npart
      temp=2.d0*suma/3.d0

      print*,'Temperatura tras los choques:',temp

c-----------------------------------------------------------------------------
      CALL REESCALAR(vx,vy,vz,npart,temp)
c-----------------------------------------------------------------------------

      print*,'Reescalamos:',temp
      print*,""

      do i=1,npart

        modulo2=dsqrt(vx(i)**2+vy(i)**2+vz(i)**2)
        write(15,*) vx(i),vy(i),vz(i),modulo2

      end do

      close(15)

      print*,"Tasa de aceptacion: ", float(validos)/nchoques
      print*,"Promedio de v2: ", v2/(nchoques/nmed)
      print*,"Promedio de v4: ", v4/(nchoques/nmed)
      print*,""

      suma=0.d0

      do i=1,npart

        suma=vx(i)**2+vy(i)**2+vz(i)**2+suma

      end do

      suma=suma/npart
      temp=2.d0*suma/3.d0
      temp=dsqrt(temp)

      print*,'Temperatura =',temp
      print*,""

      fi4=0.d0
      fi2=0.d0

      sumafi2=0.d0
      sumafi4=0.d0

!CALCULO DE LOS MOMENTOS DE LA DISTRIBUCIÓN

      do j=1,npares

      ni=1
      nj=ni

        do while (ni.eq.nj)

          call random_number(a)
          call random_number(b)
          ni=floor(npart*a)+1
          nj=floor(npart*b)+1

        end do

        vij(1)=(vx(ni)-vx(nj))
        vij(2)=(vy(ni)-vy(nj))
        vij(3)=(vz(ni)-vz(nj))

        vsum(1)=0.5d0*(vx(ni)+vx(nj))
        vsum(2)=0.5d0*(vy(ni)+vy(nj))
        vsum(3)=0.5d0*(vz(ni)+vz(nj))

        modulo2=vij(1)**2+vij(2)**2+vij(3)**2
        modulo2=dsqrt(modulo2)

        modulo3=vsum(1)**2+vsum(2)**2+vsum(3)**2
        modulo3=dsqrt(modulo3)

        vv=vij(1)*vsum(1)+vij(2)*vsum(2)+vij(3)*vsum(3)

        fi2=modulo2**3*(1d0-alfa**2)*pi/8d0
        sumafi2=fi2+sumafi2

        fi4=modulo2*pi/4d0*(5d0/3d0*(1d0-alfa**2)*modulo2**2*modulo3**2+
     &(1d0-alfa**2)*(2+alfa**2)/12d0*modulo2**4+(3d0-alfa)*(1d0+alfa)*
     &(vv**2-modulo2**2*modulo3**2/3d0))

        sumafi4=fi4+sumafi4

      end do

!---------------------------------------------------------------------------------------
!RESULTADO DE LOS MOMENTOS
!---------------------------------------------------------------------------------------

      print*,"Momento 2: ", sumafi2/npares/temp**3
      print*,"Momento 4: ", sumafi4/npares/temp**5
      mu2=dsqrt(2d0*pi)*(1d0-alfa**2)+
     &dsqrt(2d0*pi)*(1d0-alfa**2)*3d0/16d0*
     &((4d0*v4/(15d0*(nchoques/nmed)))-1d0)
      print*,"Momento 2 teorico: ",mu2
      mu4=mu2*4d0/3d0*v4/(nchoques/nmed)
      print*,"Momento 4 teorico: ",mu4
      print*,""

!---------------------------------------------------------------------------------------
!RESULTADO DEL COEFICIENTE a2
!---------------------------------------------------------------------------------------

      print*,"Valores teoricos de a2=a2(alfa,d):"
      print*,"   a2(p=2): ", 16d0*(1d0-alfa)*(1d0-2d0*alfa**2)/
     &(9d0+24d0*3d0-alfa*(41d0-8d0*3d0)+30d0*(1d0-alfa)*alfa**2)
      print*,"   a2(GT): ", 16d0*(1d0-alfa)*(1d0-2*alfa**2)/
     &(25d0+24d0*3d0-alfa*(57d0-8d0*3d0)-2d0*(1d0-alfa)*alfa**2)
      print*,"   a2(GS): ", 16d0*(1d0-alfa)*(1d0-2*alfa**2)/
     &(401d0-alfa*337d0+190d0*(1d0-alfa)*alfa**2)
      print*,""

!------------------------------RELACIÓN TEÓRICA-----------------------------------------
!La predicción del termostato gaussiano  (GT) y la aproximación para p=2 deben coincidir
!en el intervalo de alfa (0,5-1) y deben tener diferencias significativas en (0-0,3)
!
!El valor de a2(GS) fue una predicción hecha por Goldstein, la cual es erronea. Vamos a
!comprobar que esto es así viendo que da menos de lo medido a2(gs)<0,04
!---------------------------------------------------------------------------------------

      print*,"Valores medidos de a2:"
      print*,"   a2(c^4): ", (4d0*v4/(15d0*(nchoques/nmed)))-1d0

      if (alfa.lt.1d0) then

      print*,"   a2(mu): ", sumafi4/(5d0*sumafi2*temp**2)-1d0

      end if

!ESCRIBIMOS LOS MOMENTOS ALMACENADOS

      do i=0,2*ninter		!No puede haber exponencial para velocidades negativas porque usa modulos

        write(16,*) ((i-ninter)*h),px(i)/((nchoques/nmed)*(npart*h)),
     &py(i)/((nchoques/nmed)*(npart*h)),
     &pz(i)/((nchoques/nmed)*(npart*h))

      end do

c       MAXWELL:
      do i=1,ninter

        maxwell=4d0*pi*(1d0/pi)**(3d0/2d0)*((i+0.5d0)*h)**2d0*exp(-
     &((i+0.5d0)*h)**2)

        sonine=float(p(i))/((nchoques/nmed)*(npart*h))   !Aunque hemos usado la variable sonine, esto es  f(c)

        delta=((sonine/maxwell)-1d0)/(16d0*(1d0-alfa)*(1d0-2*alfa**2)/
     &(25d0+24d0*3d0-alfa*(57d0-8d0*3d0)-2d0*(1d0-alfa)*alfa**2))

        sonine=0.5d0*((i*h)**2)**2-5.d0/2.d0*(i*h)**2+15d0/8d0

        write(17,*) (i*h),maxwell,p(i)/((nchoques/nmed)*(npart*h)),
     &delta,sonine

      end do

      close(17)
      close(16)

      stop
      end

c-----------------------------------------------------------------------------------------------------------------
c-----------------------------------------------------------------------------------------------------------------

      SUBROUTINE CHOQUES (vx,vy,vz,npart,nchoques,ninter,h,alfa,temp,
     &nmed,validos,p,px,py,pz,v2,v4)

      !ENTRADA:  vx,vy,vz,npart,nchoques,ninter,alfa,h,temp,nmed
      !SALIDA:   vx,vy,vz,validos,p,px,py,pz,v2,v4

      !CALL REESCALAR(vx,vy,vz,npart,temp)
      !CALL HISTOGRAMA(vx,vy,vz,npart,ninter,h,p,px,py,pz)

      integer ni,nj,i,k,validos,npart,nchoques,ninter,nmed
      real*8 vx(npart),vy(npart),vz(npart),vij(3),sigma(3)
      integer px(0:2*ninter),py(0:2*ninter),pz(0:2*ninter),p(0:2*ninter)
      real*8 alfa,temp,wmax,a,b,modulo2,v2,v4,suma2,suma4,h,tirar

      wmax=0.d0

      do k=1,nchoques

      ni=1
      nj=ni

        do while (ni.eq.nj)

          call random_number(a)
          call random_number(b)
          ni=floor(npart*a)+1
          nj=floor(npart*b)+1

        end do

        modulo2=2d0

        do while (modulo2.gt.1d0)

          CALL random_number(sigma(1))
          CALL random_number(sigma(2))
          CALL random_number(sigma(3))

          sigma(1)=sigma(1)*2.d0-1.d0
          sigma(2)=sigma(2)*2.d0-1.d0
          sigma(3)=sigma(3)*2.d0-1.d0

          modulo2= sigma(1)**2+sigma(2)**2+sigma(3)**2

        end do

        modulo2=1/dsqrt(modulo2)

        do i=1,3

          sigma(i)=sigma(i)*modulo2

        end do

        vij(1)=(vx(ni)-vx(nj))
        vij(2)=(vy(ni)-vy(nj))
        vij(3)=(vz(ni)-vz(nj))
        wij=vij(1)*sigma(1)+vij(2)*sigma(2)+vij(3)*sigma(3)

        if(wij.gt.0.d0) then !     Si wij es negativo es que las particulas se están alejando

          if (wmax.lt.abs(wij)) then

            wmax=abs(wij)

          end if

	      call random_number(a)

          if(a.lt.abs(wij)/wmax) then

           !   tirar=vx(ni)*vx(ni)+vy(ni)*vy(ni)+vz(ni)*vz(ni)
            !tirar=tirar+vx(nj)*vx(nj)+vy(nj)*vy(nj)+vz(nj)*vz(nj)
            !print*, tirar

            vx(ni)=vx(ni)-0.5d0*(1.d0+alfa)*wij*sigma(1)
            vy(ni)=vy(ni)-0.5d0*(1.d0+alfa)*wij*sigma(2)
            vz(ni)=vz(ni)-0.5d0*(1.d0+alfa)*wij*sigma(3)
            vx(nj)=vx(nj)+0.5d0*(1.d0+alfa)*wij*sigma(1)
            vy(nj)=vy(nj)+0.5d0*(1.d0+alfa)*wij*sigma(2)
            vz(nj)=vz(nj)+0.5d0*(1.d0+alfa)*wij*sigma(3)

            validos=validos+1
            !tirar=vx(ni)*vx(ni)+vy(ni)*vy(ni)+vz(ni)*vz(ni)
            !tirar=tirar+vx(nj)*vx(nj)+vy(nj)*vy(nj)+vz(nj)*vz(nj)
            !print*, tirar
            !read*

          endif

        endif

!REESCALAMOS LAS VELOCIDADES CON LA TEMPERATURA

        if(mod(k,nmed).eq.0) then

c-------------------------------------------------------------------------------------
          CALL REESCALAR(vx,vy,vz,npart,temp)
c-------------------------------------------------------------------------------------
          suma2=0.d0
          suma4=0.d0

          do i=1,npart

            modulo2=vx(i)**2+vy(i)**2+vz(i)**2
            suma2=modulo2+suma2
            suma4=modulo2**2+suma4

      !      if (sqrt(modulo2).gt.vmax) pause 'Velocidad fuera del
  !   &histograma(|v|>vmax)'

          end do

          suma2=suma2/npart
          suma4=suma4/npart

          v2=v2+suma2
          v4=v4+suma4

          print*,'medida #',k/nmed,'   de',nchoques/nmed
          print*,'v2',suma2,'   v4 ',suma4

c-------------------------------------------------------------------------------------
          CALL HISTOGRAMA(vx,vy,vz,npart,ninter,h,p,px,py,pz)
c-------------------------------------------------------------------------------------

        end if

      end do

      return
      end

c-----------------------------------------------------------------------------------------------------------------
c-----------------------------------------------------------------------------------------------------------------

      SUBROUTINE HISTOGRAMA(vx,vy,vz,npart,ninter,h,p,px,py,pz)
      !ENTRADA: vx,vy,vz,npart,h
      !SALIDA:  p,px,py,pz

      REAL*8 vx(npart),vy(npart),vz(npart),v(npart),h
      INTEGER i,j,npart,ninter
      integer px(0:2*ninter),py(0:2*ninter),pz(0:2*ninter),p(0:2*ninter)

      do i=1,npart

        v(i)=dsqrt(vx(i)**2+vy(i)**2+vz(i)**2)
        j=floor((v(i))/h)

        if ((j.lt.0).OR.(j.gt.2*ninter)) then

          print*,'ERROR, PARTICULA FUERRA DEL HISTOGRAMA p=',j

        else

          p(j)=p(j)+1

        end if

      end do

      do i=1,npart

        j=nint((vx(i))/h)+ninter

        if ((j.lt.0).OR.(j.gt.2*ninter)) then

          print*,'ERROR, PARTICULA FUERRA DEL HISTOGRAMA px=',j

        else

          px(j)=px(j)+1

        end if

      end do

      do i=1,npart

        j=nint((vy(i))/h)+ninter

        if ((j.lt.0).OR.(j.gt.2*ninter)) then

          print*,'ERROR, PARTICULA FUERRA DEL HISTOGRAMA py=',j

        else

          py(j)=py(j)+1

        end if

      end do

      do i=1,npart

        j=nint((vz(i))/h)+ninter

        if ((j.lt.0).OR.(j.gt.2*ninter)) then

          print*,'ERROR, PARTICULA FUERRA DEL HISTOGRAMA pz=',j

        else

          pz(j)=pz(j)+1

        end if

      end do

      return
      end

c-----------------------------------------------------------------------------------------------------------------
c-----------------------------------------------------------------------------------------------------------------

      SUBROUTINE REESCALAR(vx,vy,vz,npart,temp)
      !ENTRADA: vx,vy,vz,npart
      !SALIDA: temp,suma

      REAL*8 suma,vx(npart),vy(npart),vz(npart),temp
      INTEGER i,npart
      REAL*8 sumax,sumay,sumaz,momentox,momentoy,momentoz

!IMPONEMOS MOMENTO TOTAL NULO

      sumax=0.d0
      sumay=0.d0
      sumaz=0.d0

      do i=1,npart

        sumax=sumax+vx(i)
        sumay=sumay+vy(i)
        sumaz=sumaz+vz(i)

      end do

!      print*,"Momento viejo:", sumax,sumay,sumaz

      momentox=sumax/npart
      momentoy=sumay/npart
      momentoz=sumaz/npart

c       Nuevas velocidades:
      sumax=0.d0
      sumay=0.d0
      sumaz=0.d0

      do i=1,npart

        vx(i)=vx(i)-momentox
        vy(i)=vy(i)-momentoy
        vz(i)=vz(i)-momentoz
        !print*, "vx",i,":",vx(i)
        !print*, "vy",i,":",vy(i)
        !print*, "vz",i,":",vz(i)
        sumax=sumax+vx(i)
        sumay=sumay+vy(i)
        sumaz=sumaz+vz(i)

      end do

!      print*,"Momento nuevo:", sumax,sumay,sumaz
       !hasta aqui

      suma=0.d0

      do i=1,npart

        suma=vx(i)**2+vy(i)**2+vz(i)**2+suma

      end do

      suma=suma/npart
      temp=2*suma/3		                        !3 es por la dimensión del espacio
      !print*,'Temperatura =',temp

      temp=1d0/dsqrt(temp)                         !buenas costumbres

      do i=1,npart

        vx(i)=vx(i)*temp
        vy(i)=vy(i)*temp
        vz(i)=vz(i)*temp

      end do

      return
      end


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c ... file isfvpgs.f
c
c     this file includes documentation and code for
c     subroutine isfvpgs          i
c
c ... files which must be loaded with isfvpgs.f
c
c     sphcom.f, hrfft.f, vhsgs.f, shags.f, gaqd.f
c
c
c     subroutine isfvpgs(nlat,nlon,isym,nt,sf,vp,idv,jdv,as,bs,av,bv,
c    +                   mdb,ndb,wvhsgs,lvhsgs,work,lwork,ierror)
c
c     given the scalar spherical harmonic coefficients as,bs precomputed
c     by shags for the scalar stream function sf and av,bv precomputed by
c     shags for the scalar velocity potenital vp, subroutine isfvpgs computes
c     the vector field (v,w) corresponding to sf and vp.  w is the east
c     longitudinal and v is the colatitudinal component of the vector field.
c     (v,w) is expressed in terms of sf,vp by the helmholtz relations (in
c     mathematical spherical coordinates):
c
c          v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta
c
c          w =  1/sin(theta)*d(st)/dlambda + d(vp)/dtheta
c
c     required legendre functions are stored rather than recomputed as
c     they are in subroutine isfvpgc.  v(i,j) and w(i,j) are given at
c     the i(th) gaussian colatitude point (see gaqd) theta(i) and east
c     longitude lambda(j) = (j-1)*2.*pi/nlon on the sphere.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are computed
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater than
c            3.  the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   a parameter which determines whether the vector field is
c            computed on the full or half sphere as follows:
c
c      = 0
c
c            the symmetries/antsymmetries described in isym=1,2 below
c            do not exist in sf,vp about the equator.  in this case v
c            and w are not necessarily symmetric or antisymmetric about
c            equator.  v and w are computed on the entire sphere.
c            i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and
c            j=1,...,nlon.
c
c      = 1
c
c            vp is antisymmetric and sf is symmetric about the equator.
c            in this case v is symmetric and w antisymmetric about
c            the equator and are computed for the northern hemisphere
c            only.  i.e., if nlat is odd the v(i,j),w(i,j) are computed
c            for i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is
c            even then v(i,j),w(i,j) are computed for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c      = 2
c
c            vp is symmetric and sf is antisymmetric about the equator.
c            in this case v is antisymmetric and w symmetric about
c            the equator and are computed for the northern hemisphere
c            only.  i.e., if nlat is odd the v(i,j),w(i,j) are computed
c            for i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is
c            even then v(i,j),w(i,j) are computed for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c     nt     nt is the number of scalar and vector fields.  some
c            computational efficiency is obtained for multiple fields. arrays
c            can be three dimensional corresponding to an indexed multiple
c            vector field.  in this case multiple vector synthesis will
c            be performed to compute (v,w) for each field.  the
c            third index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt = 1.  the
c            description of the remaining parameters is simplified by
c            assuming that nt=1 or that all the arrays are two dimensional.
c
c     idv    the first dimension of the arrays v,w as it appears in
c            the program that calls isfvpgs. if isym = 0 then idv
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then idv must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then idv must be at least (nlat+1)/2.
c
c     jdv    the second dimension of the arrays v,w as it appears in
c            the program that calls isfvpgs. jdv must be at least nlon.
c
c     as,bs  two or three dimensional arrays (see input parameter nt)
c            that contain the spherical harmonic coefficients of
c            the scalar field sf as computed by subroutine shags.
c
c     av,bv  two or three dimensional arrays (see input parameter nt)
c            that contain the spherical harmonic coefficients of
c            the scalar field vp as computed by subroutine shags.
c
c     mdb    the first dimension of the arrays as,bs,av,bv as it
c            appears in the program that calls isfvpgs. mdb must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndb    the second dimension of the arrays as,bs,av,bv as it
c            appears in the program that calls isfvpgs. ndb must be at
c            least nlat.
c
c     wvhsgs an array which must be initialized by subroutine vhsgsi.
c            once initialized, wvhsgs can be used repeatedly by isfvpgs
c            as long as nlon and nlat remain unchanged.  wvhsgs must
c            not bel altered between calls of isfvpgs.
c
c
c     lvhsgs the dimension of the array wvhsgs as it appears in the
c            program that calls isfvpgs. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhsgs must be at least
c
c                 l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls isfvpgs. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c
c            if isym = 0 then lwork must be at least
c
c               nlat*((2*nt+1)*nlon + 4*l1*nt + 1)
c
c            if isym = 1 or 2 then lwork must be at least
c
c               (2*nt+1)*l2*nlon + nlat*(4*l1*nt+1)
c
c     **************************************************************
c
c     output parameters
c
c    v,w    two or three dimensional arrays (see input parameter nt)
c           that contains the vector field corresponding to the stream
c           function sf and velocity potential vp whose coefficients,
c           as,bs (for sf) and av,bv (for vp), were precomputed by
c           subroutine shags.  v(i,j) and w(i,j) are given at the
c           i(th) gaussian colatitude point theta(i) and east longitude
c           point lambda(j) = (j-1)*2*pi/nlon.  the index ranges are
c           defined above at the input parameter isym.
c
c
c    ierror = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of idv
c           = 6  error in the specification of jdv
c           = 7  error in the specification of mdb
c           = 8  error in the specification of ndb
c           = 9  error in the specification of lvhsgs
c           = 10 error in the specification of lwork
c **********************************************************************
c
      subroutine isfvpgs(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv,
     +                   mdb,ndb,wvhsgs,lvhsgs,work,lwork,ierror)
      implicit none
      integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,lvhsgs,lwork,ierror
      real v(idv,jdv,nt),w(idv,jdv,nt)
      real as(mdb,ndb,nt),bs(mdb,ndb,nt)
      real av(mdb,ndb,nt),bv(mdb,ndb,nt)
      real wvhsgs(lvhsgs),work(lwork)
      integer l1,l2,mn,is,lwk,iwk,lwmin
      integer ibr,ibi,icr,ici
c
c     check input parameters
c
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if (nlon .lt. 4) return
      ierror = 3
      if (isym.lt.0 .or. isym.gt.2) return
      ierror = 4
      if (nt .lt. 0) return
      ierror = 5
      l2 = (nlat+1)/2
      if((isym.eq.0 .and. idv.lt.nlat) .or.
     +   (isym.gt.0 .and. idv.lt.l2)) return
      ierror = 6
      if(jdv .lt. nlon) return
      ierror = 7
      l1 = min0(nlat,(nlon+1)/2)
      if (mdb .lt. min0(nlat,(nlon+2)/2)) return
      ierror = 8
      if (ndb .lt. nlat) return
      ierror = 9
      lwmin = l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat
      if (lvhsgs .lt. lwmin) return
      ierror = 10
      if (isym .eq. 0) then
	lwmin = nlat*((2*nt+1)*nlon+4*l1*nt+1)
      else
	lwmin = (2*nt+1)*l2*nlon + nlat*(4*l1*nt+1)
      end if
      if (lwork .lt. lwmin) return
c
c     set first dimension for br,bi,cr,ci (as requried by vhsgs)
c
      mn = l1*nlat*nt
      ierror = 0
c
c     set work space pointers
c
      ibr = 1
      ibi = ibr+mn
      icr = ibi+mn
      ici = icr+mn
      is = ici+mn
      iwk = is+nlat
      lwk = lwork-4*mn-nlat
      call isfvpgs1(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv,mdb,
     +ndb,work(ibr),work(ibi),work(icr),work(ici),l1,work(is),
     +wvhsgs,lvhsgs,work(iwk),lwk,ierror)
      return
      end

      subroutine isfvpgs1(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv,
     +mdb,ndb,br,bi,cr,ci,mab,fnn,wvhsgs,lvhsgs,wk,lwk,ierror)
      implicit none
      integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,mab,lvhsgs,lwk,ierror
      real v(idv,jdv,nt),w(idv,jdv,nt)
      real as(mdb,ndb,nt),bs(mdb,ndb,nt)
      real av(mdb,ndb,nt),bv(mdb,ndb,nt)
      real br(mab,nlat,nt),bi(mab,nlat,nt)
      real cr(mab,nlat,nt),ci(mab,nlat,nt)
      real wvhsgs(lvhsgs),wk(lwk),fnn(nlat)
      integer n,m,mmax,k,ityp
c
c     set coefficient multiplyers
c
      do n=2,nlat
	fnn(n) = -sqrt(float(n*(n-1)))
      end do
      mmax = min0(nlat,(nlon+1)/2)
c
c     compute (v,w) coefficients from as,bs,av,bv
c
      do k=1,nt
	do n=1,nlat
	  do m=1,mab
	    br(m,n,k) = 0.0
	    bi(m,n,k) = 0.0
	    cr(m,n,k) = 0.0
	    ci(m,n,k) = 0.0
	  end do
	end do
c
c     compute m=0 coefficients
c
	do n=2,nlat
	  br(1,n,k) = -fnn(n)*av(1,n,k)
	  bi(1,n,k) = -fnn(n)*bv(1,n,k)
	  cr(1,n,k) =  fnn(n)*as(1,n,k)
	  ci(1,n,k) =  fnn(n)*bs(1,n,k)
	end do
c
c     compute m>0 coefficients using vector spherepack value for mmax
c
	do m=2,mmax
	  do n=m,nlat
	    br(m,n,k) = -fnn(n)*av(m,n,k)
	    bi(m,n,k) = -fnn(n)*bv(m,n,k)
	    cr(m,n,k) =  fnn(n)*as(m,n,k)
	    ci(m,n,k) =  fnn(n)*bs(m,n,k)
	  end do
	end do
      end do
c
c     synthesize br,bi,cr,ci into (v,w)
c
      if (isym .eq.0) then
	ityp = 0
      else if (isym .eq.1) then
	ityp = 3
      else if (isym .eq.2) then
	ityp = 6
      end if
      call vhsgs(nlat,nlon,ityp,nt,v,w,idv,jdv,br,bi,cr,ci,
     +           mab,nlat,wvhsgs,lvhsgs,wk,lwk,ierror)
      return
      end


SUBROUTINE TEST10(m,n)
    REAL, DIMENSION(1:100,1:100) :: a,b
    REAL, DIMENSION(1:100) ::w
    REAL change,tolerance
    INTEGER i,j,iters

      change = tolerance + 1
      iters = 0
      do while ( change > tolerance )
         iters = iters + 1
         change = 0

!$xev dir add(acc,data,copy(a(1:n,1:m)),create(b(2:n-1,2:m-1)),copyin(w(2:n-1)))

!$xev dir replace(acc,kernels)
!$acc kernels loop
         do j = 2, n-1
            do i = 2, m-1
              b(i,j) = 0.25*w(i)*(a(i-1,j)+a(i,j-1)+ &
                                   a(i+1,j)+a(i,j+1)) &
                        +(1.0-w(i))*a(i,j)
            end do
         end do

         do j = 2, n-1
            do i = 2, m-1
              a(i,j) = b(i,j)
            end do
         end do

!$xev dir add(acc,end,kernels)
    end do

    RETURN
END


! THIS VERSION: GALAHAD 2.2 - 26/05/2008 AT 10:30 GMT.
   PROGRAM GALAHAD_LSRT2_BIT_TEST
   USE GALAHAD_LSRT_DOUBLE                            ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: working = KIND( 1.0D+0 ) ! set precision
   INTEGER, PARAMETER :: dim_max = 3
   INTEGER, PARAMETER :: cond_max = 2
   INTEGER, PARAMETER :: sig_max = 5
   INTEGER :: it_min( sig_max, cond_max, dim_max )
   INTEGER :: it_max( sig_max, cond_max, dim_max )
   REAL ( KIND = working ) :: p = 3.0_working         ! order of regulatisation
   REAL ( KIND = working ) :: it_mean( sig_max, cond_max, dim_max )
   REAL ( KIND = working ), PARAMETER :: one = 1.0_working, zero = 0.0_working
   REAL ( KIND = working ), PARAMETER :: two = 2.0_working
   INTEGER :: m, n, i, mn, dim, sig, cond
   REAL ( KIND = working ) :: sigma, rho, c, e, tyty, tztz, prod
   REAL ( KIND = working ) :: sigmae( sig_max )
   REAL ( KIND = working ) :: rhos( cond_max )
   REAL ( KIND = working ), ALLOCATABLE, DIMENSION( : ) :: X, V, U, RES, Y, Z, D
   REAL ( KIND = working ), ALLOCATABLE, DIMENSION( : ) :: Wm, Wn
   TYPE ( LSRT_data_type ) :: data
   TYPE ( LSRT_control_type ) :: control
   TYPE ( LSRT_inform_type ) :: inform
   sigmae = (/ 0.0001_working, 0.01_working, 1.0_working, 100.0_working,        &
               10000.0_working /)
   rhos = (/ 0.01_working, 0.0001_working /)

!  Set up data -

!  A = ( I_m - yy^T/2y^Ty) D ( I_n - zz^T/2z^Tz), where
!  y_i = 1 (i=1:n), z_i = 1 (i=1:n:2), -1 (i=2:n:2) and
!  D=0 except D_ii = c + e*i (i=1:min(m,n)),
!  e = (1-rho)/(1-min(m,n)), c = 1-e
!  b_i = 1

   WRITE( 44, "( '   m     n       cond       sigma    min mean max ' )" )

   it_min = 0 ; it_max = 0 ; it_mean = zero
   DO dim = 1, dim_max
!  DO dim = 3, 3
    SELECT CASE( dim )
    CASE ( 1 )
      n = 5000
      m = 1000
    CASE ( 2 )
      n = 1000
      m = 5000
    CASE ( 3 )
      n = 5000
      m = 5000
    END SELECT

    mn = MIN( m, n )
    ALLOCATE( X( n ), V( n ), U( m ), RES( m ), Y( m ), Z( n ), D( mn ) )
    ALLOCATE( Wm( m ), Wn( n ) )
    Y = one
    DO i = 1, n, 2
      Z( i ) = one ; Z( i + 1 ) = - one
    END DO
    tyty = two * DOT_PRODUCT( Y, Y )
    tztz = two * DOT_PRODUCT( Z, Z )

    DO cond = 1, cond_max
!   DO cond = 2, 2
     rho = rhos( cond )

     e = ( one - rho ) / ( one - mn ) ; c = one - e
     DO i = 1, mn
       D( i ) = c + e * i
     END DO

     DO sig = 1, sig_max
!    DO sig = 3, 3
      sigma = sigmae( sig )

      CALL LSRT_initialize( data, control )  ! Initialize control parameters
      control%fraction_opt = 0.99            ! Only require 99% of the best
!     control%print_level = 2
!     control%itmax = 4761

      U = one                 ! The term b
!     U( m ) = one ; U( 1 : m - 1 ) = zero                 ! The term b
      inform%status = 1
      DO  ! Iteration to find the minimizer
        CALL LSRT_solve( m, n, p, sigma, X, U, V, data, control, inform )
        SELECT CASE( inform%status )  !  Branch as a result of inform%status
        CASE( 2 )                     !  Form u <- u + A * v
          prod = DOT_PRODUCT( V, Z ) / tztz
          Wn = V - prod * Z
          IF ( m <= n ) THEN
            Wm = Wn( : m ) * D( : m )
          ELSE
            Wm( : n ) = Wn * D
            Wm( n + 1 : ) = zero
          END IF
          prod = DOT_PRODUCT( Wm, Y ) / tyty
          U = U + Wm - prod * Y
        CASE( 3 )                     !  Form v <- v + A^T * u
          prod = DOT_PRODUCT( U, Y ) / tyty
          Wm = U - prod * Y
          IF ( n <= m ) THEN
            Wn = Wm( : n ) * D( : n )
          ELSE
            Wn( : m ) = Wm * D
            Wn( m + 1 : ) = zero
          END IF
          prod = DOT_PRODUCT( Wn, Z ) / tztz
          V = V + Wn - prod * Z
        CASE ( 4 )                    !  Restart
!         U( m ) = one ; U( 1 : m - 1 ) = zero ! re-initialize u to b
          U = one                     !  re-initialize u to b
        CASE ( - 2 : 0 )              !  Successful return
          prod = DOT_PRODUCT( X, Z ) / tztz
          Wn = X - prod * Z
          IF ( m <= n ) THEN
            Wm = Wn( : m ) * D( : m )
          ELSE
            Wm( : n ) = Wn * D
            Wm( n + 1 : ) = zero
          END IF
          prod = DOT_PRODUCT( Wm, Y ) / tyty
          RES = Wm - prod * Y - one
          WRITE( 6, "( 1X, I0, ' 1st pass and ', I0, ' 2nd pass iterations' )" )&
            inform%iter, inform%iter_pass2
          WRITE( 6, "( ' objective recurred and calculated = ', 2ES16.8 )" )    &
            inform%obj, 0.5_working * DOT_PRODUCT( RES, RES ) + ( sigma / p ) * &
            ( SQRT( DOT_PRODUCT( X, X ) ) ) ** p
          WRITE( 6, "( '   ||x||  recurred and calculated = ', 2ES16.8 )" )     &
            inform%x_norm, SQRT( DOT_PRODUCT( X, X ) )
          WRITE( 6, "( ' ||Ax-b|| recurred and calculated = ', 2ES16.8 )" )     &
            inform%r_norm, SQRT( DOT_PRODUCT( RES, RES ) )
          WRITE( 6, "( ' m, n, cond, sigma ',  I0, 1X, I0, 2ES12.4 )" )        &
            m, n, one / rho, sigma
          WRITE( 6, "( ' min, mean, max, number boundary iterations ',          &
         & I0, F4.1, 1X, I0, 1X, I0 )" ) inform%biter_min, inform%biter_mean,   &
             inform%biter_max, inform%biters
          WRITE( 44, "( 2I6, 2ES12.4, I4, F5.1, I4, I6 )" ) m, n, one / rho,    &
            sigma, inform%biter_min, inform%biter_mean,                        &
             inform%biter_max, inform%biters
          CALL LSRT_terminate( data, control, inform ) !delete internal workspace
          it_min( sig, cond, dim ) = inform%biter_min
          it_max( sig, cond, dim ) = inform%biter_max
          it_mean( sig, cond, dim ) = inform%biter_mean
          EXIT
        CASE DEFAULT !  Error returns
          WRITE( 6, "( ' LSRT_solve exit status = ', I6 ) " ) inform%status
          CALL LSRT_terminate( data, control, inform ) !delete internal workspace
          EXIT
        END SELECT
      END DO
     END DO
    END DO
    DEALLOCATE( X, V, U, RES, Y, Z, D, Wm, Wn )
   END DO

   DO sig = 1, sig_max
    DO cond = 1, cond_max
      WRITE( 45, "( F0.5, ' & ' , F0.0, ' & ' )" )                             &
         sigmae( sig ), one / rhos( cond )
     WRITE( 45, "( 3 ( I4, ' & ',  F5.1, ' & ', I4, ' & ' ) )" )               &
       ( it_min( sig,  cond, dim ), it_mean( sig,  cond, dim ),                &
         it_max( sig,  cond, dim ), dim = 1, dim_max )
   END DO
   END DO

   END PROGRAM GALAHAD_LSRT2_BIT_TEST


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION RINTHF (I, J, K)
!                                                                      *
!   The value of RINTHF is an approximation to:                        *
!                                                                      *
!              K                                                       *
!         I ( r  * ( P (r)*Q (r) + Q (r)*P (r) ; 0 to infinity)        *
!                     I     J       I     J                            *
!                                                                      *
!   where   I ( G(r) ; Range )  denotes  the  integral  of G(r) over   *
!   Range. This is a modification of RINT for the Type B operator.     *
!                                                                      *
!   Call(s) to: [LIB92]: QUAD.                                         *
!                                                                      *
!   Written by Per O. Jonsson             Last revision: 24 Dec 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:06:03   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  11/01/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE grid_C
      USE tatb_C
      USE wave_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE quad_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: I
      INTEGER  :: J
      INTEGER, INTENT(IN) :: K
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: L
      REAL(DOUBLE) :: RESULT
!-----------------------------------------------
!
!   Tabulate integrand as required for SUBROUTINE QUAD
!
      MTP = MIN(MF(I),MF(J))
!
!   Value at first tabulation point is arbitrary
!
      TA(1) = 0.0D00
      DO L = 2, MTP
         TA(L) = R(L)**K*(PF(L,I)*QF(L,J) + QF(L,I)*PF(L,J))*RP(L)
      END DO
!
!   Perform integration
!
      CALL QUAD (RESULT)
      RINTHF = RESULT
!
      RETURN
      END FUNCTION RINTHF


	dimension x(42),y(42),a(42,42),xf1(84),yf1(84)
	dimension rmax(500),rmin(500)
	data xa,ya,xb,yb/0.525,1.025,2*1.525/
	data x(1),y(1),x(2),y(2)/-0.01,-0.01,0.,0./
	do 85 i=3,42
	x(i)=x(i-1)+0.05
85	y(i)=x(i)
	do 86 k=1,42
	a(1,k)=-0.3
86	a(k,1)=-0.3
	do 87 j=2,42
	do 87 i=2,42
87	a(i,j)=.2*(1./sqrt((x(i)-xa)**2+(y(j)-ya)**2)+
     *       2./sqrt((x(i)-xb)**2+(y(j)-yb)**2))
	call setpen(3)
	call page(32.,22.,'SURFACE',7,1)
	call region(1.,1.,30.,20.,0,0,0)
	call setpen(5)
	call mnmx(-15.,-20.,10.,x,y,a,42,42,1,42,1,42,s)
	call prsp(-15.,-20.,10.,x,y,a,42,42,1,42,1,42,xf1,yf1,
     *       rmax,rmin,500)
	call endpg(0)
	end


!@(#) Draws patches of various bases
!(LICENSE:PD)
!
        program fpatch

      use M_draw

        character(len=20) :: dev

        integer BLACK, RED, GREEN, YELLOW, BLUE, CYAN, WHITE
        parameter (BLACK = 0, RED = 1, GREEN = 2, YELLOW = 3, BLUE = 4, CYAN = 5, WHITE = 7)

!
!  patch basis types
!
        real bezier(4,4), cardinal(4, 4), bspline(4, 4)
        real power(4, 4)
        real x1(4, 4), y1(4, 4), z1(4, 4)
        real x2(4, 4), y2(4, 4), z2(4, 4)

        character(len=50) ::  labels(4)

        real    basis(64)
        equivalence (basis(1), bezier(1, 1))
        equivalence (basis(17), cardinal(1, 1))
        equivalence (basis(33), bspline(1, 1))
        equivalence (basis(49), power(1, 1))

        data bezier/                                                    &
     &          -1.0,   3.0,    -3.0,   1.0,                            &
     &          3.0,    -6.0,   3.0,    0.0,                            &
     &          -3.0,   3.0,    0.0,    0.0,                            &
     &          1.0,    0.0,    0.0,    0.0/

        data cardinal/                                                  &
     &          -0.5,   1.5,    -1.5,   0.5,                            &
     &          1.0,    -2.5,   2.0,    -0.5,                           &
     &          -0.5,   0.0,    0.5,    0.0,                            &
     &          0.0,    1.0,    0.0,    0.0/

        data bspline/                                                   &
     &          -0.166666,     0.5,     -0.5,     0.166666,             &
     &           0.5,         -1.0,      0.5,     0.0,                  &
     &          -0.5,          0.0,      0.5,     0.0,                  &
     &           0.166666,     0.666666, 0.166666, 0.0 /

        data power/                                                     &
     &          1.0, 0.0, 0.0, 0.0,                                     &
     &          0.0, 1.0, 0.0, 0.0,                                     &
     &          0.0, 0.0, 1.0, 0.0,                                     &
     &          0.0, 0.0, 0.0, 1.0/

        data    x1 /                                                    &
     &          0.0,   0.2588,   0.5,   0.7071,                         &
     &          0.0,   0.51764,  1.0,   1.4142,                         &
     &          0.0,   0.51764,  1.0,   1.4142,                         &
     &          0.0,   0.2588,   0.5,   0.7071/

        data    y1 /                                                    &
     &          1.0,   0.966,   0.866,  0.7071,                         &
     &          2.0,   1.9318,  1.732,  1.4142,                         &
     &          2.0,   1.9318,  1.732,  1.4142,                         &
     &          1.0,   0.966,   0.866,  0.7071/

        data    z1 /                                                    &
     &          1.0,   1.0,     1.0,    1.0,                            &
     &          1.0,   1.0,     1.0,    1.0,                            &
     &          0.0,   0.0,     0.0,    0.0,                            &
     &          0.0,   0.0,     0.0,    0.0/

        data    x2 /                                                    &
     &          0.7071, 0.8660, 0.9660, 1.0,                            &
     &          1.4142, 1.7320, 1.932,  2.0,                            &
     &          1.4142, 1.7320, 1.932,  2.0,                            &
     &          0.7071, 0.8660, 0.9660, 1.0/

        data    y2 /                                                    &
     &          0.7071, 0.5,    0.2588, 0.0,                            &
     &          1.4142, 1.0,    0.5176, 0.0,                            &
     &          1.4142, 1.0,    0.5176, 0.0,                            &
     &          0.7071, 0.5,    0.2588, 0.0/

        data    z2 /                                            &
     &          1.0,   1.0,     1.0,    1.0,                            &
     &          1.0,   1.0,     1.0,    1.0,                            &
     &          0.0,   0.0,     0.0,    0.0,                            &
     &          0.0,   0.0,     0.0,    0.0/

        data labels /                                                   &
     &          'Bezier Patch(es)',                                     &
     &          'Cardinal Patch(es)',                                   &
     &          'B-Spline Patch(es)',                                   &
     &          '''Power'' Patch(es)' /

!
!  demonstrate patches
!

        write (*,*)'Enter device:'
        read(*,'(a)') dev

        call vinit(dev)

        call vsetflush(.true.)

        call color(BLACK)
        call clear

!
! Set up two viewports (They actually overlap)
!

        call viewport(-1.0, 0.3, -1.0, 0.3)
        call ortho(-2.0, 5.0, -2.0, 5.0, -2.0, 5.0)
        call lookat(0.0, 0.0, 0.0, -3.0, 2.0, -4.0, 0.0)
!
!       Save it
!
        call pushviewport
        call pushmatrix

        call viewport(-0.3, 1.0, -0.3, 1.0)
        call ortho(-2.0, 5.0, -2.0, 5.0, -2.0, 5.0)
        call lookat(0.0, 0.0, 0.0, 3.0, 2.0, -4.0, 0.0)

        call textsize(0.4, 0.4)

!
!       patchcurves provides a number of curves in the t and u
!       directions. patchprecision gives the minimum number of line
!       segments making up the curves in the t and u directions. The
!       actual number of linesegments in t or u is equal to the closest
!       integer multiple of the number of curves, > nsegs, in t or u,
!       greater than or equal to the number set by patchprecision in u or
!       t. eg. curves in t will be made up of 21 line segments so that we
!       can match up the 7 curves in u; curves in u will have 24 as 4 by 5
!       gives 20.
!
        call patchcurves(4, 7)
        call patchprecision(20, 20)

        do 10 i = 0, 3

                call axes

!
!               patchbasis sets the basis matrices for the t and u
!               functions
!
!
                call patchbasis(basis(i*16 + 1), basis(i*16 + 1))

!
!               Draw with viewport 2
!
                call move(0.0, 4.0, 0.0)
                call drawstr(labels(i+1))

!
!               Now draw the patches according to the geometry matrices in
!               x1, y1, and z1, x2, y2, z2.
!
                call drawhull(x1, y1, z1)
                call patch(x1, y1, z1)

                call drawhull(x2, y2, z2)
                call patch(x2, y2, z2)
!
!               Now with viewport 1
!
                call popviewport
                call popmatrix

                call axes

                call move(0.0, 4.0, 0.0)
                call drawstr(labels(i + 1))

!
!               now draw the patches according to the geometry matrices in
!               x1, y1, and z1, x2, y2, z2.
!
                call drawhull(x1, y1, z1)
                call patch(x1, y1, z1)

                call drawhull(x2, y2, z2)
                call patch(x2, y2, z2)

                idum=getkey()

!
!               Save viewport 1 again and reset to viewport 2
!
                call pushviewport
                call pushmatrix

                call viewport(-0.3, 1.0, -0.3, 1.0)
                call ortho(-1.5, 5.0, -1.5, 5.0, -1.5, 5.0)
                call lookat(0.0, 0.0, 0.0, 3.0, 2.0, -4.0, 0.0)

                call color(BLACK)
                call clear
10      continue

        call vexit

        end

        subroutine drawhull(x, y, z)

      use M_draw

        real    x(4,4), y(4,4), z(4,4)

        integer MAGENTA, WHITE, GREEN
        parameter (MAGENTA = 5, WHITE = 7, GREEN = 2)

        call color(MAGENTA)
        do 10 i = 1,4
                call move(x(i,1), y(i,1), z(i,1))
                do 5 j = 1,4
                        call draw(x(i,j), y(i,j), z(i,j))
5               continue
10      continue

        do 20 i = 1,4
                call move(x(1,i), y(1,i), z(1,i))
                do 15 j = 1,4
                        call draw(x(j,i), y(j,i), z(j,i))
15              continue
20      continue

        call color(GREEN)
        end

!
! axes
!
!       draw the axes
!
        subroutine axes

      use M_draw

        integer YELLOW
        parameter (YELLOW = 3)

        call color(YELLOW)
        call move(0.0, 0.0, 0.0)
        call draw(4.0, 0.0, 0.0)

        call move(0.0, 0.0, 0.0)
        call draw(0.0, 4.0, 0.0)

        call move(0.0, 0.0, 0.0)
        call draw(0.0, 0.0, 4.0)

        end


C
C $Id: msfndp.f,v 1.5 2008-07-27 00:17:09 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      DOUBLE PRECISION FUNCTION MSFNDP (ECCENT,SINPHI,COSPHI)
C
C This function computes the constant "small m".
C
      IMPLICIT DOUBLE PRECISION (A-Z)
      DATA ONE /1.0D0/
C
      CON = ECCENT * SINPHI
      MSFNDP = COSPHI / SQRT (ONE - CON * CON)
C
      RETURN
      END


      COMPLEX FUNCTION CERROR(X,Y)
c
C  SIXTH-ORDER APPROX TO THE COMPLEX ERROR FUNCTION OF X+i*Y.
C  Y MUST BE POSITIVE.
C  REFERENCE FOR EQUATIONS:
C      HUI, ARMSTRONG AND WRAY, JQSRT V.19, P.509 (1978).
C
C     P. ROSENKRANZ  2/19/88
C
      REAL X,Y
      COMPLEX A,B,ZH
      ZH = CMPLX(Y,-X)
      A = (((((.5641896*ZH+5.912626)*ZH+30.18014)*ZH+
     & 93.15558)*ZH+181.9285)*ZH+214.3824)*ZH+122.6079
      B = ((((((ZH+10.47986)*ZH+53.99291)*ZH+170.3540)*ZH+
     & 348.7039)*ZH+457.3345)*ZH+352.7306)*ZH+122.6079
      CERROR = A/B
      RETURN
      END


!***********************************/
!	Name:オイラー陽解法による時間積分プログラム
!	Alias:ExplicitEulerMethod
!	Description:時間1次精度(基本これで十分)
!	Type:Geom,CellEdge,CellCenter
!	Input:Geom,CC,CE
!	Output:CC%ConservedQuantity
!	Note:1~3次元すべてに対応済み
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2017.11.06
!	Other:
!***********************************/
subroutine ExplicitEulerMethod(Geom,CE,CC)
use StructVar_Mod
use LoopVar_Mod
use ConstantVar_Mod
implicit none
    type(Geometry),intent(in) :: Geom
    type(CellEdge), intent(in) :: CE
    type(CellCenter), intent(inout) :: CC
    double precision :: InverseVolume
    double precision,allocatable :: FluxSum(:)

        allocate(FluxSum(Geom%Dimension+2))

        InverseVolume = 1.0d0/Geom%Volume(1)

    if(Geom%Dimension == 1) then

        do iCenterX = 1, Geom%CellNumber(1)
            FluxSum(:) = CE%NormalFluxDiff(:,iFX,1,1,1)-CE%NormalFluxDiff(:,iFX-1,1,1,1)
            CC%ConservedQuantity(:,iCX,1,1) = CC%ConservedQuantity(:,iCX,1,1) - InverseVolume &
                &   * CC%TimeWidth(iTX,iTY,iTZ)*FluxSum
        end do

    else if(Geom%Dimension == 2) then
        !if(allocated(Geom%Interpolated)) then
        if(1 == 0) then
            do iCenterY = 1, Geom%CellNumber(2)
                do iCenterX = 1, Geom%CellNumber(1)
                    if(Geom%Interpolated(iCenterX,iCenterY,1) == 0) then
                        FluxSum(:) = (CE%NormalFluxDiff(:,iFX,iFY,1,1) - CE%NormalFluxDiff(:,iFX-1,iFY,1,1)) * Geom%Area(1) &
                            &   + (CE%NormalFluxDiff(:,iFX,iFY,1,2) - CE%NormalFluxDiff(:,iFX,iFY-1,1,2)) * Geom%Area(2)
                        CC%ConservedQuantity(:,iCX,iCY,1) = CC%ConservedQuantity(:,iCX,iCY,1) - InverseVolume &
                            &   * CC%TimeWidth(iTX,iTY,iTZ)*FluxSum

                    end if
                end do
            end do

        else

            do iCenterY = 1, Geom%CellNumber(2)
                do iCenterX = 1, Geom%CellNumber(1)
                        FluxSum(:) = (CE%NormalFluxDiff(:,iFX,iFY,1,1) - CE%NormalFluxDiff(:,iFX-1,iFY,1,1)) * Geom%Area(1) &
                            &   + (CE%NormalFluxDiff(:,iFX,iFY,1,2) - CE%NormalFluxDiff(:,iFX,iFY-1,1,2)) * Geom%Area(2)
                        CC%ConservedQuantity(:,iCX,iCY,1) = CC%ConservedQuantity(:,iCX,iCY,1) - InverseVolume &
                            &   * CC%TimeWidth(iTX,iTY,iTZ)*FluxSum
                end do
            end do
        end if

    else
        do iCenterZ = 1, Geom%CellNumber(3)
            do iCenterY = 1, Geom%CellNumber(2)
                do iCenterX = 1, Geom%CellNumber(1)
                    FluxSum(:) = (CE%NormalFluxDiff(:,iFX,iFY,iFZ,1) - CE%NormalFluxDiff(:,iFX-1,iFY,iFZ,1)) * Geom%Area(1) &
                            &   + (CE%NormalFluxDiff(:,iFX,iFY,iFZ,2) - CE%NormalFluxDiff(:,iFX,iFY-1,iFZ,2)) * Geom%Area(2) &
                            &   + (CE%NormalFluxDiff(:,iFX,iFY,iFZ,3) - CE%NormalFluxDiff(:,iFX,iFY,iFZ-1,3)) * Geom%Area(3)
                    CC%ConservedQuantity(:,iCX,iCY,iCZ) = CC%ConservedQuantity(:,iCX,iCY,iCZ) - InverseVolume &
                        &   * CC%TimeWidth(iTX,iTY,iTZ)*FluxSum
                end do
            end do
        end do
    end if

return
end subroutine ExplicitEulerMethod


MODULE TNOConstants
    use ISO_FORTRAN_ENV
    REAL (kind=4),PARAMETER :: Cnuk = 5.5
    REAL (kind=4),PARAMETER :: kappa = 0.41
    REAL (kind=4),PARAMETER :: Cmu = 0.09
    REAL (kind=4),PARAMETER :: pi = 3.1415
    INTEGER (4),PARAMETER :: limit = 5000
    INTEGER (4)             :: i_omega
    !!REAL (ReKi),ALLOCATABLE :: omega(:)
    REAL (kind=4) :: omega
END MODULE TNOConstants
!===========================================================
MODULE Atmosphere
    use ISO_FORTRAN_ENV
    !atmosphere constants
    REAL (kind=4) nu
    REAL (kind=4) co
    REAL (kind=4) rho
END MODULE Atmosphere
!===========================================================
MODULE Wavenumber
    use ISO_FORTRAN_ENV
    REAL (kind=4)           :: k
    REAL (kind=4)           :: k1
    REAL (kind=4)           :: k3
END MODULE Wavenumber
!===========================================================
MODULE BLParams
    use ISO_FORTRAN_ENV
    REAL (kind=4)           :: d99(2)
    REAL (kind=4)           :: Cf(2)
    REAL (kind=4)           :: d_star(2)
    REAL (kind=4)           :: edgevel(2)
END MODULE BLParams
!===========================================================
MODULE AirfoilParams
    use ISO_FORTRAN_ENV
    CHARACTER*128         :: airfoil
    REAL(kind=4)          :: aofa,a_chord,Mach,Re
    REAL(kind=4)          :: xtrup, xtrlo
    LOGICAL               :: ISTRIPPED
    LOGICAL               :: ISNACA
    LOGICAL               :: ISSUCTION
END MODULE AirfoilParams
!===========================================================
MODULE Third_Octave_Bands
    use ISO_FORTRAN_ENV
    INTEGER (4),PARAMETER :: NumBands = 34
    REAL (kind=4),PARAMETER :: Third_Octave(NumBands) = (/10.,12.5,16.,20.,25.,31.5,40.,50.,63.,80.,	&
                                                        100.,125.,160.,200.,250.,315.,400.,500.,630.,800.,	&
                                                        1000.,1250.,1600.,2000.,2500.,3150.,4000.,5000.,6300.,8000.,	&
                                                        10000.,12500.,16000.,20000./)
END MODULE Third_Octave_Bands


subroutine t_knapsack
  use bl_IO_module
  use f2kcli
  use boxarray_module
  use box_util_module
  use knapsack_module
  use list_box_module
  integer :: np, n
  real(kind=dp_t) :: thresh
  logical :: verbose
  integer, allocatable :: iweights(:), prc(:)
  integer :: i
  character(len=128) fname
  type(boxarray) :: ba
  type(box) :: bx

  if ( command_argument_count() < 1 ) then
     np = 128
  else
     call get_command_argument(1, value = fname)
     read(fname,*) np
  end if

  print*, 'np = ', np

!  call read_a_mglib_grid_ba(ba, bx, '../../data/mglib_grids/grids.5034')
  call read_a_mglib_grid_ba(ba, bx, '../../data/mglib_grids/grids.1071')

  if (contains(ba,ba)) then
     print*, 'ba contains ba'
  else
     print*, 'ba does NOT contain ba'
  endif

  if (contains(ba,bx)) then
     print*, 'ba contains empty bx'
  else
     print*, 'ba does NOT contain empty bx'
  endif

  n = nboxes(ba)

  allocate(iweights(n))
  do i = 1, n
     iweights(i) = volume(get_box(ba,i))
  end do

  allocate(prc(n))

  verbose = .true.; thresh = 1.0_dp_t

  call knapsack_i(prc, iweights, np, verbose, thresh)

  call destroy(ba)

end subroutine t_knapsack