cc Copyright (C) 2009-2012: Leslie Greengard and Zydrunas Gimbutas
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a modified FreeBSD license
cc (see COPYING in home directory).
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    $Date: 2012-03-11 16:33:15 -0400 (Sun, 11 Mar 2012) $
c    $Revision: 2823 $
c
c
c     ROTATION VIA PROJECTION  (FORTRAN 77 AND 90 VERSIONS).
c
c     Multipole expansions for complex-valued functions.
c
c     Requires FFT and Associated Legendre Function Libraries.
c
c     User-callable f77 routine is rotviaproj.
c     User-callable f90 routine is rotviaprojf90.
c     The other routines are used internally.
c
c***********************************************************************
      subroutine rotviaproj(beta,nterms,m1,m2,mpole,lmp,marray2,lmpn,
     1           w,lw,lused)
c***********************************************************************
c       Purpose:
c
c	Fast and stable algorithm for applying rotation operator about
c	the y-axis determined by angle beta.
c
c       The method is based on computing the induced potential and
c       its theta-derivative on the rotated equator
c       for each order (first index). The coefficients of  the rotated
c       expansion can then be obtained by FFT and projection.
c
c       There is some loss in speed over using recurrence relations
c       but it is stable to all orders whereas the recurrence schemes
c       are not.
c
c       If the rotation operator is to be used multiple times, and
c       memory is available, one can precompute and store the
c       multipliers used in evalall (see below). This has not yet been
c       implemented.
c
c       Our definition of complex spherical harmonics is
c
c       Ynm(theta,phi)= sqrt( 2n+1) sqrt((n-m)!/(n+m)!)
c                       Pnm(cos theta) e^(im phi),
c       Yn,-m(theta,phi) = sqrt( 2n+1) sqrt((n-m)!/(n+m)!)
c                       Pnm(cos theta) e^(-im phi),   for m >= 0.
c
c       Note that we do not include the Condon-Shortley phase (-1)^m
c
C---------------------------------------------------------------------
c       INPUT:
c
c       beta:  the rotation angle about the y-axis.
c       nterms: order of multipole expansion
c
c       m1    : max m index for first expansion
c               NOT IMPLEMENTED but integer argument must be supplied.
c       m2    : max m index for second expansion
c               NOT IMPLEMENTED but integer argument must be supplied.
c
c               That is, parameters m1,m2 are currently ignored.
c
C       mpole   coefficients of original multiple expansion
C       lmp     leading dim for mpole (must exceed nterms)
C       lmpn    leading dim for marray2 (must exceed nterms)
c       w     :  work array
c       lw    :  length of work array
c
C---------------------------------------------------------------------
c       OUTPUT:
c
c       marray2  coefficients of rotated expansion.
c       lused    amount of workspace used.
c       ier      error return flag
c                0 successful execution
c                1 insufficient memory
c
C---------------------------------------------------------------------
c
c
c
      implicit real *8 (a-h,o-z)
      integer nquad,next235_cproj
      real *8 w(lw)
      complex *16 mpole(0:lmp,-lmp:lmp)
      complex *16 marray2(0:lmpn,-lmpn:lmpn)
c
c      nquad = 2*nterms+2
c        write(*,*) nquad
      nquad = next235_cproj((2*nterms+2)*1.0d0)
c        write(*,*) nquad
      ictheta = 1
      istheta = ictheta+nquad
      icphi = istheta+nquad
      isphi = icphi+nquad
      iynm = isphi+nquad
      iynmd = iynm + (nterms+1)**2
      irat1 = iynmd + (nterms+1)**2
      irat2 = irat1 + (nterms+1)**2
      iuval = irat2 + (nterms+1)**2
      iuder = iuval + 2*nquad*(nterms+1)
      iephi = iuder + 2*nquad*(nterms+1)
      iwsave = iephi + 2*(2*nterms+1)
      iavec = iwsave + 4*nquad+20
      ibvec = iavec + 2*nquad
      lused = ibvec + 2*nquad
      if (lused.gt.lw) stop
c
      call rotviaproj0(beta,nquad,nterms,m1,m2,mpole,lmp,
     1           marray2,lmpn,w(ictheta),w(istheta),
     1           w(icphi),w(isphi),w(iynm),w(iynmd),
     1           w(irat1),w(irat2),w(iuval),w(iuder),
     1           w(iephi),w(iwsave),w(iavec),w(ibvec))
      return
      end
c
c
************************************************************************
      function next235_cproj(base)
      implicit none
      integer next235_cproj, numdiv
      real*8 base
c ----------------------------------------------------------------------
c     integer function next235_cproj returns a multiple of 2, 3, and 5
c
c     next235_cproj = 2^p 3^q 5^r >= base  where p>=1, q>=0, r>=0
************************************************************************
      next235_cproj = 2 * int(base/2d0+.9999d0)
      if (next235_cproj.le.0) next235_cproj = 2

100   numdiv = next235_cproj
      do while (numdiv/2*2 .eq. numdiv)
         numdiv = numdiv /2
      enddo
      do while (numdiv/3*3 .eq. numdiv)
         numdiv = numdiv /3
      enddo
      do while (numdiv/5*5 .eq. numdiv)
         numdiv = numdiv /5
      enddo
      if (numdiv .eq. 1) return
      next235_cproj = next235_cproj + 2
      goto 100
      end
c
c
c***********************************************************************
      subroutine rotviaproj0(beta,nquad,nterms,m1,m2,mpole,lmp,
     1           marray2,lmpn,cthetas,sthetas,cphis,sphis,ynm,ynmd,
     1           rat1,rat2,uval,uder,ephis,wsave,avec,bvec)
c***********************************************************************
C
c       INPUT:
c
c       beta:  the rotation angle about the y-axis.
c       nquad:  number of quadrature points on equator
c       nterms: order of multipole expansion
c
c       m1    : max m index for first expansion
c               NOT IMPLEMENTED but integer argument must be supplied.
c       m2    : max m index for second expansion
c               NOT IMPLEMENTED but integer argument must be supplied.
c
c       mpole:   coefficients of original multiple expansion
c       lmp:     leading dimension of mpole
c       lmpn:    leading dimension of output array marray2
c       cthetas: workspace of dimension nquad
c       sthetas: workspace of dimension nquad
c       cphis:   workspace of dimension nquad
c       sphis:   workspace of dimension nquad
c       ynm:     workspace for spherical harmonics
c       ynmd:    workspace for theta derivative of spherical harmonics
c       rat1:    workspace of same dimension as ynm for precomputation
c       rat2:    workspace of same dimension as ynm for precomputation
c       uval:    workspace
c       uder:    workspace
c       ephis:   workspace for exp(i m phi)
c       wsave:   workspace
c       avec:    workspace
c       bvec:    workspace
c
c       OUTPUT:
c
c       marray2  coefficients of rotated expansion.
c---------------------------------------------------------------------
c
      implicit real *8 (a-h,o-z)
      integer nquad,nterms
      real *8 cthetas(nquad),cphis(nquad)
      real *8 sthetas(nquad),sphis(nquad)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
      real *8 rat1(0:nterms,0:nterms)
      real *8 rat2(0:nterms,0:nterms)
      complex *16 avec(nquad)
      complex *16 bvec(nquad)
      complex *16 mpole(0:lmp,-lmp:lmp)
      complex *16 marray2(0:lmpn,-lmpn:lmpn)
      complex *16 uder(nquad,0:nterms),uval(nquad,0:nterms)
      complex *16 ephis(-nterms:nterms)
      real *8 wsave(4*nquad+20)
c
c     Algorithm:
c     1) get locations of quadrature nodes
c     2) evaluate u and du/dtheta
c     3) project onto spherical harmonics.
c
      call getmeridian(beta,nquad,cthetas,sthetas,cphis,sphis)
      call evalall2(beta,nquad,cthetas,sthetas,cphis,sphis,mpole,
     2           lmp,nterms,uval,uder,ynm,ynmd,ephis,rat1,rat2)
      call projectonynm2(nquad,uval,uder,ynm,ynmd,marray2,lmpn,nterms,
     2           m2,wsave,avec,bvec,rat1,rat2)
      return
      end
C
C
C***********************************************************************
      subroutine getmeridian(beta,nquad,cthetas,sthetas,cphis,sphis)
C***********************************************************************
C     Purpose:
C
C           For a rotation of angle BETA about the y-axis, this
C           subroutine returns the NQUAD equispaced nodes on the
C           rotated equator in the original coordinate system.
C
C---------------------------------------------------------------------
C     INPUT:
C
C     beta  = angle of rotation
C     nquad = number of quadrature nodes in equator.
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C     cthetas = cos(theta) values in original coordinate system of
C                    nquad equispaced nodes
C     sthetas = sin(theta) values in original coordinate system of
C                    nquad equispaced nodes
C     cphis =  cos(phi) values in original coordinate system of
C                    nquad equispaced nodes
C     sphis =  cos(phi) values in original coordinate system of
C                    nquad equispaced nodes
C
C***********************************************************************
      implicit real *8 (a-h,o-z)
      integer nquad
      real *8 cthetas(nquad)
      real *8 sthetas(nquad)
      real *8 cphis(nquad)
      real *8 sphis(nquad)
C
      pi = 4.0d0*datan(1.0d0)
C
      ca = cos(beta)
      sa = sin(beta)
      do i = 1,nquad
	 im1 = i-1
         phi = 2*pi*im1/nquad
	 theta = pi/2.0d0
         xp = cos(phi)*sin(theta)
         yp = sin(phi)*sin(theta)
         zp = cos(theta)
         x = ca*xp + sa*zp
         y = yp
         z = -sa*xp + ca*zp
         proj = sqrt(x**2+y**2)
	 if (proj.le.1.0d-16) then
	    cphis(i) = 1.0d0
	    sphis(i) = 0.0d0
	 else
	    cphis(i) = x/proj
	    sphis(i) = y/proj
	 endif
	 cthetas(i) = z
	 sthetas(i) = proj
      enddo
      return
      end
