MODULE Matrix_Exponential
!     DMEXP COMPUTES EXP(A) AND STORES IT IN Z WHERE A IS A MATRIX
!     OF ORDER N.  A IS DESTROYED BY THE ROUTINE.

! Reference:
! Ward, Robert C. (1977) 'Numerical computation of the matrix exponential with
! accuracy estimate', SIAM J. Numerical Analysis, vol.14, pp. 600-610.

! Code converted using TO_F90 by Alan Miller
! Date: 2002-12-19  Time: 10:46:30

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

CONTAINS

SUBROUTINE dmexp(a, n, z, ierr)
! Arguments KA, KZ & WK has been removed.

INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(OUT)  :: a(:,:)
REAL (dp), INTENT(OUT)  :: z(:,:)
INTEGER, INTENT(OUT)    :: ierr

REAL (dp) :: anorm, anorm1, factor, p, q, s, s1, wk(n,n+12)
INTEGER   :: i, igh, j, k, kp1, l, ll, low, m, np1, np10

! ----------------------------------------------------------------------
!     DMEXP COMPUTES EXP(A) AND STORES IT IN Z WHERE A IS A MATRIX
!     OF ORDER N.  A IS DESTROYED BY THE ROUTINE.

!     WK IS AN ARRAY OF DIMENSION (N,N+12).  WK IS A WORK SPACE
!     FOR THE ROUTINE.

!     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
!        IERR = 0  EXP(A) WAS SUCCESSFULLY COMPUTED.
!        IERR = 1  THE NORM OF A IS TOO LARGE.
!        IERR = 2  THE PADE DENOMINATOR MATRIX IS SINGULAR.

!     WRITTEN BY ALFRED H. MORRIS
!        NAVAL SURFACE WEAPONS CENTER
!        DAHLGREN VIRGINIA
!     ---------------
!     COEFFICIENTS FOR (12,12) PADE TABLE ENTRY
!     ---------------

REAL (dp), PARAMETER  :: c(12) = (/  &
  .500000000000000000000000000000D+00, .119565217391304347826086956522D+00,  &
  .181159420289855072463768115942D-01, .194099378881987577639751552795D-02,  &
  .155279503105590062111801242236D-03, .953470633104500381388253241800D-05,  &
  .454033634811666848280120591333D-06, .166924130445465753044161982108D-07,  &
  .463678140126293758456005505855D-09, .927356280252587516912011011710D-11,  &
  .120435880552284093105455975547D-12, .772024875335154442983692150941D-15 /)
! ----------------------------------------------------------------------

ierr = 0
IF (n <= 1) THEN
  z(1,1) = EXP(a(1,1))
  RETURN
END IF

!       BALANCE A AND SELECT THE SMALLER OF THE 1-NORM
!              AND INFINITY-NORM OF THE RESULT

CALL dbal(n, a, low, igh, wk(1:n,n+12))
anorm = 0.d0
anorm1 = 0.d0
DO  j = 1, n
  s = 0.d0
  s1 = 0.d0
  DO  i = 1, n
    s = s + ABS(a(j,i))
    s1 = s1 + ABS(a(i,j))
  END DO
  anorm = MAX(s,anorm)
  anorm1 = MAX(s1,anorm1)
END DO

anorm = MIN(anorm,anorm1)
s = anorm + 0.1D0
IF (s /= anorm) THEN

!              SELECT THE NORMALIZATION FACTOR

  m = 0
  IF (anorm > 1.d0) THEN
    factor = 1.d0
    30 m = m + 1
    factor = 2.d0 * factor
    IF (anorm > factor) GO TO 30

!                NORMALIZE THE MATRIX A

    a(1:n,1:n) = a(1:n,1:n) / factor
  END IF

  np1 = n + 1
  np10 = n + 10
  DO  j = 1, n

!     COMPUTE THE J-TH COLUMN OF THE FIRST 12 POWERS OF A

    DO  i = 1, n
      s = 0.d0
      DO  l = 1, n
        s = s + a(i,l) * a(l,j)
      END DO
      wk(i,np1) = s
    END DO

    DO  k = np1, np10
      kp1 = k + 1
      DO  i = 1, n
        s = 0.d0
        DO  l = 1, n
          s = s + a(i,l) * wk(l,k)
        END DO
        wk(i,kp1) = s
      END DO
    END DO

!     COMPUTE THE J-TH COLUMN OF THE NUMERATOR AND DENOMINATOR
!                  OF THE PADE APPROXIMATION

    DO  i = 1, n
      p = 0.d0
      q = 0.d0
      k = 12
      l = n + 11
      DO  ll = 1, 11
        s = c(k) * wk(i,l)
        p = s + p
        q = s - q
        k = k - 1
        l = l - 1
      END DO
      s = c(1) * a(i,j)
      z(i,j) = p + s
      wk(i,j) = q - s
      IF (i == j) THEN
        z(i,j) = z(i,j) + 1.d0
        wk(i,j) = wk(i,j) + 1.d0
      END IF
    END DO
  END DO

!        CALCULATE EXP(A) BY SOLVING  WK * EXP(A) = Z

  CALL dpslv(n, n, wk, z, ierr)
  IF (ierr /= 0) GO TO 200
  IF (m /= 0) THEN

!          TAKE OUT THE EFFECT OF THE NORMALIZATION
!                   OPERATION ON EXP(A)

    DO  k = 1, m
      DO  j = 1, n
        DO  i = 1, n
          s = 0.d0
          DO  l = 1, n
            s = s + z(i,l) * z(l,j)
          END DO
          wk(i,j) = s
        END DO
      END DO

      z(1:n,1:n) = wk(1:n,1:n)
    END DO
  END IF

!            TAKE OUT THE EFFECT OF THE BALANCING
!                   OPERATION ON EXP(A)

  CALL dbalnv(n, z, low, igh, wk(1:n,n+12))
  RETURN
END IF

!                     ERROR RETURN

ierr = 1
RETURN
200 ierr = 2
RETURN
END SUBROUTINE dmexp

SUBROUTINE dbal(n, a, low, igh, scale)
! Argument NM has been removed.

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: a(:,:)
INTEGER, INTENT(OUT)       :: low
INTEGER, INTENT(OUT)       :: igh
REAL (dp), INTENT(OUT)     :: scale(:)

INTEGER :: i, j, k, l, m, jj, iexc, radix

REAL (dp) :: c, f, g, r, s, b2
LOGICAL   :: noconv, skip
!-----------------------------------------------------------------------

!     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE,
!     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
!     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).

!     DBAL BALANCES A REAL (dp) REAL MATRIX AND ISOLATES
!     EIGENVALUES WHENEVER POSSIBLE.

!     ON INPUT-

!        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL ARRAY
!          PARAMETERS AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT,

!        N IS THE ORDER OF THE MATRIX,

!        A CONTAINS THE INPUT MATRIX TO BE BALANCED.

!     ON OUTPUT-

!        A CONTAINS THE BALANCED MATRIX,

!        LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J) IS EQUAL TO ZERO IF
!           (1) I IS GREATER THAN J AND
!           (2) J=1,...,LOW-1 OR I=IGH+1,...,N,

!        SCALE CONTAINS INFORMATION DETERMINING THE
!           PERMUTATIONS AND SCALING FACTORS USED.

!     SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
!     HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
!     WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
!     OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J).  THEN
!        SCALE(J) = P(J),    FOR J = 1,...,LOW-1
!                 = D(J,J),      J = LOW,...,IGH
!                 = P(J)         J = IGH+1,...,N.
!     THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
!     THEN 1 TO LOW-1.

!     NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.

!     THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN
!     DBAL IN LINE.  (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
!     K,L HAVE BEEN REVERSED.)

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

!     ********** RADIX IS A MACHINE DEPENDENT PARAMETER SPECIFYING
!                THE BASE OF THE MACHINE FLOATING POINT REPRESENTATION.

radix = 2
b2 = radix ** 2
k = 1
l = n
GO TO 50

!     ********** IN-LINE PROCEDURE FOR ROW AND COLUMN EXCHANGE **********
10 scale(m) = j
IF (j /= m) THEN

  DO  i = 1, l
    f = a(i,j)
    a(i,j) = a(i,m)
    a(i,m) = f
  END DO

  DO  i = k, n
    f = a(j,i)
    a(j,i) = a(m,i)
    a(m,i) = f
  END DO
END IF

SELECT CASE ( iexc )
  CASE (    1)
    GO TO 40
  CASE (    2)
    GO TO 80
END SELECT

!     ***** SEARCH FOR ROWS ISOLATING AN EIGENVALUE AND PUSH THEM DOWN *****
40 IF (l == 1) GO TO 200
l = l - 1
!     ********** FOR J=L STEP -1 UNTIL 1 DO -- **********
skip = .FALSE.
50 DO  jj = 1, l
  j = l + 1 - jj

  DO  i = 1, l
    IF (i /= j) THEN
      IF (a(j,i) /= 0.d0) THEN
        skip = .TRUE.
        EXIT
      END IF
    END IF
  END DO
  IF (skip) CYCLE

  m = l
  iexc = 1
  GO TO 10
END DO

GO TO 90
!     **** SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE AND PUSH THEM LEFT ****
80 k = k + 1

90 skip = .FALSE.
DO  j = k, l

  DO  i = k, l
    IF (i /= j) THEN
      IF (a(i,j) /= 0.d0) THEN
        skip = .TRUE.
        EXIT
      END IF
    END IF
  END DO
  IF (skip) CYCLE

  m = k
  iexc = 2
  GO TO 10
END DO

!     ********** NOW BALANCE THE SUBMATRIX IN ROWS K TO L **********
scale(k:l) = 1.d0
!     ********** ITERATIVE LOOP FOR NORM REDUCTION **********
130 noconv = .false.

DO  i = k, l
  c = 0.d0
  r = 0.d0

  DO  j = k, l
    IF (j /= i) THEN
      c = c + ABS(a(j,i))
      r = r + ABS(a(i,j))
    END IF
  END DO
!     ********** GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW **********
  IF (c /= 0.d0 .AND. r /= 0.d0) THEN
    g = r / radix
    f = 1.d0
    s = c + r
    150 IF (c < g) THEN
      f = f * radix
      c = c * b2
      GO TO 150
    END IF
    g = r * radix
    160 IF (c >= g) THEN
      f = f / radix
      c = c / b2
      GO TO 160
    END IF
!     ********** NOW BALANCE **********
    IF ((c+r)/f < 0.95D0*s) THEN
      g = 1.d0 / f
      scale(i) = scale(i) * f
      noconv = .true.

      DO  j = k, n
        a(i,j) = a(i,j) * g
      END DO

      DO  j = 1, l
        a(j,i) = a(j,i) * f
      END DO
    END IF
  END IF

END DO

IF (noconv) GO TO 130

200 low = k
igh = l
RETURN
END SUBROUTINE dbal

SUBROUTINE dbalnv(n, z, low, igh, scale)
! Argument NZ has been removed.

INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(OUT)  :: z(:,:)
INTEGER, INTENT(IN)     :: low
INTEGER, INTENT(IN)     :: igh
REAL (dp), INTENT(IN)   :: scale(:)

INTEGER   :: i, j, k, ii
REAL (dp) :: s

!-----------------------------------------------------------------------
!        GIVEN A MATRIX A OF ORDER N. DBAL TRANSFORMS A INTO THE MATRIX B
!     BY THE SIMILARITY TRANSFORMATION
!             B = D**(-1)*TRANSPOSE(P)*A*P*D
!     WHERE D IS A DIAGONAL MATRIX AND P A PERMUTATION MATRIX.
!     THE INFORMATION CONCERNING D AND P IS STORED IN IGH, LOW, AND SCALE.
!     THE ORDER IN WHICH THE INTERCHANGES WERE MADE IS N TO IGH + 1,
!     AND THEN 1 TO LOW - 1.

!        Z IS A MATRIX OF ORDER N. DBALNV TRANSFORMS Z INTO THE
!     MATRIX W USING THE INVERSE SIMILARITY TRANSFORM
!             W = P*D*Z*D**(-1)*TRANSPOSE(P)

!     ON INPUT-

!        NZ IS THE ROW DIMENSION OF THE MATRIX Z IN THE CALLING PROGRAM,

!        N IS THE ORDER OF THE MATRIX,

!        LOW AND IGH ARE INTEGERS DETERMINED BY  DBAL,

!        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
!          AND SCALING FACTORS USED BY  DBAL,

!     ON OUTPUT-

!        Z CONTAINS THE TRANSFORMED MATRIX W

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

IF (igh /= low) THEN

  DO  i = low, igh
    s = scale(i)
    z(i,1:n) = z(i,1:n) * s
  END DO

  DO  j = low, igh
    s = 1.d0 / scale(j)
    z(1:n,j) = z(1:n,j) * s
  END DO
END IF

!     ********- FOR I=LOW-1 STEP -1 UNTIL 1,
!               IGH+1 STEP 1 UNTIL N DO -- **********

DO  ii = 1, n
  i = ii
  IF (i < low.OR.i > igh) THEN
    IF (i < low) i = low - ii
    k = scale(i)
    IF (k /= i) THEN

      DO  j = 1, n
        s = z(i,j)
        z(i,j) = z(k,j)
        z(k,j) = s
      END DO

      DO  j = 1, n
        s = z(j,i)
        z(j,i) = z(j,k)
        z(j,k) = s
      END DO
    END IF
  END IF
END DO
RETURN
END SUBROUTINE dbalnv

SUBROUTINE dpslv(n, m, a, b, ierr)
! Arguments KA & KB have been removed.

INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: m
REAL (dp), INTENT(IN OUT)  :: a(:,:)
REAL (dp), INTENT(IN OUT)  :: b(:,:)
INTEGER, INTENT(OUT)       :: ierr

REAL (dp) :: p, t
INTEGER   :: i, j, k, km1, kp1, l, nm1

!     ------------------------------------------------------------------
!     PARTIAL PIVOT SOLUTION OF A*X = B WHERE A IS A MATRIX OF
!     ORDER N AND B IS A MATRIX HAVING N ROWS AND M COLUMNS.
!     THE SOLUTION MATRIX X IS STORED IN B.

!     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
!        IERR = 0   THE EQUATIONS HAVE BEEN SOLVED.
!        IERR = J   THE J-TH PIVOT ELEMENT WAS FOUND TO BE 0.
!     ------------------------------------------------------------------
ierr = 0
nm1 = n - 1
IF (nm1 /= 0) THEN
  DO  k = 1, nm1

