C Siconos-Numerics, Copyright INRIA 2005-2011.
C Siconos is a program dedicated to modeling, simulation and control
C of non smooth dynamical systems.
C Siconos is a free software; you can redistribute it and/or modify
C it under the terms of the GNU Lesser General Public License as published by
C the Free Software Foundation; either version 2 of the License, or
C (at your option) any later version.
C Siconos is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU Lesser General Public License for more details.
C
C You should have received a copy of the GNU Lesser General Public License
C along with Siconos; if not, write to the Free Software
C Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
C
C Contact: Vincent ACARY, siconos-team@lists.gforge.inria.fr
C
c-----------------------------------------------------------------------
c Demonstration program for DLSODPK.
c ODE system from ns-species interaction pde in 2 dimensions.
c This is the version of 14 June 2001.
c
c This version is in double precision.
c-----------------------------------------------------------------------
c This program solves a stiff ODE system that arises from a system
c of partial differential equations.  The PDE system is a food web
c population model, with predator-prey interaction and diffusion on
c the unit square in two dimensions.  The dependent variable vector is
c
c         1   2        ns
c   c = (c , c , ..., c  )
c
c and the PDEs are as follows:
c
c     i               i      i
c   dc /dt  =  d(i)*(c    + c   )  +  f (x,y,c)  (i=1,...,ns)
c                     xx     yy        i
c
c where
c                  i          ns         j
c   f (x,y,c)  =  c *(b(i) + sum a(i,j)*c )
c    i                       j=1
c
c The number of species is ns = 2*np, with the first np being prey and
c the last np being predators.  The coefficients a(i,j), b(i), d(i) are:
c
c   a(i,i) = -a  (all i)
c   a(i,j) = -g  (i .le. np, j .gt. np)
c   a(i,j) =  e  (i .gt. np, j .le. np)
c   b(i) =  b*(1 + alpha*x*y)  (i .le. np)
c   b(i) = -b*(1 + alpha*x*y)  (i .gt. np)
c   d(i) = dprey  (i .le. np)
c   d(i) = dpred  (i .gt. np)
c
c The various scalar parameters are set in subroutine setpar.
c
c The boundary conditions are: normal derivative = 0.
c A polynomial in x and y is used to set the initial conditions.
c
c The PDEs are discretized by central differencing on a mx by my mesh.
c
c The ODE system is solved by DLSODPK using method flag values
c mf = 10, 21, 22, 23, 24, 29.  The final time is tmax = 10, except
c that for mf = 10 it is tmax = 1.0d-3 because the problem is stiff,
c and for mf = 23 and 24 it is tmax = 2 because the lack of symmetry
c in the problem makes these methods more costly.
c
c Two preconditioner matrices are used.  One uses a fixed number of
c Gauss-Seidel iterations based on the diffusion terms only.
c The other preconditioner is a block-diagonal matrix based on
c the partial derivatives of the interaction terms f only, using
c block-grouping (computing only a subset of the ns by ns blocks).
c For mf = 21 and 22, these two preconditioners are applied on
c the left and right, respectively, and for mf = 23 and 24 the product
c of the two is used as the one preconditioner matrix.
c For mf = 29, the inverse of the product is applied.
c
c Two output files are written: one with the problem description and
c and performance statistics on unit 6, and one with solution profiles
c at selected output times (for mf = 22 only) on unit 8.
c-----------------------------------------------------------------------
c Note: In addition to the main program and 10 subroutines
c given below, this program requires the LINPACK subroutines
c DGEFA and DGESL, and the BLAS routine DAXPY.
c-----------------------------------------------------------------------
c Reference:
c     Peter N. Brown and Alan C. Hindmarsh,
c     Reduced Storage Matrix Methods in Stiff ODE Systems,
c     J. Appl. Math. & Comp., 31 (1989), pp. 40-91;
c     Also LLNL Report UCRL-95088, Rev. 1, June 1987.
c-----------------------------------------------------------------------
      external fweb, jacbg, solsbg
      integer ns, mx, my, mxns,
     1        mp, mq, mpsq, itmax,
     2        meshx,meshy,ngx,ngy,ngrp,mxmp,jgx,jgy,jigx,jigy,jxr,jyr
      integer i, imod3, iopt, iout, istate, itask, itol, iwork,
     1   jacflg, jpre, leniw, lenrw, liw, lrw, mf,
     2   ncfl, ncfn, neq, nfe, nfldif, nfndif, nli, nlidif, nni, nnidif,
     3   nout, npe, nps, nqu, nsdif, nst
      double precision aa, ee, gg, bb, dprey, dpred,
     1     ax, ay, acoef, bcoef, dx, dy, alph, diff, cox, coy,
     2     uround, srur
      double precision avdim, atol, cc, hu, rcfl, rcfn, dumach,
     1   rtol, rwork, t, tout
c
c The problem Common blocks below allow for up to 20 species,
c up to a 50x50 mesh, and up to a 20x20 group structure.
      common /pcom0/ aa, ee, gg, bb, dprey, dpred
      common /pcom1/ ax, ay, acoef(20,20), bcoef(20), dx, dy, alph,
     1               diff(20), cox(20), coy(20), ns, mx, my, mxns
      common /pcom2/ uround, srur, mp, mq, mpsq, itmax
      common /pcom3/ meshx, meshy, ngx, ngy, ngrp, mxmp,
     2   jgx(21), jgy(21), jigx(50), jigy(50), jxr(20), jyr(20)
c
c The dimension of cc below must be .ge. 2*neq, where neq = ns*mx*my.
c The dimension lrw of rwork must be .ge. 17*neq + ns*ns*ngrp + 61,
c and the dimension liw of iwork must be .ge. 35 + ns*ngrp.
      dimension cc(576), rwork(5213), iwork(67)
      data lrw/5213/, liw/67/
c
      open (unit=6, file='demout', status='unknown')
      open (unit=8, file='ccout', status='unknown')
c
      ax = 1.0d0
      ay = 1.0d0
c
c Call setpar to set problem parameters.
      call setpar
c
c Set remaining problem parameters.
      neq = ns*mx*my
      mxns = mx*ns
      dx = ax/(mx-1)
      dy = ay/(my-1)
      do 10 i = 1,ns
        cox(i) = diff(i)/dx**2
 10     coy(i) = diff(i)/dy**2