C
C***********************************************************************
      subroutine evalall0(beta,nquad,cthetas,sthetas,cphis,sphis,
     1           mpole,lmp,nterms,uval,uder,ynm,ynmd,ephis,rat1,rat2)
C***********************************************************************
C
C     This subroutine evaluates the multipole expansion for each
C     order at the nquad nodes on the rotated equator.
C
C---------------------------------------------------------------------
C     INPUT:
C
C     beta    : angle of rotation about y-axis.
C     nquad    : number of target point son unit sphere
C     cthetas  : cos(theta) values of target points.
C     sthetas  : sin(theta) values of target points.
C     cphis    : cos(phi) values of target points.
C     sphis    : sin(phi) values of target points.
C     mpole    : original multipole expansion
C     nterms   : order of multipole expansion
C     ynm      : work array for ynm values
C     ynmd     : work array for ynmd values
C     ephis    : work array for exp(i m phi) values
C     rat1     : work array for accelerating ynm calculation.
C     rat2     : work array for accelerating ynm calculation.
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C     uval(i,j) : contribution to potential
C                 of multipole terms of order j at ith quad node.
C     uder(i,j) : contributions to theta derivative of potential
C                 of multipole terms of order j at ith quad node.
C
C***********************************************************************
      implicit real *8 (a-h,o-z)
      integer ndeg,morder, nquad
      real *8 cthetas(nquad),cphis(nquad)
      real *8 sthetas(nquad),sphis(nquad)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
      complex *16 mpole(0:lmp,-lmp:lmp)
      complex *16 ephi1,ephis(-nterms:nterms)
      complex *16 uder(nquad,0:nterms),uval(nquad,0:nterms)
      complex *16 uv,utheta,uphi,ztmp1,ztmp2,ztsum
      complex *16 ux,uy,uz,imag
      real *8 rat1(0:nterms,0:nterms)
      real *8 rat2(0:nterms,0:nterms)
C
      data imag/(0.0d0,1.0d0)/
      pi = 4.0d0*datan(1.0d0)
C
      cbeta = cos(beta)
      sbeta = -sin(beta)
      call ylgndrini(nterms,rat1,rat2)
      do jj=1,nquad
	 ctheta = cthetas(jj)
	 stheta = sthetas(jj)
	 cphi = cphis(jj)
	 sphi = sphis(jj)
         dir1 = -sbeta
         dir2 = 0
         dir3 = cbeta
         tang1 = cphi*ctheta
         tang2 = sphi*ctheta
         tang3 = -stheta
         proj2 = tang1*dir1 + tang2*dir2 + tang3*dir3
         tang1 = -sphi
         tang2 = cphi
         tang3 = 0
         proj1 = tang1*dir1 + tang2*dir2 + tang3*dir3
	 call ylgndru2sf(nterms,ctheta,ynm,ynmd,rat1,rat2)
         ephi1 = dcmplx(cphis(jj),sphis(jj))
	 ephis(1) = ephi1
	 ephis(-1) = dconjg(ephi1)
	 do i = 2,nterms
	    ephis(i) = ephis(i-1)*ephi1
	    ephis(-i) = ephis(-i+1)*dconjg(ephi1)
	 enddo
c
	 do ndeg = 0,nterms
	    uv = ynm(ndeg,0)*mpole(ndeg,0)
	    utheta=ynmd(ndeg,0)*stheta*mpole(ndeg,0)
	    uphi = 0.0d0
	    do morder = 1,ndeg
               ztmp1 = ephis(morder)*mpole(ndeg,morder)
               ztmp2 = ephis(-morder)*mpole(ndeg,-morder)
	       ztsum = ztmp1+ztmp2
	       uv = uv + stheta*ynm(ndeg,morder)*ztsum
	       utheta = utheta + ynmd(ndeg,morder)*ztsum
	       uphi = uphi - ynm(ndeg,morder)*morder*(ztmp1-ztmp2)
	    enddo
            uval(jj,ndeg) = uv
            uder(jj,ndeg) = utheta*proj2+uphi*imag*proj1
	 enddo
      enddo
      return
      end
C
C
C***********************************************************************
      subroutine evalall1(beta,nquad,cthetas,sthetas,cphis,sphis,
     1           mpole,lmp,nterms,uval,uder,ynm,ynmd,ephis,rat1,rat2)
C***********************************************************************
C
C     This subroutine evaluates the multipole expansion for each
C     order at the nquad nodes on the rotated equator.
C
C---------------------------------------------------------------------
C     INPUT:
C
C     beta    : angle of rotation about y-axis.
C     nquad    : number of target point son unit sphere
C     cthetas  : cos(theta) values of target points.
C     sthetas  : sin(theta) values of target points.
C     cphis    : cos(phi) values of target points.
C     sphis    : sin(phi) values of target points.
C     mpole    : original multipole expansion
C     nterms   : order of multipole expansion
C     ynm      : work array for ynm values
C     ynmd     : work array for ynmd values
C     ephis    : work array for exp(i m phi) values
C     rat1     : work array for accelerating ynm calculation.
C     rat2     : work array for accelerating ynm calculation.
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C     uval(i,j) : contribution to potential
C                 of multipole terms of order j at ith quad node.
C     uder(i,j) : contributions to theta derivative of potential
C                 of multipole terms of order j at ith quad node.
C
C***********************************************************************
      implicit real *8 (a-h,o-z)
      integer ndeg,morder, nquad
      real *8 cthetas(nquad),cphis(nquad)
      real *8 sthetas(nquad),sphis(nquad)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
      complex *16 mpole(0:lmp,-lmp:lmp)
      complex *16 ephi1,ephis(-nterms:nterms)
      complex *16 uder(nquad,0:nterms),uval(nquad,0:nterms)
      complex *16 uv,utheta,uphi,ztmp1,ztmp2,ztsum,ztdif
      complex *16 ux,uy,uz,ima
      real *8 rat1(0:nterms,0:nterms)
      real *8 rat2(0:nterms,0:nterms)
C
      data ima/(0.0d0,1.0d0)/
      pi = 4.0d0*datan(1.0d0)
C
      cbeta = cos(beta)
      sbeta = -sin(beta)
      call ylgndrini(nterms,rat1,rat2)
c
      do jj=1,nquad/2
	 ctheta = cthetas(jj)
	 stheta = sthetas(jj)
	 cphi = cphis(jj)
	 sphi = sphis(jj)
ccc         write(*,*) ctheta,cphi,sphi
         dir1 = -sbeta
         dir2 = 0
         dir3 = cbeta
         tang1 = cphi*ctheta
         tang2 = sphi*ctheta
         tang3 = -stheta
         proj2 = tang1*dir1 + tang2*dir2 + tang3*dir3
         tang1 = -sphi
         tang2 = cphi
         tang3 = 0
         proj1 = tang1*dir1 + tang2*dir2 + tang3*dir3
	 call ylgndru2sf(nterms,ctheta,ynm,ynmd,rat1,rat2)
         ephi1 = dcmplx(cphis(jj),sphis(jj))
	 ephis(1) = ephi1
	 ephis(-1) = dconjg(ephi1)
	 do i = 2,nterms
	    ephis(i) = ephis(i-1)*ephi1
	    ephis(-i) = dconjg(ephis(i))
	 enddo
ccc         call prin2('ephis=*',ephis(-nterms),2*(2*nterms+1))
c
	 do ndeg = 0,nterms
	    uv=0
	    utheta=0
	    uphi=0
	    do morder = 1,ndeg
               ztmp1=ephis(morder)*mpole(ndeg,morder)
               ztmp2=ephis(-morder)*mpole(ndeg,-morder)
	       ztsum=ztmp1+ztmp2
	       ztdif=ztmp1-ztmp2
	       uv=uv+ynm(ndeg,morder)*ztsum
	       utheta=utheta+ynmd(ndeg,morder)*ztsum
	       uphi=uphi-ynm(ndeg,morder)*morder*ztdif
	    enddo
	    uv=stheta*uv+ynm(ndeg,0)*mpole(ndeg,0)
	    utheta=utheta+ynmd(ndeg,0)*stheta*mpole(ndeg,0)
c
c       ... apply the periodizing operator
c
            uval(jj,ndeg) = uv
            uder(jj,ndeg) = (utheta*proj2+uphi*ima*proj1)
            if( mod(ndeg,2) .eq. 0 ) then
            uval(jj+nquad/2,ndeg) = +uval(jj,ndeg)
            uder(jj+nquad/2,ndeg) = -uder(jj,ndeg)
            endif
            if( mod(ndeg,2) .eq. 1 ) then
            uval(jj+nquad/2,ndeg) = -uval(jj,ndeg)
            uder(jj+nquad/2,ndeg) = +uder(jj,ndeg)
            endif
c
c       ... alternative form of the periodizing operator
c
cc            uval(jj,ndeg) = 2*uv
cc            uder(jj,ndeg) = 2*(utheta*proj2+uphi*ima*proj1)
cc            uval(jj+nquad/2,ndeg) = 0
cc            uder(jj+nquad/2,ndeg) = 0
	 enddo
      enddo
      return
      end
C
C
C***********************************************************************
      subroutine evalall2(beta,nquad,cthetas,sthetas,cphis,sphis,
     1           mpole,lmp,nterms,uval,uder,ynm,ynmd,ephis,rat1,rat2)
