! { dg-do run { xfail i386-*-freebsd* } }

  use :: ieee_arithmetic
  implicit none

  real :: sx1, sx2, sx3
  double precision :: dx1, dx2, dx3
  integer, parameter :: s = kind(sx1), d = kind(dx1)
  type(ieee_round_type) :: mode

  ! Test IEEE_CLASS

  if (ieee_support_datatype(0._s)) then
    sx1 = 0.1_s
    if (ieee_class(sx1) /= ieee_positive_normal) STOP 1
    if (ieee_class(-sx1) /= ieee_negative_normal) STOP 2
    sx1 = huge(sx1)
    if (ieee_class(sx1) /= ieee_positive_normal) STOP 3
    if (ieee_class(-sx1) /= ieee_negative_normal) STOP 4
    if (ieee_class(2*sx1) /= ieee_positive_inf) STOP 5
    if (ieee_class(2*(-sx1)) /= ieee_negative_inf) STOP 6
    sx1 = tiny(sx1)
    if (ieee_class(sx1) /= ieee_positive_normal) STOP 7
    if (ieee_class(-sx1) /= ieee_negative_normal) STOP 8
    if (ieee_class(sx1 / 2) /= ieee_positive_denormal) STOP 9
    if (ieee_class((-sx1) / 2) /= ieee_negative_denormal) STOP 10
    sx1 = -1
    if (ieee_class(sqrt(sx1)) /= ieee_quiet_nan) STOP 11
    sx1 = 0
    if (ieee_class(sx1) /= ieee_positive_zero) STOP 12
    if (ieee_class(-sx1) /= ieee_negative_zero) STOP 13
  end if

  if (ieee_support_datatype(0._d)) then
    dx1 = 0.1_d
    if (ieee_class(dx1) /= ieee_positive_normal) STOP 14
    if (ieee_class(-dx1) /= ieee_negative_normal) STOP 15
    dx1 = huge(dx1)
    if (ieee_class(dx1) /= ieee_positive_normal) STOP 16
    if (ieee_class(-dx1) /= ieee_negative_normal) STOP 17
    if (ieee_class(2*dx1) /= ieee_positive_inf) STOP 18
    if (ieee_class(2*(-dx1)) /= ieee_negative_inf) STOP 19
    dx1 = tiny(dx1)
    if (ieee_class(dx1) /= ieee_positive_normal) STOP 20
    if (ieee_class(-dx1) /= ieee_negative_normal) STOP 21
    if (ieee_class(dx1 / 2) /= ieee_positive_denormal) STOP 22
    if (ieee_class((-dx1) / 2) /= ieee_negative_denormal) STOP 23
    dx1 = -1
    if (ieee_class(sqrt(dx1)) /= ieee_quiet_nan) STOP 24
    dx1 = 0
    if (ieee_class(dx1) /= ieee_positive_zero) STOP 25
    if (ieee_class(-dx1) /= ieee_negative_zero) STOP 26
  end if

  ! Test IEEE_VALUE and IEEE_UNORDERED

  if (ieee_support_datatype(0._s)) then
    sx1 = ieee_value(sx1, ieee_quiet_nan)
    if (.not. ieee_is_nan(sx1)) STOP 27
    if (.not. ieee_unordered(sx1, sx1)) STOP 28
    if (.not. ieee_unordered(sx1, 0._s)) STOP 29
    if (.not. ieee_unordered(sx1, 0._d)) STOP 30
    if (.not. ieee_unordered(0._s, sx1)) STOP 31
    if (.not. ieee_unordered(0._d, sx1)) STOP 32
    if (ieee_unordered(0._s, 0._s)) STOP 33

    sx1 = ieee_value(sx1, ieee_positive_inf)
    if (ieee_is_finite(sx1)) STOP 34
    if (ieee_is_nan(sx1)) STOP 35
    if (ieee_is_negative(sx1)) STOP 36
    if (ieee_is_normal(sx1)) STOP 37

    sx1 = ieee_value(sx1, ieee_negative_inf)
    if (ieee_is_finite(sx1)) STOP 38
    if (ieee_is_nan(sx1)) STOP 39
    if (.not. ieee_is_negative(sx1)) STOP 40
    if (ieee_is_normal(sx1)) STOP 41

    sx1 = ieee_value(sx1, ieee_positive_normal)
    if (.not. ieee_is_finite(sx1)) STOP 42
    if (ieee_is_nan(sx1)) STOP 43
    if (ieee_is_negative(sx1)) STOP 44
    if (.not. ieee_is_normal(sx1)) STOP 45

    sx1 = ieee_value(sx1, ieee_negative_normal)
    if (.not. ieee_is_finite(sx1)) STOP 46
    if (ieee_is_nan(sx1)) STOP 47
    if (.not. ieee_is_negative(sx1)) STOP 48
    if (.not. ieee_is_normal(sx1)) STOP 49

    sx1 = ieee_value(sx1, ieee_positive_denormal)
    if (.not. ieee_is_finite(sx1)) STOP 50
    if (ieee_is_nan(sx1)) STOP 51
    if (ieee_is_negative(sx1)) STOP 52
    if (ieee_is_normal(sx1)) STOP 53
    if (sx1 <= 0) STOP 54
    if (sx1 >= tiny(sx1)) STOP 55

    sx1 = ieee_value(sx1, ieee_negative_denormal)
    if (.not. ieee_is_finite(sx1)) STOP 56
    if (ieee_is_nan(sx1)) STOP 57
    if (.not. ieee_is_negative(sx1)) STOP 58
    if (ieee_is_normal(sx1)) STOP 59
    if (sx1 >= 0) STOP 60
    if (sx1 <= -tiny(sx1)) STOP 61

    sx1 = ieee_value(sx1, ieee_positive_zero)
    if (.not. ieee_is_finite(sx1)) STOP 62
    if (ieee_is_nan(sx1)) STOP 63
    if (ieee_is_negative(sx1)) STOP 64
    if (.not. ieee_is_normal(sx1)) STOP 65
    if (sx1 /= 0) STOP 66

    sx1 = ieee_value(sx1, ieee_negative_zero)
    if (.not. ieee_is_finite(sx1)) STOP 67
    if (ieee_is_nan(sx1)) STOP 68
    if (.not. ieee_is_negative(sx1)) STOP 69
    if (.not. ieee_is_normal(sx1)) STOP 70
    if (sx1 /= 0) STOP 71

  end if

  if (ieee_support_datatype(0._d)) then
    dx1 = ieee_value(dx1, ieee_quiet_nan)
    if (.not. ieee_is_nan(dx1)) STOP 72
    if (.not. ieee_unordered(dx1, dx1)) STOP 73
    if (.not. ieee_unordered(dx1, 0._s)) STOP 74
    if (.not. ieee_unordered(dx1, 0._d)) STOP 75
    if (.not. ieee_unordered(0._s, dx1)) STOP 76
    if (.not. ieee_unordered(0._d, dx1)) STOP 77
    if (ieee_unordered(0._d, 0._d)) STOP 78

    dx1 = ieee_value(dx1, ieee_positive_inf)
    if (ieee_is_finite(dx1)) STOP 79
    if (ieee_is_nan(dx1)) STOP 80
    if (ieee_is_negative(dx1)) STOP 81
    if (ieee_is_normal(dx1)) STOP 82

    dx1 = ieee_value(dx1, ieee_negative_inf)
    if (ieee_is_finite(dx1)) STOP 83
    if (ieee_is_nan(dx1)) STOP 84
    if (.not. ieee_is_negative(dx1)) STOP 85
    if (ieee_is_normal(dx1)) STOP 86

    dx1 = ieee_value(dx1, ieee_positive_normal)
    if (.not. ieee_is_finite(dx1)) STOP 87
    if (ieee_is_nan(dx1)) STOP 88
    if (ieee_is_negative(dx1)) STOP 89
    if (.not. ieee_is_normal(dx1)) STOP 90

    dx1 = ieee_value(dx1, ieee_negative_normal)
    if (.not. ieee_is_finite(dx1)) STOP 91
    if (ieee_is_nan(dx1)) STOP 92
    if (.not. ieee_is_negative(dx1)) STOP 93
    if (.not. ieee_is_normal(dx1)) STOP 94

    dx1 = ieee_value(dx1, ieee_positive_denormal)
    if (.not. ieee_is_finite(dx1)) STOP 95
    if (ieee_is_nan(dx1)) STOP 96
    if (ieee_is_negative(dx1)) STOP 97
    if (ieee_is_normal(dx1)) STOP 98
    if (dx1 <= 0) STOP 99
    if (dx1 >= tiny(dx1)) STOP 100

    dx1 = ieee_value(dx1, ieee_negative_denormal)
    if (.not. ieee_is_finite(dx1)) STOP 101
    if (ieee_is_nan(dx1)) STOP 102
    if (.not. ieee_is_negative(dx1)) STOP 103
    if (ieee_is_normal(dx1)) STOP 104
    if (dx1 >= 0) STOP 105
    if (dx1 <= -tiny(dx1)) STOP 106

    dx1 = ieee_value(dx1, ieee_positive_zero)
    if (.not. ieee_is_finite(dx1)) STOP 107
    if (ieee_is_nan(dx1)) STOP 108
    if (ieee_is_negative(dx1)) STOP 109
    if (.not. ieee_is_normal(dx1)) STOP 110
    if (dx1 /= 0) STOP 111

    dx1 = ieee_value(dx1, ieee_negative_zero)
    if (.not. ieee_is_finite(dx1)) STOP 112
    if (ieee_is_nan(dx1)) STOP 113
    if (.not. ieee_is_negative(dx1)) STOP 114
    if (.not. ieee_is_normal(dx1)) STOP 115
    if (dx1 /= 0) STOP 116

  end if

end


# include "define.inc"

module ran
  ! <doc>
  !  A wrapper module for random number generator.
  !  Thie module provides real function ranf
  !  using intrinsic random_number/random_seed or
  !  Mersenne Twister 19937 (see mt19937.f90).
  !  Note that instrinsic function appears to use
  !  and integer vector seed of length 2, but this
  !  is implementation dependent.  If there is ever
  !  a system that uses seed integer vector of
  !  different length, an error message will print.
  ! </doc>

  implicit none

  private

  public :: ranf
  public :: get_rnd_seed_length,get_rnd_seed,init_ranf

contains

!-------------------------------------------------------------------
  function ranf (seed)

    ! <doc>
    !  returns a uniform deviate in [0., 1.)
    !  The generator is initialized with the given seed if exists,
    !  otherwise uses the default seed.
    ! </doc>

# if RANDOM == _RANMT_
    use mt19937, only: sgrnd, grnd
# endif
    integer, intent(in), optional :: seed
    real :: ranf
    integer :: l
    integer, allocatable :: seed_in(:)