c
c Write heading.
      write(6,20)ns, mx,my,neq
 20   format(' Demonstration program for DLSODPK package'//
     1   ' Food web problem with ns species, ns =',i4/
     2   ' Predator-prey interaction and diffusion on a 2-d square'//
     3   ' Mesh dimensions (mx,my) =',2i4/
     4   ' Total system size is neq =',i7//)
      write(6,25) aa,ee,gg,bb,dprey,dpred,alph
 25   format(' Matrix parameters:  a =',d12.4,'   e =',d12.4,
     1   '   g =',d12.4/20x,' b =',d12.4//
     2   ' Diffusion coefficients: dprey =',d12.4,'   dpred =',d12.4/
     3   ' Rate parameter alpha =',d12.4//)
c
c Set remaining method parameters.
      jpre = 3
      jacflg = 1
      iwork(3) = jpre
      iwork(4) = jacflg
      iopt = 0
      mp = ns
      mq = mx*my
      mpsq = ns*ns
      uround = dumach()
      srur = sqrt(uround)
      meshx = mx
      meshy = my
      mxmp = meshx*mp
      ngx = 2
      ngy = 2
      ngrp = ngx*ngy
      call gset (meshx, ngx, jgx, jigx, jxr)
      call gset (meshy, ngy, jgy, jigy, jyr)
      iwork(1) = mpsq*ngrp
      iwork(2) = mp*ngrp
      itmax = 5
      itol = 1
      rtol = 1.0d-5
      atol = rtol
      itask = 1
      write(6,30)ngrp,ngx,ngy,itmax,rtol,atol
 30   format(' Preconditioning uses interaction-only block-diagonal',
     1   ' matrix'/' with block-grouping, and Gauss-Seidel iterations'//
     2   ' Number of diagonal block groups = ngrp =',i4,
     3   '   (ngx by ngy, ngx =',i2,'  ngy =',i2,' )'//
     4   ' G-S preconditioner uses itmax iterations, itmax =',i3//
     5   ' Tolerance parameters: rtol =',d10.2,'   atol =',d10.2)
c
c
c Loop over mf values 10, 21, ..., 24, 29.
c
      do 90 mf = 10,29
      if (mf .gt. 10 .and. mf .lt. 21) go to 90
      if (mf .gt. 24 .and. mf .lt. 29) go to 90
      write(6,40)mf
 40   format(//80('-')//' Solution with mf =',i3//
     1   '   t       nstep  nfe  nni  nli  npe  nq',
     2   4x,'h          avdim    ncf rate    lcf rate')
c
      t = 0.0d0
      tout = 1.0d-8
      nout = 18
      if (mf .eq. 10) nout = 6
      if (mf .eq. 23 .or. mf .eq. 24) nout = 10
      call cinit (cc)
      if (mf .eq. 22) call outweb (t, cc, ns, mx, my, 8)
      istate = 1
      nli = 0
      nni = 0
      ncfn = 0
      ncfl = 0
      nst = 0
c
c Loop over output times and call DLSODPK.
c
      do 70 iout = 1,nout
        call dlsodpk (fweb, neq, cc, t, tout, itol, rtol, atol, itask,
     1         istate, iopt, rwork, lrw, iwork, liw, jacbg, solsbg, mf)
        nsdif = iwork(11) - nst
        nst = iwork(11)
        nfe = iwork(12)
        npe = iwork(13)
        nnidif = iwork(19) - nni
        nni = iwork(19)
        nlidif = iwork(20) - nli
        nli = iwork(20)
        nfndif = iwork(22) - ncfn
        ncfn = iwork(22)
        nfldif = iwork(23) - ncfl
        ncfl = iwork(23)
        nqu = iwork(14)
        hu = rwork(11)
        avdim = 0.0d0
        rcfn = 0.0d0
        rcfl = 0.0d0
        if (nnidif .gt. 0) avdim = real(nlidif)/real(nnidif)
        if (nsdif .gt. 0) rcfn = real(nfndif)/real(nsdif)
        if (nnidif .gt. 0) rcfl = real(nfldif)/real(nnidif)
        write(6,50)t,nst,nfe,nni,nli,npe,nqu,hu,avdim,rcfn,rcfl
 50     format(d10.2,i5,i6,3i5,i4,2d11.2,d10.2,d12.2)
        imod3 = iout - 3*(iout/3)
        if (mf .eq. 22 .and. imod3 .eq. 0) call outweb (t,cc,ns,mx,my,8)
        if (istate .eq. 2) go to 65
        write(6,60)t
 60     format(//' final time reached =',d12.4//)
        go to 75
 65     continue
        if (tout .gt. 0.9d0) tout = tout + 1.0d0
        if (tout .lt. 0.9d0) tout = tout*10.0d0
 70     continue
c
 75   continue
      nst = iwork(11)
      nfe = iwork(12)
      npe = iwork(13)
      lenrw = iwork(17)
      leniw = iwork(18)
      nni = iwork(19)
      nli = iwork(20)
      nps = iwork(21)
      if (nni .gt. 0) avdim = real(nli)/real(nni)
      ncfn = iwork(22)
      ncfl = iwork(23)
      write (6,80) lenrw,leniw,nst,nfe,npe,nps,nni,nli,avdim,
     1               ncfn,ncfl
 80   format(//' Final statistics for this run:'/
     1   ' rwork size =',i8,'   iwork size =',i6/
     2   ' number of time steps            =',i5/
     3   ' number of f evaluations         =',i5/
     4   ' number of preconditioner evals. =',i5/
     4   ' number of preconditioner solves =',i5/
     5   ' number of nonlinear iterations  =',i5/
     5   ' number of linear iterations     =',i5/
     6   ' average subspace dimension  =',f8.4/
     7   i5,' nonlinear conv. failures,',i5,' linear conv. failures')
c
 90   continue
      stop
c------  end of main program for DLSODPK demonstration program ----------
      end

      subroutine setpar
c-----------------------------------------------------------------------
c This routine sets the problem parameters.
c It set ns, mx, my, and problem coefficients acoef, bcoef, diff, alph,
c using parameters np, aa, ee, gg, bb, dprey, dpred.
c-----------------------------------------------------------------------
      integer ns, mx, my, mxns
      integer i, j, np
      double precision aa, ee, gg, bb, dprey, dpred,
     1     ax, ay, acoef, bcoef, dx, dy, alph, diff, cox, coy
      common /pcom0/ aa, ee, gg, bb, dprey, dpred
      common /pcom1/ ax, ay, acoef(20,20), bcoef(20), dx, dy, alph,
     1               diff(20), cox(20), coy(20), ns, mx, my, mxns
c
      np = 3
      mx = 6
      my = 6
      aa = 1.0d0
      ee = 1.0d4
      gg = 0.5d-6
      bb = 1.0d0
      dprey = 1.0d0
      dpred = 0.5d0
      alph = 1.0d0
      ns = 2*np
      do 70 j = 1,np
        do 60 i = 1,np
          acoef(np+i,j) = ee
          acoef(i,np+j) = -gg
 60       continue
        acoef(j,j) = -aa
        acoef(np+j,np+j) = -aa
        bcoef(j) = bb
        bcoef(np+j) = -bb
        diff(j) = dprey
        diff(np+j) = dpred
 70     continue
c
      return
c------------  end of subroutine setpar  -------------------------------
      end

      subroutine gset (m, ng, jg, jig, jr)
c-----------------------------------------------------------------------
c This routine sets arrays jg, jig, and jr describing
c a uniform partition of (1,2,...,m) into ng groups.
c-----------------------------------------------------------------------
      integer m, ng, jg, jig, jr
      dimension jg(*), jig(*), jr(*)
      integer ig, j, len1, mper, ngm1
c
      mper = m/ng
      do 10 ig = 1,ng
 10     jg(ig) = 1 + (ig - 1)*mper
      jg(ng+1) = m + 1
c
      ngm1 = ng - 1
      len1 = ngm1*mper
      do 20 j = 1,len1
 20     jig(j) = 1 + (j-1)/mper
      len1 = len1 + 1
      do 25 j = len1,m
 25     jig(j) = ng
c
      do 30 ig = 1,ngm1
 30     jr(ig) = 0.5d0 + (ig - 0.5d0)*mper
      jr(ng) = 0.5d0*(1 + ngm1*mper + m)
c
      return
c------------  end of subroutine gset  ---------------------------------
      end

      subroutine cinit (cc)
c-----------------------------------------------------------------------
c This routine computes and loads the vector of initial values.
c-----------------------------------------------------------------------
      double precision cc
      dimension cc(*)
      integer ns, mx, my, mxns
      integer i, ici, ioff, iyoff, jx, jy
      double precision ax,ay,acoef,bcoef,dx,dy,alph,diff,cox,coy
      double precision argx, argy, x, y
      common /pcom1/ ax, ay, acoef(20,20), bcoef(20), dx, dy, alph,
     1               diff(20), cox(20), coy(20), ns, mx, my, mxns
c
        do 20 jy = 1,my
          y = (jy-1)*dy
          argy = 16.0d0*y*y*(ay-y)*(ay-y)
          iyoff = mxns*(jy-1)
          do 10 jx = 1,mx
            x = (jx-1)*dx
            argx = 16.0d0*x*x*(ax-x)*(ax-x)
            ioff = iyoff + ns*(jx-1)
            do 5 i = 1,ns
              ici = ioff + i
              cc(ici) = 10.0d0 + i*argx*argy
  5           continue
 10         continue
 20       continue
      return
c------------  end of subroutine cinit  --------------------------------
      end

      subroutine outweb (t, c, ns, mx, my, lun)
c-----------------------------------------------------------------------
c This routine prints the values of the individual species densities
c at the current time t.  The write statements use unit lun.
c-----------------------------------------------------------------------
      integer ns, mx, my, lun
      double precision t, c
      dimension c(ns,mx,my)
      integer i, jx, jy
c
      write(lun,10) t
 10   format(/80('-')/30x,'At time t = ',d16.8/80('-') )
c
      do 40 i = 1,ns
        write(lun,20) i
 20     format(' the species c(',i2,') values are:')
        do 30 jy = my,1,-1
          write(lun,25) (c(i,jx,jy),jx=1,mx)
 25       format(6(1x,g12.6))
 30       continue
        write(lun,35)
 35     format(80('-'),/)
 40     continue
c
      return
c------------  end of subroutine outweb  -------------------------------
      end

      subroutine fweb (neq, t, cc, cdot)
c-----------------------------------------------------------------------
c This routine computes the derivative of cc and returns it in cdot.
c The interaction rates are computed by calls to webr, and these are
c saved in cc(neq+1),...,cc(2*neq) for use in preconditioning.
c-----------------------------------------------------------------------
      integer neq
      double precision t, cc, cdot
      dimension cc(neq), cdot(neq)
      integer ns, mx, my, mxns
      integer i, ic, ici, idxl, idxu, idyl, idyu, iyoff, jx, jy
      double precision ax,ay,acoef,bcoef,dx,dy,alph,diff,cox,coy
      double precision dcxli, dcxui, dcyli, dcyui, x, y
      common /pcom1/ ax, ay, acoef(20,20), bcoef(20), dx, dy, alph,
     1               diff(20), cox(20), coy(20), ns, mx, my, mxns
c
      do 100 jy = 1,my
        y = (jy-1)*dy
        iyoff = mxns*(jy-1)
        idyu = mxns
        if (jy .eq. my) idyu = -mxns
        idyl = mxns
        if (jy .eq. 1) idyl = -mxns
        do 90 jx = 1,mx
          x = (jx-1)*dx
          ic = iyoff + ns*(jx-1) + 1
c Get interaction rates at one point (x,y).
          call webr (x, y, t, cc(ic), cc(neq+ic))
          idxu = ns
          if (jx .eq. mx) idxu = -ns
          idxl = ns
          if (jx .eq. 1) idxl = -ns
          do 80 i = 1,ns
            ici = ic + i - 1
c Do differencing in y.
            dcyli = cc(ici) - cc(ici-idyl)
            dcyui = cc(ici+idyu) - cc(ici)
c Do differencing in x.
            dcxli = cc(ici) - cc(ici-idxl)
            dcxui = cc(ici+idxu) - cc(ici)
c Collect terms and load cdot elements.
            cdot(ici) = coy(i)*(dcyui - dcyli) + cox(i)*(dcxui - dcxli)
     1                  + cc(neq+ici)
 80         continue
 90       continue
 100    continue
      return
c------------  end of subroutine fweb  ---------------------------------
      end

      subroutine webr (x, y, t, c, rate)
c-----------------------------------------------------------------------
c This routine computes the interaction rates for the species
c c(1),...,c(ns), at one spatial point and at time t.
c-----------------------------------------------------------------------
      double precision x, y, t, c, rate
      dimension c(*), rate(*)
      integer ns, mx, my, mxns
      integer i
      double precision ax,ay,acoef,bcoef,dx,dy,alph,diff,cox,coy
      double precision fac
      common /pcom1/ ax, ay, acoef(20,20), bcoef(20), dx, dy, alph,
     1               diff(20), cox(20), coy(20), ns, mx, my, mxns
c
      do 10 i = 1,ns
 10     rate(i) = 0.0d0
      do 15 i = 1,ns
        call daxpy (ns, c(i), acoef(1,i), 1, rate, 1)
 15     continue
      fac = 1.0d0 + alph*x*y
      do 20 i = 1,ns
 20     rate(i) = c(i)*(bcoef(i)*fac + rate(i))
      return
c------------  end of subroutine webr  ---------------------------------
      end

      subroutine jacbg (f, neq, t, cc, ccsv, rewt, f0, f1, hl0,
     1                  bd, ipbd, ier)
c-----------------------------------------------------------------------
c This routine generates part of the block-diagonal part of the
c Jacobian, multiplies by -hl0, adds the identity matrix,
c and calls DGEFA to do LU decomposition of each diagonal block.
c The computation of the diagonal blocks uses the block and grouping
c information in /pcom1/ and /pcom2/.  One block per group is computed.
c The Jacobian elements are generated by difference quotients
c using calls to the routine fbg.
c-----------------------------------------------------------------------
c The two Common blocks below are used for internal communication.
c The variables used are:
c   mp     = size of blocks in block-diagonal preconditioning matrix.
c   mq     = number of blocks in each direction (neq = mp*mq).
c   mpsq   = mp*mp.
c   uround = unit roundoff, generated by a call uround = dumach().
c   srur   = sqrt(uround).
c   meshx  = x mesh size
c   meshy  = y mesh size (mesh is meshx by meshy)
c   ngx    = no. groups in x direction in block-grouping scheme.
c   ngy    = no. groups in y direction in block-grouping scheme.
c   ngrp   = total number of groups = ngx*ngy.
c   mxmp   = meshx*mp.
c   jgx    = length ngx+1 array of group boundaries in x direction.
c            group igx has x indices jx = jgx(igx),...,jgx(igx+1)-1.
c   jigx   = length meshx array of x group indices vs x node index.
c            x node index jx is in x group jigx(jx).
c   jxr    = length ngx array of x indices representing the x groups.
c            the index for x group igx is jx = jxr(igx).
c   jgy, jigy, jyr = analogous arrays for grouping in y direction.
c-----------------------------------------------------------------------
      external f
      integer neq, ipbd, ier
      double precision t, cc, ccsv, rewt, f0, f1, hl0, bd
      dimension cc(neq), ccsv(neq), rewt(neq), f0(neq), f1(neq),
     1          bd(*), ipbd(*)
      integer mp, mq, mpsq, itmax,
     2        meshx,meshy,ngx,ngy,ngrp,mxmp,jgx,jgy,jigx,jigy,jxr,jyr
      integer i, ibd, idiag, if0, if00, ig, igx, igy, iip,
     1   j, jj, jx, jy, n
      double precision uround, srur
      double precision fac, r, r0, dvnorm
c
      common /pcom2/ uround, srur, mp, mq, mpsq, itmax
      common /pcom3/ meshx, meshy, ngx, ngy, ngrp, mxmp,
     1   jgx(21), jgy(21), jigx(50), jigy(50), jxr(20), jyr(20)
c
      n = neq
c
c-----------------------------------------------------------------------
c Make mp calls to fbg to approximate each diagonal block of Jacobian.
c Here cc(neq+1),...,cc(2*neq) contains the base fb value.
c r0 is a minimum increment factor for the difference quotient.
c-----------------------------------------------------------------------
 200  fac = dvnorm (n, f0, rewt)
      r0 = 1000.0d0*abs(hl0)*uround*n*fac
      if (r0 .eq. 0.0d0) r0 = 1.0d0
      ibd = 0
      do 240 igy = 1,ngy
        jy = jyr(igy)
        if00 = (jy - 1)*mxmp
        do 230 igx = 1,ngx
          jx = jxr(igx)
          if0 = if00 + (jx - 1)*mp
          do 220 j = 1,mp
            jj = if0 + j
            r = max(srur*abs(cc(jj)),r0/rewt(jj))
            cc(jj) = cc(jj) + r
            fac = -hl0/r
            call fbg (neq, t, cc, jx, jy, f1)
            do 210 i = 1,mp
 210          bd(ibd+i) = (f1(i) - cc(neq+if0+i))*fac
            cc(jj) = ccsv(jj)
            ibd = ibd + mp
 220        continue
 230      continue
 240    continue
c
c Add identity matrix and do LU decompositions on blocks. --------------
 260  continue
      ibd = 1
      iip = 1
      do 280 ig = 1,ngrp
        idiag = ibd
        do 270 i = 1,mp
          bd(idiag) = bd(idiag) + 1.0d0
 270      idiag = idiag + (mp + 1)
        call dgefa (bd(ibd), mp, mp, ipbd(iip), ier)
        if (ier .ne. 0) go to 290
        ibd = ibd + mpsq
        iip = iip + mp
 280    continue
 290  return
c------------  end of subroutine jacbg  --------------------------------
      end

      subroutine fbg (neq, t, cc, jx, jy, cdot)
c-----------------------------------------------------------------------
c This routine computes one block of the interaction terms of the
c system, namely block (jx,jy), for use in preconditioning.
c-----------------------------------------------------------------------
      integer neq, jx, jy
      double precision t, cc, cdot
      dimension cc(neq), cdot(neq)
      integer ns, mx, my, mxns
      integer iblok, ic
      double precision ax,ay,acoef,bcoef,dx,dy,alph,diff,cox,coy
      double precision x, y
c
      common /pcom1/ ax, ay, acoef(20,20), bcoef(20), dx, dy, alph,
     1               diff(20), cox(20), coy(20), ns, mx, my, mxns
c
      iblok = jx + (jy-1)*mx
        y = (jy-1)*dy
          x = (jx-1)*dx
          ic = ns*(iblok-1) + 1
          call webr (x, y, t, cc(ic), cdot)
      return
c------------  end of subroutine fbg  ----------------------------------
      end

      subroutine solsbg (n, t, cc, f0, wk, hl0, bd, ipbd, v, lr, ier)
c-----------------------------------------------------------------------
c This routine applies one or two inverse preconditioner matrices
c to the array v, using the interaction-only block-diagonal Jacobian
c with block-grouping, and Gauss-Seidel applied to the diffusion terms.
c When lr = 1 or 3, it calls gs for a Gauss-Seidel approximation
c to ((I-hl0*Jd)-inverse)*v, and stores the result in v.
c When lr = 2 or 3, it computes ((I-hl0*dg/dc)-inverse)*v, using LU
c factors of the blocks in bd, and pivot information in ipbd.
c In both cases, the array v is overwritten with the solution.
c-----------------------------------------------------------------------
      integer n, ipbd, lr, ier
      double precision t, cc, f0, wk, hl0, bd, v
      dimension cc(n), f0(n), wk(n), bd(*), ipbd(*), v(n)
      integer mp, mq, mpsq, itmax,
     2        meshx,meshy,ngx,ngy,ngrp,mxmp,jgx,jgy,jigx,jigy,jxr,jyr
      integer ibd, ig0, igm1, igx, igy, iip, iv, jx, jy
      double precision uround, srur
c
      common /pcom2/ uround, srur, mp, mq, mpsq, itmax
      common /pcom3/ meshx, meshy, ngx, ngy, ngrp, mxmp,
     1   jgx(21), jgy(21), jigx(50), jigy(50), jxr(20), jyr(20)
c
      ier = 0
c
      if (lr.eq.0 .or. lr.eq.1 .or. lr.eq.3) call gs (n, hl0, v, wk)
      if (lr.eq.0 .or. lr.eq.2 .or. lr.eq.3) then
        iv = 1
        do 20 jy = 1,meshy
          igy = jigy(jy)
          ig0 = (igy - 1)*ngx
          do 10 jx = 1,meshx
            igx = jigx(jx)
            igm1 = igx - 1 + ig0
            ibd = 1 + igm1*mpsq
            iip = 1 + igm1*mp
            call dgesl (bd(ibd), mp, mp, ipbd(iip), v(iv), 0)
            iv = iv + mp
 10         continue
 20       continue
        endif
c
      return
c------------  end of subroutine solsbg  -------------------------------
      end

      subroutine gs (n, hl0, z, x)
c-----------------------------------------------------------------------
c This routine performs itmax Gauss-Seidel iterations
c to compute an approximation to P-inverse*z, where P = I - hl0*Jd, and
c Jd represents the diffusion contributions to the Jacobian.
c z contains the answer on return.
c The dimensions below assume ns .le. 20.
c-----------------------------------------------------------------------
      integer n
      double precision hl0, z, x
      dimension z(n), x(n)
      integer ns, mx, my, mxns,
     1        mp, mq, mpsq, itmax
      integer i, ic, ici, iter, iyoff, jx, jy
      double precision ax,ay,acoef,bcoef,dx,dy,alph,diff,cox,coy,
     2     uround, srur
      double precision beta,beta2,cof1,elamda,gamma,gamma2
      dimension beta(20), gamma(20), beta2(20), gamma2(20), cof1(20)
      common /pcom1/ ax, ay, acoef(20,20), bcoef(20), dx, dy, alph,
     1               diff(20), cox(20), coy(20), ns, mx, my, mxns
      common /pcom2/ uround, srur, mp, mq, mpsq, itmax
c
c-----------------------------------------------------------------------
c Write matrix as P = D - L - U.
c Load local arrays beta, beta2, gamma, gamma2, and cof1.
c-----------------------------------------------------------------------
      do 10 i = 1,ns
        elamda = 1.d0/(1.d0 + 2.d0*hl0*(cox(i) + coy(i)))
        beta(i) = hl0*cox(i)*elamda
        beta2(i) = 2.d0*beta(i)
        gamma(i) = hl0*coy(i)*elamda
        gamma2(i) = 2.d0*gamma(i)
        cof1(i) = elamda
 10     continue
c-----------------------------------------------------------------------
c Begin iteration loop.
c Load array x with (D-inverse)*z for first iteration.
c-----------------------------------------------------------------------
      iter = 1
c
      do 50 jy = 1,my
        iyoff = mxns*(jy-1)
        do 40 jx = 1,mx
          ic = iyoff + ns*(jx-1)
          do 30 i = 1,ns
            ici = ic + i
            x(ici) = cof1(i)*z(ici)
            z(ici) = 0.d0
 30         continue
 40       continue
 50     continue
      go to 160
c-----------------------------------------------------------------------
c Calculate (D-inverse)*U*x.
c-----------------------------------------------------------------------
 70   continue
      iter = iter + 1
      jy = 1
        jx = 1
        ic = ns*(jx-1)
        do 75 i = 1,ns
          ici = ic + i
 75       x(ici) = beta2(i)*x(ici+ns) + gamma2(i)*x(ici+mxns)
        do 85 jx = 2,mx-1
          ic = ns*(jx-1)
          do 80 i = 1,ns
            ici = ic + i
 80         x(ici) = beta(i)*x(ici+ns) + gamma2(i)*x(ici+mxns)
 85       continue
        jx = mx
        ic = ns*(jx-1)
        do 90 i = 1,ns
          ici = ic + i
 90       x(ici) = gamma2(i)*x(ici+mxns)
      do 115 jy = 2,my-1
        iyoff = mxns*(jy-1)
          jx = 1
          ic = iyoff
          do 95 i = 1,ns
            ici = ic + i
 95         x(ici) = beta2(i)*x(ici+ns) + gamma(i)*x(ici+mxns)
          do 105 jx = 2,mx-1
            ic = iyoff + ns*(jx-1)
            do 100 i = 1,ns
              ici = ic + i
 100          x(ici) = beta(i)*x(ici+ns) + gamma(i)*x(ici+mxns)
 105        continue
          jx = mx
          ic = iyoff + ns*(jx-1)
          do 110 i = 1,ns
            ici = ic + i
 110        x(ici) = gamma(i)*x(ici+mxns)
 115      continue
      jy = my
      iyoff = mxns*(jy-1)
        jx = 1
        ic = iyoff
        do 120 i = 1,ns
          ici = ic + i
 120      x(ici) = beta2(i)*x(ici+ns)
        do 130 jx = 2,mx-1
          ic = iyoff + ns*(jx-1)
          do 125 i = 1,ns
            ici = ic + i
 125      x(ici) = beta(i)*x(ici+ns)
 130      continue
        jx = mx
        ic = iyoff + ns*(jx-1)
        do 135 i = 1,ns
          ici = ic + i
 135      x(ici) = 0.0d0
c-----------------------------------------------------------------------
c Calculate (I - (D-inverse)*L)-inverse * x.
c-----------------------------------------------------------------------
 160  continue
      jy = 1
        do 175 jx = 2,mx-1
          ic = ns*(jx-1)
          do 170 i = 1,ns
            ici = ic + i
 170        x(ici) = x(ici) + beta(i)*x(ici-ns)
 175      continue
        jx = mx
        ic = ns*(jx-1)
        do 180 i = 1,ns
          ici = ic + i
 180      x(ici) = x(ici) + beta2(i)*x(ici-ns)
      do 210 jy = 2,my-1
        iyoff = mxns*(jy-1)
          jx = 1
          ic = iyoff
          do 185 i = 1,ns
            ici = ic + i
 185        x(ici) = x(ici) + gamma(i)*x(ici-mxns)
          do 200 jx = 2,mx-1
            ic = iyoff + ns*(jx-1)
            do 195 i = 1,ns
              ici = ic + i
              x(ici) = (x(ici) + beta(i)*x(ici-ns))
     1             + gamma(i)*x(ici-mxns)
 195          continue
 200        continue
            jx = mx
            ic = iyoff + ns*(jx-1)
            do 205 i = 1,ns
              ici = ic + i
              x(ici) = (x(ici) + beta2(i)*x(ici-ns))
     1             + gamma(i)*x(ici-mxns)
 205          continue
 210        continue
      jy = my
      iyoff = mxns*(jy-1)
        jx = 1
        ic = iyoff
        do 215 i = 1,ns
          ici = ic + i
 215      x(ici) = x(ici) + gamma2(i)*x(ici-mxns)
        do 225 jx = 2,mx-1
          ic = iyoff + ns*(jx-1)
          do 220 i = 1,ns
            ici = ic + i
            x(ici) = (x(ici) + beta(i)*x(ici-ns))
     1           + gamma2(i)*x(ici-mxns)
 220        continue
 225      continue
        jx = mx
        ic = iyoff + ns*(jx-1)
        do 230 i = 1,ns
          ici = ic + i
          x(ici) = (x(ici) + beta2(i)*x(ici-ns))
     1         + gamma2(i)*x(ici-mxns)
 230      continue
c-----------------------------------------------------------------------
c Add increment x to z.
c-----------------------------------------------------------------------
      do 300 i = 1,n
 300    z(i) = z(i) + x(i)
c
      if (iter .lt. itmax) go to 70
      return
c------------  end of subroutine gs  -----------------------------------
      end


program permutations

  implicit none
  integer, parameter :: value_min = 1
  integer, parameter :: value_max = 3
  integer, parameter :: position_min = value_min
  integer, parameter :: position_max = value_max
  integer, dimension (position_min : position_max) :: permutation

  call generate (position_min)

contains

  recursive subroutine generate (position)

    implicit none
    integer, intent (in) :: position
    integer :: value

    if (position > position_max) then
      write (*, *) permutation
    else
      do value = value_min, value_max
        if (.not. any (permutation (: position - 1) == value)) then
          permutation (position) = value
          call generate (position + 1)
        end if
      end do
    end if

  end subroutine generate

end program permutations


module RCImageProcess
  use RCImageBasic
  implicit none
contains

  subroutine get_histogram(img, histogram)
    type(scimage), intent(in) :: img
    integer, dimension(0:255), intent(out) :: histogram

    integer :: i

    histogram = 0
    do i = 0,255
       histogram(i) = sum(img%channel, img%channel == i)
    end do
  end subroutine get_histogram

  function histogram_median(histogram)
    integer, dimension(0:255), intent(in) :: histogram
    integer :: histogram_median

    integer :: from, to, left, right

    from = 0
    to = 255
    left = histogram(from)
    right = histogram(to)
    do while ( from /= to )
       if ( left < right ) then
          from = from + 1
          left = left + histogram(from)
       else
          to = to - 1
          right = right + histogram(to)
       end if
    end do
    histogram_median = from
  end function histogram_median

end module RCImageProcess


PROGRAM test_ylmr2

  IMPLICIT NONE
  INTEGER :: lmax2
  INTEGER :: Ng
  REAL(8), ALLOCATABLE :: G(:,:), GG(:)
  REAL(8), ALLOCATABLE :: ylm(:,:)
  INTEGER :: ig
  INTEGER :: lmaxkb, lm

  Ng = 5
  lmaxkb = 3
  lmax2 = (lmaxkb+1)**2

  WRITE(*,*) 'lmax2 = ', lmax2

  ALLOCATE( G(3,Ng) )
  ALLOCATE( GG(Ng) )
  ALLOCATE( ylm(Ng,lmax2) )

  DO ig = 1, Ng
    G(:,ig) = (/ -2.1d0, 2.d0, 1.d0 /)
    GG(ig) = G(1,ig)**2 + G(2,ig)**2 + G(3,ig)**2
  ENDDO

  CALL ylmr2( lmax2, Ng, G, GG, ylm )

  DO lm = 1,lmax2
    WRITE(*,*)
    WRITE(*,'(A,I5)') 'lm = ', lm
    DO ig = 1,Ng
      WRITE(*,'(I5,F18.10)') ig, ylm(ig,lm)
    ENDDO
  ENDDO

  DEALLOCATE( G )
  DEALLOCATE( GG )
  DEALLOCATE( ylm )

END PROGRAM


c=======================================================================
c
c     subroutine ALLOCSKEW
c
c     Asset allocation with a skewness constraint
c
c-----------------------------------------------------------------------
      SUBROUTINE allocskew ( n, p, x, w, cov, rho,
     &                       neq, nin, ccst, bcst, cinf, csup,
     &                       mu, sigma, skew,
     &                       iwork, dwork, wopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n       : number of values                               integer
c       p       : portfolio size                                 integer
c       x       : returns values (n*p)                            double
c       w       : benchmark portfolio weights (p)                 double
c       cov     : covariance matrix (p*p)                         double
c       rho     : mean returns vector (p)                         double
c       neq     : number equality constraints                    integer
c       nin     : number inequality constraints                  integer
c       ccst    : matrix of constraints (p*(neq+nin))             double
c       bcst    : vector initial of constraints (neq+nin)         double
c       cinf    : lower bound (p)                                 double
c       csup    : upper bound (p)                                 double
c       mu      : performance target                              double
c       sigma   : volatility target                               double
c       skew    : skewness delta target (vs. index)               double
c
c     WORKSPACE
c       iwork   : 16*p + 4*nin + 2*neq + 31                      integer
c       dwork   : (p+1)*(p+1)*(p+nin+neq+6)+2*nin+neq+2*p+7
c               + (neq + 2*nin + 2*p + 7)*(neq + 2*nin + 2*p + 32)/2
c               + (2*neq + 2*nin + 2*p + 13)*(p + 1)*(p + 2)/2
c               + (p + 1)*(15*p + 31)                             double
c
c     OUTPUT
c       wopt    : optimal portfolio (p)                           double
c       info    : diagnostic argument                            integer
c
c     CALL
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, info, neq, nin
      DOUBLE PRECISION mu, sigma, skew
      DOUBLE PRECISION x(*), w(*), cov(*), rho(*), cinf(*), csup(*),
     &                 ccst(*), bcst(*), wopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piwo, pdwo, pisdp, pdsdp, pisdls, pdsdls, pdskew1,
     &        pdskew3, pdwopt, pdQ, pdCeq, pdbEq, pdCineq,
     &        pdbLowerIneq, pdbUpperIneq
      INTEGER i, q, nbEqCst, nbIneqCst
      DOUBLE PRECISION mutest, cstPrecision, minEigenValue
      DOUBLE PRECISION pVolat, bVolat, pSkew, bSkew, pReturn, bReturn,
     &                 EPS
      PARAMETER ( EPS = 1.E-8 )
c
c     external subroutines
      EXTERNAL opmv, testsdp, utskew1, utskew2, utskew3, sdlsg
c
c-----------------------------------------------------------------------
c
c     initializations
      info      = 0
      q         = p + 1
      nbEqCst   = neq + 1
      nbIneqCst = nin + p + 1 + 1 + 1
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      pisdp = 1
c     pisdp : pointer for TESTSDP (p)
      piwo  = 1
c     piwo  : pointer for OPMV (3*p + 2*nin + neq + 3)
      pisdls = 1
c     pisdls : pointer for SDLSG (2*nbEqCst + 4*nbIneqCst + 12*(p+1) + 5)
c                               = 2*neq + 4*nin + 4*p + 12*p + 2 + 12 + 12 + 5
c
c     Total size of iwork array = ( 16*p + 4*nin + 2*neq + 31 )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdsdp = 1
c     pdsdp : pointer for TESTSDP p*(2*p + 7)
      pdwo  = 1
c     pdwo  : pointer for OPMV
c            p*( p + neq + nin + 9 ) + 2*neq + 4*nin + 4
      pdQ          = 1
c     pdQ   : pointer for initial matrix SDLS (p+1)*(p+1)
      pdwopt       = pdQ + (p+1)*(p+1)
c     pdwopt : pointer for optimal matrix SDLS (p+1)*(p+1)
      pdCeq        = pdwopt + (p+1)*(p+1)
c     pdCeq : pointer for eq. cst. matrix SDLS (neq+1)*(p+1)*(p+1)
      pdbEq        = pdCeq + (neq+1)*(p+1)*(p+1)
c     pdbEq : pointer for eq. cst. vector SDLS (neq+1)
      pdCineq      = pdbEq + (neq+1)
c     pdCineq : pointer for ineq. cst. matrix SDLS (nin+p+3)*(p+1)*(p+1)
      pdbLowerIneq = pdCineq + (nin+p+3)*(p+1)*(p+1)
c     pdbLowerIneq : pointer for ineq. cst. vector SDLS (nin+p+3)
      pdbUpperIneq = pdbLowerIneq + (nin+p+3)
c     pdbUpperIneq : pointer for ineq. cst. vector SDLS (nin+p+3)
      pdskew1      = pdbUpperIneq + (nin+p+3)
c     pdskew1 : pointer for UTSKEW1 (p*p)
      pdskew3      = pdbUpperIneq + (nin+p+3)
c     pdskew3 : pointer for UTSKEW3 p*(15*p + 3)
      pdsdls       = pdbUpperIneq + (nin+p+3)
c     pdsdls : pointer for SDLSG
c                    (mcte+2*mcti)*(mcte+2*mcti+25)/2
c                  + (2*mcte+2*mcti+5)*(p*(p+1)/2)
c                  +  p*(4*p + 27)
c
c     Total size of dwork array = (p + 1)*(p + 1)*(p + nin + neq + 6) + 2*nin + neq + 2*p + 7
c                               + (neq + 2*nin + 2*p + 7)*(neq + 2*nin + 2*p + 32)/2
c                               + (2*neq + 2*nin + 2*p + 13)*(p + 1)*(p + 2)/2
c                               + (p + 1)*(15*p + 31)
c
c-----------------------------------------------------------------------
c
c     test inputs
      IF (sigma .LT. EPS) THEN
        info = -104
        RETURN
      ENDIF
c
c     covariance matrix SDP test
      CALL testsdp (p, cov, iwork(pisdp), dwork(pdsdp), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     tests constraints compatibility
      mutest = -1.E+8
      CALL opmv ( p, cov, rho, mutest,
     &            neq, nin, ccst, bcst, cinf, csup,
     &            iwork(piwo), dwork(pdwo), wopt, info )
      IF (info .EQ. 1001) THEN
        info = -100
        RETURN
      ENDIF
c
c     test constraint w*rho > mu
      CALL opmv ( p, cov, rho, mu,
     &            neq, nin, ccst, bcst, cinf, csup,
     &            iwork(piwo), dwork(pdwo), wopt, info )
      IF (info .EQ. 1001) THEN
        info = -101
        RETURN
      ENDIF
c
c
c     SDLS input matrix
c     Q = | W   w |
c         | w'  1 |
      CALL utskew1(p, w, iwork(pisdp), dwork(pdskew1), dwork(pdQ), info)
      IF (info .LT. 0) RETURN
c
c     SDLS contraints: equalities
      CALL utskew2(p, neq, ccst, bcst,
     &             nbEqCst, dwork(pdCeq), dwork(pdbEq), info)
      IF (info .LT. 0) RETURN
c
c     SDLS contraints: inequalities
      CALL utskew3(n, p, x, w, rho, cov,
     &             neq, nin, ccst, bcst, cinf, csup,
     &             mu, sigma, skew,
     &             iwork(pisdp), dwork(pdskew3),
     &             nbIneqCst, dwork(pdCineq),
     &             dwork(pdbLowerIneq), dwork(pdbUpperIneq), info)
      IF (info .LT. 0) RETURN
c
c     optimization with SDLS
      cstPrecision  = 1.E-15
      minEigenValue = 1.E-12
      CALL sdlsg ( q, dwork(pdQ), nbEqCst, dwork(pdCeq), dwork(pdbEq),
     &             nbIneqCst, dwork(pdCineq),
     &             dwork(pdbLowerIneq), dwork(pdbUpperIneq),
     &             cstPrecision, minEigenValue,
     &             iwork(pisdls), dwork(pdsdls), dwork(pdwopt), info )
      IF (info .NE. 0) RETURN
c
c     optimal portfolio
      DO i = 1,p
        wopt(i) = dwork(pdwopt + q*q - q - 1 + i)
      ENDDO
c
c     ex-ante skewness (benchmark)
      CALL EXARSK ( n, p, w, x, cov, dwork(pdsdls), bSkew, info)
      IF (info .LT. 0) RETURN
c
c     ex-ante skewness (portfolio)
      CALL EXARSK ( n, p, wopt, x, cov, dwork(pdsdls), pSkew, info)
      IF (info .LT. 0) RETURN
c
      CALL EXARET ( p, rho, w, bReturn, info )
      IF (info .LT. 0) RETURN
c
c     ex-ante mean return
      CALL EXARET ( p, rho, wopt, pReturn, info )
      IF (info .LT. 0) RETURN
c
c     ex-ante volatility (optimal portfolio)
      CALL EXARVO (p, cov, w, bVolat, info)
      IF (info .LT. 0) RETURN
c
c     ex-ante volatility (optimal portfolio)
      CALL EXARVO (p, cov, wopt, pVolat, info)
      IF (info .LT. 0) RETURN
c
      IF (pSkew .LT. (bSkew+skew)) THEN
        info = 120
        RETURN
      ENDIF
      IF (pReturn .LT. (mu - EPS)) THEN
        info = 121
        RETURN
      ENDIF
      IF (pVolat .GT. (sigma + EPS)) THEN
        info = 122
        RETURN
      ENDIF
c
      RETURN
      END


program test_utils
use utils
implicit none

!real :: mu
!integer :: i
!
!mu = 7.0
!
!do i=1,100
!    write(*, fmt="(A, I0)") "test:", poisson(mu)
!end do

integer :: i, j, n_bin, n_trails
integer :: int_array(6), order_array(6), count_array(20)
real :: real_array(6), array_copy(10000), m
real :: phi1, phi2, lambda1, lambda2, d, theta_min, theta_max, phi_rot, lambda_rot
real, dimension(10000) :: phi1_array, lambda1_array, phi2_array, lambda2_array, distance_array, lon_reach1_array, lon_reach2_array
real, dimension(10000, 2) :: cos_sin_array1, cos_sin_array2

real, dimension(:), allocatable :: big_real_array

type(binning) :: bins

integer(kind=8) :: clock_count_start, clock_count_end, elapsed_time
real :: clock_rate, average_time

d = 0.2
phi1 = 0.5
lambda1 = 0.5

print *, max_longitude_difference(lambda1, phi1, d)

n_bin = 10
theta_min = 1.0/60.0
theta_max = 20.0/60.0

theta_min = deg2rad(theta_min)
theta_max = deg2rad(theta_max)

call create_bins(x_min=theta_min, x_max=theta_max, n_bin=n_bin, spacing=lin_binning, bins=bins)

!print *, bins%bin_edges
!print *, bins%bin_centers

call random_seed()

call random_number_int(array=int_array, max=10, min=0)
print *, int_array
call qsort_arg_int(int_array, order_array)
print *, "sorted array: ", int_array(order_array)

count_array = 0
do i=1, 10000
    call random_unique_number_int(int_array, max=20, min=1)
    count_array(int_array) = count_array(int_array) + 1
end do
print *, "counts ", count_array

call random_number(real_array)
real_array = real_array*10

n_trails = 10
elapsed_time = 0
do i=1,n_trails
    call random_number(real_array)

    call system_clock(count=clock_count_start)
    call qsort_arg(real_array, order_array)
    !write(*,fmt="(10F3.2)") real_array(order_array)
    call system_clock(count=clock_count_end, count_rate=clock_rate)
    elapsed_time = elapsed_time + clock_count_end-clock_count_start
end do
average_time = real(elapsed_time)/n_trails
print *, "Time elapsed for copy qsort: ", average_time/clock_rate

print *, "Variance: ", variance(real_array)

phi1 = 0.3
lambda1 = pi*1.5
phi_rot = pi/2
lambda_rot = pi*0.6
call rotation_sphere(lambda1, phi1, lambda_rot, phi_rot, lambda2, phi2)
print "(A, F5.2, A, F5.2, A, F5.2, A)", "lambda rot: ", lambda_rot/pi, " : ", lambda1/pi, " -> ", lambda2/pi
print "(A, F5.2, A, F5.2, A, F5.2, A)", "phi rot: ", phi_rot/pi, " : ", phi1/pi, " -> ", phi2/pi

print *, "Checking pointing angles"
call random_number(phi1_array)
call random_number(phi2_array)
call random_number(lambda1_array)
call random_number(lambda2_array)
phi1_array = phi1_array * 2.0*pi
phi2_array = phi2_array * 2.0*pi
lambda1_array = lambda1_array *pi - pi/2.0
lambda2_array = lambda2_array *pi - pi/2.0

distance_array = distance_sphere(lambda1_array, phi1_array, lambda2_array, phi2_array)
n_trails = 100
elapsed_time = 0
do j=1,n_trails
    do i=1,size(distance_array)
        call system_clock(count=clock_count_start)
        cos_sin_array1(i,:) = angles_sphere(lambda1_array(i), phi1_array(i), lambda2_array(i), phi2_array(i), distance_array(i))
        call system_clock(count=clock_count_end, count_rate=clock_rate)
        elapsed_time = elapsed_time + clock_count_end-clock_count_start
    end do
end do
average_time = real(elapsed_time)/n_trails
print *, "Time elapsed for old pointing angle: ", average_time/clock_rate
elapsed_time = 0
do j=1,n_trails
    do i=1,size(distance_array)
        call system_clock(count=clock_count_start)
        cos_sin_array2(i,:) = pointing_angle_cos_sin_sphere(lambda1_array(i), phi1_array(i), lambda2_array(i), phi2_array(i), distance_array(i))
        call system_clock(count=clock_count_end, count_rate=clock_rate)
        elapsed_time = elapsed_time + clock_count_end-clock_count_start
    end do
end do
average_time = real(elapsed_time)/n_trails
print *, "Time elapsed for new pointing angle: ", average_time/clock_rate

lon_reach1_array = max_longitude_difference(lambda1_array, phi1_array*0.1, distance_array(1)*0.1)
lon_reach2_array = longitude_reach_sphere(phi1_array*0.1, distance_array(1)*0.1)

print *, sum(abs(cos_sin_array1-cos_sin_array2))/size(distance_array)
print *, sum(abs(lon_reach1_array-lon_reach2_array))/size(distance_array)
print *, sum(distance_array)/size(distance_array)

print *, distance_to_meridian_sphere(pi, -0.3, 0.0)
print *, distance_to_meridian_sphere(3.0, 0.0, 2.0*pi)

print "(3(A, F4.2))", "Mean : ", mean(phi1_array), " Median : ", median(phi1_array), " Variance : ", variance(phi1_array)

real_array = [(i, i=1,size(real_array))]
real_array = [1.0, 1.0, 1.0, 2.0, 3.0, 2.0]

print "(3(A, F4.2))", "Mean : ", mean(real_array), " Median : ", median(real_array), " Variance : ", variance(real_array)

allocate(big_real_array(300000))
call random_number(big_real_array)
print *, big_real_array(:10)
print "(A, F4.2)", "Median : ", median(big_real_array)

n_trails = 1
elapsed_time = 0
do j=1,n_trails
    call system_clock(count=clock_count_start)
    m = median(big_real_array)
    call system_clock(count=clock_count_end, count_rate=clock_rate)
    elapsed_time = elapsed_time + clock_count_end-clock_count_start
end do
average_time = real(elapsed_time)/n_trails
print *, "Time elapsed for median: ", average_time/clock_rate

end program test_utils


module riemann_sample_module

contains

subroutine riemann_sample(rho_l, u_l, p_l, &
                          rho_r, u_r, p_r, &
                          xn_l, xn_r, &
                          ustar, pstar, &
                          W_l, W_r, &
                          x, xjump, time, &
                          rho, u, p, xn)

  use amrex_fort_module, only : rt => amrex_real
  use amrex_constants_module
  use eos_module
  use eos_type_module
  use network, only: nspec
  use riemann_support

  implicit none

  real (rt), intent(in) :: rho_l, u_l, p_l
  real (rt), intent(in) :: rho_r, u_r, p_r
  real (rt), intent(in) :: xn_l(nspec), xn_r(nspec)
  real (rt), intent(in) :: ustar, pstar
  real (rt), intent(in) :: W_l, W_r
  real (rt), intent(in) :: x, xjump, time
  real (rt), intent(out) :: rho, u, p, xn(nspec)

  real (rt) :: cs_l, cs_r

  real (rt) :: W_temp, Z_temp

  type (eos_t) :: eos_state

  real (rt) :: xi, chi
  real (rt) :: rhostar
  real (rt) :: xihat, uhat_s, uhat_star
  real (rt) :: lambdahat_s, lambdahat_star
  real (rt) :: cs_star
  real (rt) :: rho_s, p_s, u_s, W_s, cs_s

  ! get the initial sound speeds
  eos_state%rho = rho_l
  eos_state%p = p_l
  eos_state%xn(:) = xn_l(:)
  eos_state%T = initial_temp_guess

  call eos(eos_input_rp, eos_state)

  cs_l = sqrt(eos_state%gam1*p_l/rho_l)

  eos_state%rho = rho_r
  eos_state%p = p_r
  eos_state%xn(:) = xn_r(:)
  eos_state%T = initial_temp_guess

  call eos(eos_input_rp, eos_state)

  cs_r = sqrt(eos_state%gam1*p_r/rho_r)

  !---------------------------------------------------------------------------
  ! find the solution as a function of xi = x/t
  !---------------------------------------------------------------------------

  ! This follows from the discussion around C&G Eq. 15

  ! compute xi = x/t -- this is the similarity variable for the
  ! solution
  xi = (x - xjump)/time

  ! check which side of the contact we need to worry about
  chi = sign(ONE, xi - ustar)

  if (chi == -ONE) then
     rho_s = rho_l
     u_s = u_l
     p_s = p_l

     W_s = W_l

     cs_s = cs_l

     xn = xn_l

     uhat_s = chi*u_s
     xihat = chi*xi
     uhat_star = chi*ustar

  else if (chi == ONE) then
     rho_s = rho_r
     u_s = u_r
     p_s = p_r

     W_s = W_r

     cs_s = cs_r

     xn = xn_r

     uhat_s = chi*u_s
     xihat = chi*xi
     uhat_star = chi*ustar

  else
     ! we should average in this case
     call amrex_error("Not implemented")

  endif

  ! are we a shock or rarefaction?
  if (pstar > p_s) then
     ! shock

     rhostar = ONE/(ONE/rho_s - (pstar - p_s)/W_s**2)

     !print *, 'shock: rhostar = ', rhostar
  else
     ! rarefaction.  Here we need to integrate the Riemann
     ! invariant curves to our pstar to get rhostar and cs_star
     if (chi == -ONE) then
        call rarefaction(pstar, rho_s, u_s, p_s, xn, 1, Z_temp, W_temp, rhostar)
     else
        call rarefaction(pstar, rho_s, u_s, p_s, xn, 3, Z_temp, W_temp, rhostar)
     endif

  endif

  ! get the soundspeed via the EOS (C&G suggest getting it from
  ! the jump conditions)
  eos_state%rho = rhostar
  eos_state%p = pstar
  eos_state%xn(:) = xn(:)
  eos_state%T = initial_temp_guess

  call eos(eos_input_rp, eos_state)

  cs_star = sqrt(eos_state%gam1*pstar/rhostar)

  ! now deal with the cases where we are not spanning a rarefaction
  if (pstar <= p_s) then
     lambdahat_s = uhat_s + cs_s
     lambdahat_star = uhat_star + cs_star
  else
     lambdahat_s = uhat_s + W_s/rho_s
     lambdahat_star = lambdahat_s
  endif

  if (xihat <= lambdahat_star) then
     p = pstar
     rho = rhostar
     u = ustar

  else if (xihat > lambdahat_s) then
     p = p_s
     rho = rho_s
     u = u_s

  else
     ! we are inside the rarefaction.  To find the solution here,
     ! we need to integrate up to the point where uhat + c = xihat
     ! starting from U = U_s

     ! for the 1-rarefaction, chi = -1, so this is -u + c = -xi,
     ! or u - c = xi, meaning we integrate to u = xi + c

     ! for the 3-rarefaction, chi = 1, so this is u + c = xi,
     ! so we integrate to u = xi - c

     ! Note that c here is c(rho,p) -- we need to compute that
     ! self-consistently as we integrate
     if (chi == -ONE) then
        call rarefaction_to_u(rho_s, u_s, p_s, xn, 1, xi, rho, p, u)

     else if (chi == ONE) then
        call rarefaction_to_u(rho_s, u_s, p_s, xn, 3, xi, rho, p, u)

     endif
  endif

end subroutine riemann_sample

end module riemann_sample_module


!      SUBROUTINE CVNMO(IT02,ISI,IX2V2,NSAMPS,IANSWS,ISI2,ISI3,SCALAR)
      SUBROUTINE CVNMO(I1,I2,I3,I4,I5,I6,I7,I8)
!    CVNMO CALCULATES NORMAL MOVEOUT FOR A CONSTANT VELOCITY USING THE AP.
!  ACTUALLY, IT CALCULATES AN ARRAY OF TX VALUES (INDEXES TO THE UNMOVEDOUT
!  TRACE) CORRESPONDING TO A UNIFORMLY INCREASING T0.
!
!    TX=(SQRT(T0**2+C)+SCALAR+SI/2)/SI
!  WHERE:
!   TX = 2 WAY TRAVEL TIME (AS INDEXES TO THE TRACE)
!   T0 = 2 WAY NORMAL INCIDENT TIME
!   C  = X**2/V**2
!   X  = SHOT TO RECEIVER DISTANCE
!   V  = THE CONSTANT VELOCITY
!   SI = THE SAMPLE INTERVAL
!  SCALAR - A SCALAR VALUE TO ADD BEFORE CONVERTING TO INDEXS. THIS IS A
!           CONVENIENT WAY TO REMOVE THE DEEP WATER DELAY TIME AND ALSO
!           FIND THE BEGINNING OF THE WINDOW
!
!  METHOD:
!    1)  BUILD AN ARRAY OF T0**2 USING THE INITIAL T0**2 AND THE SAMPLE INTERVAL
!    2)  SQUARE T0
!    3)  ADD THE CONSTANT X**2/V**2
!    4)  TAKE THE SQUARE ROOT
!    5)  ADD THE SCALAR
!    6)  ADD HALF THE SAMPLE INTERVAL FOR ROUNDOFF
!    7)  DIVIDE BY THE SAMPLE INTERVAL TO CONVERT TO SAMPLES
!    8)  CONVERT SAMPLES TO INDEXES (32 BIT INTEGERS).
!
!  ARGUMENTS:
!    IT02   - THE AP ADDRESS OF THE INITIAL T0 VALUE.
!    ISI    - THE AP ADDRESS OF THE TIME INCREMENT BETWEEN SUCCESSIVE T0 VALUES.
!    IX2V2  - THE AP ADDRESS OF THE SQUARE OF THE RANGE DIVIDED BY THE CONSTANT
!             VELOCITY ((X**2)/(V**2)).
!    NSAMPS - THE NUMBER OF TX VALUES TO COMPUTE.
!    IANSWS - THE AP ADDRESS OF THE OUTPUT ARRAY OF TX.
!    ISI2   - THE AP ADDRESS OF THE SAMPLE INTERVAL, IN SECONDS.
!    ISI3   - THE AP ADDRESS OF HALF THE SAMPLE INTERVAL.
!    SCALAR - THE AP ADDRESS OF THE SCALAR VALUE TO ADD.
!
!  WRITTEN AND COPYRIGHTED BY:
!  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, 25 MARCH 1981
!  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
!  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
!
      IMPLICIT INTEGER (A-Z)
      IT02=I1
      ISI=I2
      IX2V2=I3
      NSAMPS=I4
      IANSWS=I5
      ISI2=I6
      ISI3=I7
      SCALAR=I8
      CALL VRAMP(IT02,ISI,IANSWS,1,NSAMPS)
      CALL VMUL(IANSWS,1,IANSWS,1,IANSWS,1,NSAMPS)
      CALL VSADD(IANSWS,1,IX2V2,IANSWS,1,NSAMPS)
      CALL VSQRT(IANSWS,1,IANSWS,1,NSAMPS)
      CALL VSADD(IANSWS,1,SCALAR,IANSWS,1,NSAMPS)
      CALL VSADD(IANSWS,1,ISI3,IANSWS,1,NSAMPS)
      CALL VDIV(ISI2,0,IANSWS,1,IANSWS,1,NSAMPS)
