      MODULE dkes_input
!     Modified indata namelist to be named dkes_input so as not to
!     conflict with VMEC input namelist.
!
!     CONTAINS INPUT PARAMETERS AND ARRAYS READ IN FROM THE DATAIN NAMELIST
!
!     mpol      : Number of Fourier harmonics used to represent the theta
!                 dependence of the distribution functions; 1 < mpol <= mpold
!     mpolb     : Number of Fourier harmonics used to represent the theta
!                 dependence of the equilibrium magnetic field; 1 < mpolb <= mpolbd
!     ntor      : Number of Fourier harmonics used to represent the zeta
!                 dependence of the distributions; 0 < ntor <= ntord
!     ntorb     : Number of Fourier harmonics used to represent the zeta
!                 dependence of the equilibrium field; 0 < ntorb <= ntorbd
!     mmnn      : Matrix containing the distribution of toroidal mode numbers
!                 (expressed in units of nzperiod) in column 1, and the
!                 number of poloidal modes associated with each toroidal
!                 mode in column 2. the poloidal mode numbers associated
!                 with each toroidal mode are stored in the same row,
!                 starting in column 3. WARNING : this spectrum must
!                 encompass the spectrum of the input magnetic field.

!     nrun      : Number of cmul = nu/v  and  efield = Erad/v values
!                 for which solutions are to be calculated; must be < krun
!     cmul      : Corresponding array of cmul values; should be non-zero.
!     efield    : Corresponding array of efield values.
!     nzperiod  : Number of toroidal field periods.
!     chip      : chip = d(chi)/d(rho), radial derivative of the poloidal flux.
!     psip      : psip = d(psi)/d(rho), radial derivative of the toroidal flux
!     btheta    : covariant poloidal component of B. In Boozer coordinates,
!                 a flux function (I, the TOROIDAL current density)
!     bzeta     : covariant toroidal component of B. In Boozer coordinates,
!                 a flux function (J, the POLOIDAL current density)
!     borbi     : Array of nonzero Fourier coefficients of |B| (or 1/|B|) defined by
!                 borbi_realspace (theta,zeta) = SUM borbi(n,m)*cos[m*theta - nzperiod*n*zeta],
!                 where m = 0 to mpolb, n = -ntorb to ntorb
!                 Note: borbi represents "|B|" or 1/|B| ("binverse"), depending on ibbi)
!                 OBSOLETE (see nvalsb array below):
!                 borbi_realspace(theta,zeta) = borbi(n,m)*cos[(m-1)*theta - nzperiod*nvalsb(n)*zeta].
!     ibbi  = 1 : borbi represents B (default, comes from boozmn file, for example)
!     ibbi  = 2 : borbi represents 1/B
!     nvalsb    : (NOW OBSOLETE) Array of ntorb toroidal mode numbers
!                 expressed in units of nzperiod. For an axisymmetric
!                 device, ntorb = 1 and nvalsb(1) = 0.

!     ipmb  = 0 : DKES computes both sine and cosine solutions (default)
!     ipmb  = 1 : DKES computes only sine            solutions.
!     ipmb  = 2 : DKES computes only cosine          solutions.

!     idisk = 0 : DKES computes all l values.
!     idisk = 1 : DKES computes only l = 0,1,2,3,4,5 (default)

!     lfout = 0 : Final distributions not written in the file DKESF. (default)
!     lfout > 0 : Final distributions     written in the file DKESF,
!                 for l+1 = 1,2,.....,lfout <= lalpha.

!     meshtz    : Determines theta and zeta meshes for Fourier transforms.
!                 See ntheta and nzeta in the MNSET subroutine. Used to
!                 ensure accuracy of spectral matrix elements.

!     lalpha    : Number of orthonormalized Legendre polynomials used to
!                 represent the dependence of the distributions on the
!                 pitch-angle variable cos(alpha); lalpha >= 6
!                 NOTE OF IMPORTANCE: the sqrt(l+1/2) factor is built in!

      USE stel_kinds
      INTEGER, PARAMETER :: mpold = 200
      INTEGER, PARAMETER :: ntord = 200
      INTEGER, PARAMETER :: mpolbd = 100
      INTEGER, PARAMETER :: ntorbd = 100
      INTEGER, PARAMETER :: bigint = 2**16
      INTEGER, PARAMETER :: krun = 100

      INTEGER :: mpol, ntor, lalpha, ipmb, meshtz, idisk,
     1   lfout, ifscl, nrun, nzperiod, mpolb, ntorb, ibbi

      INTEGER, DIMENSION(mpold + 2,ntord) :: mmnn

      REAL(rprec), DIMENSION(krun) :: cmul, efield
      REAL(rprec) :: chip, psip, btheta, bzeta
      REAL(rprec), DIMENSION(-ntorbd:ntorbd,0:mpolbd) :: borbi
      INTEGER, DIMENSION(ntorbd) :: nvalsb                              !OBSOLETE
      CHARACTER*1, PARAMETER :: dashes(131) = (/ ('-', idisk=1,131) /)
      CHARACTER*80 :: summary_file            !record file addition
      INTEGER :: itab_out                     !record file addition
      LOGICAL :: lscreen

      NAMELIST /dkes_indata/mpol, ntor, lalpha, ipmb,mmnn,meshtz,idisk,
     1   lfout, ifscl, nrun, cmul, efield, nzperiod, chip, psip, mpolb,
     2   ntorb, nvalsb, borbi, btheta, bzeta, ibbi

      CONTAINS

      SUBROUTINE read_dkes_input
      USE safe_open_mod
      USE vimatrix, ONLY: ioout, ioout_opt
      IMPLICIT NONE
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      INTEGER, PARAMETER :: idata = 7
      INTEGER, PARAMETER :: iout = 20
      INTEGER, PARAMETER :: iout_opt = 14
      REAL (rprec), PARAMETER :: zero = 0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: numargs, icount, istat, index_blank, iodata
      INTEGER :: m, n, nmax, mmax
      CHARACTER :: output_file*55, opt_file*55, input_file*50
      CHARACTER*50 :: arg1(7)
      CHARACTER :: tb*1            !record file addition
      LOGICAL :: lexist
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      EXTERNAL getcarg, dkes_input_prepare
C-----------------------------------------------
      tb = char(9)            !record file addition
      lscreen = .true.

c  Read input data from "datain" namelist
      CALL getcarg(1, arg1(1), numargs)

      DO icount = 2, MIN(7,numargs)
         CALL getcarg(icount, arg1(icount), istat)
      END DO
      IF (numargs .ge. 4) THEN
         IF (numargs .eq. 4) arg1(5) = 'T'
         CALL dkes_input_prepare (arg1, numargs, input_file, 1)
         IF (arg1(5)(1:1).eq.'f' .or. arg1(5)(1:1).eq.'F')
     1      lscreen = .false.
      ELSE IF (numargs .eq. 1) THEN
         input_file = TRIM(arg1(1))
      ELSE
         PRINT *, ' MUST ENTER INPUT FILENAME ON COMMAND LINE'
         STOP
      END IF

      index_blank = INDEX(input_file,'input.')

      IF (index_blank .eq. 0) THEN
         INQUIRE (file=TRIM(input_file), exist=lexist)
         IF (.not.lexist) THEN
            input_file = 'input.' // TRIM(input_file)
            index_blank = 1
         ELSE
            index_blank = INDEX(input_file,'.') - 5
         END IF
      END IF

      index_blank = MAX(index_blank + 5,1)
      output_file= 'dkesout' // input_file(index_blank:)
      opt_file= 'opt_dkes' // input_file(index_blank:)             !DAS 2/21/2000
      summary_file = 'results' // input_file(index_blank:)         !record file addition

!
!     OPEN INPUT AND OUTPUT FILES FOR READING (AND WRITING OUTPUT)
!
      iodata = idata
      CALL safe_open(iodata, istat, input_file, 'old', 'formatted')
      IF (istat .ne. 0) STOP 'Error reading input file in DKES'
      ioout = iout
      CALL safe_open(ioout, istat, output_file, 'replace', 'formatted')
      IF (istat .ne. 0) STOP 'Error writing output file'
      ioout_opt = iout_opt
      CALL safe_open(ioout_opt, istat, opt_file, 'replace','formatted')
      IF (istat .ne. 0) STOP 'Error writing opt_output file'

!     Read namelist (datain) input
      nvalsb(1) = -bigint-1
      idisk = 1
      lfout = 0
      ibbi = 1
      borbi = 0
      READ (iodata, nml=dkes_indata, iostat=istat)
      IF (istat .ne. 0) STOP'Error reading dkes_indata NAMELIST in DKES'
      CLOSE (iodata)

!
!     Recompute ntorb, mpolb for new style input where
!     borbi is input with actual index value, borbi(n,m)
!
      IF (nvalsb(1) <= -bigint) THEN
         nmax = -bigint;  mmax = -bigint
         DO n = -ntorbd, ntorbd
            DO m = 0, mpolbd
               IF (borbi(n,m) .ne. zero) THEN
                  nmax = max (nmax, abs(n))
                  mmax = max (mmax, abs(m))
               END IF
            END DO
         END DO

!        User MAY input smaller values if he does not want to use entire array
         ntorb = min (abs(ntorb), nmax)
         mpolb = min (abs(mpolb-1), mmax)

      ELSE
         IF (ntorb > ntorbd) THEN
            WRITE (ioout, 45) ntorb, ntorbd
            STOP ' ntorb > ntorbd in DKES input'
         END IF
         IF (mpolb < 2) THEN
            WRITE (ioout, 20) mpolb
            STOP ' mpolb < 2 in DKES input'
         ENDIF
  20     FORMAT(' mpolb = ',i5,'  is less than 2')
  45     FORMAT(' ntorb = ',i5,'  is greater than ntorbd = ',i5)

      END IF
!
!     perform error checking on input data

      IF (nzperiod .le. 0) nzperiod = 1
      IF (ibbi<1 .or. ibbi >2) THEN
         WRITE (ioout,'(a)') ' ibbi must =1 or =2'
         STOP ' ibbi <1 or ibbi >2 in DKES input'
      END IF

      IF (mpol < 1) THEN
         WRITE (ioout, 10) mpol
  10     FORMAT(' mpol = ',i5,'  is less than 1')
         STOP ' mpol < 1 in DKES input'
      ENDIF

      IF (mpol > mpold) THEN
         WRITE (ioout, 15) mpol, mpold
  15     FORMAT(' mpol = ',i5,'  is greater than mpold = ',i5)
         STOP ' mpol > mpold in DKES input'
      ENDIF

      IF (mpolb > mpolbd) THEN
         WRITE (ioout, 25) mpolb, mpolbd
  25     FORMAT(' mpolb = ',i5,'  is greater than mpolbd = ',i5)
         STOP ' mpolb > mpolbd in DKES input'
      ENDIF

      IF (ntor < 1) THEN
         WRITE (ioout, 30) ntor
  30     FORMAT(' ntor = ',i5,'  is less than 1')
         STOP ' ntor < 1 in DKES input'
      ENDIF

      IF (ntor > ntord) THEN
         WRITE (ioout, 35) ntor, ntord
  35     FORMAT(' ntor = ',i5,'  is greater than ntord = ',i5)
         STOP ' ntor > ntord in DKES input'
      ENDIF

      IF (lalpha < 6) THEN
         WRITE (ioout, 50) lalpha
  50     FORMAT(' lalpha = ',i5,'  is less than 6')
         STOP ' lalpha < 6 in DKES input'
      ENDIF

      IF (ipmb<0 .or. ipmb>2) ipmb = 0

      meshtz = MAX(0,meshtz)

      END SUBROUTINE read_dkes_input

      END MODULE dkes_input


