      SUBROUTINE DYNFVARS
*
*       Jpetts - Calculate DYNFCOEF et al
*       Recalculate variables used for dynamical friction formula every
*       time parameters are adjusted. Note if one changes the potential
*       one must also update the calculations of BDENS, VDIST and bmax.
*       One must note that the Maxwellian assumption for the velocity
*       distribution underestimates the frictional force for a power law
*       slope shallower than gamma = 0.5. The stalling is also not
*       not correctly captured in constant density cores. A dynamical
*       friction model for cores will be added in the future
*       (see Petts et al 2015 & Petts et al 2016a).
*       ----------------------------------
*
      INCLUDE 'common6.h'
      COMMON/GALAXY/ GMG,RG(3),VG(3),FG(3),FGD(3),TG,
     &               OMEGA,DISK,A,B,V02,RL2,GMB,AR,GAM,ZDUM(7)
      REAL*8 XRA,XRA2,XRA3,XRA4,MASSENC
      REAL*8 RG_RT,DRG_RT,BDENS_RT1,BDENS_RT2,RT_D2PHIDR2
      REAL*8 RT_OMEGA2,RDIST_RT,RTIDE_TEMP, FVSTAR, E_APO, L2_APO, RG_APO
      REAL*8 VESC, FV_VS, FV_ESC
      INTEGER*4 RT_CHECK
*
*
*        Calculate r
      DO 10 K = 1,3
          RGDENS(K) = RG(K) + RDENS(K)
   10 CONTINUE
      RGDENSMAG = SQRT(RGDENS(1)**2.0+RGDENS(2)**2.0+RGDENS(3)**2.0)
*
*       Calculate v
      DO 101 K = 1,3
          VGCORE(K) = VG(K) + VCORE(K)
  101 CONTINUE
      VGCOREMAG = SQRT(VGCORE(1)**2.0+VGCORE(2)**2.0+VGCORE(3)**2.0)

*       Calculate the coulomb logarithm.
*     ----Calculate bmax = min((rho/[drho/dr]),r)
      COULOG = min(RGDENSMAG*(RGDENSMAG+AR)/(AR*GAM + 4.d0*RGDENSMAG)
     &     ,RGDENSMAG)
*     ----Calculate bmin = max(R_hm, G*M_s/V_s**2)
      COULOG = COULOG/max(RSCALE,MASSCL/VGCOREMAG**2)
      COULOG = log(COULOG)
*
*       Calculate the local background density.
      BDENS = ((3.0-GAM)*GMB*AR)/(4.0*ONEPI)
      BDENS = BDENS/(RGDENSMAG**GAM)
      BDENS = BDENS/((RGDENSMAG+AR)**(4.0-GAM))

***********************Calculate f(v*<vs)******************************
* If gamma = 0.0, integrate the self-consistent velocity distribution,
* as the Maxwellian approximation of the velocity distribution is inaccurate
* at ~< 0.5 a. for gam >= 0.5 the Maxwellian approximation is accurate
* within ~10%, and is employed for speed of calculation.
*
********Calculate the local velocity dispersion*************************
*
*  Included here is the general velocity disperion profile for a Dehnen
*  model with (or without) a central point mass black hole. The
*  derivation is general in that it allows one to use any SMBH/
*  background mass ratio, any slope gamma and any scale radius. The
*  functions f(x,gam) and h(x,gam) must be pre-calculated and included
*  in the code. gam = 0.5,1.0, 1.5, 1.75 and 2.0 are included by
*  default. Adding another value of gamma is straightforward and described
*  in the README.
*
*  The presence of a SMBH is optional, setting GMG to 0.0 in the
*  input file will ommit a SMBH.
*
*  One needs to derive the velocity disperion profile of the
*  background distribution themselves if they want to use a density
*  distribution other than a Dehnen model. The functions f(x,gam) and h(x,gam)
*  are only analytic when 4*gamma is an integer.
*
*
*  V_r^2(r) = ((GMB/a)*(x+1)^(4-gam)) * (f(x,gam)  + mu*h(x,gam))
*
*  where:       x = r/a,                 f(x,gam) = BVDISPBULGE
*               h(x,gam) = BVDISPBH      mu = GMG/GMB
*
************************************************************************
      XRA = RGDENSMAG/AR
      XRA2 = XRA**2.d0
      XRA3 = XRA**3.d0
      XRA4 = XRA**4.d0

*
*     ----select apropriate calculated pre-calculated integrals
      IF(GAM == 0.0) THEN
         IF (GMG .ne. 0.0) THEN
            WRITE(6,*) "No isotropic solution for gamma = 0.0 + BH."
            WRITE(6,*) "See Antonnini+ 2012"
            STOP
         END IF
         !Calculate the self consistent f(v*<vs)
         GO TO 4

      ELSE IF(GAM == 0.25) THEN
         IF (GMG .ne. 0.0) THEN
            WRITE(6,*) "No isotropic solution for gamma = 0.25 + BH."
            WRITE(6,*) "See Antonnini+ 2012"
            STOP
         END IF

         BVDISPBULGE = 0.0005772005772d0*XRA**(3.d0/4.d0) * (128.d0*XRA4
     &        + 704.d0*XRA3 + 1584.d0*XRA2 + 1848.d0*XRA + 1155.d0)
     &        *(XRA/(XRA+1.d0))**(3.d0/4.d0)
     &        /(XRA+1.d0)**(19.d0/4.d0)

         BVDISPBH = 0.0

      ELSE IF(GAM == 0.5) THEN
          BVDISPBULGE = 0.2d0/(1.d0+XRA)**5.d0
*
*
          BVDISPBH = (0.1333333333d0*(128.d0*XRA**(3.d0/2.d0)*(1.d0+XRA)
     &    **(5.d0/2.d0)-128.d0*XRA4-320.d0*XRA3-240.d0*XRA2-40.d0*XRA
     &    +5.d0))/(XRA**(3.d0/2.d0)*(1.d0+XRA)**(5.d0/2.d0))
*
*     ----multiply by mu
          BVDISPBH = BVDISPBH*(GMG/GMB)
      ELSE IF(GAM == 1.0) THEN
          BVDISPBULGE = (1.d0/12.d0)*(-12.d0*XRA3-25.d0+12.d0*
     &    log(XRA+1.d0)-12.d0*log(XRA)-52.d0*XRA-42.d0*XRA2+12.d0*
     &    log(XRA+1.d0)*XRA4-12.d0*log(XRA)*XRA4+48.d0*log(XRA+1.d0)
     &    *XRA3-48.d0*log(XRA)*XRA3+72.d0*log(XRA+1.d0)*XRA2-72.d0*
     &    log(XRA)*XRA2+48.d0*log(XRA+1.d0)*XRA-48.d0*log(XRA)*XRA)/
     &    (XRA4+4.d0*XRA3+6*XRA2+4.d0*XRA+1.d0)
*
*
          BVDISPBH = -(1.d0/2.d0)*(12.d0*log(XRA)*XRA4-12.d0*
     &    log(XRA+1.d0)*XRA4+24.d0*log(XRA)*XRA3-24.d0*log(XRA+1.d0)*
     &    XRA3+12.d0*log(XRA)*XRA2-12.d0*log(XRA+1.d0)*XRA2+12.d0*XRA3+
     &    18.d0*XRA2+4.d0*XRA-1.d0)/(XRA2*(XRA2+2.d0*XRA+1.d0))
*
*     ----multiply by mu
          BVDISPBH = BVDISPBH*(GMG/GMB)
      ELSE IF(GAM == 1.5) THEN
          BVDISPBULGE = -(0.3333333333d0*(-3.d0-12.d0*XRA3+12.d0*
     &    log(1.d0+XRA)*XRA4-12.d0*log(XRA)*XRA4+36.d0*log(1.d0+XRA)
     &    *XRA3-36.d0*log(XRA)*XRA3+36.d0*log(1.d0+XRA)*XRA2-36.d0*
     &    log(XRA)*XRA2+12.d0*log(1.d0+XRA)*XRA-12.d0*log(XRA)*XRA-
     &    30.d0*XRA2-22.d0*XRA))/((1.d0+XRA)**3*XRA)
*
*
          BVDISPBH = -(0.1333333333d0*(128.d0*XRA**(5.d0/2.d0)*
     &    (1.d0+XRA)**(3.d0/2.d0)-128.d0*XRA4-192.d0*XRA3-48.d0*XRA2+
     &    8.d0*XRA-3.d0))/(XRA**(5.d0/2.d0)*(1.d0+XRA)**(3.d0/2.d0))
*
*     ----multiply by mu
          BVDISPBH = BVDISPBH*(GMG/GMB)
      ELSE IF(GAM == 1.75) THEN
          BVDISPBULGE = (0.1333333333d0*(128.d0*XRA**(3.d0/4.d0)*
     &    (1.d0+XRA)**(7.d0/4.d0)*(XRA*(1.d0+XRA))**(3.d0/4.d0)-128.d0
     &    *XRA4-320.d0*XRA3-240.d0*XRA2-40.d0*XRA+5.d0))/
     &    (XRA**(3.d0/4.d0)*(1.d0+XRA)**(7.d0/4.d0)*(XRA*(1.d0+XRA))
     &    **(3.d0/4.d0))
*
*
          BVDISPBH = -(0.01038961039d0*(2048.d0*XRA**(11.d0/4.d0)*
     &    (1.d0+XRA)**(5.d0/4.d0)-2048.d0*XRA4-2560.d0*XRA3-320.d0*XRA2
     7    +80.d0*XRA-35.d0))/(XRA**(11.d0/4.d0)*(1.d0+XRA)**(5.d0/4.d0))
*
*     ----multiply by mu
          BVDISPBH = BVDISPBH*(GMG/GMB)
      ELSE IF(GAM == 2.0) THEN
          BVDISPBULGE = (0.5000000000d0*(1.d0-12.d0*XRA3-18.d0*XRA2+
     &    12.d0*log(1.d0+XRA)*XRA4-12.d0*log(XRA)*XRA4+24.d0*
     &    log(1.d0+XRA)*XRA3-24.d0*log(XRA)*XRA3+12.d0*log(1.d0+XRA)*
     &    XRA2-12.d0*log(XRA)*XRA2-4.d0*XRA))/
     &    (XRA2*(XRA2+2.d0*XRA+1.d0))
*
*
          BVDISPBH = -(1.d0/3.d0)*(-1.d0-6.d0*XRA2+12.d0*log(XRA+1.d0)*
     &    XRA4-12.d0*log(XRA)*XRA4+12.d0*log(XRA+1.d0)*XRA3-12.d0*
     &    log(XRA)*XRA3-12.d0*XRA3+2.d0*XRA)/((XRA+1.d0)*XRA3)
*
*     ----multiply by mu
          BVDISPBH = BVDISPBH*(GMG/GMB)
      ELSE
          write(6,*) "f(x,gamma) and h(x,gamma) functions not defined"
          write(6,*) "for gamma =", GAM,". These needed to be added to"
          write(6,*) "dynfvars.f. Please consult the README file."
          stop
      END IF
*
*
      BVDISP = ((GMB/AR)*(XRA**GAM)*(XRA+1.d0)**(4.d0-GAM))*
     &        (BVDISPBULGE+BVDISPBH)
      BVDISP = SQRT(BVDISP)
*
*     ----Calcuate BRATIO for BDIST
      BRATIO = VGCOREMAG/(SQRT(2.0)*BVDISP)
*
*       Calculate fraction of stars with V*<VCORE for Gamma > 0.0
      BDIST = erf(BRATIO) - (2.0*BRATIO/SQRT(ONEPI))*exp(-(BRATIO**2.0))

*     --for gamma = 0 integrate the true distribution function.
    4 IF (GAM == 0.0) THEN

         !Calculate vesc
         VESC = sqrt(2.d0*(GMB/AR)*(1.d0/(2.d0-GAM))*
     &         ( 1.d0 - (RGDENSMAG/(RGDENSMAG+AR))**(2.d0-GAM)))

         !integrate f(v) from 0 to vs (Trapezium rule)
         FV_VS = 0.d0
         do I = 1,999
            FVSTAR = 1d-12 + ((VGCOREMAG-2d-12)*real(I)/1000.0)
            FV_VS = FV_VS + 2.0*fv(FVSTAR)
         end do
         FVSTAR = 1d-12
         FV_VS = FV_VS + fv(FVSTAR)
         VSTAR = VGCOREMAG-1d-12
         FV_VS = FV_VS + fv(FVSTAR)

         FV_VS = FV_VS * ((VGCOREMAG-2d-12)/1000.0)/2.0

         !integrate f(v) from 0 to vesc (Trapezium rule)
         FV_ESC = 0.d0
         do I = 1,999
            FVSTAR = VGCOREMAG+1d-12 + ((VESC-VGCOREMAG-2d-12)*real(I)
     &               /1000.0)
            FV_ESC = FV_ESC + 2.0*fv(FVSTAR)
         end do
         FVSTAR = VGCOREMAG + 1d-12
         FV_ESC = FV_ESC + fv(FVSTAR)
         FVSTAR = VESC-1d-12
         FV_ESC = FV_ESC + fv(FVSTAR)

         FV_ESC = FV_ESC * ((VESC-VGCOREMAG-2.0d-12)/1000.0)/2.0

         !calc BDIST = f(v)_vs/ f(v)_vesc
         BDIST = FV_VS/(FV_VS+FV_ESC)
         write(205,*) RGDENSMAG, BDIST

      END IF
*
*

*
*        Calculate VDOT for dynfri calc

      DO 1 K = 1,3
          IF (TTOT >= DTADJ) THEN
              VDOT(K) = (VGCORE(K) - VPREV(K))  /  (TTOT - DYNFTPREV)
          END IF
          VPREV(K) = VGCORE(K)
    1 CONTINUE
      DYNFTPREV = TTOT

*       Jpetts- calculate tidal radius, itterate and update membership