!     SEARCH FOR THE K-TH PIVOT ELEMENT

    p = 0.d0
    DO  i = k, n
      t = ABS(a(i,k))
      IF (p < t) THEN
        p = t
        l = i
      END IF
    END DO
    IF (p == 0.d0) GO TO 120
    IF (k /= l) THEN

!     INTERCHANGE ROWS K AND L

      DO  j = k, n
        t = a(k,j)
        a(k,j) = a(l,j)
        a(l,j) = t
      END DO
      DO  j = 1, m
        t = b(k,j)
        b(k,j) = b(l,j)
        b(l,j) = t
      END DO
    END IF

!     ELIMINATE THE COEFFICIENTS OF X(K) IN ROWS I = K+1,...,N

    p = a(k,k)
    kp1 = k + 1
    DO  i = kp1, n
      t = a(i,k) / p
      DO  j = kp1, n
        a(i,j) = a(i,j) - t * a(k,j)
      END DO
      DO  j = 1, m
        b(i,j) = b(i,j) - t * b(k,j)
      END DO
    END DO
  END DO
  IF (a(n,n) == 0.d0) GO TO 130

!     BACKSOLVE THE TRIANGULAR SET OF EQUATIONS

  DO  j = 1, m
    k = n
    km1 = nm1
    DO  l = 2, n
      b(k,j) = b(k,j) / a(k,k)
      t = b(k,j)
      DO  i = 1, km1
        b(i,j) = b(i,j) - t * a(i,k)
      END DO
      k = km1
      km1 = k - 1
    END DO
    b(1,j) = b(1,j) / a(1,1)
  END DO
  RETURN
END IF

!     CASE WHEN N = 1

IF (a(1,1) /= 0.d0) THEN
  b(1,1:m) = b(1,1:m) / a(1,1)
  RETURN
END IF

!     ERROR RETURN

ierr = 1
RETURN
120 ierr = k
RETURN
130 ierr = n
RETURN
END SUBROUTINE dpslv

END MODULE Matrix_Exponential


      subroutine ttWprod(p1,p2,m)
      implicit none
C-----Calculate the amplitudes for the process
C-----q(p1)+qb(p2)--> t(p3)+a(p4)+l(p5)+l~(p6)
C-----amplitude stripped of an overall factor of gw^2*gs^2*t(CA)*T(CA)
C-----with Tr (t^ca t^cb)=\delta(ca,cb)
C-----and   k3=+bp/beta*p3-bm/beta*p4
C-----      k4=-bm/beta*p3+bp/beta*p4
C-----      p3=bp*k5+bm*k6
C-----      p4=bm*k5+bp*k6
      include 'constants.f'
      include 'zprods_com.f'
      include 'sprods_com.f'
      include 'masses.f'
      integer p1,p2,p3,p4,p5,p6,k3,k4
      double complex m(2,2),zba2
      double precision s156,s256
      parameter(p5=3,p6=4,k3=5,k4=6)
C---Statement function
      zba2(p1,p2,p3,p4)=zb(p1,p2)*za(p2,p4)+zb(p1,p3)*za(p3,p4)
C---End statement function
      s156=s(p1,p5)+s(p1,p6)+s(p5,p6)
      s256=s(p2,p5)+s(p2,p6)+s(p5,p6)

      m(2,2)=mt/(s(k3,k4)*s(p5,p6)*s256) * (
     &      -za(p2,p5)*zb(p1,k3)/za(k3,k4)*zba2(p6,p2,p5,k3)
     &      +za(p2,p5)*zb(p1,k4)/za(k3,k4)*zba2(p6,p2,p5,k4))
     &      +mt/(s(k3,k4)*s(p5,p6)*s156) * (
     &      +za(p2,k3)*zb(p1,p6)/za(k3,k4)*zba2(k3,p1,p6,p5)
     &      -za(p2,k4)*zb(p1,p6)/za(k3,k4)*zba2(k4,p1,p6,p5))

      m(1,2)=
     & (-za(p2,p5)*zb(p1,k4)*zba2(p6,p2,p5,k3))/(s(k3,k4)*s(p5,p6)*s256)
     &+(+za(p2,k3)*zb(p1,p6)*zba2(k4,p1,p6,p5))/(s(k3,k4)*s(p5,p6)*s156)

       m(2,1) =
     & (-za(p2,p5)*zb(p1,k3)*zba2(p6,p2,p5,k4))/(s(k3,k4)*s(p5,p6)*s256)
     &+(+za(p2,k4)*zb(p1,p6)*zba2(k3,p1,p6,p5))/(s(k3,k4)*s(p5,p6)*s156)

       m(1,1)=mt/(s(k3,k4)*s(p5,p6)*s256) * (
     &       -za(p2,p5)*zb(p1,k3)/zb(k3,k4)*zba2(p6,p2,p5,k3)
     &       +za(p2,p5)*zb(p1,k4)/zb(k3,k4)*zba2(p6,p2,p5,k4))
     &       +mt/(s(k3,k4)*s(p5,p6)*s156) * (
     &       +za(p2,k3)*zb(p1,p6)/zb(k3,k4)*zba2(k3,p1,p6,p5)
     &       -za(p2,k4)*zb(p1,p6)/zb(k3,k4)*zba2(k4,p1,p6,p5))

      return
      end


!---------------------------------------------------------------------------------------------------
! All the formulations  have been taken from the original
! article,the Span-Wagner EoS for CO2.
! The EoS has been published in J. Phys. Chem. Ref. Data, Vol.25,
! pp. 1509-1596, 1996.
!---------------------------------------------------------------------------------------------------

!--------------------------------------------------------------------------------------------------
! MODULE   properties
! @brief   Compute thermodynamic properties  in IS p.1517 Table3:
!          Pressure, specific internal energy , specific Cv, specific Cp, speed of sound,
!          specific entropy, specific helmholtz energy, specific gibbs energy
! @routine helmholtz_deriv.f90, helmholtz_dimless.f90
! @authors Yu Fang
! @date    10-02-2017
! NOTE: derivatives are added 27/11/2017
!--------------------------------------------------------------------------------------------------

MODULE properties
!
       USE def_constants
!
       USE def_variables, ONLY: saturP, saturP_sat, vL_psat_spline, vV_psat_spline,&
&                             uL_psat_spline, uV_psat_spline, Tsat_psat_spline,  &
&                             saturP2, saturP_sat2, vL_psat_spline2, vV_psat_spline2,&
&                             uL_psat_spline2, uV_psat_spline2, Tsat_psat_spline2
       IMPLICIT NONE
!
       PRIVATE
       PUBLIC :: pressure, inter_energy, heat_cap_v, heat_cap_p,dpdv_T, dpdT_v,&
&                sound_speed, entropy, helmho, gibbs,dpdu_v, dpdr_u, satprop, satderiv, axlpress,&
&                dedr_T
       CONTAINS
!
!
!===============================================================================================
       SUBROUTINE pressure(T,v,p)  !Pa
!===============================================================================================
        IMPLICIT NONE
!
!IN/OUT
        REAL(pr) :: T,v
        REAL(pr) :: p
!LOCAL
        REAL(pr) :: rho,delt
!
!for helmholtz_deriv
!
        REAL(pr) :: phi_r_ddelt, phi_r_dtau,&
                    phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau
!Pre-compute
!
        rho      = 1_pr  / v
        delt     = 1_pr   / (rho_cr*v)