C***********************************************************************
C
C     This subroutine evaluates the multipole expansion for each
C     order at the nquad nodes on the rotated equator.
C
C---------------------------------------------------------------------
C     INPUT:
C
C     beta    : angle of rotation about y-axis.
C     nquad    : number of target point son unit sphere
C     cthetas  : cos(theta) values of target points.
C     sthetas  : sin(theta) values of target points.
C     cphis    : cos(phi) values of target points.
C     sphis    : sin(phi) values of target points.
C     mpole    : original multipole expansion
C     nterms   : order of multipole expansion
C     ynm      : work array for ynm values
C     ynmd     : work array for ynmd values
C     ephis    : work array for exp(i m phi) values
C     rat1     : work array for accelerating ynm calculation.
C     rat2     : work array for accelerating ynm calculation.
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C     uval(i,j) : contribution to potential
C                 of multipole terms of order j at ith quad node.
C     uder(i,j) : contributions to theta derivative of potential
C                 of multipole terms of order j at ith quad node.
C
C***********************************************************************
      implicit real *8 (a-h,o-z)
      integer ndeg,morder, nquad
      real *8 cthetas(nquad),cphis(nquad)
      real *8 sthetas(nquad),sphis(nquad)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
      complex *16 mpole(0:lmp,-lmp:lmp)
      complex *16 ephi1,ephis(-nterms:nterms)
      complex *16 uder(nquad,0:nterms),uval(nquad,0:nterms)
      complex *16 uv,utheta,uphi,ztmp1,ztmp2,ztsum,ztdif
      complex *16 ux,uy,uz,ima
      real *8 rat1(0:nterms,0:nterms)
      real *8 rat2(0:nterms,0:nterms)
C
      data ima/(0.0d0,1.0d0)/
      pi = 4.0d0*datan(1.0d0)
C
      cbeta = cos(beta)
      sbeta = -sin(beta)
      call ylgndrini(nterms,rat1,rat2)
c
ccc        write(*,*) nquad, nquad/2, nquad/4
      nquad2=nquad/2
      if( mod(nquad2,2) .eq. 0 ) nquad4=nquad2/2+1
      if( mod(nquad2,2) .eq. 1 ) nquad4=nquad2/2+1
c
      do jj=1,nquad4
	 ctheta = cthetas(jj)
	 stheta = sthetas(jj)
	 cphi = cphis(jj)
	 sphi = sphis(jj)
ccc         write(*,*) ctheta,cphi,sphi
         dir1 = -sbeta
         dir2 = 0
         dir3 = cbeta
         tang1 = cphi*ctheta
         tang2 = sphi*ctheta
         tang3 = -stheta
         proj2 = tang1*dir1 + tang2*dir2 + tang3*dir3
         tang1 = -sphi
         tang2 = cphi
         tang3 = 0
         proj1 = tang1*dir1 + tang2*dir2 + tang3*dir3
	 call ylgndru2sf(nterms,ctheta,ynm,ynmd,rat1,rat2)
         ephi1 = dcmplx(cphis(jj),sphis(jj))
	 ephis(1) = ephi1
	 ephis(-1) = dconjg(ephi1)
	 do i = 2,nterms
	    ephis(i) = ephis(i-1)*ephi1
	    ephis(-i) = dconjg(ephis(i))
	 enddo
ccc         call prin2('ephis=*',ephis(-nterms),2*(2*nterms+1))
c
	 do ndeg = 0,nterms
	    uv=0
	    utheta=0
	    uphi=0
	    do morder = 1,ndeg
               ztmp1=ephis(morder)*mpole(ndeg,morder)
               ztmp2=ephis(-morder)*mpole(ndeg,-morder)
	       ztsum=ztmp1+ztmp2
	       ztdif=ztmp1-ztmp2
	       uv=uv+ynm(ndeg,morder)*ztsum
	       utheta=utheta+ynmd(ndeg,morder)*ztsum
	       uphi=uphi-ynm(ndeg,morder)*morder*ztdif
	    enddo
	    uv=stheta*uv+ynm(ndeg,0)*mpole(ndeg,0)
	    utheta=utheta+ynmd(ndeg,0)*stheta*mpole(ndeg,0)
c
c       ... apply the periodizing operator
c
            uval(jj,ndeg) = uv
            uder(jj,ndeg) = (utheta*proj2+uphi*ima*proj1)
            if( mod(ndeg,2) .eq. 0 ) then
            uval(jj+nquad/2,ndeg) = +uval(jj,ndeg)
            uder(jj+nquad/2,ndeg) = -uder(jj,ndeg)
            endif
            if( mod(ndeg,2) .eq. 1 ) then
            uval(jj+nquad/2,ndeg) = -uval(jj,ndeg)
            uder(jj+nquad/2,ndeg) = +uder(jj,ndeg)
            endif
c
c       ... alternative form of the periodizing operator
c
cc            uval(jj,ndeg) = 2*uv
cc            uder(jj,ndeg) = 2*(utheta*proj2+uphi*ima*proj1)
cc            uval(jj+nquad/2,ndeg) = 0
cc            uder(jj+nquad/2,ndeg) = 0
	 enddo

         if_reflect=1
         if( jj .eq. 1 ) if_reflect=0
         if( jj .eq. nquad4 .and. mod(nquad2,2) .eq. 0 ) if_reflect=0
c
         if( if_reflect .eq. 1 ) then
         jjr=nquad2 - jj + 2
ccc         write(*,*) jj, jjr
         call ylgndr2pm_opt(nterms,ynm,ynmd)

	 ctheta = -cthetas(jj)
	 stheta = sthetas(jj)
	 cphi = -cphis(jj)
	 sphi = sphis(jj)
ccc         write(*,*) ctheta,cphi,sphi
         dir1 = -sbeta
         dir2 = 0
         dir3 = cbeta
         tang1 = cphi*ctheta
         tang2 = sphi*ctheta
         tang3 = -stheta
         proj2 = tang1*dir1 + tang2*dir2 + tang3*dir3
         tang1 = -sphi
         tang2 = cphi
         tang3 = 0
         proj1 = tang1*dir1 + tang2*dir2 + tang3*dir3

         ephi1 = dcmplx(cphi,sphi)
	 ephis(1) = ephi1
	 ephis(-1) = dconjg(ephi1)
	 do i = 2,nterms
	    ephis(i) = ephis(i-1)*ephi1
	    ephis(-i) = dconjg(ephis(i))
	 enddo
ccc         call prin2('ephis=*',ephis(-nterms),2*(2*nterms+1))
c
	 do ndeg = 0,nterms
	    uv=0
	    utheta=0
	    uphi=0
	    do morder = 1,ndeg
               ztmp1=ephis(morder)*mpole(ndeg,morder)
               ztmp2=ephis(-morder)*mpole(ndeg,-morder)
	       ztsum=ztmp1+ztmp2
	       ztdif=ztmp1-ztmp2
	       uv=uv+ynm(ndeg,morder)*ztsum
	       utheta=utheta+ynmd(ndeg,morder)*ztsum
	       uphi=uphi-ynm(ndeg,morder)*morder*ztdif
	    enddo
	    uv=stheta*uv+ynm(ndeg,0)*mpole(ndeg,0)
	    utheta=utheta+ynmd(ndeg,0)*stheta*mpole(ndeg,0)
c
c       ... apply the periodizing operator
c
            uval(jjr,ndeg) = uv
            uder(jjr,ndeg) = (utheta*proj2+uphi*ima*proj1)
            if( mod(ndeg,2) .eq. 0 ) then
            uval(jjr+nquad/2,ndeg) = +uval(jjr,ndeg)
            uder(jjr+nquad/2,ndeg) = -uder(jjr,ndeg)
            endif
            if( mod(ndeg,2) .eq. 1 ) then
            uval(jjr+nquad/2,ndeg) = -uval(jjr,ndeg)
            uder(jjr+nquad/2,ndeg) = +uder(jjr,ndeg)
            endif
c
c       ... alternative form of the periodizing operator
c
cc            uval(jjr,ndeg) = 2*uv
cc            uder(jjr,ndeg) = 2*(utheta*proj2+uphi*ima*proj1)
cc            uval(jjr+nquad/2,ndeg) = 0
cc            uder(jjr+nquad/2,ndeg) = 0
	 enddo
         endif
      enddo
      return
      end
C
C
C
C
C
C***********************************************************************
      subroutine projectonynm(nquad,uval,uder,
     1           ynm,ynmd,marray,lmpn,nterms,m2,wsave,avec,bvec,
     $           rat1,rat2)