c      CALL VFIX32(IANSWS,1,IANSWS,1,NSAMPS)
      RETURN
      END


	SUBROUTINE PC_INTT  ( temp, adata, bdata, nparms, intflg,
     +			      angflg, jtemp, outdat, iret )
C************************************************************************
C* PC_INTT								*
C*									*
C* This subroutine interpolates temperature between two levels of	*
C* data.  The data are interpolated with respect to the height		*
C* except for the pressure, which is interpolated with respect		*
C* to the log of the pressure.  Temperature is found in the input 	*
C* arrays in the location given by jtemp. If errors are encountered 	*
C* no output data are changed.  Therefore, data should be set to 	*
C* RMISSD before calling this subroutine.				*
C*									*
C* PC_INTT  ( TEMP, ADATA, BDATA, NPARMS, INTFLG, ANGFLG, JTEMP,	*
C*            OUTDAT, IRET )						*
C*									*
C* Input parameters:							*
C*	TEMP		REAL		Temperature to be interpolated	*
C*	ADATA (NPARMS)	REAL		Data at first level		*
C*	BDATA (NPARMS)	REAL		Data at second level		*
C*	NPARMS		INTEGER		Size of data arrays		*
C*	INTFLG (NPARMS)	LOGICAL		Interpolation flags		*
C*	ANGFLG (NPARMS)	LOGICAL		Angle interpolation flags	*
C*	JTEMP		INTEGER		Location of TEMP		*
C*									*
C* Output parameters:							*
C*	OUTDAT (NPARMS)	REAL		Data interpolated to TEMP	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-24 = vlev not between levels	*
C**									*
C* Log:									*
C* T. Lee/GSC	 	8/99	Created					*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
	REAL		adata (*), bdata (*), outdat (*)
	LOGICAL		intflg (*), angflg (*)