*       Jpetts - Asume Dehnen profile
      RG_RT = RGDENSMAG
      RT_D2PHIDR2 = -AR*((RG_RT/(RG_RT+AR))**(-GAM))
     &            *(AR*GAM - AR + 2.0*RG_RT)
      RT_D2PHIDR2 = RT_D2PHIDR2/(AR+RG_RT)**4
      RT_D2PHIDR2 = RT_D2PHIDR2*GMB/AR
      RT_OMEGA2 = (GMB*(RG_RT/(RG_RT+AR))**(3.0-GAM))/RG_RT**3

      !take 90% (arbitrarily) of old mass as starting point
      RTIDE_TEMP = (0.9*MASSCL/(RT_OMEGA2-RT_D2PHIDR2))**(1.0/3.0)
      MASSCL = 0.0
      NBOUND = 0
      DO 12 I = IFIRST,NTOT
         BOUND(I) = 0
 12   CONTINUE

      DO 2 I = IFIRST,NTOT
         RDIST_RT = SQRT((X(1,I)-RDENS(1))**2 +
     &      (X(2,I)-RDENS(2))**2 + (X(3,I)-RDENS(3))**2)
         IF (RDIST_RT < RTIDE_TEMP) THEN
            BOUND(I) = 1
            NBOUND = NBOUND + 1
            MASSCL = MASSCL + BODY(I)
         END IF
    2 CONTINUE

      DO 3
        RTIDE_TEMP = (MASSCL/(RT_OMEGA2-RT_D2PHIDR2))**(1.0/3.0)
        RT_CHECK = 0
        DO 31 I = IFIRST,NTOT
            RDIST_RT = SQRT((X(1,I)-RDENS(1))**2 +
     &      (X(2,I)-RDENS(2))**2 + (X(3,I)-RDENS(3))**2)
            IF (RDIST_RT < RTIDE_TEMP .and. BOUND(I)==0) THEN
                BOUND(I) = 1
                NBOUND = NBOUND + 1
                MASSCL = MASSCL + BODY(I)
                RT_CHECK = 1
            END IF
   31 CONTINUE

      IF (RT_CHECK == 0) EXIT

    3 CONTINUE

*     ----Calculate the dynamical friction coeffecient - zero in stalling state

* ----- Calculate apocentre -----
*

      !Check not at apocentre
      if ((((RGDENS(1)*VGCORE(1)) + (RGDENS(2)*VGCORE(2)) +
     &      (RGDENS(3)*VGCORE(3))) .eq. 0.d0) .AND.
     &  (VGCOREMAG .le. sqrt(GMB*RGDENSMAG**(2.0-GAM)/
     &   (RGDENSMAG+AR)**(3.0-GAM)))) THEN
      ELSE
*        Jpetts - NOTE 10.0*AR is arbitrary, code will break if apo further than 5.0
*                 unless one increases the limit past the maximum apocentre distance below.
         E_APO = 0.5*VGCOREMAG**2 -(GMB/AR)*(1.d0/(2.d0-GAM))*
     &   (1.d0 - (RGDENSMAG/(RGDENSMAG+AR))**(2.d0-GAM))
         L2_APO = (RGDENS(2)*VGCORE(3) - RGDENS(3)*VGCORE(2))**2 +
     &            (RGDENS(3)*VGCORE(1) - RGDENS(1)*VGCORE(3))**2 +
     &            (RGDENS(1)*VGCORE(2) - RGDENS(2)*VGCORE(1))**2
         RG_APO = dfapo(1d-9,RGDENSMAG-1d-9,10.0*AR,GMB,AR,GAM,
     &                 E_APO,L2_APO)
      END IF

*       Jpetts - Calculate circular orbit tidal radius at apocentre of orbit for stalling

*       Jpetts - Asume Dehnen profile
      RT_D2PHIDR2 = -AR*((RG_APO/(RG_APO+AR))**(-GAM))
     &            *(AR*GAM - AR + 2.0*RG_APO)
      RT_D2PHIDR2 = RT_D2PHIDR2/(AR+RG_APO)**4
      RT_D2PHIDR2 = RT_D2PHIDR2*GMB/AR
      RT_OMEGA2 = (GMB*(RG_APO/(RG_APO+AR))**(3.0-GAM))/RG_APO**3
      RTIDE_APO = (MASSCL/(RT_OMEGA2-RT_D2PHIDR2))**(1.0/3.0)
*
      IF (RG_APO .lt. RTIDE_APO .AND. DFOFF == 0) THEN
         DYNFCOEF = 0.d0
         write(212,*) "RTIDE_APO > RGDENSMAG:", RTIDE_APO, ">"
     &        , RG_APO, "DF SWITCHED OFF"
         DFOFF = 1
      ELSEIF (DFOFF == 1) THEN
         DYNFCOEF = 0.d0
      ELSE
         DYNFCOEF = 4.d0*ONEPI*MASSCL*COULOG*BDENS*BDIST
      END IF
*

*
      RETURN
*
      END


c======================================================================
      subroutine rpn2(ixy,maxm,meqn,mwaves,mbc,mx,ql,qr,auxl,auxr,
     &                  fwave,s,amdq,apdq)
c======================================================================
c
c Solves normal Riemann problems for the 2D SHALLOW WATER equations
c     with topography:
c     #        h_t + (hu)_x + (hv)_y = 0                           #
c     #        (hu)_t + (hu^2 + 0.5gh^2)_x + (huv)_y = -ghb_x      #
c     #        (hv)_t + (huv)_x + (hv^2 + 0.5gh^2)_y = -ghb_y      #

c On input, ql contains the state vector at the left edge of each cell
c     qr contains the state vector at the right edge of each cell
c
c This data is along a slice in the x-direction if ixy=1
c     or the y-direction if ixy=2.

c  Note that the i'th Riemann problem has left state qr(i-1,:)
c     and right state ql(i,:)
c  From the basic clawpack routines, this routine is called with
c     ql = qr
c
c
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                           !
!      # This Riemann solver is for the shallow water equations.            !
!                                                                           !
!       It allows the user to easily select a Riemann solver in             !
!       riemannsolvers_geo.f. this routine initializes all the variables    !
!       for the shallow water equations, accounting for wet dry boundary    !
!       dry cells, wave speeds etc.                                         !
!                                                                           !
!           David George, Vancouver WA, Feb. 2009                           !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      use geoclaw_module

      implicit none

      !input
      integer maxm,meqn,mwaves,mbc,mx,ixy

      double precision  fwave(1-mbc:maxm+mbc, meqn, mwaves)
      double precision  s(1-mbc:maxm+mbc, mwaves)
      double precision  ql(1-mbc:maxm+mbc, meqn)
      double precision  qr(1-mbc:maxm+mbc, meqn)
      double precision  apdq(1-mbc:maxm+mbc, meqn)
      double precision  amdq(1-mbc:maxm+mbc, meqn)
      double precision  auxl(1-mbc:maxm+mbc, *)
      double precision  auxr(1-mbc:maxm+mbc, *)

      double precision drytol,g

      !local only
      integer m,i,mw,maxiter,mu,nv,mcapa
      double precision wall(3)
      double precision fw(3,3)
      double precision sw(3)

      double precision hR,hL,huR,huL,uR,uL,hvR,hvL,vR,vL,phiR,phiL
      double precision bR,bL,sL,sR,sRoe1,sRoe2,sE1,sE2,uhat,chat
      double precision s1m,s2m
      double precision hstar,hstartest,hstarHLL,sLtest,sRtest
      double precision tw,dxdc

      logical rare1,rare2

      common /cmcapa/  mcapa

      g=grav
      drytol=drytolerance

      !loop through Riemann problems at each grid cell
      do i=2-mbc,mx+mbc

!-----------------------Initializing-----------------------------------
         !inform of a bad riemann problem from the start
         if((qr(i-1,1).lt.0.d0).or.(ql(i,1) .lt. 0.d0)) then
            write(*,*) 'Negative input: hl,hr,i=',qr(i-1,1),ql(i,1),i
         endif

         !Initialize Riemann problem for grid interface
         do mw=1,mwaves
              s(i,mw)=0.d0
              do m=1,meqn
                 fwave(i,m,mw)=0.d0
              enddo
         enddo

c        !set normal direction
         if (ixy.eq.1) then
            mu=2
            nv=3
         else
            mu=3
            nv=2
         endif

         !zero (small) negative values if they exist
         if (qr(i-1,1).lt.0.d0) then
            do m=1,meqn
               qr(i-1,m)=0.d0
            enddo
         endif

         if (ql(i,1).lt.0.d0) then
            do m=1,meqn
               ql(i,m)=0.d0
            enddo
         endif

         !skip problem if in a completely dry area
         if (qr(i-1,1).le.drytol.and.ql(i,1).le.drytol) then
            go to 30
         endif

         !Riemann problem variables
         hL = qr(i-1,1)
         hR = ql(i,1)
         huL = qr(i-1,mu)
         huR = ql(i,mu)
         bL = auxr(i-1,1)
         bR = auxl(i,1)

         hvL=qr(i-1,nv)
         hvR=ql(i,nv)

         !check for wet/dry boundary
         if (hR.gt.drytol) then
            uR=huR/hR
            vR=hvR/hR
            phiR = 0.5d0*g*hR**2 + huR**2/hR
         else
            hR = 0.d0
            huR = 0.d0
            hvR = 0.d0
            uR = 0.d0
            vR = 0.d0
            phiR = 0.d0
         endif

         if (hL.gt.drytol) then
            uL=huL/hL
            vL=hvL/hL
            phiL = 0.5d0*g*hL**2 + huL**2/hL
         else
            hL=0.d0
            huL=0.d0
            hvL=0.d0
            uL=0.d0
            vL=0.d0
            phiL = 0.d0
         endif

         wall(1) = 1.d0
         wall(2) = 1.d0
         wall(3) = 1.d0
         if (hR.le.drytol) then
            call riemanntype(hL,hL,uL,-uL,hstar,s1m,s2m,
     &                                  rare1,rare2,1,drytol,g)
            hstartest=max(hL,hstar)
            if (hstartest+bL.lt.bR) then !right state should become ghost values that mirror left for wall problem
c                bR=hstartest+bL
               wall(2)=0.d0
               wall(3)=0.d0
               hR=hL
               huR=-huL
               bR=bL
               phiR=phiL
               uR=-uL
               vR=vL
            elseif (hL+bL.lt.bR) then
               bR=hL+bL
            endif
         elseif (hL.le.drytol) then ! right surface is lower than left topo
            call riemanntype(hR,hR,-uR,uR,hstar,s1m,s2m,
     &                                  rare1,rare2,1,drytol,g)
            hstartest=max(hR,hstar)
            if (hstartest+bR.lt.bL) then  !left state should become ghost values that mirror right
c               bL=hstartest+bR
               wall(1)=0.d0
               wall(2)=0.d0
               hL=hR
               huL=-huR
               bL=bR
               phiL=phiR
               uL=-uR
               vL=vR
            elseif (hR+bR.lt.bL) then
               bL=hR+bR
            endif
         endif

         !determine wave speeds
         sL=uL-sqrt(g*hL) ! 1 wave speed of left state
         sR=uR+sqrt(g*hR) ! 2 wave speed of right state

         uhat=(sqrt(g*hL)*uL + sqrt(g*hR)*uR)/(sqrt(g*hR)+sqrt(g*hL)) ! Roe average
         chat=sqrt(g*0.5d0*(hR+hL)) ! Roe average
         sRoe1=uhat-chat ! Roe wave speed 1 wave
         sRoe2=uhat+chat ! Roe wave speed 2 wave

         sE1 = min(sL,sRoe1) ! Eindfeldt speed 1 wave
         sE2 = max(sR,sRoe2) ! Eindfeldt speed 2 wave

         !--------------------end initializing...finally----------
         !solve Riemann problem.

         maxiter = 1

         call riemann_aug_JCP(maxiter,3,3,hL,hR,huL,
     &        huR,hvL,hvR,bL,bR,uL,uR,vL,vR,phiL,phiR,sE1,sE2,
     &                                    drytol,g,sw,fw)

c         call riemann_ssqfwave(maxiter,meqn,mwaves,hL,hR,huL,huR,
c     &     hvL,hvR,bL,bR,uL,uR,vL,vR,phiL,phiR,sE1,sE2,drytol,g,sw,fw)

c          call riemann_fwave(meqn,mwaves,hL,hR,huL,huR,hvL,hvR,
c     &      bL,bR,uL,uR,vL,vR,phiL,phiR,sE1,sE2,drytol,g,sw,fw)

c        !eliminate ghost fluxes for wall
         do mw=1,3
            sw(mw)=sw(mw)*wall(mw)
            do m=1,meqn
               fw(m,mw)=fw(m,mw)*wall(mw)
            enddo
         enddo

         do mw=1,mwaves
            s(i,mw)=sw(mw)
            fwave(i,1,mw)=fw(1,mw)
            fwave(i,mu,mw)=fw(2,mw)
            fwave(i,nv,mw)=fw(3,mw)
         enddo

 30      continue
      enddo

c==========Capacity for mapping from latitude longitude to physical space====

        if (mcapa.gt.0) then
         do i=2-mbc,mx+mbc
          if (ixy.eq.1) then
             dxdc=(Rearth*pi/180.d0)
          else
	          dxdc=Rearth*pi*cos(auxl(i,3))/180.d0
          endif

          do mw=1,mwaves
c             if (s(i,mw) .gt. 316.d0) then
c               # shouldn't happen unless h > 10 km!
c                write(6,*) 'speed > 316: i,mw,s(i,mw): ',i,mw,s(i,mw)
c                endif
	           s(i,mw)=dxdc*s(i,mw)
             do m=1,meqn
               fwave(i,m,mw)=dxdc*fwave(i,m,mw)
             enddo
          enddo
         enddo
        endif

c===============================================================================