!***********************************/
!	Name:SLAU2で非粘性流束を計算するプログラム
!	Alias:USlau2
!	Description:隣接する2つのセルから基礎変数を受け取って流束を計算する
!	Type:
!	Input:
!	Output:
!	Note:基礎変数MUSCLとの併用を前提としているため，入力は基礎変数
!	Author:Akitaka Toyota
!	Date:2018.11.19
!	Update:
!	Other:
!***********************************/
subroutine USlau2(UConf, UG, UCC, UCE) !MUSCL経由の場合CEのみ，1次精度の場合CCを渡す
    use StructVar_Mod
    use LoopVar_Mod
    use ConstantVar_Mod, Gamma => SpecificOfHeatRatio, Epsilon => EntropyCorrection
    implicit none
    type(Configulation), intent(in) :: UConf
    type(UnstructuredGrid), intent(in) :: UG
    type(CellCenter), intent(inout) :: UCC
    type(CellEdge), intent(inout) :: UCE

    double precision, allocatable :: PhaiLR(:, :), Normal(:)    ! (1:密度，x速度，y速度，z速度, エンタルピー, 2:L(minus)=1, R(plus)=2
    double precision :: PresL, PresR, DensL, DensR,VelNormL, VelNormR
    double precision :: SoundV_Ave !,SoundV_L, SoundV_R
    double precision :: NormalVelocity_L, NormalVelocity_R
    double precision :: AbsNormalVelocity_ave, AbsNormalVelocity_P, AbsNormalVelocity_M   ! PMはプラスマイナスの意味
    double precision :: Mach_L, Mach_R, Mach_hat
    double precision :: param_Chi, param_g   ! Chi =　カイ = xの筆記体は文献によってLambdaと表記されることがある
    double precision :: pres_P_a, pres_M_a, gamma_hr
    double precision :: mass_flux, pressure_flux
    iDim = UG%GM%Dimension

    allocate(PhaiLR(5, 2), Normal(5))
    Normal = 0.0d0

    do iEdge=1, UG%GI%Edges !すべての界面について
        ! set quantity of cell between surface iEdge
        if(UConf%UseMUSCL == 1) then
            PhaiLR(1, 1:2) = 1.0d0
            ! R = - = Phai1 = ReQ1 (Surface Front Cell)
            PresR = UCE%RebuildQunatity(5,1,1,1,iEdge)
            DensR = UCE%RebuildQunatity(1,1,1,1,iEdge)
            VelNormR = sum(UCE%RebuildQunatity(2:4,1,1,1,iEdge)**2)

            PhaiLR(2:4,1) = UCE%RebuildQunatity(2:4,1,1,1,iEdge)
            PhaiLR(5,1) = InverseGmin1 * Gamma * PresR / UCE%RebuildQunatity(1,1,1,1,iEdge) + 0.5d0 * VelNormR

            ! L = + = Phai2 = ReQ2 (Surface Back Cell)
            PresL = UCE%RebuildQunatity(5,1,1,2,iEdge)
            DensL = UCE%RebuildQunatity(1,1,1,2,iEdge)
            VelNormL = sum(UCE%RebuildQunatity(2:4,1,1,2,iEdge)**2)

            PhaiLR(2:4,2) = UCE%RebuildQunatity(2:4,1,1,2,iEdge)
            PhaiLR(5,2) = InverseGmin1 * Gamma * PresL / UCE%RebuildQunatity(1,1,1,2,iEdge) + 0.5d0 * VelNormL

        else   ! UCC%PrimitiveVariablesからPhaiを計算する場合はこっちを利用(空間1次精度計算用)
            call JPUConserve2Primitive(UG, UCC)
            iCell = UG%Line%Cell(iEdge, 1, 1)
            iAdjacentCell = UG%Line%Cell(iEdge, 2, 1)

            PhaiLR(1, 1:2) = 1.0d0
            ! R = - = Phai1 = ReQ1 (Surface Front Cell)
            PresR = UCC%PrimitiveVariable(5,iCell,1,1)
            DensR = UCC%PrimitiveVariable(1,iCell,1,1)
            VelNormR = sum(UCC%PrimitiveVariable(2:4,iCell,1,1)**2)

            PhaiLR(2:4,1) = UCC%PrimitiveVariable(2:4,iCell,1,1)
            PhaiLR(5,1) = InverseGmin1 * Gamma * PresR / UCC%PrimitiveVariable(1,iCell,1,1) + 0.5d0 * VelNormR

            ! L = + = Phai2 = ReQ2 (Surface Back Cell)
            PresL = UCC%PrimitiveVariable(5,iAdjacentCell,1,1)
            DensL = UCC%PrimitiveVariable(1,iAdjacentCell,1,1)
            VelNormL = sum(UCC%PrimitiveVariable(2:4,iAdjacentCell,1,1)**2)

            PhaiLR(2:4,2) = UCC%PrimitiveVariable(2:4,iAdjacentCell,1,1)
            PhaiLR(5,2) = InverseGmin1 * Gamma * PresL / UCC%PrimitiveVariable(1,iAdjacentCell,1,1) + 0.5d0 * VelNormL
        end if
        Normal(2:4) = UG%GM%Normal(iEdge, :)

        ! get sound veocity average
        SoundV_Ave = 0.5d0 * (sqrt(Gamma * PresL / DensL) + sqrt(Gamma * PresR / DensR))

        ! get absolute normal velocity of each cell
        NormalVelocity_L = dot_product(PhaiLR(2:4, 2), UG%GM%Normal(iEdge, :))
        NormalVelocity_R = dot_product(PhaiLR(2:4, 1), UG%GM%Normal(iEdge, :))

        AbsNormalVelocity_ave = (DensL * abs(NormalVelocity_L) + DensR * abs(NormalVelocity_R)) &
                                & / (DensL + DensR)

        ! calc local mach number
        Mach_L = NormalVelocity_L / SoundV_Ave
        Mach_R = NormalVelocity_R / SoundV_Ave
        Mach_hat = min(1.0d0, sqrt(0.5d0 * (VelNormL + VelNormR)) / SoundV_Ave)

        ! calc parameter param_Chi and param_g
        param_Chi = (1.0d0 - Mach_hat) ** 2
        param_g = -max(min(Mach_L, 0.0d0), -1.0d0) * min(max(Mach_R, 0.0d0), 1.0d0)

        ! calc absolute normal velocity Plus and Minus
        AbsNormalVelocity_P = (1.0d0 - param_g) * AbsNormalVelocity_ave + param_g * abs(NormalVelocity_L)
        AbsNormalVelocity_M = (1.0d0 - param_g) * AbsNormalVelocity_ave + param_g * abs(NormalVelocity_R)

        ! get mass_flux
        mass_flux = 0.5d0 * (DensL * (NormalVelocity_L + AbsNormalVelocity_P) &
                         & + DensR * (NormalVelocity_R - AbsNormalVelocity_M) &
                         & - param_Chi / SoundV_Ave * (PresR - PresL))    ! 最後の圧力の差分式は、プラスマイナス逆である可能性あり

        ! get pressure flux
        if(abs(Mach_L) > 1.0d0) then
            pres_P_a = 0.5d0 * (1.0d0 + sign(1.0d0, Mach_L))
        else
            pres_P_a = 0.25d0 * ((Mach_L + 1.0d0) ** 2) * (2.0d0 - Mach_L)
        end if

        if(abs(Mach_R) > 1.0d0) then
            pres_M_a = 0.5d0 * (1.0d0 - sign(1.0d0, Mach_R))
        else
            pres_M_a = 0.25d0 * ((Mach_R - 1.0d0) ** 2) * (2.0d0 + Mach_R)
        end if

        !gamma_hr = ! high resolution化は後回し

        pressure_flux = 0.5d0 * (PresL + PresR) + 0.5d0 * (pres_P_a - pres_M_a) * (PresL - PresR) &
                        & + sqrt(0.5d0 * (VelNormL + VelNormR)) * (pres_P_a + pres_M_a - 1.0d0) * (0.5d0 * (DensL + DensR) / SoundV_Ave)

        UCE%NormalFluxDiff(:,1,1,1,iEdge) = &
        &   0.5d0 * (mass_flux + abs(mass_flux)) * PhaiLR(:, 2) &
        & + 0.5d0 * (mass_flux - abs(mass_flux)) * PhaiLR(:, 1) &
        & + pressure_flux * Normal

    end do

    return
end subroutine USlau2


c *****************************************************
c    hgdengen.f
c 22 Mar., 2015   written by D. Kawata
c *****************************************************
c70*******************************************************************

      subroutine hgdengen(npg,mtothg,cnfw,rvir)
      include './define.f'

      integer npg
      integer i
      double precision mtothg,cnfw,rvir
      double precision rs,gcv,rho0hg
      double precision rp,xp
      double precision rhombhg
      external rhombhg

      rs=rvir/cnfw
      gcv=9.0d0*dlog(1.0d0+(4.0d0/3.0d0)*cnfw)
     &   -8.0d0*dlog(1.0d0+cnfw)-(4.0d0*cnfw/(1.0d0+cnfw))
      rho0hg=mtothg/(4.0d0*M_PI*(rs**3)*gcv)

      do i=0,npg-1
        if(x_rzg(i).gt.0.0d0.or.z_rzg(i).gt.0.0d0) then
          rp=dsqrt(x_rzg(i)**2+z_rzg(i)**2)
        else
          rp=10.0d0**lri_rzg
        endif
        xp=rp/rs
        rho_rzg(i)=rho0hg*rhombhg(xp)
      enddo

      return
      end


MODULE kmeans
IMPLICIT NONE

!     Define BIG to be a very large positive number

REAL, PARAMETER, PRIVATE  :: zero = 0.0, one = 1.0, big = HUGE(zero)

PUBLIC   :: kmns
PRIVATE  :: optra, qtran

CONTAINS

SUBROUTINE kmns(a, m, n, c, k, ic1, ic2, nc, an1, an2, ncp, d,  &
                itran, live, iter, wss, ifault)

! Code converted using TO_F90 by Alan Miller
! Date: 2000-11-01  Time: 10:00:51

!     ALGORITHM AS 136  APPL. STATIST. (1979) VOL.28, NO.1

!     Divide M points in N-dimensional space into K clusters so that
!     the within cluster sum of squares is minimized.

REAL, INTENT(IN)         :: a(:,:)   ! a(m,n)
INTEGER, INTENT(IN)      :: m
INTEGER, INTENT(IN)      :: n
REAL, INTENT(IN OUT)     :: c(:,:)   ! c(k,n)
INTEGER, INTENT(IN)      :: k
INTEGER, INTENT(OUT)     :: ic1(:)
INTEGER, INTENT(OUT)     :: ic2(:)
INTEGER, INTENT(OUT)     :: nc(:)
REAL, INTENT(OUT)        :: an1(:)
REAL, INTENT(OUT)        :: an2(:)
INTEGER, INTENT(OUT)     :: ncp(:)
REAL, INTENT(IN OUT)     :: d(:)
INTEGER, INTENT(OUT)     :: itran(:)
INTEGER, INTENT(IN OUT)  :: live(:)
INTEGER, INTENT(IN)      :: iter
REAL, INTENT(OUT)        :: wss(:)
INTEGER, INTENT(OUT)     :: ifault

! Local variables

INTEGER  :: i, ii, ij, il, indx, j, l
REAL     :: aa, da, db, dc, dt(2), temp

ifault = 3
IF (k <= 1 .OR. k >= m) RETURN

!     For each point I, find its two closest centres, IC1(I) and
!     IC2(I).     Assign it to IC1(I).

DO  i = 1, m
  ic1(i) = 1
  ic2(i) = 2
  DO  il = 1, 2
    dt(il) = zero
    DO  j = 1, n
      da = a(i,j) - c(il,j)
      dt(il) = dt(il) + da*da
    END DO
  END DO
  IF (dt(1) > dt(2)) THEN
    ic1(i) = 2
    ic2(i) = 1
    temp = dt(1)
    dt(1) = dt(2)
    dt(2) = temp
  END IF

  loop50:  DO  l = 3, k
    db = zero
    DO  j = 1, n
      dc = a(i,j) - c(l,j)
      db = db + dc*dc
      IF (db >= dt(2)) CYCLE loop50
    END DO
    IF (db >= dt(1)) THEN
      dt(2) = db
      ic2(i) = l
    ELSE
      dt(2) = dt(1)
      ic2(i) = ic1(i)
      dt(1) = db
      ic1(i) = l
    END IF
  END DO loop50
END DO

!     Update cluster centres to be the average of points contained
!     within them.

DO  l = 1, k
  nc(l) = 0
  c(l,1:n) = zero
END DO
DO  i = 1, m
  l = ic1(i)
  nc(l) = nc(l) + 1
  c(l,1:n) = c(l,1:n) + a(i,1:n)
END DO

!     Check to see if there is any empty cluster at this stage

DO  l = 1, k
  IF (nc(l) == 0) THEN
    ifault = 1
    RETURN
  END IF
  aa = nc(l)
  c(l,1:n) = c(l,1:n) / aa

!     Initialize AN1, AN2, ITRAN & NCP
!     AN1(L) = NC(L) / (NC(L) - 1)
!     AN2(L) = NC(L) / (NC(L) + 1)
!     ITRAN(L) = 1 if cluster L is updated in the quick-transfer stage,
!              = 0 otherwise
!     In the optimal-transfer stage, NCP(L) stores the step at which
!     cluster L is last updated.
!     In the quick-transfer stage, NCP(L) stores the step at which
!     cluster L is last updated plus M.

  an2(l) = aa / (aa + one)
  an1(l) = big
  IF (aa > one) an1(l) = aa / (aa - one)
  itran(l) = 1
  ncp(l) = -1
END DO
indx = 0
DO  ij = 1, iter

!     In this stage, there is only one pass through the data.   Each
!     point is re-allocated, if necessary, to the cluster that will
!     induce the maximum reduction in within-cluster sum of squares.

  CALL optra(a, m, n, c, k, ic1, ic2, nc, an1, an2, ncp, d, itran, live, indx)

!     Stop if no transfer took place in the last M optimal transfer steps.

  IF (indx == m) GO TO 150

!     Each point is tested in turn to see if it should be re-allocated
!     to the cluster to which it is most likely to be transferred,
!     IC2(I), from its present cluster, IC1(I).   Loop through the
!     data until no further change is to take place.

  CALL qtran(a, m, n, c, ic1, ic2, nc, an1, an2, ncp, d, itran, indx)

!     If there are only two clusters, there is no need to re-enter the
!     optimal transfer stage.

  IF (k == 2) GO TO 150

!     NCP has to be set to 0 before entering OPTRA.

  ncp(1:k) = 0
END DO

!     Since the specified number of iterations has been exceeded, set
!     IFAULT = 2.   This may indicate unforeseen looping.

ifault = 2

!     Compute within-cluster sum of squares for each cluster.

150 DO  l = 1, k
  wss(l) = zero
  c(l,1:n) = zero
END DO
DO  i = 1, m
  ii = ic1(i)
  c(ii,1:n) = c(ii,1:n) + a(i,1:n)
END DO
DO  j = 1, n
  c(1:k,j) = c(1:k,j) / REAL(nc(l))
  DO  i = 1, m
    ii = ic1(i)
    da = a(i,j) - c(ii,j)
    wss(ii) = wss(ii) + da*da
  END DO
END DO

RETURN
END SUBROUTINE kmns

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

!     ALGORITHM AS 136.1  APPL. STATIST. (1979) VOL.28, NO.1

!     This is the optimal transfer stage.

!     Each point is re-allocated, if necessary, to the cluster that will
!     induce a maximum reduction in the within-cluster sum of squares.

REAL, INTENT(IN)         :: a(:,:)   ! a(m,n)
INTEGER, INTENT(IN)      :: m
INTEGER, INTENT(IN)      :: n
REAL, INTENT(IN OUT)     :: c(:,:)   ! c(k,n)
INTEGER, INTENT(IN)      :: k
INTEGER, INTENT(IN OUT)  :: ic1(:)
INTEGER, INTENT(IN OUT)  :: ic2(:)
INTEGER, INTENT(IN OUT)  :: nc(:)
REAL, INTENT(IN OUT)     :: an1(:)
REAL, INTENT(IN OUT)     :: an2(:)
INTEGER, INTENT(IN OUT)  :: ncp(:)
REAL, INTENT(OUT)        :: d(:)
INTEGER, INTENT(IN OUT)  :: itran(:)
INTEGER, INTENT(OUT)     :: live(:)
INTEGER, INTENT(OUT)     :: indx

! Local variables

INTEGER  :: i, j, l, l1, l2, ll
REAL     :: al1, al2, alt, alw, da, db, dc, dd, de, df, rr, r2

!     If cluster L is updated in the last quick-transfer stage, it
!     belongs to the live set throughout this stage.   Otherwise, at
!     each step, it is not in the live set if it has not been updated
!     in the last M optimal transfer steps.

DO  l = 1, k
  IF (itran(l) == 1) live(l) = m + 1
END DO
DO  i = 1, m
  indx = indx + 1
  l1 = ic1(i)
  l2 = ic2(i)
  ll = l2

!     If point I is the only member of cluster L1, no transfer.

  IF (nc(l1) == 1) THEN
    IF (indx == m) RETURN
    CYCLE
  END IF

!     If L1 has not yet been updated in this stage, no need to re-compute D(I).

  IF (ncp(l1) == 0) GO TO 30
  de = zero
  DO  j = 1, n
    df = a(i,j) - c(l1,j)
    de = de + df*df
  END DO
  d(i) = de * an1(l1)

!     Find the cluster with minimum R2.

  30 da = zero
  DO  j = 1, n
    db = a(i,j) - c(l2,j)
    da = da + db*db
  END DO
  r2 = da * an2(l2)
  loop60:  DO  l = 1, k

!    If I >= LIVE(L1), then L1 is not in the live set.   If this is true, we
!    only need to consider clusters that are in the live set for possible
!    transfer of point I.  Otherwise, we need to consider all possible clusters.

    IF (i >= live(l1) .AND. i >= live(l) .OR. l == l1 .OR.  &
        l == ll) CYCLE loop60
    rr = r2 / an2(l)
    dc = zero
    DO  j = 1, n
      dd = a(i,j) - c(l,j)
      dc = dc + dd*dd
      IF (dc >= rr) CYCLE loop60
    END DO
    r2 = dc * an2(l)
    l2 = l
  END DO loop60
  IF (r2 >= d(i)) THEN

!     If no transfer is necessary, L2 is the new IC2(I).

    ic2(i) = l2
    IF (indx == m) RETURN

!     Update cluster centres, LIVE, NCP, AN1 & AN2 for clusters L1 and
!     L2, and update IC1(I) & IC2(I).

  ELSE
    indx = 0
    live(l1) = m + i
    live(l2) = m + i
    ncp(l1) = i
    ncp(l2) = i
    al1 = nc(l1)
    alw = al1 - one
    al2 = nc(l2)
    alt = al2 + one
    DO  j = 1, n
      c(l1,j) = (c(l1,j) * al1 - a(i,j)) / alw
      c(l2,j) = (c(l2,j) * al2 + a(i,j)) / alt
    END DO
    nc(l1) = nc(l1) - 1
    nc(l2) = nc(l2) + 1
    an2(l1) = alw / al1
    an1(l1) = big
    IF (alw > one) an1(l1) = alw / (alw - one)
    an1(l2) = alt / al2
    an2(l2) = alt / (alt + one)
    ic1(i) = l2
    ic2(i) = l1
  END IF
END DO
DO  l = 1, k

!     ITRAN(L) = 0 before entering QTRAN.   Also, LIVE(L) has to be
!     decreased by M before re-entering OPTRA.

  itran(l) = 0
  live(l) = live(l) - m
END DO

RETURN
END SUBROUTINE optra

SUBROUTINE qtran(a, m, n, c, ic1, ic2, nc, an1, an2, ncp, d, itran, indx)

! N.B. Argument K has been removed.

!     ALGORITHM AS 136.2  APPL. STATIST. (1979) VOL.28, NO.1

!     This is the quick transfer stage.
!     IC1(I) is the cluster which point I belongs to.
!     IC2(I) is the cluster which point I is most likely to be
!         transferred to.
!     For each point I, IC1(I) & IC2(I) are switched, if necessary, to
!     reduce within-cluster sum of squares.  The cluster centres are
!     updated after each step.

REAL, INTENT(IN)         :: a(:,:)   ! a(m,n)
INTEGER, INTENT(IN)      :: m
INTEGER, INTENT(IN)      :: n
REAL, INTENT(IN OUT)     :: c(:,:)   ! c(k,n)
INTEGER, INTENT(IN OUT)  :: ic1(:)
INTEGER, INTENT(IN OUT)  :: ic2(:)
INTEGER, INTENT(IN OUT)  :: nc(:)
REAL, INTENT(IN OUT)     :: an1(:)
REAL, INTENT(IN OUT)     :: an2(:)
INTEGER, INTENT(IN OUT)  :: ncp(:)
REAL, INTENT(OUT)        :: d(:)
INTEGER, INTENT(OUT)     :: itran(:)
INTEGER, INTENT(OUT)     :: indx

! Local variables

INTEGER  :: i, icoun, istep, j, l1, l2
REAL     :: al1, al2, alt, alw, da, db, dd, de, r2

!     In the optimal transfer stage, NCP(L) indicates the step at which
!     cluster L is last updated.   In the quick transfer stage, NCP(L)
!     is equal to the step at which cluster L is last updated plus M.

icoun = 0
istep = 0
10 DO  i = 1, m
  icoun = icoun + 1
  istep = istep + 1
  l1 = ic1(i)
  l2 = ic2(i)

!     If point I is the only member of cluster L1, no transfer.

  IF (nc(l1) == 1) GO TO 60

!     If ISTEP > NCP(L1), no need to re-compute distance from point I to
!     cluster L1.   Note that if cluster L1 is last updated exactly M steps
!     ago, we still need to compute the distance from point I to cluster L1.

  IF (istep > ncp(l1)) GO TO 30
  da = zero
  DO  j = 1, n
    db = a(i,j) - c(l1,j)
    da = da + db*db
  END DO
  d(i) = da * an1(l1)

!     If ISTEP >= both NCP(L1) & NCP(L2) there will be no transfer of
!     point I at this step.

  30 IF (istep >= ncp(l1) .AND. istep >= ncp(l2)) GO TO 60
  r2 = d(i) / an2(l2)
  dd = zero
  DO  j = 1, n
    de = a(i,j) - c(l2,j)
    dd = dd + de*de
    IF (dd >= r2) GO TO 60
  END DO

!     Update cluster centres, NCP, NC, ITRAN, AN1 & AN2 for clusters
!     L1 & L2.   Also update IC1(I) & IC2(I).   Note that if any
!     updating occurs in this stage, INDX is set back to 0.

  icoun = 0
  indx = 0
  itran(l1) = 1
  itran(l2) = 1
  ncp(l1) = istep + m
  ncp(l2) = istep + m
  al1 = nc(l1)
  alw = al1 - one
  al2 = nc(l2)
  alt = al2 + one
  DO  j = 1, n
    c(l1,j) = (c(l1,j) * al1 - a(i,j)) / alw
    c(l2,j) = (c(l2,j) * al2 + a(i,j)) / alt
  END DO
  nc(l1) = nc(l1) - 1
  nc(l2) = nc(l2) + 1
  an2(l1) = alw / al1
  an1(l1) = big
  IF (alw > one) an1(l1) = alw / (alw - one)
  an1(l2) = alt / al2
  an2(l2) = alt / (alt + one)
  ic1(i) = l2
  ic2(i) = l1

!     If no re-allocation took place in the last M steps, return.

  60 IF (icoun == m) RETURN
END DO
GO TO 10
END SUBROUTINE qtran

END MODULE kmeans


module lttb
    implicit none

contains

    subroutine lttb_downsize(data, threshold, series)
        implicit NONE

        real, intent(in) :: data(:)
        integer, intent(in) :: threshold
        real, intent(out), allocatable :: series(:)

        ! internal variables
        integer i, sampledIndex, a, nextA, dataLength
        real maxAreaPoint, maxArea, area, every

        dataLength = size(data)

        ! just copy the data 'as-is'
        if (dataLength .le. threshold) then
            print *, 'no downsizing needed, copying time-series'

            allocate (series(dataLength))
            series(:) = data(:)

            return
        end if

        print *, 'downsizing time-series with Largest-Triangle-Three-Buckets'

        allocate (series(threshold))

        ! always add the first point
        series(1) = data(1)
        sampledIndex = 1
        a = 0
        nextA = 0
        maxAreaPoint = 0.0

        ! Bucket size. Leave room for start and end data points
        every = real(dataLength - 2)/real(threshold - 2)

        do i = 0, threshold - 2 - 1
            block
                integer avgRangeStart, avgRangeEnd, avgRangeLength
                real avgX, avgY, pointAX, pointAY
                integer rangeOffs, rangeTo

                avgRangeStart = floor((i + 1)*every) + 1
                avgRangeEnd = floor((i + 2)*every) + 1
                avgRangeEnd = min(avgRangeEnd, dataLength)
                avgRangeLength = avgRangeEnd - avgRangeStart

                avgX = 0.0
                avgY = 0.0

                do while (avgRangeStart < avgRangeEnd)
                    avgX = avgX + avgRangeStart
                    avgY = avgY + data(1 + avgRangeStart)
                    avgRangeStart = avgRangeStart + 1
                end do

                avgX = avgX/avgRangeLength
                avgY = avgY/avgRangeLength

                ! Get the range for this bucket
                rangeOffs = floor((i + 0)*every) + 1
                rangeTo = floor((i + 1)*every) + 1

                ! Point a
                pointAX = a
                pointAY = data(1 + a)

                maxArea = -1

                do while (rangeOffs < rangeTo)
                    ! Calculate triangle area over three buckets
                    area = abs((pointAX - avgX)*(data(1 + rangeOffs) - pointAY) -&
                    &(pointAX - rangeOffs)*(avgY - pointAY))*0.5

                    if (area .gt. maxArea) then
                        maxArea = area
                        maxAreaPoint = data(1 + rangeOffs)
                        nextA = rangeOffs ! Next a is this b
                    end if

                    rangeOffs = rangeOffs + 1
                end do

                series(1 + sampledIndex) = maxAreaPoint ! Pick this point from the bucket
                sampledIndex = sampledIndex + 1
                a = nextA ! This a is the next a (chosen b)
            end block
        end do

        ! always add the last element
        series(1 + sampledIndex) = data(dataLength)
        sampledIndex = sampledIndex + 1

    end subroutine lttb_downsize

end module lttb


*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Program SNR
* to determine the SNR in the frequency space of an experimental image,
* for which the SNR is known (in direct space).
*
* INPUT:
*   Image experimentale
*   snr0 (scalaire) : rapport Signal/Bruit dans l'espace reel
*		 (signal moyen / variance)
*   alpha (scalaire) : fiabilite de snr0
*				alpha =	1 si snr0 est tres bien determine
*					2 valeur par defaut
*					3 si snr0 est tres mal determine.
* OUTPUT
*
*	- tableau SNR de nx*ny elements		*.SNR
*	- tableau du majorant du bruit en frequences spatiales  *.SIG
*	- TF de l'image experimentale	(partie reelle)		*.RFT
*	-	"	"	"	(partie imaginaire)	*.IFT
*
*	- recapitulation des parametres de SNR dans le fichier  *.SUM
*
*
* S. ROQUES - J. VIGNEAU				16 NOVEMRE 1989
* JLP (modif midas...)
* Version 02-05-91
*-------------------------------------------------------------------------------
	program d_snr
	implicit none
        real*4 snr0
	character*40 filein,filesum,filesnr,filesig, iftmre, iftmim
	integer*4 nx,ny,pntrin,pntrsnr,pntrsig,pntir, pntii
	integer*4 dpin,dptir,dptii,alpha,n,long,lu
	character name*20,comments*80
	integer*4 madrid(1)
	common /vmr/madrid
*
* Initialisation
	call jlp_begin
	call jlp_inquifmt
        write(6,102)
102     format('******* Program d_snr  Version 02-07-92')

*
* Saisie de snr0
* snr0 (scalaire) : rapport Signal/Bruit dans l'espace reel
*		 (signal moyen / variance)
	write(6,11)
11	format(' Mean SNR in the direct space ?')
	read(5,*) snr0
*
* Estimation de la fiabilite
	write(6,12)
12	format(' Reliability factor of SNR (1=good, 2=medium, 3=bad) ?')
	read(5,*) alpha
*
* Ouverture du fichier Image Experimentale
*
	write(6,*) ' Experimental image ?'
	filein=' '
	call jlp_vm_readimag(pntrin,nx,ny,filein,comments)
*
* Fabrication de la chaine de caracteres "NAME"
*
55	write(6,*) ' Generic name for the output ? (dot at the end)'
	read(5,10) name
	long=index(name,'.')-1
	if(long.le.0)goto 55
10	format(a)
*
* Ouverture du fichier <name>.SUM
*
	lu=1
	filesum = Name(:long)//'.SUM'
	open(1,file=filesum,status='unknown',access='sequential')
*
* Prenons quelques notes...
*
	write (lu,980)
980	format(/,' MODULE SNR',/,' ----------',/)
	write (lu,981) filein
981	format(' Image experimentale : ',A)
*
	write (lu,500) snr0,alpha
	write (6,500) snr0,alpha
500	format (' Rapport Signal/Bruit : ',e12.5,' criterium : ',i2)
*
	N = nx*ny
*
* on reserve de la place en REAL*4
	call jlp_getvm (PntrSnr,N*4)
	call jlp_getvm (PntrSig,N*4)
  	call jlp_getvm (PnTIR,N*4)
* pour partie reelle TF image
	call jlp_getvm (PnTII,N*4)
* pour partie imaginaire TF image

* on reserve de la place en REAL*8
* pour l'image experimentale
	call jlp_getvm (DpIn,N*8)
* pour partie reelle TF image
  	call jlp_getvm (DpTIR,N*8)
* pour partie imaginaire TF image
	call jlp_getvm (DpTII,N*8)
*
* passage en D.P.
	call S_to_D (madrid(PntrIn), madrid(DpIn), N)

* on charge l'image experimentale dans DpTIR
	call psi_to_phi(nx,ny,madrid(DpIn),madrid(DpTIR))
*
* et on calcule la T.F. de l'image experimentale
*
	call fourier1(madrid(dptir),madrid(dptii),nx,ny,1)
*
* on repasse en R*4 pour la TF de l'Image Experimentale
*
	call D_to_S (madrid(DpTIR), madrid(PnTIR), N)
	call D_to_S (madrid(DpTII), madrid(PnTII), N)
*
* appel de BRUIT
* computes the sigma in PntrSig
	call bruit(nx,ny,snr0,alpha,madrid(DpIn),madrid(PntrSig))
*
* Calcul du Rapport Signal/Bruit dans l'Espace des Frequences
*
	call rsb(madrid(PntrSig),madrid(PnTIR),
     1	madrid(PnTII),madrid(PntrSnr),N)
*
* Output of the images:
*
* Recenter image to get zero frequency at (1,1):
        call recentre(madrid(pntrsnr),madrid(pntrsnr),nx,ny,nx)
	fileSnr = Name(:long)//'.SNR'
	comments = 'SNR (in the Fourier domain) of:'//fileIn
	call jlp_writeimag(madrid(pntrsnr),nx,ny,nx,
     1	filesnr,comments)
*
* ouverture du fichier .SIG
*
* Recenter image to get zero frequency at (1,1):
        call recentre(madrid(pntrsig),madrid(pntrsig),nx,ny,nx)
	filesig = Name(:long)//'.SIG'
	comments = 'Sigma (in Fourier domain) of:'//fileIn
	call jlp_writeimag(madrid(pntrsig),nx,ny,nx,
     1	filesig,comments)
*
* ouverture des fichiers .RFT et .IFT (T.F. Image Experimentale)
*
* Recenter image to get zero frequency at (1,1):
        call recentre(madrid(pntir),madrid(pntir),nx,ny,nx)
	iftmre = Name(:long)//'.RFT'
	comments = ('F.T (real part) of: '//fileIn)
	call jlp_writeimag(madrid(pntir),nx,ny,nx,
     1	iftmre,comments)
*
* Recenter image to get zero frequency at (1,1):
        call recentre(madrid(pntii),madrid(pntii),nx,ny,nx)
	iftmim = Name(:long)//'.IFT'
	comments = ('F.T (imag. part) of: '//fileIn)
	call jlp_writeimag(madrid(pntii),nx,ny,nx,
     1	iftmim,comments)
*
	close(lu)
*
*
* Sortie normale
*
	call jlp_end
	stop
 	end
*
********************************************************************
* Subroutine BRUIT
*
* To determine the noise in the Fourier domain
* The trick is to solve in 5 iterations the equation:
*      PHI_experimental(i,j) = PHI_ideal(i,j) + noise(i,j)
* The noise is assumed to be consistent with the SNR value give by the user
* and following a gaussian law.
*
* Then the Fourier transform FT(noise)(u,v) is computed from the
* map noise(i,j),
*
* INPUT: NPIX, N, K, ALPHA, PHI
* OUTPUT: SIGMAI (noise of the input image)
*
* Note:  PHI is also modified in the loop
*
********************************************************************
	subroutine bruit (nx,ny,snr0,alpha,phi,sigmai)
	implicit none
	integer*4 nx,ny,N,alpha
	real*8	phi(nx,*),alk
	real*4	SigmaI(nx,*),snr0
	integer*4 DpBr, DpBi, dpsi, i, j
	integer*4 madrid(1)
	common /vmr/madrid
*
* Setting to zero SigmaI:
	do j=1,ny
	  do i=1,nx
	    SigmaI(i,j)=0.
	  end do
	end do

* on reserve de la memoire
*
	N = nx*ny
	alk = float(alpha)/snr0
* Tableau R*8 du Bruit (reel)
	call jlp_getvm (dpBr,N*8)
* Tableau R*8 du Bruit (imaginaire)
	call jlp_getvm (dpBi,N*8)
* working space for the noised image
	call jlp_getvm (dpsi,N*8)
*
* initialisation du generateur gaussien (NAG)
C	call G05CBF(0)
	call jlp_random_init(1)
*
* BOUCLE DE TRAVAIL
	do i = 1,5
*
* Computing the Gaussian noise:
* Br: gaussian noise corresponding to be present value of phi
* Bi is set to zero
	 call B_gauss (nx,ny,alk,phi,madrid(dpBr),madrid(dpBi))
*
* et on l'ajoute au signal experimental: psi=phi+Br
	 call add_bruit(nx,ny,phi,madrid(dpsi),madrid(dpBr))
*
* on calcule la TF du Bruit B
	 call fourier1(madrid(dpbr),madrid(dpbi),nx,ny,1)
*
* calcul de sigmai
* SigmaI=SigmaI+sqrt(Br**2+Bi**2)
	 call somme_i(nx,ny,sigmai,madrid(dpbr),madrid(dpbi))
*
* on remplace le signal initial par le signal bruite boucle phi = psi
	 call psi_to_phi(nx,ny,madrid(dpsi),phi)
*
	end do
*
* calcul definitif de SigmaI:
	do j = 1, ny
	 do i = 1, nx
	  sigmai(i,j) = sigmai(i,j) * 2./5.
	 end do
	end do
*
	return
	end
*
*-------------------------------------------------------------------------------
*
	subroutine b_gauss(nx,ny,alk,phi,br,bi)
*
* calcule le bruit gaussien B(i,j), real and imaginary
*
*IN: nx,ny,alk, phi
*OUT: Br, Bi
*
        real*4 work
	integer*4 nx,ny,i,j
	real*8	phi(nx,*),Sig_B,Br(nx,*), Bi(nx,*),alk
*
* calcul du bruit gaussien
*
	do j = 1,ny
	 do i = 1,nx
	  sig_B = phi(i,j)*alk
C NAG routine for random generator (G05DDF):
C	  Br(i,j) = G05DDF(phi(i,j),sig_B) - phi(i,j)
C jlp_random_gauss has a mean of 0. and a sigma of 1.
          call jlp_random_gauss(work)
	  Br(i,j) = work*sig_B
	  Bi(i,j) = 0.
	 end do
	end do
*
	return
	end
*
*-------------------------------------------------------------------------------
*
 	subroutine add_bruit (nx,ny,phi,psi,bruit)
*
	implicit none
	integer*4	nx,ny,i,j
	real*8	phi(nx,*),psi(nx,*),bruit(nx,*)
*
	do j = 1,ny
	 do i = 1,nx
	  Psi(i,j) = Phi(i,j) + Bruit(i,j)
	 end do
	end do
*
	return
	end
*
*-------------------------------------------------------------------------------
*
	subroutine somme_i (nx,ny,sigmai,b_real,b_imag)
*
	integer*4 nx,ny,i,j
	real*4	sigmai(nx,*),u,v
	real*8	b_real(nx,*),B_imag (nx,*)
*
	do j = 1, ny
	 do i = 1, nx
	  u = sngl (B_real(i,j) * B_real(i,j))
	  v = sngl (B_imag(i,j) * B_imag(i,j))
	  SigmaI(i,j) = SigmaI(i,j) + sqrt (u + v)
	 end do
	end do
*
	return
	end
*
*-------------------------------------------------------------------------------
*
	subroutine psi_to_phi(nx,ny,psi,phi)
*
	implicit none
	integer*4 nx,ny,i,j
	real*8	psi(nx,*),phi(nx,*)
*
	do j = 1, ny
	 do i = 1, nx
	  phi(i,j) = psi(i,j)
	 end do
	end do
*
	return
	end
*
*-------------------------------------------------------------------------------
*
 	subroutine rsb(sigma_i,rtf,ift,snr,n)
*
* Calcule le rapport Signal/Bruit
*
	implicit none
	integer*4 n,i
	real*4	sigma_i(n),rtf(n),ift(n),snr(n),module
*
	do i = 1,n
	 module = sqrt (rtf(i)*rtf(i) + ift(i)*ift(i))
	 snr(i) = module/sigma_i(i)
	end do
*
	return
	end
C-----------------------------------------------------------------------------
C	include 'd_utilities.for'


      MODULE module_mp_sbu_ylin
      USE module_wrf_error
      REAL, PARAMETER, PRIVATE :: RH = 1.0
      REAL, PARAMETER, PRIVATE :: xnor = 8.0e6
      REAL, PARAMETER, PRIVATE :: Nt_c = 10.E6
      REAL, PARAMETER, PRIVATE :: Rvapor = 461.5
      REAL, PARAMETER, PRIVATE :: oRv = 1./Rvapor
      REAL, PARAMETER, PRIVATE :: Rair = 287.04
      REAL, PARAMETER, PRIVATE :: Cp = 1004.0
      REAL, PARAMETER, PRIVATE :: grav = 9.81
      REAL, PARAMETER, PRIVATE :: rhowater = 1000.0
      REAL, PARAMETER, PRIVATE :: rhosnow = 100.0
      REAL, PARAMETER, PRIVATE :: SVP1=0.6112
      REAL, PARAMETER, PRIVATE :: SVP2=17.67
      REAL, PARAMETER, PRIVATE :: SVP3=29.65
      REAL, PARAMETER, PRIVATE :: SVPT0=273.15
      REAL, PARAMETER, PRIVATE :: EP1=Rvapor/Rair-1.
      REAL, PARAMETER, PRIVATE :: EP2=Rair/Rvapor
      REAL, PARAMETER, PRIVATE :: XLS = 2.834E6
      REAL, PARAMETER, PRIVATE :: XLV = 2.5E6
      REAL, PARAMETER, PRIVATE :: XLF = XLS - XLV
      REAL, PARAMETER, PRIVATE :: &
             qi0 = 1.0e-3, &
             xmi50 = 4.8e-10, xmi40 = 2.46e-10, &
             xni0 = 1.0e-2, xmnin = 1.05e-18, bni = 0.5, &
             di50 = 1.0e-4, xmi = 4.19e-13, &
             bv_r = 0.8, bv_i = 0.25, &
             o6 = 1./6., cdrag = 0.6, &
             avisc = 1.49628e-6, adiffwv = 8.7602e-5, &
             axka = 1.4132e3, cw = 4.187e3, ci = 2.093e3
CONTAINS
      SUBROUTINE sbu_ylin(th &
                      ,qv, ql, qr &
                      ,qi, qs, Ri3D &
                      ,rho, pii, p &
                      ,dt_in &
                      ,z,ht, dz8w &
                      ,RAINNC, RAINNCV &
                      ,ids,ide, jds,jde, kds,kde &
                      ,ims,ime, jms,jme, kms,kme &
                      ,its,ite, jts,jte, kts,kte &
                                                                   )
      IMPLICIT NONE
     INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , &
                                      ims,ime, jms,jme, kms,kme , &
                                      its,ite, jts,jte, kts,kte
     REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
        INTENT(INOUT) :: &
                                                              th, &
                                                              qv, &
                                                           qi,ql, &
                                                           qs,qr
     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
        INTENT(INOUT) :: Ri3D
     REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
        INTENT(IN ) :: &
                                                             rho, &
                                                             pii, &
                                                             z,p, &
                                                            dz8w
     REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: ht
     REAL, INTENT(IN ) :: dt_in
     REAL, DIMENSION( ims:ime , jms:jme ), &
        INTENT(INOUT) :: RAINNC, &
                                                          RAINNCV
     INTEGER :: min_q, max_q
     REAL, DIMENSION( its:ite , jts:jte ) &
                               :: rain, snow,ice
     REAL, DIMENSION( kts:kte ) :: qvz, qlz, qrz, &
                                                      qiz, qsz, qgz, &
                                                                thz, &
                                                        tothz, rhoz, &
                                                      orhoz, sqrhoz, &
                                                           prez, zz, &
                                                        dzw
     REAL, DIMENSION( kts:kte ) :: riz
     REAL :: dt, pptice, pptrain, pptsnow, pptgraul, rhoe_s
     INTEGER :: i,j,k
      dt=dt_in
      rhoe_s=1.29
      j_loop: DO j = jts, jte
      i_loop: DO i = its, ite
      DO k = kts, kte
       qvz(k)=qv(i,k,j)
       qlz(k)=ql(i,k,j)
       qrz(k)=qr(i,k,j)
       qiz(k)=qi(i,k,j)
       qsz(k)=qs(i,k,j)
       thz(k)=th(i,k,j)
       rhoz(k)=rho(i,k,j)
       orhoz(k)=1./rhoz(k)
       prez(k)=p(i,k,j)
       sqrhoz(k)=1.0
       tothz(k)=pii(i,k,j)
       zz(k)=z(i,k,j)
       dzw(k)=dz8w(i,k,j)
      END DO
      pptrain=0.
      pptsnow=0.
      pptice =0.
     CALL clphy1d_ylin( dt, qvz, qlz, qrz, qiz, qsz, &
                         thz, tothz, rhoz, orhoz, sqrhoz, &
                         prez, zz, dzw, ht(I,J), &
                         pptrain, pptsnow, pptice, &
                         kts, kte, i, j, riz )
      rain(i,j)= pptrain
      snow(i,j)= pptsnow
      ice(i,j) = pptice
      RAINNCV(i,j)= pptrain + pptsnow + pptice
      RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptice
      DO k = kts, kte
       qv(i,k,j)=qvz(k)
       ql(i,k,j)=qlz(k)
       qr(i,k,j)=qrz(k)
       th(i,k,j)=thz(k)
       qi(i,k,j)=qiz(k)
       qs(i,k,j)=qsz(k)
       ri3d(i,k,j)=riz(k)
      END DO
      ENDDO i_loop
      ENDDO j_loop
      END SUBROUTINE sbu_ylin
      SUBROUTINE clphy1d_ylin(dt, qvz, qlz, qrz, qiz, qsz, &
                      thz, tothz, rho, orho, sqrho, &
                      prez, zz, dzw, zsfc, pptrain, pptsnow,pptice, &
                      kts, kte, i, j,riz )
      IMPLICIT NONE
     INTEGER, INTENT(IN ) :: kts, kte, i, j
     REAL, DIMENSION( kts:kte ), &
           INTENT(INOUT) :: qvz, qlz, qrz, qiz, qsz, &
                                          thz
     REAL, DIMENSION( kts:kte ), &
           INTENT(IN ) :: tothz, rho, orho, sqrho, &
                                          prez, zz, dzw
     REAL, INTENT(INOUT) :: pptrain, pptsnow, pptice
     REAL, INTENT(IN ) :: dt, zsfc
     REAL :: obp4, bp3, bp5, bp6, odp4, &
                                            dp3, dp5, dp5o2
     REAL :: tmp, tmp0, tmp1, tmp2,tmp3, &
                                          tmp4, tmpa,tmpb,tmpc,tmpd,alpha1, &
                                          qic, abi,abr, abg, odtberg, &
                                          vti50,eiw,eri,esi,esr, esw, &
                                          erw,delrs,term0,term1, &
                                          Ap, Bp, &
                                          factor, tmp_r, tmp_s,tmp_g, &
                                          qlpqi, rsat, a1, a2, xnin
     REAL, DIMENSION( kts:kte ) :: oprez, tem, temcc, theiz, qswz, &
                                       qsiz, qvoqswz, qvoqsiz, qvzodt, &
                                       qlzodt, qizodt, qszodt, qrzodt
     REAL, DIMENSION( kts:kte ) :: psnow, psaut, psfw, psfi, praci, &
                                      piacr, psaci, psacw, psdep, pssub, &
                                      pracs, psacr, psmlt, psmltevp, &
                                      prain, praut, pracw, prevp, pvapor, &
                                      pclw, pladj, pcli, pimlt, pihom, &
                                      pidw, piadj, pgfr, &
                                      qschg
     REAL, DIMENSION( kts:kte ) :: qvsbar, rs0, viscmu, visc, diffwv, &
                                      schmidt, xka
     REAL, DIMENSION( kts:kte ):: ab_s,ab_r,ab_riming,lamc
     REAL, DIMENSION( kts:kte ):: cap_s
     REAL, PARAMETER :: vf1s = 0.65, vf2s = 0.44, vf1r =0.78 , vf2r = 0.31
     REAL, PARAMETER :: am_c1=0.004, am_c2= 6e-5, am_c3=0.15
     REAL, PARAMETER :: bm_c1=1.85, bm_c2= 0.003, bm_c3=1.25
     REAL, PARAMETER :: aa_c1=1.28, aa_c2= -0.012, aa_c3=-0.6
     REAL, PARAMETER :: ba_c1=1.5, ba_c2= 0.0075, ba_c3=0.5
     REAL, PARAMETER :: best_a=1.08 , best_b = 0.499
     REAL, DIMENSION(kts:kte):: am_s,bm_s,av_s,bv_s,Ri,N0_s,tmp_ss,lams
     REAL, DIMENSION(kts:kte):: aa_s,ba_s,tmp_sa
     REAL, PARAMETER :: mu_s=0.,mu_i=0.,mu_r=0.
     REAL :: tc0, disp, Dc_liu, eta, mu_c, R6c
     REAL, DIMENSION(kts:kte) :: Riz
     REAL, DIMENSION( kts:kte ) :: vtr, vts, &
                                      vtrold, vtsold, vtiold, &
                                      xlambdar, xlambdas, &
                                      olambdar, olambdas
     REAL :: episp0k, dtb, odtb, pi, pio4, &
                                      pio6, oxLf, xLvocp, xLfocp, av_r, &
                                      av_i, ocdrag, gambp4, gamdp4, &
                                      gam4pt5, Cpor, oxmi, gambp3, gamdp3,&
                                      gambp6, gam3pt5, gam2pt75, gambp5o2,&
                                      gamdp5o2, cwoxlf, ocp, xni50, es
     REAL :: qvmin=1.e-20
     REAL :: temc1,save1,save2,xni50mx
     INTEGER :: min_q, max_q, max_ri_k, k
     REAL :: max_ri
     REAL :: t_del_tv, del_tv, flux, fluxin, fluxout ,tmpqrz
     LOGICAL :: notlast
      mu_c = AMIN1(15., (1000.E6/Nt_c + 2.))
      R6c = 10.0E-6
      dtb=dt
      odtb=1./dtb
      pi =acos(-1.)
      pio4=acos(-1.)/4.
      pio6=acos(-1.)/6.
      ocp=1./cp
      oxLf=1./xLf
      xLvocp=xLv/cp
      xLfocp=xLf/cp
      Cpor=cp/Rair
      oxmi=1.0/xmi
      cwoxlf=cw/xlf
      av_r=2115.0*0.01**(1-bv_r)
      av_i=152.93*0.01**(1-bv_i)
      ocdrag=1./Cdrag
      episp0k=RH*ep2*1000.*svp1
      gambp4=ggamma(bv_r+4.)
      gamdp4=ggamma(bv_i+4.)
      gambp3=ggamma(bv_r+3.)
      gambp6=ggamma(bv_r+6)
      gambp5o2=ggamma((bv_r+5.)/2.)
      gamdp5o2=ggamma((bv_i+5.)/2.)
      obp4=1.0/(bv_r+4.0)
      bp3=bv_r+3.0
      bp5=bv_r+5.0
      bp6=bv_r+6.0
      odp4=1.0/(bv_i+4.0)
      dp3=bv_i+3.0
      dp5=bv_i+5.0
      dp5o2=0.5*(bv_i+5.0)
      do k=kts,kte
         oprez(k)=1./prez(k)
         qlz(k)=amax1( 0.0,qlz(k) )
         qiz(k)=amax1( 0.0,qiz(k) )
         qvz(k)=amax1( qvmin,qvz(k) )
         qsz(k)=amax1( 0.0,qsz(k) )
         qrz(k)=amax1( 0.0,qrz(k) )
         tem(k)=thz(k)*tothz(k)
         temcc(k)=tem(k)-273.15
         es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) )
         qswz(k)=ep2*es/(prez(k)-es)
         if (tem(k) .lt. 273.15 ) then
            es=1000.*svp1*exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) )
            qsiz(k)=ep2*es/(prez(k)-es)
            if (temcc(k) .lt. -40.0) qswz(k)=qsiz(k)
         else
            qsiz(k)=qswz(k)
         endif
         qvoqswz(k)=qvz(k)/qswz(k)
         qvoqsiz(k)=qvz(k)/qsiz(k)
         qvzodt(k)=amax1( 0.0,odtb*qvz(k) )
         qlzodt(k)=amax1( 0.0,odtb*qlz(k) )
         qizodt(k)=amax1( 0.0,odtb*qiz(k) )
         qszodt(k)=amax1( 0.0,odtb*qsz(k) )
         qrzodt(k)=amax1( 0.0,odtb*qrz(k) )
         theiz(k)=thz(k)+(xlvocp*qvz(k)-xlfocp*qiz(k))/tothz(k)
      enddo
      do k=kts,kte
         psnow(k)=0.0
         psaut(k)=0.0
         psfw(k)=0.0
         psfi(k)=0.0
         praci(k)=0.0
         piacr(k)=0.0
         psaci(k)=0.0
         psacw(k)=0.0
         psdep(k)=0.0
         pssub(k)=0.0
         pracs(k)=0.0
         psacr(k)=0.0
         psmlt(k)=0.0
         psmltevp(k)=0.0
         prain(k)=0.0
         praut(k)=0.0
         pracw(k)=0.0
         prevp(k)=0.0
         pgfr(k)=0.0
         pvapor(k)=0.0
         pclw(k)=0.0
         pladj(k)=0.0
         pcli(k)=0.0
         pimlt(k)=0.0
         pihom(k)=0.0
         pidw(k)=0.0
         piadj(k)=0.0
         qschg(k)=0.
      enddo
      DO k=kts,kte
        viscmu(k)=avisc*tem(k)**1.5/(tem(k)+120.0)
        visc(k)=viscmu(k)*orho(k)
        diffwv(k)=adiffwv*tem(k)**1.81*oprez(k)
        schmidt(k)=visc(k)/diffwv(k)
        xka(k)=axka*viscmu(k)
        rs0(k)=ep2*1000.*svp1/(prez(k)-1000.*svp1)
      END DO
       do k = kts, kte
         tc0 = tem(k)-273.15
        if (rho(k)*qlz(k) .gt. 1e-5 .AND. rho(k)*qsz(k) .gt. 1e-5) then
         Ri(k) = 1.0/(1.0+6e-5/(rho(k)**1.170*qlz(k)*qsz(k)**0.170))
        else
         Ri(k) = 0
        endif
       enddo
       max_ri_k = MAXLOC(Ri,dim=1)
       max_ri = MAXVAL(Ri)
       do k = kts, max_ri_k
         Ri(k) = max_ri
       enddo
      do k = kts, kte
         Ri(k) = AMAX1(0.,AMIN1(Ri(k),1.0))
         Riz(k) = Ri(k)
         cap_s(k)= 0.25*(1+Ri(k))
         tc0 = AMIN1(-0.1, tem(k)-273.15)
         N0_s(k) = amin1(2.0E8, 2.0E6*exp(-0.12*tc0))
         am_s(k) = am_c1+am_c2*tc0+am_c3*Ri(k)*Ri(k)
         am_s(k) = AMAX1(0.000023,am_s(k))
         bm_s(k) = bm_c1+bm_c2*tc0+bm_c3*Ri(k)
         bm_s(k) = AMIN1(bm_s(k),3.0)
         am_s(k) = 10**(2*bm_s(k)-3.0)*am_s(k)
         aa_s(k) = aa_c1 + aa_c2*tc0 + aa_c3*Ri(k)
         ba_s(k) = ba_c1 + ba_c2*tc0 + ba_c3*Ri(k)
         aa_s(k) = (1e-2)**(2.0-ba_s(k))*aa_s(k)
         av_s(k) = best_a*viscmu(k)*(2*grav*am_s(k)/rho(k)/aa_s(k)/(viscmu(k)**2))**best_b
         bv_s(k) = best_b*(bm_s(k)-ba_s(k)+2)-1
         tmp_ss(k)= bm_s(k)+mu_s+1
         tmp_sa(k)= ba_s(k)+mu_s+1
      enddo
      t_del_tv=0.
      del_tv=dtb
      notlast=.true.
      DO while (notlast)
       min_q=kte
       max_q=kts-1
      do k=kts,kte-1
         if (qrz(k) .gt. 1.0e-8) then
            min_q=min0(min_q,k)
            max_q=max0(max_q,k)
            tmp1=sqrt(pi*rhowater*xnor/rho(k)/qrz(k))
            tmp1=sqrt(tmp1)
            vtrold(k)=o6*av_r*gambp4*sqrho(k)/tmp1**bv_r
            if (k .eq. 1) then
               del_tv=amin1(del_tv,0.9*(zz(k)-zsfc)/vtrold(k))
            else
               del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtrold(k))
            endif
         else
            vtrold(k)=0.
         endif
      enddo
      if (max_q .ge. min_q) then
         t_del_tv=t_del_tv+del_tv
         if ( t_del_tv .ge. dtb ) then
              notlast=.false.
              del_tv=dtb+del_tv-t_del_tv
         endif
         fluxin=0.
         do k=max_q,min_q,-1
            fluxout=rho(k)*vtrold(k)*qrz(k)
            flux=(fluxin-fluxout)/rho(k)/dzw(k)
            tmpqrz=qrz(k)
            qrz(k)=qrz(k)+del_tv*flux
            fluxin=fluxout
         enddo
         if (min_q .eq. 1) then
            pptrain=pptrain+fluxin*del_tv
         else
            qrz(min_q-1)=qrz(min_q-1)+del_tv* &
                          fluxin/rho(min_q-1)/dzw(min_q-1)
         endif
      else
         notlast=.false.
      endif
      ENDDO
      t_del_tv=0.
      del_tv=dtb
      notlast=.true.
      DO while (notlast)
       min_q=kte
       max_q=kts-1
      do k=kts,kte-1
         if (qsz(k) .gt. 1.0e-8) then
            min_q=min0(min_q,k)
            max_q=max0(max_q,k)
            tmp1= (am_s(k)*N0_s(k)*ggamma(tmp_ss(k))*orho(k)/qsz(k))&
                   **(1./tmp_ss(k))
            vtsold(k)= sqrho(k)*av_s(k)*ggamma(bv_s(k)+tmp_ss(k))/ &
                      ggamma(tmp_ss(k))/(tmp1**bv_s(k))
            if (k .eq. 1) then
               del_tv=amin1(del_tv,0.9*(zz(k)-zsfc)/vtsold(k))
            else
               del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtsold(k))
            endif
         else
            vtsold(k)=0.
         endif
      enddo
      if (max_q .ge. min_q) then
         t_del_tv=t_del_tv+del_tv
         if ( t_del_tv .ge. dtb ) then
              notlast=.false.
              del_tv=dtb+del_tv-t_del_tv
         endif
         fluxin=0.
         do k=max_q,min_q,-1
            fluxout=rho(k)*vtsold(k)*qsz(k)
            flux=(fluxin-fluxout)/rho(k)/dzw(k)
            qsz(k)=qsz(k)+del_tv*flux
            qsz(k)=amax1(0.,qsz(k))
            fluxin=fluxout
         enddo
         if (min_q .eq. 1) then
            pptsnow=pptsnow+fluxin*del_tv
         else
            qsz(min_q-1)=qsz(min_q-1)+del_tv* &
                         fluxin/rho(min_q-1)/dzw(min_q-1)
         endif
      else
         notlast=.false.
      endif
      ENDDO
      t_del_tv=0.
      del_tv=dtb
      notlast=.true.
      DO while (notlast)
      min_q=kte
      max_q=kts-1
      do k=kts,kte-1
         if (qiz(k) .gt. 1.0e-8) then
            min_q=min0(min_q,k)
            max_q=max0(max_q,k)
            vtiold(k)= 3.29 * (rho(k)* qiz(k))** 0.16
            if (k .eq. 1) then
               del_tv=amin1(del_tv,0.9*(zz(k)-zsfc)/vtiold(k))
            else
               del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtiold(k))
            endif
         else
            vtiold(k)=0.
         endif
      enddo
      if (max_q .ge. min_q) then
         t_del_tv=t_del_tv+del_tv
         if ( t_del_tv .ge. dtb ) then
              notlast=.false.
              del_tv=dtb+del_tv-t_del_tv
         endif
         fluxin=0.
         do k=max_q,min_q,-1
            fluxout=rho(k)*vtiold(k)*qiz(k)
            flux=(fluxin-fluxout)/rho(k)/dzw(k)
            qiz(k)=qiz(k)+del_tv*flux
            qiz(k)=amax1(0.,qiz(k))
            fluxin=fluxout
         enddo
         if (min_q .eq. 1) then
            pptice=pptice+fluxin*del_tv
         else
            qiz(min_q-1)=qiz(min_q-1)+del_tv* &
                         fluxin/rho(min_q-1)/dzw(min_q-1)
         endif
      else
         notlast=.false.
      endif
      ENDDO
      DO 2000 k=kts,kte
         qvzodt(k)=amax1( 0.0,odtb*qvz(k) )
         qlzodt(k)=amax1( 0.0,odtb*qlz(k) )
         qizodt(k)=amax1( 0.0,odtb*qiz(k) )
         qszodt(k)=amax1( 0.0,odtb*qsz(k) )
         qrzodt(k)=amax1( 0.0,odtb*qrz(k) )
        tmp=qiz(k)+qlz(k)+qsz(k)+qrz(k)
        if( qvz(k)+qlz(k)+qiz(k) .lt. qsiz(k) &
            .and. tmp .eq. 0.0 ) go to 2000
        if (qrz(k) .gt. 1.0e-8) then
            tmp1=sqrt(pi*rhowater*xnor*orho(k)/qrz(k))
            xlambdar(k)=sqrt(tmp1)
            olambdar(k)=1.0/xlambdar(k)
            vtrold(k)=o6*av_r*gambp4*sqrho(k)*olambdar(k)**bv_r
        else
            vtrold(k)=0.
            olambdar(k)=0.
        endif
        if (qrz(k) .gt. 1.0e-8) then
            tmp1=sqrt(pi*rhowater*xnor*orho(k)/qrz(k))
            xlambdar(k)=sqrt(tmp1)
            olambdar(k)=1.0/xlambdar(k)
            vtr(k)=o6*av_r*gambp4*sqrho(k)*olambdar(k)**bv_r
        else
            vtr(k)=0.
            olambdar(k)=0.
        endif
        if (qsz(k) .gt. 1.0e-8) then
            tmp1= (am_s(k)*N0_s(k)*ggamma(tmp_ss(k))*orho(k)/qsz(k))&
                   **(1./tmp_ss(k))
            olambdas(k)=1.0/tmp1
            vtsold(k)= sqrho(k)*av_s(k)*ggamma(bv_s(k)+tmp_ss(k))/ &
                      ggamma(tmp_ss(k))/(tmp1**bv_s(k))
        else
            vtsold(k)=0.
            olambdas(k)=0.
        endif
        if (qsz(k) .gt. 1.0e-8) then
             tmp1= (am_s(k)*N0_s(k)*ggamma(tmp_ss(k))*orho(k)/qsz(k))&
                   **(1./tmp_ss(k))
             olambdas(k)=1.0/tmp1
             vts(k)= sqrho(k)*av_s(k)*ggamma(bv_s(k)+tmp_ss(k))/ &
                      ggamma(tmp_ss(k))/(tmp1**bv_s(k))
        else
            vts(k)=0.
            olambdas(k)=0.
        endif
        if (tem(k) .lt. 273.15) then
           alpha1=1.0e-3*exp( 0.025*temcc(k) )
           if(temcc(k) .lt. -20.0) then
             tmp1=-7.6+4.0*exp( -0.2443e-3*(abs(temcc(k))-20)**2.455 )
             qic=1.0e-3*exp(tmp1)*orho(k)
           else
             qic=qi0
           end if
           tmp1=odtb*(qiz(k)-qic)*(1.0-exp(-alpha1*dtb))
           psaut(k)=amax1( 0.0,tmp1 )
          if( qlz(k) .gt. 1.0e-10 ) then
            temc1=amax1(-30.99,temcc(k))
            a1=parama1( temc1 )
            a2=parama2( temc1 )
            tmp1=1.0-a2
            a1=a1*0.001**tmp1
            odtberg=(a1*tmp1)/(xmi50**tmp1-xmi40**tmp1)
            vti50=av_i*di50**bv_i*sqrho(k)
            eiw=1.0
            save1=a1*xmi50**a2
            save2=0.25*pi*eiw*rho(k)*di50*di50*vti50
            tmp2=( save1 + save2*qlz(k) )
            xni50mx=qlzodt(k)/tmp2
            xni50=qiz(k)*( 1.0-exp(-dtb*odtberg) )/xmi50
            xni50=amin1(xni50,xni50mx)
            tmp3=odtb*tmp2/save2*( 1.0-exp(-save2*xni50*dtb) )
            psfw(k)=amin1( tmp3,qlzodt(k) )
            tmp1=xni50*xmi50-psfw(k)
            psfi(k)=amin1(tmp1,qizodt(k))
          end if
          if(qrz(k) .le. 0.0) go to 1000
          eri=1.0
          save1=pio4*eri*xnor*av_r*sqrho(k)
          tmp1=save1*gambp3*olambdar(k)**bp3
          praci(k)=qizodt(k)*( 1.0-exp(-tmp1*dtb) )
          tmp2=qiz(k)*save1*rho(k)*pio6*rhowater*gambp6*oxmi* &
                   olambdar(k)**bp6
          piacr(k)=amin1( tmp2,qrzodt(k) )