# if RANDOM == _RANMT_
    if (present(seed)) call sgrnd(seed)
    ranf = grnd()
# else
    if (present(seed)) then
       call random_seed(size=l)
       allocate(seed_in(l))
       seed_in(:)=seed
       call random_seed(put=seed_in)
    endif
    call random_number(ranf)
# endif

  end function ranf
!-------------------------------------------------------------------
  function get_rnd_seed_length () result (l)
    ! <doc>
    !  get_rnd_seed_length gets the length of the integer vector for
    !      the random number generator seed
    ! </doc>
    integer :: l
# if RANDOM == _RANMT_
    l=1
# else
    call random_seed(size=l)
# endif

  end function get_rnd_seed_length
!-------------------------------------------------------------------
  subroutine get_rnd_seed(seed)
    ! <doc>
    !  get_rnd_seed  random number seed integer vector
    ! </doc>
    integer, dimension(:), intent(out) :: seed
# if RANDOM == _RANMT_
    !NOTE: If MT is generator, more codding needs to be done to
    !      extract seed, so this should be run using only randomize
    seed=0
# else
    call random_seed(get=seed)
# endif

  end subroutine get_rnd_seed
!-------------------------------------------------------------------
  subroutine init_ranf(randomize,init_seed)
    ! <doc>
    !  init_ranf seeds the choosen random number generator.
    !  if randomize=T, a random seed based on date and time is used.
    !  (this randomizing procedure is proposed in GNU gfortran manual.)
    !  Otherwise, it sets the seed using init_seed
    !  In either case, it outputs the initial seed in init_seed
    ! </doc>
    use constants, only: kind_id
# if RANDOM == _RANMT_
    use mt19937, only: sgrnd
# endif
    implicit none
    logical, intent(in) :: randomize
    integer, intent(inout), dimension(:) :: init_seed
    integer :: i, nseed, dt(8)
    integer (kind=kind_id) :: t

    call system_clock(t)
    if (t == 0) then
       call date_and_time(values=dt)
       t = (dt(1) - 1970) * 365_kind_id * 24 * 60 * 60 * 1000 &
            + dt(2) * 31_kind_id * 24 * 60 * 60 * 1000 &
            + dt(3) * 24_kind_id * 60 * 60 * 1000 &
            + dt(5) * 60 * 60 * 1000 &
            + dt(6) * 60 * 1000 + dt(7) * 1000 &
            + dt(8)
    end if

# if RANDOM == _RANMT_
    if (randomize) then
       init_seed(1) = lcg(t)
       call sgrnd(init_seed(1))
    else
       call sgrnd(init_seed(1))
    endif
# else
    if (randomize) then

       call random_seed(size=nseed)

       do i = 1, nseed
          init_seed(i) = lcg(t)
       end do

       call random_seed(put=init_seed)
    else
       call random_seed(put=init_seed)
    endif
# endif

  end subroutine init_ranf

  ! This simple PRNG might not be good enough for real work, but is
  ! sufficient for seeding a better PRNG.
  function lcg(s)
    use constants, only: kind_id, kind_is
    integer :: lcg
    integer (kind=kind_id) :: s

    if (kind_id > 0) then
       if (s == 0) then
          s = 104729
       else
          s = mod(s, 4294967296_kind_id)
       end if
       s = mod(s * 279470273_kind_id, 4294967291_kind_id)
       lcg = int(mod(s, int(huge(0), kind_id)), kind(0))
    else
       lcg = mod(16807*int(s,kind_is), 2147483647)
    end if

  end function lcg

end module ran