c============= compute fluctuations=============================================
         do i=1-mbc,mx+mbc
            do m=1,meqn
               amdq(i,m)=0.0d0
               apdq(i,m)=0.0d0
               do  mw=1,mwaves
                  if (s(i,mw).lt.0.d0) then
                     amdq(i,m)=amdq(i,m) + fwave(i,m,mw)
                  elseif (s(i,mw).gt.0.d0) then
                     apdq(i,m)=apdq(i,m) + fwave(i,m,mw)
                  else
		            amdq(i,m) = amdq(i,m) + .5d0*fwave(i,m,mw)
		            apdq(i,m) = apdq(i,m) + .5d0*fwave(i,m,mw)
                  endif
               enddo
            enddo
         enddo

      return
      end subroutine


!>@brief The module 'gozrineo_a_stochy_mod' contains the subroutine 'gozrineo_a_stochy'
      module gozrineo_a_stochy_mod

      implicit none

      contains
!>@brief The subroutine 'gozrineo_a_stochy' calculates the deriviates of assoicate legendre polynomials
!>@details This code is taken from the legacy spectral GFS
      subroutine gozrineo_a_stochy(plnev_a,plnod_a,
     &                      pddev_a,pddod_a,
     &                      plnew_a,plnow_a,
     &                      epse,epso,ls_node,num_lat)
cc
      use spectral_layout_mod
      use kinddef
      implicit none
cc
      real(kind=kind_dbl_prec) plnev_a(len_trie_ls,latg2)
      real(kind=kind_dbl_prec) plnod_a(len_trio_ls,latg2)
      real(kind=kind_dbl_prec) pddev_a(len_trie_ls,latg2)
      real(kind=kind_dbl_prec) pddod_a(len_trio_ls,latg2)
      real(kind=kind_dbl_prec) plnew_a(len_trie_ls,latg2)
      real(kind=kind_dbl_prec) plnow_a(len_trio_ls,latg2)
cc
      real(kind=kind_dbl_prec)    epse(len_trie_ls)
      real(kind=kind_dbl_prec)    epso(len_trio_ls)
cc
cc
      integer                  ls_node(ls_dim,3)
cc
      integer                  num_lat
cc
!cmr  ls_node(1,1) ... ls_node(ls_max_node,1) : values of L
!cmr  ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev
!cmr  ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod
cc
      integer                  l,lat,locl,n
cc
      integer                  indev,indev1,indev2
      integer                  indod,indod1,indod2
      integer                  inddif
cc
      real(kind=kind_dbl_prec) rn,rnp1,wcsa
cc
      real(kind=kind_dbl_prec) cons0     !constant
      real(kind=kind_dbl_prec) cons2     !constant
      real  rerth
cc
      integer                  indlsev,jbasev
      integer                  indlsod,jbasod
cc
      include 'function2'
cc
cc
      cons0 = 0.d0     !constant
      cons2 = 2.d0     !constant
      rerth  =6.3712e+6      ! radius of earth (m)
cc
cc
      do lat=1,num_lat
cc
         do locl=1,ls_max_node
                 l=ls_node(locl,1)
            jbasev=ls_node(locl,2)
            jbasod=ls_node(locl,3)
cc
            rn=l
cc
cc
            pddev_a(indlsev(l,l),lat) = -epso(indlsod(l+1,l))
     &                              * plnod_a(indlsod(l+1,l),lat) * rn
            indev1 = indlsev(L,L) + 1
            if (mod(L,2).eq.mod(jcap+1,2)) then
               indev2 = indlsev(jcap-1,L)
            else
               indev2 = indlsev(jcap  ,L)
            endif
            indod1 = indlsod(l+1,l)
            inddif = indev1 - indod1
cc
            rn  =l+2
            rnp1=l+2+1
            do indev = indev1 , indev2
cc
               pddev_a(indev,lat) = epse(indev)
     &                         * plnod_a(indev-inddif  ,lat) * rnp1
     &                            - epso(indev-inddif+1)
     &                         * plnod_a(indev-inddif+1,lat) * rn
cc
               rn   = rn   + cons2     !constant
               rnp1 = rnp1 + cons2     !constant
            enddo
cc
cc......................................................................
            indev1 = indlsev(L,L)
            if (mod(L,2).eq.mod(jcap+1,2)) then
               indev2 = indlsev(jcap+1,L) - 1
            else
               indev2 = indlsev(jcap  ,L) - 1
            endif
            indod1 = indlsod(l+1,l)
            inddif = indev1 - indod1
cc
            rn  =l+1
            rnp1=l+1+1
            do indev = indev1 , indev2
cc
               pddod_a(indev-inddif,lat) = epso(indev-inddif)
     &                                * plnev_a(indev  ,lat) * rnp1
     &                                   - epse(indev+1)
     &                                * plnev_a(indev+1,lat) * rn
cc
               rn   = rn   + cons2     !constant
               rnp1 = rnp1 + cons2     !constant
            enddo
cc
         enddo
cc
cc......................................................................
cc
         do locl=1,ls_max_node
                 l=ls_node(locl,1)
            jbasev=ls_node(locl,2)
            jbasod=ls_node(locl,3)
cc
            if (mod(L,2).eq.mod(jcap+1,2)) then
cc
cc             set the even (n-l) terms of the top row to zero
               pddev_a(indlsev(jcap+1,l),lat) = cons0     !constant
cc
            else
cc
cc             set the  odd (n-l) terms of the top row to zero
               pddod_a(indlsod(jcap+1,l),lat) = cons0     !constant
cc
            endif
cc
         enddo
cc
cc......................................................................
cc
         wcsa=rcs2_a(lat)/rerth
cc
cc
         do locl=1,ls_max_node
                 l=ls_node(locl,1)
            jbasev=ls_node(locl,2)
            jbasod=ls_node(locl,3)
            indev1 = indlsev(L,L)
            indod1 = indlsod(L+1,L)
            if (mod(L,2).eq.mod(jcap+1,2)) then
               indev2 = indlsev(jcap+1,L)
               indod2 = indlsod(jcap  ,L)
            else
               indev2 = indlsev(jcap  ,L)
               indod2 = indlsod(jcap+1,L)
            endif
            do indev = indev1 , indev2
cc
               pddev_a(indev,lat) = pddev_a(indev,lat) * wcsa
               plnew_a(indev,lat) = plnev_a(indev,lat) * wgt_a(lat)
cc
            enddo
cc
            do indod = indod1 , indod2
cc
               pddod_a(indod,lat) = pddod_a(indod,lat) * wcsa
               plnow_a(indod,lat) = plnod_a(indod,lat) * wgt_a(lat)
cc
            enddo
cc
         enddo
cc
      enddo
cc
      return
      end

      end module gozrineo_a_stochy_mod