1000 continue
          if(qsz(k) .le. 0.0) go to 1200
          esi=exp( 0.025*temcc(k) )
          save1 = aa_s(k)*sqrho(k)*N0_s(k)* &
                  ggamma(bv_s(k)+tmp_sa(k))*olambdas(k)**(bv_s(k)+tmp_sa(k))
          tmp1=esi*save1
          psaci(k)=qizodt(k)*( 1.0-exp(-tmp1*dtb) )
          esw=1.0
          tmp1=esw*save1
          psacw(k)=qlzodt(K)*( 1.0-exp(-tmp1*dtb) )
          tmpa=rvapor*xka(k)*tem(k)*tem(k)
          tmpb=xls*xls*rho(k)*qsiz(k)*diffwv(k)
          tmpc=tmpa*qsiz(k)*diffwv(k)
          abi=4.0*pi*cap_s(k)*(qvoqsiz(k)-1.0)*tmpc/(tmpa+tmpb)
          tmp1=av_s(k)*sqrho(k)*olambdas(k)**(5+bv_s(k)+2*mu_s)/visc(k)
          tmp2= abi*N0_s(k)*( vf1s*olambdas(k)*olambdas(k)+ &
                vf2s*schmidt(k)**0.33334* &
                ggamma(2.5+0.5*bv_s(k)+mu_s)*sqrt(tmp1) )
          tmp3=odtb*( qvz(k)-qsiz(k) )
          if( tmp2 .le. 0.0) then
            tmp2=amax1( tmp2,tmp3)
            pssub(k)=amax1( tmp2,-qszodt(k) )
            psdep(k)=0.0
          else
            psdep(k)=amin1( tmp2,tmp3 )
            pssub(k)=0.0
          end if
          if(qrz(k) .le. 0.0) go to 1200
          esr=1.0
          tmpa=olambdar(k)*olambdar(k)
          tmpb=olambdas(k)*olambdas(k)
          tmpc=olambdar(k)*olambdas(k)
          tmp1=pi*pi*esr*xnor*N0_s(k)*abs( vtr(k)-vts(k) )*orho(k)
          tmp2=tmpb*tmpb*olambdar(k)*(5.0*tmpb+2.0*tmpc+0.5*tmpa)
          tmp3=tmp1*rhosnow*tmp2
          pracs(k)=amin1( tmp3,qszodt(k) )
          pracs(k)=0.0
          tmp3=tmpa*tmpa*olambdas(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb)
          tmp4=tmp1*rhowater*tmp3
          psacr(k)=amin1( tmp4,qrzodt(k) )
            if (qrz(k) .gt. 1.e-8 ) then
               Bp=100.
               Ap=0.66
               tmp1=olambdar(k)*olambdar(k)*olambdar(k)
               tmp2=20.*pi*pi*Bp*xnor*rhowater*orho(k)* &
                    (exp(-Ap*temcc(k))-1.0)*tmp1*tmp1*olambdar(k)
               pgfr(k)=amin1( tmp2,qrzodt(k) )
            else
               pgfr(k)=0
            endif