C*
	LOGICAL		betwen
C*
        INCLUDE         'ERMISS.FNC'
C-------------------------------------------------------------------------
C*	Check that TEMP is between two pressures input.
C
	temp1 = adata (jtemp)
	temp2 = bdata (jtemp)
	betwen = ( ( (temp1 .lt. temp2) .and. (temp1 .lt. temp) .and.
     +		     (temp  .lt. temp2) )  .or.
     +		   ( (temp2 .lt. temp1) .and. (temp2 .lt. temp) .and.
     +		     (temp  .lt. temp1) ) )
C
C*	Test for errors - can't interpolate or a non-positive pressure.
C
	IF  ( .not. betwen )  THEN
	    iret = -24
	  ELSE
	    iret = 0
C
C*	    Set up interpolation.  Check for interpolation of angles
C*	    through 360 degrees.
C
	    rmult = ( temp - adata (jtemp) ) /
     +			( bdata (jtemp) - adata (jtemp) )
	    outdat (jtemp) = temp
	    DO  i = 1, nparms
	      IF  ( i .ne. jtemp )  THEN
		IF  ( intflg (i) )  THEN
		    IF  ( angflg (i) )  THEN
			ang1 = AMOD ( adata(i), 360. )
			ang2 = AMOD ( bdata(i), 360. )
			IF  ( ABS (ang1 - ang2) .gt. 180.)  THEN
			    IF  ( ang1 .lt. ang2 )  THEN
				ang1 = ang1 + 360.
			      ELSE
				ang2 = ang2 + 360.
			    END IF
			END IF
			ang = ang1 + (ang2 - ang1) * rmult
			outdat (i) = AMOD ( ang, 360. )
		      ELSE
			IF  ( i .eq. 1 )  THEN
			    plog = ALOG (bdata (i)) - ALOG (adata (i))
			    outdat (i) = adata (i) * EXP (rmult * plog)
			  ELSE
			    outdat (i) = adata (i) +
     +				      ( bdata(i) - adata (i) ) * rmult
			END IF
		    END IF
		    IF  ( ERMISS ( adata(i) ) .or.
     +				ERMISS ( bdata(i) ) )
     +					outdat (i) = RMISSD
		END IF
	      END IF
	    END DO
	END IF