MODULE mo_particle_external_properties
  USE mo_submctl, ONLY : pi6, eps, rg, surfw0, grav, spec
  USE classSection, ONLY : Section
  USE util, ONLY : getBinMassArray
  USE mo_ice_shape, ONLY : getDiameter, t_shape_coeffs
  IMPLICIT NONE

  ! This module contains a collection of function to calculate physical and thermodynamical particle properties,
  ! such as diameters, fall velocities, equilibirium saturation ratios at a droplet surface etc.

  CONTAINS

    !
    ! Function for calculating terminal velocities for different particle types and size ranges.
    !     Tomi Raatikainen (2.5.2017)
    !     - Changed from radius to diameter since ~the rest of the model
    !       as well as the calculations below take diameter anyway! -Juha
    REAL FUNCTION terminal_vel(diam,rhop,rhoa,visc,beta,flag,shape,dnsp)
      IMPLICIT NONE
      REAL, INTENT(in) :: diam,  &      ! Particle diameter; for ice this should be the spherical equivalent diameter
                          rhop          ! Bulk density of particle
      REAL, INTENT(in) :: rhoa, visc, beta ! Air density, viscocity and Cunningham correction factor
      INTEGER, INTENT(IN) :: flag ! Parameter for identifying aerosol (1), cloud droplets (2), precip (3), ice (4)
      TYPE(t_shape_coeffs), INTENT(in), OPTIONAL :: shape ! Shape coefficients needed for ice
      REAL, INTENT(in), OPTIONAL :: dnsp                  ! Maximum diameter of non-spherical ice particle

      ! Constants
      REAL, PARAMETER :: rhoa_ref = 1.225 ! reference air density (kg/m^3)

      REAL :: Vb, Ap   ! Bulk volume, cross sectional area (should revise Ap for nonspherical ice!!!)
      REAL :: X     ! Best number

      terminal_vel = 0.
      IF( ANY(flag == [1,2,3])) THEN
         ! Aerosol and cloud and rain droplets
         IF (diam<80.0e-6) THEN
            ! Stokes law with Cunningham slip correction factor
            terminal_vel = (diam**2)*(rhop-rhoa)*grav*beta/(18.*visc)  ![m s-1]
         ELSE IF (diam<1.2e-3) THEN
            ! Droplets from 40 um to 0.6 mm: linear dependence on particle radius and a correction for reduced pressure
            !   R.R. Rogers: A Short Course in Cloud Physics, Pergamon Press Ltd., 1979.
            terminal_vel = 4.e3*diam*SQRT(rhoa_ref/rhoa)
         ELSE
            ! Droplets larger than 0.6 mm: square root dependence on particle radius and a correction for reduced pressure
            !   R.R. Rogers: A Short Course in Cloud Physics, Pergamon Press Ltd., 1979.
            ! Note: this is valid up to 2 mm or 9 m/s (at 1000 mbar), where droplets start to break
            terminal_vel = 2.01e2*SQRT( MIN(diam/2.,2.0e-3)*rhoa_ref/rhoa )
         END IF
      ELSE IF (flag==4) THEN   ! Ice

         ! Khvorostyanov and Curry 2002
         Vb = pi6*diam**3     ! Bulk volume of the particle obtained from spherical equivalent diameter
         Ap = shape%gamma*dnsp**shape%sigma
         X = ( 2. * Vb * (rhop - rhoa) * grav * dnsp**2 ) /  &
              ( Ap * rhoa * visc**2 )
         IF (X < 0.) WRITE(*,*) 'HEP', rhop, rhoa
         terminal_vel = kcVt(shape,dnsp,X,visc,rhoa)

      END IF

    END FUNCTION terminal_vel
    !--
    REAL FUNCTION kc1213(X)
      ! Calculate the term needed in 2.12 and 2.13 in Khvorostyanov and Curry 2002
      REAL, INTENT(in) :: X
      REAL, PARAMETER :: c1 = 0.0902 !(KC2002)
      kc1213 = SQRT(1. + c1*SQRT(X))
    END FUNCTION kc1213
    !--
    REAL FUNCTION kcbre(X)
      ! b_Re from 2.12 in KC2002
      REAL, INTENT(in) :: X
      REAL, PARAMETER :: c1 = 0.0902 !(KC2002)
      kcbre = 0.5 * c1 * SQRT(X)
      kcbre = kcbre / ( kc1213(X) - 1. )
      kcbre = kcbre / kc1213(X)
    END FUNCTION kcbre
    !--
    REAL FUNCTION kcare(X)
      ! a_Re from 2.13 in KC2002
      REAL, INTENT(in) :: X
      REAL, PARAMETER :: delta0 = 9.06, c1 = 0.0902 !(KC2002)
      REAL :: bre
      bre = kcbre(X)
      kcare = 0.25*delta0**2
      kcare = kcare * (kc1213(X) - 1.)**2
      kcare = kcare / (X**bre)
    END FUNCTION kcare
    !--
    REAL FUNCTION kcAv(shape,X,visc,rhoa)
      ! 2.24 from KC2002
      TYPE(t_shape_coeffs), INTENT(in) :: shape
      REAL, INTENT(in) :: X,visc, rhoa
      REAL :: are, bre
      are = kcare(X)
      bre = kcbre(X)
      kcAv = are * visc**(1.-2.*bre)
      kcAv = kcAv * ( (2.*shape%alpha*grav)/(rhoa*shape%gamma) )**bre
    END FUNCTION kcAv
    !--
    REAL FUNCTION kcBv(shape,X)
      ! 2.25 from KC2002
      TYPE(t_shape_coeffs), INTENT(in) :: shape
      REAL, INTENT(in) :: X
      REAL :: bre
      bre = kcbre(X)
      kcBv = bre * (shape%beta - shape%sigma + 2.) - 1.
    END FUNCTION kcBv
    !--
    REAL FUNCTION kcVt(shape,D,X,visc,rhoa)
      ! 2.23 from KC2002
      TYPE(t_shape_coeffs), INTENT(in) :: shape
      REAL, INTENT(in) :: D, X, visc, rhoa
      REAL :: Av, Bv
      Av = kcAv(shape,X,visc,rhoa)
      Bv = kcBv(shape,X)
      kcVt = Av * D**Bv
    END FUNCTION kcVt

    !
    ! Function for calculating effective (wet) radius for any particle type
    ! - Aerosol, cloud and rain are spherical
    ! - Snow and ice can be irregular and their densities can be size-dependent
    !
    ! Correct dimension is needed for irregular particles (e.g. ice) for calculating fall speed (deposition and coagulation)
    ! and capacitance (condensation). Otherwise spherical assumed. This function is overloaded for LES and SALSA environments.
    !
    FUNCTION calcDiamLES(ns,numc,mass,flag,sph)
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: ns ! Number of species
      INTEGER, INTENT(IN) :: flag ! Parameter for identifying aerosol (1), cloud droplets (2), precip (3) and ice (4) particle phases
      REAL, INTENT(IN) :: numc, mass(ns)
      LOGICAL, OPTIONAL, INTENT(in) :: sph
      REAL :: calcDiamLES

      LOGICAL :: l_sph

      ! By default, calculate diameter assuming spherical particles (relevant for ice)
      l_sph = .TRUE.
      IF (PRESENT(sph)) l_sph = sph

      calcDiamLES=0.

      IF (numc < 1.e-15) RETURN

      IF (flag==4) THEN   ! Ice
         IF (l_sph) THEN
            ! Spherical equivalent for ice
            calcDiamLES = ( SUM(mass(1:ns)/spec%rhoice(1:ns))/numc/pi6 )**(1./3.)
         ELSE
            ! non-spherical ice
            ! Get the effective ice diameter, i.e. the max diameter for non-spherical ice
            calcDiamLES = getDiameter( SUM(mass(1:ns-1)),mass(ns),numc )
         END IF
      ELSE
         ! Radius from total volume of a spherical particle or aqueous droplet
         calcDiamLES = ( SUM(mass(1:ns)/spec%rholiq(1:ns))/numc/pi6 )**(1./3.)
      ENDIF

    END FUNCTION calcDiamLES

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

    !
    ! Function for calculating equilibrium water saturation ratio at droplet surface based on Köhler theory
    !
    REAL FUNCTION calcSweq(part,T)
      TYPE(Section), INTENT(in) :: part ! Any particle
      REAL, INTENT(IN) :: T ! Absolute temperature (K)
      REAL :: dwet

      REAL :: znw,zns ! Moles of water and soluble material
      REAL :: zvw, zvs, zvtot ! Volume concentrations of water and soluble material and total dry
      INTEGER :: iwa, ndry ! Index for water, number of "dry" species
      INTEGER :: i

      iwa = spec%getIndex("H2O")
      ndry = spec%getNSpec(type="dry")

      calcSweq = 0.
      IF (part%numc < part%nlim) RETURN

      ! Wet diameter  !! USE THE FUNCTIONS PROVIDED FOR THIS??
      dwet = (SUM(part%volc(:))/part%numc/pi6)**(1./3.)

      ! Equilibrium saturation ratio = xw*exp(4*sigma*v_w/(R*T*Dwet))

      znw = part%volc(iwa)*spec%rhowa/spec%mwa
      zvw = part%volc(iwa)
      zns = 0.
      zvs = 0.
      zvtot = 0.
      DO i = 1,ndry
         zns = zns + spec%diss(i)*part%volc(i)*spec%rholiq(i)/spec%MM(i)
         zvs = zvs + MIN(1.,spec%diss(i)) * part%volc(i) ! Use "diss" here just to select the soluble species
         zvtot = zvtot + part%volc(i)
      END DO

      ! Combine the two cases from original code since they're exactly the same??
      IF (zvw > 1.e-28*part%numc .OR. zvs > 1.e-28*part%numc) THEN
         ! Aqueous droplet OR dry partially soluble particle
         calcSweq = (znw/(zns+znw)) * exp(4.*surfw0*spec%mwa/(rg*T*spec%rhowa*dwet))
      ELSE IF (zvtot-zvs > 1.e-28*part%numc) THEN
         ! Dry insoluble particle
         calcSweq = exp(4.*surfw0*spec%mwa/(rg*T*spec%rhowa*dwet))
      ELSE
         ! Just add eps to avoid divide by zero
         calcSweq = (znw/(eps+zns+znw)) * exp(4.*surfw0*spec%mwa/(rg*T*spec%rhowa*dwet))
      END IF

    END FUNCTIOn calcSweq

  END MODULE mo_particle_external_properties


      subroutine eval_dlam(ctfm,ctfmp,n_A,n_Athth,n_Axx,n_B,n_K,n_Lamx,n
     &_Sx,n_alpha,n_beta,n_divbeta,n_phi,octfmp,x,Nx,hx,myzero,vee,phys_
     &bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 myzero
      real*8 vee
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_Athth(Nx)
      real*8 n_Axx(Nx)
      real*8 n_B(Nx)
      real*8 n_K(Nx)
      real*8 n_Lamx(Nx)
      real*8 n_Sx(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_divbeta(Nx)
      real*8 n_phi(Nx)
      real*8 octfmp(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = 0.6666666666666667D0 * n_divbeta(i) * n_Lamx(i) * vee - 0.2D1
     # / n_A(i) * n_alpha(i) * n_Sx(i) + (-0.4D1 / n_B(i) / n_A(i) * n_A
     #thth(i) * n_alpha(i) + 0.4D1 / n_B(i) ** 2 * n_alpha(i) * n_Athth(
     #i)) / ctfm(i) - 0.2D1 / ctfm(i) ** 2 / n_B(i) * n_beta(i) + ((0.50
     #00000000000000D0 / n_A(i) ** 3 * n_Axx(i) * n_alpha(i) * (-0.1D1 *
     # n_A(i - 1) + n_A(i + 1)) - 0.1D1 / n_B(i) ** 2 / n_A(i) * (-0.1D1
     # * n_B(i - 1) + n_B(i + 1)) * n_Athth(i) * n_alpha(i) + 0.66666666
     #66666667D0 / n_A(i) * n_alpha(i) * (n_K(i - 1) - 0.1D1 * n_K(i + 1
     #)) + 0.5000000000000000D0 * n_beta(i) * (-0.1D1 * n_Lamx(i - 1) +
     #n_Lamx(i + 1)) + 0.1D1 / n_A(i) ** 2 * n_Axx(i) * (n_alpha(i - 1)
     #- 0.1D1 * n_alpha(i + 1)) - 0.5000000000000000D0 * n_Lamx(i) * (-0
     #.1D1 * n_beta(i - 1) + n_beta(i + 1)) - 0.5000000000000000D0 * (-0
     #.1D1 * n_beta(i - 1) + n_beta(i + 1)) / n_A(i) * octfmp(i) - 0.166
     #6666666666667D0 / n_A(i) * vee * (n_divbeta(i - 1) - 0.1D1 * n_div
     #beta(i + 1)) - 0.6D1 / n_A(i) ** 2 * n_alpha(i) * n_Axx(i) * (n_ph
     #i(i - 1) - 0.1D1 * n_phi(i + 1))) / ctfmp(i) + 0.1D1 / n_B(i) * (-
     #0.1D1 * n_beta(i - 1) + n_beta(i + 1)) / ctfmp(i) / ctfm(i)) / hx
     #- 0.1D1 / n_A(i) / ctfmp(i) ** 2 * (-0.1D1 * n_beta(i - 1) + 0.2D1
     # * n_beta(i) - 0.1D1 * n_beta(i + 1)) / hx ** 2
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      END


       subroutine pwrvf(x,nch,ns,nf,p,wrk)
       complex x(nch,ns,nf)
       real p(nf),wrk(nch,0:nf)

c************given the array x (nch channels , ns time segments, nf
c                   frequencies )  find average power for each
c                frequency, and return a damped inverse of this
c                crude average power spectrum for whitening the
c                 spectrum

c........find average power for each freq, channel
       do 10 i = 1,nch
       do 10 j = 1,nf
       wrk(i,j) = 0.
          do 5 k = 1,ns
5         wrk(i,j) =wrk(i,j) + x(i,k,j)*conjg(x(i,k,j))
10     wrk(i,j) = wrk(i,j)/ns

c.........normalize so that each channel has avg pwr 1 (avgd over freq)
       do 20 i = 1,nch
       wrk(i,0) = 0.
         do 15 j = 1,nf
15       wrk(i,0) = wrk(i,0)+wrk(i,j)
       wrk(i,0) = wrk(i,0)/nf
         do 18 j = 1,nf
         wrk(i,j) = wrk(i,j)/wrk(i,0)
18       continue
20    continue

c......... find average power for each freq.
      do 30 j = 1,nf
      p(j) =0.
         do 25 i = 1,nch
25       p(j) = p(j) + wrk(i,j)
      p(j) = p(j)/nch
      wrk(1,j) = p(j)
30    continue

c.......... find median average power
      call sort(p,nf)

c.......... add to average power to determine relative weights
      pmed = p(nf/2)
      do 40 j = 1,nf
40    p(j) = 1./(wrk(1,j) + pmed)
      return
      end


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine dipole_norm(dipole,norm)
  use global_variables
  implicit none
  real(dp) :: dipole,norm

  dipole = sum(xyn(:,:)*abs(zwfn(:,:))**2)*dx**2
  norm = sum(abs(zwfn(:,:))**2)*dx**2

  return
end subroutine dipole_norm


!****************************************************
!   LOWPASS
!   Lowpass filtering using Weighted Least Squares
!
!   Input:
!       lowpass [options] [inputfile] [outputfile]
!
!   Options:
!       -tday      Treat times as days (default).
!       -tsec      Treat times as seconds.
!       -version   Print program version information.
!
!   Written by
!     Rasmus Handberg
!     Department of Physics and Astronomy
!     Aarhus University
!****************************************************

program lowpas
	use kind_defs
	use timeseries
	implicit none
	real(dbl), allocatable :: lp(:)
	real(dbl) :: dF, nu_max, nu_lowpass, nu_min
	real(dbl) :: t1, t2
	integer :: N, err, j
	logical :: bolUseWeights
	character(200) :: buffer, inputfile, outputfile
   	integer :: TimeType = 1 ! Default time type is days
	integer :: nargs, iargc

	! Extract parameters from command-line:
	nargs = iargc()
	do j = 1,nargs
		call getarg(j, buffer)
		select case (trim(buffer))
			case ("-tsec")
				TimeType = 0
			case ("-tday")
				TimeType = 1
			case ("-version")
				print *, "Current version:"
				print *, "$Revision: 119 $"
				print *, "$Date: 2016-02-09 09:57:56 +0100 (ti, 09 feb 2016) $"
				stop

			case default
				buffer = trim(buffer)
				if (.not. buffer(1:1) == "-" .and. inputfile == "") then
					inputfile = trim(buffer)
				elseif (.not. buffer(1:1) == "-" .and. outputfile == "") then
					outputfile = trim(buffer)
				else
					print *, "UNKNOWN ARGUMENT: " // trim(buffer)
					stop
				endif
		end select
	enddo

	print *, "--------------------------------"
    print *, "         LOWPASS-filter         "
    print *, "--------------------------------"

	! If no files were given, ask for input and make output:
	if (inputfile == "") then
        print *, 'Enter input-file:'
        read '(a50)', inputfile
	endif
	if (outputfile == '') then
		outputfile = 'lowpass.dat'
	endif

    print *, "Reading data..."
    open(50, file=inputfile, status='old', action='read')
        ! Count number of datapoints:
        call CountData(50, N, bolUseWeights)
        ! Allocate the data:d
    	allocate(t(1:N), f(1:N), w(1:N), lp(1:N), stat=err)
    	if (err /= 0) stop "Couldn't allocate memory!"
	    ! Ask to use the statistical weights:
		if (bolUseWeights) then
			print *, "Do you want to use the statistical weights? (1=yes,0=no)"
			read(*, '(i1)') j
			if (j == 0) bolUseWeights = .false.
		endif
        ! Import the data:
        call ImportData(50, bolUseWeights, t, f, w)
    close(50)

    ! Convert time vector to seconds, based on the selected input:
	if (TimeType == 1) then
		t = t*86400_dbl
	endif

    ! Print information about series:
	call print_info(t)

	! Ask for frequencies:
	print *, ''
	print *, "min-frequency: (microHz)"
	read *, nu_min
	print *, "max-frequency: (microHz)"
	read *, nu_max
	print *, "Frequency resolution: (microHz)"
	read *, dF
	print *, "Lowpass-frequency: (microHz)"
	read *, nu_lowpass
	print *, ''

	! Run the lowpass-filter:
	call cpu_time(t1)
	lp = lowpass(t, f, w, nu_lowpass, nu_min, nu_max, dF)

	! Convert time vector back to the original units, based on the selected input:
	if (TimeType == 1) then
		t = t/86400_dbl
	endif

	! Write results to file:
	open(51, file=outputfile, status='replace', action='write')
	do j = 1,N
		write(51, '(3ES26.16E3)') t(j), lp(j), 1.0_dbl/sqrt(w(j))
	enddo
	close(51)

	! Clean up memory:
	deallocate(t, f, w, lp)

	call cpu_time(t2)
	print *, "--------------------------------"
    call print_time(t2-t1)
end program lowpas


C--------------------------------------------------------------
C All the routines in this file were updated on 9 Feb 2015 to
C reverse the dimensions of "clcntr"/"c" (from "k x n" to
C "n x k") so that the calling C routine could have the
C dimensions be K x N.
C--------------------------------------------------------------
C NCLFORTSTART
      subroutine kmns136 (dat, m, n, clcntr, k,  ic1, nc
     +                   ,iter, iseed, wss, ier)
      implicit none
c                            ! INPUT
      integer m, n, k, iter, iseed
      double precision dat(m,n)
c                            ! INPUT/OUTPUT
      integer ic1(m), nc(k), ier
      double precision clcntr(n,k), wss(k)
C NCLEND
c                            ! LOCAL WORK ARRAYS
      integer          ic2(m), ncp(k), itran(k), live(k)
      double precision an1(k), an2(k), d(m)
      integer nv, kk, mm

c Currently: two methods to set the seed
c . iseed=1 pick 1st k elements of the dat array
c . iseed=2 'randomly' sample the dat array

      do kk=1,k
         if (iseed.eq.1) then
             mm = kk
         else
             mm = m/kk
         end if
        do nv=1,n
           clcntr(nv,kk) = dat(mm,nv)
c c c      print *,"mm=", mm," kk=",kk,"  nv=",nv," clc=",clcntr(kk,nv)
        end do
      end do

      call kmns (dat,m,n,clcntr,k,ic1,ic2,nc,an1,an2,ncp,d
     &          ,itran,live,iter,wss,ier )

      return
      end

c*********************************************************************72
      subroutine kmns ( a, m, n, c, k, ic1, ic2, nc, an1, an2, ncp, d
     &                ,itran, live, iter, wss, ifault )
c
cc KMNS carries out the K-means algorithm.
c
c  Discussion:
c
c    This routine attempts to divide M points in N-dimensional space into
c    K clusters so that the within cluster sum of squares is minimized.
c
c  Modified:
c
c    13 February 2008
c
c  Author:
c
c    Original FORTRAN77 version by John Hartigan, Manchek Wong.
c    Modifications by John Burkardt.
c
c  Reference:
c
c    John Hartigan, Manchek Wong,
c    Algorithm AS 136:
c    A K-Means Clustering Algorithm,
c    Applied Statistics,
c    Volume 28, Number 1, 1979, pages 100-108.
c
c  Parameters:
c
c    Input, double precision A(M,N), the points.
c
c    Input, integer M, the number of points.
c
c    Input, integer N, the number of spatial dimensions (aka, variables).
c
c    Input/output, double precision C(N,K), the cluster centers.
c
c    Input, integer K, the number of clusters.
c
c    Output, integer IC1(M), the cluster to which each point is assigned.
c
c    Workspace, integer IC2(M), used to store the cluster which each point
c    is most likely to be transferred to at each step.
c
c    Output, integer NC(K), the number of points in each cluster.
c
c    Workspace, double precision AN1(K).
c
c    Workspace, double precision AN2(K).
c
c    Workspace, integer NCP(K).
c
c    Workspace, double precision D(M).
c
c    Workspace, integer ITRAN(K).
c
c    Workspace, integer LIVE(K).
c
c    Input, integer ITER, the maximum number of iterations allowed.
c
c    Output, double precision WSS(K), the within-cluster sum of squares
c    of each cluster.
c
c    Output, integer IFAULT, error indicator.
c    0, no error was detected.
c    1, at least one cluster is empty after the initial assignment.
c       A better set of initial cluster centers is needed.
c    2, the allowed maximum number off iterations was exceeded.
c    3, K is less than or equal to 1, or greater than or equal to M.
c
      implicit none

      integer k
      integer m
      integer n

      double precision a(m,n)
      double precision aa
      double precision an1(k)
      double precision an2(k)
      double precision c(n,k)
      double precision d(m)
      double precision da
      double precision db
      double precision dc
      double precision dt(2)
      integer i
      integer ic1(m)
      integer ic2(m)
      integer ifault
      integer ii
      integer ij
      integer il
      integer indx
      integer iter
      integer itran(k)
      integer j
      integer l
      integer live(k)
      integer nc(k)
      integer ncp(k)
      double precision r8_huge
      double precision temp
      double precision wss(k)

      ifault = 0

      if ( k .le. 1 .or. m .le. k ) then
        ifault = 3
        return
      end if
c
c  For each point I, find its two closest centers, IC1(I) and
c  IC2(I).  Assign the point to IC1(I).
c
      do i = 1, m

        ic1(i) = 1
        ic2(i) = 2

        do il = 1, 2
          dt(il) = 0.0D+00
          do j = 1, n
            da = a(i,j) - c(j,il)
            dt(il) = dt(il) + da * da
          end do
        end do

        if ( dt(2) .lt. dt(1) ) then
          ic1(i) = 2
          ic2(i) = 1
          temp = dt(1)
          dt(1) = dt(2)
          dt(2) = temp
        end if

        do l = 3, k

          db = 0.0D+00

          do j = 1, n
            dc = a(i,j) - c(j,l)
            db = db + dc * dc
          end do

          if ( db .lt. dt(2) ) then

            if ( dt(1) .le. db ) then
              dt(2) = db
              ic2(i) = l
            else
              dt(2) = dt(1)
              ic2(i) = ic1(i)
              dt(1) = db
              ic1(i) = l
            end if

          end if

        end do

      end do
c
c  Update cluster centers to be the average of points contained within them.
c
      do l = 1, k
        nc(l) = 0
        do j = 1, n
          c(j,l) = 0.0D+00
        end do
      end do

      do i = 1, m
        l = ic1(i)
        nc(l) = nc(l) + 1
        do j = 1, n
          c(j,l) = c(j,l) + a(i,j)
        end do
      end do
c
c  Check to see if there is any empty cluster at this stage.
c
      ifault = 1

      do l = 1, k

        if ( nc(l) .eq. 0 ) then
          ifault = 1
          return
        end if

      end do

      ifault = 0

      do l = 1, k

        aa = dble ( nc(l) )

        do j = 1, n
          c(j,l) = c(j,l) / aa
        end do
c
c  Initialize AN1, AN2, ITRAN and NCP.
c
c  AN1(L) = NC(L) / (NC(L) - 1)
c  AN2(L) = NC(L) / (NC(L) + 1)
c  ITRAN(L) = 1 if cluster L is updated in the quick-transfer stage,
c           = 0 otherwise
c
c  In the optimal-transfer stage, NCP(L) stores the step at which
c  cluster L is last updated.
c
c  In the quick-transfer stage, NCP(L) stores the step at which
c  cluster L is last updated plus M.
c
        an2(l) = aa / ( aa + 1.0D+00 )

        if ( 1.0D+00 .lt. aa ) then
          an1(l) = aa / ( aa - 1.0D+00 )
        else
          an1(l) = r8_huge ( )
        end if

        itran(l) = 1
        ncp(l) = -1

      end do

      indx = 0
      ifault = 2

      do ij = 1, iter
c
c  In this stage, there is only one pass through the data.   Each
c  point is re-allocated, if necessary, to the cluster that will
c  induce the maximum reduction in within-cluster sum of squares.
c
        call optra ( a, m, n, c, k, ic1, ic2, nc, an1, an2, ncp, d,
     &    itran, live, indx )
c
c  Stop if no transfer took place in the last M optimal transfer steps.
c
        if ( indx .eq. m ) then
          ifault = 0
          go to 150
        end if
c
c  Each point is tested in turn to see if it should be re-allocated
c  to the cluster to which it is most likely to be transferred,
c  IC2(I), from its present cluster, IC1(I).   Loop through the
c  data until no further change is to take place.
c
        call qtran ( a, m, n, c, k, ic1, ic2, nc, an1, an2, ncp, d,
     &    itran, indx )
c
c  If there are only two clusters, there is no need to re-enter the
c  optimal transfer stage.
c
        if ( k .eq. 2 ) then
          ifault = 0
          go to 150
        end if
c
c  NCP has to be set to 0 before entering OPTRA.
c
        do l = 1, k
          ncp(l) = 0
        end do

      end do

  150 continue
c
c  If the maximum number of iterations was taken without convergence,
c  IFAULT is 2 now.  This may indicate unforeseen looping.
c
      if ( ifault == 2 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'KMNS - Warning!'
        write ( *, '(a)' ) '  Maximum number of iterations reached'
        write ( *, '(a)' ) '  without convergence.'
      end if
c
c  Compute the within-cluster sum of squares for each cluster.
c
      do l = 1, k
        wss(l) = 0.0D+00
        do j = 1, n
          c(j,l) = 0.0D+00
        end do
      end do

      do i = 1, m
        ii = ic1(i)
        do j = 1, n
          c(j,ii) = c(j,ii) + a(i,j)
        end do
      end do

      do j = 1, n
        do l = 1, k
          c(j,l) = c(j,l) / dble ( nc(l) )
        end do
        do i = 1, m
          ii = ic1(i)
          da = a(i,j) - c(j,ii)
          wss(ii) = wss(ii) + da * da
        end do
      end do

      return
      end
      subroutine optra ( a, m, n, c, k, ic1, ic2, nc, an1, an2, ncp,
     &  d, itran, live, indx )

c*********************************************************************72
c
cc OPTRA carries out the optimal transfer stage.
c
c  Discussion:
c
c    This is the optimal transfer stage.
c
c    Each point is re-allocated, if necessary, to the cluster that
c    will induce a maximum reduction in the within-cluster sum of
c    squares.
c
c  Modified:
c
c    15 February 2008
c
c  Author:
c
c    Original FORTRAN77 version by John Hartigan, Manchek Wong.
c    Modifications by John Burkardt.
c
c  Reference:
c
c    John Hartigan, Manchek Wong,
c    Algorithm AS 136:
c    A K-Means Clustering Algorithm,
c    Applied Statistics,
c    Volume 28, Number 1, 1979, pages 100-108.
c
c  Parameters:
c
c    Input, double precision A(M,N), the points.
c
c    Input, integer M, the number of points.
c
c    Input, integer N, the number of spatial dimensions.
c
c    Input/output, double precision C(N,K), the cluster centers.
c
c    Input, integer K, the number of clusters.
c
c    Input/output, integer IC1(M), the cluster to which each point is assigned.
c
c    Input/output, integer IC2(M), used to store the cluster which each point
c    is most likely to be transferred to at each step.
c
c    Input/output, integer NC(K), the number of points in each cluster.
c
c    Input/output, double precision AN1(K).
c
c    Input/output, double precision AN2(K).
c
c    Input/output, integer NCP(K).
c
c    Input/output, double precision D(M).
c
c    Input/output, integer ITRAN(K).
c
c    Input/output, integer LIVE(K).
c
c    Input/output, integer INDX, the number of steps since a transfer took place.
c
      implicit none

      integer k
      integer m
      integer n

      double precision a(m,n)
      double precision al1
      double precision al2
      double precision alt
      double precision alw
      double precision an1(k)
      double precision an2(k)
      double precision c(n,k)
      double precision d(m)
      double precision da
      double precision db
      double precision dc
      double precision dd
      double precision de
      double precision df
      integer i
      integer ic1(m)
      integer ic2(m)
      integer indx
      integer itran(k)
      integer j
      integer l
      integer l1
      integer l2
      integer live(k)
      integer ll
      integer nc(k)
      integer ncp(k)
      double precision r2
      double precision r8_huge
      double precision rr
c
c  If cluster L is updated in the last quick-transfer stage, it
c  belongs to the live set throughout this stage.   Otherwise, at
c  each step, it is not in the live set if it has not been updated
c  in the last M optimal transfer steps.
c
      do l = 1, k
        if ( itran(l) .eq. 1) then
          live(l) = m + 1
        end if
      end do

      do i = 1, m

        indx = indx + 1
        l1 = ic1(i)
        l2 = ic2(i)
        ll = l2
c
c  If point I is the only member of cluster L1, no transfer.
c
        if ( 1 .lt. nc(l1)  ) then
c
c  If L1 has not yet been updated in this stage, no need to
c  re-compute D(I).
c
          if ( ncp(l1) .ne. 0 ) then
            de = 0.0D+00
            do j = 1, n
              df = a(i,j) - c(j,l1)
              de = de + df * df
            end do
            d(i) = de * an1(l1)
          end if
c
c  Find the cluster with minimum R2.
c
         da = 0.0D+00
          do j = 1, n
            db = a(i,j) - c(j,l2)
            da = da + db * db
          end do
          r2 = da * an2(l2)

          do l = 1, k
c
c  If LIVE(L1) <= I, then L1 is not in the live set.   If this is
c  true, we only need to consider clusters that are in the live set
c  for possible transfer of point I.   Otherwise, we need to consider
c  all possible clusters.
c
            if ( ( i .lt. live(l1) .or. i .lt. live(l2) ) .and.
     &             l .ne. l1 .and. l .ne. ll ) then

              rr = r2 / an2(l)

              dc = 0.0D+00
              do j = 1, n
                dd = a(i,j) - c(j,l)
                dc = dc + dd * dd
              end do

              if ( dc .lt. rr ) then
                r2 = dc * an2(l)
                l2 = l
              end if

            end if

          end do
c
c  If no transfer is necessary, L2 is the new IC2(I).
c
          if ( d(i) .le. r2 ) then

            ic2(i) = l2
c
c  Update cluster centers, LIVE, NCP, AN1 and AN2 for clusters L1 and
c  L2, and update IC1(I) and IC2(I).
c
          else

            indx = 0
            live(l1) = m + i
            live(l2) = m + i
            ncp(l1) = i
            ncp(l2) = i
            al1 = nc(l1)
            alw = al1 - 1.0D+00
            al2 = nc(l2)
            alt = al2 + 1.0D+00
            do j = 1, n
              c(j,l1) = ( c(j,l1) * al1 - a(i,j) ) / alw
              c(j,l2) = ( c(j,l2) * al2 + a(i,j) ) / alt
            end do
            nc(l1) = nc(l1) - 1
            nc(l2) = nc(l2) + 1
            an2(l1) = alw / al1
            if ( 1.0D+00 .lt. alw ) then
              an1(l1) = alw / ( alw - 1.0D+00 )
            else
              an1(l1) = r8_huge ( )
            end if
            an1(l2) = alt / al2
            an2(l2) = alt / ( alt + 1.0D+00 )
            ic1(i) = l2
            ic2(i) = l1

          end if

        end if

        if ( indx .eq. m ) then
          return
        end if

      end do
c
c  ITRAN(L) = 0 before entering QTRAN.   Also, LIVE(L) has to be
c  decreased by M before re-entering OPTRA.
c
      do l = 1, k
        itran(l) = 0
        live(l) = live(l) - m
      end do

      return
      end
      subroutine qtran ( a, m, n, c, k, ic1, ic2, nc, an1, an2, ncp,
     &  d, itran, indx )

c*********************************************************************72
c
cc QTRAN carries out the quick transfer stage.
c
c  Discussion:
c
c    This is the quick transfer stage.
c
c    IC1(I) is the cluster which point I belongs to.
c    IC2(I) is the cluster which point I is most likely to be
c    transferred to.
c
c    For each point I, IC1(I) and IC2(I) are switched, if necessary, to
c    reduce within-cluster sum of squares.  The cluster centers are
c    updated after each step.
c
c  Modified:
c
c    15 February 2008
c
c  Author:
c
c    Original FORTRAN77 version by John Hartigan, Manchek Wong.
c    Modifications by John Burkardt.
c
c  Reference:
c
c    John Hartigan, Manchek Wong,
c    Algorithm AS 136:
c    A K-Means Clustering Algorithm,
c    Applied Statistics,
c    Volume 28, Number 1, 1979, pages 100-108.
c
c  Parameters:
c
c    Input, double precision A(M,N), the points.
c
c    Input, integer M, the number of points.
c
c    Input, integer N, the number of spatial dimensions.
c
c    Input/output, double precision C(N,K), the cluster centers.
c
c    Input, integer K, the number of clusters.
c
c    Input/output, integer IC1(M), the cluster to which each point is assigned.
c
c    Input/output, integer IC2(M), used to store the cluster which each point
c    is most likely to be transferred to at each step.
c
c    Input/output, integer NC(K), the number of points in each cluster.
c
c    Input/output, double precision AN1(K).
c
c    Input/output, double precision AN2(K).
c
c    Input/output, integer NCP(K).
c
c    Input/output, double precision D(M).
c
c    Input/output, integer ITRAN(K).
c
c    Input/output, integer INDX, counts the number of steps since the
c    last transfer.
c
      implicit none

      integer k
      integer m
      integer n

      double precision a(m,n)
      double precision al1
      double precision al2
      double precision alt
      double precision alw
      double precision an1(k)
      double precision an2(k)
      double precision c(n,k)
      double precision d(m)
      double precision da
      double precision db
      double precision dd
      double precision de
      integer i
      integer ic1(m)
      integer ic2(m)
      integer icoun
      integer indx
      integer istep
      integer itran(k)
      integer j
      integer l1
      integer l2
      integer nc(k)
      integer ncp(k)
      double precision r2
      double precision r8_huge
c
c  In the optimal transfer stage, NCP(L) indicates the step at which
c  cluster L is last updated.   In the quick transfer stage, NCP(L)
c  is equal to the step at which cluster L is last updated plus M.
c
      icoun = 0
      istep = 0

   10 continue

        do i = 1, m

          icoun = icoun + 1
          istep = istep + 1
          l1 = ic1(i)
          l2 = ic2(i)
c
c  If point I is the only member of cluster L1, no transfer.
c
          if ( 1 .lt. nc(l1) ) then
c
c  If NCP(L1) < ISTEP, no need to re-compute distance from point I to
c  cluster L1.   Note that if cluster L1 is last updated exactly M
c  steps ago, we still need to compute the distance from point I to
c  cluster L1.
c
            if ( istep .le. ncp(l1) ) then

              da = 0.0D+00
              do j = 1, n
                db = a(i,j) - c(j,l1)
                da = da + db * db
              end do

              d(i) = da * an1(l1)

            end if
c
c  If NCP(L1) <= ISTEP and NCP(L2) <= ISTEP, there will be no transfer of
c  point I at this step.
c
            if ( istep .lt. ncp(l1) .or. istep .lt. ncp(l2) ) then

              r2 = d(i) / an2(l2)

              dd = 0.0D+00
              do j = 1, n
                de = a(i,j) - c(j,l2)
                dd = dd + de * de
              end do
c
c  Update cluster centers, NCP, NC, ITRAN, AN1 and AN2 for clusters
c  L1 and L2.   Also update IC1(I) and IC2(I).   Note that if any
c  updating occurs in this stage, INDX is set back to 0.
c
              if ( dd .lt. r2 ) then

                icoun = 0
                indx = 0
                itran(l1) = 1
                itran(l2) = 1
                ncp(l1) = istep + m
                ncp(l2) = istep + m
                al1 = nc(l1)
                alw = al1 - 1.0D+00
                al2 = nc(l2)
                alt = al2 + 1.0D+00
                do j = 1, n
                  c(j,l1) = ( c(j,l1) * al1 - a(i,j) ) / alw
                  c(j,l2) = ( c(j,l2) * al2 + a(i,j) ) / alt
                end do
                nc(l1) = nc(l1) - 1
                nc(l2) = nc(l2) + 1
                an2(l1) = alw / al1
                if ( 1.0D+00 .lt. alw ) then
                  an1(l1) = alw / ( alw - 1.0D+00 )
                else
                  an1(l1) = r8_huge ( )
                end if
                an1(l2) = alt / al2
                an2(l2) = alt / ( alt + 1.0D+00 )
                ic1(i) = l2
                ic2(i) = l1

              end if

            end if

          end if
c
c  If no re-allocation took place in the last M steps, return.
c
          if ( icoun .eq. m ) then
            return
          end if

        end do

      go to 10
      end
      function r8_huge ( )

c*********************************************************************72
c
cc R8_HUGE returns a "huge" R8.
c
c  Modified:
c
c    13 April 2004
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Output, double precision R8_HUGE, a huge number.
c
      implicit none

      double precision r8_huge

      r8_huge = 1.0D+30

      return
      end


C
C $Id: bccurv.f,v 1.6 2008-07-27 00:17:29 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE BCCURV(BXI,BYI,NO,XO,YO,NPTS)
C
C  PURPOSE
C    This subroutine calculates points along a Bezier curve whose
C    four control points are given in BXI and BYI.  In the default
C    case a recursive subdivision algorithm is implemented that
C    calculates the points along the curve to within a predefined
C    tolerance limit.
C
C  USAGE
C                Argument    Type     Mode    Dimension
C                --------    ----     ----    ---------
C    CALL BCCURV(BXI,        Real     Input   4
C                BYI,        Real     Input   4
C                NO,         Integer  Input
C                XO,         Real     Output  NO
C                YO,         Real     Output  NO
C                NPTS)       Integer  Output
C
C
C         BXI   --  The X coordinates for four Bezier control points.
C         BYI   --  The Y coordinates for four Bezier control points.
C         NO    --  The deminsion of the output arrays XO and YO.
C         XO    --  The interpolated X coordinates for the points along
C                   the Bezier curve that is defined by the input control
C                   points.
C         YO    --  The interpolated Y coordinates for the points along
C                   the Bezier curve that is defined by the input control
C                   points.
C         NPTS  --  The number of points returned in XO and YO.  NPTS
C                   must be less than NO or an error results.
C
C-------------------------------------------------------------------------------
C
C  UNDEF  --  A number to flag that fields have not been defined.
C  NLEV   --  The maximum number of iterations for curve subdivision,
C             i.e. the maximum number of times a curve will be subdivided
C             before calling the points in the subdivided curves the final
C             ones to represent the original curve.
C  MXCRV  --  Maximum number of curves resulting from the subdivision
C             process.
C
      include 'bccom.h'
C
      PARAMETER (UNDEF=2.**100, NLEV=8, MXCRV=2**(NLEV-1))
C
      DIMENSION BXI(4),BYI(4),XO(NO),YO(NO)
C
C  Dimension the arrays used to store the curves resulting from
C  subdivision.  At each level of subdivision, the subdivided curves
C  computed at that level are stored in these arrays.
C
      DIMENSION BZPTSX(4,MXCRV),BZPTSY(4,MXCRV),BZX(4),BZY(4)
      DIMENSION TWIN(4),TVPT(4)
C
C Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
      CALL BCBKD
C
C  Set the flatness tolerance value EPS in user coordinates.
C
      CALL GQCNTN(IER,NTR)
      IF (IER .EQ. 8) THEN
        PRINT * , 'BCCURV -- GKS must be open before calling functions i
     +n the Bezier curve package.'
        STOP
      ENDIF
      CALL GQNT(NTR,IER,TWIN,TVPT)
      EPS = FRATIO*(TWIN(4)-TWIN(3))/(TVPT(4)-TVPT(3))
C
C  Calculate the required number of points along the curve by using
C  the actual cubic parametric equations for the Bezier curve.  This
C  is done only if the subdivision algorithm is being overridden.
C
      IF (NPPC .GT. 1) THEN
        IF (NO .LT. NPPC) THEN
          WRITE(6,510) NPPC,NO
  510     FORMAT(' BCCURV -- Number of points specified for interpolatio
     -n along the curve = ',I5,',',/'           exceeds the array dimens
     -ion reserved for them =',I5,'.'/)
        ENDIF
        CALL BCFCRV(BXI,BYI,NPPC,XO,YO)
        NPTS = NPPC
        GO TO 110
      ENDIF
C
C  Initialize the Bezier point arrays.
C
      DO 20 J=1,MXCRV
        DO 30 K=1,4
          BZPTSX(K,J) = UNDEF
          BZPTSY(K,J) = UNDEF
   30   CONTINUE
   20 CONTINUE
C
C  Specify the input Bezier points as the initial curve in the array
C  of subdivided curves.
C
      DO 50 I=1,4
        BZPTSX(I,1) = BXI(I)
        BZPTSY(I,1) = BYI(I)
   50 CONTINUE
C
C  Continue curve subdivision until the flatness criterion is
C  satisfied or we are at the final level.
C
      DO 60 LEVEL=1,NLEV-1
C
C  Number of curves possible at this level.
C
        NUMCRV = 2**(LEVEL-1)
C
C  Calculate the increment between the points that will be stored in
C  the arrays if a curve satisfies the flatness criterion at this level.
C
        INC = MXCRV/(2**LEVEL)
C
C  Loop through the curves at this level and test for flatness;
C  NFLAT is a flag to indicate if all curves are flat at this level.
C
        NFLAT = 1
        DO 70 J=1,NUMCRV
          NDXO = 2*INC*(J-1)+1
          NDXL = NDXO
          NDXR = NDXL+INC
          IF (BZPTSX(1,NDXO) .NE. UNDEF) THEN
            DIST = BCFTOL(BZPTSX(1,NDXO),BZPTSY(1,NDXO))
            IF (DIST .GT. EPS) THEN
C
C  Curve is not flat, subdivide it.
C
              NFLAT = 0
              DO 100 K=1,4
                BZX(K) = BZPTSX(K,NDXO)
                BZY(K) = BZPTSY(K,NDXO)
  100         CONTINUE
              CALL BCSUBD(BZX,BZY,BZPTSX(1,NDXL),BZPTSY(1,NDXL),
     -                            BZPTSX(1,NDXR),BZPTSY(1,NDXR))
            ENDIF
          ENDIF
   70   CONTINUE
        IF (NFLAT .EQ. 1) GO TO 80
   60 CONTINUE
   80 CONTINUE
C
C  Collect the defined points into the output array.
C
      NPTS  = 1
      XO(1) = BZPTSX(1,1)
      YO(1) = BZPTSY(1,1)
      DO 90 I=1,MXCRV
        IF (BZPTSX(4,I) .NE. UNDEF) THEN
          NPTS = NPTS+1
          XO(NPTS) = BZPTSX(4,I)
          YO(NPTS) = BZPTSY(4,I)
        ENDIF
   90 CONTINUE
C
      IF (NO .LT. NPTS) THEN
        WRITE(6,510) NPTS,NO
        STOP
      ENDIF
C
  110 CONTINUE
      RETURN
C
      END


!> 通过简单的粒子间距与光滑长度相匹配进行最近相邻粒子搜索的子程序。详见第 4 章 148 页。
!>   subroutine to calculate the smoothing funciton for each particle and
!>   the interaction parameters used by the sph algorithm. interaction
!>   pairs are determined by directly comparing the particle distance
!>   with the corresponding smoothing length.
!>   see p.148 in chapter 4
subroutine direct_find(itimestep, ntotal, hsml, x, niac, pair_i, pair_j, w, dwdx, countiac)

    use sph_kind, only: rk
    use parameter
    implicit none

    !> 当前时间步
    !> current time step
    integer, intent(in) :: itimestep
    !> 在模拟中所使用的粒子总数
    !> number of particles in simulation
    integer, intent(in) :: ntotal
    !> 粒子的光滑长度
    !> smoothing length
    real(rk), intent(in) :: hsml(maxn)
    !> 粒子的坐标
    !> coordinates of all particles
    real(rk), intent(in) :: x(dim, maxn)
    !> 相互作用对的数目
    !> number of interaction pairs
    integer, intent(out) :: niac
    !> 相互作用对的第一个粒子
    !> first partner of interaction pair
    integer, intent(out) :: pair_i(max_interaction)
    !> 相互作用对的第二个粒子
    !> second partner of interaction pair
    integer, intent(out) :: pair_j(max_interaction)
    !> 给定相互作用对的光滑核函数
    !> kernel for all interaction pairs
    real(rk), intent(out) :: w(max_interaction)
    !> 核函数对 x, y, z 的导数
    !> derivative of kernel with respect to x, y and z
    real(rk), intent(out) :: dwdx(dim, max_interaction)
    !> 相互作用对的数目
    !> number of neighboring particles
    integer, intent(out) :: countiac(ntotal)

    integer :: i, j, d, sumiac, maxiac, miniac, noiac, maxp, minp, scale_k
    real(rk) :: dxiac(dim), driac, r, mhsml, tdwdx(dim)

    !> smoothing kernel function
    !> skf = 1, cubic spline kernel by w4 - spline (monaghan 1985)
    !>     = 2, gauss kernel   (gingold and monaghan 1981)
    !>     = 3, quintic kernel (morris 1997)
    if (skf == 1) then; scale_k = 2
    else if (skf == 2) then; scale_k = 3
    else if (skf == 3) then; scale_k = 3
    end if

    countiac(1:ntotal) = 0

    niac = 0

    do i = 1, ntotal - 1
        do j = i + 1, ntotal
            dxiac(1) = x(1, i) - x(1, j)
            driac = dxiac(1)*dxiac(1)
            do d = 2, dim
                dxiac(d) = x(d, i) - x(d, j)
                driac = driac + dxiac(d)*dxiac(d)
            end do
            mhsml = (hsml(i) + hsml(j))/2.0_rk
            if (sqrt(driac) < scale_k*mhsml) then
                if (niac < max_interaction) then

                    !> neighboring pair list, and totalinteraction number and
                    !> the interaction number for each particle

                    niac = niac + 1
                    pair_i(niac) = i
                    pair_j(niac) = j
                    r = sqrt(driac)
                    countiac(i) = countiac(i) + 1
                    countiac(j) = countiac(j) + 1

                    !> kernel and derivations of kernel

                    call kernel(r, dxiac, mhsml, w(niac), tdwdx)
                    do d = 1, dim
                        dwdx(d, niac) = tdwdx(d)
                    end do
                else
                    error stop ' >>> error <<< : too many interactions'
                end if
            end if
        end do
    end do

    !> statistics for the interaction

    sumiac = 0
    maxiac = 0
    miniac = 1000
    noiac = 0
    do i = 1, ntotal
        sumiac = sumiac + countiac(i)
        if (countiac(i) > maxiac) then
            maxiac = countiac(i)
            maxp = i
        end if
        if (countiac(i) < miniac) then
            miniac = countiac(i)
            minp = i
        end if
        if (countiac(i) == 0) noiac = noiac + 1
    end do

    if (mod(itimestep, print_step) == 0) then
        if (int_stat) then
            print *, ' >> statistics: interactions per particle:'
            print 100, '**** particle: ', maxp, '   maximal interactions: ', maxiac
            print 100, '**** particle: ', minp, '   minimal interactions: ', miniac
            print 101, '**** average : ', real(sumiac)/real(ntotal)
            print 100, '**** total pairs : ', niac
            print 100, '**** particles with no interactions: ', noiac
        end if
    end if

101 format(1x,*(a,g0.2))
100 format(1x,*(a,i0))

end subroutine direct_find


      SUBROUTINE EROY (ROTANG, XFRMT)

      REAL XFRMT (4,4), SN, CS, ROTANG

      CALL IDMAT (4, XFRMT)
      SN = SIN(ROTANG)
      CS = COS(ROTANG)
      XFRMT (1,1) =  CS
      XFRMT (3,3) =  CS
      XFRMT (1,3) =  SN
      XFRMT (3,1) = -SN

      END


!*******************************************************************
!> author: Akira Kageyama
!  license: MIT
!  date: 2020.01.22
!
!  流体場データ構造体
!
!  @note コードを簡潔にするため.curl.や.div.などの
!        ベクトル解析演算子をいったんは定義したが、いまは
!        それらの演算子を使う部分はコメントアウトしている。
!        一部のFortranコンパイラでこの部分の挙動が
!        怪しかったからである。
!        演習室のFortranコンパイラでは大丈夫かもしれないが未確認。
!
!  @note このバージョンでは古典的な関数呼び出しで
!        curlやdivなどを実行しているが、コメントを付け替える
!        だけで演算子（.curl.等）が使えるはず。
!
!  @note 配列演算を多用している。つまり一行で書かれている部分も
!        実際は3重do loopで書かれような大量の演算をしているところが
!        多い。このコードをOpenMP化する時には、そのような部分を
!        3重do loopに展開して書き直す必要がある。
!

module field_m
  use constants_m  ! 定数定義
  use grid_m       ! 格子点
  implicit none    ! 暗黙の型宣言無効化。必須

  public
    ! 通常はデフォルトを非公開（private）とするが、
    ! このモジュール内の変数・ルーチン等はデフォルトで公開。
  private :: & ![assignments]
             assignment_real_to_fluid,           &
             assignment_real_to_vector
  public  :: & ![operators]
             operator_cross_product,             &
             operator_curl,                      &
             operator_div,                       &
             operator_dot_product,               &
             operator_energyintegral,            &
             operator_fluid_add,                 &
             operator_fluid_times_real,          &
             operator_laplacian_scalar,          &
             operator_laplacian_vector,          &
             operator_real_times_fluid,          &
             operator_real_times_vector,         &
             operator_scalar_times_vector,       &
             operator_scalarintegral,            &
             operator_vector_add,                &
             operator_vector_divby_scalar,       &
             operator_vector_times_real,         &
             operator_vector_times_scalar
  private :: & ![routines]
             boundary_condition_fluid,           &
             boundary_condition_scalar,          &
             boundary_condition_vector

  interface field__boundary_condition
    !! 境界条件呼び出しルーチンの多重定義
    !! 境界条件を設定する変数の種類によって
    !! 実際に使用するルーチンが違うが、
    !! 呼び出し側では統一した名前でcallする。
    !! コンパイラは引数の型で使用するルーチンを
    !! 判断する。
    module procedure boundary_condition_fluid,  &
                     boundary_condition_scalar, &
                     boundary_condition_vector
  end interface

  !--- << Types >> ---!

  type field__vector3d_t
    !! 3次元ベクトル場構造体
    !! ここでは配列のサイズを決めているが、
    !! 実行時に不定にしたい場合はallocatable
    !! は配列を使えば良い。しミュレーション
    !! コード全体にサイズ（行数）がそれほど
    !! 多くない今のような場合は、配列サイズ
    !! （=シミュレーションの格子点数）を
    !! 変更する度にコンパイルしてもたいした
    !! 時間はかからないのでこのように
    !! 決め打ちにしても問題ない。
    real(DR), dimension(NX,NY,NZ) :: x  !! x成分
      ! 倍精度浮動小数点数（double real, DR）の
      ! 3次元配列、という意味。念の為。
    real(DR), dimension(NX,NY,NZ) :: y  !! y成分
    real(DR), dimension(NX,NY,NZ) :: z  !! z成分
  end type field__vector3d_t

  type field__fluid_t
    !! このシミュレーションコードで最も大事な
    !! 変数（構造体）。流体の状態を保持する。
    real(DR), dimension(NX,NY,NZ) :: pressure  !! 圧力場
    real(DR), dimension(NX,NY,NZ) :: density   !! 質量密度場
    type(field__vector3d_t)       :: flux      !! 質量フラックス
    ! 質量フラックス (flux) と速度場 (velocity_vector)
    !    flux = density * velocity_vector
    ! という関係がある。速度場を基本変数にしても問題ない。
    ! 単にこのシミュレーションで解く基本方程式
    ! ナビエ・ストークス方程式）の基本変数をどちらで
    ! 表現するか、の違いである。
  end type field__fluid_t

  !--- << Operators >> ---!

! interface operator(.curl.)
!    !! ベクトル解析のcurl演算子
!    module procedure operator_curl
! end interface
!
! interface operator(.div.)
!    !! ベクトル解析のdivergence演算子
!    module procedure operator_div
! end interface
!
! interface operator(.energyintegral.)
!    !! 全エネルギーを計算（体積積分）する演算子
!    module procedure operator_energyintegral
! end interface
!
! interface operator(.scalarintegral.)
!    !! 任意のスカラー場の体積積分をする演算子
!    module procedure operator_scalarintegral
! end interface
!
! interface operator(.laplacian.)
!    !! ラプラシアン演算子
!    !! スカラー場とベクトル場用の2つの多重定義
!    module procedure operator_laplacian_scalar
!    module procedure operator_laplacian_vector
! end interface
!
! interface operator(.x.)
!    !! ベクトル解析の外積演算子
!    module procedure operator_cross_product
! end interface
!
! interface operator(.dot.)
!    !! ベクトル解析の内積演算子
!    module procedure operator_dot_product
! end interface
!
! interface operator(+)
!    !! 構造体全要素の足し算を+記号で書けるように定義
!    module procedure operator_fluid_add
!    module procedure operator_vector_add
! end interface
!
! interface operator(/)
!    !! ベクトル場の3成分をあるスカラー場て割り算する
!    !! 操作は何度か出てくる（例えば質量フラックスfluxから
!    !! 速度場velocity_vectorを求めるときに
!    !! velocity_vector = flux / mass_density
!    !! という割り算が必要である）この計算を
!    !! スラッシュ記号一つで書けるように定義
!    module procedure operator_vector_divby_scalar
! end interface
!
! interface operator(*)
!    !! 各種構造体に掛け算記号が使えるように定義
!    module procedure operator_integer_times_fluid
!    module procedure operator_fluid_times_integer
!    module procedure operator_fluid_times_real
!    module procedure operator_real_times_fluid
!    module procedure operator_real_times_vector
!    module procedure operator_scalar_times_vector
!    module procedure operator_vector_times_real
!    module procedure operator_vector_times_scalar
! end interface
!
! interface assignment(=)
!    !! 各種構造体に代入記号が使えるように定義
!    module procedure assignment_real_to_fluid
!    module procedure assignment_real_to_vector
! end interface

contains

  subroutine assignment_real_to_fluid(fluid,real)
    !! 流体構造体に実数を代入。
    !! 初期条件ですべての要素を0にセットするときに使う。
    type(field__fluid_t), intent(out) :: fluid !! 流体場
    real(DR),             intent(in)  :: real  !! 代入する実数

    fluid%pressure(:,:,:) = real
    fluid%density(:,:,:)  = real
    fluid%flux%x(:,:,:)   = real
    fluid%flux%y(:,:,:)   = real
    fluid%flux%z(:,:,:)   = real
  end subroutine assignment_real_to_fluid

  subroutine assignment_real_to_vector(vector,real)
    !! ベクトル場に実数を代入。
    !! 初期条件で0にセットするときに使う。
    type(field__vector3d_t), intent(out) :: vector !! ベクトル場
    real(DR),                intent(in)  :: real   !! 代入する実数

    vector%x(:,:,:) = real
    vector%y(:,:,:) = real
    vector%z(:,:,:) = real
  end subroutine assignment_real_to_vector

  subroutine boundary_condition_fluid(fluid)
    !! 流体構造体の境界条件設定
    type(field__fluid_t), intent(inout) :: fluid !! 流体場

    call boundary_condition_scalar(fluid%pressure)
    call boundary_condition_scalar(fluid%density)
    call boundary_condition_vector(fluid%flux)
  end subroutine boundary_condition_fluid

  subroutine boundary_condition_scalar(scalar)
    !! スカラー場の境界条件設定
    real(DR), dimension(NX,NY,NZ), intent(inout) :: scalar !! スカラー場

    scalar( 1,:,:) = scalar(NX-1,:,:)
    scalar(NX,:,:) = scalar(   2,:,:)

    scalar(:, 1,:) = scalar(:,NY-1,:)
    scalar(:,NY,:) = scalar(:,   2,:)

    scalar(:,:, 1) = scalar(:,:,NZ-1)
    scalar(:,:,NZ) = scalar(:,:,   2)
  end subroutine boundary_condition_scalar

  subroutine boundary_condition_vector(vec)
    !! ベクトル場の境界条件設定
    type(field__vector3d_t), intent(inout) :: vec !! ベクトル場

    vec%x( 1,:,:) = vec%x(NX-1,:,:)    !-- yz-plane --!
    vec%y( 1,:,:) = vec%y(NX-1,:,:)
    vec%z( 1,:,:) = vec%z(NX-1,:,:)
    vec%x(NX,:,:) = vec%x(   2,:,:)
    vec%y(NX,:,:) = vec%y(   2,:,:)
    vec%z(NX,:,:) = vec%z(   2,:,:)

    vec%x(:, 1,:) = vec%x(:,NY-1,:)    !-- zx-plane --!
    vec%y(:, 1,:) = vec%y(:,NY-1,:)
    vec%z(:, 1,:) = vec%z(:,NY-1,:)
    vec%x(:,NY,:) = vec%x(:,   2,:)
    vec%y(:,NY,:) = vec%y(:,   2,:)
    vec%z(:,NY,:) = vec%z(:,   2,:)

    vec%x(:,:, 1) = vec%x(:,:,NZ-1)    !-- xy-plane --!
    vec%y(:,:, 1) = vec%y(:,:,NZ-1)
    vec%z(:,:, 1) = vec%z(:,:,NZ-1)
    vec%x(:,:,NZ) = vec%x(:,:,   2)
    vec%y(:,:,NZ) = vec%y(:,:,   2)
    vec%z(:,:,NZ) = vec%z(:,:,   2)
  end subroutine boundary_condition_vector

  function operator_cross_product(a,b)
    !! ベクトル場の外積
    type(field__vector3d_t), intent(in) :: a, b !! 掛けるベクトル場
    type(field__vector3d_t) :: operator_cross_product !! 外積

    operator_cross_product%x = (a%y)*(b%z) - (a%z)*(b%y)
    operator_cross_product%y = (a%z)*(b%x) - (a%x)*(b%z)
    operator_cross_product%z = (a%x)*(b%y) - (a%y)*(b%x)
  end function operator_cross_product

  function operator_curl(a)
    !! ベクトル場のcurl
    type(field__vector3d_t), intent(in) :: a !! これのcurlをとる
    type(field__vector3d_t) :: operator_curl !! curlした結果

    integer(SI) :: i, j, k
    real(DR) :: dx1, dy1, dz1

    dx1 = grid%d1%x  ! x方向の偏微分演算用定数
    dy1 = grid%d1%y  ! y方向の偏微分演算用定数
    dz1 = grid%d1%z  ! z方向の偏微分演算用定数

    do k = 2 , NZ-1
      ! 境界上の格子点を飛ばして、シミュレーション領域内部
      ! の格子点上で差分法によりcurlを計算する
      do j = 2 , NY-1
        do i = 2 , NX-1
          operator_curl%x(i,j,k) = dy1*(a%z(i,j+1,k)-a%z(i,j-1,k)) &
                                 - dz1*(a%y(i,j,k+1)-a%y(i,j,k-1))
          operator_curl%y(i,j,k) = dz1*(a%x(i,j,k+1)-a%x(i,j,k-1)) &
                                 - dx1*(a%z(i+1,j,k)-a%z(i-1,j,k))
          operator_curl%z(i,j,k) = dx1*(a%y(i+1,j,k)-a%y(i-1,j,k)) &
                                 - dy1*(a%x(i,j+1,k)-a%x(i,j-1,k))
        end do
      end do
    end do

    call boundary_condition_vector(operator_curl)
      ! 境界の格子点は境界条件ルーチンで設定する
  end function operator_curl

  function operator_div(a)
    !! ベクトル場のdivergence
    type(field__vector3d_t), intent(in)  :: a  !! これのdivをとる
    real(DR), dimension(NX,NY,NZ)        :: operator_div !! 結果

    integer(SI) :: i, j, k
    real(DR) :: dx1, dy1, dz1

    dx1 = grid%d1%x   ! x方向の偏微分演算用定数
    dy1 = grid%d1%y   ! y方向の偏微分演算用定数
    dz1 = grid%d1%z   ! z方向の偏微分演算用定数

    do k = 2 , NZ-1
      ! 境界上の格子点を飛ばして、シミュレーション領域内部
      ! の格子点上で差分法によりdivergenceを計算する
      do j = 2 , NY-1
         do i = 2 , NX-1
           operator_div(i,j,k) = dx1*(a%x(i+1,j,k)-a%x(i-1,j,k)) &
                               + dy1*(a%y(i,j+1,k)-a%y(i,j-1,k)) &
                               + dz1*(a%z(i,j,k+1)-a%z(i,j,k-1))
         end do
      end do
    end do

    call boundary_condition_scalar(operator_div)
      ! 境界の格子点は境界条件ルーチンで設定する
  end function operator_div

  function operator_dot_product(a,b)
    !! ベクトル場の内積
    type(field__vector3d_t), intent(in) :: a, b  !! 内積をとるベクトル場
    real(DR), dimension(NX,NY,NZ) :: operator_dot_product !! 計算結果

    operator_dot_product = a%x*b%x +a%y*b%y + a%z*b%z
      ! 配列演算
      !
      ! 実際にはここで3重do_loopが回っている
      ! OpenMP化するときにはこの簡潔な
      ! 書き方をやめて3重do_loopに書き直す必要がある。
  end function operator_dot_product

  function operator_energyintegral(a)
    !! 流体の運動エネルギーの体積積分
    type(field__fluid_t), intent(in) :: a  !! 流体場
    real(DR)                         :: operator_energyintegral !! 全エネルギー
      ! 以下のエネルギー密度の式を全空間で体積積分する
      ! flow_energy = (1/2) * rho * vel^2 = (1/2) * (massflux)^2 / rho
    real(DR) :: dvol
    real(DR), dimension(NX,NY,NZ) :: flux_sq  ! sq は2乗(squared)を意味する

    dvol = (grid%delta%x)*(grid%delta%y)*(grid%delta%z)
         ! 現在のシュミレーションでは格子間隔はx, y, z それぞれに
         ! 一様であることを仮定している。つまりdx, dy, dzは空間位置に
         ! 依存せず一定である。

!   flux_sq = (a%flux).dot.(a%flux)
    flux_sq = operator_dot_product(a%flux,a%flux)
      ! 質量フラックスの2乗を一時的な配列にセットする
      ! ユーザ定義演算子が使えるコンパイラならば.dot.を
      ! 使った表記のほうが読みやすいであろう。

    operator_energyintegral                                      &
         = 0.5_DR * sum(    flux_sq(2:NX-1,2:NY-1,2:NZ-1)        &
                        / a%density(2:NX-1,2:NY-1,2:NZ-1)        &
                        ) * dvol
      ! ここで配列演算の添字が1からNXではなく2からNX-1などに
      ! 限定されていることに注意。これは体積積分の範囲を計算領域の
      ! 内部に限定していること、つまり境界上の格子点を除いて
      ! 積分していることを意味する。境界上の格子点まで
      ! 入れると重複してカウントしてしまうからである
  end function operator_energyintegral

  function operator_fluid_add(a,b)
    !! 流体構造体の足し算演算子
    type(field__fluid_t), intent(in) :: a, b   !! 足し算する2つの流体場
    type(field__fluid_t) :: operator_fluid_add !! 計算結果

    operator_fluid_add%flux%x   = a%flux%x   + b%flux%x
    operator_fluid_add%flux%y   = a%flux%y   + b%flux%y
    operator_fluid_add%flux%z   = a%flux%z   + b%flux%z
    operator_fluid_add%density  = a%density  + b%density
    operator_fluid_add%pressure = a%pressure + b%pressure
  end function operator_fluid_add

  function operator_fluid_times_integer(fluid,integer)
    !! 流体構造体を整数倍するための演算子
    type(field__fluid_t), intent(in) :: fluid    !! 流体場
    integer(SI),          intent(in) :: integer  !! かける整数
    type(field__fluid_t) :: operator_fluid_times_integer

    operator_fluid_times_integer%pressure = integer*(fluid%pressure)
    operator_fluid_times_integer%density  = integer*(fluid%density)
    operator_fluid_times_integer%flux%x   = integer*(fluid%flux%x)
    operator_fluid_times_integer%flux%y   = integer*(fluid%flux%y)
    operator_fluid_times_integer%flux%z   = integer*(fluid%flux%z)
  end function operator_fluid_times_integer

  function operator_fluid_times_real(fluid,real)
    !! 流体構造体を実数倍するための演算子
    type(field__fluid_t), intent(in) :: fluid    !! 流体場
    real(DR),             intent(in) :: real     !! かける実数
    type(field__fluid_t) :: operator_fluid_times_real  !! 計算結果

    operator_fluid_times_real%pressure = real*(fluid%pressure)
    operator_fluid_times_real%density  = real*(fluid%density)
    operator_fluid_times_real%flux%x   = real*(fluid%flux%x)
    operator_fluid_times_real%flux%y   = real*(fluid%flux%y)
    operator_fluid_times_real%flux%z   = real*(fluid%flux%z)
  end function operator_fluid_times_real

  function operator_integer_times_fluid(integer,fluid)
    !! 整数に流体構造体を掛け算するための演算子
    integer(SI),          intent(in) :: integer  !! かける整数
    type(field__fluid_t), intent(in) :: fluid    !! 流体場
    type(field__fluid_t) :: operator_integer_times_fluid  !! 計算結果

    operator_integer_times_fluid%pressure = integer*(fluid%pressure)
    operator_integer_times_fluid%density  = integer*(fluid%density)
    operator_integer_times_fluid%flux%x   = integer*(fluid%flux%x)
    operator_integer_times_fluid%flux%y   = integer*(fluid%flux%y)
    operator_integer_times_fluid%flux%z   = integer*(fluid%flux%z)
  end function operator_integer_times_fluid

  function operator_laplacian_scalar(a)
    !! スカラー場のラプラシアン
    real(DR), dimension(NX,NY,NZ), intent(in) :: a  !! 入力スカラー場
    real(DR), dimension(NX,NY,NZ) :: operator_laplacian_scalar !! 計算結果

    integer(SI) :: i, j, k
    real(DR) :: dx2, dy2, dz2

    dx2 = grid%d2%x   ! x方向の2階偏微分演算用定数
    dy2 = grid%d2%y   ! y方向の2階偏微分演算用定数
    dz2 = grid%d2%z   ! z方向の2階偏微分演算用定数

    do k = 2 , NZ-1
      ! 境界上の格子点を飛ばして、シミュレーション領域内部
      ! の格子点上で差分法により計算する
      do j = 2 , NY-1
        do i = 2 , NX-1
          operator_laplacian_scalar(i,j,k)  &
               = dx2*(a(i+1,j,k)-2*a(i,j,k)+a(i-1,j,k))  &
               + dy2*(a(i,j+1,k)-2*a(i,j,k)+a(i,j-1,k))  &
               + dz2*(a(i,j,k+1)-2*a(i,j,k)+a(i,j,k-1))
        end do
      end do
    end do

    call boundary_condition_scalar(operator_laplacian_scalar)
      ! 境界の格子点は境界条件ルーチンで設定する
  end function operator_laplacian_scalar

  function operator_laplacian_vector(a)
    !! ベクトル場のラプラシアン
    type(field__vector3d_t), intent(in) :: a  !! 入力ベクトル場
    type(field__vector3d_t) :: operator_laplacian_vector !! 計算結果

    integer(SI) :: i, j, k
    real(DR) :: dx2, dy2, dz2

    dx2 = grid%d2%x   ! x方向の2階偏微分演算用定数
    dy2 = grid%d2%y   ! y方向の2階偏微分演算用定数
    dz2 = grid%d2%z   ! z方向の2階偏微分演算用定数

    do k = 2 , NZ-1
      ! 境界上の格子点を飛ばして、シミュレーション領域内部
      ! の格子点上で差分法により計算する
      do j = 2 , NY-1
        do i = 2 , NX-1
          operator_laplacian_vector%x(i,j,k)  &
               = dx2*(a%x(i+1,j,k)-2*a%x(i,j,k)+a%x(i-1,j,k))  &
               + dy2*(a%x(i,j+1,k)-2*a%x(i,j,k)+a%x(i,j-1,k))  &
               + dz2*(a%x(i,j,k+1)-2*a%x(i,j,k)+a%x(i,j,k-1))
          operator_laplacian_vector%y(i,j,k)  &
               = dx2*(a%y(i+1,j,k)-2*a%y(i,j,k)+a%y(i-1,j,k))  &
               + dy2*(a%y(i,j+1,k)-2*a%y(i,j,k)+a%y(i,j-1,k))  &
               + dz2*(a%y(i,j,k+1)-2*a%y(i,j,k)+a%y(i,j,k-1))
          operator_laplacian_vector%z(i,j,k)  &
               = dx2*(a%z(i+1,j,k)-2*a%z(i,j,k)+a%z(i-1,j,k))  &
               + dy2*(a%z(i,j+1,k)-2*a%z(i,j,k)+a%z(i,j-1,k))  &
               + dz2*(a%z(i,j,k+1)-2*a%z(i,j,k)+a%z(i,j,k-1))
        end do
     end do
    end do

    call boundary_condition_vector(operator_laplacian_vector)
      ! 境界の格子点は境界条件ルーチンで設定する
  end function operator_laplacian_vector

  function operator_real_times_fluid(real,fluid)
    !! 実数に流体場を掛ける演算子
    real(DR),             intent(in) :: real  !! 掛ける実数
    type(field__fluid_t), intent(in) :: fluid !! 流体場
    type(field__fluid_t) :: operator_real_times_fluid !! 計算結果

    operator_real_times_fluid%pressure = real*(fluid%pressure)
    operator_real_times_fluid%density  = real*(fluid%density)
    operator_real_times_fluid%flux%x   = real*(fluid%flux%x)
    operator_real_times_fluid%flux%y   = real*(fluid%flux%y)
    operator_real_times_fluid%flux%z   = real*(fluid%flux%z)
  end function operator_real_times_fluid

  function operator_real_times_vector(real,vec)
    !! 実数にベクトル場を掛ける演算子
    real(DR),                intent(in) :: real !! 掛ける実数
    type(field__vector3d_t), intent(in) :: vec  !! 流体場
    type(field__vector3d_t) :: operator_real_times_vector !! 計算結果

    operator_real_times_vector%x = real*(vec%x)
    operator_real_times_vector%y = real*(vec%y)
    operator_real_times_vector%z = real*(vec%z)
  end function operator_real_times_vector

  function operator_scalar_times_vector(scalar,vec)
    !! スカラー場にベクトル場を掛ける演算子
    real(DR), dimension(NX,NY,NZ), intent(in) :: scalar  !! スカラー場
    type(field__vector3d_t),       intent(in) :: vec     !! ベクトル場
    type(field__vector3d_t) :: operator_scalar_times_vector !! 計算結果

    operator_scalar_times_vector%x = scalar*(vec%x)
    operator_scalar_times_vector%y = scalar*(vec%y)
    operator_scalar_times_vector%z = scalar*(vec%z)
  end function operator_scalar_times_vector

  function operator_scalarintegral(a)
    !! スカラー場の体積積分演算子
    real(DR), dimension(NX,NY,NZ), intent(in) :: a  !! スカラー場
    real(DR) :: operator_scalarintegral             !! 体積積分結果

    real(DR) :: dvol

    dvol = (grid%delta%x)*(grid%delta%y)*(grid%delta%z)
         ! 現在のシュミレーションでは格子間隔はx, y, z それぞれに
         ! 一様であることを仮定している。つまりdx, dy, dzは空間位置に
         ! 依存せず一定である。
    operator_scalarintegral = sum( a(2:NX-1,2:NY-1,2:NZ-1) ) * dvol
      ! ここで配列演算の添字が1からNXではなく2からNX-1などに
      ! 限定されていることに注意。これは体積積分の範囲を計算領域の
      ! 内部に限定していること、つまり境界上の格子点を除いて
      ! 積分していることを意味する。境界上の格子点まで
      ! 入れると重複してカウントしてしまうからである
  end function operator_scalarintegral

  function operator_vector_add(a,b)
    !! ベクトル場の和の演算子
    type(field__vector3d_t), intent(in) :: a, b    !! 和をとるベクトル場
    type(field__vector3d_t) :: operator_vector_add !! 計算結果

    operator_vector_add%x = a%x + b%x
    operator_vector_add%y = a%y + b%y
    operator_vector_add%z = a%z + b%z
  end function operator_vector_add

  function operator_vector_divby_scalar(vec,scalar)
    !! ベクトル場の各成分をスカラー場で割る
    type(field__vector3d_t),       intent(in) :: vec    !! ベクトル場
    real(DR), dimension(NX,NY,NZ), intent(in) :: scalar !! スカラー場
    type(field__vector3d_t) :: operator_vector_divby_scalar !! 計算結果

    operator_vector_divby_scalar%x = (vec%x) / scalar
    operator_vector_divby_scalar%y = (vec%y) / scalar
    operator_vector_divby_scalar%z = (vec%z) / scalar
  end function operator_vector_divby_scalar

  function operator_vector_times_real(vec,real)
    !! ベクトル場の実数倍の演算子
    type(field__vector3d_t), intent(in) :: vec  !! ベクトル場
    real(DR),                intent(in) :: real !! 掛ける実数
    type(field__vector3d_t) :: operator_vector_times_real  !! 計算結果

    operator_vector_times_real%x = real*(vec%x)
    operator_vector_times_real%y = real*(vec%y)
    operator_vector_times_real%z = real*(vec%z)
  end function operator_vector_times_real

  function operator_vector_times_scalar(vec,scalar)
    !! ベクトル場にスカラー場を掛ける
    type(field__vector3d_t),       intent(in) :: vec    !! ベクトル場
    real(DR), dimension(NX,NY,NZ), intent(in) :: scalar !! スカラー場
    type(field__vector3d_t) :: operator_vector_times_scalar  !! 計算結果

    operator_vector_times_scalar%x = scalar*(vec%x)
    operator_vector_times_scalar%y = scalar*(vec%y)
    operator_vector_times_scalar%z = scalar*(vec%z)
  end function operator_vector_times_scalar

end module field_m