1200 continue
        else
         if (qsz(k) .le. 0.0) go to 1400
            esw=1.0
            save1 =aa_s(k)*sqrho(k)*N0_s(k)* &
                   ggamma(bv_s(k)+tmp_sa(k))*olambdas(k)**(bv_s(k)+tmp_sa(k))
            tmp1=esw*save1
            psacw(k)=qlzodt(k)*( 1.0-exp(-tmp1*dtb) )
            esr=1.0
            tmpa=olambdar(k)*olambdar(k)
            tmpb=olambdas(k)*olambdas(k)
            tmpc=olambdar(k)*olambdas(k)
            tmp1=pi*pi*esr*xnor*N0_s(k)*abs( vtr(k)-vts(k) )*orho(k)
            tmp2=tmpa*tmpa*olambdas(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb)
            tmp3=tmp1*rhowater*tmp2
            psacr(k)=amin1( tmp3,qrzodt(k) )
            delrs=rs0(k)-qvz(k)
            term1=2.0*pi*orho(k)*( xlv*diffwv(k)*rho(k)*delrs- &
                  xka(k)*temcc(k) )
            tmp1= av_s(k)*sqrho(k)*olambdas(k)**(5+bv_s(k)+2*mu_s)/visc(k)
            tmp2= N0_s(k)*( vf1s*olambdas(k)*olambdas(k)+ &
                  vf2s*schmidt(k)**0.33334* &
                  ggamma(2.5+0.5*bv_s(k)+mu_s)*sqrt(tmp1) )
            tmp3=term1*oxlf*tmp2-cwoxlf*temcc(k)*( psacw(k)+psacr(k) )
            tmp4=amin1(0.0,tmp3)
            psmlt(k)=amax1( tmp4,-qszodt(k) )
            tmpa=rvapor*xka(k)*tem(k)*tem(k)
            tmpb=xlv*xlv*rho(k)*qswz(k)*diffwv(k)
            tmpc=tmpa*qswz(k)*diffwv(k)
            tmpd=amin1( 0.0,(qvoqswz(k)-0.90)*qswz(k)*odtb )
            abr=2.0*pi*(qvoqswz(k)-0.90)*tmpc/(tmpa+tmpb)
            tmp1=av_s(k)*sqrho(k)*olambdas(k)**(5+bv_s(k)+2*mu_s)/visc(k)
            tmp2= N0_s(k)*( vf1s*olambdas(k)*olambdas(k)+ &
                  vf2s*schmidt(k)**0.33334* &
                  ggamma(2.5+0.5*bv_s(k)+mu_s)*sqrt(tmp1) )
            tmp3=amin1(0.0,tmp2)
            tmp3=amax1( tmp3,tmpd )
            psmltevp(k)=amax1( tmp3,-qszodt(k) )