C*
	RETURN
	END


!*****************************************************************************

!  MPFUN-MPFR: An MPFR-based Fortran arbitrary precision computation package
!  Precision level declaration module (module MPFUNF)

!  Version date:  19 Apr 2017

!  AUTHOR:
!     David H. Bailey
!     Lawrence Berkeley National Lab (retired) and University of California, Davis
!     Email: dhbailey@lbl.gov

!  COPYRIGHT AND DISCLAIMER:
!    All software in this package (c) 2017 David H. Bailey.
!    By downloading or using this software you agree to the copyright, disclaimer
!    and license agreement in the accompanying file DISCLAIMER.txt.

!  PURPOSE OF PACKAGE:
!    This package permits one to perform floating-point computations (real and
!    complex) to arbitrarily high numeric precision, by making only relatively
!    minor changes to existing Fortran-90 programs.  All basic arithmetic
!    operations and transcendental functions are supported, together with several
!    special functions.

!    This version differs from the MPFUN-Fort version by the same author in that
!    it is based on MPFR, which presently is the fastest available low-level
!    package for high-precision floating-point computation.  Thus most user
!    applications typically run 3X faster.  In addition, the developers of the
!    MPFR package have taken considerable pains to ensure that the many functions
!    return correctly rounded (to the last bit) results for each input.  At the
!    Fortran user level, application codes written for MPFUN-Fort may be compiled
!    and executed with MPFUN-MPFR --i.e., MPFUN-MPFR is "plug compatible" with
!    MPFUN-Fort.

!  DOCUMENTATION:
!    A detailed description of this package, and instructions for compiling
!    and testing this program on various specific systems are included in the
!    README file accompanying this package, and, in more detail, in the
!    following technical paper:

!    David H. Bailey, "MPFUN2015: A thread-safe arbitrary precision package,"
!    available at http://www.davidhbailey.com/dhbpapers/mpfun2015.pdf.

!  DESCRIPTION OF THIS MODULE (MPFUNF):
!    This module defines the default precision level in digits (mpipl) and
!    the equivalent precision level in words (mpwds), which is calculated
!    below according to the formula:
!       mpwds = int (mpipl / mpdpw + 2)
!    where mpdpw = 19.26591972249... is an approximation to log10(2^64)
!    (mpdpw is set in module MPFUNA). This precision level is the working
!    precision level for all operations that use module MPFUNG, unless one
!    dynamically varies the medium precision level, in which case this is the
!    maximum working precision level.

module mpfunf
use mpfuna

implicit none
integer, public:: mpipl

!  *** Set the default precision level (in digits) here.

parameter (mpipl = 1200)

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

!  *** Do not change the following code (in normal usage).

integer, public:: mpwds, mpwdsbt, mpwds6
parameter (mpwds = int (mpipl / mpdpw + 2.d0), mpwdsbt = mpnbt * mpwds, &
  mpwds6 = mpwds + 6)

end module mpfunf


c Author: Anand Patil, anand.prabhakar.patil@gmail.com

      SUBROUTINE checksymm(X,n,cs)
c Checks symmetry
cf2py intent(hide) n
cf2py intent(out) cs
      DOUBLE PRECISION X(n,n)
      INTEGER n,i,j
      LOGICAL cs

      cs = .FALSE.
      do j=1,n-1
          do i=j+1,n
              if (X(i,j).NE.X(j,i)) then
                  cs = .TRUE.
                  return
              end if
          end do
      end do

      return
      END

      SUBROUTINE chol_mvnorm(x, mu, sig, n, like, info)

cf2py double precision dimension(n), intent(copy) :: x
cf2py double precision dimension(n), intent(copy) :: mu
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py double precision dimension(n,n), intent(in) :: sig
cf2py double precision intent(out) :: like
cf2py integer intent(hide) :: info
cf2py threadsafe

      DOUBLE PRECISION sig(n,n), x(n), mu(n), like
      INTEGER n, info, i
      DOUBLE PRECISION twopi_N, log_detC, gd
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      PARAMETER (PI=3.141592653589793238462643d0)

      EXTERNAL DPOTRS
! DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) Solves triangular system
      EXTERNAL DAXPY
! DAXPY(N,DA,DX,INCX,DY,INCY) Adding vectors
      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