C***********************************************************************
C
C     This subroutine projects from values on equator for each multipole
C     order (uval, uder = dudthteta)
C     onto spherical harmonics
C
C---------------------------------------------------------------------
C     INPUT:
C
C     nquad    : number of points on equator
C     uval     : F values on equator
C     uder     : dFdtheta values on equator
C     ynm      : work array for ynm values
C     ynmd     : work array for ynmd values
C     lmpn     : leading dim of marray (must exceed nterms)
C     nterms   : order of expansion
C     m2       : NOT IMPLEMENTED (for reduced number of degrees in
C                expansion (second index)
C     wsave    : work array for FFT (dimension at least 4*nquad+20)
C     avec     : work array of length nquad for FFT (complex)
C     bvec     : work array of length nquad for FFT (complex)
C---------------------------------------------------------------------
C     OUTPUT:
C
C     marray   : rotated expansion
C
C
C***********************************************************************
      implicit real *8 (a-h,o-z)
      integer nquad, norder
      complex *16 ephi,ephi1,uval(nquad,0:1)
      complex *16 uder(nquad,0:1)
      complex *16 utheta,uphi,ztmp1,ztmp2
      complex *16 alpha,beta,ima
      complex *16 marray(0:lmpn,-lmpn:lmpn)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
      real *8 wsave(4*nquad+20)
      complex *16 avec(nquad)
      complex *16 bvec(nquad)
      real *8 rat1(0:nterms,0:nterms)
      real *8 rat2(0:nterms,0:nterms)
C
      data ima/(0.0d0,1.0d0)/
c
cc      pi = 4.0d0*datan(1.0d0)
cc      theta = pi/2.0d0
cc      ctheta = cos(theta)
cc      stheta = sin(theta)
c
      ctheta = 0.0d0
      stheta = 1.0d0
      h = 1.0d0/nquad
      call ylgndru2sf(nterms,ctheta,ynm,ynmd,rat1,rat2)
      call zffti(nquad,wsave)
      do norder=0,nterms
	 do ii = 1,nquad
	    avec(ii) = uval(ii,norder)
	    bvec(ii) = uder(ii,norder)
         enddo
ccc         call prin2('uval=*',avec,2*nquad)
ccc         call prin2('uder=*',bvec,2*nquad)
	 call zfftf(nquad,avec,wsave)
	 call zfftf(nquad,bvec,wsave)
ccc         call prin2('after fft, avec=*',avec,2*nquad)
ccc         call prin2('after fft, bvec=*',bvec,2*nquad)
         do m = -norder,norder
	    if (m.ge.0)  alpha = avec(m+1)*h
	    if (m.lt.0)  alpha = avec(nquad+m+1)*h
	    if (m.ge.0)  beta = bvec(m+1)*h
	    if (m.lt.0)  beta = bvec(nquad+m+1)*h
            marray(norder,m) = (alpha*ynm(norder,abs(m)) -
     1        beta*ynmd(norder,abs(m)))/
     1        (ynm(norder,abs(m))**2 + (ynmd(norder,abs(m)))**2)
         enddo
      enddo
      return
      end
c
c
c
c
c
C***********************************************************************
      subroutine projectonynm2(nquad,uval,uder,
     1           ynm,ynmd,marray,lmpn,nterms,m2,wsave,avec,bvec,
     $           rat1,rat2)
C***********************************************************************
C
C     This subroutine projects from values on equator for each multipole
C     order (uval, uder = dudthteta)
C     onto spherical harmonics
C
C---------------------------------------------------------------------
C     INPUT:
C
C     nquad    : number of points on equator
C     uval     : F values on equator
C     uder     : dFdtheta values on equator
C     ynm      : work array for ynm values
C     ynmd     : work array for ynmd values
C     lmpn     : leading dim of marray (must exceed nterms)
C     nterms   : order of expansion
C     m2       : NOT IMPLEMENTED (for reduced number of degrees in
C                expansion (second index)
C     wsave    : work array for FFT (dimension at least 4*nquad+20)
C     avec     : work array of length nquad for FFT (complex)
C     bvec     : work array of length nquad for FFT (complex)
C---------------------------------------------------------------------
C     OUTPUT:
C
C     marray   : rotated expansion
C
C
C***********************************************************************
      implicit real *8 (a-h,o-z)
      integer nquad, norder
      complex *16 ephi,ephi1,uval(nquad,0:1)
      complex *16 uder(nquad,0:1)
      complex *16 utheta,uphi,ztmp1,ztmp2
      complex *16 alpha,beta,ima
      complex *16 marray(0:lmpn,-lmpn:lmpn)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
      real *8 wsave(4*nquad+20)
      complex *16 avec(nquad)
      complex *16 bvec(nquad)
      real *8 rat1(0:nterms,0:nterms)
      real *8 rat2(0:nterms,0:nterms)
C
      data ima/(0.0d0,1.0d0)/
c
cc      pi = 4.0d0*datan(1.0d0)
cc      theta = pi/2.0d0
cc      ctheta = cos(theta)
cc      stheta = sin(theta)
c
      ctheta = 0.0d0
      stheta = 1.0d0
      h = 1.0d0/nquad
      call ylgndru2sf(nterms,ctheta,ynm,ynmd,rat1,rat2)
      call zffti(nquad,wsave)
      do norder=0,nterms
         d=sqrt(2*norder+1.0d0)
	 do ii = 1,nquad
	    avec(ii) = uval(ii,norder)*d + uder(ii,norder)
ccc	    bvec(ii) = uder(ii,norder)
         enddo
ccc         call prin2('uval=*',avec,2*nquad)
ccc         call prin2('uder=*',bvec,2*nquad)
	 call zfftf(nquad,avec,wsave)
ccc	 call zfftf(nquad,bvec,wsave)
ccc         call prin2('after fft, avec=*',avec,2*nquad)
ccc         call prin2('after fft, bvec=*',bvec,2*nquad)
         do m = -norder,norder
	    if (m.ge.0)  alpha = avec(m+1)*h
	    if (m.lt.0)  alpha = avec(nquad+m+1)*h
            marray(norder,m) = alpha/
     1        (ynm(norder,abs(m))*d - (ynmd(norder,abs(m))))
         enddo
      enddo
      return
      end
c
c
c
c
c
c***********************************************************************
      subroutine rotviaprojf90(beta,nterms,m1,m2,mpole,lmp,
     1           marray2,lmpn)
c***********************************************************************
c       Purpose:
c
c	Fast and stable algorithm for applying rotation operator about
c	the y-axis determined by angle beta.
c
c       The method is based on computing the induced potential and
c       its theta-derivative on the rotated equator
c       for each order (first index). The coefficients of  the rotated
c       expansion can then be obtained by FFT and projection.
c
c       There is some loss in speed over using recurrence relations
c       but it is stable to all orders whereas the recurrence schemes
c       are not.
c
c       If the rotation operator is to be used multiple times, and
c       memory is available, one can precompute and store the
c       multipliers used in evalall (see below). This has not yet been
c       implemented.
c
C---------------------------------------------------------------------
c       INPUT:
c
c       beta:  the rotation angle about the y-axis.
c       nterms: order of multipole expansion
C       mpole   coefficients of original multiple expansion
C       lmp     leading dim for mpole (must exceed nterms)
C       lmpn    leading dim for marray2 (must exceed nterms)
c
C---------------------------------------------------------------------
c       OUTPUT:
c
c       marray2  coefficients of rotated expansion.
c
C---------------------------------------------------------------------
c
c
c
      implicit none
      integer nquad,ier,m1,m2,nterms,lmp,lmpn, next235_cproj
      integer ictheta,istheta,icphi,isphi,iynm,iynmd,irat1,irat2
      integer iuval,iuder,iephi,iwsave,iavec,ibvec,lused
      real *8 beta
      real *8, allocatable :: w(:)
      complex *16 mpole(0:lmp,-lmp:lmp)
      complex *16 marray2(0:lmpn,-lmpn:lmpn)
      complex *16, allocatable :: cw(:)
c
c      nquad = 2*nterms+2
c        write(*,*) nquad
      nquad = next235_cproj((2*nterms+2)*1.0d0)
c        write(*,*) nquad
      ictheta = 1
      istheta = ictheta+nquad
      icphi = istheta+nquad
      isphi = icphi+nquad
      iynm = isphi+nquad
      iynmd = iynm + (nterms+1)**2
      irat1 = iynmd + (nterms+1)**2
      irat2 = irat1 + (nterms+1)**2
      iwsave = irat2 + (nterms+1)**2
      lused = iwsave + 4*nquad+20
      allocate (w(lused), stat=ier)
      iuval = 1
      iuder = iuval + nquad*(nterms+1)
      iephi = iuder + nquad*(nterms+1)
      iavec = iephi + (2*nterms+1)
      ibvec = iavec + 2*nquad
      lused = ibvec + 2*nquad
      allocate (cw(lused), stat=ier)
      if (ier.ne.0) then
         write(6,*) ' alloc failure in rotviaprojf90'
         stop
      endif
c
      call rotviaproj0(beta,nquad,nterms,nterms,nterms,mpole,lmp,
     1           marray2,lmpn,w(ictheta),w(istheta),
     1           w(icphi),w(isphi),w(iynm),w(iynmd),
     1           w(irat1),w(irat2),cw(iuval),cw(iuder),
     1           cw(iephi),w(iwsave),cw(iavec),cw(ibvec))
      deallocate(w)
      return
      end
c
c


      SUBROUTINE slSUGA (DSL, DSB, DL, DB)
*+
*     - - - - - - -
*      S U G A
*     - - - - - - -
*
*  Transformation from de Vaucouleurs supergalactic coordinates
*  to IAU 1958 galactic coordinates (double precision)
*
*  Given:
*     DSL,DSB     dp       supergalactic longitude and latitude
*
*  Returned:
*     DL,DB       dp       galactic longitude and latitude L2,B2
*
*  (all arguments are radians)
*
*  Called:
*     slDS2C, slDIMV, slDC2S, slDA2P, slDA1P
*
*  References:
*
*     de Vaucouleurs, de Vaucouleurs, & Corwin, Second Reference
*     Catalogue of Bright Galaxies, U. Texas, page 8.
*
*     Systems & Applied Sciences Corp., Documentation for the
*     machine-readable version of the above catalogue,
*     Contract NAS 5-26490.
*
*    (These two references give different values for the galactic
*     longitude of the supergalactic origin.  Both are wrong;  the
*     correct value is L2=137.37.)
*
*  P.T.Wallace   Starlink   March 1986
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION DSL,DSB,DL,DB

      DOUBLE PRECISION slDA2P,slDA1P

      DOUBLE PRECISION V1(3),V2(3)

*
*  System of supergalactic coordinates:
*
*    SGL   SGB        L2     B2      (deg)
*     -    +90      47.37  +6.32
*     0     0         -      0
*
*  Galactic to supergalactic rotation matrix:
*
      DOUBLE PRECISION RMAT(3,3)
      DATA RMAT(1,1),RMAT(1,2),RMAT(1,3),
     :     RMAT(2,1),RMAT(2,2),RMAT(2,3),
     :     RMAT(3,1),RMAT(3,2),RMAT(3,3)/
     : -0.735742574804D0,+0.677261296414D0,+0.000000000000D0,
     : -0.074553778365D0,-0.080991471307D0,+0.993922590400D0,
     : +0.673145302109D0,+0.731271165817D0,+0.110081262225D0/

*  Spherical to Cartesian
      CALL slDS2C(DSL,DSB,V1)

*  Supergalactic to galactic
      CALL slDIMV(RMAT,V1,V2)

*  Cartesian to spherical
      CALL slDC2S(V2,DL,DB)

*  Express in conventional ranges
      DL=slDA2P(DL)
      DB=slDA1P(DB)

      END


Module plasticity_mod
  ! Module for all plasticity-related calculations

Contains

  Subroutine Plasticity(m, sv, ndir, eps, use_temp)
    ! This is the main entry point for plasticity calculations

    Use matProp_Mod
    Use stateVar_Mod

    ! Arguments
    Type(matProps), intent(IN) :: m
    Type(stateVars), intent(INOUT) :: sv                ! State variables related to plasticity
    Integer, intent(IN) :: ndir
    Double Precision, intent(INOUT) :: eps(ndir,ndir)   ! Strain tensor
    Logical, optional :: use_temp                       ! Set to true to use temporary state variables (default=False)

    ! Locals
    Logical :: use_temporary_sv

    Double Precision, parameter :: one=1.d0, two=2.d0
    ! -------------------------------------------------------------------- !

    ! Set default behavior for use_temp
    If (present(use_temp)) Then
      use_temporary_sv = use_temp
    Else
      use_temporary_sv = .FALSE.
    End If

    If (m%shearNonlinearity12) Then
      If (use_temporary_sv) Then
        Call ro_plasticity(two*eps(1,2), sv%d_eps12_temp, m%G12, m%aPL, m%nPL, sv%Plas12_temp, sv%Inel12_temp)
        eps(1,2) = eps(1,2) - sv%Plas12_temp/two
        eps(2,1) = eps(1,2)
      Else
        Call ro_plasticity(two*eps(1,2), sv%d_eps12, m%G12, m%aPL, m%nPL, sv%Plas12, sv%Inel12)
        eps(1,2) = eps(1,2) - sv%Plas12/two
        eps(2,1) = eps(1,2)
      End IF
    Else If (m%shearNonlinearity13) Then
      If (use_temporary_sv) Then
        Call ro_plasticity(two*eps(1,3), sv%d_eps13_temp, m%G13, m%aPL, m%nPL, sv%Plas13_temp, sv%Inel13_temp)
        eps(1,3) = eps(1,3) - sv%Plas13_temp/two
        eps(3,1) = eps(1,3)
      Else
        Call ro_plasticity(two*eps(1,3), sv%d_eps13, m%G13, m%aPL, m%nPL, sv%Plas13, sv%Inel13)
        eps(1,3) = eps(1,3) - sv%Plas13/two
        eps(3,1) = eps(1,3)
      End IF
    ! Else If (m%other_plasticity_model)
      ! TODO
    End If

    Return
  End Subroutine Plasticity

  Subroutine ro_plasticity(strain, d_strain_sign, modulus, aPL, nPL, Plas, Inel)
    ! The purpose of this subroutine is to calculate the plastic and inelastic strains
    ! for the given total strain state and nonlinear stress-strain curve.

    Use forlog_Mod

    ! Arguments
    Double Precision, intent(IN) :: modulus                 ! Elastic modulus (eg G12)
    Double Precision, intent(IN) :: strain, d_strain_sign   ! Strain
    Double Precision, intent(IN) :: aPL, nPL                ! NL shear strain properties
    Double Precision, intent(INOUT) :: Plas, Inel

    ! Locals
    Double Precision :: epsEff,tau,Inel_trial,ff0,ff1,tol
    Integer :: E, E_max
    Double Precision, parameter :: one=1.d0
    ! -------------------------------------------------------------------- !

    ! effective strain (used to account for unloading and reloading)
    epsEff = ABS(strain - Plas) + Inel

    ! Compute stress following the Ramberg-Osgood curve
    tau = ramberg_osgood(epsEff, modulus, aPL, nPL)

    ! Compute the inelastic strain (independent of unloading/reloading) and plastic strain (depends on loading direction)
    Inel_trial = epsEff - tau/Modulus
    If (Inel_trial > Inel) Then
      Plas = Plas + (Inel_trial - Inel)*d_strain_sign
      Inel = Inel_trial
    End If

    Return
  End Subroutine ro_plasticity

  Function ramberg_osgood(strain, modulus, aPL, nPL) result(tau)
    ! Find shear stress corresponding to strain following RO law

    Use forlog_Mod

    ! Input
    Double Precision, intent(IN) :: strain        ! engineering shear strain
    Double Precision, intent(IN) :: modulus, aPL, nPL

    ! Output
    Double Precision :: tau

    ! Locals
    Double Precision :: epsEff,Inel_trial,ff0,ff1,tol
    Integer :: E, E_max
    Double Precision, parameter :: zero=0.d0, one=1.d0
    ! -------------------------------------------------------------------- !

    epsEff = ABS(strain) ! effective strain
    tau = Modulus*strain ! initial guess for stress

    tol = 1.d-8 ! tolerance for epsPL convergence [strain]

    E_max = 1000 ! maximum epsPL loop iterations
    epsPL: Do E = 0,E_max
      ff0 = tau + SIGN(one, tau)*aPL*ABS(tau)**nPL - Modulus*epsEff ! ff0 = 0, solve for tau
      If (ABS(ff0)/Modulus <= tol) EXIT epsPL
      If (E == E_max) Call log%error("epsPL loop in ramberg_osgood failed to converge: " // trim(str(strain)))
      ff1 = one + aPL*nPL*ABS(tau)**(nPL - one) ! derivative of ff0 w.r.t. tau
      tau = tau - ff0/ff1 ! Newton-Raphson equation
    End Do epsPL

    Return
  End Function ramberg_osgood

End Module plasticity_mod


Function ulalps(q2)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Save /ludat2/
  If (mstu(111)<=0) Then
    ulalps = paru(111)
    mstu(118) = mstu(112)
    paru(117) = 0.
    paru(118) = paru(111)
    Return
  End If
  q2eff = q2
  If (mstu(115)>=2) q2eff = max(q2, paru(114))
  nf = mstu(112)
  alam2 = paru(112)**2
  100 If (nf>max(2,mstu(113))) Then
    q2thr = paru(113)*pmas(nf, 1)**2
    If (q2eff<q2thr) Then
      nf = nf - 1
      alam2 = alam2*(q2thr/alam2)**(2./(33.-2.*nf))
      Goto 100
    End If
  End If
  110 If (nf<min(8,mstu(114))) Then
    q2thr = paru(113)*pmas(nf+1, 1)**2
    If (q2eff>q2thr) Then
      nf = nf + 1
      alam2 = alam2*(alam2/q2thr)**(2./(33.-2.*nf))
      Goto 110
    End If
  End If
  If (mstu(115)==1) q2eff = q2eff + alam2
  paru(117) = sqrt(alam2)
  b0 = (33.-2.*nf)/6.
  algq = log(q2eff/alam2)
  If (mstu(111)==1) Then
    ulalps = paru(2)/(b0*algq)
  Else
    b1 = (153.-19.*nf)/6.
    ulalps = paru(2)/(b0*algq)*(1.-b1*log(algq)/(b0**2*algq))
  End If
  mstu(118) = nf
  paru(118) = ulalps
  Return
End Function ulalps


C++************************************************************************
C Program to set up initial conditions for the cluster
C filament simulations.
C
C Isotropic cluster and isotropic filament galaxy
C
C From Peter Quinn Sept. 1987
C
C@@@ JLP JUNE 1989 : added dispersion in velocities at a given radius
C************************************************************************
C Notes to use these programs:
C
C Check audit.dat generated by EVOLVE_CLUSTER. If the energy is not
C constant take a smaller step.
C
C In February-May 1988:
C Sigma_cluster    = 200
C Rcore_cluster    = 2
C Rtidal_cluster   = 30
C Mass_galaxy      = 1.E+08
C Re_galaxy        = 4
C Initial_distance = 20
C Ellipse
C Fraction of circular energy = 1.E-10
C Number of particles  = 20000
C Stability factor     = 1
C
C--************************************************************************

	PROGRAM SETUP_CLUSTER
	PARAMETER (G=1.,unit_vel=976.6,unit_mass=2.217e+11)
C (Quinn' extent=10.)
        PARAMETER (max_bodies=20000,extent=3.)

	DIMENSION xp(max_bodies),yp(max_bodies),zp(max_bodies)
	DIMENSION vxp(max_bodies),vyp(max_bodies),vzp(max_bodies)
	DIMENSION pmass(max_bodies),header(128)

	LOGICAL is_member

	REAL lum_mass_member,lum_mass_filgal

        CHARACTER*1 orbit_type
	CHARACTER*40 params_file,model_file

	params_file = 'params'
	model_file = 'model'

	PRINT *,' '
	PRINT *,'setup>> Cluster initial conditions set up program <<'
	PRINT *,' '

	WRITE(6,1)
   1	FORMAT(1x,'setup>> Supply : Cluster velocity dispersion : '$)
	READ(5,*)sigma_cluster
	WRITE(6,2)
   2	FORMAT(1x,'setup>>          Cluster core radius         : '$)
	READ(5,*)core_radius_cluster
	WRITE(6,3)
   3	FORMAT(1x,'setup>>          Cluster outer radius        : '$)
	READ(5,*)outer_radius_cluster

        pi=2.*asin(1.)
	sigma_cluster_scaled=sigma_cluster/unit_vel
	rho_0_cluster=(sigma_cluster_scaled**2)/
     &                (2.*pi*G*core_radius_cluster**2)
	ratio2=outer_radius_cluster/core_radius_cluster
	total_mass_cluster=4.*pi*rho_0_cluster*core_radius_cluster**3*
     &                     (ratio2-atan(ratio2))
        total_mass_scaled=total_mass_cluster*unit_mass
	PRINT *,'setup>---> Total cluster mass : ',total_mass_scaled

        PRINT *,' '
C	WRITE(6,4)
   4	FORMAT(1x,'setup>> Do you want a cluster member as well (y/n)? :'$)
C	READ(5,5)ans4
   5	FORMAT(a1)
	IF(ans4.eq.'y'.or.ans4.eq.'Y')THEN
             is_member=.true.
	   ELSE
	     is_member=.false.
	   ENDIF

	IF(is_member)THEN
	     PRINT *,' '
	     WRITE(6,6)
   6         FORMAT(1x,'setup>> Supply the member position (x,y,z) : '$)
	     READ(5,*)x_member,y_member,z_member
	     WRITE(6,7)
   7	     FORMAT(1x,'setup>>            member luminous mass    : '$)
             READ(5,*)lum_mass_member
             WRITE(6,8)
   8         FORMAT(1x,'setup>>            member half-light radius: '$)
	     READ(5,*)re_member
	   ELSE
	     x_member=0.
	     y_member=0.
	     z_member=0.
	     re_member=0.
	     lum_mass_member=0.
	   ENDIF

	PRINT *,' '

	WRITE(6,9)
   9	FORMAT(1x,'setup>> Supply the filament galaxy luminous mass : '$)
	READ(5,*)lum_mass_filgal
	WRITE(6,10)
  10	FORMAT(1x,'setup>> Filament galaxy half-light radius  : '$)
	READ(5,*)re_filgal
	WRITE(6,11)
  11	FORMAT(1x,'setup>> Distance of the filament ',
     1	'galaxy from the centre : '$)
	READ(5,*)r_filgal

	IF(r_filgal.ge.outer_radius_cluster)THEN
	     contained_cluster_mass=total_mass_cluster
           ELSE
             ratio1=r_filgal/core_radius_cluster
	     contained_cluster_mass=4.*pi*rho_0_cluster*
     1	core_radius_cluster**3*(ratio1-atan(ratio1))
	   ENDIF
	contained_mass=contained_cluster_mass*unit_mass
	PRINT *,'setup>---> Cluster mass inside radius : ',contained_mass

	PRINT *,' '
	WRITE(6,12)
  12	FORMAT(1x,'setup>> Filament galaxy orbit : c,p,e : ? : '$)
	READ(5,5)orbit_type
	IF(orbit_type.eq.'e')THEN
	     WRITE(6,13)
  13	     FORMAT(1x,'setup>> fraction of circular energy : '$)
	     READ(5,*)e_fraction
	   ELSEIF(orbit_type.eq.'p')THEN
	     WRITE(6,20)
  20         FORMAT(1x,'setup>> approximate peri-distance : '$)
	     READ(5,*)peri_distance
 	   ENDIF

	PRINT *,' '
	WRITE(6,14)
  14	FORMAT(1x,'setup>> Number of particles in filament galaxy : '$)
	READ(5,*)nbodies

	PRINT *,' '
	PRINT *,'setup>> Beginning Setup << '

C	CALL gen_filgal(nbodies,re_filgal,lum_mass_filgal,
C    &                  gamma_halo,extent,xp,yp,zp,vxp,vyp,vzp)
	CALL gen_plumgal(nbodies,re_filgal,lum_mass_filgal,
     &                  gamma_halo,extent,xp,yp,zp,vxp,vyp,vzp)

	header(1)=nbodies
	header(2)=1
	header(3)=0
	header(6)=G
	model=1

C	CALL nuwrite(model,model_file,header,xp,yp,zp,vxp,vyp,vzp,
C     &               pmass)

	OPEN(unit=11,file=model_file,status='unknown',form='unformatted')
	WRITE(11)nbodies
C Write iteration,time
	it0=1
	time0=0.
	WRITE(11)it0,time0
	DO i=1,nbodies
	   WRITE(11)i,xp(i),yp(i),zp(i),vxp(i),vyp(i),vzp(i)
	ENDDO
	CLOSE(unit=11)

 	OPEN (unit=10,file=params_file,status='unknown')
	WRITE(10,*)sigma_cluster,core_radius_cluster,outer_radius_cluster
	WRITE(10,*)is_member
	WRITE(10,*)x_member,y_member,z_member
	WRITE(10,*)lum_mass_member,re_member
	WRITE(10,*)nbodies,lum_mass_filgal
	WRITE(10,*)re_filgal,gamma_halo,extent
        WRITE(10,*)r_filgal
	WRITE(10,*)orbit_type
	WRITE(10,*)e_fraction,peri_distance
	CLOSE(unit=10)

	PRINT *,' '
	PRINT *,'setup>> All done <<'
	PRINT *,' '

	END

C***************************************************************************
C
C	Subroutine to generate the filament galaxy as a simple
C	Plummer sphere of particles in a Plummer field plus
C       a modified isothermal halo.
C
C Input :
C nbodies
C re_filgal
C lum_mass_filgal
C extent
C
C Output:
C gamma_halo
C xp,yp,zp
C vxp,vyp,vzp
C
C***************************************************************************

	SUBROUTINE gen_filgal(nbodies,re_filgal,lum_mass_filgal,
     &                        gamma_halo,extent,xp,yp,zp,vxp,vyp,vzp)

	PARAMETER (max_bodies=20000)
	PARAMETER (rmax_factor=3.)
 	PARAMETER (scale=3.)
	PARAMETER (G=1.,unit_vel=976.6,unit_mass=2.217e+11)

	DIMENSION xp(1),yp(1),zp(1)
	DIMENSION vxp(1),vyp(1),vzp(1)
	DIMENSION radius(max_bodies)
	DIMENSION potential(max_bodies)

	REAL lum_mass_filgal,lum_mass_filgal_scaled

	iseed=1234567
	pi=2.*asin(1.)
	rmax=rmax_factor*re_filgal

C Random generation of the positions:
	n=0
	count=0
  10    r_3=ran(iseed)*rmax**3
        r=r_3**0.3333333
	f_r=1./(1.+(r/re_filgal)**2)**2.5
	a_num=ran(iseed)
	IF(a_num.gt.f_r)GOTO 10

	n=n+1
	count=count+1
C Random generation of phi (0. to 2*pi)
C and theta (projection uniform between -1. and 1.)
         cos_theta=(0.5-ran(iseed))*2.
        phi=2.*pi*ran(iseed)
	sin_theta=sqrt(1.-cos_theta*cos_theta)
	radius(n)=r
	xp(n)=r*sin_theta*cos(phi)
	yp(n)=r*sin_theta*sin(phi)
	zp(n)=r*cos_theta
	IF(mod(n,500).eq.0)THEN
	   PRINT *,'....',n
	   count=0
	   ENDIF
	IF(n.lt.nbodies)GOTO 10

	PRINT *,' '
	PRINT *,'gen_filgal>>',nbodies,' Particles set up <<'

C Recentrering the centre of mass to (0,0,0)
 	CALL  cmt_x(nbodies,xp,yp,zp,radius)

C Computing the central velocity dispersion :
	gamma_halo=scale*re_filgal
	lum_mass_filgal_scaled=lum_mass_filgal/unit_mass
	v_dispersion_filgal=sqrt(pi*G*lum_mass_filgal_scaled/
     &                          (32.*re_filgal))
	rho_0_halo=v_dispersion_filgal**2/(2.*pi*G*gamma_halo**2)
	r_chi=extent*gamma_halo
	halo_mass=4.*pi*rho_0_halo*gamma_halo**3*
     &               ((r_chi/gamma_halo)-atan(r_chi/gamma_halo))
	halo_mass_unscaled=halo_mass*unit_mass
	ratio_masses=halo_mass/lum_mass_filgal_scaled
	rscale=r_chi/gamma_halo
	v_dispersion_unscaled=v_dispersion_filgal*unit_vel

	PRINT *,' '
	PRINT *,'gen_filgal>---> filament galaxy velocity dispersion : ',
     &                        v_dispersion_unscaled
	PRINT *,'gen_filgal>---> extent of halo around filament galaxy : ',
     &                        r_chi
	PRINT *,'gen_filgal>---> total halo mass : ',halo_mass_unscaled
	PRINT *,' '

C Random generation of the velocities: (v_dispersion_filgal)
C Initializes the Gaussian NAG random generator:
C	 call g05cbf(0)
	 call jlp_random_init(1)

	DO i=1,nbodies
c	   IF(radius(i).gt.r_chi)THEN
c	      phi_halo=-G*halo_mass/radius(i)
c	      ELSE
c	      r1=radius(i)/gamma_halo
c	      t1=(1./r1)*atan(r1)-1.
c	      t2=0.5*alog((1.+r1*r1)/(1.+rscale*rscale))
c	      t3=halo_mass/(gamma_halo*(rscale-atan(rscale)))
c	      phi_halo=G*t3*(t2+t1)
c	      ENDIF
	    phi_filgal=-G*lum_mass_filgal_scaled
     &                  /sqrt((radius(i)**2+re_filgal**2))

	    phi_total=phi_filgal
C	    phi_total=phi_halo+phi_filgal
	    v_total=sqrt(abs(phi_total))

C Gaussian NAG random generator :
C (sigma decreasing linearily with the distance)
	    sigma=v_dispersion_filgal
     1	*(gamma_halo-radius(i))/gamma_halo
	    sigma=max(0.,sigma)
C	    v_total=g05ddf(dble(v_total),dble(sigma))
	    call jlp_random_gauss(work)
            v_total=v_total+sigma*work

C!! Not necessary since there is already a dispersion in the velocities
C (from the angular random distribution)

	    phi=2.*pi*ran(iseed)
	    cos_theta=(0.5-ran(iseed))*2.
	    sin_theta=sqrt(1.-cos_theta**2)
	    vxp(i)=v_total*sin_theta*cos(phi)
	    vyp(i)=v_total*sin_theta*sin(phi)
	    vzp(i)=v_total*cos_theta
	    ENDDO

C Setting the mean velocity to (0,0,0)
	CALL cmt_v(nbodies,vxp,vyp,vzp)

	RETURN
	END

C*************************************************************************
C
C	Subroutine to transform to center of mass coordinates
C			in space.
C
C*************************************************************************

	SUBROUTINE cmt_x(nbodies,xp,yp,zp,radius)

	DIMENSION xp(1),yp(1),zp(1),radius(1)

	xsum=0.
	ysum=0.
	zsum=0.

	DO i=1,nbodies
	   xsum=xsum+xp(i)
	   ysum=ysum+yp(i)
	   zsum=zsum+zp(i)
	   ENDDO

	xcm=xcm/float(nbodies)
	ycm=ycm/float(nbodies)
	zcm=zcm/float(nbodies)

	DO i=1,nbodies
	   xp(i)=xp(i)-xcm
	   yp(i)=yp(i)-ycm
	   zp(i)=zp(i)-zcm
	   radius(i)=sqrt(xp(i)*xp(i)+yp(i)*yp(i)+zp(i)*zp(i))
	   ENDDO

	PRINT *,' '
	PRINT *,'cmt_x>> CMT in x complete <<'

	RETURN
	END

C*************************************************************************
C
C	Subroutine to transform to center of mass coordinates
C			in velocity
C
C*************************************************************************

	SUBROUTINE cmt_v(nbodies,vxp,vyp,vzp)

	DIMENSION vxp(1),vyp(1),vzp(1)

	vxsum=0.
	vysum=0.
	vzsum=0.

	DO i=1,nbodies
	   vxsum=vxsum+vxp(i)
	   vysum=vysum+vyp(i)
	   vzsum=vzsum+vzp(i)
	   ENDDO

	vxcm=vxcm/float(nbodies)
	vycm=vycm/float(nbodies)
	vzcm=vzcm/float(nbodies)

	DO i=1,nbodies
	   vxp(i)=vxp(i)-vxcm
	   vyp(i)=vyp(i)-vycm
	   vzp(i)=vzp(i)-vzcm
	   ENDDO

	PRINT *,' '
	PRINT *,'cmt_v>> CMT in v complete <<'
	PRINT *,' '

	RETURN
	END

C*******************************************************************
C
C     A SUBROUTINE TO WRITE UNFORMATTED DATA TO A FILE
C     WHERE MORE THAN ONE RECORD CAN BE USED PER MODEL.
C     model specifies the model to be written and the particles
C     are loaded into records irecsize at a time
C
C*******************************************************************

C      header(1)=number particles
C      header(2)=it
C      header(3)=tt
C      header(4)=etot
C      header(5)=am
C      header(8)=g (Newton's constant)
C      header(9)=epsilon (kpc)

      SUBROUTINE nuwrite(model,infile,header,x,y,z,vx,vy,vz,pmass)

      DIMENSION X(1),Y(1),Z(1),VX(1),VY(1),VZ(1)
      DIMENSION header(1),pmass(1)
      CHARACTER*40 infile
      INTEGER extend,records

      PARAMETER (irecsize=128)
      PARAMETER (nobytes=1)
      PARAMETER (lu=10)
      PARAMETER (ibig=8000000)

c     nobytes = 8 CRAY
c     nobytes = 4 VAX UNIX
c     nobytes = 1 VAX VMS

c     LANL specific :

c     ibig is necessary for the CFT call to FAMSIZ
c     which sets the size of the direct access file in
c     words.

      LOGICAL tail

      ISIZE=(7*irecsize)*nobytes
      tail=.false.

      OPEN(unit=lu,file=infile,status='unknown',
     &      access='direct',recl=isize)

C     CALL famsiz(lu,ibig)

      n=header(1)
      numrec=n/irecsize + 1
      remain=(float(n)/float(irecsize)) -  n/irecsize
      IF(remain.ne.0)THEN
         numrec=numrec+1
         tail=.true.
         END IF
      ireci=(model-1)*numrec+1
      irec=ireci
      i=1
      extend=irecsize
      WRITE(lu,rec=irec)(header(j),j=1,irecsize)
      irec=irec+1
      DO 10 j=2,numrec
         IF(j.eq.numrec)THEN
            IF(tail)THEN
               extend=n-(numrec-2)*irecsize
               END IF
            END IF
         k1=i
         k2=i+extend-1
         WRITE(lu,rec=irec)(x(l),y(l),z(l),vx(l),vy(l),vz(l)
     &                  ,pmass(l),l=k1,k2)
         i=i+extend
         irec=irec+1
  10     CONTINUE
      CLOSE(unit=lu)
      IF(tail)THEN
         records=numrec-2
         WRITE(6,100)records,irecsize,extend,model,infile
 100     FORMAT(1x,'nuwrite>> Writing ',i3,'*',i4,'+',i4,
     & ' particles into model ',i3,' of file :',a40)
         ELSE
         records=numrec-1
         WRITE(6,200)records,irecsize,model,infile
 200     FORMAT(1x,'nuwrite>> Writing ',i3,'*',i4,
     & ' particles into model ',i3,' of file :',a40)
         END IF
      RETURN
      END

C***************************************************************************
C
C Subroutine to generate the filament galaxy as a simple
C	Plummer sphere of particles in a Plummer field
C
C Input :
C nbodies
C re_filgal
C lum_mass_filgal
C extent
C
C Output:
C gamma_halo
C xp,yp,zp
C vxp,vyp,vzp
C
C***************************************************************************

	SUBROUTINE gen_plumgal(nbodies,re_filgal,lum_mass_filgal,
     &                        gamma_halo,extent,xp,yp,zp,vxp,vyp,vzp)

	PARAMETER (max_bodies=20000)
	PARAMETER (rmax_factor=3.)
 	PARAMETER (scale=3.)
	PARAMETER (G=1.,unit_vel=976.6,unit_mass=2.217e+11)

	DIMENSION xp(1),yp(1),zp(1)
	DIMENSION vxp(1),vyp(1),vzp(1)
	DIMENSION radius(max_bodies)
	DIMENSION potential(max_bodies)

	real lum_mass_filgal,lum_mass_filgal_scaled
        real v_total, work

	iseed=1234567
	pi=2.*asin(1.)
	rmax=rmax_factor*re_filgal

C Random generation of the positions:
	n=0
	count=0
  10    r_3=ran(iseed)*rmax**3
        r=r_3**0.3333333
	f_r=1./(1.+(r/re_filgal)**2)**2.5
	a_num=ran(iseed)
	IF(a_num.gt.f_r)GOTO 10

	n=n+1
	count=count+1
C Random generation of phi (0. to 2*pi)
C and theta (projection uniform between -1. and 1.)
         cos_theta=(0.5-ran(iseed))*2.
        phi=2.*pi*ran(iseed)
	sin_theta=sqrt(1.-cos_theta*cos_theta)
	radius(n)=r
	xp(n)=r*sin_theta*cos(phi)
	yp(n)=r*sin_theta*sin(phi)
	zp(n)=r*cos_theta
	IF(mod(n,500).eq.0)THEN
	   PRINT *,'....',n
	   count=0
	   ENDIF
	IF(n.lt.nbodies)GOTO 10

	PRINT *,' '
	PRINT *,'gen_filgal>>',nbodies,' Particles set up <<'

C Recentrering the centre of mass to (0,0,0)
 	CALL  cmt_x(nbodies,xp,yp,zp,radius)

C Computing the central velocity dispersion :
	gamma_halo=scale*re_filgal
	lum_mass_filgal_scaled=lum_mass_filgal/unit_mass
	v_dispersion_filgal=sqrt(pi*G*lum_mass_filgal_scaled/
     &                          (32.*re_filgal))
	rho_0_halo=v_dispersion_filgal**2/(2.*pi*G*gamma_halo**2)
	r_chi=extent*gamma_halo
	halo_mass=4.*pi*rho_0_halo*gamma_halo**3*
     &               ((r_chi/gamma_halo)-atan(r_chi/gamma_halo))
	halo_mass_unscaled=halo_mass*unit_mass
	ratio_masses=halo_mass/lum_mass_filgal_scaled
	rscale=r_chi/gamma_halo
	v_dispersion_unscaled=v_dispersion_filgal*unit_vel

	PRINT *,' '
	PRINT *,'gen_filgal>---> filament galaxy velocity dispersion : ',
     &                        v_dispersion_unscaled
	PRINT *,'gen_filgal>---> extent of halo around filament galaxy : ',
     &                        r_chi
	PRINT *,'gen_filgal>---> total halo mass : ',halo_mass_unscaled
	PRINT *,' '

C When stability=1. the particle velocity is set to the escape velocity
	PRINT *,' '
	PRINT *,'gen_filgal>---> stability factor  (10?) : '
	READ(5,*) stability_factor

C Random generation of the velocities: (v_dispersion_filgal)
C (Gaussian NAG random generator):
C	 call g05cbf(0)
	 call jlp_random_init(1)

	DO i=1,nbodies
	    phi_filgal=-G*lum_mass_filgal_scaled
     &                  /sqrt(radius(i)**2+re_filgal**2)

	    v_total=sqrt(abs(phi_filgal))/stability_factor

C Gaussian NAG random generator :
C (sigma decreasing linearily with the distance)
	    sigma=v_dispersion_filgal
     1	*(gamma_halo-radius(i))/gamma_halo
	    sigma=max(0.,sigma)
C	    v_total=g05ddf(dble(v_total),dble(sigma))
	    call jlp_random_gauss(work)
            v_total=v_total+sigma*work

C@@@ JLP JUNE 1989
C!!Old comment from P. Quinn:
C!! Not necessary since there is already a dispersion in the velocities
C!! (from the angular random distribution)

	    phi=2.*pi*ran(iseed)
	    cos_theta=(0.5-ran(iseed))*2.
	    sin_theta=sqrt(1.-cos_theta**2)
	    vxp(i)=v_total*sin_theta*cos(phi)
	    vyp(i)=v_total*sin_theta*sin(phi)
	    vzp(i)=v_total*cos_theta
	    ENDDO

C Setting the mean velocity to (0,0,0)
	CALL cmt_v(nbodies,vxp,vyp,vzp)

	RETURN
	END


      SUBROUTINE main_vector_cairn
      USE global
      INTEGER  ::IC

! === Main Loop =======================================================
      DO 99 J = 1, NTIME

!---- Computation of parameter at integral time steps -----------------
      CALL FD4n(VX(1,:), FD0(1,:))
      CALL FD4n(NI(1,:), FD1(1,:))
      CALL FD4n(PH(1,:), FD2(1,:))

      DO 17 IC = 3, NXP2
         NI(2,IC) = NI(2,IC) - DT*(NI(1,IC)*FD0(1,IC)+ VX(1,IC) &
     &   *FD1(1,IC))
         VX(2,IC) = VX(2,IC) - DT*(VX(1,IC)*FD0(1,IC) + FD2(1,IC))
   17 CONTINUE

!---- Boundary condition -------
      NI(2,1)      = NI(2,NXP1)
      NI(2,2)      = NI(2,NXP2)
      NI(2,NXP3)   = NI(2,3)
      NI(2,NXP4)   = NI(2,4)
!
      VX(2,1)      = VX(2,NXP1)
      VX(2,2)      = VX(2,NXP2)
      VX(2,NXP3)   = VX(2,3)
      VX(2,NXP4)   = VX(2,4)
!---- FILTERING -------------------------------------------------------
      CALL FILTERn(NI(2,:))
      CALL FILTERn(VX(2,:))
!---- Giving initla value ---------------------------------------------
      PH(2,:) = PH(1,:)
! --- Poisson solveer -------------------------------------------------
      CALL POISSON_SOL_CAIRN(PH(2,:), NI(2,:))
!---- FILTERING -------------------------------------------------------
      CALL FILTERn(PH(2,:))
!
!---- Computation of parameter at HALF integral time steps ------------
      CALL FD4n(VX(2,:), FD0(1,:))
      CALL FD4n(NI(2,:), FD1(1,:))
      CALL FD4n(PH(2,:), FD2(1,:))
!
      DO 20 IC = 3, NXP2
         NI(1,IC) = NI(1,IC) - DT*(NI(2,IC)*FD0(1,IC) + VX(2,IC) &
     &    *FD1(1,IC))
         VX(1,IC) = VX(1,IC) - DT*(VX(2,IC)*FD0(1,IC) + FD2(1,IC))
   20 CONTINUE
!---- Boundary condition -------
      NI(1,1)      = NI(1,NXP1)
      NI(1,2)      = NI(1,NXP2)
      NI(1,NXP3)   = NI(1,3)
      NI(1,NXP4)   = NI(1,4)
!
      VX(1,1)      = VX(1,NXP1)
      VX(1,2)      = VX(1,NXP2)
      VX(1,NXP3)   = VX(1,3)
      VX(1,NXP4)   = VX(1,4)
!
!---- FILTERING -------------------------------------------------------
      CALL FILTERn(NI(1,:))
      CALL FILTERn(VX(1,:))
!---- Giving initla value ---------------------------------------------
      PH(1,:) = PH(2,:)
!
      CALL POISSON_SOL_CAIRN(PH(1,:), NI(1,:))
!---- FILTERING -------------------------------------------------------
      CALL FILTERn(PH(1,:))

      IF (MOD(J,TIDATA)==0) THEN
      CALL datawriting
      END IF

   99 CONTINUE

      END SUBROUTINE main_vector_cairn


!==============================================================================!
  subroutine Numerics_Mod_Advection_Scheme(phi_f,                &
                                           s,                    &
                                           phi,                  &
                                           phi_i, phi_j, phi_k,  &
                                           di, dj, dk,           &
                                           flux)
!------------------------------------------------------------------------------!
!   Computes the value at the cell face using different convective  schemes.   !
!   In this subroutine I try to follow the nomenclature from Basara's and      !
!   Przulj's AIAA paper.                                                       !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  real           :: phi_f, phi_f_c, phi_f_u
  integer        :: s
  type(Var_Type) :: phi
  real           :: phi_i(-phi % pnt_grid % n_bnd_cells:  &
                           phi % pnt_grid % n_cells),     &
                    phi_j(-phi % pnt_grid % n_bnd_cells:  &
                           phi % pnt_grid % n_cells),     &
                    phi_k(-phi % pnt_grid % n_bnd_cells:  &
                           phi % pnt_grid % n_cells)
  real           :: di(phi % pnt_grid % n_faces),  &
                    dj(phi % pnt_grid % n_faces),  &
                    dk(phi % pnt_grid % n_faces)
  real           :: flux(phi % pnt_grid % n_faces)
!-----------------------------------[Locals]-----------------------------------!
  type(Grid_Type), pointer :: grid
  integer                  :: c1, c2, c, d
  real                     :: fj ! flow oriented interpolation factor
  real                     :: g_d, g_u, alfa, beta1, beta2
  real                     :: phij, phi_u, phi_star, rj, sign, gamma_c, beta
!==============================================================================!
!
!               Flux > 0
!   +---------+---------+---------+---------+
!   |         |         |         |         |
!   |         |   c1    |   c2    |         |
!   |    o    |    o  ==s=>  o    |    o    |----> xi
!   |    U    |    c    |    d    |         |
!   |         |         |         |         |
!   +---------+---------+---------+---------+
!
!
!               Flux < 0
!   +---------+---------+---------+---------+
!   |         |         |         |         |
!   |         |   c1    |   c2    |         |
!   |    o    |    o  <=s==  o    |    o    |----> xi
!   |         |    d    |    c    |    U    |
!   |         |         |         |         |
!   +---------+---------+---------+---------+
!
!------------------------------------------------------------------------------!

  ! Take aliases
  grid => phi % pnt_grid

  c1 = grid % faces_c(1,s)
  c2 = grid % faces_c(2,s)

  if(flux(s) > 0.0) then ! goes from c1 to c2
    fj   = 1.0 - grid % f(s)
    c    = c1
    d    = c2
    sign = +1.0
  else ! flux(s) < 0.0   ! goes from c2 to c1
    fj = grid % f(s)
    c    = c2
    d    = c1
    sign = -1.0
  end if

  if(flux(s) > 0.0) then
    phi_star = phi % n(d) - 2.0 * (  phi_i(c)*di(s)   &
                                   + phi_j(c)*dj(s)   &
                                   + phi_k(c)*dk(s) )
  else
    phi_star = phi % n(d) + 2.0 * (  phi_i(c)*di(s)   &
                                   + phi_j(c)*dj(s)   &
                                   + phi_k(c)*dk(s) )
  end if

  phi_u = max( phi % min(c), min(phi_star, phi % max(c)) )

  rj = ( phi % n(c) - phi_u ) / ( phi % n(d)-phi % n(c) + 1.0e-16 )

  g_d = 0.5 * fj * (1.0+fj)
  g_u = 0.5 * fj * (1.0-fj)

  if(phi % adv_scheme .eq. CENTRAL) then
    phij = fj

  else if(phi % adv_scheme .eq. QUICK) then
    rj = ( phi % n(c) - phi_u ) / ( phi % n(d)-phi % n(c) + 1.0e-12 )
    alfa = 0.0
    phij = (g_d - alfa) + (g_u + alfa) * rj

  else if(phi % adv_scheme .eq. LUDS) then
    alfa = 0.5 * fj * (1+fj)
    phij = (g_d - alfa) + (g_u + alfa) * rj

  else if(phi % adv_scheme .eq. MINMOD) then
    phij = fj * max(0.0, min(rj,1.0))

  else if(phi % adv_scheme .eq. SMART) then
    beta1 = 3.0
    beta2 = 1.0
    phij = max( 0.0, min( (beta1-1.0)*rj, g_d+g_u*rj, beta2 ) )

  else if(phi % adv_scheme .eq. AVL_SMART) then
    beta1 = 1.0 + fj*(2.0+fj)
    beta2 = fj*(2.0-fj)
    phij = max( 0.0, min( (beta1-1.0)*rj, g_d+g_u*rj, beta2 ) )

  else if(phi % adv_scheme .eq. SUPERBEE) then
    phij = 0.5 * max( 0.0, min( 2.0*rj,1.0 ), min( rj,2.0 ) )

  else if(phi % adv_scheme .eq. UPWIND) then
    phi_f = phi % n(c)  ! upwind value
    return

  else if(phi % adv_scheme .eq. BLENDED) then
    phi_f_c = phi % n(c) + fj * sign * (phi % n(c2)-phi % n(c1))  ! central part
    phi_f_u = phi % n(c)                                          ! upwind part
    ! Blended value
    phi_f   =        phi % blend  * phi_f_c   &
            + (1.0 - phi % blend) * phi_f_u
    return
  end if

  phi_f = phi % n(c) + phij * sign * (phi % n(c2)-phi % n(c1))

  if(phi % adv_scheme .eq. GAMMA) then
    beta = 0.1

    if(flux(s) > 0.0) then
      phi_star = 1.0 - (phi % n(d) - phi % n(c))/(2.0 * (  phi_i(c)*di(s)   &
                                                         + phi_j(c)*dj(s)   &
                                                         + phi_k(c)*dk(s)))
    else
      phi_star = 1.0 + (phi % n(d) - phi % n(c))/(2.0 * (  phi_i(c)*di(s)   &
                                                         + phi_j(c)*dj(s)   &
                                                         + phi_k(c)*dk(s)))
    end if

    gamma_c = phi_star / beta

    if(phi_star < beta.and.phi_star > 0.0) then
      phi_f = (1.0 - gamma_c*(1.0 - grid % f(s))) * phi % n(c)   &
                   + gamma_c*(1.0 - grid % f(s))  * phi % n(d)
    else if(phi_star < 1.0.and.phi_star >= beta) then
       phi_f =        grid % f(s)  * phi % n(c)  &
             + (1.0 - grid % f(s)) * phi % n(d)
    else
      phi_f = phi % n(c)
    end if
  end if

  end subroutine