1400 continue
        end if
       if (qlz(k) .gt. 1e-6) then
           lamc(k) = (Nt_c*rhowater*pi*ggamma(4.+mu_c)/(6.*rho(k)*qlz(k))/ &
                    ggamma(1+mu_c))**0.3333
           Dc_liu = (ggamma(6+1+mu_c)/ggamma(1+mu_c))**(1./6.)/lamc(k)
           if (Dc_liu .gt. R6c) then
             disp = 1./(mu_c+1.)
             eta = (0.75/pi/(1e-3*rhowater))**2*1.9e11*((1+3*disp)*(1+4*disp)*&
                   (1+5*disp)/(1+disp)/(1+2*disp))
             praut(k) = eta*(1e-3*rho(k)*qlz(k))**3/(1e-6*Nt_c)
             praut(k) = praut(k)/(1e-3*rho(k))
           else
            praut(k) = 0.0
           endif
       else
         praut(k) = 0.0
       endif
        erw=1.0
        tmp1=pio4*erw*xnor*av_r*sqrho(k)* &
             gambp3*olambdar(k)**bp3
        pracw(k)=qlzodt(k)*( 1.0-exp(-tmp1*dtb) )
         tmpa=rvapor*xka(k)*tem(k)*tem(k)
         tmpb=xlv*xlv*rho(k)*qswz(k)*diffwv(k)
         tmpc=tmpa*qswz(k)*diffwv(k)
         tmpd=amin1(0.0,(qvoqswz(k)-0.90)*qswz(k)*odtb)
         abr=2.0*pi*(qvoqswz(k)-0.90)*tmpc/(tmpa+tmpb)
         tmp1=av_r*sqrho(k)*olambdar(k)**bp5/visc(k)
         tmp2=abr*xnor*( vf1r*olambdar(k)*olambdar(k)+ &
              vf2r*schmidt(k)**0.33334*gambp5o2*sqrt(tmp1) )
         tmp3=amin1( 0.0,tmp2 )
         tmp3=amax1( tmp3,tmpd )
         prevp(k)=amax1( tmp3,-qrzodt(k) )
      if ( temcc(k) .lt. 0.0) then
           tmp=psdep(k)
           if ( tmp .gt. qvzodt(k) ) then
              factor=qvzodt(k)/tmp
              psdep(k)=psdep(k)*factor
           end if
           tmp=praut(k)+psacw(k)+psfw(k)+pracw(k)
           if ( tmp .gt. qlzodt(k) ) then
              factor=qlzodt(k)/tmp
              praut(k)=praut(k)*factor
              psacw(k)=psacw(k)*factor
              psfw(k)=psfw(k)*factor
              pracw(k)=pracw(k)*factor
           end if
           tmp=psaut(k)+psaci(k)+praci(k)+psfi(k)
           if (tmp .gt. qizodt(k) ) then
              factor=qizodt(k)/tmp
              psaut(k)=psaut(k)*factor
              psaci(k)=psaci(k)*factor
              praci(k)=praci(k)*factor
              psfi(k)=psfi(k)*factor
           endif
          tmp_r=piacr(k)+psacr(k)-prevp(k)-praut(k)-pracw(k)+pgfr(k)
          if (tmp_r .gt. qrzodt(k) ) then
             factor=qrzodt(k)/tmp_r
             piacr(k)=piacr(k)*factor
             psacr(k)=psacr(k)*factor
             prevp(k)=prevp(k)*factor
             pgfr(k)=pgfr(k)*factor
          endif
          tmp_s=-pssub(k)-(psaut(k)+psaci(k)+psacw(k)+psfw(k)+pgfr(k)+ &
                 psfi(k)+praci(k)+piacr(k)+ &
                 psdep(k)+psacr(k)-pracs(k))
          if ( tmp_s .gt. qszodt(k) ) then
             factor=qszodt(k)/tmp_s
             pssub(k)=pssub(k)*factor
             Pracs(k)=Pracs(k)*factor
          endif
         pvapor(k)=-pssub(k)-psdep(k)-prevp(k)
         qvz(k)=amax1( qvmin,qvz(k)+dtb*pvapor(k) )
         pclw(k)=-praut(k)-pracw(k)-psacw(k)-psfw(k)
         qlz(k)=amax1( 0.0,qlz(k)+dtb*pclw(k) )
         pcli(k)=-psaut(k)-psfi(k)-psaci(k)-praci(k)
         qiz(k)=amax1( 0.0,qiz(k)+dtb*pcli(k) )
         tmp_r=piacr(k)+psacr(k)-prevp(k)-praut(k)-pracw(k)+pgfr(k)-pracs(k)
         prain(k)=-tmp_r
         qrz(k)=amax1( 0.0,qrz(k)+dtb*prain(k) )
         tmp_s=-pssub(k)-(psaut(k)+psaci(k)+psacw(k)+psfw(k)+pgfr(k)+ &
                psfi(k)+praci(k)+piacr(k)+ &
                psdep(k)+psacr(k)-pracs(k))
         psnow(k)=-tmp_s
         qsz(k)=amax1( 0.0,qsz(k)+dtb*psnow(k) )
         qschg(k)=qschg(k)+psnow(k)
         qschg(k)=psnow(k)
         tmp=ocp/tothz(k)*xLf*qschg(k)
         theiz(k)=theiz(k)+dtb*tmp
         thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k)
         tem(k)=thz(k)*tothz(k)
         temcc(k)=tem(k)-273.15
         if( temcc(k) .lt. -40.0 ) qswz(k)=qsiz(k)
         qlpqi=qlz(k)+qiz(k)
         if ( qlpqi .eq. 0.0 ) then
            qvsbar(k)=qsiz(k)
         else
            qvsbar(k)=( qiz(k)*qsiz(k)+qlz(k)*qswz(k) )/qlpqi
         endif
      else
          tmp=praut(k)+psacw(k)+pracw(k)
          if ( tmp .gt. qlzodt(k) ) then
             factor=qlzodt(k)/tmp
             praut(k)=praut(k)*factor
             psacw(k)=psacw(k)*factor
             pracw(k)=pracw(k)*factor
          end if
          tmp_s=-(psmlt(k)+psmltevp(k))
          if (tmp_s .gt. qszodt(k) ) then
             factor=qszodt(k)/tmp_s
             psmlt(k)=psmlt(k)*factor
             psmltevp(k)=psmltevp(k)*factor
          endif
          tmp_r=-prevp(k)-(praut(k)+pracw(k)+psacw(k)-psmlt(k))
          if (tmp_r .gt. qrzodt(k) ) then
             factor=qrzodt(k)/tmp_r
             prevp(k)=prevp(k)*factor
          endif
          pvapor(k)=-psmltevp(k)-prevp(k)
          qvz(k)=amax1( qvmin,qvz(k)+dtb*pvapor(k))
          pclw(k)=-praut(k)-pracw(k)-psacw(k)
          qlz(k)=amax1( 0.0,qlz(k)+dtb*pclw(k) )
          pcli(k)=0.0
          qiz(k)=amax1( 0.0,qiz(k)+dtb*pcli(k) )
          tmp_r=-prevp(k)-(praut(k)+pracw(k)+psacw(k)-psmlt(k))
          prain(k)=-tmp_r
          tmpqrz=qrz(k)
          qrz(k)=amax1( 0.0,qrz(k)+dtb*prain(k) )
          tmp_s=-(psmlt(k)+psmltevp(k))
          psnow(k)=-tmp_s
          qsz(k)=amax1( 0.0,qsz(k)+dtb*psnow(k) )
          qschg(k)=psnow(k)
          tmp=ocp/tothz(k)*xLf*qschg(k)
          theiz(k)=theiz(k)+dtb*tmp
          thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k)
          tem(k)=thz(k)*tothz(k)
          temcc(k)=tem(k)-273.15
          es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) )
          qswz(k)=ep2*es/(prez(k)-es)
          qsiz(k)=qswz(k)
          qvsbar(k)=qswz(k)
      end if
         rsat=1.0
         if( qvz(k)+qlz(k)+qiz(k) .lt. rsat*qvsbar(k) ) then
          qvz(k)=qvz(k)+qlz(k)+qiz(k)
          qlz(k)=0.0
          qiz(k)=0.0
          thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k)
          tem(k)=thz(k)*tothz(k)
          temcc(k)=tem(k)-273.15
          go to 1800
        else
          pladj(k)=qlz(k)
          piadj(k)=qiz(k)
        CALL satadj(qvz, qlz, qiz, prez, theiz, thz, tothz, kts, kte, &
                    k, xLvocp, xLfocp, episp0k, EP2,SVP1,SVP2,SVP3,SVPT0)
          pladj(k)=odtb*(qlz(k)-pladj(k))
          piadj(k)=odtb*(qiz(k)-piadj(k))
          pclw(k)=pclw(k)+pladj(k)
          pcli(k)=pcli(k)+piadj(k)
          pvapor(k)=pvapor(k)-( pladj(k)+piadj(k) )
          thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k)
          tem(k)=thz(k)*tothz(k)
          temcc(k)=tem(k)-273.15
          es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) )
          qswz(k)=ep2*es/(prez(k)-es)
          if (tem(k) .lt. 273.15 ) then
             es=1000.*svp1*exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) )
             qsiz(k)=ep2*es/(prez(k)-es)
             if (temcc(k) .lt. -40.0) qswz(k)=qsiz(k)
          else
             qsiz(k)=qswz(k)
          endif
          qlpqi=qlz(k)+qiz(k)
          if ( qlpqi .eq. 0.0 ) then
             qvsbar(k)=qsiz(k)
          else
             qvsbar(k)=( qiz(k)*qsiz(k)+qlz(k)*qswz(k) )/qlpqi
          endif
        end if
        qlpqi=qlz(k)+qiz(k)
        if(qlpqi .le. 0.0) go to 1800
        if(temcc(k) .lt. -40.0) pihom(k)=qlz(k)*odtb
        if(temcc(k) .gt. 0.0) pimlt(k)=qiz(k)*odtb
        if(temcc(k) .lt. 0.0 .and. temcc(k) .gt. -31.0) then
          a1=parama1( temcc(k) )
          a2=parama2( temcc(k) )
          a1=a1*0.001**(1.0-a2)
          xnin=xni0*exp(-bni*temcc(k))
          pidw(k)=xnin*orho(k)*(a1*xmnin**a2)
        end if
        pcli(k)=pcli(k)+pihom(k)-pimlt(k)+pidw(k)
        pclw(k)=pclw(k)-pihom(k)+pimlt(k)-pidw(k)
        qlz(k)=amax1( 0.0,qlz(k)+dtb*(-pihom(k)+pimlt(k)-pidw(k)) )
        qiz(k)=amax1( 0.0,qiz(k)+dtb*(pihom(k)-pimlt(k)+pidw(k)) )
        CALL satadj(qvz, qlz, qiz, prez, theiz, thz, tothz, kts, kte, &
                    k, xLvocp, xLfocp, episp0k ,EP2,SVP1,SVP2,SVP3,SVPT0)
        thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k)
        tem(k)=thz(k)*tothz(k)
        temcc(k)=tem(k)-273.15
        es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) )
        qswz(k)=ep2*es/(prez(k)-es)
        if (tem(k) .lt. 273.15 ) then
           es=1000.*svp1*exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) )
           qsiz(k)=ep2*es/(prez(k)-es)
           if (temcc(k) .lt. -40.0) qswz(k)=qsiz(k)
        else
           qsiz(k)=qswz(k)
        endif
        qlpqi=qlz(k)+qiz(k)
        if ( qlpqi .eq. 0.0 ) then
           qvsbar(k)=qsiz(k)
        else
           qvsbar(k)=( qiz(k)*qsiz(k)+qlz(k)*qswz(k) )/qlpqi
        endif