! NB DDOT from ATLAS, compiled with gfortran 4.2 on Ubuntu Gutsy,
! was producing bad output- hence the manual dot product.

!     x <- (x-mu)
      call DAXPY(n, -1.0D0, mu, 1, x, 1)

!       mu <- x
      call DCOPY(n,x,1,mu,1)

!     x <- sig ^-1 * x
      call DPOTRS('L',n,1,sig,n,x,n,info)

      gd=0.0D0
      do i=1,n
          gd=gd+x(i)*mu(i)
      end do

!     like <- .5 dot(x,mu) (.5 (x-mu) C^{-1} (x-mu)^T)
      like = -0.5D0 * gd
!       print *, like

      twopi_N = 0.5D0 * N * dlog(2.0D0*PI)
!       print *, twopi_N

      log_detC = 0.0D0
      do i=1,n
        log_detC = log_detC + log(sig(i,i))
      enddo
!       print *, log_detC

      like = like - twopi_N - log_detC

      return
      END

      SUBROUTINE cov_mvnorm(x, mu, C, n, like, info)

cf2py double precision dimension(n), intent(copy) :: x
cf2py double precision dimension(n), intent(copy) :: mu
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py double precision dimension(n,n), intent(copy) :: C
cf2py double precision intent(out) :: like
cf2py integer intent(hide) :: info
cf2py threadsafe

      DOUBLE PRECISION C(n,n), x(n), mu(n), like
      INTEGER n, info
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      PARAMETER (PI=3.141592653589793238462643d0)

      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization

!     C <- cholesky(C)
      call DPOTRF( 'L', n, C, n, info )
!       print *, C

!      If cholesky failed, puke.
       if (info .GT. 0) then
         like = -infinity
         RETURN
       endif

!     Call to chol_mvnorm
      call chol_mvnorm(x,mu,C,n,like,info)

      return
      END

      SUBROUTINE prec_mvnorm(x, mu, tau, n, like)

cf2py double precision dimension(n), intent(copy) :: x
cf2py double precision dimension(n), intent(copy) :: mu
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py double precision dimension(n,n), intent(copy) :: tau
cf2py double precision intent(out) :: like
cf2py threadsafe

      DOUBLE PRECISION tau(n,n), x(n), mu(n), like, gd
      INTEGER n, info, i
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      PARAMETER (PI=3.141592653589793238462643d0)
      DOUBLE PRECISION twopi_N, log_dettau

      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization
      EXTERNAL DSYMV
! DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) Symmetric matrix-vector multiply
      EXTERNAL DAXPY
! DAXPY(N,DA,DX,INCX,DY,INCY) Adding vectors
      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y

      twopi_N = 0.5D0 * N * dlog(2.0D0*PI)

!     x <- (x-mu)
      call DAXPY(n, -1.0D0, mu, 1, x, 1)

!       mu <- x
      call DCOPY(n,x,1,mu,1)

!     mu <- tau * x
      call DSYMV('L',n,1.0D0,tau,n,x,1,0.0D0,mu,1)

      gd = 0.0D0
      do i=1,n
          gd=gd+x(i)*mu(i)
      end do

!     like <- -.5 dot(x,mu) (.5 (x-mu) C^{-1} (x-mu)^T)
      like = -0.5D0 * gd

!      Cholesky factorize tau for the determinant.
       call DPOTRF( 'L', n, tau, n, info )

!      If cholesky failed, puke.
       if (info .GT. 0) then
         like = -infinity
         RETURN
       endif

!      Otherwise read off determinant.
       log_dettau = 0.0D0
       do i=1,n
         log_dettau = log_dettau + dlog(tau(i,i))
       enddo

       like = like - twopi_N + log_dettau

      return
      END

      SUBROUTINE blas_wishart(X,k,n,T,like)

c Wishart log-likelihood function.

cf2py double precision dimension(k,k),intent(copy) :: X,T
cf2py double precision intent(out) :: like
cf2py integer intent(hide),depend(X) :: k=len(X)
cf2py threadsafe

      INTEGER i,k,n
      DOUBLE PRECISION X(k,k),T(k,k),bx(k,k)
      DOUBLE PRECISION dx,db,tbx,a,g,like
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      LOGICAL csx
      PARAMETER (PI=3.141592653589793238462643d0)

      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
      EXTERNAL DSYMM
! DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) alpha*A*B + beta*C when side='l'
      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization

c Check X for symmetry
      CALL checksymm(X,k,csx)
      if (csx) then
          like = -infinity
          return
      end if

c trace of T*X
!     bx <- T * X
      call DSYMM('L','L',k,k,1.0D0,T,k,x,k,0.0D0,bx,k)

c Cholesky factor T, puke if not pos def.
      call DPOTRF( 'L', k, T, k, info )
      if (info .GT. 0) then
        like = -infinity
        RETURN
      endif

c Cholesky factor X, puke if not pos def.
      call DPOTRF( 'L', k, X, k, info )
      if (info .GT. 0) then
        like = -infinity
        RETURN
      endif

c Get the trace and log-sqrt-determinants
      tbx = 0.0D0
      dx = 0.0D0
      db = 0.0D0

      do i=1,k
        tbx = tbx + bx(i,i)
        dx = dx + dlog(X(i,i))
        db = db + dlog(T(i,i))
      enddo

      if (k .GT. n) then
        like = -infinity
        RETURN
      endif

      like = 0.0D0
      like = (n - k - 1) * dx
      like = like + n * db
      like = like - 0.5D0 * tbx
      like = like - (n*k/2.0d0)*dlog(2.0d0)

      do i=1,k
        a = (n - i + 1)/2.0D0
        call gamfun(a, g)
        like = like - g
      enddo

      like = like - k * (k-1) * 0.25D0 * dlog(PI)
!
      return
      END

c

      SUBROUTINE blas_wishart_cov(X,k,n,V,like)

c Wishart log-likelihood function.
c Doesn't vectorize the determinants, just the matrix multiplication.

cf2py double precision dimension(k,k),intent(copy) :: V,X
cf2py double precision intent(out) :: like
cf2py integer intent(hide),depend(X) :: k=len(X)
cf2py threadsafe

      INTEGER i,k,info, n
      DOUBLE PRECISION X(k,k),V(k,k),bx(k,k)
      DOUBLE PRECISION dx,db,tbx,a,g,like
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      LOGICAL csx
      PARAMETER (PI=3.141592653589793238462643d0)
c
      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization
      EXTERNAL DPOTRS
! DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) Solves triangular system

c determinants
c Check X for symmetry
      CALL checksymm(X,k,csx)
      if (csx) then
          like = -infinity
          return
      end if

c Cholesky factorize sigma, puke if not pos def
!     V <- cholesky(V)
      call DPOTRF( 'L', k, V, k, info )
      if (info .GT. 0) then
        like = -infinity
        RETURN
      endif

c trace of V^{-1}*X
!     bx <- X
      call DCOPY(k * k,X,1,bx,1)
!     bx <- V^{-1} * bx
      call DPOTRS('L',k,k,V,k,bx,k,info)

!     X <- cholesky(X)
      call DPOTRF( 'L', k, X, k, info )

! sqrt-log-determinant of sigma and X, and trace
      db=0.0D0
      dx=0.0D0
      tbx = 0.0D0
      do i=1,k
        db = db + dlog(V(i,i))
        dx = dx + dlog(X(i,i))
        tbx = tbx + bx(i,i)
      enddo

      if (k .GT. n) then
        like = -infinity
        RETURN
      endif

      like = (n - k - 1) * dx
      like = like - n * db
      like = like - 0.5D0*tbx
      like = like - (n*k/2.0D0)*dlog(2.0d0)

      do i=1,k
        a = (n - i + 1)/2.0D0
        call gamfun(a, g)
        like = like - g
      enddo

      like = like - k * (k-1) * 0.25D0 * dlog(PI)

      return
      END

      SUBROUTINE blas_inv_wishart(X,k,n,T,like)

c Inverse Wishart log-likelihood function.

cf2py double precision dimension(k,k),intent(copy) :: X,T
cf2py double precision intent(out) :: like
cf2py integer intent(hide),depend(X) :: k=len(X)
cf2py threadsafe

      INTEGER i,k,n
      DOUBLE PRECISION X(k,k),T(k,k),TX(k,k)
      DOUBLE PRECISION dx,db,tbx,a,g,like
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      LOGICAL csx
      PARAMETER (PI=3.141592653589793238462643d0)

      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization
      EXTERNAL DTRMM
! DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) B := alpha*B*op( A )

c Check X and T for symmetry
      CALL checksymm(X,k,csx)
      if (csx) then
          like = -infinity
          return
      end if

c trace of T*X^{-1}
!     TX <- T
      call DCOPY(k*k,T,1,TX,1)
!     TX <- T * X^{-1}
      call DTRMM('R','L','T','N',k,k,1.0D0,X,k,TX,k)

c Cholesky factor T, puke if not pos def.
      call DPOTRF( 'L', k, T, k, info )
      if (info .GT. 0) then
        like = -infinity
        RETURN
      endif

c Cholesky factor X, puke if not pos def.
      call DPOTRF( 'L', k, X, k, info )
      if (info .GT. 0) then
        like = -infinity
        RETURN
      endif

c Get the trace and log-sqrt-determinants
      tbx = 0.0D0
      dx = 0.0D0
      db = 0.0D0

      do i=1,k
        tbx = tbx + TX(i,i)
        dx = dx + dlog(X(i,i))
        db = db + dlog(T(i,i))
      enddo

      if (k .GT. n) then
        like = -infinity
        RETURN
      endif

      like = -1.0D0*(n + k + 1) * dx
      like = like + n * db
      like = like - 0.5D0 * tbx
      like = like - (n*k/2.0d0)*dlog(2.0d0)

      do i=1,k
        a = (n - i + 1)/2.0D0
        call gamfun(a, g)
        like = like - g
      enddo

      like = like - k * (k-1) * 0.25D0 * dlog(PI)
!
      return
      END

      SUBROUTINE dtrsm_wrap(M,N,A,B,SIDE,TRANSA,UPLO)
cf2py intent(inplace)::B
cf2py integer intent(hide)::M
cf2py integer intent(hide)::N
cf2py threadsafe

*     .. Scalar Arguments ..
      DOUBLE PRECISION ALPHA
      INTEGER LDA,LDB,M,N
      CHARACTER DIAG,SIDE,TRANSA,UPLO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION A(M,M),B(M,N)

      EXTERNAL DTRSM
! DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,

      DIAG = 'N'
      LDA = M
      LDB = M
      ALPHA=1.0D0

      CALL DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
      RETURN
      END

      SUBROUTINE dtrmm_wrap(M,N,A,B,SIDE,TRANSA,UPLO)
cf2py intent(inplace)::B
cf2py integer intent(hide)::M
cf2py integer intent(hide)::N
cf2py threadsafe

*     .. Scalar Arguments ..
      DOUBLE PRECISION ALPHA
      INTEGER LDA,LDB,M,N
      CHARACTER DIAG,SIDE,TRANSA,UPLO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION A(M,M),B(M,N)

      EXTERNAL DTRMM
! DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*     X = alpha*op( A )*B,   or   X = alpha*B*op( A ),

      DIAG = 'N'
      LDA = M
      LDB = M
      ALPHA=1.0D0

      CALL DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
      RETURN
      END

      subroutine dchdc_wrap(a,p,work,piv,info)

cf2py intent(inplace) a
cf2py intent(hide) p
cf2py intent(hide) work
cf2py intent(out) piv
cf2py intent(out) info
cf2py threadsafe

      integer lda,p,piv(p),job,info
      double precision a(p,p),work(p)

c
c     dchdc computes the cholesky decomposition of a positive definite
c     matrix.  a pivoting option allows the user to estimate the
c     condition of a positive definite matrix or determine the rank
c     of a positive semidefinite matrix.
c
c     on entry
c
c         a      double precision(lda,p).
c                a contains the matrix whose decomposition is to
c                be computed.  onlt the upper half of a need be stored.
c                the lower part of the array a is not referenced.
c
c         lda    integer.
c                lda is the leading dimension of the array a.
c
c         Since f2py will make sure that a is column-major contiguous,
c         lda is set to p in this wrapper.
c
c         p      integer.
c                p is the order of the matrix.
c
c         work   double precision.
c                work is a work array.
c
c         piv   integer(p).
c                piv contains integers that control the selection
c                of the pivot elements, if pivoting has been requested.
c                each diagonal element a(k,k)
c                is placed in one of three classes according to the
c                value of piv(k).
c
c                   if piv(k) .gt. 0, then x(k) is an initial
c                                      element.
c
c                   if piv(k) .eq. 0, then x(k) is a free element.
c
c                   if piv(k) .lt. 0, then x(k) is a final element.
c
c                before the decomposition is computed, initial elements
c                are moved by symmetric row and column interchanges to
c                the beginning of the array a and final
c                elements to the end.  both initial and final elements
c                are frozen in place during the computation and only
c                free elements are moved.  at the k-th stage of the
c                reduction, if a(k,k) is occupied by a free element
c                it is interchanged with the largest free element
c                a(l,l) with l .ge. k.  piv is not referenced if
c                job .eq. 0.
c
c        job     integer.
c                job is an integer that initiates column pivoting.
c                if job .eq. 0, no pivoting is done.
c                if job .ne. 0, pivoting is done.
c
c        In this wrapper, job=1.
c
c     on return
c
c         a      a contains in its upper half the cholesky factor
c                of the matrix a as it has been permuted by pivoting.
c
c         piv   piv(j) contains the index of the diagonal element
c                of a that was moved into the j-th position,
c                provided pivoting was requested.
c
c         info   contains the index of the last positive diagonal
c                element of the cholesky factor.
c
c     for positive definite matrices info = p is the normal return.
c     for pivoting with positive semidefinite matrices info will
c     in general be less than p.  however, info may be greater than
c     the rank of a, since rounding error can cause an otherwise zero
c     element to be positive. indefinite systems will always cause
c     info to be less than p.
c
c     linpack. this version dated 08/14/78 .
c     j.j. dongarra and g.w. stewart, argonne national laboratory and
c     university of maryland.
c
c
c     blas daxpy,dswap
c     fortran dsqrt
c
c     internal variables
c
      integer pu,pl,plp1,i,j,jp,jt,k,kb,km1,kp1,l,maxl
      double precision temp
      double precision maxdia
      logical swapk,negk