!
        CALL helmholtz_deriv( T, v, phi_r_ddelt, phi_r_dtau,&
                            phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!       print*, phi_r_ddelt, phi_r_dtau,phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau
!
        p = (1_pr + delt * phi_r_ddelt) * R * T * rho
!
       END SUBROUTINE pressure
!
!=================================================================================================
       SUBROUTINE inter_energy(T,v,e) !J/kg
!=================================================================================================
        IMPLICIT NONE
!
!IN/OUT
        REAL(pr) :: T,v,e
!LOCAL
        REAL(pr) :: tau
!for helmholtz_deriv

        REAL(pr) :: phi_r_ddelt, phi_r_dtau,&
                    phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau

!for helmholtz_dimless

        REAL(pr) :: phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                    phi0_dddelt,phi0_ddtau
!
!Pre-compute

        tau      = T_cr  / T
!initialisation
      phi_0 = 0_pr
      phi_r = 0_pr
      phi0_ddelt = 0_pr
      phi0_dtau = 0_pr
      phi0_dddelt = 0_pr
      phi0_ddtau = 0_pr
      phi_r_ddelt= 0_pr
      phi_r_dtau = 0_pr
      phi_r_dddelt = 0_pr
      phi_r_ddtau = 0_pr
      phi_r_ddeltdtau = 0_pr
!
        CALL helmholtz_dimless (T,v,phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)
!       print*, phi_0,phi_r,phi0_ddelt,phi0_dtau,phi0_dddelt,phi0_ddtau
!
!        print*, T,v
        CALL helmholtz_deriv( T, v, phi_r_ddelt, phi_r_dtau,&
                            phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!       print*, phi_r_ddelt, phi_r_dtau,phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau
!
!
        e = tau * ( phi0_dtau + phi_r_dtau) * R * T
!
!        print*, 'phi_r_dtau(properties) = ',phi_r_dtau
!
       END SUBROUTINE inter_energy
!
!============================================================================================================
       SUBROUTINE heat_cap_v(T,v,cv)  !J/kgK
!============================================================================================================
        IMPLICIT NONE
!
!IN/OUT
        REAL(pr) :: T,v,cv
!LOCAL
        REAL(pr) :: tau, tau2
!for helmholtz_deriv

        REAL(pr) :: phi_r_ddelt, phi_r_dtau,&
                    phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau

!for helmholtz_dimless

        REAL(pr) :: phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                    phi0_dddelt,phi0_ddtau
!
!Pre-compute

        tau      = T_cr  / T
        tau2     = tau   * tau
!initialisation
      phi_0 = 0_pr
      phi_r = 0_pr
      phi0_ddelt = 0_pr
      phi0_dtau = 0_pr
      phi0_dddelt = 0_pr
      phi0_ddtau = 0_pr
      phi_r_ddelt= 0_pr
      phi_r_dtau = 0_pr
      phi_r_dddelt = 0_pr
      phi_r_ddtau = 0_pr
      phi_r_ddeltdtau = 0_pr

        CALL helmholtz_dimless (T,v,phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)
!       print*, phi_0,phi_r,phi0_ddelt,phi0_dtau,phi0_dddelt,phi0_ddtau

        CALL helmholtz_deriv( T, v, phi_r_ddelt, phi_r_dtau,&
                            phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!       print*, phi_r_ddelt, phi_r_dtau,phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau
!
!
!
        cv = -tau2 * ( phi0_ddtau + phi_r_ddtau ) * R

!       print*, phi0_ddtau , phi_r_ddtau , tau2
!
!
       END SUBROUTINE heat_cap_v
!
!================================================================================================================
       SUBROUTINE heat_cap_p(T,v,cp)  !J/kgK
!================================================================================================================
        IMPLICIT NONE
!IN/OUT
        REAL(pr) :: T,v,cp
!LOCAL
        REAL(pr) :: rho,delt,tau,tau2,delt2

!for helmholtz_deriv

        REAL(pr) :: phi_r_ddelt, phi_r_dtau,&
                    phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau

!for helmholtz_dimless

        REAL(pr) :: phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                    phi0_dddelt,phi0_ddtau

!Pre-compute

        rho      = 1_pr  / v
        delt     = rho   / rho_cr
        tau      = T_cr  / T
        tau2     = tau   * tau
        delt2    = delt  * delt
!initialisation
      phi_0 = 0_pr
      phi_r = 0_pr
      phi0_ddelt = 0_pr
      phi0_dtau = 0_pr
      phi0_dddelt = 0_pr
      phi0_ddtau = 0_pr
      phi_r_ddelt= 0_pr
      phi_r_dtau = 0_pr
      phi_r_dddelt = 0_pr
      phi_r_ddtau = 0_pr
      phi_r_ddeltdtau = 0_pr

        CALL helmholtz_dimless (T,v,phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)
!       print*, phi_0,phi_r,phi0_ddelt,phi0_dtau,phi0_dddelt,phi0_ddtau

        CALL helmholtz_deriv( T, v, phi_r_ddelt, phi_r_dtau,&
                            phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!       print*, phi_r_ddelt, phi_r_dtau,phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau
!
!
        cp = ( -tau2   * ( phi0_ddtau + phi_r_ddtau ) + &
             (1_pr+delt*phi_r_ddelt-delt*tau*phi_r_ddeltdtau)**(2_pr) / &
             (1_pr+2_pr*delt*phi_r_ddelt+delt2*phi_r_dddelt) ) * R
!
!
       END SUBROUTINE heat_cap_p
!
!=============================================================================================================
       SUBROUTINE sound_speed(T,v,c)   !m/s
!=============================================================================================================
        IMPLICIT NONE
!IN/OUT
        REAL(pr) :: T,v,c
!LOCAL
        REAL(pr) :: rho,delt,tau,tau2,delt2,c_2

!for helmholtz_deriv

        REAL(pr) :: phi_r_ddelt, phi_r_dtau,&
                    phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau

!for helmholtz_dimless

        REAL(pr) :: phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                    phi0_dddelt,phi0_ddtau

!Pre-compute

        rho      = 1_pr  / v
        delt     = 1_pr  / (rho_cr*v)
        tau      = T_cr  / T
        tau2     = tau   * tau
        delt2    = delt  * delt

!initialisation
      phi_0 = 0_pr
      phi_r = 0_pr
      phi0_ddelt = 0_pr
      phi0_dtau = 0_pr
      phi0_dddelt = 0_pr
      phi0_ddtau = 0_pr
      phi_r_ddelt= 0_pr
      phi_r_dtau = 0_pr
      phi_r_dddelt = 0_pr
      phi_r_ddtau = 0_pr
      phi_r_ddeltdtau = 0_pr

        CALL helmholtz_dimless (T,v,phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)
!       print*, phi_0,phi_r,phi0_ddelt,phi0_dtau,phi0_dddelt,phi0_ddtau

        CALL helmholtz_deriv( T, v, phi_r_ddelt, phi_r_dtau,&
                            phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!       print*, phi_r_ddelt, phi_r_dtau,phi_r_dddelt, phi_r_ddtau,
!       phi_r_ddeltdtau
!
!
        c_2 = ( 1_pr + 2_pr*delt*phi_r_ddelt + delt2*phi_r_dddelt - &
              (1_pr + delt*phi_r_ddelt  - delt*tau*phi_r_ddeltdtau)**(2_pr) / &
              ( tau2 * (phi0_ddtau+phi_r_ddtau) ) ) * R * T
!        print*, tau2 * (phi0_ddtau+phi_r_ddtau)
!         print*, delt*phi_r_dddelt,delt*tau* phi_r_ddeltdtau
!         print*, (1_pr + delt*phi_r_ddelt  - delt*tau*phi_r_ddeltdtau)
!         print*, delt*phi_r_ddelt
        c = abs( sqrt(c_2) )
!
!
       END SUBROUTINE sound_speed
!
!
!====================================================================================================================
       SUBROUTINE entropy(T,v,s)  !J/kgK
!====================================================================================================================
        IMPLICIT NONE
!IN/OUT
        REAL(pr) :: T,v,s
!LOCAL
        REAL(pr) :: tau
!for helmholtz_deriv

        REAL(pr) :: phi_r_ddelt, phi_r_dtau,&
                    phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau

!for helmholtz_dimless

        REAL(pr) :: phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                    phi0_dddelt,phi0_ddtau

!Pre-compute

        tau      = T_cr  / T
!
!initialisation
      phi_0 = 0_pr
      phi_r = 0_pr
      phi0_ddelt = 0_pr
      phi0_dtau = 0_pr
      phi0_dddelt = 0_pr
      phi0_ddtau = 0_pr
      phi_r_ddelt= 0_pr
      phi_r_dtau = 0_pr
      phi_r_dddelt = 0_pr
      phi_r_ddtau = 0_pr
      phi_r_ddeltdtau = 0_pr

        CALL helmholtz_dimless (T,v,phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)
!       print*, phi_0,phi_r,phi0_ddelt,phi0_dtau,phi0_dddelt,phi0_ddtau

        CALL helmholtz_deriv( T, v, phi_r_ddelt, phi_r_dtau,&
                            phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!       print*, phi_r_ddelt, phi_r_dtau,phi_r_dddelt, phi_r_ddtau,
!       phi_r_ddeltdtau
!
!
        s = (tau * ( phi0_dtau + phi_r_dtau) - phi_0 - phi_r) * R
!
!
       END SUBROUTINE entropy
!
!================================================================================================================
       SUBROUTINE helmho(T,v,h_helmho) !J/kg
!================================================================================================================
        IMPLICIT NONE
!IN/OUT
        REAL(pr) :: T,v,h_helmho
!LOCAL
        REAL(pr) :: phi
!for helmholtz_dimless

        REAL(pr) :: phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                    phi0_dddelt,phi0_ddtau
!
!initialisation
      phi_0 = 0_pr
      phi_r = 0_pr
      phi0_ddelt = 0_pr
      phi0_dtau = 0_pr
      phi0_dddelt = 0_pr
      phi0_ddtau = 0_pr

!
        CALL helmholtz_dimless (T,v,phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)
!
!
        phi = phi_0 + phi_r
! print*, 'propoerties phi0, phir',phi_0, phi_r
! phi is a dimensionless magnitude, R is in [J/kg/K], T in [K]:
!
        h_helmho   = phi * R * T                      ! [J/kg]
!
!
       END SUBROUTINE helmho
!
!
!=================================================================================================================
       SUBROUTINE gibbs(T,v,g) !J/kg
!=================================================================================================================
        IMPLICIT NONE
!IN/OUT
        REAL(pr) :: T,v,g
!LOCAL
        REAL(pr) :: h_helmho, p
!
!
        CALL helmho(T,v,h_helmho)
        CALL pressure(T,v,p)
!
!
        g = h_helmho + p * v
!
!
       END SUBROUTINE gibbs
!
!
!==================================================================================================================
      SUBROUTINE dpdr_u(T,v,deriv) !Pa.m3/kg
!=================================================================================================================
        IMPLICIT NONE
!IN/OUT
        REAL(pr) :: T,v,deriv
!LOCAL
        REAL(pr) :: rho, delt, phi_r_ddelt, phi_r_dtau,&
&                   phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau
        REAL(pr) :: phi_0,phi_r,phi0_ddelt,phi0_dtau,phi0_dddelt,phi0_ddtau,tau
        REAL(pr) :: dp_dr_T, dp_du_r, du_dr_T
!
        rho      = 1_pr  / v
        delt     = 1_pr  / (rho_cr*v)
        tau      = T_cr/T
        phi_r_ddelt = 0_pr
        phi_r_dtau  = 0_pr
        phi_r_dddelt= 0_pr
        phi_r_ddtau = 0_pr
        phi_r_ddeltdtau = 0_pr

!
        CALL helmholtz_dimless (T,v,phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)

        CALL helmholtz_deriv( T, v, phi_r_ddelt, phi_r_dtau,&
&                             phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!
        CALL dpdu_v(T,v,dp_du_r)
        dp_dr_T  = (1_pr + 2_pr*delt*phi_r_ddelt + delt*delt*phi_r_dddelt) *R *T
        du_dr_T  = R*T*tau/rho_cr * phi_r_ddeltdtau
!
        deriv = dp_dr_T - dp_du_r*du_dr_T

      END SUBROUTINE dpdr_u
!==================================================================================================================
      SUBROUTINE dpdv_T(T,v,deriv) !Pa.m3/kg
!=================================================================================================================
        IMPLICIT NONE
!IN/OUT
        REAL(pr) :: T,v,deriv
!LOCAL
        REAL(pr) :: rho, delt, phi_r_ddelt, phi_r_dtau,&
&                   phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau
        REAL(pr) :: phi_0,phi_r,phi0_ddelt,phi0_dtau,phi0_dddelt,phi0_ddtau,tau
        REAL(pr) :: dp_dr_T, dp_du_r, du_dr_T
!
        rho      = 1_pr  / v
        delt     = 1_pr  / (rho_cr*v)
        tau      = T_cr/T
        phi_r_ddelt = 0_pr
        phi_r_dtau  = 0_pr
        phi_r_dddelt= 0_pr
        phi_r_ddtau = 0_pr
        phi_r_ddeltdtau = 0_pr

!
        CALL helmholtz_dimless (T,v,phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)

        CALL helmholtz_deriv( T, v, phi_r_ddelt, phi_r_dtau,&
&                             phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!
        CALL dpdu_v(T,v,dp_du_r)
        dp_dr_T  = (1_pr + 2_pr*delt*phi_r_ddelt + delt*delt*phi_r_dddelt) *R *T
!
        deriv = dp_dr_T *(-rho*rho)

      END SUBROUTINE dpdv_T
!
!==================================================================================================================
      SUBROUTINE dpdT_v(T,v,deriv)
!=================================================================================================================
        IMPLICIT NONE
!IN/OUT
        REAL(pr) :: T,v,deriv
!LOCAL
        REAL(pr) :: rho, delt, phi_r_ddelt, phi_r_dtau,&
&                   phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau
        REAL(pr) :: tau
!
        REAL(pr) :: dp_dT_v, du_dT_v
        rho      = 1_pr  / v
        delt     = 1_pr  / (rho_cr*v)
        tau      = T_cr/T
        phi_r_ddelt = 0_pr
        phi_r_dtau  = 0_pr
        phi_r_dddelt= 0_pr
        phi_r_ddtau = 0_pr
        phi_r_ddeltdtau = 0_pr
!
!
        CALL helmholtz_deriv( T, v, phi_r_ddelt, phi_r_dtau,&
&                             phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!
        dp_dT_v = rho * R * (1_pr+delt*phi_r_ddelt-tau*delt*phi_r_ddeltdtau )

        deriv = dp_dT_v

      END SUBROUTINE dpdT_v
!

!
!==================================================================================================================
      SUBROUTINE dpdu_v(T,v,deriv) !Pa/J.kg/m3
!=================================================================================================================
        IMPLICIT NONE
!IN/OUT
        REAL(pr) :: T,v,deriv
!LOCAL
        REAL(pr) :: rho, delt, phi_r_ddelt, phi_r_dtau,&
&                   phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau
        REAL(pr) :: phi_0,phi_r,phi0_ddelt,phi0_dtau,phi0_dddelt,phi0_ddtau,tau
!
        REAL(pr) :: dp_dT_v, du_dT_v
        rho      = 1_pr  / v
        delt     = 1_pr  / (rho_cr*v)
        tau      = T_cr/T
        phi_r_ddelt = 0_pr
        phi_r_dtau  = 0_pr
        phi_r_dddelt= 0_pr
        phi_r_ddtau = 0_pr
        phi_r_ddeltdtau = 0_pr
!
!
!
        CALL helmholtz_dimless (T,v,phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)
!
        CALL helmholtz_deriv( T, v, phi_r_ddelt, phi_r_dtau,&
&                             phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!
        dp_dT_v = rho * R * (1_pr+delt*phi_r_ddelt-tau*delt*phi_r_ddeltdtau )
        du_dT_v = -R*tau*tau*( phi0_ddtau + phi_r_ddtau )

        deriv = dp_dT_v / du_dT_v

      END SUBROUTINE dpdu_v
!
!
!=================================================================================
!
     SUBROUTINE satprop(mode, psat, Tsat, vvsat, vlsat, uvsat, ulsat)
!
!=================================================================================
      IMPLICIT NONE
!
      INTEGER  :: i, j, j_sat
!
      REAL(pr), INTENT(in)  :: psat
      INTEGER , INTENT(in)  :: mode
!
      REAL(pr), INTENT(out) :: Tsat, vvsat,vlsat,uvsat,ulsat
!
      REAL(pr) :: delta, pp, temp
      REAL(pr) :: vL, uL, vV, uV
!
!
!use 3e order spline
!
      IF (mode == 3) THEN
!
       delta = saturP(2) - saturP(1)
       j_sat = INT((psat  - saturP(1))/delta) + 1
!
!##computing saturation quantities
!
       vL = 0_pr; uL = 0_pr;  vV = 0_pr;  uV = 0_pr; temp = 0_pr
       DO i = 1, ord_spline+1
          pp = psat**(i-1)
          vL   = vL  + vL_psat_spline  (ord_spline+2-i, j_sat) * pp
          uL   = uL  + uL_psat_spline  (ord_spline+2-i, j_sat) * pp
          vV   = vV  + vV_psat_spline  (ord_spline+2-i, j_sat) * pp
          uV   = uV  + uV_psat_spline  (ord_spline+2-i, j_sat) * pp
          temp = temp+ Tsat_psat_spline(ord_spline+2-i, j_sat) * pp
       ENDDO
!
!##for output saturation quantities
!
       Tsat  = temp
       vvsat = vV
       vlsat = vL
       uvsat = uV
       ulsat = uL
!
!use 5e order spline
!
      ELSEIF (mode == 5) THEN
!
       delta = saturP2(2) - saturP2(1)
       j_sat = INT((psat  - saturP2(1))/delta) + 1
!
!##computing saturation quantities
!
       vL = 0_pr; uL = 0_pr;  vV = 0_pr;  uV = 0_pr
       DO i = 1, 6
          pp = psat**(i-1)
          vL   = vL  + vL_psat_spline2  (5+2-i, j_sat) * pp
          uL   = uL  + uL_psat_spline2  (5+2-i, j_sat) * pp
          vV   = vV  + vV_psat_spline2  (5+2-i, j_sat) * pp
          uV   = uV  + uV_psat_spline2  (5+2-i, j_sat) * pp
          temp = temp+ Tsat_psat_spline2(5+2-i, j_sat) * pp
       ENDDO
!
!##for output saturation quantities
!
       Tsat  = temp
       vvsat = vV
       vlsat = vL
       uvsat = uV
       ulsat = uL
!
      ENDIF
     END SUBROUTINE satprop
!
!=================================================================================
!
     SUBROUTINE satderiv(mode, psat, duL_dp, duV_dp, dvL_dp, dvV_dp)
!
!=================================================================================
      IMPLICIT NONE
!
      INTEGER  :: i, j, j_sat
!
      REAL(pr), INTENT(in)  :: psat
      INTEGER , INTENT(in)  :: mode
!
      REAL(pr), INTENT(out) :: duL_dp, duV_dp, dvL_dp, dvV_dp
!
      REAL(pr) :: delta, pp
      REAL(pr) :: duLdp, duVdp, dvLdp, dvVdp
!
!
!use 3e order spline
!
      IF (mode == 3) THEN
!
       delta = saturP(2) - saturP(1)
       j_sat = INT((psat  - saturP(1))/delta) + 1
!
!##computing derivatives
!
       duLdp = 0_pr;  duVdp = 0_pr;  dvLdp = 0_pr;  dvVdp = 0_pr
       DO i = 1, ord_spline
          pp      = psat**(ord_spline - i)
          duLdp  = duLdp + (ord_spline+1-i) * uL_psat_spline(i,j_sat) *pp
          duVdp  = duVdp + (ord_spline+1-i) * uV_psat_spline(i,j_sat) *pp
          dvLdp  = dvLdp + (ord_spline+1-i) * vL_psat_spline(i,j_sat) *pp
          dvVdp  = dvVdp + (ord_spline+1-i) * vV_psat_spline(i,j_sat) *pp
       ENDDO
!
!##for output saturation quantities
!
       duL_dp = duLdp
       duV_dp = duVdp
       dvL_dp = dvLdp
       dvV_dp = dvVdp
!
!use 5e order spline
!
      ELSEIF (mode == 5) THEN
!
       delta = saturP2(2) - saturP2(1)
       j_sat = INT((psat  - saturP2(1))/delta) + 1
!
!##computing derivatives
!
       duLdp = 0_pr;  duVdp = 0_pr;  dvLdp = 0_pr;  dvVdp = 0_pr
       DO i = 1, 5
          pp      = psat**(5 - i)
          duLdp  = duLdp + (5+1-i) * uL_psat_spline2(i,j_sat) *pp
          duVdp  = duVdp + (5+1-i) * uV_psat_spline2(i,j_sat) *pp
          dvLdp  = dvLdp + (5+1-i) * vL_psat_spline2(i,j_sat) *pp
          dvVdp  = dvVdp + (5+1-i) * vV_psat_spline2(i,j_sat) *pp
       ENDDO
!
!##for output saturation quantities
!
       duL_dp = duLdp
       duV_dp = duVdp
       dvL_dp = dvLdp
       dvV_dp = dvVdp
!
      ENDIF
     END SUBROUTINE satderiv
!==================================================================================================================
      SUBROUTINE axlpress(T,vvap, vliq, p1, p2, p3) !Pa
!=================================================================================================================
        IMPLICIT NONE
!IN/OUT
        REAL(pr), INTENT(IN)  :: vvap,vliq,T
        REAL(pr), INTENT(OUT) :: p1,p2,p3
!LOCAL
        REAL(pr) :: deltp,deltpp,tau
        REAL(pr) :: phi_r_ddelt1, phi_r_ddelt2, phi_r_dtau,&
&                   phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau
        REAL(pr) :: phi_0,phi_r1,phi_r2,phi0_ddelt,phi0_dtau,phi0_dddelt,phi0_ddtau
!

        deltp      = 1_pr  / (rho_cr*vliq)
        deltpp     = 1_pr  / (rho_cr*vvap)
        tau        = T_cr/T
!
        phi_r1 = 0_pr
        phi_r2 = 0_pr
        phi_r_ddelt1 = 0_pr
        phi_r_ddelt2 = 0_pr
        phi_r_dtau  = 0_pr
        phi_r_dddelt= 0_pr
        phi_r_ddtau = 0_pr
        phi_r_ddeltdtau = 0_pr
!
!
!
        CALL helmholtz_dimless (T,vliq,phi_0,phi_r1,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)
!
        CALL helmholtz_deriv( T, vliq, phi_r_ddelt1, phi_r_dtau,&
&                             phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!
        CALL helmholtz_dimless (T,vvap,phi_0,phi_r2,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)
!
        CALL helmholtz_deriv( T, vvap, phi_r_ddelt2, phi_r_dtau,&
&                             phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!----------eq2.2a, 2.2b, 2.2C--------------
        p1 = R*T/vliq * (1.0+deltp*phi_r_ddelt1)
        p2 = R*T/vvap * (1.0+deltpp*phi_r_ddelt2)
        p3 = ( phi_r1 - phi_r2 + dlog(vvap/vliq) ) * R*T / (vvap-vliq)
!
!
      END SUBROUTINE axlpress
!
!==================================================================================================================
      SUBROUTINE dedr_T(T,v,deriv)
!=================================================================================================================
        IMPLICIT NONE
!IN/OUT
        REAL(pr) :: T,v,deriv
!LOCAL
        REAL(pr) :: rho, delt, phi_r_ddelt, phi_r_dtau,&
&                   phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau
!
        REAL(pr) :: de_dr_T, tau
        rho      = 1_pr  / v
        delt     = 1_pr  / (rho_cr*v)
        tau      = T_cr/T
        phi_r_ddelt = 0_pr
        phi_r_dtau  = 0_pr
        phi_r_dddelt= 0_pr
        phi_r_ddtau = 0_pr
        phi_r_ddeltdtau = 0_pr
!
!
        CALL helmholtz_deriv( T, v, phi_r_ddelt, phi_r_dtau,&
&                             phi_r_dddelt, phi_r_ddtau, phi_r_ddeltdtau )
!
        de_dr_T = R * T_cr / rho_cr * phi_r_ddeltdtau

        deriv = de_dr_T

      END SUBROUTINE dedr_T
!
!
END MODULE properties


      subroutine qlYcalc(xpi,Y,Yalt)
C----Calculate Y from xpi
C----Assumes, if we have 1 internal mass it is position 4
C----Assumes, if we have 2 internal masses they are positions 3,4 or 2,4
      implicit none
      include 'qlconstants.f'
      double precision xpi(13),Y(4,4),Yalt(4,4)
      logical opposite,qlnonzero,qlzero
      integer j,k,massive
      massive=0
      do j=1,4
      if (qlnonzero(xpi(j))) massive=massive+1
      do k=1,4
      Yalt(j,k)=0d0
      enddo
      enddo
      if (qlzero(xpi(3))) then
      opposite=.true.
      else
      opposite=.false.
      endif

      Y(1,1)=xpi(1)
      Y(2,2)=xpi(2)
      Y(3,3)=xpi(3)
      Y(4,4)=xpi(4)
      Y(1,2)=half*(xpi(1)+xpi(2)-xpi(5))
      Y(1,3)=half*(xpi(1)+xpi(3)-xpi(9))
      Y(1,4)=half*(xpi(1)+xpi(4)-xpi(8))
      Y(2,1)=Y(1,2)
      Y(2,3)=half*(xpi(2)+xpi(3)-xpi(6))
      Y(2,4)=half*(xpi(2)+xpi(4)-xpi(10))
      Y(3,1)=Y(1,3)
      Y(3,2)=Y(2,3)
      Y(3,4)=half*(xpi(3)+xpi(4)-xpi(7))
      Y(4,1)=Y(1,4)
      Y(4,2)=Y(2,4)
      Y(4,3)=Y(3,4)

      if (massive .eq. 0) then
      Yalt(1,1)=zip
      Yalt(2,2)=zip
      Yalt(3,3)=zip
      Yalt(4,4)=zip
      Yalt(1,2)=zip
      Yalt(1,3)=zip
      Yalt(1,4)=zip
      Yalt(2,3)=zip
      Yalt(2,4)=zip
      Yalt(3,4)=zip
      elseif (massive .eq. 1) then
C---exchange (1<-->3)
      Yalt(1,1)=Y(3,3)
      Yalt(2,2)=Y(2,2)
      Yalt(3,3)=Y(1,1)
      Yalt(4,4)=Y(4,4)
      Yalt(1,2)=Y(2,3)
      Yalt(1,3)=Y(1,3)
      Yalt(1,4)=Y(3,4)
      Yalt(2,3)=Y(1,2)
      Yalt(2,4)=Y(2,4)
      Yalt(3,4)=Y(1,4)
      elseif ((massive .eq. 2) .and. (opposite .eqv. .true.)) then
C---exchange (2<-->4) .and (1<-->3)
      Yalt(1,1)=Y(3,3)
      Yalt(2,2)=Y(4,4)
      Yalt(3,3)=Y(1,1)
      Yalt(4,4)=Y(2,2)
      Yalt(1,2)=Y(3,4)
      Yalt(1,3)=Y(1,3)
      Yalt(1,4)=Y(2,3)
      Yalt(2,3)=Y(1,4)
      Yalt(2,4)=Y(2,4)
      Yalt(3,4)=Y(1,2)

      elseif ((massive .eq. 2) .and. (opposite .eqv. .false.)) then
C---exchange (1<-->2)and(3<-->4)
      Yalt(1,1)=Y(2,2)
      Yalt(2,2)=Y(1,1)
      Yalt(3,3)=Y(4,4)
      Yalt(4,4)=Y(3,3)
      Yalt(1,2)=Y(1,2)
      Yalt(3,4)=Y(3,4)
      Yalt(1,3)=Y(2,4)
      Yalt(1,4)=Y(2,3)
      Yalt(2,3)=Y(1,4)
      Yalt(2,4)=Y(1,3)
      endif

C----symmetrize Y
      do j=1,4
      do k=j+1,4
      Y(k,j)=Y(j,k)
      Yalt(k,j)=Yalt(j,k)
      enddo
      enddo

      return
      end


      FUNCTION FORMOM(XMAA,XMOM)
C     ==================================================================
C     formfactorfor pi-pi0 gamma final state
C      R. Decker, Z. Phys C36 (1987) 487.
C     ==================================================================
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
      REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
      COMMON /TESTA1/ KEYA1
      COMPLEX BWIGN,FORMOM
      DATA ICONT /1/
* THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
      BWIGN(XM,AM,GAMMA)=1./CMPLX(XM**2-AM**2,GAMMA*AM)
* HADRON CURRENT
      FRO  =0.266*AMRO**2
      ELPHA=- 0.1
      AMROP = 1.7
      GAMROP= 0.26
      AMOM  =0.782
      GAMOM =0.0085
      AROMEG= 1.0
      GCOUP=12.924
      GCOUP=GCOUP*AROMEG
      FQED  =SQRT(4.0*3.1415926535/137.03604)
      FORMOM=FQED*FRO**2/SQRT(2.0)*GCOUP**2*BWIGN(XMOM,AMOM,GAMOM)
     $     *(BWIGN(XMAA,AMRO,GAMRO)+ELPHA*BWIGN(XMAA,AMROP,GAMROP))
     $     *(BWIGN( 0.0,AMRO,GAMRO)+ELPHA*BWIGN( 0.0,AMROP,GAMROP))
      END

C=======================================================================
      COMPLEX FUNCTION FK1AB(XMSQ,INDX)
C     ==================================================================
C     complex form-factor for a1+a1prime.                       AJW 1/98
C     ==================================================================

      COMPLEX F1,F2,AMPA,AMPB
      INTEGER IFIRST,INDX
      DATA IFIRST/0/

      IF (IFIRST.EQ.0) THEN
        IFIRST = 1
        XM1 = PKORB(1,19)
        XG1 = PKORB(2,19)
        XM2 = PKORB(1,20)
        XG2 = PKORB(2,20)

        XM1SQ = XM1*XM1
        GF1 = GFUN(XM1SQ)
        GG1 = XM1*XG1/GF1
        XM2SQ = XM2*XM2
        GF2 = GFUN(XM2SQ)
        GG2 = XM2*XG2/GF2
      END IF

      IF (INDX.EQ.1) THEN
        AMPA = CMPLX(PKORB(3,81),0.)
        AMPB = CMPLX(PKORB(3,82),0.)
      ELSE IF (INDX.EQ.2) THEN
        AMPA = CMPLX(PKORB(3,83),0.)
        AMPB = CMPLX(PKORB(3,84),0.)
      ELSEIF (INDX.EQ.3) THEN
        AMPA = CMPLX(PKORB(3,85),0.)
        AMPB = CMPLX(PKORB(3,86),0.)
      ELSEIF (INDX.EQ.4) THEN
        AMPA = CMPLX(PKORB(3,87),0.)
        AMPB = CMPLX(PKORB(3,88),0.)
      END IF

      GF = GFUN(XMSQ)
      FG1 = GG1*GF
      FG2 = GG2*GF
      F1 = CMPLX(-XM1SQ,0.0)/CMPLX(XMSQ-XM1SQ,FG1)
      F2 = CMPLX(-XM2SQ,0.0)/CMPLX(XMSQ-XM2SQ,FG2)
      FK1AB = AMPA*F1+AMPB*F2

      RETURN
      END

      FUNCTION FORM1(MNUM,QQ,S1,SDWA)
C     ==================================================================
C     formfactorfor F1 for 3 scalar final state
C     R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
C     H. Georgi, Weak interactions and modern particle theory,
C     The Benjamin/Cummings Pub. Co., Inc. 1984.
C     R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
C     and erratum !!!!!!
C     ==================================================================
C
      COMPLEX FORM1,WIGNER,WIGFOR,FPIKM,BWIGM
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      COMMON /IPChT/ IVER
      INTEGER        IVER

      COMPLEX FORMA1,FORMK1,FORMRO,FORMKS
      COMPLEX FA1A1P,FK1AB,F3PI,F3PI_RCHT
C
      IF     (MNUM.EQ.0) THEN
C ------------  3 pi hadronic state (a1)
C       FORMRO = FPIKM(SQRT(S1),AMPI,AMPI)
C       FORMRO = F3PI(1,QQ,S1,SDWA)
C       FORMA1 = FA1A1P(QQ)
C       FORM1 = FORMA1*FORMRO
      IF (IVER.EQ.0) THEN
        FORM1 = F3PI(1,QQ,S1,SDWA)
      ELSE
        FORM1 = F3PI_RCHT(1,QQ,S1,SDWA)
      ENDIF

      ELSEIF (MNUM.EQ.1) THEN
C ------------ K- pi- K+ (K*0 K-)
       FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
       FORMA1 = FA1A1P(QQ)
       FORM1 = FORMA1*FORMKS

      ELSEIF (MNUM.EQ.2) THEN
C ------------ K0 pi- K0B (K*- K0)
       FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
       FORMA1 = FA1A1P(QQ)
       FORM1 = FORMA1*FORMKS

      ELSEIF (MNUM.EQ.3) THEN
C ------------ K- pi0 K0 (K*0 K-)
       FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
       FORMA1 = FA1A1P(QQ)
       FORM1 = FORMA1*FORMKS

      ELSEIF (MNUM.EQ.4) THEN
C ------------ pi0 pi0 K-  (K*-pi0)
       FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
       FORMK1 = FK1AB(QQ,3)
       FORM1 = FORMK1*FORMKS

      ELSEIF (MNUM.EQ.5) THEN
C ------------ K- pi- pi+ (rho0 K-)
       FORMK1 = FK1AB(QQ,4)
       FORMRO = FPIKM(SQRT(S1),AMPI,AMPI)
       FORM1 = FORMK1*FORMRO

      ELSEIF (MNUM.EQ.6) THEN
C ------------ pi- K0B pi0 (pi- K*0B)
       FORMK1 = FK1AB(QQ,1)
       FORMKS = BWIGM(S1,AMKST,GAMKST,AMK,AMPI)
       FORM1 = FORMK1*FORMKS

      ELSEIF (MNUM.EQ.7) THEN
C -------------- eta pi- pi0 final state
       FORM1=0.0
      ENDIF
      END
      FUNCTION FORM2(MNUM,QQ,S1,SDWA)
C     ==================================================================
C     formfactorfor F2 for 3 scalar final state
C     R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
C     H. Georgi, Weak interactions and modern particle theory,
C     The Benjamin/Cummings Pub. Co., Inc. 1984.
C     R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
C     and erratum !!!!!!
C     ==================================================================
C
      COMPLEX FORM2,WIGNER,WIGFOR,FPIKM,BWIGM
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      COMMON /IPChT/ IVER
      INTEGER        IVER

      COMPLEX FORMA1,FORMK1,FORMRO,FORMKS
      COMPLEX FA1A1P,FK1AB,F3PI,F3PI_RCHT

      IF     (MNUM.EQ.0) THEN
C ------------  3 pi hadronic state (a1)
C       FORMRO = FPIKM(SQRT(S1),AMPI,AMPI)
C       FORMRO = F3PI(2,QQ,S1,SDWA)
C       FORMA1 = FA1A1P(QQ)
C       FORM2 = FORMA1*FORMRO
C       FORM2 = F3PI(2,QQ,S1,SDWA)
      IF (IVER.EQ.0) THEN
       FORM2 = F3PI(2,QQ,S1,SDWA)
      ELSE
       FORM2 = F3PI_RCHT(2,QQ,S1,SDWA)
      ENDIF
      ELSEIF (MNUM.EQ.1) THEN
C ------------ K- pi- K+ (rho0 pi-)
       FORMRO = FPIKM(SQRT(S1),AMK,AMK)
       FORMA1 = FA1A1P(QQ)
       FORM2 = FORMA1*FORMRO

      ELSEIF (MNUM.EQ.2) THEN
C ------------ K0 pi- K0B (rho0 pi-)
       FORMRO = FPIKM(SQRT(S1),AMK,AMK)
       FORMA1 = FA1A1P(QQ)
       FORM2 = FORMA1*FORMRO

      ELSEIF (MNUM.EQ.3) THEN
C ------------ K- pi0 K0 (rho- pi0)
       FORMRO = FPIKM(SQRT(S1),AMK,AMK)
       FORMA1 = FA1A1P(QQ)
       FORM2 = FORMA1*FORMRO

      ELSEIF (MNUM.EQ.4) THEN
C ------------ pi0 pi0 K-  (K*-pi0)
       FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
       FORMK1 = FK1AB(QQ,3)
       FORM2 = FORMK1*FORMKS

      ELSEIF (MNUM.EQ.5) THEN
C ------------ K- pi- pi+  (K*0B pi-)
       FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
       FORMK1 = FK1AB(QQ,1)
       FORM2 = FORMK1*FORMKS
C
      ELSEIF (MNUM.EQ.6) THEN
C ------------ pi- K0B pi0 (rho- K0B)
       FORMRO = FPIKM(SQRT(S1),AMPI,AMPI)
       FORMK1 = FK1AB(QQ,2)
       FORM2 = FORMK1*FORMRO
C
      ELSEIF (MNUM.EQ.7) THEN
C -------------- eta pi- pi0 final state
       FORM2=0.0
      ENDIF
C
      END
      COMPLEX FUNCTION BWIGM(S,M,G,XM1,XM2)
C **********************************************************
C     P-WAVE BREIT-WIGNER  FOR RHO
C **********************************************************
      REAL S,M,G,XM1,XM2
      REAL PI,QS,QM,W,GS
      DATA INIT /0/
C ------------ PARAMETERS --------------------
      IF (INIT.EQ.0) THEN
      INIT=1
      PI=3.141592654
C -------  BREIT-WIGNER -----------------------
         ENDIF
       IF (S.GT.(XM1+XM2)**2) THEN
         QS=SQRT(ABS((S   -(XM1+XM2)**2)*(S   -(XM1-XM2)**2)))/SQRT(S)
         QM=SQRT(ABS((M**2-(XM1+XM2)**2)*(M**2-(XM1-XM2)**2)))/M
         W=SQRT(S)
         GS=G*(M/W)**2*(QS/QM)**3
       ELSE
         GS=0.0
       ENDIF
         BWIGM=M**2/CMPLX(M**2-S,-SQRT(S)*GS)
      RETURN
      END
      COMPLEX FUNCTION FPIKM(W,XM1,XM2)
C **********************************************************
C     PION FORM FACTOR
C **********************************************************
      COMPLEX BWIGM
      REAL ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
      EXTERNAL BWIG
      DATA  INIT /0/
C
C ------------ PARAMETERS --------------------
      IF (INIT.EQ.0 ) THEN
      INIT=1
      PI=3.141592654
      PIM=.140
      ROM=0.773
      ROG=0.145
      ROM1=1.370
      ROG1=0.510
      BETA1=-0.145
      ENDIF
C -----------------------------------------------
      S=W**2
      FPIKM=(BWIGM(S,ROM,ROG,XM1,XM2)+BETA1*BWIGM(S,ROM1,ROG1,XM1,XM2))
     & /(1+BETA1)
      RETURN
      END
      COMPLEX FUNCTION FPIKMD(W,XM1,XM2)
C **********************************************************
C     PION FORM FACTOR
C **********************************************************
      COMPLEX BWIGM
      REAL ROM,ROG,ROM1,ROG1,PI,PIM,S,W
      EXTERNAL BWIG
      DATA  INIT /0/
C
C ------------ PARAMETERS --------------------
      IF (INIT.EQ.0 ) THEN
      INIT=1
      PI=3.141592654
      PIM=.140
      ROM=0.773
      ROG=0.145
      ROM1=1.500
      ROG1=0.220
      ROM2=1.750
      ROG2=0.120
      BETA=6.5
      DELTA=-26.0
      ENDIF
C -----------------------------------------------
      S=W**2
      FPIKMD=(DELTA*BWIGM(S,ROM,ROG,XM1,XM2)
     $      +BETA*BWIGM(S,ROM1,ROG1,XM1,XM2)
     $      +     BWIGM(S,ROM2,ROG2,XM1,XM2))
     & /(1+BETA+DELTA)
      RETURN
      END

      FUNCTION FORM3(MNUM,QQ,S1,SDWA)
C     ==================================================================
C     formfactorfor F3 for 3 scalar final state
C     R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
C     H. Georgi, Weak interactions and modern particle theory,
C     The Benjamin/Cummings Pub. Co., Inc. 1984.
C     R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
C     and erratum !!!!!!
C     ==================================================================
C
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      COMMON /IPChT/ IVER
      INTEGER        IVER
      COMPLEX FORM3,BWIGM
      COMPLEX FORMA1,FORMK1,FORMRO,FORMKS
      COMPLEX FA1A1P,FK1AB,F3PI,F3PI_RCHT
C
      IF (MNUM.EQ.0) THEN
C ------------  3 pi hadronic state (a1)
C       FORMRO = FPIKM(SQRT(S1),AMPI,AMPI)
C       FORMRO = F3PI(3,QQ,S1,SDWA)
C       FORMA1 = FA1A1P(QQ)
C       FORM3 = FORMA1*FORMRO
      IF (IVER.EQ.0) THEN
        FORM3 = F3PI(3,QQ,S1,SDWA)
      ELSE
        FORM3 = (0.,0.)
      ENDIF

      ELSEIF (MNUM.EQ.3) THEN
C ------------ K- pi0 K0  (K*- K0)
       FORMKS = BWIGM(S1,AMKST,GAMKST,AMPIZ,AMK)
       FORMA1 = FA1A1P(QQ)
       FORM3 = FORMA1*FORMKS

      ELSEIF (MNUM.EQ.6) THEN
C ------------ pi- K0B pi0 (K*- pi0)
       FORMKS = BWIGM(S1,AMKST,GAMKST,AMK,AMPI)
       FORMK1 = FK1AB(QQ,3)
       FORM3 = FORMK1*FORMKS

      ELSE
       FORM3=CMPLX(0.,0.)
      ENDIF
      END
      FUNCTION FORM4(MNUM,QQ,S1,S2,S3)
C     ==================================================================
C     formfactorfor F4 for 3 scalar final state
C     R. Decker, in preparation
C     R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
C     and erratum !!!!!!
C     ==================================================================
C
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      COMMON /IPChT/ IVER
      INTEGER        IVER

      COMPLEX FORM4,WIGNER,FPIKM,F3PI_RCHT
      REAL*4 M
C ---- this formfactor is switched off for cleo version
       FORM4=CMPLX(0.0,0.0)
      IF (MNUM.EQ.0) THEN
C ------------  3 pi hadronic state (a1)
C       FORMRO = FPIKM(SQRT(S1),AMPI,AMPI)
C       FORMRO = F3PI(3,QQ,S1,SDWA)
C       FORMA1 = FA1A1P(QQ)
C       FORM3 = FORMA1*FORMRO
C        FORM4 = CMPLX(-1., 0.)
       IF (IVER.EQ.1) FORM4 = F3PI_RCHT(4,QQ,S1,S2)* CMPLX(0., 1.)
      ENDIF

      END
      FUNCTION FORM5(MNUM,QQ,S1,S2)
C     ==================================================================
C     formfactorfor F5 for 3 scalar final state
C     G. Kramer, W. Palmer, S. Pinsky, Phys. Rev. D30 (1984) 89.
C     G. Kramer, W. Palmer             Z. Phys. C25 (1984) 195.
C     R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
C     and erratum !!!!!!
C     ==================================================================
C
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      COMPLEX FORM5,WIGNER,FPIKM,FPIKMD,BWIGM
      IF     (MNUM.EQ.0) THEN
C ------------  3 pi hadronic state (a1)
        FORM5=0.0
      ELSEIF (MNUM.EQ.1) THEN
C ------------ K- pi- K+
         ELPHA=-0.2
         FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)/(1+ELPHA)
     $        *(       FPIKM(SQRT(S2),AMPI,AMPI)
     $          +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
      ELSEIF (MNUM.EQ.2) THEN
C ------------ K0 pi- K0B
         ELPHA=-0.2
         FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)/(1+ELPHA)
     $        *(       FPIKM(SQRT(S2),AMPI,AMPI)
     $          +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
      ELSEIF (MNUM.EQ.3) THEN
C ------------ K- K0 pi0
        FORM5=0.0
      ELSEIF (MNUM.EQ.4) THEN
C ------------ pi0 pi0 K-
        FORM5=0.0
      ELSEIF (MNUM.EQ.5) THEN
C ------------ K- pi- pi+
        ELPHA=-0.2
        FORM5=BWIGM(QQ,AMKST,GAMKST,AMPI,AMK)/(1+ELPHA)
     $       *(       FPIKM(SQRT(S1),AMPI,AMPI)
     $         +ELPHA*BWIGM(S2,AMKST,GAMKST,AMPI,AMK))
      ELSEIF (MNUM.EQ.6) THEN
C ------------ pi- K0B pi0
        ELPHA=-0.2
        FORM5=BWIGM(QQ,AMKST,GAMKST,AMPI,AMKZ)/(1+ELPHA)
     $       *(       FPIKM(SQRT(S2),AMPI,AMPI)
     $         +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
      ELSEIF (MNUM.EQ.7) THEN
C -------------- eta pi- pi0 final state
       FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)*FPIKM(SQRT(S1),AMPI,AMPI)
      ENDIF
C
      END
      SUBROUTINE CURRX(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
C     ==================================================================
C     hadronic current for 4 pi final state
C     R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
C     R. Decker Z. Phys C36 (1987) 487.
C     M. Gell-Mann, D. Sharp, W. Wagner Phys. Rev. Lett 8 (1962) 261.
C     ==================================================================

      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
      REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
C ARBITRARY FIXING OF THE FOUR PI X-SECTION NORMALIZATION
      COMMON /ARBIT/ ARFLAT,AROMEG
      REAL  PIM1(4),PIM2(4),PIM3(4),PIM4(4),PAA(4)
      COMPLEX HADCUR(4),FORM1,FORM2,FORM3,FPIKM
      COMPLEX BWIGN
      REAL PA(4),PB(4)
      REAL AA(4,4),PP(4,4)
      DATA PI /3.141592653589793238462643/
      DATA  FPI /93.3E-3/
      BWIGN(A,XM,XG)=1.0/CMPLX(A-XM**2,XM*XG)
C
C --- masses and constants
      G1=12.924
      G2=1475.98
      G =G1*G2
      ELPHA=-.1
      AMROP=1.7
      GAMROP=0.26
      AMOM=.782
      GAMOM=0.0085
      ARFLAT=1.0
      AROMEG=1.0
C
      FRO=0.266*AMRO**2
      COEF1=2.0*SQRT(3.0)/FPI**2*ARFLAT
      COEF2=FRO*G*AROMEG
C --- initialization of four vectors
      DO 7 K=1,4
      DO 8 L=1,4
 8    AA(K,L)=0.0
      HADCUR(K)=CMPLX(0.0)
      PAA(K)=PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K)
      PP(1,K)=PIM1(K)
      PP(2,K)=PIM2(K)
      PP(3,K)=PIM3(K)
 7    PP(4,K)=PIM4(K)
C
      IF (MNUM.EQ.1) THEN
C ===================================================================
C pi- pi- p0 pi+ case                                            ====
C ===================================================================
       QQ=PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2
C --- loop over thre contribution of the non-omega current
       DO 201 K=1,3
        SK=(PP(K,4)+PIM4(4))**2-(PP(K,3)+PIM4(3))**2
     $    -(PP(K,2)+PIM4(2))**2-(PP(K,1)+PIM4(1))**2
C -- definition of AA matrix
C -- cronecker delta
        DO 202 I=1,4
         DO 203 J=1,4
 203     AA(I,J)=0.0
 202    AA(I,I)=1.0
C ... and the rest ...
        DO 204 L=1,3
         IF (L.NE.K) THEN
          DENOM=(PAA(4)-PP(L,4))**2-(PAA(3)-PP(L,3))**2
     $         -(PAA(2)-PP(L,2))**2-(PAA(1)-PP(L,1))**2
          DO 205 I=1,4
          DO 205 J=1,4
                      SIG= 1.0
           IF(J.NE.4) SIG=-SIG
           AA(I,J)=AA(I,J)
     $            -SIG*(PAA(I)-2.0*PP(L,I))*(PAA(J)-PP(L,J))/DENOM
 205      CONTINUE
         ENDIF
 204    CONTINUE
C --- lets add something to HADCURR
       FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
C       FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
CCCCCCCCCCCCCCCCC       FORM1=WIGFOR(SK,AMRO,GAMRO)      (tests)
C
       FIX=1.0
       IF (K.EQ.3) FIX=-2.0
       DO 206 I=1,4
       DO 206 J=1,4
        HADCUR(I)=
     $  HADCUR(I)+CMPLX(FIX*COEF1)*FORM1*AA(I,J)*(PP(K,J)-PP(4,J))
 206   CONTINUE
C --- end of the non omega current (3 possibilities)
 201   CONTINUE
C
C
C --- there are two possibilities for omega current
C --- PA PB are corresponding first and second pi-s
       DO 301 KK=1,2
        DO 302 I=1,4
         PA(I)=PP(KK,I)
         PB(I)=PP(3-KK,I)
 302    CONTINUE
C --- lorentz invariants
         QQA=0.0
         SS23=0.0
         SS24=0.0
         SS34=0.0
         QP1P2=0.0
         QP1P3=0.0
         QP1P4=0.0
         P1P2 =0.0
         P1P3 =0.0
         P1P4 =0.0
        DO 303 K=1,4
                     SIGN=-1.0
         IF (K.EQ.4) SIGN= 1.0
         QQA=QQA+SIGN*(PAA(K)-PA(K))**2
         SS23=SS23+SIGN*(PB(K)  +PIM3(K))**2
         SS24=SS24+SIGN*(PB(K)  +PIM4(K))**2
         SS34=SS34+SIGN*(PIM3(K)+PIM4(K))**2
         QP1P2=QP1P2+SIGN*(PAA(K)-PA(K))*PB(K)
         QP1P3=QP1P3+SIGN*(PAA(K)-PA(K))*PIM3(K)
         QP1P4=QP1P4+SIGN*(PAA(K)-PA(K))*PIM4(K)
         P1P2=P1P2+SIGN*PA(K)*PB(K)
         P1P3=P1P3+SIGN*PA(K)*PIM3(K)
         P1P4=P1P4+SIGN*PA(K)*PIM4(K)
 303    CONTINUE
C
        FORM2=COEF2*(BWIGN(QQ,AMRO,GAMRO)+ELPHA*BWIGN(QQ,AMROP,GAMROP))
C        FORM3=BWIGN(QQA,AMOM,GAMOM)*(BWIGN(SS23,AMRO,GAMRO)+
C     $        BWIGN(SS24,AMRO,GAMRO)+BWIGN(SS34,AMRO,GAMRO))
        FORM3=BWIGN(QQA,AMOM,GAMOM)
C
        DO 304 K=1,4
         HADCUR(K)=HADCUR(K)+FORM2*FORM3*(
     $             PB  (K)*(QP1P3*P1P4-QP1P4*P1P3)
     $            +PIM3(K)*(QP1P4*P1P2-QP1P2*P1P4)
     $            +PIM4(K)*(QP1P2*P1P3-QP1P3*P1P2) )
 304    CONTINUE
 301   CONTINUE
C
      ELSE
C ===================================================================
C pi0 pi0 p0 pi- case                                            ====
C ===================================================================
       QQ=PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2
       DO 101 K=1,3
C --- loop over thre contribution of the non-omega current
        SK=(PP(K,4)+PIM4(4))**2-(PP(K,3)+PIM4(3))**2
     $    -(PP(K,2)+PIM4(2))**2-(PP(K,1)+PIM4(1))**2
C -- definition of AA matrix
C -- cronecker delta
        DO 102 I=1,4
         DO 103 J=1,4
 103     AA(I,J)=0.0
 102    AA(I,I)=1.0
C
C ... and the rest ...
        DO 104 L=1,3
         IF (L.NE.K) THEN
          DENOM=(PAA(4)-PP(L,4))**2-(PAA(3)-PP(L,3))**2
     $         -(PAA(2)-PP(L,2))**2-(PAA(1)-PP(L,1))**2
          DO 105 I=1,4
          DO 105 J=1,4
                      SIG=1.0
           IF(J.NE.4) SIG=-SIG
           AA(I,J)=AA(I,J)
     $            -SIG*(PAA(I)-2.0*PP(L,I))*(PAA(J)-PP(L,J))/DENOM
 105      CONTINUE
         ENDIF
 104    CONTINUE
C --- lets add something to HADCURR
       FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
C       FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
CCCCCCCCCCCCC       FORM1=WIGFOR(SK,AMRO,GAMRO)        (tests)
        DO 106 I=1,4
        DO 106 J=1,4
         HADCUR(I)=
     $   HADCUR(I)+CMPLX(COEF1)*FORM1*AA(I,J)*(PP(K,J)-PP(4,J))
 106    CONTINUE
C --- end of the non omega current (3 possibilities)
 101   CONTINUE
      ENDIF
      END
      FUNCTION WIGFOR(S,XM,XGAM)
      COMPLEX WIGFOR,WIGNOR
      WIGNOR=CMPLX(-XM**2,XM*XGAM)
      WIGFOR=WIGNOR/CMPLX(S-XM**2,XM*XGAM)
      END
      SUBROUTINE CURINF
C HERE the form factors of M. Finkemeier et al. start
C it ends with the string:  M. Finkemeier et al. END
      COMMON /INOUT/ INUT, IOUT
      WRITE (UNIT = IOUT,FMT = 99)
      WRITE (UNIT = IOUT,FMT = 98)
c                    print *, 'here is curinf'
 99   FORMAT(
     . /,   ' *************************************************** ',
     . /,   '   YOU ARE USING THE 4 PION DECAY MODE FORM FACTORS    ',
     . /,   '   WHICH HAVE BEEN DESCRIBED IN:',
     . /,   ' R. DECKER, M. FINKEMEIER, P. HEILIGER AND H.H. JONSSON',
     . /,   '   "TAU DECAYS INTO FOUR PIONS" ',
     . /,   '   UNIVERSITAET KARLSRUHE PREPRINT TTP 94-13 (1994);',
     . /,   '                    LNF-94/066(IR); HEP-PH/9410260  ',
     . /,   '  ',
     . /,   ' PLEASE NOTE THAT THIS ROUTINE IS USING PARAMETERS',
     . /,   ' RELATED TO THE 3 PION DECAY MODE (A1 MODE), SUCH AS',
     . /,   ' THE A1 MASS AND WIDTH (TAKEN FROM THE COMMON /PARMAS/)',
     . /,   ' AND THE 2 PION VECTOR RESONANCE FORM FACTOR (BY USING',
     . /,   ' THE ROUTINE FPIKM)'                                   ,
     . /,   ' THUS IF YOU DECIDE TO CHANGE ANY OF THESE, YOU WILL'  ,
     . /,   ' HAVE TO REFIT THE 4 PION PARAMETERS IN THE COMMON'    )
   98   FORMAT(
     .      ' BLOCK /TAU4PI/, OR YOU MIGHT GET A BAD DISCRIPTION'   ,
     . /,   ' OF TAU -> 4 PIONS'       ,
     . /,   ' for these formfactors set in routine CHOICE for',
     . /,  ' mnum.eq.102 -- AMRX=1.42 and GAMRX=.21',
     . /,  ' mnum.eq.101 -- AMRX=1.3 and GAMRX=.46 PROB1,PROB2=0.2',
     . /,  ' to optimize phase space parametrization',
     . /,   ' *************************************************** ',
     . /,   ' coded by M. Finkemeier and P. Heiliger, 29. sept. 1994',
     . /,   ' incorporated to TAUOLA by Z. Was      17. jan. 1995',
c     . /,   ' fitted on (day/month/year) by ...  ',
c     . /,   ' to .... data ',
     . /,   ' changed by: Z. Was on 17.01.95',
     . /,   ' changes by: M. Finkemeier on 30.01.95' )
      END
C
      SUBROUTINE CURINI
      COMMON /TAU4PI/ GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
     .                ROM2,ROG2,BETA2
      REAL*4          GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
     .                ROM2,ROG2,BETA2
      GOMEGA = 1.4
      GAMMA1 = 0.38
      GAMMA2 = 0.38
      ROM1   = 1.35
      ROG1   = 0.3
      BETA1  = 0.08
      ROM2   = 1.70
      ROG2   = 0.235
      BETA2  = -0.0075
      END
      COMPLEX FUNCTION BWIGA1(QA)
C     ================================================================
C     breit-wigner enhancement of a1
C     ================================================================
      COMPLEX WIGNER
      COMMON / PARMAS/ AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU,
     %                 AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1,
     %                 AMK,AMKZ,AMKST,GAMKST

C
      REAL*4           AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU,
     %                 AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1,
     %                 AMK,AMKZ,AMKST,GAMKST

      WIGNER(A,B,C)=CMPLX(1.0,0.0)/CMPLX(A-B**2,B*C)
      GAMAX=GAMA1*GFUN(QA)/GFUN(AMA1**2)
      BWIGA1=-AMA1**2*WIGNER(QA,AMA1,GAMAX)
      RETURN
      END
      COMPLEX FUNCTION BWIGEPS(QEPS)
C     =============================================================
C     breit-wigner enhancement of epsilon
C     =============================================================
      REAL QEPS,MEPS,GEPS
      MEPS=1.300
      GEPS=.600
      BWIGEPS=CMPLX(MEPS**2,-MEPS*GEPS)/
     %        CMPLX(MEPS**2-QEPS,-MEPS*GEPS)
      RETURN
      END
      COMPLEX FUNCTION FRHO4(W,XM1,XM2)
C     ===========================================================
C     rho-type resonance factor with higher radials, to be used
C     by CURR for the four pion mode
C     ===========================================================
      COMPLEX BWIGM
      COMMON /TAU4PI/ GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
     .                ROM2,ROG2,BETA2
      REAL*4          GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
     .                ROM2,ROG2,BETA2
      REAL ROM,ROG,PI,PIM,S,W
      EXTERNAL BWIG
      DATA  INIT /0/
C
C ------------ PARAMETERS --------------------
      IF (INIT.EQ.0 ) THEN
      INIT=1
      PI=3.141592654
      PIM=.140
      ROM=0.773
      ROG=0.145
      ENDIF
C -----------------------------------------------
      S=W**2
c	       print *,'rom2,rog2 =',rom2,rog2
      FRHO4=(BWIGM(S,ROM,ROG,XM1,XM2)+BETA1*BWIGM(S,ROM1,ROG1,XM1,XM2)
     & +BETA2*BWIGM(S,ROM2,ROG2,XM1,XM2))
     & /(1+BETA1+BETA2)
      RETURN
      END
      SUBROUTINE CURR(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
C     ==================================================================
C     Hadronic current for 4 pi final state, according to:
C     R. Decker, M. Finkemeier, P. Heiliger, H.H.Jonsson, TTP94-13
C
C     See also:
C     R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
C     R. Decker Z. Phys C36 (1987) 487.
C     M. Gell-Mann, D. Sharp, W. Wagner Phys. Rev. Lett 8 (1962) 261.
C     ==================================================================

      COMMON /TAU4PI/ GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
     .                ROM2,ROG2,BETA2
      REAL*4          GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
     .                ROM2,ROG2,BETA2
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
      REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
      REAL  PIM1(4),PIM2(4),PIM3(4),PIM4(4),PAA(4)
      COMPLEX HADCUR(4),FORM1,FORM2,FORM3,FPIKM
      COMPLEX BWIGN,FRHO4
      COMPLEX BWIGEPS,BWIGA1
      COMPLEX HCOMP1(4),HCOMP2(4),HCOMP3(4),HCOMP4(4)

      COMPLEX T243,T213,T143,T123,T341,T342
      COMPLEX T124,T134,T214,T234,T314,T324
      COMPLEX S2413,S2314,S1423,S1324,S34
      COMPLEX S2431,S3421
      COMPLEX BRACK1,BRACK2,BRACK3,BRACK4A,BRACK4B,BRACK4

      REAL QMP1,QMP2,QMP3,QMP4
      REAL PS43,PS41,PS42,PS34,PS14,PS13,PS24,PS23
      REAL PS21,PS31

      REAL PD243,PD241,PD213,PD143,PD142
      REAL PD123,PD341,PD342,PD413,PD423
      REAL PD124,PD134,PD214,PD234,PD314,PD324
      REAL QP1,QP2,QP3,QP4

      REAL PA(4),PB(4)
      REAL AA(4,4),PP(4,4)
      DATA PI /3.141592653589793238462643/
      DATA  FPI /93.3E-3/
      DATA INIT /0/
      BWIGN(A,XM,XG)=1.0/CMPLX(A-XM**2,XM*XG)
C
      IF (INIT.EQ.0) THEN
	CALL CURINI
	CALL CURINF
	INIT = 1
      ENDIF
C
C --- MASSES AND CONSTANTS
      G1=12.924
      G2=1475.98 * GOMEGA
      G =G1*G2
      ELPHA=-.1
      AMROP=1.7
      GAMROP=0.26
      AMOM=.782
      GAMOM=0.0085
      ARFLAT=1.0
      AROMEG=1.0
C
      FRO=0.266*AMRO**2
      COEF1=2.0*SQRT(3.0)/FPI**2*ARFLAT
      COEF2=FRO*G*AROMEG
C --- INITIALIZATION OF FOUR VECTORS
      DO 7 K=1,4
      DO 8 L=1,4
 8    AA(K,L)=0.0
      HADCUR(K)=CMPLX(0.0)
      PAA(K)=PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K)
      PP(1,K)=PIM1(K)
      PP(2,K)=PIM2(K)
      PP(3,K)=PIM3(K)
 7    PP(4,K)=PIM4(K)
C
      IF (MNUM.EQ.1) THEN
C ===================================================================
C PI- PI- P0 PI+ CASE                                            ====
C ===================================================================
       QQ=PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2

C FIRST DEFINITION OF SCALAR PRODUCTS OF MOMENTUM VECTORS

C DEFINE (Q-PI)**2 AS QPI:

      QMP1=(PIM2(4)+PIM3(4)+PIM4(4))**2-(PIM2(3)+PIM3(3)+PIM4(3))**2
     %   -(PIM2(2)+PIM3(2)+PIM4(2))**2-(PIM2(1)+PIM3(1)+PIM4(1))**2

      QMP2=(PIM1(4)+PIM3(4)+PIM4(4))**2-(PIM1(3)+PIM3(3)+PIM4(3))**2
     %   -(PIM1(2)+PIM3(2)+PIM4(2))**2-(PIM1(1)+PIM3(1)+PIM4(1))**2

      QMP3=(PIM1(4)+PIM2(4)+PIM4(4))**2-(PIM1(3)+PIM2(3)+PIM4(3))**2
     %   -(PIM1(2)+PIM2(2)+PIM4(2))**2-(PIM1(1)+PIM2(1)+PIM4(1))**2

      QMP4=(PIM1(4)+PIM2(4)+PIM3(4))**2-(PIM1(3)+PIM2(3)+PIM3(3))**2
     %   -(PIM1(2)+PIM2(2)+PIM3(2))**2-(PIM1(1)+PIM2(1)+PIM3(1))**2

C DEFINE (PI+PK)**2 AS PSIK:

      PS43=(PIM4(4)+PIM3(4))**2-(PIM4(3)+PIM3(3))**2
     %    -(PIM4(2)+PIM3(2))**2-(PIM4(1)+PIM3(1))**2

      PS41=(PIM4(4)+PIM1(4))**2-(PIM4(3)+PIM1(3))**2
     %    -(PIM4(2)+PIM1(2))**2-(PIM4(1)+PIM1(1))**2

      PS42=(PIM4(4)+PIM2(4))**2-(PIM4(3)+PIM2(3))**2
     %    -(PIM4(2)+PIM2(2))**2-(PIM4(1)+PIM2(1))**2

      PS34=PS43

      PS14=PS41

      PS13=(PIM1(4)+PIM3(4))**2-(PIM1(3)+PIM3(3))**2
     %    -(PIM1(2)+PIM3(2))**2-(PIM1(1)+PIM3(1))**2

      PS24=PS42

      PS23=(PIM2(4)+PIM3(4))**2-(PIM2(3)+PIM3(3))**2
     %    -(PIM2(2)+PIM3(2))**2-(PIM2(1)+PIM3(1))**2

      PD243=PIM2(4)*(PIM4(4)-PIM3(4))-PIM2(3)*(PIM4(3)-PIM3(3))
     %     -PIM2(2)*(PIM4(2)-PIM3(2))-PIM2(1)*(PIM4(1)-PIM3(1))

      PD241=PIM2(4)*(PIM4(4)-PIM1(4))-PIM2(3)*(PIM4(3)-PIM1(3))
     %     -PIM2(2)*(PIM4(2)-PIM1(2))-PIM2(1)*(PIM4(1)-PIM1(1))

      PD213=PIM2(4)*(PIM1(4)-PIM3(4))-PIM2(3)*(PIM1(3)-PIM3(3))
     %     -PIM2(2)*(PIM1(2)-PIM3(2))-PIM2(1)*(PIM1(1)-PIM3(1))

      PD143=PIM1(4)*(PIM4(4)-PIM3(4))-PIM1(3)*(PIM4(3)-PIM3(3))
     %     -PIM1(2)*(PIM4(2)-PIM3(2))-PIM1(1)*(PIM4(1)-PIM3(1))

      PD142=PIM1(4)*(PIM4(4)-PIM2(4))-PIM1(3)*(PIM4(3)-PIM2(3))
     %     -PIM1(2)*(PIM4(2)-PIM2(2))-PIM1(1)*(PIM4(1)-PIM2(1))

      PD123=PIM1(4)*(PIM2(4)-PIM3(4))-PIM1(3)*(PIM2(3)-PIM3(3))
     %     -PIM1(2)*(PIM2(2)-PIM3(2))-PIM1(1)*(PIM2(1)-PIM3(1))

      PD341=PIM3(4)*(PIM4(4)-PIM1(4))-PIM3(3)*(PIM4(3)-PIM1(3))
     %     -PIM3(2)*(PIM4(2)-PIM1(2))-PIM3(1)*(PIM4(1)-PIM1(1))

      PD342=PIM3(4)*(PIM4(4)-PIM2(4))-PIM3(3)*(PIM4(3)-PIM2(3))
     %     -PIM3(2)*(PIM4(2)-PIM2(2))-PIM3(1)*(PIM4(1)-PIM2(1))

      PD413=PIM4(4)*(PIM1(4)-PIM3(4))-PIM4(3)*(PIM1(3)-PIM3(3))
     %     -PIM4(2)*(PIM1(2)-PIM3(2))-PIM4(1)*(PIM1(1)-PIM3(1))

      PD423=PIM4(4)*(PIM2(4)-PIM3(4))-PIM4(3)*(PIM2(3)-PIM3(3))
     %     -PIM4(2)*(PIM2(2)-PIM3(2))-PIM4(1)*(PIM2(1)-PIM3(1))

C DEFINE Q*PI = QPI:

      QP1=PIM1(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
     %   -PIM1(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
     %   -PIM1(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
     %   -PIM1(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))

      QP2=PIM2(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
     %   -PIM2(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
     %   -PIM2(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
     %   -PIM2(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))

      QP3=PIM3(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
     %   -PIM3(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
     %   -PIM3(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
     %   -PIM3(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))

      QP4=PIM4(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
     %   -PIM4(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
     %   -PIM4(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
     %   -PIM4(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))

C DEFINE T(PI;PJ,PK)= TIJK:

      T243=BWIGA1(QMP2)*FPIKM(SQRT(PS43),AMPI,AMPI)*GAMMA1
      T213=BWIGA1(QMP2)*FPIKM(SQRT(PS13),AMPI,AMPI)*GAMMA1
      T143=BWIGA1(QMP1)*FPIKM(SQRT(PS43),AMPI,AMPI)*GAMMA1
      T123=BWIGA1(QMP1)*FPIKM(SQRT(PS23),AMPI,AMPI)*GAMMA1
      T341=BWIGA1(QMP3)*FPIKM(SQRT(PS41),AMPI,AMPI)*GAMMA1
      T342=BWIGA1(QMP3)*FPIKM(SQRT(PS42),AMPI,AMPI)*GAMMA1

C DEFINE S(I,J;K,L)= SIJKL:

      S2413=FRHO4(SQRT(PS24),AMPI,AMPI)*GAMMA2
      S2314=FRHO4(SQRT(PS23),AMPI,AMPI)*BWIGEPS(PS14)*GAMMA2
      S1423=FRHO4(SQRT(PS14),AMPI,AMPI)*GAMMA2
      S1324=FRHO4(SQRT(PS13),AMPI,AMPI)*BWIGEPS(PS24)*GAMMA2
      S34=FRHO4(SQRT(PS34),AMPI,AMPI)*GAMMA2

C DEFINITION OF AMPLITUDE, FIRST THE [] BRACKETS:

      BRACK1=2.*T143+2.*T243+T123+T213
     %    +T341*(PD241/QMP3-1.)+T342*(PD142/QMP3-1.)
     %    +3./4.*(S1423+S2413-S2314-S1324)-3.*S34

      BRACK2=2.*T143*PD243/QMP1+3.*T213
     %    +T123*(2.*PD423/QMP1+1.)+T341*(PD241/QMP3+3.)
     %    +T342*(PD142/QMP3+1.)
     %    -3./4.*(S2314+3.*S1324+3.*S1423+S2413)

      BRACK3=2.*T243*PD143/QMP2+3.*T123
     %    +T213*(2.*PD413/QMP2+1.)+T341*(PD241/QMP3+1.)
     %    +T342*(PD142/QMP3+3.)
     %    -3./4.*(3.*S2314+S1324+S1423+3.*S2413)

      BRACK4A=2.*T143*(PD243/QQ*(QP1/QMP1+1.)+PD143/QQ)
     %     +2.*T243*(PD143/QQ*(QP2/QMP2+1.)+PD243/QQ)
     %     +T123+T213
     %     +2.*T123*(PD423/QQ*(QP1/QMP1+1.)+PD123/QQ)
     %     +2.*T213*(PD413/QQ*(QP2/QMP2+1.)+PD213/QQ)
     %     +T341*(PD241/QMP3+1.-2.*PD241/QQ*(QP3/QMP3+1.)
     %           -2.*PD341/QQ)
     %     +T342*(PD142/QMP3+1.-2.*PD142/QQ*(QP3/QMP3+1.)
     %           -2.*PD342/QQ)

      BRACK4B=-3./4.*(S2314*(2.*(QP2-QP3)/QQ+1.)
     %             +S1324*(2.*(QP1-QP3)/QQ+1.)
     %             +S1423*(2.*(QP1-QP4)/QQ+1.)
     %             +S2413*(2.*(QP2-QP4)/QQ+1.)
     %             +4.*S34*(QP4-QP3)/QQ)

      BRACK4=BRACK4A+BRACK4B

      DO 208 K=1,4

      HCOMP1(K)=(PIM3(K)-PIM4(K))*BRACK1
      HCOMP2(K)=PIM1(K)*BRACK2
      HCOMP3(K)=PIM2(K)*BRACK3
      HCOMP4(K)=(PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K))*BRACK4

 208  CONTINUE

      DO 209 I=1,4

      HADCUR(I)=HCOMP1(I)-HCOMP2(I)-HCOMP3(I)+HCOMP4(I)
      HADCUR(I)=-COEF1*FRHO4(SQRT(QQ),AMPI,AMPI)*HADCUR(I)

 209  CONTINUE

C --- END OF THE NON OMEGA CURRENT (3 POSSIBILITIES)
 201   CONTINUE
C
C
C --- THERE ARE TWO POSSIBILITIES FOR OMEGA CURRENT
C --- PA PB ARE CORRESPONDING FIRST AND SECOND PI-S
       DO 301 KK=1,2
        DO 302 I=1,4
         PA(I)=PP(KK,I)
         PB(I)=PP(3-KK,I)
 302    CONTINUE
C --- LORENTZ INVARIANTS
         QQA=0.0
         SS23=0.0
         SS24=0.0
         SS34=0.0
         QP1P2=0.0
         QP1P3=0.0
         QP1P4=0.0
         P1P2 =0.0
         P1P3 =0.0
         P1P4 =0.0
        DO 303 K=1,4
                     SIGN=-1.0
         IF (K.EQ.4) SIGN= 1.0
         QQA=QQA+SIGN*(PAA(K)-PA(K))**2
         SS23=SS23+SIGN*(PB(K)  +PIM3(K))**2
         SS24=SS24+SIGN*(PB(K)  +PIM4(K))**2
         SS34=SS34+SIGN*(PIM3(K)+PIM4(K))**2
         QP1P2=QP1P2+SIGN*(PAA(K)-PA(K))*PB(K)
         QP1P3=QP1P3+SIGN*(PAA(K)-PA(K))*PIM3(K)
         QP1P4=QP1P4+SIGN*(PAA(K)-PA(K))*PIM4(K)
         P1P2=P1P2+SIGN*PA(K)*PB(K)
         P1P3=P1P3+SIGN*PA(K)*PIM3(K)
         P1P4=P1P4+SIGN*PA(K)*PIM4(K)
 303    CONTINUE
C
        FORM2=COEF2*(BWIGN(QQ,AMRO,GAMRO)+ELPHA*BWIGN(QQ,AMROP,GAMROP))
C        FORM3=BWIGN(QQA,AMOM,GAMOM)*(BWIGN(SS23,AMRO,GAMRO)+
C     $        BWIGN(SS24,AMRO,GAMRO)+BWIGN(SS34,AMRO,GAMRO))
        FORM3=BWIGN(QQA,AMOM,GAMOM)
C
        DO 304 K=1,4
          HADCUR(K)=HADCUR(K)+FORM2*FORM3*(
     $              PB  (K)*(QP1P3*P1P4-QP1P4*P1P3)
     $             +PIM3(K)*(QP1P4*P1P2-QP1P2*P1P4)
     $             +PIM4(K)*(QP1P2*P1P3-QP1P3*P1P2) )
 304    CONTINUE
 301   CONTINUE
C
      ELSE
C ===================================================================
C PI0 PI0 P0 PI- CASE                                            ====
C ===================================================================
       QQ=PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2

C FIRST DEFINITION OF SCALAR PRODUCTS OF MOMENTUM VECTORS

C DEFINE (Q-PI)**2 AS QPI:

      QMP1=(PIM2(4)+PIM3(4)+PIM4(4))**2-(PIM2(3)+PIM3(3)+PIM4(3))**2
     %   -(PIM2(2)+PIM3(2)+PIM4(2))**2-(PIM2(1)+PIM3(1)+PIM4(1))**2

      QMP2=(PIM1(4)+PIM3(4)+PIM4(4))**2-(PIM1(3)+PIM3(3)+PIM4(3))**2
     %   -(PIM1(2)+PIM3(2)+PIM4(2))**2-(PIM1(1)+PIM3(1)+PIM4(1))**2

      QMP3=(PIM1(4)+PIM2(4)+PIM4(4))**2-(PIM1(3)+PIM2(3)+PIM4(3))**2
     %   -(PIM1(2)+PIM2(2)+PIM4(2))**2-(PIM1(1)+PIM2(1)+PIM4(1))**2

      QMP4=(PIM1(4)+PIM2(4)+PIM3(4))**2-(PIM1(3)+PIM2(3)+PIM3(3))**2
     %   -(PIM1(2)+PIM2(2)+PIM3(2))**2-(PIM1(1)+PIM2(1)+PIM3(1))**2

C DEFINE (PI+PK)**2 AS PSIK:

      PS14=(PIM1(4)+PIM4(4))**2-(PIM1(3)+PIM4(3))**2
     %    -(PIM1(2)+PIM4(2))**2-(PIM1(1)+PIM4(1))**2

      PS21=(PIM2(4)+PIM1(4))**2-(PIM2(3)+PIM1(3))**2
     %    -(PIM2(2)+PIM1(2))**2-(PIM2(1)+PIM1(1))**2

      PS23=(PIM2(4)+PIM3(4))**2-(PIM2(3)+PIM3(3))**2
     %    -(PIM2(2)+PIM3(2))**2-(PIM2(1)+PIM3(1))**2

      PS24=(PIM2(4)+PIM4(4))**2-(PIM2(3)+PIM4(3))**2
     %    -(PIM2(2)+PIM4(2))**2-(PIM2(1)+PIM4(1))**2

      PS31=(PIM3(4)+PIM1(4))**2-(PIM3(3)+PIM1(3))**2
     %    -(PIM3(2)+PIM1(2))**2-(PIM3(1)+PIM1(1))**2

      PS34=(PIM3(4)+PIM4(4))**2-(PIM3(3)+PIM4(3))**2
     %    -(PIM3(2)+PIM4(2))**2-(PIM3(1)+PIM4(1))**2

      PD324=PIM3(4)*(PIM2(4)-PIM4(4))-PIM3(3)*(PIM2(3)-PIM4(3))
     %     -PIM3(2)*(PIM2(2)-PIM4(2))-PIM3(1)*(PIM2(1)-PIM4(1))

      PD314=PIM3(4)*(PIM1(4)-PIM4(4))-PIM3(3)*(PIM1(3)-PIM4(3))
     %     -PIM3(2)*(PIM1(2)-PIM4(2))-PIM3(1)*(PIM1(1)-PIM4(1))

      PD234=PIM2(4)*(PIM3(4)-PIM4(4))-PIM2(3)*(PIM3(3)-PIM4(3))
     %     -PIM2(2)*(PIM3(2)-PIM4(2))-PIM2(1)*(PIM3(1)-PIM4(1))

      PD214=PIM2(4)*(PIM1(4)-PIM4(4))-PIM2(3)*(PIM1(3)-PIM4(3))
     %     -PIM2(2)*(PIM1(2)-PIM4(2))-PIM2(1)*(PIM1(1)-PIM4(1))

      PD134=PIM1(4)*(PIM3(4)-PIM4(4))-PIM1(3)*(PIM3(3)-PIM4(3))
     %     -PIM1(2)*(PIM3(2)-PIM4(2))-PIM1(1)*(PIM3(1)-PIM4(1))

      PD124=PIM1(4)*(PIM2(4)-PIM4(4))-PIM1(3)*(PIM2(3)-PIM4(3))
     %     -PIM1(2)*(PIM2(2)-PIM4(2))-PIM1(1)*(PIM2(1)-PIM4(1))

C DEFINE Q*PI = QPI:

      QP1=PIM1(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
     %   -PIM1(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
     %   -PIM1(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
     %   -PIM1(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))

      QP2=PIM2(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
     %   -PIM2(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
     %   -PIM2(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
     %   -PIM2(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))

      QP3=PIM3(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
     %   -PIM3(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
     %   -PIM3(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
     %   -PIM3(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))

      QP4=PIM4(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
     %   -PIM4(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
     %   -PIM4(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
     %   -PIM4(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))

C DEFINE T(PI;PJ,PK)= TIJK:

      T324=BWIGA1(QMP3)*FPIKM(SQRT(PS24),AMPI,AMPI)*GAMMA1
      T314=BWIGA1(QMP3)*FPIKM(SQRT(PS14),AMPI,AMPI)*GAMMA1
      T234=BWIGA1(QMP2)*FPIKM(SQRT(PS34),AMPI,AMPI)*GAMMA1
      T214=BWIGA1(QMP2)*FPIKM(SQRT(PS14),AMPI,AMPI)*GAMMA1
      T134=BWIGA1(QMP1)*FPIKM(SQRT(PS34),AMPI,AMPI)*GAMMA1
      T124=BWIGA1(QMP1)*FPIKM(SQRT(PS24),AMPI,AMPI)*GAMMA1

C DEFINE S(I,J;K,L)= SIJKL:

      S1423=FRHO4(SQRT(PS14),AMPI,AMPI)*BWIGEPS(PS23)*GAMMA2
      S2431=FRHO4(SQRT(PS24),AMPI,AMPI)*BWIGEPS(PS31)*GAMMA2
      S3421=FRHO4(SQRT(PS34),AMPI,AMPI)*BWIGEPS(PS21)*GAMMA2

C DEFINITION OF AMPLITUDE, FIRST THE [] BRACKETS:

      BRACK1=T234+T324+2.*T314+T134+2.*T214+T124
     %    +T134*PD234/QMP1+T124*PD324/QMP1
     %    -3./2.*(S3421+S2431+2.*S1423)

      BRACK2=T234*(1.+2.*PD134/QMP2)+3.*T324+3.*T124
     %    +T134*(1.-PD234/QMP1)+2.*T214*PD314/QMP2
     %    -T124*PD324/QMP1
     %    -3./2.*(S3421+3.*S2431)

      BRACK3=T324*(1.+2.*PD124/QMP3)+3.*T234+3.*T134
     %    +T124*(1.-PD324/QMP1)+2.*T314*PD214/QMP3
     %    -T134*PD234/QMP1
     %    -3./2.*(3.*S3421+S2431)

      BRACK4A=2.*T234*(1./2.+PD134/QQ*(QP2/QMP2+1.)+PD234/QQ)
     %     +2.*T324*(1./2.+PD124/QQ*(QP3/QMP3+1.)+PD324/QQ)
     %     +2.*T134*(1./2.+PD234/QQ*(QP1/QMP1+1.)
     %              -1./2.*PD234/QMP1+PD134/QQ)
     %     +2.*T124*(1./2.+PD324/QQ*(QP1/QMP1+1.)
     %              -1./2.*PD324/QMP1+PD124/QQ)
     %     +2.*T214*(PD314/QQ*(QP2/QMP2+1.)+PD214/QQ)
     %     +2.*T314*(PD214/QQ*(QP3/QMP3+1.)+PD314/QQ)

      BRACK4B=-3./2.*(S3421*(2.*(QP3-QP4)/QQ+1.)
     %             +S2431*(2.*(QP2-QP4)/QQ+1.)
     %             +S1423*2.*(QP1-QP4)/QQ)

      BRACK4=BRACK4A+BRACK4B

      DO 308 K=1,4

      HCOMP1(K)=(PIM1(K)-PIM4(K))*BRACK1
      HCOMP2(K)=PIM2(K)*BRACK2
      HCOMP3(K)=PIM3(K)*BRACK3
      HCOMP4(K)=(PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K))*BRACK4

 308  CONTINUE

      DO 309 I=1,4

      HADCUR(I)=HCOMP1(I)+HCOMP2(I)+HCOMP3(I)-HCOMP4(I)
      HADCUR(I)=COEF1*FRHO4(SQRT(QQ),AMPI,AMPI)*HADCUR(I)

 309  CONTINUE

 101   CONTINUE
      ENDIF
C M. Finkemeier et al. END
      END


module da_spectral

#ifdef DM_PARALLEL
!  use mpi, only : mpi_sum
#endif

   use da_control, only : trace_use, its,ite,jts,jte, &
      da_zero_complex, jds,jde,comm,ierr,test_transforms, stdout, pi, &
      gaussian_lats, earth_radius, alpha_corr_type, alpha_corr_scale, &
      alpha_corr_unit1, alpha_corr_unit2, filename_len, num_alpha_corr_types, &
      earth_radius, alpha_corr_type_exp, alpha_corr_type_soar, &
      alpha_corr_type_gaussian, trace_use
#ifdef FFTPACK
   use da_control, only : ide
#endif
   use da_define_structures, only : xbx_type
#ifdef DM_PARALLEL
   use da_par_util1, only : true_mpi_complex
#endif
   use da_reporting, only : da_error, message
   use da_tools_serial, only : da_get_unit, da_free_unit
   use da_tracing, only : da_trace_entry, da_trace_exit

   !-----------------------------------------------------------------------
   ! Contains all necessary routines to perform global spectral transform
   ! (based on Fourier and Legendre decompositions).
   !-----------------------------------------------------------------------

   implicit none

#ifdef DM_PARALLEL
   include 'mpif.h'
#endif

contains

#include "da_asslegpol.inc"
#include "da_calc_power_spectrum.inc"
#include "da_get_gausslats.inc"
#include "da_get_reglats.inc"
#include "da_initialize_h.inc"
#include "da_legtra_inv.inc"
#include "da_legtra.inc"
#include "da_setlegpol_test.inc"
#include "da_setlegpol.inc"
#include "da_test_spectral.inc"
#include "da_vtovv_spectral.inc"
#include "da_vv_to_v_spectral.inc"
#include "da_vtovv_spectral_adj.inc"
#include "da_legtra_inv_adj.inc"
#include "da_apply_power.inc"

end module da_spectral


MODULE module_mp_kessler

CONTAINS

   SUBROUTINE kessler( t, qv, qc, qr, rho, pii &
                      ,dt_in, z, xlv, cp &
                      ,EP2,SVP1,SVP2,SVP3,SVPT0,rhowater &
                      ,dz8w &
                      ,RAINNC, RAINNCV &
                      ,ids,ide, jds,jde, kds,kde &
                      ,ims,ime, jms,jme, kms,kme &
                      ,its,ite, jts,jte, kts,kte &
                                                                )

   IMPLICIT NONE

   REAL , PARAMETER :: c1 = .001
   REAL , PARAMETER :: c2 = .001
   REAL , PARAMETER :: c3 = 2.2
   REAL , PARAMETER :: c4 = .875
   REAL , PARAMETER :: fudge = 1.0
   REAL , PARAMETER :: mxfall = 10.0

   INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
                                     ims,ime, jms,jme, kms,kme, &
                                     its,ite, jts,jte, kts,kte
   REAL , INTENT(IN ) :: xlv, cp
   REAL , INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0
   REAL , INTENT(IN ) :: rhowater

   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
         INTENT(INOUT) :: &
                                                            t , &
                                                            qv, &
                                                            qc, &
                                                            qr

   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
         INTENT(IN ) :: &
                                                           rho, &
                                                           pii, &
                                                          dz8w

   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
         INTENT(IN ) :: z

   REAL, INTENT(IN ) :: dt_in

   REAL, DIMENSION( ims:ime , jms:jme ), &
         INTENT(INOUT) :: RAINNC, &
                                                       RAINNCV

   REAL :: qrprod, ern, gam, rcgs, rcgsi
   REAL, DIMENSION( its:ite , kts:kte, jts:jte ) :: prod
   REAL, DIMENSION(kts:kte) :: vt, prodk, vtden,rdzk,rhok,factor,rdzw
   INTEGER :: i,j,k
   INTEGER :: nfall, n, nfall_new
   REAL :: qrr, pressure, temp, es, qvs, dz, dt
   REAL :: f5, dtfall, rdz, product
   REAL :: max_heating, max_condense, max_rain, maxqrp
   REAL :: vtmax, ernmax, crmax, factorn, time_sediment
   REAL :: qcr, factorr, ppt
   REAL, PARAMETER :: max_cr_sedimentation = 0.75

   INTEGER :: imax, kmax

    dt = dt_in

    f5 = svp2*(svpt0-svp3)*xlv/cp
    ernmax = 0.
    maxqrp = -100.

      max_heating = 0.
      max_condense = 0.
      max_rain = 0.

  microphysics_outer_j_loop: DO j = jts, jte

  sedimentation_outer_i_loop: DO i = its,ite

   crmax = 0.

   DO k = 1, kte
     prodk(k) = qr(i,k,j)
     rhok(k) = rho(i,k,j)
     qrr = amax1(0.,qr(i,k,j)*0.001*rhok(k))
     vtden(k) = sqrt(rhok(1)/rhok(k))
     vt(k) = 36.34*(qrr**0.1364) * vtden(k)

     rdzw(k) = 1./dz8w(i,k,j)
     crmax = amax1(vt(k)*dt*rdzw(k),crmax)
   ENDDO
   DO k = 1, kte-1
     rdzk(k) = 1./(z(i,k+1,j) - z(i,k,j))
   ENDDO
   rdzk(kte) = 1./(z(i,kte,j) - z(i,kte-1,j))

   nfall = max(1,nint(0.5+crmax/max_cr_sedimentation))
   dtfall = dt / float(nfall)
   time_sediment = dt

   column_sedimentation: DO WHILE ( nfall > 0 )

   time_sediment = time_sediment - dtfall
   DO k = 1, kte-1
     factor(k) = dtfall*rdzk(k)/rhok(k)
   ENDDO
   factor(kte) = dtfall*rdzk(kte)

   ppt=0.

      k = 1
      ppt=rhok(k)*prodk(k)*vt(k)*dtfall/rhowater
      RAINNCV(i,j)=ppt*1000.
      RAINNC(i,j)=RAINNC(i,j)+ppt*1000.

      DO k = kts, kte-1
        prodk(k) = prodk(k) - factor(k) &
                  * (rhok(k)*prodk(k)*vt(k) &
                    -rhok(k+1)*prodk(k+1)*vt(k+1))
      ENDDO

      k = kte
      prodk(k) = prodk(k) - factor(k)*prodk(k)*vt(k)

      IF( nfall > 1 ) THEN

        nfall = nfall - 1
        crmax = 0.
        DO k = kts, kte
          qrr = amax1(0.,prodk(k)*0.001*rhok(k))
          vt(k) = 36.34*(qrr**0.1364) * vtden(k)

          crmax = amax1(vt(k)*time_sediment*rdzw(k),crmax)
        ENDDO

        nfall_new = max(1,nint(0.5+crmax/max_cr_sedimentation))
        if (nfall_new /= nfall ) then
          nfall = nfall_new
          dtfall = time_sediment/nfall
        end if

      ELSE

        DO k=kts,kte
          prod(i,k,j) = prodk(k)
        ENDDO
        nfall = 0

      END IF

   ENDDO column_sedimentation

   ENDDO sedimentation_outer_i_loop

     DO k = kts, kte
     DO i = its, ite
       factorn = 1.0 / (1.+c3*dt*amax1(0.,qr(i,k,j))**c4)
       qrprod = qc(i,k,j) * (1.0 - factorn) &
             + factorn*c1*dt*amax1(qc(i,k,j)-c2,0.)
       rcgs = 0.001*rho(i,k,j)

       qc(i,k,j) = amax1(qc(i,k,j) - qrprod,0.)
       qr(i,k,j) = (qr(i,k,j) + prod(i,k,j)-qr(i,k,j))
       qr(i,k,j) = amax1(qr(i,k,j) + qrprod,0.)

       temp = pii(i,k,j)*t(i,k,j)
       pressure = 1.000e+05 * (pii(i,k,j)**(1004./287.))
       gam = 2.5e+06/(1004.*pii(i,k,j))

       es = 1000.*svp1*exp(svp2*(temp-svpt0)/(temp-svp3))
       qvs = ep2*es/(pressure-es)

       prod(i,k,j) = (qv(i,k,j)-qvs) / (1.+pressure/(pressure-es)*qvs*f5/(temp-svp3)**2)
       ern = amin1(dt*(((1.6+124.9*(rcgs*qr(i,k,j))**.2046) &
          *(rcgs*qr(i,k,j))**.525)/(2.55e8/(pressure*qvs) &
          +5.4e5))*(dim(qvs,qv(i,k,j))/(rcgs*qvs)), &
          amax1(-prod(i,k,j)-qc(i,k,j),0.),qr(i,k,j))

       product = amax1(prod(i,k,j),-qc(i,k,j))
       t (i,k,j) = t(i,k,j) + gam*(product - ern)
       qv(i,k,j) = amax1(qv(i,k,j) - product + ern,0.)
       qc(i,k,j) = qc(i,k,j) + product
       qr(i,k,j) = qr(i,k,j) - ern

     ENDDO
     ENDDO

  ENDDO microphysics_outer_j_loop

  RETURN

  END SUBROUTINE kessler

END MODULE module_mp_kessler


!
!   FnVFP.f90
!
!
!   Created by Kurt Mitman on 10/10/14.
!
!

DOUBLE PRECISION FUNCTION FnVFP(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons,qltemp
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

call basefun(GridB,nb,bsav,vals,inds)

! call BiLinInterp1(nb,GridB,ngpPh,PhGrid,ql(:,gil,gim,gih,giExo,:,gij+1),bsav,gPh,qltemp)
qltemp=0.0d0

cons=gliq+qltemp*gloc*ghouse-FnQb(bsav,(gPh-gmort)*ghouse)*bsav

if(cons .GT. cmin) then

FnVFP = -1.0d0*(uown(cons,ghouse,gij)+bet*(vals(1)*EVown(inds(1),gil,gim,gih,gij)+vals(2)*EVown(inds(2),gil,gim,gih,gij)))

else

FnVFP = 1.0d10+10.0d0*(cmin-cons)

endif

END FUNCTION FnVFP