1800 continue
2000 continue
      do k=kts+1,kte
         if ( qvz(k) .lt. qvmin ) then
            qlz(k)=0.0
            qiz(k)=0.0
            qvz(k)=amax1( qvmin,qvz(k)+qlz(k)+qiz(k) )
         end if
      enddo
      END SUBROUTINE clphy1d_ylin
      SUBROUTINE satadj(qvz, qlz, qiz, prez, theiz, thz, tothz, &
                        kts, kte, k, xLvocp, xLfocp, episp0k, EP2,SVP1,SVP2,SVP3,SVPT0)
      IMPLICIT NONE
     INTEGER, INTENT(IN ) :: kts, kte, k
     REAL, DIMENSION( kts:kte ), &
                       INTENT(INOUT) :: qvz, qlz, qiz
     REAL, DIMENSION( kts:kte ), &
                       INTENT(IN ) :: prez, theiz, tothz
     REAL, INTENT(IN ) :: xLvocp, xLfocp, episp0k
     REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0
     INTEGER :: n
     REAL, DIMENSION( kts:kte ) :: thz, tem, temcc, qsiz, &
                                        qswz, qvsbar
     REAL :: qsat, qlpqi, ratql, t0, t1, tmp1, ratqi, tsat, absft, &
             denom1, denom2, dqvsbar, ftsat, dftsat, qpz,es
      thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k)
      tem(k)=tothz(k)*thz(k)
      if (tem(k) .gt. 273.15) then
         es=1000.*svp1*exp( svp2*(tem(k)-svpt0)/(tem(k)-svp3) )
         qsat=ep2*es/(prez(k)-es)
      else
        qsat=episp0k/prez(k)* &
             exp( 21.8745584*(tem(k)-273.15)/(tem(k)-7.66) )
      end if
      qpz=qvz(k)+qlz(k)+qiz(k)
      if (qpz .lt. qsat) then
         qvz(k)=qpz
         qiz(k)=0.0
         qlz(k)=0.0
         go to 400
      end if
      qlpqi=qlz(k)+qiz(k)
      if( qlpqi .ge. 1.0e-5) then
        ratql=qlz(k)/qlpqi
        ratqi=qiz(k)/qlpqi
      else
        t0=273.15
        t1=248.15
        tmp1=( t0-tem(k) )/(t0-t1)
        tmp1=amin1(1.0,tmp1)
        tmp1=amax1(0.0,tmp1)
        ratqi=tmp1
        ratql=1.0-tmp1
      end if
      tsat=tem(k)
      absft=1.0
      do 200 n=1,20
         denom1=1.0/(tsat-svp3)
         denom2=1.0/(tsat-7.66)
         es=1000.*svp1*exp( svp2*denom1*(tsat-svpt0) )
         qswz(k)=ep2*es/(prez(k)-es)
         if (tem(k) .lt. 273.15) then
            es=1000.*svp1*exp( 21.8745584*denom2*(tsat-273.15) )
            qsiz(k)=ep2*es/(prez(k)-es)
            if (tem(k) .lt. 233.15) qswz(k)=qsiz(k)
         else
            qsiz(k)=qswz(k)
         endif
         qvsbar(k)=ratql*qswz(k)+ratqi*qsiz(k)
         if( absft .lt. 0.01 ) go to 300
         dqvsbar=ratql*qswz(k)*svp2*243.5*denom1*denom1+ &
                 ratqi*qsiz(k)*21.8745584*265.5*denom2*denom2
         ftsat=tsat+(xlvocp+ratqi*xlfocp)*qvsbar(k)- &
               tothz(k)*theiz(k)-xlfocp*ratqi*(qvz(k)+qlz(k)+qiz(k))
         dftsat=1.0+(xlvocp+ratqi*xlfocp)*dqvsbar
         tsat=tsat-ftsat/dftsat
         absft=abs(ftsat)