c
      pl = 1
      pu = 0
      info = p
      job=1
      lda=p
      if (job .eq. 0) go to 160
c
c        pivoting has been requested. rearrange the
c        the elements according to piv.
c
         do 70 k = 1, p
            swapk = piv(k) .gt. 0
            negk = piv(k) .lt. 0
            piv(k) = k
            if (negk) piv(k) = -piv(k)
            if (.not.swapk) go to 60
               if (k .eq. pl) go to 50
                  call dswap(pl-1,a(1,k),1,a(1,pl),1)
                  temp = a(k,k)
                  a(k,k) = a(pl,pl)
                  a(pl,pl) = temp
                  plp1 = pl + 1
                  if (p .lt. plp1) go to 40
                  do 30 j = plp1, p
                     if (j .ge. k) go to 10
                        temp = a(pl,j)
                        a(pl,j) = a(j,k)
                        a(j,k) = temp
                     go to 20
   10                continue
                     if (j .eq. k) go to 20
                        temp = a(k,j)
                        a(k,j) = a(pl,j)
                        a(pl,j) = temp
   20                continue
   30             continue
   40             continue
                  piv(k) = piv(pl)
                  piv(pl) = k
   50          continue
               pl = pl + 1
   60       continue
   70    continue
         pu = p
         if (p .lt. pl) go to 150
         do 140 kb = pl, p
            k = p - kb + pl
            if (piv(k) .ge. 0) go to 130
               piv(k) = -piv(k)
               if (pu .eq. k) go to 120
                  call dswap(k-1,a(1,k),1,a(1,pu),1)
                  temp = a(k,k)
                  a(k,k) = a(pu,pu)
                  a(pu,pu) = temp
                  kp1 = k + 1
                  if (p .lt. kp1) go to 110
                  do 100 j = kp1, p
                     if (j .ge. pu) go to 80
                        temp = a(k,j)
                        a(k,j) = a(j,pu)
                        a(j,pu) = temp
                     go to 90
   80                continue
                     if (j .eq. pu) go to 90
                        temp = a(k,j)
                        a(k,j) = a(pu,j)
                        a(pu,j) = temp
   90                continue
  100             continue
  110             continue
                  jt = piv(k)
                  piv(k) = piv(pu)
                  piv(pu) = jt
  120          continue
               pu = pu - 1
  130       continue
  140    continue
  150    continue
  160 continue
      do 270 k = 1, p
c
c        reduction loop.
c
         maxdia = a(k,k)
         kp1 = k + 1
         maxl = k
c
c        determine the pivot element.
c
         if (k .lt. pl .or. k .ge. pu) go to 190
            do 180 l = kp1, pu
               if (a(l,l) .le. maxdia) go to 170
                  maxdia = a(l,l)
                  maxl = l
  170          continue
  180       continue
  190    continue
c
c        quit if the pivot element is not positive.
c
         if (maxdia .gt. 0.0d0) go to 200
            info = k - 1
c     ......exit
            go to 280
  200    continue
         if (k .eq. maxl) go to 210
c
c           start the pivoting and update piv.
c
            km1 = k - 1
            call dswap(km1,a(1,k),1,a(1,maxl),1)
            a(maxl,maxl) = a(k,k)
            a(k,k) = maxdia
            jp = piv(maxl)
            piv(maxl) = piv(k)
            piv(k) = jp
  210    continue
c
c        reduction step. pivoting is contained across the rows.
c
         work(k) = dsqrt(a(k,k))
         a(k,k) = work(k)
         if (p .lt. kp1) go to 260
         do 250 j = kp1, p
            if (k .eq. maxl) go to 240
               if (j .ge. maxl) go to 220
                  temp = a(k,j)
                  a(k,j) = a(j,maxl)
                  a(j,maxl) = temp
               go to 230
  220          continue
               if (j .eq. maxl) go to 230
                  temp = a(k,j)
                  a(k,j) = a(maxl,j)
                  a(maxl,j) = temp
  230          continue
  240       continue
            a(k,j) = a(k,j)/work(k)
            work(j) = a(k,j)
            temp = -a(k,j)
            call daxpy(j-k,temp,work(kp1),1,a(kp1,j),1)
  250    continue
  260    continue
  270 continue
  280 continue

C Zero the lower triangle
      do i=2,info
        do j=1,i-1
          a(i,j) = 0.0D0
        enddo
      enddo

C decrement the pivots.
      do i=1,p
        piv(i) = piv(i)-1
      enddo
      return
      end

      SUBROUTINE dpotrs_wrap(chol_fac, b, info, n, m, uplo)

cf2py double precision dimension(n,n), intent(in) :: chol_fac
cf2py integer depend(chol_fac), intent(hide)::n=shape(chol_fac,0)
cf2py integer depend(b), intent(hide)::m=shape(b,1)
cf2py optional character intent(in):: uplo='U'
cf2py integer intent(out)::info
cf2py double precision intent(inplace), dimension(n,m)::b
cf2py threadsafe

      DOUBLE PRECISION chol_fac(n,n), b(n,m)
      INTEGER n, info,m

      CHARACTER uplo

      EXTERNAL DPOTRS
! DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) Solves triangular system

      call DPOTRS(uplo,n,m,chol_fac,n,b,n,info)

      return
      END


module read_data_module

    contains
    subroutine read_data(file_name, raw_data, how_many)
        implicit none

        character(*), intent(in) :: file_name
        integer, intent(in) :: how_many
        real, dimension(:), allocatable, &
            intent(out) :: raw_data
        integer :: i

        allocate(raw_data(how_many))
        open(1,file=file_name,status='old')
        do i = 1, how_many
            read(1,*) raw_data(i)
        end do
        close(1)
    end subroutine
end module

module sort_data_module

    contains
    subroutine sort_data(raw_data, how_many)
        implicit none

        integer, intent(in) :: how_many
        real, dimension(:), intent(inout) :: raw_data

        call quicksort(1,how_many)

        contains
        recursive subroutine quicksort(l, r)
            implicit none

            integer, intent(in) :: l, r
            integer :: i, j
            real :: v, t

            i = l
            j = r
            v = raw_data(int((l+r)/2))
            do
                do while (raw_data(i)<v)
                    i = i+1
                end do
                do while (v<raw_data(j))
                    j = j-1
                end do
                if (i<=j) then
                    t = raw_data(i)
                    raw_data(i) = raw_data(j)
                    raw_data(j) = t
                    i = i+1
                    j = j-1
                end if
                if (i>j) exit
            end do
            if (l<j) then
                call quicksort(l,j)
            end if
            if (i<r) then
                call quicksort(i,r)
            end if
        end subroutine
    end subroutine
end module

module print_data_module

    contains
    subroutine  print_data(raw_data, how_many)
        implicit none

        integer, intent(in) :: how_many
        real, dimension(:), intent(in) :: raw_data
        integer :: i

        open(2,file='sorted.txt')
        do i = 1, how_many
            write(2,*) raw_data(i)
        end do
        close(2)
    end subroutine
end module

program ch2006
    ! Allocatable Dummy Arrays
    use read_data_module
    use sort_data_module
    use print_data_module
    implicit none

    integer :: how_many
    character(20) :: file_name
    real, dimension(:), allocatable :: raw_data

    print *, ' how many data items are there?'
    read *, how_many
    print *, ' what is the file name?'
    read '(a)', file_name
    call read_data(file_name,raw_data,how_many)
    print *, ' allocate and read'
    call sort_data(raw_data,how_many)
    print *, ' sort'
    call print_data(raw_data,how_many)
    print *, ' print'
    print *, ' '
    print *, ' data written to file sorted.txt'
end program


      PROGRAM NESTED_REDUCTION
      INTEGER K,I,SIZE
      PARAMETER (SIZE=100)
      REAL SUM

      SUM = 0

      DO I = 1, SIZE
         DO K = 1, SIZE
            SUM = SUM + I + K
         ENDDO
      ENDDO

      PRINT *, SUM
      END


module Molec_m
  USE NumParameters_m
  implicit none
  private

  real(kind=Rk) :: mass = ONE

  public :: Calc_pot,mass

contains
  FUNCTION Calc_pot(Q)
    real(kind=Rk)             :: Calc_pot

    real(kind=Rk), intent(in) :: Q

  Calc_pot = HALF * Q*Q

  END FUNCTION Calc_pot

end module Molec_m


	subroutine splines22(x,y,no,ntau,tau,yy,f)
	include 'PARAMETER'   !por kt

	parameter (kt2=kt*kn)  !lo pongo en ff, que antes tenia 5250
	implicit real*4 (a-h,o-z)
	real*4 a(kt,kt),x(*),y(*),tau(*),yy(*),f(kt,kt),ff(kt2)
	real*4 taure(kt),peso(5),sum(kt)

	COMMON/FACTORSPLIN/FF
        common/nspl_lin/nspl_lin !para seleccionar interp.lineal=(1,3 o 5) o splines=(0,2 o 4)

	n=no+2

        if(nspl_lin.eq.0 .or. nspl_lin.eq.2 .or. nspl_lin.eq.4) then !if 0
c Interpolamos por splines ---------------------------------
c           print*,'splines22 interpola splines'

           paso=x(2)-x(1)
           p2=2*paso*paso
	   if(n.gt.3)then    !if 1
	      CALL SPLINB(n,kt,a)

	      ks=0
	      do i=1,ntau
                j1=1+int((tau(i)-x(1))/paso)
	        j2=j1+1
	        f2=(tau(i)-x(j1))/paso
	        f1=1.0-f2
	        f3=f1*(f1*f1-1.0)
	        f4=f2*(f2*f2-1.0)
	        do k=1,n
	           f(i,k)=f3*a(j1,k)+f4*a(j2,k)
	           if(k.eq.j1)f(i,k)=f(i,k)+f1
	           if(k.eq.j2)f(i,k)=f(i,k)+f2
	        end do
	        do k=1,n
	           ks=ks+1
	           ff(ks)=f(i,k)
	        end do
	     end do
	   else    ! else (if 1)
                 do i=1,ntau
	            taure(i)=(tau(i)-x(1))/paso
	         end do
              if(n.eq.2)then !if 2
      		      ks=0
c                      print*,'trabajamos con 2 nodos bb'
		      do i=1,ntau
			 f(i,1)=1.0-taure(i)
			 f(i,2)=taure(i)
			    do k=1,n
			       ks=ks+1
			       ff(ks)=f(i,k)
			    end do
		      end do
		end if !fin (if 2)
              if(n.eq.3)then !if 2b
		  ks=0
		  do i=1,ntau
		     xx=(tau(i)-x(1))/(x(2)-x(1))
		     xx2=xx*xx
		     f(i,1)=1.0-1.5*xx+0.5*xx2
	             f(i,2)=    2.0*xx- xx2
	             f(i,3)=   -0.5*xx+0.5*xx2
		     do k=1,n
		        ks=ks+1
		        ff(ks)=f(i,k)
		     end do
	          end do
              end if !fin (if 2b)
           end if !fin (if 1)
       else
c Interpolamos por rectas ---------------------------------
c        print*,'splines22 interpola lineal'
	if(n.gt.2)then

              i_inter=(ntau-1)/(n-1) !numero de puntos entre 2 nodos
                                     !incluye uno de los nodos
              do j=1,n
                 do i=1,ntau
                    f(i,j)=0.
                 enddo
              enddo

              do j=1,n-1
                 j1=j
                 j2=j+1
                 i1=(j-1)*i_inter+1
                 pasoj=x(j2)-x(j1)
                 do i=i1,i1+i_inter-1
                    taure(i)=(tau(i)-x(j1))/pasoj
                    f(i,j1)=1.0-taure(i)
                    f(i,j2)=taure(i)
c           print*,j1,j2,x(j1),x(j2),'--',i,taure(i),'---',f(i,j1),f(i,j2)
                 enddo
              enddo
              f(ntau,n)=1.

c filtramos las esquinas
              nw=2                   !anchura del filtro
              peso(1)=.11111
              peso(2)=.22222
              peso(3)=.33334
              peso(4)=.22222
              peso(5)=.11111
              if(i_inter.eq.1)then
                 nw=1
                 peso(1)=0.
                 peso(2)=.25
                 peso(3)=.50
                 peso(4)=.25
                 peso(5)=0.
              end if

              do j=1,n
                 do i=nw+1,ntau-nw
                    sum(i)=0.
                    do ii=-nw,nw
                       sum(i)=sum(i)+peso(ii+3)*f(i+ii,j)
                    enddo
                    f(i,j)=sum(i)
                 enddo
              enddo

	      ks=0
	      do i=1,ntau
	         do k=1,n
		    ks=ks+1
                    ff(ks)=f(i,k)
	         end do
	      end do

	   else

              paso=x(2)-x(1)

	      do i=1,ntau
	         taure(i)=(tau(i)-x(1))/paso
	      end do
	      if(no.eq.0)then
	          ks=0
	          do i=1,ntau
	             f(i,1)=1.0-taure(i)
	             f(i,2)=taure(i)
	             do k=1,n
		        ks=ks+1
                        ff(ks)=f(i,k)
	             end do
	           end do
	       else
	       ks=0
               do i=1,ntau
 	          if(taure(i).lt.1.0)then
		        f(i,1)=1.0-taure(i)
			f(i,2)=taure(i)
			f(i,3)=0.0
	           else
			f(i,1)=0.0
			f(i,2)=2.0-taure(i)
			f(i,3)=taure(i)-1.0
		   end if
		   do k=1,n
		      ks=ks+1
		      ff(ks)=f(i,k)
		   end do
		end do
	      end if
	    end if

	end if