!==========================================================================
elemental function gsw_dilution_coefficient_t_exact (sa, t, p)
!==========================================================================
!
!  Calculates the dilution coefficient of seawater.  The dilution
!  coefficient of seawater is defined as the Absolute Salinity times the
!  second derivative of the Gibbs function with respect to Absolute
!  Salinity, that is, SA.*g_SA_SA.
!
!  SA =  Absolute Salinity                                         [ g/kg ]
!  t  =  in-situ temperature (ITS-90)                             [ deg C ]
!  p  =  sea pressure                                              [ dbar ]
!        ( i.e. absolute pressure - 10.1325 dbar )
!
!  dilution_coefficient_t_exact  =  dilution coefficient   [ (J/kg)(kg/g) ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_sfac

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, t, p

real (r8) :: gsw_dilution_coefficient_t_exact

real (r8) :: g08, x, x2, y, z

x2 = gsw_sfac*sa
x = sqrt(x2)
y = t*0.025_r8
z = p*1e-4_r8      ! note.the input pressure (p) is sea pressure in units of dbar.

g08 = 2.0_r8*(8103.20462414788_r8 + &
          y*(2175.341332000392_r8 + &
	      y*(-274.2290036817964_r8 + &
                  y*(197.4670779425016_r8 + &
		      y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - &
          90.6734234051316_r8*z) + &
	      1.5_r8*x*(-5458.34205214835_r8 - 980.14153344888_r8*y + &
                  (4.0_r8/3.0_r8)*x*(2247.60742726704_r8 - &
		  340.1237483177863_r8*1.25_r8*x + 220.542973797483_r8*y) + &
              180.142097805543_r8*z) + &
          z*(-219.1676534131548_r8 + &
	      (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z))

g08 = x2*g08 + &
          x*(-7296.43987145382_r8 + &
	      z*(598.378809221703_r8 + &
                  z*(-156.8822727844005_r8 + &
		      (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + &
              y*(-1480.222530425046_r8 + &
	          z*(-525.876123559641_r8 + &
                      (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + &
                  y*(-129.1994027934126_r8 + &
	              z*(1149.174198007428_r8 + &
                          z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + &
                  y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + &
                      y*(2.626801985426835_r8 + 703.695562834065_r8*z))))) + &
      11625.62913253464_r8 + 1702.453469893412_r8*y

gsw_dilution_coefficient_t_exact = 0.25_r8*gsw_sfac*g08

! Note that this function avoids the singularity that occurs at SA = 0 if
! the straightforward expression for the dilution coefficient of seawater,
! SA*g_SA_SA is simply evaluated as SA.*gsw_gibbs(2,0,0,SA,t,p).

return
end function

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


      subroutine runP_00ii(i1,i2,m0sq,Gr,Czero2,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,i1,i2,m,n,np
      parameter(np=3)
      double precision m0sq,Gr(np,np)
      double complex Czero2(z2max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Dv(diiii(z4(n,m,i1,i2))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Dv(dzzii(z2(i1,i2))+N0,ep-1)

      Dv(dzzii(z2(i1,i2))+N0,ep)=
     . (pole
     . +2d0*Czero2(z2(i1,i2),ep)
     . +2d0*m0sq*Dv(dii(z2(i1,i2))+N0,ep)
     . -bit)/16d0
      enddo

      return
      end


      SUBROUTINE DGBSL(ABD,LDA,N,ML,MU,IPVT,B,JOB)                      00000010
      INTEGER LDA,N,ML,MU,IPVT(1),JOB                                   00000020
      DOUBLE PRECISION ABD(LDA,1),B(1)                                  00000030
C                                                                       00000040
C     DGBSL SOLVES THE DOUBLE PRECISION BAND SYSTEM                     00000050
C     A * X = B  OR  TRANS(A) * X = B                                   00000060
C     USING THE FACTORS COMPUTED BY DGBCO OR DGBFA.                     00000070
C                                                                       00000080
C     ON ENTRY                                                          00000090
C                                                                       00000100
C        ABD     DOUBLE PRECISION(LDA, N)                               00000110
C                THE OUTPUT FROM DGBCO OR DGBFA.                        00000120
C                                                                       00000130
C        LDA     INTEGER                                                00000140
C                THE LEADING DIMENSION OF THE ARRAY  ABD .              00000150
C                                                                       00000160
C        N       INTEGER                                                00000170
C                THE ORDER OF THE ORIGINAL MATRIX.                      00000180
C                                                                       00000190
C        ML      INTEGER                                                00000200
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.           00000210
C                                                                       00000220
C        MU      INTEGER                                                00000230
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.           00000240
C                                                                       00000250
C        IPVT    INTEGER(N)                                             00000260
C                THE PIVOT VECTOR FROM DGBCO OR DGBFA.                  00000270
C                                                                       00000280
C        B       DOUBLE PRECISION(N)                                    00000290
C                THE RIGHT HAND SIDE VECTOR.                            00000300
C                                                                       00000310
C        JOB     INTEGER                                                00000320
C                = 0         TO SOLVE  A*X = B ,                        00000330
C                = NONZERO   TO SOLVE  TRANS(A)*X = B , WHERE           00000340
C                            TRANS(A)  IS THE TRANSPOSE.                00000350
C                                                                       00000360
C     ON RETURN                                                         00000370
C                                                                       00000380
C        B       THE SOLUTION VECTOR  X .                               00000390
C                                                                       00000400
C     ERROR CONDITION                                                   00000410
C                                                                       00000420
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A   00000430
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY  00000440
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER       00000450
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE     00000460
C        CALLED CORRECTLY AND IF DGBCO HAS SET RCOND .GT. 0.0           00000470
C        OR DGBFA HAS SET INFO .EQ. 0 .                                 00000480
C                                                                       00000490
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX                 00000500
C     WITH  P  COLUMNS                                                  00000510
C           CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)                    00000520
C           IF (RCOND IS TOO SMALL) GO TO ...                           00000530
C           DO 10 J = 1, P                                              00000540
C              CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0)                00000550
C        10 CONTINUE                                                    00000560
C                                                                       00000570
C     LINPACK. THIS VERSION DATED 08/14/78 .                            00000580
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.      00000590
C                                                                       00000600
C     SUBROUTINES AND FUNCTIONS                                         00000610
C                                                                       00000620
C     BLAS DAXPY,DDOT                                                   00000630
C     FORTRAN MIN0                                                      00000640
C                                                                       00000650
C     INTERNAL VARIABLES                                                00000660
C                                                                       00000670
      DOUBLE PRECISION DDOT,T                                           00000680
      INTEGER K,KB,L,LA,LB,LM,M,NM1                                     00000690
C                                                                       00000700
      M = MU + ML + 1                                                   00000710
      NM1 = N - 1                                                       00000720
      IF (JOB .NE. 0) GO TO 50                                          00000730
C                                                                       00000740
C        JOB = 0 , SOLVE  A * X = B                                     00000750
C        FIRST SOLVE L*Y = B                                            00000760
C                                                                       00000770
         IF (ML .EQ. 0) GO TO 30                                        00000780
         IF (NM1 .LT. 1) GO TO 30                                       00000790
            DO 20 K = 1, NM1                                            00000800
               LM = MIN0(ML,N-K)                                        00000810
               L = IPVT(K)                                              00000820
               T = B(L)                                                 00000830
               IF (L .EQ. K) GO TO 10                                   00000840
                  B(L) = B(K)                                           00000850
                  B(K) = T                                              00000860
   10          CONTINUE                                                 00000870
               CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1)                   00000880
   20       CONTINUE                                                    00000890
   30    CONTINUE                                                       00000900
C                                                                       00000910
C        NOW SOLVE  U*X = Y                                             00000920
C                                                                       00000930
         DO 40 KB = 1, N                                                00000940
            K = N + 1 - KB                                              00000950
            B(K) = B(K)/ABD(M,K)                                        00000960
            LM = MIN0(K,M) - 1                                          00000970
            LA = M - LM                                                 00000980
            LB = K - LM                                                 00000990
            T = -B(K)                                                   00001000
            CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1)                        00001010
   40    CONTINUE                                                       00001020
      GO TO 100                                                         00001030
   50 CONTINUE                                                          00001040
C                                                                       00001050
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B                         00001060
C        FIRST SOLVE  TRANS(U)*Y = B                                    00001070
C                                                                       00001080
         DO 60 K = 1, N                                                 00001090
            LM = MIN0(K,M) - 1                                          00001100
            LA = M - LM                                                 00001110
            LB = K - LM                                                 00001120
            T = DDOT(LM,ABD(LA,K),1,B(LB),1)                            00001130
            B(K) = (B(K) - T)/ABD(M,K)                                  00001140
   60    CONTINUE                                                       00001150
C                                                                       00001160
C        NOW SOLVE TRANS(L)*X = Y                                       00001170
C                                                                       00001180
         IF (ML .EQ. 0) GO TO 90                                        00001190
         IF (NM1 .LT. 1) GO TO 90                                       00001200
            DO 80 KB = 1, NM1                                           00001210
               K = N - KB                                               00001220
               LM = MIN0(ML,N-K)                                        00001230
               B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1)             00001240
               L = IPVT(K)                                              00001250
               IF (L .EQ. K) GO TO 70                                   00001260
                  T = B(L)                                              00001270
                  B(L) = B(K)                                           00001280
                  B(K) = T                                              00001290
   70          CONTINUE                                                 00001300
   80       CONTINUE                                                    00001310
   90    CONTINUE                                                       00001320
  100 CONTINUE                                                          00001330
      RETURN                                                            00001340
      END                                                               00001350


!###############################################################
!     PURPOSE  : SOLVE DMFT-IPT REPULSIVE IN MATSUBARA FREQUENCY
!     AUTHORS  : Adriano Amaricci
!###############################################################
module IPT_MATSUBARA
  USE IPT_VARS_GLOBAL
  USE IPT_GF
  USE SF_LINALG, only: inv
  USE SF_CONSTANTS, only: xi,pi,one
  USE SF_ARRAYS, only:arange
  USE SF_SPECIAL, only: bethe_lattice
  USE SF_IOTOOLS, only: free_unit
  implicit none
  private

  interface ipt_solve_matsubara
     module procedure solve_ipt_matsubara
     module procedure solve_ipt_sc_matsubara
  end interface ipt_solve_matsubara

  interface mpt_solve_matsubara
     module procedure solve_mpt_matsubara
     module procedure solve_mpt_sc_matsubara
  end interface mpt_solve_matsubara

  interface ipt_measure_dens_matsubara
     module procedure ipt_measure_dens_matsubara_SW,ipt_measure_dens_matsubara_G
  end interface ipt_measure_dens_matsubara

  interface ipt_measure_energy_matsubara
     module procedure ipt_measure_energy_matsubara_bethe,ipt_measure_energy_matsubara_hk
  end interface ipt_measure_energy_matsubara

  !half-filling solver:
  public :: ipt_solve_matsubara
  public :: mpt_solve_matsubara

  public :: ipt_measure_potential_energy_matsubara
  public :: ipt_measure_kinetic_energy_matsubara
  public :: ipt_measure_hartree_energy_matsubara
  public :: ipt_measure_dens_matsubara
  public :: ipt_measure_phi_matsubara
  public :: ipt_measure_docc_matsubara
  public :: ipt_measure_zeta_matsubara
  !
  public :: ipt_measure_observables_matsubara
  public :: ipt_measure_energy_matsubara

  ! real(8) :: S0,S1,C0,C1,C2,C3

contains

  !##################################################################
  !##################################################################
  !##################################################################
  ! SOLVER ROUTINES: NORMAL AND SUPERCONDUCTIVE CASES
  !##################################################################
  !##################################################################
  !##################################################################

  !+-------------------------------------------------------------------+
  !PURPOSE: Solve 2nd order perturbation theory in Matsubara normal:
  ! - half-filling
  ! - away-from-half-filling
  !+-------------------------------------------------------------------+
  function solve_ipt_matsubara(fg0_iw) result(sigma_iw)
    complex(8),dimension(:)            :: fg0_iw
    complex(8),dimension(size(fg0_iw)) :: sigma_iw
    real(8),dimension(0:size(fg0_iw))  :: fg0_tau,sigma_tau
    integer                            :: i,Lf,unit
    real(8)                            :: n
    Lf=size(fg0_iw)
    n = 0.5d0
    call fft_iw2tau(fg0_iw,fg0_tau(0:),beta)
    forall(i=0:Lf)sigma_tau(i)=Uloc(1)*Uloc(1)*fg0_tau(i)*fg0_tau(Lf-i)*fg0_tau(i)
    call fft_tau2iw(sigma_tau(0:),sigma_iw,beta)
    unit=free_unit()
    open(unit,file="Sigma_tau.ipt")
    do i=0,Lf
       write(unit,*)i*beta/Lf,sigma_tau(i)
    enddo
    close(unit)
  end function solve_ipt_matsubara

  function solve_mpt_matsubara(fg0_iw,n,n0,xmu0) result(sigma_iw)
    complex(8),dimension(:)            :: fg0_iw
    complex(8),dimension(size(fg0_iw)) :: sigma_iw
    real(8),dimension(0:size(fg0_iw))  :: fg0_tau,sigma_tau
    real(8)                            :: n,n0,xmu0
    real(8)                            :: A,B,A1,A2,B1,B2
    integer                            :: i,Lf
    Lf=size(fg0_iw)
    call fft_iw2tau(fg0_iw,fg0_tau(0:),beta)
    forall(i=0:Lf)sigma_tau(i)=Uloc(1)*Uloc(1)*fg0_tau(i)*fg0_tau(Lf-i)*fg0_tau(i)
    call fft_tau2iw(sigma_tau(0:),sigma_iw,beta)
    A1= n*(1.d0-n)
    A2= n0*(1.d0-n0)
    A = A1/A2
    B1 = (xmu0-xmu) + Uloc(1)*(1.d0-2.d0*n)
    B2 = n0*(1.d0-n0)*Uloc(1)*Uloc(1)
    B  = B1/B2
    sigma_iw = Uloc(1)*(n-0.5d0) + A*sigma_iw/(1.d0-B*sigma_iw)
    open(11,file="Sigma_tau.ipt")
    do i=0,Lf
       write(11,*)i*beta/Lf,sigma_tau(i)
    enddo
    close(11)
  end function solve_mpt_matsubara

  !+-------------------------------------------------------------------+
  !PURPOSE: Solve 2nd order perturbation theory in Matsubara attractive:
  !   REAL order parameter case
  ! - half-filling, REAL order parameter.
  !+-------------------------------------------------------------------+
  function solve_ipt_sc_matsubara(fg0_iw,delta) result(sigma_iw)
    complex(8),dimension(:,:)                           :: fg0_iw
    complex(8),dimension(size(fg0_iw,1),size(fg0_iw,2)) :: sigma_iw
    real(8)                                             :: delta
    complex(8),dimension(size(fg0_iw,2))                :: calG11,calG22,calF
    real(8),dimension(0:size(fg0_iw,2))                 :: calG11t,calG22t,calFt
    real(8),dimension(0:size(fg0_iw,2))                 :: sigmat,selft
    integer                                             :: i,LM
    LM=size(fg0_iw,2)
    if(size(fg0_iw,1)/=2)stop "solve_ipt_sc_matsubara: size(input,1)!= 2"
    calG11  =  fg0_iw(1,:)
    calG22  = -conjg(fg0_iw(1,:))
    calF    =  fg0_iw(2,:)
    call fft_iw2tau(calG11,calG11t(0:),beta)
    call fft_iw2tau(calG22,calG22t(0:),beta)
    call fft_iw2tau(calF,calFt(0:),beta,notail=.true.)
    !Get the 2nd-order Sigma:
    forall(i=0:LM)
       sigmat(i)= Uloc(1)*Uloc(1)*(calG11t(i)*calG22t(i) - calFt(i)*calFt(i))*calG22t(LM-i)
       selft(i) =-Uloc(1)*Uloc(1)*(calFt(i)*calFt(i)     - calG11t(i)*calG22t(i))*calFt(i)
    end forall
    call fft_tau2iw(Sigmat(0:),sigma_iw(1,:),beta)
    call fft_tau2iw(Selft(0:),sigma_iw(2,:),beta)
    sigma_iw(2,:)=sigma_iw(2,:)-delta
    !
    open(11,file="Sigma_tau.ipt")
    open(12,file="Self_tau.ipt")
    do i=0,LM
       write(11,*)i*beta/LM,sigmat(i)
       write(12,*)i*beta/LM,selft(i)
    enddo
    close(11);close(12)
  end function solve_ipt_sc_matsubara

  !PURPOSE: Solve 2nd order perturbation theory in Matsubara attractive:
  !   REAL order parameter case
  ! - away-from-half-filling, REAL order parameter.
  function solve_mpt_sc_matsubara(fg0_iw,n,n0,delta,delta0) result(sigma_iw)
    complex(8),dimension(:,:)                           :: fg0_iw
    complex(8),dimension(size(fg0_iw,1),size(fg0_iw,2)) :: sigma_iw
    complex(8),dimension(size(fg0_iw,2))                :: calG11,calG22,calF
    real(8),dimension(0:size(fg0_iw,2))                 :: calG11t,calG22t,calFt
    real(8),dimension(0:size(fg0_iw,2))                 :: sigmat,selft
    integer                                             :: i,LM
    real(8)                                             :: n,n0
    real(8)                                             :: delta,delta0
    real(8)                                             :: A,B
    LM=size(fg0_iw,2)
    if(size(fg0_iw,1)/=2)stop "solve_mipt_sc_matsubara_r: size(input,1)!= 2"
    !GEt all components of the HFB-corrected Weiss-Fields:
    calG11  =  fg0_iw(1,:)
    calG22  = -conjg(fg0_iw(1,:))
    calF    =  fg0_iw(2,:)
    call fft_iw2tau(calG11,calG11t(0:),beta)
    call fft_iw2tau(calG22,calG22t(0:),beta)
    call fft_iw2tau(calF,calFt(0:),beta,notail=.true.)
    !Get the 2nd-order Sigma:
    forall(i=0:LM)
       sigmat(i)= Uloc(1)*Uloc(1)*(calG11t(i)*calG22t(i) - calFt(i)*calFt(i))*calG22t(LM-i)
       selft(i) =-Uloc(1)*Uloc(1)*(calFt(i)*calFt(i)     - calG11t(i)*calG22t(i))*calFt(i)
    end forall
    call fft_tau2iw(Sigmat(0:),sigma_iw(1,:),beta)
    call fft_tau2iw(Selft(0:),sigma_iw(2,:),beta)
    !
    A=Uloc(1)*Uloc(1)*n*(1.d0-n)-delta**2
    B=Uloc(1)*Uloc(1)*n0*(1.d0-n0)-delta0**2
    sigma_iw(1,:) =-Uloc(1)*(n-0.5d0) + sigma_iw(1,:)*A/B
    sigma_iw(2,:) =-delta       + sigma_iw(2,:)*A/B
    !
    open(11,file="Sigma_tau.ipt")
    open(12,file="Self_tau.ipt")
    do i=0,LM
       write(11,*)i*beta/LM,sigmat(i)
       write(12,*)i*beta/LM,selft(i)
    enddo
    close(11);close(12)
    !
  end function solve_mpt_sc_matsubara

  !##################################################################
  !##################################################################
  !##################################################################
  ! MEASURE OBSERVABLES
  !##################################################################
  !##################################################################
  !##################################################################

  !+-------------------------------------------------------------------+
  !PURPOSE: measure observables in Matsubara formalism
  !+-------------------------------------------------------------------+
  function ipt_measure_observables_matsubara(Sigma,Weiss) result(obs)
    complex(8),dimension(:)          :: Sigma
    complex(8),dimension(size(Sigma)):: Weiss
    real(8),dimension(2)             :: obs
    obs(1) = ipt_measure_docc_matsubara(Sigma,Weiss)
    obs(2) = ipt_measure_zeta_matsubara(Sigma,Weiss)
  end function ipt_measure_observables_matsubara

  !PURPOSE: measure density
  function ipt_measure_dens_matsubara_SW(Sigma,Weiss) result(ipt_dens)
    complex(8),dimension(:)           :: Sigma
    complex(8),dimension(size(Sigma)) :: Weiss,Green
    real(8),dimension(0:size(Sigma)) :: Gtau
    real(8)                           :: ipt_dens
    integer :: i
    Green = one/Weiss - Sigma
    Green = one/Green
    call fft_iw2tau(Green,Gtau(0:),beta)
    do i=0,size(Sigma)
       write(450,*)i*beta/size(Sigma),Gtau(i)
    enddo
    ipt_dens = fft_gbeta_minus(Green,beta)
  end function ipt_measure_dens_matsubara_SW
  function ipt_measure_dens_matsubara_G(Green) result(ipt_dens)
    complex(8),dimension(:)           :: Green
    real(8)                           :: ipt_dens
    ipt_dens = fft_gbeta_minus(Green,beta)
  end function ipt_measure_dens_matsubara_G

  function ipt_measure_phi_matsubara(Green) result(ipt_phi)
    complex(8),dimension(:)           :: Green
    real(8)                           :: ipt_phi
    ipt_phi = fft_gbeta_minus(Green,beta,notail=.true.)
  end function ipt_measure_phi_matsubara

  !PURPOSE: measure renormalization constant zeta
  function ipt_measure_zeta_matsubara(Sigma,Weiss) result(ipt_zeta)
    complex(8),dimension(:)           :: Sigma
    complex(8),dimension(size(Sigma)) :: Weiss
    real(8)                           :: ipt_zeta,wm1
    wm1=pi/beta
    ipt_zeta = 1d0 - dimag(Sigma(1))/wm1
    ipt_zeta = 1d0/ipt_zeta
  end function ipt_measure_zeta_matsubara

  !PURPOSE: measure double occupancy
  function ipt_measure_docc_matsubara(Sigma,Weiss) result(ipt_docc)
    complex(8),dimension(:)           :: Sigma
    complex(8),dimension(size(Sigma)) :: Weiss
    real(8)                           :: ipt_docc,epot,ehar
    epot = ipt_measure_potential_energy_matsubara(Sigma,Weiss)
    ehar = ipt_measure_hartree_energy_matsubara(Sigma,Weiss)
    ipt_docc = 0.25d0
    if(uloc(1) > 0d0)ipt_docc = epot/uloc(1) - ehar/uloc(1)
  end function ipt_measure_docc_matsubara

  !PURPOSE: measure all energies for the Bethe lattice
  function ipt_measure_energy_matsubara_bethe(Sigma,Weiss,Lk,D) result(obs)
    real(8),optional                 :: D
    real(8)                          :: D_
    complex(8),dimension(:)          :: Sigma
    complex(8),dimension(size(Sigma)):: Weiss
    real(8),dimension(3)             :: obs
    real(8),dimension(:),allocatable :: Hk,wtk
    integer                          :: Lk,i
    D_=1d0;if(present(D))D_=D
    allocate(Hk(Lk),Wtk(Lk))
    call bethe_lattice(Wtk,Hk,Lk,D_)
    obs(1) = ipt_measure_kinetic_energy_matsubara(Hk,Wtk,Sigma)
    obs(2) = ipt_measure_potential_energy_matsubara(Sigma,Weiss)
    obs(3) = ipt_measure_hartree_energy_matsubara(Sigma,Weiss)
    deallocate(Hk,Wtk)
  end function ipt_measure_energy_matsubara_bethe
  !PURPOSE: measure all energies for a given Hamiltonian Hk
  function ipt_measure_energy_matsubara_hk(Sigma,Weiss,Hk,Wtk) result(obs)
    real(8),dimension(:)              :: Hk
    complex(8),dimension(:)           :: Sigma
    complex(8),dimension(size(Sigma)) :: Weiss
    real(8),dimension(size(Hk))       :: Wtk
    real(8),dimension(3)              :: obs
    obs(1) = ipt_measure_kinetic_energy_matsubara(Hk,Wtk,Sigma)
    obs(2) = ipt_measure_potential_energy_matsubara(Sigma,Weiss)
    obs(3) = ipt_measure_hartree_energy_matsubara(Sigma,Weiss)
  end function ipt_measure_energy_matsubara_hk

  !PURPOSE: measure potential energy
  function ipt_measure_potential_energy_matsubara(Sigma,Weiss) result(ipt_Epot)
    complex(8),dimension(:)           :: Sigma
    complex(8),dimension(size(Sigma)) :: Weiss,Green
    real(8)                           :: ipt_Epot
    Green = one/Weiss - Sigma
    Green = one/Green
    ipt_Epot=sum(dreal(Sigma)*dreal(Green))
    ipt_Epot=ipt_Epot-sum(dimag(Sigma)*dimag(Green))
    ipt_Epot=ipt_Epot/beta*2d0
  end function ipt_measure_potential_energy_matsubara

  !PURPOSE: measure hartree energy term
  function ipt_measure_hartree_energy_matsubara(Sigma,Weiss) result(ipt_Ehartree)
    complex(8),dimension(:)           :: Sigma
    complex(8),dimension(size(Sigma)) :: Weiss,Green
    real(8)                           :: ipt_Ehartree,n
    Green = one/Weiss - Sigma
    Green = one/Green
    n = fft_gbeta_minus(Green,beta)
    ipt_Ehartree = -Uloc(1)*n + Uloc(1)*0.25d0
  end function ipt_measure_hartree_energy_matsubara

  !PURPOSE: measure kinetic energy
  function ipt_measure_kinetic_energy_matsubara(Hk,Wtk,Sigma) result(ipt_Ekin)
    real(8),dimension(:)                  :: Hk
    complex(8),dimension(:)               :: Sigma
    real(8),dimension(size(Hk))           :: Wtk
    complex(8),dimension(1,1,size(Hk))    :: Hk_
    complex(8),dimension(1,1,size(Sigma)) :: Sigma_
    real(8)                               :: ipt_Ekin
    Sigma_(1,1,:)=Sigma
    Hk_(1,1,:) = Hk
    ipt_Ekin = f_ipt_kinetic_normal(Hk_,Wtk,Sigma_)
  end function ipt_measure_kinetic_energy_matsubara
  function f_ipt_kinetic_normal(Hk,Wtk,Sigma) result(ipt_Ekin)
    integer                                  :: Lk,No,Liw
    integer                                  :: i,ik,iorb
    complex(8),dimension(:,:,:)              :: Hk
    complex(8),dimension(:,:,:)              :: Sigma
    real(8),dimension(:)                     :: Wtk
    !
    real(8),dimension(:,:),allocatable       :: Sigma_HF
    real(8),dimension(:),allocatable         :: wm
    complex(8),dimension(:,:),allocatable    :: Ak,Bk
    complex(8),dimension(:,:),allocatable    :: Ck,Zk
    complex(8),dimension(:,:),allocatable    :: Zeta,Gk,Tk
    real(8)                                  :: Tail0,Tail1,spin_degeneracy
    !
    real(8)                                  :: H0,ipt_Ekin
    !
    No = size(Hk,1)
    Lk = size(Hk,3)
    Liw= size(Sigma,3)
    if(No/=size(Hk,2))stop "get_kinetic_energy: size(Hk,1)!=size(Hk,2) [Norb_total]"
    if(No/=size(Sigma,1).OR.No/=size(Sigma,2))stop "get_kinetic_energy: size(Sigma,1/2)!=size(Hk,1) [Norb_total]"
    if(Lk/=size(Wtk))stop "get_kinetic_energy: size(Wtk)!=size(Hk,3) [L_k]"
    !
    allocate(wm(Liw))
    allocate(Sigma_HF(No,No))
    allocate(Ak(No,No),Bk(No,No),Ck(No,No),Zk(No,No),Zeta(No,No),Gk(No,No),Tk(No,No))
    !
    wm = pi/beta*(2*arange(1,Liw)-1)
    !
    Sigma_HF = dreal(Sigma(:,:,Liw))
    !
    H0=0d0
    Zk=0d0 ; forall(i=1:No)Zk(i,i)=1d0
    do ik=1,Lk
       Ak= Hk(:,:,ik)
       Bk=-Hk(:,:,ik)-Sigma_HF(:,:)
       do i=1,Liw
          Gk = (xi*wm(i)+xmu)*Zk(:,:) - Hk(:,:,ik) - Sigma(:,:,i)
          select case(No)
          case default
             call inv(Gk)
          case(1)
             Gk = 1d0/Gk
          end select
          Tk = Zk(:,:)/(xi*wm(i)) - Bk(:,:)/(xi*wm(i))**2
          Ck = matmul(Ak,Gk - Tk)
          H0 = H0 + Wtk(ik)*trace_matrix(Ck,No)
       enddo
    enddo
    spin_degeneracy=3.d0-Nspin !2 if Nspin=1, 1 if Nspin=2
    H0=H0/beta*2.d0*spin_degeneracy
    !
    Tail0=0d0
    Tail1=0d0
    do ik=1,Lk
       Ak= Hk(:,:,ik)
       Bk=-Hk(:,:,ik)-Sigma_HF(:,:)
       Ck= matmul(Ak,Bk)
       Tail0 = Tail0 + 0.5d0*Wtk(ik)*trace_matrix(Ak,No)
       Tail1 = Tail1 + 0.25d0*Wtk(ik)*trace_matrix(Ck,No)
    enddo
    Tail0=spin_degeneracy*Tail0
    Tail1=spin_degeneracy*Tail1*beta
    ipt_Ekin=H0+Tail0+Tail1
    deallocate(wm,Sigma_HF,Ak,Bk,Ck,Zk,Zeta,Gk,Tk)
  contains
    function trace_matrix(M,dim) result(tr)
      integer                       :: dim
      complex(8),dimension(dim,dim) :: M
      complex(8) :: tr
      integer                       :: i
      tr=dcmplx(0d0,0d0)
      do i=1,dim
         tr=tr+M(i,i)
      enddo
    end function trace_matrix
  end function f_ipt_kinetic_normal

  !##################################################################
  !##################################################################
  !##################################################################
  ! DEBUG MULTI-BAND && 4th ORDER
  !##################################################################
  !##################################################################
  !##################################################################

  ! function solve_ipt_matsubara_mb(fg0_iw) result(sigma_iw)
  !   complex(8),dimension(:,:)                           :: fg0_iw
  !   complex(8),dimension(size(fg0_iw,1),size(fg0_iw,2)) :: sigma_iw
  !   real(8),dimension(size(fg0_iw,1),0:size(fg0_iw,2))  :: fg0_tau,sigma_tau
  !   integer                                             :: i,ib,Lf,Nb
  !   Nb=size(fg0_iw,1)
  !   !<DEBUG
  !   if(Nb>2)stop "Nband>2 is not yet implemented... ask developer"
  !   !>DEBUG
  !   Lf=size(fg0_iw,2)
  !   do ib=1,Nb
  !      call fftgf_iw2tau(fg0_iw(ib,:),fg0_tau(ib,0:),beta)
  !   enddo
  !   !Get contribution of the first diagram (1s,1sbar,1sbar)/(2s,2sbar,2sbar)
  !   forall(ib=1:Nb,i=0:Lf)sigma_tau(ib,i)=U*U*fg0_tau(ib,i)*fg0_tau(ib,Lf-i)*fg0_tau(ib,i)
  !   !Get contribution of the second class of
  !   !diagrams (1s,2s,2s)+(1s,2sbar,2sbar)/(2s,1s,1s)+(2s,1sbar,1sbar)
  !   if(Ust/=0.d0)then
  !      do ib=1,Nb
  !         do i=0,Lf
  !            sigma_tau(ib,i)=sigma_tau(ib,i)+&
  !                 2.d0*Ust*Ust*fg0_tau(ib,i)*fg0_tau(3-ib,Lf-i)*fg0_tau(3-ib,i)
  !         enddo
  !      enddo
  !   endif
  !   do ib=1,Nb
  !      call fftgf_tau2iw(sigma_tau(ib,0:),sigma_iw(ib,:),beta)
  !   enddo
  !   open(100,file="Sigma_tau.ipt")
  !   do i=0,Lf
  !      write(100,"(5F20.12)")i*beta/dble(Lf),(sigma_tau(ib,i),ib=1,Nb)
  !   enddo
  !   close(100)
  ! end function solve_ipt_matsubara_mb

  ! !+-------------------------------------------------------------------+
  ! !PURPOSE: Solve 4th order perturbation theory in Matsubara for
  ! ! the repulsive model at half-filling
  ! !+-------------------------------------------------------------------+
  ! function solve_ipt_matsubara_4th(fg0_iw) result(sigma_iw)
  !   complex(8),dimension(:)            :: fg0_iw
  !   complex(8),dimension(size(fg0_iw)) :: sigma_iw
  !   real(8),dimension(:),allocatable   :: fg0_tau
  !   real(8),dimension(:),allocatable   :: sigma_tau
  !   real(8),dimension(:),allocatable   :: sigma_tau_a,sigma_tau_b,sigma_tau_c,sigma_tau_d
  !   real(8),dimension(:),allocatable   :: ker,intx,kerx,kery,chi_a,chi_b
  !   integer :: itau,ix,iy
  !   real(8) :: dtau
  !   L=size(fg0_iw)
  !   dtau = beta/dble(L)
  !   !Get G_0(tau)
  !   allocate(fg0_tau(0:L))
  !   allocate(sigma_tau(0:L))
  !   call fftgf_iw2tau(fg0_iw,fg0_tau(0:),beta)
  !   allocate(kerx(0:L),kery(0:L),intx(0:L),ker(0:L))
  !   allocate(sigma_tau_a(0:L),chi_a(0:L))
  !   !get \Sigma^(4a):
  !   do itau=0,L
  !      do ix=0,itau
  !         kerx(ix) =  fg0_tau(itau-ix)**2*fg0_tau(ix)**2
  !      enddo
  !      do ix=itau,L
  !         kerx(ix) = (-fg0_tau(L+itau-ix))**2*fg0_tau(ix)**2
  !      enddo
  !      chi_a(itau) = trapz(dtau,kerx(0:L))
  !   enddo
  !   do itau=0,L
  !      do ix=0,itau
  !         kerx(ix) =  fg0_tau(itau-ix)**2*chi_a(ix)
  !      enddo
  !      do ix=itau,L
  !         kerx(ix) = (-fg0_tau(L+itau-ix))**2*chi_a(ix)
  !      enddo
  !      sigma_tau_a(itau) = U*U*U*U*fg0_tau(itau)*trapz(dtau,kerx(0:L))
  !   enddo
  !   !get \Sigma^(4b):
  !   allocate(sigma_tau_b(0:L),chi_b(0:L))
  !   do itau=0,L
  !      do ix=0,itau
  !         kerx(ix) =  fg0_tau(itau-ix)**3*fg0_tau(ix)
  !      enddo
  !      do ix=itau,L
  !         kerx(ix) = (-fg0_tau(L+itau-ix))**3*fg0_tau(ix)
  !      enddo
  !      chi_b(itau) = trapz(dtau,kerx(0:L))
  !   enddo
  !   do itau=0,L
  !      do ix=0,itau
  !         kerx(ix) =  fg0_tau(itau-ix)*chi_b(ix)
  !      enddo
  !      do ix=itau,L
  !         kerx(ix) = (-fg0_tau(L+itau-ix))*chi_b(ix)
  !      enddo
  !      sigma_tau_b(itau) = U*U*U*U*fg0_tau(itau)**2*trapz(dtau,kerx(0:L))
  !   enddo
  !   !get \Sigma^(4c):
  !   allocate(sigma_tau_c(0:L))
  !   do itau=0,L
  !      do iy=0,itau
  !         kery(iy) =  fg0_tau(itau-iy)**2*fg0_tau(iy)
  !      enddo
  !      do iy=itau,L
  !         kery(iy) = (-fg0_tau(L+itau-iy))**2*fg0_tau(iy)
  !      enddo
  !      !
  !      do ix=0,itau
  !         kerx(ix) =  fg0_tau(itau-ix)*fg0_tau(ix)**2
  !      enddo
  !      do ix=itau,L
  !         kerx(ix) = (-fg0_tau(L+itau-ix))*fg0_tau(ix)**2
  !      enddo
  !      !
  !      do iy=0,L
  !         do ix=0,iy
  !            ker(ix) =  (-fg0_tau(L+ix-iy))*kerx(ix) !there  was an error itau=>iy
  !         enddo
  !         do ix=iy,L
  !            ker(ix) = fg0_tau(ix-iy)*kerx(ix)
  !         enddo
  !         intx(iy) = trapz(dtau,ker(0:L))
  !      enddo
  !      sigma_tau_c(itau) = U*U*U*U*trapz(dtau,kery(0:L)*intx(0:L))
  !   enddo
  !   !get \Sigma^(4d):
  !   allocate(sigma_tau_d(0:L))
  !   do itau=0,L
  !      do iy=0,itau
  !         kery(iy) =  fg0_tau(itau-iy)*fg0_tau(iy)
  !      enddo
  !      do iy=itau,L
  !         kery(iy) = (-fg0_tau(L+itau-iy))*fg0_tau(iy)
  !      enddo
  !      !
  !      do ix=0,itau
  !         kerx(ix) =  fg0_tau(itau-ix)*fg0_tau(ix)
  !      enddo
  !      do ix=itau,L
  !         kerx(ix) = (-fg0_tau(L+itau-ix))*fg0_tau(ix)
  !      enddo
  !      !
  !      do iy=0,L
  !         do ix=0,iy
  !            ker(ix) =  (-fg0_tau(L+ix-iy))**2*kerx(ix)
  !         enddo
  !         do ix=iy,L
  !            ker(ix) = fg0_tau(ix-iy)**2*kerx(ix)
  !         enddo
  !         intx(iy) = trapz(dtau,ker(0:L))
  !      enddo
  !      sigma_tau_d(itau) = -U*U*U*U*fg0_tau(itau)*trapz(dtau,kery(0:L)*intx(0:L))
  !   enddo
  !   forall(itau=0:L)sigma_tau(itau)=U**2*(fg0_tau(itau))**2*fg0_tau(L-itau)
  !   sigma_tau(0:) = sigma_tau(0:) + 3d0*(sigma_tau_a(0:)+sigma_tau_b(0:)+sigma_tau_c(0:)+sigma_tau_d(0:))
  !   call fftgf_tau2iw(sigma_tau(0:),sigma_iw,beta)
  !   open(100,file="Sigma_tau.ipt")
  !   do itau=0,L
  !      write(100,*)itau*beta/dble(L),sigma_tau(itau)
  !   enddo
  !   close(100)
  ! end function solve_ipt_matsubara_4th

  !##################################################################
  !##################################################################
  !##################################################################
  ! SUPERCONDUCTING CASE WITH COMPLEX ORDER PARAMETER.
  !##################################################################
  !##################################################################
  !##################################################################

  ! !+-------------------------------------------------------------------+
  ! !PURPOSE: Solve 2nd order perturbation theory in Matsubara attractive:
  ! ! - half-filling, CMPLX order parameter.
  ! ! - away-from-half-filling, CMPLX order parameter.
  ! !+-------------------------------------------------------------------+
  ! function solve_ipt_sc_matsubara_c(fg0_iw,delta) result(sigma_iw)
  !   complex(8),dimension(:,:)                           :: fg0_iw
  !   complex(8),dimension(size(fg0_iw,1),size(fg0_iw,2)) :: sigma_iw
  !   complex(8)                                          :: delta
  !   complex(8),dimension(:),allocatable                 :: calG11,calG22,calF
  !   real(8),dimension(:),allocatable                    :: calG11t,calG22t
  !   real(8),dimension(:),allocatable                    :: sigmat
  !   complex(8),dimension(:),allocatable                 :: calFt,selft
  !   integer                                             :: i,LM
  !   LM=size(fg0_iw,2)
  !   if(size(fg0_iw,1)/=2)stop "solve_ipt_sc_matsubara_c: size(input,1)!= 2"
  !   allocate(calG11(LM),calG11t(0:LM))
  !   allocate(calG22(LM),calG22t(0:LM))
  !   allocate(calF(LM),calFt(0:LM))
  !   allocate(sigmat(0:LM),selft(0:LM))
  !   !
  !   !Get the HF-corrected Weiss-Fields:
  !   calG11 =  fg0_iw(1,:)
  !   calG22 = -conjg(fg0_iw(1,:))
  !   calF   =  fg0_iw(2,:)
  !   call fftgf_iw2tau(calG11,calG11t(0:),beta)
  !   call fftgf_iw2tau(calG22,calG22t(0:),beta)
  !   call fftff_iw2tau(calF,calFt(0:),beta)
  !   !Get the 2nd-order Sigma:
  !   forall(i=0:LM)
  !      sigmat(i)=  U**2*(calG11t(i)*calG22t(i) - abs(calFt(i))**2)*calG22t(LM-i)
  !      selft(i) = -U**2*(abs(calFt(i))**2 - calG11t(i)*calG22t(i))*calFt(i) !ACTHUNG HERE: time inversion simmetry
  !   end forall
  !   call fftgf_tau2iw(sigmat(0:),sigma_iw(1,:),beta)
  !   call fftff_tau2iw(selft(0:),sigma_iw(2,:),beta)
  !   !
  !   sigma_iw(2,:)=sigma_iw(2,:) - delta
  !   !
  !   open(11,file="Sigma_tau.ipt",access="append")
  !   open(12,file="Self_tau.ipt",access="append")
  !   do i=0,LM
  !      write(11,*)i*beta/dble(LM),sigmat(i)
  !      write(12,*)i*beta/dble(LM),dreal(selft(i)),dimag(selft(i))
  !   enddo
  !   close(11);close(12)
  !   !
  !   deallocate(calG11,calG11t)
  !   deallocate(calG22,calG22t)
  !   deallocate(calF,calFt)
  !   deallocate(sigmat,selft)
  ! end function solve_ipt_sc_matsubara_c

  ! !+-------------------------------------------------------------------+
  ! !PURPOSE: Solve 2nd order modified perturbation theory in Matsubara for
  ! ! the attractice model away, REAL order parameter case
  ! !+-------------------------------------------------------------------+
  ! function solve_mpt_sc_matsubara_c(fg0_iw,n,n0,delta,delta0) result(sigma_iw)
  !   complex(8),dimension(:,:)                           :: fg0_iw
  !   complex(8),dimension(size(fg0_iw,1),size(fg0_iw,2)) :: sigma_iw
  !   complex(8),dimension(:),allocatable                 :: calG11,calG22,calF
  !   real(8),dimension(:),allocatable                    :: calG11t,calG22t
  !   real(8),dimension(:),allocatable                    :: sigmat
  !   complex(8),dimension(:),allocatable                 :: calFt,selft
  !   integer                                             :: i,LM
  !   real(8)                                             :: n,n0
  !   complex(8)                                          :: delta,delta0
  !   real(8)                                             :: A,B
  !   LM=size(fg0_iw,2)
  !   if(size(fg0_iw,1)/=2)stop "solve_ipt_sc_matsubara_c: size(input,1)!= 2"
  !   allocate(calG11(LM),calG11t(0:LM))
  !   allocate(calG22(LM),calG22t(0:LM))
  !   allocate(calF(LM),calFt(0:LM))
  !   allocate(sigmat(0:LM),selft(0:LM))
  !   !
  !   !Get the HF-corrected Weiss-Fields:
  !   calG11 =  fg0_iw(1,:)
  !   calG22 = -conjg(fg0_iw(1,:))
  !   calF   =  fg0_iw(2,:)
  !   call fftgf_iw2tau(calG11,calG11t(0:),beta)
  !   call fftgf_iw2tau(calG22,calG22t(0:),beta)
  !   call fftff_iw2tau(calF,calFt(0:),beta)
  !   !Get the 2nd-order Sigma:
  !   forall(i=0:LM)
  !      sigmat(i)=  U**2*(calG11t(i)*calG22t(i) - abs(calFt(i))**2)*calG22t(LM-i)
  !      selft(i) = -U**2*(abs(calFt(i))**2 - calG11t(i)*calG22t(i))*calFt(i) !ACTHUNG HERE: time inversion simmetry
  !   end forall
  !   call fftgf_tau2iw(sigmat(0:),sigma_iw(1,:),beta)
  !   call fftff_tau2iw(selft(0:),sigma_iw(2,:),beta)
  !   !
  !   !This is not obvious, just a guess now but I need to check!!
  !   A=U**2*n*(1.d0-n)-abs(delta)**2
  !   B=U**2*n0*(1.d0-n0)-abs(delta0)**2
  !   sigma_iw(1,:) =-U*(n-0.5d0) + sigma_iw(1,:)*A/B
  !   sigma_iw(2,:) =-delta       + sigma_iw(2,:)*A/B
  !   !
  !   open(11,file="Sigma_tau.ipt",access="append")
  !   open(12,file="Self_tau.ipt",access="append")
  !   do i=0,LM
  !      write(11,*)i*beta/dble(LM),sigmat(i)
  !      write(12,*)i*beta/dble(LM),dreal(selft(i)),dimag(selft(i))
  !   enddo
  !   close(11);close(12)
  !   !
  !   deallocate(calG11,calG11t)
  !   deallocate(calG22,calG22t)
  !   deallocate(calF,calFt)
  !   deallocate(sigmat,selft)
  ! end function solve_mpt_sc_matsubara_c

end module IPT_MATSUBARA


	subroutine partials(fn_srcpar,
     &	nsrc, src_cusp, src_lat, src_lon, src_dep,
     &	nsta, sta_lab, sta_lat, sta_lon,
     &	mod_nl, mod_ratio, mod_v, mod_top,
     &	tmp_ttp, tmp_tts,
     &	tmp_xp, tmp_yp, tmp_zp)

	implicit none

	include'hypoDD.inc'

c	Parameters:
	character	fn_srcpar*80	! Source-parameter file
	integer		nsrc		! No. of sources
	integer		src_cusp(MAXEVE)! [1..nsrc]
	doubleprecision	src_lat(MAXEVE)	! [1..nsrc]
	doubleprecision	src_lon(MAXEVE)	! [1..nsrc]
	real		src_dep(MAXEVE)	! [1..nsrc]
	integer		nsta		! No. of stations
	character	sta_lab(MAXSTA)*7! [1..nsta]
	real		sta_lat(MAXSTA)	! [1..nsta]
	real		sta_lon(MAXSTA)	! [1..nsta]
	integer		mod_nl		! No. of layers
	real		mod_ratio	! Vp/Vs
	real		mod_v(MAXLAY)	! [1..mod_nl]
	real		mod_top(MAXLAY)	! [1..mod_nl]
	real		tmp_ttp(MAXSTA,MAXEVE)! [1..nsta,1..nsrc]
	real		tmp_tts(MAXSTA,MAXEVE)! [1..nsta,1..nsrc]
	real		tmp_xp(MAXSTA,MAXEVE)! [1..nsta,1..nsrc]
	real		tmp_yp(MAXSTA,MAXEVE)! [1..nsta,1..nsrc]
	real		tmp_zp(MAXSTA,MAXEVE)! [1..nsta,1..nsrc]

c	Local variables:
	real		ain
	real		az
	real		del
	real		dist
	integer		i, j, k
	integer		iunit		! Output unit number
	real		pi
	integer		trimlen
        real            vs(MAXLAY)

	parameter(pi=3.141593)

      iunit = 0
      if (trimlen(fn_srcpar).gt.1) then
c        Open source-parameter file
         call freeunit(iunit)
         open(iunit,file=fn_srcpar,status='unknown')
      endif

c     Make sure hypocenters don't fall on layer boundaries
      do i=1,nsrc
         do j=1,mod_nl
            if (abs(src_dep(i)-mod_top(j)).lt.0.0001)
     &         src_dep(i) = src_dep(i)-0.001
         enddo
      enddo

c     Get S velocity model
      do i=1,mod_nl
         vs(i) = mod_v(i)/mod_ratio
      enddo

c     Compute epicentral distances, azimuths, angles of incidence,
c     and P/S-travel times from sources to stations
      do i=1,nsta
         do j=1,nsrc
            call delaz2(src_lat(j), src_lon(j), sta_lat(i), sta_lon(i),
     &                 del, dist, az)

c           1D ray tracing
            call ttime(dist, src_dep(j), mod_nl, mod_v, mod_top,
     &                 tmp_ttp(i, j), ain)
            call ttime(dist, src_dep(j), mod_nl, vs, mod_top,
     &                 tmp_tts(i, j), ain)

c           Determine wave speed at the hypocenter
            do k=1,mod_nl
               if (src_dep(j).le.mod_top(k)) goto 10	! break
            enddo
10          continue

c           Depth derivative
            tmp_zp(i,j) = cos((ain * pi)/180.0)/mod_v(k-1)
c           Epicentral derivatives
	    tmp_xp(i,j) = (sin((ain * pi)/180.0) *
     &               cos(((az - 90) * pi)/180.0))/mod_v(k-1)
	    tmp_yp(i,j) = (sin((ain * pi)/180.0) *
     &               cos((az * pi)/180.0))/mod_v(k-1)

c           Write to source-parameter file
            if (iunit .ne. 0)
     &         write(iunit,'(i9,2x,f9.4,2x,f9.4,2x,a7,2x,f9.4,
     &         2x,f9.4,2x,f9.4)')
     &         src_cusp(j), src_lat(j), src_lon(j), sta_lab(i),
     &         dist, az, ain

         enddo
      enddo

      if (iunit .ne. 0) close(iunit)	! Source-parameter file

      end !of subroutine partials


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_fertri
   !
   !     calculates fermi energy and weights using triangular (tetrahedron) method
   !
   USE m_juDFT
   USE m_types
   USE m_constants
   USE m_tetraef
   USE m_dosef
   USE m_dosint
   USE m_doswt

   IMPLICIT NONE

   CONTAINS

   SUBROUTINE fertri(input,kpts,irank,ne,jspins,zc,eig,sfac,&
                     ef,seigv,w)

      TYPE(t_input), INTENT(IN)    :: input
      TYPE(t_kpts),  INTENT(IN)    :: kpts
      INTEGER,       INTENT(IN)    :: jspins,irank
      REAL,          INTENT(IN)    :: zc,sfac
      INTEGER,       INTENT(IN)    :: ne(:,:)!(nkpt,jspins)
      REAL,          INTENT(OUT)   :: seigv
      REAL,          INTENT(INOUT) :: ef
      REAL,          INTENT(OUT)   :: w(:,:,:) !(neig,nkpt,jspins)
      REAL,          INTENT(INOUT) :: eig(:,:,:)!(neig,nkpt,jspins)

      REAL    :: chmom,ct,del,dez,ei,emax,emin,s,s1,workf
      REAL    :: lb,ub,e_set
      INTEGER :: i,ic,j,jsp,k,neig
      INTEGER :: nemax(2)
      REAL, PARAMETER :: de = 5.0e-3 !Step for initial search

      IF (irank == 0) THEN
         WRITE (oUnit,FMT=8000)
8000     FORMAT (/,/,10x,'linear triangular method')
      END IF

      !
      !--->   clear w and set eig=-9999.9
      e_set = -9999.9
      IF (.NOT.input%film) e_set = 1.0e10
      DO jsp = 1,jspins
         nemax(jsp) = 0.0
         DO k = 1,kpts%nkpt
            nemax(jsp) = max0(nemax(jsp),ne(k,jsp))
            DO i = 1,ne(k,jsp)
               w(i,k,jsp) = 0.
            ENDDO
            DO i = ne(k,jsp)+1,size(w,1)
               w(i,k,jsp) = 0.
               eig(i,k,jsp) = e_set
            ENDDO
         ENDDO
      ENDDO
      !
      !      sfac = 2.0/real(jspins)

      IF(.not.input%film) THEN
         lb = MINVAL(eig) - 0.01
         ub = ef + 0.2
         CALL tetra_ef(kpts,jspins,lb,ub,eig,zc,sfac,ef,w)
      ELSE
         IF (irank == 0) THEN
            WRITE (oUnit,FMT=*) 'ef_hist=',ef
         END IF

         ei = ef
!jr      emin = -9999.9
         emin = +9999.9
         emax = -emin
         !Find initial boundaries for the bisection method
         ic = 1
         DO WHILE (emin.GT.emax)
            ic = ic + 1

            CALL dosint(ei,nemax,jspins,kpts,sfac,eig,ct)

            IF (irank == 0) WRITE (oUnit,FMT=*) 'ct=',ct

            IF (ct.LT.zc) THEN ! ei < ef
               emin = ei
               ei = ei + de
            ELSEIF (ct.GT.zc) THEN ! ei > ef
               emax = ei
               ei = ei - de
            ENDIF

            IF (irank==0 .AND. ic.GT.100) THEN
               WRITE (oUnit,FMT=8050) ei,ef,emin,emax,ct,zc
8050           FORMAT (/,/,10x,'error fertri: initial guess of ef off by 25 mry',&
                        ' ei,ef,emin,emax,ct,zc',/,10x,6e16.7,/,10x,&
                        'check number of bands')
               CALL juDFT_error("initial guess of ef off by 25 mry",calledby="fertri")
            END IF

         ENDDO

         IF (ct.NE.zc) THEN
            IF (irank == 0) WRITE (oUnit,FMT=*) '2nd dosint'
            !---> refine ef to a value of 5 mry * (2**-20)
            iterate : DO i = 1, 40
               ei = 0.5* (emin+emax)

               CALL dosint(ei,nemax,jspins,kpts,sfac,eig,ct)

               IF (irank == 0) WRITE (oUnit,FMT=*) 'i=',i,', ct=',ct
               IF ( ct == zc ) THEN
                  EXIT iterate
               ELSEIF ( ct > zc ) THEN
                  emax = ei
               ELSE
                  emin = ei
               ENDIF
            ENDDO iterate
         ENDIF
         ef = ei
         del = emax - emin
         dez = zc - ct
         workf = -hartree_to_ev_const*ef
         IF (irank == 0) THEN
            WRITE (oUnit,FMT=8030) ef,workf,del,dez
8030        FORMAT(/,10x,'fermi energy=',f10.5,' har',/,10x,'work function='&
                    ,f10.5,' ev',/,10x,'uncertainity in energy and weights=',&
                     2e16.6)
         END IF
         !
         !--->   obtain dos at ef
         !
         CALL dosef(ei,nemax,jspins,kpts,sfac,eig)
         !
         !--->   obtain weights needed for integration
         !
         CALL doswt(ei,nemax,jspins,kpts,eig,w)

      ENDIF ! .NOT.input%film

      !
      !--->   write weights
      !
!     DO jsp = 1,jspins
!        neig = nemax(jsp)
!        DO i = 1,neig
!           DO k = 1,kpts%nkpt
!              WRITE (oUnit,FMT=*) 'w(',i,',',k,',',jsp,')=',w(i,k,jsp)
!           ENDDO
!        ENDDO
!     ENDDO

      !
      !--->   obtain sum of weights and valence eigenvalues
      !
      s1 = 0.
      seigv = 0.
      DO jsp = 1,jspins
         s = 0.
         neig = nemax(jsp)
         DO i = 1,neig
            DO k = 1,kpts%nkpt
               s = s + w(i,k,jsp)
               seigv = seigv + w(i,k,jsp)*eig(i,k,jsp)
            ENDDO
         ENDDO
         s1 = s1 + s
      ENDDO
      seigv = sfac*seigv
      chmom = s1 - jspins*s

      IF (irank == 0) THEN
         WRITE (oUnit,FMT=8040) seigv,s1,chmom
8040     FORMAT (/,10x,'sum of valence eigenvalues=',f20.6,5x,&
                  'sum of weights=',f10.6,/,10x,'moment=',f12.6)
      END IF

   END SUBROUTINE fertri
END MODULE m_fertri


! =========================================================
subroutine rp1(maxmx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =========================================================

! solve Riemann problems for the 1D Euler reactive Euler equations using Roe's
! approximate Riemann solver for the Euler system plus a passive
! tracer.

! waves: 3
! equations: 4

! Conserved quantities:
!       1 density
!       2 momentum
!       3 energy
!       4 lamda

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell
! On output, wave contains the waves,
!            s the speeds,
!            amdq the  left-going flux difference  A^- \Delta q
!            apdq the right-going flux difference  A^+ \Delta q

! Note that the i'th Riemann problem has left state qr(:,i-1)
!                                    and right state ql(:,i)
! From the basic clawpack routine step1, rp is called with ql = qr = q.

    implicit double precision (a-h,o-z)
    dimension   ql(meqn,1-mbc:maxmx+mbc)
    dimension   qr(meqn,1-mbc:maxmx+mbc)
    dimension    s(mwaves,1-mbc:maxmx+mbc)
    dimension wave(meqn, mwaves,1-mbc:maxmx+mbc)
    dimension amdq(meqn,1-mbc:maxmx+mbc)
    dimension apdq(meqn,1-mbc:maxmx+mbc)

!     # local storage
!     ---------------
    dimension delta(meqn)
    dimension u(1-mbc:maxmx+mbc),enth(1-mbc:maxmx+mbc)
    dimension a(1-mbc:maxmx+mbc)
    logical :: efix
    common /cparam/  gamma, qheat

    data efix /.true./    !# use entropy fix for transonic rarefactions

    gamma1 = gamma - 1.d0

!     # Compute Roe-averaged quantities:

    do 20 i=2-mbc,mx+mbc
        rhsqrtl = dsqrt(qr(1,i-1))
        rhsqrtr = dsqrt(ql(1,i))
        pl = gamma1*(qr(3,i-1) &
        - 0.5d0*(qr(2,i-1)**2)/qr(1,i-1)+qr(4,i-1)*qheat)
        pr = gamma1*(ql(3,i) &
        - 0.5d0*(ql(2,i)**2)/ql(1,i)+qr(4,i)*qheat)
        rhsq2 = rhsqrtl + rhsqrtr
        u(i) = (qr(2,i-1)/rhsqrtl + ql(2,i)/rhsqrtr) / rhsq2
        enth(i) = (((qr(3,i-1)+pl)/rhsqrtl &
        + (ql(3,i)+pr)/rhsqrtr)) / rhsq2
        a2 = gamma1*(enth(i) - .5d0*u(i)**2)
        a(i) = dsqrt(a2)
    20 END DO

    do 30 i=2-mbc,mx+mbc

    !        # find a1 thru a3, the coefficients of the 3 eigenvectors:

        delta(1) = ql(1,i) - qr(1,i-1)
        delta(2) = ql(2,i) - qr(2,i-1)
        delta(3) = ql(3,i) - qr(3,i-1)
        delta(4) = ql(4,i) - qr(4,i-1)
        a2 = gamma1/a(i)**2 * ((enth(i)-u(i)**2)*delta(1) &
        + u(i)*delta(2) - delta(3))
        a3 = (delta(2) + (a(i)-u(i))*delta(1) - a(i)*a2) / (2.d0*a(i))
        a1 = delta(1) - a2 - a3

    !        # Compute the waves.

        wave(1,1,i) = a1
        wave(2,1,i) = a1*(u(i)-a(i))
        wave(3,1,i) = a1*(enth(i) - u(i)*a(i))
        wave(4,1,i) = 0.d0
        s(1,i) = u(i)-a(i)

        wave(1,2,i) = a2
        wave(2,2,i) = a2*u(i)
        wave(3,2,i) = a2*0.5d0*u(i)**2
        wave(4,2,i) = delta(4)
        s(2,i) = u(i)

        wave(1,3,i) = a3
        wave(2,3,i) = a3*(u(i)+a(i))
        wave(3,3,i) = a3*(enth(i)+u(i)*a(i))
        wave(4,3,i) = 0.d0
        s(3,i) = u(i)+a(i)
    30 END DO

!     # compute Godunov flux f0:
!     --------------------------

    if (efix) go to 110

!     # no entropy fix
!     ----------------

!     # amdq = SUM s*wave   over left-going waves
!     # apdq = SUM s*wave   over right-going waves

    do 100 m=1,3
        do 100 i=2-mbc, mx+mbc
            amdq(m,i) = 0.d0
            apdq(m,i) = 0.d0
            do 90 mw=1,mwaves
                if (s(mw,i) < 0.d0) then
                    amdq(m,i) = amdq(m,i) + s(mw,i)*wave(m,mw,i)
                else
                    apdq(m,i) = apdq(m,i) + s(mw,i)*wave(m,mw,i)
                endif
            90 END DO
    100 END DO
    go to 900

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

    110 continue

!     # With entropy fix
!     ------------------

!    # compute flux differences amdq and apdq.
!    # First compute amdq as sum of s*wave for left going waves.
!    # Incorporate entropy fix by adding a modified fraction of wave
!    # if s should change sign.

    do 200 i=2-mbc,mx+mbc

    !        # check 1-wave:
    !        ---------------

        rhoim1 = qr(1,i-1)
        pim1 = gamma1*(qr(3,i-1) - 0.5d0*qr(2,i-1)**2 / rhoim1 + &
        qr(4,i-1)*qheat)
        cim1 = dsqrt(gamma*pim1/rhoim1)
        s0 = qr(2,i-1)/rhoim1 - cim1     !# u-c in left state (cell i-1)

    !        # check for fully supersonic case:
        if (s0 >= 0.d0 .AND. s(1,i) > 0.d0)  then
        !            # everything is right-going
            do 60 m=1,3
                amdq(m,i) = 0.d0
            60 END DO
            go to 200
        endif

        rho1 = qr(1,i-1) + wave(1,1,i)
        rhou1 = qr(2,i-1) + wave(2,1,i)
        en1 = qr(3,i-1) + wave(3,1,i)
        qlam1 = qr(4,i-1) + wave(4,1,i)
        p1 = gamma1*(en1 - 0.5d0*rhou1**2/rho1 + qlam1)
        c1 = dsqrt(gamma*p1/rho1)
        s1 = rhou1/rho1 - c1  !# u-c to right of 1-wave
        if (s0 < 0.d0 .AND. s1 > 0.d0) then
        !            # transonic rarefaction in the 1-wave
            sfract = s0 * (s1-s(1,i)) / (s1-s0)
        else if (s(1,i) < 0.d0) then
        !            # 1-wave is leftgoing
            sfract = s(1,i)
        else
        !            # 1-wave is rightgoing
            sfract = 0.d0   !# this shouldn't happen since s0 < 0
        endif
        do 120 m=1,3
            amdq(m,i) = sfract*wave(m,1,i)
        120 END DO

    !        # check 2-wave:
    !        ---------------

        if (s(2,i) >= 0.d0) go to 200  !# 2-wave is rightgoing
        do 140 m=1,3
            amdq(m,i) = amdq(m,i) + s(2,i)*wave(m,2,i)
        140 END DO

    !        # check 3-wave:
    !        ---------------

        rhoi = ql(1,i)
        pi = gamma1*(ql(3,i) - 0.5d0*ql(2,i)**2 / rhoi + ql(4,i)*qheat)
        ci = dsqrt(gamma*pi/rhoi)
        s3 = ql(2,i)/rhoi + ci     !# u+c in right state  (cell i)

        rho2 = ql(1,i) - wave(1,3,i)
        rhou2 = ql(2,i) - wave(2,3,i)
        en2 = ql(3,i) - wave(3,3,i)
        qlam2 = ql(4,i) - wave(4,3,i)
        p2 = gamma1*(en2 - 0.5d0*rhou2**2/rho2 + qlam2)
        c2 = dsqrt(gamma*p2/rho2)
        s2 = rhou2/rho2 + c2   !# u+c to left of 3-wave
        if (s2 < 0.d0 .AND. s3 > 0.d0) then
        !            # transonic rarefaction in the 3-wave
            sfract = s2 * (s3-s(3,i)) / (s3-s2)
        else if (s(3,i) < 0.d0) then
        !            # 3-wave is leftgoing
            sfract = s(3,i)
        else
        !            # 3-wave is rightgoing
            go to 200
        endif

        do 160 m=1,3
            amdq(m,i) = amdq(m,i) + sfract*wave(m,3,i)
        160 END DO
    200 END DO

!     # compute the rightgoing flux differences:
!     # df = SUM s*wave   is the total flux difference and apdq = df - amdq

    do 220 m=1,4
        do 220 i = 2-mbc, mx+mbc
            df = 0.d0
            do 210 mw=1,mwaves
                df = df + s(mw,i)*wave(m,mw,i)
            210 END DO
            apdq(m,i) = df - amdq(m,i)
    220 END DO

    900 continue
    return
    end subroutine rp1


c*************************************************************************
c                            TU4_STEP.F
c*************************************************************************
c This subroutine has same i/o as STEP_KDK but here we use a 4th
c order T + U decomposition of the Hamiltonian like the old symplectic
c method (4th order) used by Gladman and Duncan.
c Steps both massive and test particles in the same subroutine.
c
c             Input:
c                 i1st          ==>  = 0 if first step; = 1 not (int scalar)
c                 time          ==>  current time (real scalar)
c                 nbod          ==>  number of massive bodies (int scalar)
c                 ntp            ==>  number of massive bodies (int scalar)
c                 mass          ==>  mass of bodies (real array)
c                 j2rp2,j4rp4   ==>  J2*radii_pl^2 and  J4*radii_pl^4
c                                     (real scalars)
c                 xh,yh,zh      ==>  initial position in helio coord
c                                    (real arrays)
c                 vxh,vyh,vzh   ==>  initial velocity in helio coord
c                                    (real arrays)
c                 xht,yht,zht    ==>  initial part position in helio coord
c                                      (real arrays)
c                 vxht,vyht,vzht ==>  initial velocity in helio coord
c                                        (real arrays)
c                 istat           ==>  status of the test paricles
c                                      (2d integer array)
c                                      istat(i,1) = 0 ==> active:  = 1 not
c                                      istat(i,2) = -1 ==> Danby did not work
c                 rstat           ==>  status of the test paricles
c                                      (2d real array)
c                 dt            ==>  time step
c             Output:
c                 xh,yh,zh      ==>  final position in helio coord
c                                       (real arrays)
c                 vxh,vyh,vzh   ==>  final velocity in helio coord
c                                       (real arrays)
c                 xht,yht,zht    ==>  final position in helio coord
c                                       (real arrays)
c                 vxht,vyht,vzht ==>  final position in helio coord
c                                       (real arrays)
c
c
c Remarks:  Based on Martin's NB4M routines and Hal's STEP_KDK
c Authors:  Martin Duncan
c Date:    3/8/93
c Last revision: 2/24/94

      subroutine tu4_step(i1st,time,nbod,ntp,mass,j2rp2,j4rp4,
     &     xh,yh,zh,vxh,vyh,vzh,xht,yht,zht,vxht,vyht,vzht,
     &     istat,rstat,dt)

      include '../swift.inc'

c...  Inputs Only:
      integer nbod,ntp,i1st
      real*8 mass(nbod),dt,time,j2rp2,j4rp4

c...  Inputs and Outputs:
      integer istat(NTPMAX,NSTAT)
      real*8 rstat(NTPMAX,NSTATR)
      real*8 xh(nbod),yh(nbod),zh(nbod)
      real*8 vxh(nbod),vyh(nbod),vzh(nbod)
      real*8 xht(ntp),yht(ntp),zht(ntp)
      real*8 vxht(ntp),vyht(ntp),vzht(ntp)

c...  Internals
      integer j
      real*8 xb(NPLMAX),yb(NPLMAX),zb(NPLMAX)
      real*8 vxb(NPLMAX),vyb(NPLMAX),vzb(NPLMAX)
      real*8 axb(NPLMAX),ayb(NPLMAX),azb(NPLMAX)
      real*8 xbt(NTPMAX),ybt(NTPMAX),zbt(NTPMAX)
      real*8 vxbt(NTPMAX),vybt(NTPMAX),vzbt(NTPMAX)
      real*8 axbt(NTPMAX),aybt(NTPMAX),azbt(NTPMAX)
      real*8 msys

      real*8 w0,w1,asymp(4),bsymp(4),adt,bdt

      save asymp,bsymp
c----
c...  Executable code

c If first time, load up the symplectic coeffs asymp(*) and bsymp(*)

      if (i1st .eq.0) then

         w1= 1.d0/(2.d0 -(2.d0**(1.d0/3.d0)))
         w0= 1.d0 - 2.d0*(w1)
         asymp(1) = 0.5*w1
         asymp(4) = asymp(1)
         asymp(2) = 0.5*(w0 + w1)
         asymp(3) = asymp(2)
         bsymp(1) = 0.0d0
         bsymp(2) = w1
         bsymp(3) = w0
         bsymp(4) = w1

         i1st = 1
      endif

c...  Convert to barycentric coords
      call coord_h2b(nbod,mass,xh,yh,zh,vxh,vyh,vzh,
     &     xb,yb,zb,vxb,vyb,vzb,msys)
      call coord_h2b_tp(ntp,xht,yht,zht,vxht,vyht,vzht,
     &     xb(1),yb(1),zb(1),vxb(1),vyb(1),vzb(1),
     &     xbt,ybt,zbt,vxbt,vybt,vzbt)

c Take a drift forward to begin the leapfrog (the first kick = 0).
      adt = asymp(1)*dt

      call tu4_ldrift(nbod,xb,yb,zb,vxb,vyb,vzb,adt)
      call tu4_ldrift_tp(ntp,xbt,ybt,zbt,vxbt,vybt,vzbt,
     &     adt,istat)

c Get the accelerations, kick and drift three times
      do j=2,4
         call tu4_getaccb(nbod,mass,j2rp2,j4rp4,xb,yb,zb,axb,ayb,azb)
         call tu4_getaccb_tp(nbod,mass,j2rp2,j4rp4,xb,yb,zb,
     &        ntp,xbt,ybt,zbt,istat,axbt,aybt,azbt)

         bdt = bsymp(j)*dt
         call tu4_vkickb(nbod,vxb,vyb,vzb,axb,ayb,azb,bdt)
         call tu4_vkickb_tp(ntp,vxbt,vybt,vzbt,axbt,aybt,
     &        azbt,bdt,istat)

         adt = asymp(j)*dt
         call tu4_ldrift(nbod,xb,yb,zb,vxb,vyb,vzb,adt)
         call tu4_ldrift_tp(ntp,xbt,ybt,zbt,vxbt,vybt,
     &            vzbt,adt,istat)
      enddo

c...  Convert back to helio. coords at the end of the step
      call coord_b2h(nbod,mass,xb,yb,zb,vxb,vyb,vzb,
     &     xh,yh,zh,vxh,vyh,vzh)
      call coord_b2h_tp(ntp,xbt,ybt,zbt,vxbt,vybt,vzbt,
     &     xb(1),yb(1),zb(1),vxb(1),vyb(1),vzb(1),
     &     xht,yht,zht,vxht,vyht,vzht)

      return

      end   ! step_tu4
c------------------------------------------------------------------------