200 continue
9020 format(1x,'point can not converge, absft,n=',e12.5,i5)
300 continue
      if( qpz .gt. qvsbar(k) ) then
        qvz(k)=qvsbar(k)
        qiz(k)=ratqi*( qpz-qvz(k) )
        qlz(k)=ratql*( qpz-qvz(k) )
      else
        qvz(k)=qpz
        qiz(k)=0.0
        qlz(k)=0.0
      end if
400 continue
      END SUBROUTINE satadj
     REAL FUNCTION parama1(temp)
      IMPLICIT NONE
      REAL, INTENT (IN ) :: temp
      REAL, DIMENSION(32) :: a1
      INTEGER :: i1, i1p1
      REAL :: ratio
      data a1/0.100e-10,0.7939e-7,0.7841e-6,0.3369e-5,0.4336e-5, &
              0.5285e-5,0.3728e-5,0.1852e-5,0.2991e-6,0.4248e-6, &
              0.7434e-6,0.1812e-5,0.4394e-5,0.9145e-5,0.1725e-4, &
              0.3348e-4,0.1725e-4,0.9175e-5,0.4412e-5,0.2252e-5, &
              0.9115e-6,0.4876e-6,0.3473e-6,0.4758e-6,0.6306e-6, &
              0.8573e-6,0.7868e-6,0.7192e-6,0.6513e-6,0.5956e-6, &
              0.5333e-6,0.4834e-6/
      i1=int(-temp)+1
      i1p1=i1+1
      ratio=-(temp)-float(i1-1)
      parama1=a1(i1)+ratio*( a1(i1p1)-a1(i1) )
      END FUNCTION parama1
      REAL FUNCTION parama2(temp)
      IMPLICIT NONE
      REAL, INTENT (IN ) :: temp
      REAL, DIMENSION(32) :: a2
      INTEGER :: i1, i1p1
      REAL :: ratio
      data a2/0.0100,0.4006,0.4831,0.5320,0.5307,0.5319,0.5249, &
              0.4888,0.3849,0.4047,0.4318,0.4771,0.5183,0.5463, &
              0.5651,0.5813,0.5655,0.5478,0.5203,0.4906,0.4447, &
              0.4126,0.3960,0.4149,0.4320,0.4506,0.4483,0.4460, &
              0.4433,0.4413,0.4382,0.4361/
      i1=int(-temp)+1
      i1p1=i1+1
      ratio=-(temp)-float(i1-1)
      parama2=a2(i1)+ratio*( a2(i1p1)-a2(i1) )
      END FUNCTION parama2
      REAL FUNCTION RSLF(P,T)
      IMPLICIT NONE
      REAL, INTENT(IN):: P, T
      REAL:: ESL,X
      REAL, PARAMETER:: C0= .611583699E03
      REAL, PARAMETER:: C1= .444606896E02
      REAL, PARAMETER:: C2= .143177157E01
      REAL, PARAMETER:: C3= .264224321E-1
      REAL, PARAMETER:: C4= .299291081E-3
      REAL, PARAMETER:: C5= .203154182E-5
      REAL, PARAMETER:: C6= .702620698E-8
      REAL, PARAMETER:: C7= .379534310E-11
      REAL, PARAMETER:: C8=-.321582393E-13
      X=MAX(-80.,T-273.16)
      ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
      RSLF=.622*ESL/(P-ESL)
      END FUNCTION RSLF
      REAL FUNCTION RSIF(P,T)
      IMPLICIT NONE
      REAL, INTENT(IN):: P, T
      REAL:: ESI,X
      REAL, PARAMETER:: C0= .609868993E03
      REAL, PARAMETER:: C1= .499320233E02
      REAL, PARAMETER:: C2= .184672631E01
      REAL, PARAMETER:: C3= .402737184E-1
      REAL, PARAMETER:: C4= .565392987E-3
      REAL, PARAMETER:: C5= .521693933E-5
      REAL, PARAMETER:: C6= .307839583E-7
      REAL, PARAMETER:: C7= .105785160E-9
      REAL, PARAMETER:: C8= .161444444E-12
      X=MAX(-80.,T-273.16)
      ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
      RSIF=.622*ESI/(P-ESI)
      END FUNCTION RSIF
      REAL FUNCTION ggamma(X)
      IMPLICIT NONE
      REAL, INTENT(IN ) :: x
      REAL, DIMENSION(8) :: B
      INTEGER ::j, K1
      REAL ::PF, G1TO2 ,TEMP
      DATA B/-.577191652,.988205891,-.897056937,.918206857, &
             -.756704078,.482199394,-.193527818,.035868343/
      PF=1.
      TEMP=X
      DO 10 J=1,200
      IF (TEMP .LE. 2) GO TO 20
      TEMP=TEMP-1.
   10 PF=PF*TEMP
   20 G1TO2=1.
      TEMP=TEMP - 1.
      DO 30 K1=1,8
   30 G1TO2=G1TO2 + B(K1)*TEMP**K1
      ggamma=PF*G1TO2
      END FUNCTION ggamma
      END MODULE module_mp_sbu_ylin


!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!* See https://llvm.org/LICENSE.txt for license information.
!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
!   forall containing derived type assignments

type junk
 integer m1,m2(2),m3
end type

integer result(20), expect(20)
data expect/10,20,30,40, 20,40,60,80, 30,60,90,120, &
40,80,120,160, 50,100,150,200 /

type(junk):: j(5)

forall(i=1:5)
 j(i)%m1 = 10*i
 j(i)%m2(1) = 20*i
 j(i)%m2(2) = 30*i
 j(i)%m3 = 40*i
endforall

do i = 1,5
 result(i*4-3) = j(i)%m1
 result(i*4-2) = j(i)%m2(1)
 result(i*4-1) = j(i)%m2(2)
 result(i*4-0) = j(i)%m3