c a partir de aqui lo hace siempre

	ks=0
	do i=1,ntau
	   yy(i)=0.0
	   do k=1,n
	      ks=ks+1
	      f(i,k)=ff(ks)
	      yy(i)=yy(i)+f(i,k)*y(k)
	   end do
	end do

	return
	end


!
!
!
!
!
!
!
  SUBROUTINE PLMBAR_MOD_D1 (LMAX, LAT, DPLM)
  USE SHTOOLS
  IMPLICIT NONE
  INTEGER, PARAMETER :: LLMAX=512, JJMAX=(LLMAX+1)*(LLMAX+2)/2
  INTEGER J, J_INDEX, MJ, JMAX, LMAX
  REAL*8 LAT
  REAL*8 Z, PLM(JJMAX), DPLM(JJMAX)
  REAL*8 COSDD
!
! Given latitude LAT (in degrees), computes the detivatives wrt 'theta'
! of *all* the fully normalized associated Legendre functions \bar P_{lm}(x),
! with x=cos(colatitude), to degree LMAX. Uses the SHTOOLS Legendre functions
! by PlmBar_d1, rescales by sqrt(2-delta(0,m)), and transforms.
!
! Created by GS August 7 2008 for version 2.8 of SELEN
!
!
! ---- Tests the latitude bounds
!
  If(abs(lat).gt.90.) then
 	        Write(88,*) "Error in Sbr. PLMBAR_MOD_D1: Latitude is out of range"
	 	Write(88,*) "The program will STOP ----------------"
 	        Write(* ,*) "Error in Sbr. PLMBAR_MOD_D1: Latitude is out of range"
	 	Write(* ,*) "The program will STOP ----------------"
                call stop_config
	        Stop 1
  elseif(lmax>llmax) then
		Write(88,*) "Error in Sbr. PLMBAR_MOD_D1: The degree exceeds 256", lmax
	 	Write(88,*) "The program will STOP ----------------"
 	        Write(* ,*) "Error in Sbr. PLMBAR_MOD_D1: The degree exceeds 256", lmax
	 	Write(* ,*) "The program will STOP ----------------"
                call stop_config
	        Stop 2
  Endif
!
!
! ---- "z" is cos(theta), theta is co-latitude
!
	z=cosdd(90.-lat)
!
! ---- Builds the SHTOOLS Legendre functions,
!      including the "Condon-Shortley phase"...
!
  	call PlmBar_d1(plm, dplm, lmax, z, -1)
!
!
! ---- Scales consistently to our convention for Legendre functions,
!      dividing by factor sqrt(2-delta(0,m)), AND transofrms to obtain
!      a derivative wrt 'theta' from the derivative wrt 'cos theta'
!
  	do j=1, j_index(lmax,lmax)
     		if(mj(j)/=0) dplm(j)=dplm(j)/sqrt(2.)
	                     dplm(j)=-sqrt(1.-z**2)*dplm(j)
  	enddo
!
  END SUBROUTINE PLMBAR_MOD_D1
!
!
!
!
!


C      +----------------------+
C      !     LITT splines     !
C      +----------------------+
C                      06.03.95

C      Snoopy (entier): interpolation avec 26 pts egalement espaces
C
C      Rem: Ce programme ne contient pasde routine pour le transfert
C           de donnees vers Matlab. Apres compilation, taper:
C                a.out >resultat.m

       integer n,I
       parameter (n=26)
       double precision x,s,XN(n),YN(n),DN(n),W(3*n)

C      ------------------------
C               Data
C      ------------------------
       data YN/0.0 , 0.3 , 0.35, 0.35, 0.35, 0.4, 0.6,
     *         1.2 , 1.45, 1.55, 1.5 ,
     *         1.35, 1.1 , 0.85, 0.6 , 0.7 , 1.2, 1.4, 1.5 , 1.35, 1.0,
     *         0.8 , 0.75, 0.55, 0.3 , 0.0/

       data XN/0.0 , 0.5 , 1.0 , 1.5, 1.8, 2.0, 2.1, 2.5, 3.0,
     *         3.5 , 4.0 , 4.5 , 5.0, 5.5, 5.9,
     *         6.0 , 6.5 , 7.0 , 7.5, 8.0, 8.5, 9.0, 9.5,
     *         10.0, 10.5, 11.0/

       do 30 I=1,n
          write(*,*)'xn(',I,')=',XN(I),';'
          write(*,*)'yn(',I,')=',YN(I),';'
30     continue

C      ------------------------
C        Interpolation spline
C      ------------------------
       call TB04AD(n,XN,YN,DN,W)

C      ------------------------
C        Graphique -> Matlab
C      ------------------------
       x=0.0
       do 10 I=1,201
          s=TG01BD(1,n,XN,YN,DN,x)
          write(*,*)'x(',I,')=',x,'; y(',I,')=',s,';'
          x=x+11.0/200.0
10     continue

       end


c     Package to convert times to UTC
c     AJ_Kettle, Dec08/2017

      SUBROUTINE convert_time_utc(l_mlent,j_sd,f_lon_deg,
     +   st_sd_time,st_sd_time_id,
     +   st_sd_timeutc,st_sd_timeutc_hh_mm_ss)

      IMPLICIT NONE
c************************************************************************
      INTEGER             :: i,j,k,ii,jj,kk

      INTEGER             :: l_mlent
      INTEGER             :: j_sd
      CHARACTER(LEN=4)    :: st_sd_time(l_mlent)
      CHARACTER(LEN=3)    :: st_sd_time_id(l_mlent)
      REAL                :: f_lon_deg

      CHARACTER(LEN=4)    :: st_sd_timeutc(l_mlent)
      CHARACTER(LEN=8)    :: st_sd_timeutc_hh_mm_ss(l_mlent)

c     Intermediate variables for time conversion
      CHARACTER(LEN=4)    :: s_timesingle
      CHARACTER(LEN=2)    :: s_hour
      CHARACTER(LEN=2)    :: s_minute
      CHARACTER(LEN=2)    :: s_second
      CHARACTER(LEN=2)    :: s_test2
      REAL                :: f_test
      REAL                :: f_hour
      REAL                :: f_minute
      REAL                :: f_hourfrac
      REAL                :: f_hourfrac_utc
      INTEGER             :: i_hournew
      INTEGER             :: i_minutenew
      INTEGER             :: i_secondnew
      REAL                :: f_minutenew
      REAL                :: f_secondnew
      REAL                :: f_minuteround
      INTEGER             :: i_test
      INTEGER             :: i_minuteround

      CHARACTER(LEN=2)    :: s_hournew
      CHARACTER(LEN=2)    :: s_minutenew
      CHARACTER(LEN=2)    :: s_secondnew
c************************************************************************
c      print*,'st_sd_time_id..start',st_sd_time_id(1)
c      print*,'st_sd_time_id..end',st_sd_time_id(j_sd)
c      call sleep(5)

      DO i=1,j_sd
c       print*,'st_sd_time_id(i)',st_sd_time_id(i)

       s_timesingle=st_sd_time(i)
       s_hour      =s_timesingle(1:2)
       s_minute    =s_timesingle(3:4)
       s_second    ='00'

c      Convert hour & minute to float
       s_test2       =TRIM(s_hour)
       READ(s_test2,*) f_test
       f_hour        =f_test

       s_test2       =TRIM(s_minute)
       READ(s_test2,*) f_test
       f_minute      =f_test

       f_hourfrac=f_hour+f_minute/60.0
c******
c      UTC: no change in format
       IF (st_sd_time_id(i).EQ.'UTC') THEN
        st_sd_timeutc(i)=st_sd_time(i)

        st_sd_timeutc_hh_mm_ss(i)=
     +    s_hour//':'//s_minute//':'//s_second

c        print*,'UTC case'
c        CALL SLEEP(1)

        GOTO 22
       ENDIF
c******
c      MEZ: shift by 1hour
       IF (st_sd_time_id(i).EQ.'MEZ') THEN
        f_hourfrac_utc=f_hourfrac-1.0
        i_hournew=INT(f_hourfrac_utc)
        f_minutenew=(f_hourfrac_utc-FLOAT(i_hournew))*60.0
        i_minutenew=INT((f_hourfrac_utc-FLOAT(i_hournew))*60.0)
        f_secondnew=(f_minutenew-FLOAT(i_minutenew))*60.0
        i_secondnew=INT(f_secondnew)

c       Convert from integer to string
        IF (i_hournew.GE.10) THEN
         WRITE(s_test2,'(i2)') i_hournew
         s_hournew=s_test2
        ENDIF
        IF (i_hournew.LT.10) THEN
         WRITE(s_test2,'(i2)') i_hournew
         s_hournew='0'//TRIM(ADJUSTL(s_test2))
        ENDIF

        IF (i_minutenew.GE.10) THEN
         WRITE(s_test2,'(i2)') i_minutenew
         s_minutenew=s_test2
        ENDIF
        IF (i_minutenew.LT.10) THEN
         WRITE(s_test2,'(i2)') i_minutenew
         s_minutenew='0'//TRIM(ADJUSTL(s_test2))
        ENDIF

        IF (i_secondnew.GE.10) THEN
         WRITE(s_test2,'(i2)') i_secondnew
         s_secondnew=s_test2
        ENDIF
        IF (i_secondnew.LT.10) THEN
         WRITE(s_test2,'(i2)') i_secondnew
         s_secondnew='0'//TRIM(ADJUSTL(s_test2))
        ENDIF

        st_sd_timeutc(i)=s_hournew//s_minutenew
        st_sd_timeutc_hh_mm_ss(i)=
     +    s_hournew//':'//s_minutenew//':'//s_secondnew

c        print*,'MEZ case'
c        print*,'st_sd_time,st_sd_timeutc',st_sd_time(i),
c     +    st_sd_timeutc(i),st_sd_timeutc_hh_mm_ss(i)
c        CALL SLEEP(5)

        GOTO 22
       ENDIF
c******
c      MOZ: convert LST to UTC
       IF (st_sd_time_id(i).EQ.'MOZ') THEN
        f_hourfrac_utc=f_hourfrac-24.0*(f_lon_deg/360.0)
        i_hournew=INT(f_hourfrac_utc)
        f_minutenew=(f_hourfrac_utc-FLOAT(i_hournew))*60.0
        i_minutenew=INT((f_hourfrac_utc-FLOAT(i_hournew))*60.0)
        f_secondnew=(f_minutenew-FLOAT(i_minutenew))*60.0
        i_secondnew=INT(f_secondnew)

c       Procedure to round minutes
        f_minuteround=10.0*FLOAT(NINT(f_minutenew/10.0))
c       case where rounded minutes >60s
        IF (f_minuteround.GE.60.0) THEN
         f_minuteround=f_minuteround-60.0
         i_hournew=i_hournew+1
        ENDIF
        i_minuteround=INT(f_minuteround)

c       Convert from integer to string
        IF (i_hournew.GE.10) THEN
         WRITE(s_test2,'(i2)') i_hournew
         s_hournew=s_test2
        ENDIF
        IF (i_hournew.LT.10) THEN
         WRITE(s_test2,'(i2)') i_hournew
         s_hournew='0'//TRIM(ADJUSTL(s_test2))
        ENDIF

        IF (i_minuteround.GE.10) THEN
         WRITE(s_test2,'(i2)') i_minuteround
         s_minutenew=s_test2
        ENDIF
        IF (i_minuteround.LT.10) THEN
         WRITE(s_test2,'(i2)') i_minuteround
         s_minutenew='0'//TRIM(ADJUSTL(s_test2))
        ENDIF

c        IF (i_minutenew.GE.10) THEN
c         WRITE(s_test2,'(i2)') i_minutenew
c         s_minutenew=s_test2
c        ENDIF
c        IF (i_minutenew.LT.10) THEN
c         WRITE(s_test2,'(i2)') i_minutenew
c         s_minutenew='0'//TRIM(ADJUSTL(s_test2))
c        ENDIF

c        IF (i_minutenew.GE.10) THEN
c         WRITE(s_test2,'(i2)') i_minutenew
c         s_minutenew=s_test2
c        ENDIF
c        IF (i_minutenew.LT.10) THEN
c         WRITE(s_test2,'(i2)') i_minutenew
c         s_minutenew='0'//TRIM(ADJUSTL(s_test2))
c        ENDIF

c        IF (i_secondnew.GE.10) THEN
c         WRITE(s_test2,'(i2)') i_secondnew
c         s_secondnew=s_test2
c        ENDIF
c        IF (i_secondnew.LT.10) THEN
c         WRITE(s_test2,'(i2)') i_secondnew
c         s_secondnew='0'//TRIM(ADJUSTL(s_test2))
c        ENDIF
c       Hardwire seconds to 00
        s_secondnew='00'

        st_sd_timeutc(i)=s_hournew//s_minutenew
        st_sd_timeutc_hh_mm_ss(i)=
     +    s_hournew//':'//s_minutenew//':'//s_secondnew

c        print*,'MOZ case',i
c        print*,'f_lon_deg=',f_lon_deg
c        print*,'f_hour=',f_hour
c        print*,'f_minute=',f_minute
c        print*,'f_hourfrac=',f_hourfrac
c        print*,'f_hourfrac_utc=',f_hourfrac_utc
c        print*,'i_hournew=',i_hournew
c        print*,'i_minutenew=',i_minutenew
c        print*,'s_hournew=',s_hournew
c        print*,'s_minutenew=',s_minutenew

c        print*,'i_hournew,i_minuteround',i_hournew,i_minuteround

c        print*,'st_sd_time,st_sd_timeutc',st_sd_time(i),
c     +    st_sd_timeutc(i),st_sd_timeutc_hh_mm_ss(i)
c        CALL SLEEP(1)

        GOTO 22
       ENDIF
c******
       print*,'emergency stop, convert_variables'
       print*,'no time id, i=',i,j_sd
       CALL SLEEP(20)

22     CONTINUE
      ENDDO

      RETURN
      END