enddo

!print *,result
call check( result, expect, 20 )

end


! Copyright (c) 2016, Donald E. Willcox
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! * Redistributions of source code must retain the above copyright notice, this
!   list of conditions and the following disclaimer.
!
! * Redistributions in binary form must reproduce the above copyright notice,
!   this list of conditions and the following disclaimer in the documentation
!   and/or other materials provided with the distribution.
!
! * Neither the name of gauss-jordan-solver nor the names of its
!   contributors may be used to endorse or promote products derived from
!   this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

subroutine get_nonzero_dp(x)
  implicit none

  double precision :: x
  x = 0.0d0
  do while ( x == 0.0d0)
     call RANDOM_NUMBER(x)
  end do
end subroutine get_nonzero_dp

subroutine random_solve(which_iters, which_solver, N, niter, Asparse, aresid)
  use gauss_jordan_module, only : gauss_jordan_solve
  implicit none

  integer, intent(in) :: N, which_solver, which_iters, niter
  integer, dimension(N,N), intent(in) :: Asparse
  double precision, dimension(N), intent(out) :: aresid
  double precision, dimension(N,N) :: A, Acopy
  double precision, dimension(N) :: xsolv, xtrue, b
  integer, dimension(N) :: IPIV
  integer :: i, j, INFO

  do i = 1, N
     call get_nonzero_dp(xtrue(i))
     do j = 1, N
        if ( Asparse(i, j) == 1 ) then
           call get_nonzero_dp(A(i, j))
        else
           A(i, j) = 0.0d0
        end if
     end do
  end do
  b = MATMUL(A, xtrue)
  if ( which_solver == 1 ) then
     !     write(*,*) 'Using gauss-jordan solver'
     if ( which_iters == 2 ) then
        do i = 1, niter
           Acopy = A
           call gauss_jordan_solve(Acopy, xsolv, b)
        end do
     elseif ( which_iters == 1 ) then
        call gauss_jordan_solve(A, xsolv, b)
     end if
  elseif ( which_solver == 2) then
     !     write(*,*) 'Using LAPACK DGESV'
     if ( which_iters == 2 ) then
        do i = 1, niter
           xsolv = b
           Acopy = A
           call DGESV(N, 1, Acopy, N, IPIV, xsolv, N, INFO)
        end do
     elseif ( which_iters == 1 ) then
        xsolv = b
        call DGESV(N, 1, A, N, IPIV, xsolv, N, INFO)
     end if
     if ( INFO /= 0 ) then
        write(*,*) 'LAPACK could not find a solution!'
        stop
     end if
  else
     write(*,*) 'NO SOLVER SPECIFIED. ENTER 1 or 2.'
     stop
  end if
  aresid = abs(xtrue - xsolv)
end subroutine random_solve

program test_gj_solve
  ! Takes 4 command-line arguments:
  ! 1: Name of sparsity structure file to read
  ! 2: Number of random matrix equations Ax=b to solve
  ! 3: Which solver to use (1 = gauss jordan, 2 = LAPACK DGESV)
  ! 4: Matrix generation (1 = resample matrix every iteration,
  !                       2 = randomly sample matrix only once)

  implicit none

  character(LEN=50) :: sparsity_file
  character(LEN=50) :: str_num_iters, str_solver_choice, str_iters_choice
  integer :: N, unit, niter, which_solver, which_iters
  integer, dimension(:,:), allocatable :: Asparsity
  double precision, dimension(:,:), allocatable :: aresid
  double precision, dimension(:), allocatable :: arave, arstd
  double precision :: scratch
  integer :: i, j
  logical :: invalid_arguments

  ! Initialize the random number generator
  call init_random_seed()

  invalid_arguments = .false.

  ! Read the first command-line argument as the sparsity file name
  call GET_COMMAND_ARGUMENT(1, sparsity_file)

  if (len(trim(sparsity_file)) .eq. 0) then
     invalid_arguments = .true.
  end if

  ! Read the second command-line argument as the number of random solutions to run
  call GET_COMMAND_ARGUMENT(2, str_num_iters)
  read(str_num_iters, '(I50)') niter
  if ( niter <= 0 ) then
     invalid_arguments = .true.
  end if
  ! Read the third command-line argument as the selection for which solver to use
  ! if which_solver = 1, then use the nonzero gauss-jordan solver
  ! if which_solver = 2, then use LAPACK DGESV
  call GET_COMMAND_ARGUMENT(3, str_solver_choice)
  read(str_solver_choice, '(I50)') which_solver
  if ( .not. ( which_solver == 1 .or. which_solver == 2 )) then
     invalid_arguments = .true.
  end if
  if ( which_solver == 1 ) then
     write(*,*) 'Using Nonzero Gauss-Jordan Solver'
  elseif ( which_solver == 2 ) then
     write(*,*) 'Using LAPACK DGESV Solver'
  end if
  ! Read the fourth command-line argument as the selection for which randomization to use
  ! if which_iters = 1, then solve different randomized matrix systems
  ! if which_iters = 2, then solve the same randomized matrix system over and over
  call GET_COMMAND_ARGUMENT(4, str_iters_choice)
  read(str_iters_choice, '(I50)') which_iters
  if ( .not. ( which_iters == 1 .or. which_iters == 2 )) then
     invalid_arguments = .true.
  end if

  if (invalid_arguments) then
     print *, "test_gj_solve takes 4 command-line arguments:"
     print *, "  1: Name of sparsity structure file to read"
     print *, "  2: Number of iterations of matrix equations Ax=b to solve"
     print *, "  3: Which solver to use (1 = gauss jordan, 2 = LAPACK DGESV)"
     print *, "  4: Matrix generation (1 = resample random matrix every iteration,"
     print *, "                        2 = randomly sample matrix only once)"
     stop
  end if

  ! Read the sparsity file and set up sparsity matrix
  open(newunit=unit, file=sparsity_file)
  ! Get size of matrix
  read(unit,*) N
  allocate( Asparsity(N, N) )
  ! Read sparsity matrix in row-major order
  read(unit,*) Asparsity
  ! Transpose matrix into column-major format for Fortran
  Asparsity = TRANSPOSE(Asparsity)
  close(unit=unit)

  ! Test solver with a random matrix equation using this sparsity
  allocate( arave(N) )
  allocate( arstd(N) )
  if ( which_iters == 1 ) then
     allocate( aresid(N, niter) )
     do i = 1, niter
        call random_solve(which_iters, which_solver, N, niter, Asparsity, aresid(:, i))
     end do
     ! Get statistics for residuals
     do i = 1, N
        arave(i) = SUM(aresid(i, :))/dble(niter)
        scratch = 0.0d0
        do j = 1, niter
           scratch = scratch + ((aresid(i, j) - arave(i))**2)/dble(niter)
        end do
        arstd(i) = sqrt(scratch)
     end do
     ! Print statistics for absolute values of residuals
     write(*,*) niter, ' Random Systems Solved'
     write(*,*) 'Residual Average +/- StdDev for solutions of the system Ax=b.'
     do i = 1, N
        write(*,*) 'x(', i, '): ', arave(i), ' +/- ', arstd(i)
     end do
  elseif ( which_iters == 2 ) then
     allocate( aresid(N, 1) )
     call random_solve(which_iters, which_solver, N, niter, Asparsity, aresid(:, 1))
     ! Print residuals
     write(*,*) niter, ' Solution Iterations of a Random System'
     write(*,*) 'Residuals for solution of the system Ax=b.'
     do i = 1, N
        write(*,*) 'x(', i, '): ', aresid(i, 1)
     end do
  end if

  ! Cleanup memory
  deallocate( aresid )
  deallocate( arave )
  deallocate( arstd )
  deallocate( Asparsity )
end program test_gj_solve


PROGRAM main

  USE mo_kind, ONLY: i4, dp, sp
  use mo_ansi_colors, only: color, c_red, c_green
  USE mo_sort, ONLY: sort, sort_index

  IMPLICIT NONE

  REAL(dp),    DIMENSION(10) :: dat1, dat2
  REAL(sp),    DIMENSION(10) :: sat1, sat2
  INTEGER(i4), DIMENSION(10) :: ii

  LOGICAL :: isgood

  Write(*,*) ''
  Write(*,*) 'Test mo_sort.f90'

  ! Double precision
  dat1 = (/ 1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)
  isgood = .true.
  dat2 = dat1(10:1:-1)
  call sort(dat2)
  if (any(abs(dat1-dat2) > 0._dp)) isgood = .false.
  dat2 = dat1(10:1:-1)
  ii = sort_index(dat2)
  if (any(abs(dat1-dat2(ii)) > 0._dp)) isgood = .false.

  if (isgood) then
     write(*,*) 'mo_sort double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_sort double precision ', color('failed!', c_red)
  endif

  ! Single precision
  sat1 = (/ 1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)
  isgood = .true.
  sat2 = sat1(10:1:-1)
  call sort(sat2)
  if (any(abs(sat1-sat2) > 0._sp)) isgood = .false.
  sat2 = sat1(10:1:-1)
  ii = sort_index(sat2)
  if (any(abs(sat1-sat2(ii)) > 0._sp)) isgood = .false.

  if (isgood) then
     write(*,*) 'mo_sort single precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_sort single precision ', color('failed!', c_red)
  endif

END PROGRAM main


************************************************************************
* The MIT License (MIT)
*
* Copyright (c) 2016 Daniel Everhart
*
* Permission is hereby granted, free of charge, to any person obtaining
* a copy of this software and associated documentation files (the
* "Software"), to deal in the Software without restriction, including
* without limitation the rights to use, copy, modify, merge, publish,
* distribute, sublicense, and/or sell copies of the Software, and to
* permit persons to whom the Software is furnished to do so, subject
* to the following conditions:
*
* The above copyright notice and this permission notice shall be
* included in all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
* IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
* CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
* TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
* SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*
************************************************************************
* FMTDP: Format a DOUBLE PRECISION value to fit in buffer with max
* precision.
************************************************************************
*  VAL * I * DOUBLE PRECISION value to format
*   WD * I * Desired field width
* BUFF * O * Buffer in which to write formatted value
************************************************************************
* Error will result in writing '*' characters to the buffer.
* The format for real numbers is:
*                           Fw.d
*                           Ew.dEe
*                           Gw.d
* W is the total width, D is the number of digits to the right of
* the floating point.  This subroutine starts with the total width,
* and figures out how much width is allowaded for D.
************************************************************************
* W    * 'w' of Gw.d format descriptor
* D    * 'd' of Gw.d format descriptor
* E    * 'e' of Ew.dEe format descriptor
* IOS  * IOSTAT for read/write operations
* FIOS * IOSTAT for reading FVAL from TBUF
* EIOS * IOSTAT for reading EVAL from TBUF
* FSTR * Fw.d format string
* ESTR * Ew.dEe format string
* TBUF * Temporary buffer for writing formated real value
* FVAL * Value read from buffer based of Fw.d format string
* EVAL * Value read from buffer based of Ew.d format string
************************************************************************
      SUBROUTINE FMTDP(VAL, BUFF, WD)
      IMPLICIT NONE
      DOUBLE PRECISION VAL
      CHARACTER*(*) BUFF
      INTEGER WD
*
      INTEGER W, D, E, POW10
      INTEGER IOS, FIOS, EIOS
      CHARACTER*16 FSTR, ESTR
      CHARACTER*32 TBUF
      DOUBLE PRECISION FVAL, EVAL
*
      FVAL = 0D0
      EVAL = 0D0
      W = MIN(LEN(BUFF), WD)
      DO 100 D = 1, W
  100 BUFF(D:D) = '*'
*
** Special case when value is 0D0
*
      IF (VAL.EQ.0D0) THEN
        IF (WD.EQ.1) THEN
          BUFF = '.'
        ELSEIF (WD.EQ.2) THEN
          BUFF = '.0'
        ELSE
          WRITE(FSTR,920, IOSTAT=IOS) W, W-2
          WRITE(BUFF, FSTR, IOSTAT=IOS) VAL
        ENDIF
        RETURN
      ENDIF
*
** Attempt to write value using Fw.d
*
      D = W
      TBUF = '*'
      DO 200 WHILE (TBUF(1:1).EQ.'*')
      D = D - 1
      IF (D.LT.0) EXIT
      WRITE(FSTR,920, IOSTAT=IOS) W, D
  200 WRITE(TBUF, FSTR, IOSTAT=IOS) VAL
      READ(TBUF,*,IOSTAT=FIOS) FVAL
*
** Attempt to write value using Ew.d
*
      D = W
      E = INT(LOG(REAL(INT(LOG(VAL)))))
      TBUF = '*'
      DO 300 WHILE (TBUF(1:1).EQ.'*')
      D = D - 1
      IF (D.LT.0) EXIT
      WRITE(ESTR,930, IOSTAT=IOS) W, D, E
  300 WRITE(TBUF, ESTR, IOSTAT=IOS) VAL
      READ(TBUF,*,IOSTAT=EIOS) EVAL
*
** Determine which method yields a value which is nearest the
** original value.
*
      IF(FIOS.NE.0) THEN
        WRITE(BUFF, ESTR, IOSTAT=IOS) VAL
      ELSE
        IF (ABS(EVAL-VAL).GE.ABS(FVAL-VAL)) THEN
          WRITE(BUFF, FSTR, IOSTAT=IOS) VAL
        ELSE
          WRITE(BUFF, ESTR, IOSTAT=IOS) VAL
        END IF
      END IF
*
      RETURN
  920 FORMAT('(F'I2'.'I2')')
  930 FORMAT('(E'I2'.'I2'E'I1')')
      END SUBROUTINE FMTDP


program test_dairybi
  use types, only: dp
  use constants, only: i_
  use utils, only: assert
  use special, only: dairybi
  implicit none

  ! check a few value against the ones computed with SciPy:
  integer :: i
  real(dp), parameter :: eps = 1d-14
  real(dp), parameter :: xReal(5) = [1.1_dp, 3.0_dp, 10.0_dp, 2.1_dp, 5.5_dp]
  real(dp), parameter :: xImag(5) = [0.1_dp, -0.3_dp, 2.5_dp, -1.8_dp, 2.0_dp]

  complex(dp), parameter :: correctResults(5) = [(1.052054289401527_dp, 0.143160933990618_dp),&
       (19.320522812668564_dp, -11.875745094026080_dp), (-118511775.639862522482872_dp, 872764689.469506621360779_dp),&
       (-3.142357771618667_dp, -0.870151474552866_dp), (296.691403478894586_dp, -3076.714959917741453_dp)]

  do i = 1,5
     call assert(abs(dairybi(xReal(i)+i_*xImag(i)) - correctResults(i)) < eps)
  end do

end program test_dairybi