C---A Fortran code for the maximum likelihood estimation (MLE) for the  Bernoulli ERG model of a bipartite network
C---Bipartite network: Example bank firm network
C-- Input Parameters....
C--N: No of firms, M: No of banks, L: Total number of links, ni= number
C of parameter to be estimated. ni=1 for bernouli model
C-- nconf: No of ensamble avarage------
C---iseeds are the intital random number seed....

C---output will be written in "theta_Bernoulli.dat". col1: no of
C-- ensamble avg, col2: no of converge ensamble avg, col3: estimated
C----parameter theta, col4: <theta^2>, col5: std of theta

      implicit double precision(a-h,o-z)
      parameter (N=10,M=5,L=17,kmax=M,kmax1=N)
      parameter (ni=1,nconf=1000,maxrun1=7+3*ni)
      parameter (iseed2=1449942249,iseed1=76438761,iseed3=387489371)
      integer  Pneb(N,kmax),Pdegree(N),Pneb1(N,kmax),Pdegree1(N)
      integer  Adegree(M),Adegree1(M),Aneb(M,kmax1),Aneb1(M,kmax1)
      dimension theta(ni),z(ni),u(ni),zo(ni),zsum(ni),zsqsum(ni)
      dimension  D1inv(ni),f3(ni),thetasum(ni),thetasqsum(ni)
      dimension zf(ni)

      iran1=iseed1
      iran2=iseed2
      iran3=iseed3

c----initialize degree array
      Pdegree=0
      Adegree=0

C-----------Read the linklist data of observed network and creat the degree array and neigbour list of each node--------------------------------------
C----Link list data does not cotain any parallel edges-------
C---'linklist.dat' is a two columns data file. col1: firm index{1,N}, colo2: bank index {1,M}-------
      open(1,file="linklist.dat")
      do 11 iL=1,L
      read(1,*)i,j
      Pdegree(i)=Pdegree(i)+1
      Adegree(j)=Adegree(j)+1
      Pneb(i,Pdegree(i))=j
      Aneb(j,Adegree(j))=i
 11   enddo
      close(1)

C----------Calculate network statistics in observed network zo----
C----Expected number of links is the only known observable zo(1)
      zo(1)=L

      write(*,*)dlog(zo(1)/(M*N-zo(1)))

C-------Make a copy of the observed network---------------------------------------
      Pneb1=Pneb
      Pdegree1=Pdegree
      Aneb1=Aneb
      Adegree1=Adegree
      z=zo

C-----Initialization-------

      thetasum=0.0d00
      thetasqsum=0.0d00
      kount=0
      zf=0.0d00

      do 5000 iconf=1,nconf

c-------Phase 1------------------------------------------

c--To determine Scaling Matrix D0 and initial parameters

      theta=0.0d00
      zsum=0.d00
      zsqsum=0.0d00
      a=0.10d00

      do irun1=1,maxrun1

C-----Starting from the observed network generate maxrun1=(7+3*ni) new network using MCMC------
      Pneb=Pneb1
      Pdegree=Pdegree1
      Aneb=Aneb1
      Adegree=Adegree1
      z=zo

      call MCMC(N,M,ni,Pneb,Pdegree,Aneb,Adegree,z,theta,
     .iran1,iran2,iran3)
c,Fr2,Fr5,Fr7,Fr9,Br1,Br2,Br3,Br4)

C-----average stattics of the generated network------------------
      do ir=1,ni
      zsum(ir)=zsum(ir)+z(ir)
      zsqsum(ir)=zsqsum(ir)+z(ir)*z(ir)
      enddo

      enddo

      count=maxrun1

C----Scaling matrix D1-------------------
      do ir=1,ni
      av=zsum(ir)/count
      avsq=zsqsum(ir)/count
      D1=avsq-av*av
      D1inv(ir)=1.0d00/D1
      theta(ir)=theta(ir)-a*D1inv(ir)*(av-zo(ir))
      enddo
C------------Phase 2---------------------------

      itime=0
      isub=0

 17   it=0
      isub=isub+1
      a=0.20d00
      zsum=0.d00
      zsqsum=0.0d00
      count=0.0d00

 18   it=it+1
      imt=(7+ni)*(2**(1.333d00*it))+200
      do 1000 im=1,imt
C------Start from the observed network-----------------
      itime=itime+1
      Pneb=Pneb1
      Pdegree=Pdegree1
      Aneb=Aneb1
      Adegree=Adegree1
      z=zo
C-----Generating one graph and statistics Z from the model

      call MCMC(N,M,ni,Pneb,Pdegree,Aneb,Adegree,z,theta,
     .iran1,iran2,iran3)
c---------------------------------
C------Optimization: Newton Raphson minimization-----
      do ir=1,ni
      theta(ir)=theta(ir)-a*D1inv(ir)*(z(ir)-zo(ir))
      enddo

      if(it.gt.4)then
      do ir=1,ni
      zsum(ir)=zsum(ir)+z(ir)
      zsqsum(ir)=zsqsum(ir)+z(ir)*z(ir)
      enddo

      count=count+1
      ic=0
      do ir=1,ni
      f1=zsum(ir)/count
      f2=dsqrt(zsqsum(ir)/count-f1*f1)
      f3(ir)=(f1-zo(ir))/f2
      if(dabs(f3(ir)).gt.0.1d00)ic=1
      enddo

      if(ic.lt.1)then
      kount=kount+1

      open(1,file='theta_Bernoulli.dat')
      do ir=1,ni

      thetasum(ir)=thetasum(ir)+theta(ir)
      thetasqsum(ir)=thetasqsum(ir)+theta(ir)*theta(ir)
      std=dsqrt((thetasqsum(ir)/kount)-((thetasum(ir)/kount)
     .*(thetasum(ir)/kount)))

      zf(ir)=zf(ir)+zsum(ir)/count

      write(1,*)iconf,kount,thetasum(ir)/kount,thetasqsum(ir)/kount,std
      enddo
      close(1)
      goto 5000
      endif
      endif

 1000 enddo
       a=a/2.0d00
       if(isub.gt.35.and.it.eq.6)goto 5000
       if(it.lt.6)goto 18
       if(it.gt.5)goto 17

 5000 enddo
      end

      subroutine MCMC(N,M,ni,Pneb,Pdegree,Aneb,Adegree,z,theta,
     .iran1,iran2,iran3)
      implicit double precision(a-h,o-z)
C----set maxrun 10*N*M---------
      parameter (maxrun=10*10*5)
      integer  Pneb(N,M),Pdegree(N)
      integer  Adegree(M),Aneb(M,N)
      dimension u(ni),theta(ni),z(ni)
      dimension Fr1(N),Fr2(N),Fr3(N),Fr4(N),Fr5(N)
      dimension Fr6(N),Fr7(N),Fr8(N),Fr9(N)
      dimension Br1(M),Br2(M),Br3(M),Br4(M),Br5(M)

      do 3000 irun=1,maxrun

 20   i=1+ranf1(iran1)*N
      if(i.gt.N)goto 20
 21   j=1+ranf2(iran2)*M
      if(j.gt.M)goto 21

      kj=Adegree(j)
      ki=Pdegree(i)
      do k=1,ki
      if(Pneb(i,k).eq.j)goto 333
      enddo
C-----calculation of change statistics if link added------
      u=0.0d00
      u(1)=1

      Hr=0.0d00
      do ir=1,ni
      Hr=Hr+theta(ir)*u(ir)
      enddo

      if(ranf3(iran3).lt.dexp(Hr))then
      do ir=1,ni
      z(ir)=z(ir)+u(ir)
      enddo
      Pdegree(i)=Pdegree(i)+1
      Adegree(j)=Adegree(j)+1
      Pneb(i,Pdegree(i))=j
      Aneb(j,Adegree(j))=i
c------------------------------------
      endif
      goto 50
C-----calculation of change statistics if link deleted------

 333  u=0.0d00
      u(1)=-1.0d00

      Hr=0.0d00
      do ir=1,ni
      Hr=Hr+theta(ir)*u(ir)
      enddo

      if(ranf3(iran3).lt.dexp(Hr))then
      isuc=isuc+1
      do ir=1,ni
      z(ir)=z(ir)+u(ir)
      enddo
      i1=k
      do k=1,kj
      if(Aneb(j,k).eq.i)goto 444
      enddo
 444  j1=k
      ineb=Pneb(i,ki)
      Pdegree(i)=Pdegree(i)-1
      if(j.ne.ineb)Pneb(i,i1)=ineb

      jneb=Aneb(j,kj)
      Adegree(j)=Adegree(j)-1
      if(i.ne.jneb)Aneb(j,j1)=jneb

c------------------------------------

      endif

 50   continue

 3000 enddo

      end

*----------------------------------------------------------------------------------
*     RANDOM NUMBER GENERATOR 1
*----------------------------------------------------------------------------------

      double precision function ranf1(iran1)
      iran1=iran1*1566083941
      if(iran1.lt.0)iran1=iran1+2147483647+1
      iran1=iran1*1566083941
      if(iran1.lt.0)iran1=iran1+2147483647+1
      ranf1=iran1*4.6566128752458D-10
      return
      end

*----------------------------------------------------------------------------------
*     RANDOM NUMBER GENERATOR 2
*----------------------------------------------------------------------------------

      double precision function ranf2(iran2)
      iran2=iran2*1664525
      if(iran2.lt.0)iran2=iran2+2147483647+1
      iran2=iran2*1664525
      if(iran2.lt.0)iran2=iran2+2147483647+1
      ranf2=iran2*4.6566128752458D-10
      return
      end

*----------------------------------------------------------------------------------
*     RANDOM NUMBER GENERATOR 3
*----------------------------------------------------------------------------------

      double precision function ranf3(iran3)
      iran3=iran3*16807
      if(iran3.lt.0)iran3=iran3+2147483647+1
      iran3=iran3*16807
      if(iran3.lt.0)iran3=iran3+2147483647+1
      ranf3=iran3*4.6566128752458D-10
      return
      end


!* Copyright (c) 1998, NVIDIA CORPORATION.  All rights reserved.
!*
!* Licensed under the Apache License, Version 2.0 (the "License");
!* you may not use this file except in compliance with the License.
!* You may obtain a copy of the License at
!*
!*     http://www.apache.org/licenses/LICENSE-2.0
!*
!* Unless required by applicable law or agreed to in writing, software
!* distributed under the License is distributed on an "AS IS" BASIS,
!* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!* See the License for the specific language governing permissions and
!* limitations under the License.
!
!   arrays of derived type

program p
type test
 integer,dimension(:,:),pointer:: mem
end type
integer results(18), expect(18)
integer l1,l2,u1,u2
data expect /1,3,1,3,36,69, 2,3,2,3,45,56, 3,5,3,5,102,135/

type(test)::a(3)

allocate(a(1)%mem(1:3,1:3))
allocate(a(2)%mem(2:3,2:3))
allocate(a(3)%mem(3:5,3:5))

do k = lbound(a,1),ubound(a,1)
 do i = lbound(a(k)%mem,1), ubound(a(k)%mem,1)
  do j = lbound(a(k)%mem,2), ubound(a(k)%mem,2)
   a(k)%mem(i,j) = i*10+j
  enddo
 enddo
enddo

kk = 0
do k = lbound(a,1),ubound(a,1)
 l1 = lbound(a(k)%mem,1)
 u1 = ubound(a(k)%mem,1)
 l2 = lbound(a(k)%mem,2)
 u2 = ubound(a(k)%mem,2)
 kk = kk + 1
 results(kk) = l1
 kk = kk + 1
 results(kk) = u1
 kk = kk + 1
 results(kk) = l2
 kk = kk + 1
 results(kk) = u2
 kk = kk + 1
 results(kk) = sum(a(k)%mem(l1,:))
 kk = kk + 1
 results(kk) = sum(a(k)%mem(:,u2))
enddo

!print *,results
call check( results, expect, 18)
end


program test

    use mpi

    use quadrature, only: trapezoid
    use functions, only: f, fevals_proc, k

    implicit none
    real(kind=8) :: a,b,int_true, int_approx

    integer :: proc_num, num_procs, ierr, n, fevals_total
    integer, dimension(MPI_STATUS_SIZE) :: status

    call MPI_INIT(ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, proc_num, ierr)

    ! All processes set these values so we don't have to broadcast:
    k = 1.d3   ! functions module variable
    a = 0.d0
    b = 2.d0
    int_true = (b-a) + (b**4 - a**4) / 4.d0 - (1.d0/k) * (cos(k*b) - cos(k*a))
    n = 1000

    ! Each process keeps track of number of fevals:
    fevals_proc = 0

    if (proc_num==0) then
        print '("Using ",i3," processes")', num_procs
        print '("true integral: ", es22.14)', int_true
        print *, " "  ! blank line
        endif

    call MPI_BARRIER(MPI_COMM_WORLD,ierr) ! wait for process 0 to print

    ! Note: In this version all processes call trap and repeat the
    !       same work, so each should get the same answer.
    int_approx = trapezoid(f,a,b,n)
    print '("Process ",i3," with n = ",i8," computes int_approx = ",es22.14)', &
            proc_num,n, int_approx

    call MPI_BARRIER(MPI_COMM_WORLD,ierr) ! wait for all process to print

    ! print the number of function evaluations by each thread:
    print '("fevals by Process ",i2,": ",i13)',  proc_num, fevals_proc

    call MPI_BARRIER(MPI_COMM_WORLD,ierr) ! wait for all process to print

    if (proc_num==0) then
        ! This is wrong -- part of homework is to fix this:
        fevals_total = 0   !! need to fix
        print '("Total number of fevals: ",i10)', fevals_total
        endif

    call MPI_FINALIZE(ierr)

end program test


SUBROUTINE ZGEEQU_F95( A, R, C, ROWCND, COLCND, AMAX, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: ERINFO
   USE F77_LAPACK, ONLY: GEEQU_F77 => LA_GEEQU
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
   REAL(WP), INTENT( OUT ), OPTIONAL :: AMAX, COLCND, ROWCND
!  .. ARRAY ARGUMENTS ..
   COMPLEX(WP), INTENT( IN ) :: A( :, : )
   REAL(WP), INTENT( OUT ) :: C( : ), R( : )
!---------------------------------------------------------------------
!
! Purpose
! =======
!
! LA_GEEQU computes row and column scalings intended to equilibrate a
! rectangle matrix A and reduce its condition number.  R returns the
! row scale factors and C the column scale factors, chosen to try to
! make the largest entry in each row and column of the matrix B with
! elements B(i,j) = R(i) A(i,j) C(j) have absolute value 1.
!
! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
! number and BIGNUM = largest safe number. Use of these scaling
! factors is not guaranteed to reduce the condition number of A but
! works well in practice.
!
! Arguments
! =========
!
! SUBROUTINE LA_GEEQU ( A, R, C, ROWCND, COLCND, AMAX, INFO )
!    <type>(<wp>), INTENT(IN) :: A(:,:)
!    REAL(<wp>), INTENT( OUT ) :: R(:), C(:)
!    REAL(<wp>), INTENT( OUT ), OPTIONAL :: ROWCND, COLCND, AMAX
!    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!    where
!    <type> ::= REAL | COMPLEX
!    <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! ====================
!
! A       (input) either REAL or COMPLEX array, shape (:,:).
!         The matrix A, whose equilibration factors are to be computed.
!
! R       (output) REAL array, shape (:), size(R) == size(A,1).
!         If INFO = 0 or INFO > size(A,1), R contains the row
!         scale factors for A.
!
! C       (output) REAL array, shape (:), size(C) == size(A,2).
!         If INFO = 0, C contains the column scale factors for A.
!
! ROWCND  Optional (output) REAL.
!         If INFO = 0 or INFO > size(A,1), ROWCND contains the ratio
!         of the smallest R(i) to the largest R(i).  If ROWCND >= 0.1
!         and AMAX is neither too large nor too small, it is not worth
!         scaling by R.
!
! COLCND  Optional (output) REAL.
!         If INFO = 0, COLCND contains the ratio of the smallest
!         C(i) to the largest C(i).  If COLCND >= 0.1, it is not
!         worth scaling by C.
!
! AMAX    Optional (output) REAL.
!         Absolute value of largest matrix element.  If AMAX is very
!         close to overflow or very close to underflow, the matrix
!         should be scaled.
!
! INFO    Optional (output) INTEGER
!         If INFO is present
!            = 0:  successful exit
!            < 0:  if INFO = -k, the k-th argument had an illegal value
!            > 0:  if INFO = k,  and k is
!                  <= M:  the k-th row of A is exactly zero
!                  >  M:  the (k-M)-th column of A is exactly zero
!                         where M = size(A,1)
!         If INFO is not present and an error occurs, then the program is
!            terminated with an error message.
!
!-------------------------------------------------------------------------
!  .. PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GEEQU'
!  .. LOCAL SCALARS ..
   INTEGER :: LINFO, M, N
   REAL(WP) :: LAMAX, LCOLCND, LROWCND
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC SIZE, MAX
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; M = SIZE(A, 1); N = SIZE(A, 2)
!  .. TEST THE ARGUMENTS
   IF ( SIZE(R) /= M ) THEN; LINFO = -2
   ELSE IF ( SIZE(C) /= N ) THEN; LINFO = -3
   ELSE
!     .. CALL LAPACK77 ROUTINE
      CALL GEEQU_F77( M, N, A, MAX(1,M), R, C, LROWCND, LCOLCND, LAMAX, LINFO )
      IF( PRESENT( ROWCND ) ) ROWCND = LROWCND
      IF( PRESENT( COLCND ) ) COLCND = LCOLCND
      IF( PRESENT( AMAX ) ) AMAX = LAMAX
   END IF
   CALL ERINFO( LINFO, SRNAME, INFO )
END SUBROUTINE ZGEEQU_F95


MODULE RadiationFieldsUtilitiesModule

  USE KindModule, ONLY: &
    DP
  USE ProgramHeaderModule, ONLY: &
    nDOF

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: CellAverage

CONTAINS

  PURE REAL(DP) FUNCTION CellAverage( uR, VJ )

    REAL(DP), DIMENSION(1:nDOF), INTENT(in) :: uR, VJ

!!$    CellAverage &
!!$      = DOT_PRODUCT( WeightsR, uR * VJ ) &
!!$        / DOT_PRODUCT( WeightsR, VJ )

    RETURN
  END FUNCTION CellAverage

END MODULE RadiationFieldsUtilitiesModule


!  TEST_NAIVE - test the naive forward substitution algorithm for a 3x3 problem

    program test_naive
    use naive
    use, intrinsic:: iso_fortran_env
    implicit none
    integer:: j, ierr
    namelist/matrixdata/ a, b

    real(DP):: a(3,3), b(3)

    read(INPUT_UNIT,matrixdata)
    call forward_naive(a, 3, b)
    if(ierr.eq.0) then
       write(OUTPUT_UNIT,*) b
    else
       write(OUTPUT_UNIT,*) 'error: ', ierr
    endif  ! or END IF
    stop
    end program test_naive


module gocean2d_io_mod
  use kind_params_mod
  use field_mod
  implicit none

  private

  logical, save :: l_out   !< Whether or not to produce output
  integer, save :: mprint  !< frequency of output
  !> Extents of arrays to write \todo Carry with field object.
  integer, save :: jpi, jpj

  public read_namelist
  public model_write_init, model_write, model_write_finalise

contains

  !===================================================

  !> Reads the namelist file for user-specified control
  !! parameters
  SUBROUTINE read_namelist(jpiglo, jpjglo, dx, dy,   &
                           nit000, nitend, irecord,  &
                           jphgr_msh, dep_const, rdt, cbfr, visc)
    implicit none
    !> Extent of the mask that describes the area that
    !! contains the simulation domain
    integer,  intent(out) :: jpiglo, jpjglo
    !> Grid spacing
    real(go_wp), intent(out) :: dx, dy
    !> Start time-step, stop time-step and output interval
    integer, intent(out) :: nit000, nitend, irecord
    !> Whether grid is to be read from file or not
    integer, intent(out) :: jphgr_msh
    !> (Constant) depth of water in domain
    real(go_wp), intent(out) :: dep_const
    !> Model time-step (seconds?)
    real(go_wp), intent(out) :: rdt
    !> Coefficient of bottom friction
    real(go_wp), intent(out) :: cbfr
    !> Background/constant viscosity
    real(go_wp), intent(out) :: visc
    ! namelist input
    character (len=8) :: nml_name = "namelist"
    integer :: input_unit = 99
    integer :: ios

    !! Read in model setup parameters
    NAMELIST/namctl/ jpiglo, jpjglo, jphgr_msh, &
                     dx    , dy    , dep_const, &
                     nit000, nitend, irecord  , &
                     rdt   , cbfr  , visc

    !! Default values

    jpiglo      =      50               !  number of columns of model grid
    jpjglo      =     100               !  number of rows of model grid
    jphgr_msh   =       1               !  type of grid (0: read in a data file; 1: setup with following parameters)
    dx          =   1000._go_wp            !  grid size in x direction (m)
    dy          =   1000._go_wp            !  grid size in y direction (m)
    dep_const   =    100._go_wp            !  constant depth (m)
    nit000      =       1               !  first time step
    nitend      =    1000               !  end time step
    irecord     =       1               !  intervals to save results
    rdt         =     10._go_wp            !  size of time step (second)
    cbfr        =   0.001_go_wp            !  bottom friction coefficeint
    visc        =     100._go_wp           !  horiz. kinematic viscosity coeff.

    OPEN(input_unit, file=nml_name, STATUS='OLD')
    REWIND(input_unit)
    READ(input_unit, NML=namctl, IOSTAT = ios)
    IF(ios /= 0) STOP "err found in reading namelist file"
    WRITE(*,NML=namctl)

    CLOSE(unit=input_unit)

  END SUBROUTINE read_namelist

  !===================================================

  SUBROUTINE model_write_init(m, n, interval)
    IMPLICIT none
    INTEGER, INTENT(in) :: m, n, interval

    jpi = m
    jpj = n
    mprint = interval
    l_out = .true.

  END SUBROUTINE model_write_init

  !===================================================

  !> Write data for the current time step
  subroutine model_write(grid, istp, ht, sshn, un, vn)
    use kind_params_mod
    use grid_mod
    implicit none
    type(grid_type), intent(in) :: grid
    integer, intent(in) :: istp
    type(r2d_field), intent(in) :: ht, sshn, un, vn
    ! Locals
    integer :: ji, jj
    real(go_wp) :: rtmp1, rtmp2
    character(len=5) :: fname

    if( l_out .and. (mod(istp, mprint) .eq. 0) ) then

       if( ht%data_on_device )then
!$acc update host(un%data, vn%data, sshn%data, ht%data)
       end if

       ! output model results
       write(fname, '(I5.5)') istp
       open(21, file='go2d_'//fname//'.dat', STATUS='UNKNOWN', &
            action='write')

       rewind(21)

       write(21, '("# x  y  depth   ssh  u  v")')

       ! Loop over 'internal' T points
       DO jj = sshn%internal%ystart, sshn%internal%ystop, 1
          DO ji = sshn%internal%xstart, sshn%internal%xstop, 1

             rtmp1 = 0.5_go_wp * (un%data(ji-1,jj) + un%data(ji,jj))
             rtmp2 = 0.5_go_wp * (vn%data(ji,jj-1) + vn%data(ji,jj))

             ! write "x-coord, y-coord, depth, ssh, u-velocity,
             ! v-velocity" to ASCII files

              write(21,'(6e16.7)') grid%xt(ji,jj), grid%yt(ji,jj), &
                                   ht%data(ji,jj), sshn%data(ji,jj), &
                                   rtmp1, rtmp2
          END DO
          WRITE(21,*)
       END DO

       close(21)

    end if ! we're doing output

  end subroutine model_write

  !===================================================

  SUBROUTINE model_write_finalise()
    IMPLICIT none

    ! Nothing to do here as we open and close ASCII file for
    ! each write.

  END SUBROUTINE model_write_finalise

  !===================================================

  ! Check error code
!!$  subroutine check(status, text)
!!$    implicit none
!!$
!!$    integer, intent(in) :: status
!!$    character (len=*)   :: text
!!$
!!$    if (status /= 0) then
!!$       write(6,*) "error ", status
!!$       write(6,*) text
!!$       stop 2
!!$    endif
!!$
!!$  end subroutine check

  !===================================================

END MODULE gocean2d_io_mod


!
! Copyright (c) 2015 - 2022, Intel Corporation
! SPDX-License-Identifier: BSD-3-Clause

program timed_loop

use geopm_prof
use, intrinsic :: ISO_C_BINDING

implicit none

include 'mpif.h'

integer, external :: omp_get_thread_num, omp_get_num_threads
integer :: ierr
integer :: index
real(kind=c_double) :: sum
integer(8) :: region_id
integer :: rank
integer(4) :: num_thread
integer(4) :: num_iter
integer(4) :: chunk_size
integer(4) :: thread_idx

num_iter = 100000000
chunk_size = 1000

call MPI_Init(ierr)
ierr = geopm_prof_region(c_char_'loop_0'//c_null_char, GEOPM_REGION_HINT_UNKNOWN, region_id)
ierr = geopm_prof_enter(region_id)
sum = 0
!$omp parallel
    num_thread = omp_get_num_threads()
!$omp end parallel
!$omp parallel default(shared) private(thread_idx)
    thread_idx = omp_get_thread_num()
    ierr = geopm_tprof_init(num_iter)
!$omp do schedule(static, chunk_size)
    do index = 1, int(num_iter)
        sum = sum + index
        ierr = geopm_tprof_post()
    end do
!$omp end do
!$omp end parallel

call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)
if (rank == 0) then
    print *,'sum=', sum
end if
ierr = geopm_prof_exit(region_id)
call MPI_Finalize(ierr)

end program timed_loop


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_scalar_check
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine checks a complex number to see if it is +-INF or NAN.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  NUM             COMPLEX(8)
!                    real number to be checked
!
! OUTPUT VARIABLES:
!
!  FLAG            LOGICAL
!                    .TRUE. implies valid complex(8)
!                    .FALSE. implies NUM contains +-INF or NAN
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_scalar_check(NUM,FLAG)

  implicit none

  ! input variables
  complex(8), intent(in) :: NUM
  logical, intent(inout) :: FLAG

  ! initialize INFO
  FLAG = .FALSE.

  ! check real part of NUM
  call d_scalar_check(dble(NUM),FLAG)
  if (.NOT.FLAG) then
    return
  end if

  ! check imaginary part of NUM
  call d_scalar_check(aimag(NUM),FLAG)

end subroutine z_scalar_check


      FUNCTION GAMDEV(IA,IDUM)
      IF(IA.LT.1)PAUSE
      IF(IA.LT.6)THEN
        X=1.
        DO 11 J=1,IA
          X=X*RAN1(IDUM)
11      CONTINUE
        X=-LOG(X)
      ELSE
1         V1=2.*RAN1(IDUM)-1.
          V2=2.*RAN1(IDUM)-1.
        IF(V1**2+V2**2.GT.1.)GO TO 1
          Y=V2/V1
          AM=IA-1
          S=SQRT(2.*AM+1.)
          X=S*Y+AM
        IF(X.LE.0.)GO TO 1
          E=(1.+Y**2)*EXP(AM*LOG(X/AM)-S*Y)
        IF(RAN1(IDUM).GT.E)GO TO 1
      ENDIF
      GAMDEV=X
      RETURN
      END


*> \brief \b SLARRF
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLARRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND,
*                          W, WGAP, WERR,
*                          SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
*                          DPLUS, LPLUS, WORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            CLSTRT, CLEND, INFO, N
*       REAL               CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
*       ..
*       .. Array Arguments ..
*       REAL               D( * ), DPLUS( * ), L( * ), LD( * ),
*      $          LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> Given the initial representation L D L^T and its cluster of close
*> eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
*> W( CLEND ), SLARRF finds a new relatively robust representation
*> L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
*> eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix (subblock, if the matrix splitted).
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          The N diagonal elements of the diagonal matrix D.
*> \endverbatim
*>
*> \param[in] L
*> \verbatim
*>          L is REAL array, dimension (N-1)
*>          The (N-1) subdiagonal elements of the unit bidiagonal
*>          matrix L.
*> \endverbatim
*>
*> \param[in] LD
*> \verbatim
*>          LD is REAL array, dimension (N-1)
*>          The (N-1) elements L(i)*D(i).
*> \endverbatim
*>
*> \param[in] CLSTRT
*> \verbatim
*>          CLSTRT is INTEGER
*>          The index of the first eigenvalue in the cluster.
*> \endverbatim
*>
*> \param[in] CLEND
*> \verbatim
*>          CLEND is INTEGER
*>          The index of the last eigenvalue in the cluster.
*> \endverbatim
*>
*> \param[in] W
*> \verbatim
*>          W is REAL array, dimension
*>          dimension is >=  (CLEND-CLSTRT+1)
*>          The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
*>          W( CLSTRT ) through W( CLEND ) form the cluster of relatively
*>          close eigenalues.
*> \endverbatim
*>
*> \param[in,out] WGAP
*> \verbatim
*>          WGAP is REAL array, dimension
*>          dimension is >=  (CLEND-CLSTRT+1)
*>          The separation from the right neighbor eigenvalue in W.
*> \endverbatim
*>
*> \param[in] WERR
*> \verbatim
*>          WERR is REAL array, dimension
*>          dimension is >=  (CLEND-CLSTRT+1)
*>          WERR contain the semiwidth of the uncertainty
*>          interval of the corresponding eigenvalue APPROXIMATION in W
*> \endverbatim
*>
*> \param[in] SPDIAM
*> \verbatim
*>          SPDIAM is REAL
*>          estimate of the spectral diameter obtained from the
*>          Gerschgorin intervals
*> \endverbatim
*>
*> \param[in] CLGAPL
*> \verbatim
*>          CLGAPL is REAL
*> \endverbatim
*>
*> \param[in] CLGAPR
*> \verbatim
*>          CLGAPR is REAL
*>          absolute gap on each end of the cluster.
*>          Set by the calling routine to protect against shifts too close
*>          to eigenvalues outside the cluster.
*> \endverbatim
*>
*> \param[in] PIVMIN
*> \verbatim
*>          PIVMIN is REAL
*>          The minimum pivot allowed in the Sturm sequence.
*> \endverbatim
*>
*> \param[out] SIGMA
*> \verbatim
*>          SIGMA is REAL
*>          The shift used to form L(+) D(+) L(+)^T.
*> \endverbatim
*>
*> \param[out] DPLUS
*> \verbatim
*>          DPLUS is REAL array, dimension (N)
*>          The N diagonal elements of the diagonal matrix D(+).
*> \endverbatim
*>
*> \param[out] LPLUS
*> \verbatim
*>          LPLUS is REAL array, dimension (N-1)
*>          The first (N-1) elements of LPLUS contain the subdiagonal
*>          elements of the unit bidiagonal matrix L(+).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (2*N)
*>          Workspace.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          Signals processing OK (=0) or failure (=1)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
*> \par Contributors:
*  ==================
*>
*> Beresford Parlett, University of California, Berkeley, USA \n
*> Jim Demmel, University of California, Berkeley, USA \n
*> Inderjit Dhillon, University of Texas, Austin, USA \n
*> Osni Marques, LBNL/NERSC, USA \n
*> Christof Voemel, University of California, Berkeley, USA
*
*  =====================================================================
      SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND,
     $                   W, WGAP, WERR,
     $                   SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
     $                   DPLUS, LPLUS, WORK, INFO )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            CLSTRT, CLEND, INFO, N
      REAL               CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
*     ..
*     .. Array Arguments ..
      REAL               D( * ), DPLUS( * ), L( * ), LD( * ),
     $          LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO
      PARAMETER          ( ONE = 1.0E0, TWO = 2.0E0,
     $                     QUART = 0.25E0,
     $                     MAXGROWTH1 = 8.E0,
     $                     MAXGROWTH2 = 8.E0 )
*     ..
*     .. Local Scalars ..
      LOGICAL   DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
      INTEGER            I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
      PARAMETER          ( KTRYMAX = 1, SLEFT = 1, SRIGHT = 2 )
      REAL               AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
     $                   FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA,
     $                   MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX,
     $                   RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2
*     ..
*     .. External Functions ..
      LOGICAL SISNAN
      REAL               SLAMCH
      EXTERNAL           SISNAN, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      FACT = REAL(2**KTRYMAX)
      EPS = SLAMCH( 'Precision' )
      SHIFT = 0
      FORCER = .FALSE.

*     Note that we cannot guarantee that for any of the shifts tried,
*     the factorization has a small or even moderate element growth.
*     There could be Ritz values at both ends of the cluster and despite
*     backing off, there are examples where all factorizations tried
*     (in IEEE mode, allowing zero pivots & infinities) have INFINITE
*     element growth.
*     For this reason, we should use PIVMIN in this subroutine so that at
*     least the L D L^T factorization exists. It can be checked afterwards
*     whether the element growth caused bad residuals/orthogonality.

*     Decide whether the code should accept the best among all
*     representations despite large element growth or signal INFO=1
      NOFAIL = .TRUE.
*

*     Compute the average gap length of the cluster
      CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT)
      AVGAP = CLWDTH / REAL(CLEND-CLSTRT)
      MINGAP = MIN(CLGAPL, CLGAPR)
*     Initial values for shifts to both ends of cluster
      LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT )
      RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND )

*     Use a small fudge to make sure that we really shift to the outside
      LSIGMA = LSIGMA - ABS(LSIGMA)* TWO * EPS
      RSIGMA = RSIGMA + ABS(RSIGMA)* TWO * EPS

*     Compute upper bounds for how much to back off the initial shifts
      LDMAX = QUART * MINGAP + TWO * PIVMIN
      RDMAX = QUART * MINGAP + TWO * PIVMIN

      LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT
      RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT
*
*     Initialize the record of the best representation found
*
      S = SLAMCH( 'S' )
      SMLGROWTH = ONE / S
      FAIL = REAL(N-1)*MINGAP/(SPDIAM*EPS)
      FAIL2 = REAL(N-1)*MINGAP/(SPDIAM*SQRT(EPS))
      BESTSHIFT = LSIGMA
*
*     while (KTRY <= KTRYMAX)
      KTRY = 0
      GROWTHBOUND = MAXGROWTH1*SPDIAM

 5    CONTINUE
      SAWNAN1 = .FALSE.
      SAWNAN2 = .FALSE.
*     Ensure that we do not back off too much of the initial shifts
      LDELTA = MIN(LDMAX,LDELTA)
      RDELTA = MIN(RDMAX,RDELTA)

*     Compute the element growth when shifting to both ends of the cluster
*     accept the shift if there is no element growth at one of the two ends

*     Left end
      S = -LSIGMA
      DPLUS( 1 ) = D( 1 ) + S
      IF(ABS(DPLUS(1)).LT.PIVMIN) THEN
         DPLUS(1) = -PIVMIN
*        Need to set SAWNAN1 because refined RRR test should not be used
*        in this case
         SAWNAN1 = .TRUE.
      ENDIF
      MAX1 = ABS( DPLUS( 1 ) )
      DO 6 I = 1, N - 1
         LPLUS( I ) = LD( I ) / DPLUS( I )
         S = S*LPLUS( I )*L( I ) - LSIGMA
         DPLUS( I+1 ) = D( I+1 ) + S
         IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN
            DPLUS(I+1) = -PIVMIN
*           Need to set SAWNAN1 because refined RRR test should not be used
*           in this case
            SAWNAN1 = .TRUE.
         ENDIF
         MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
 6    CONTINUE
      SAWNAN1 = SAWNAN1 .OR.  SISNAN( MAX1 )

      IF( FORCER .OR.
     $   (MAX1.LE.GROWTHBOUND .AND. .NOT.SAWNAN1 ) ) THEN
         SIGMA = LSIGMA
         SHIFT = SLEFT
         GOTO 100
      ENDIF

*     Right end
      S = -RSIGMA
      WORK( 1 ) = D( 1 ) + S
      IF(ABS(WORK(1)).LT.PIVMIN) THEN
         WORK(1) = -PIVMIN
*        Need to set SAWNAN2 because refined RRR test should not be used
*        in this case
         SAWNAN2 = .TRUE.
      ENDIF
      MAX2 = ABS( WORK( 1 ) )
      DO 7 I = 1, N - 1
         WORK( N+I ) = LD( I ) / WORK( I )
         S = S*WORK( N+I )*L( I ) - RSIGMA
         WORK( I+1 ) = D( I+1 ) + S
         IF(ABS(WORK(I+1)).LT.PIVMIN) THEN
            WORK(I+1) = -PIVMIN
*           Need to set SAWNAN2 because refined RRR test should not be used
*           in this case
            SAWNAN2 = .TRUE.
         ENDIF
         MAX2 = MAX( MAX2,ABS(WORK(I+1)) )
 7    CONTINUE
      SAWNAN2 = SAWNAN2 .OR.  SISNAN( MAX2 )

      IF( FORCER .OR.
     $   (MAX2.LE.GROWTHBOUND .AND. .NOT.SAWNAN2 ) ) THEN
         SIGMA = RSIGMA
         SHIFT = SRIGHT
         GOTO 100
      ENDIF
*     If we are at this point, both shifts led to too much element growth

*     Record the better of the two shifts (provided it didn't lead to NaN)
      IF(SAWNAN1.AND.SAWNAN2) THEN
*        both MAX1 and MAX2 are NaN
         GOTO 50
      ELSE
         IF( .NOT.SAWNAN1 ) THEN
            INDX = 1
            IF(MAX1.LE.SMLGROWTH) THEN
               SMLGROWTH = MAX1
               BESTSHIFT = LSIGMA
            ENDIF
         ENDIF
         IF( .NOT.SAWNAN2 ) THEN
            IF(SAWNAN1 .OR. MAX2.LE.MAX1) INDX = 2
            IF(MAX2.LE.SMLGROWTH) THEN
               SMLGROWTH = MAX2
               BESTSHIFT = RSIGMA
            ENDIF
         ENDIF
      ENDIF

*     If we are here, both the left and the right shift led to
*     element growth. If the element growth is moderate, then
*     we may still accept the representation, if it passes a
*     refined test for RRR. This test supposes that no NaN occurred.
*     Moreover, we use the refined RRR test only for isolated clusters.
      IF((CLWDTH.LT.MINGAP/REAL(128)) .AND.
     $   (MIN(MAX1,MAX2).LT.FAIL2)
     $  .AND.(.NOT.SAWNAN1).AND.(.NOT.SAWNAN2)) THEN
         DORRR1 = .TRUE.
      ELSE
         DORRR1 = .FALSE.
      ENDIF
      TRYRRR1 = .TRUE.
      IF( TRYRRR1 .AND. DORRR1 ) THEN
      IF(INDX.EQ.1) THEN
         TMP = ABS( DPLUS( N ) )
         ZNM2 = ONE
         PROD = ONE
         OLDP = ONE
         DO 15 I = N-1, 1, -1
            IF( PROD .LE. EPS ) THEN
               PROD =
     $         ((DPLUS(I+1)*WORK(N+I+1))/(DPLUS(I)*WORK(N+I)))*OLDP
            ELSE
               PROD = PROD*ABS(WORK(N+I))
            END IF
            OLDP = PROD
            ZNM2 = ZNM2 + PROD**2
            TMP = MAX( TMP, ABS( DPLUS( I ) * PROD ))
 15      CONTINUE
         RRR1 = TMP/( SPDIAM * SQRT( ZNM2 ) )
         IF (RRR1.LE.MAXGROWTH2) THEN
            SIGMA = LSIGMA
            SHIFT = SLEFT
            GOTO 100
         ENDIF
      ELSE IF(INDX.EQ.2) THEN
         TMP = ABS( WORK( N ) )
         ZNM2 = ONE
         PROD = ONE
         OLDP = ONE
         DO 16 I = N-1, 1, -1
            IF( PROD .LE. EPS ) THEN
               PROD = ((WORK(I+1)*LPLUS(I+1))/(WORK(I)*LPLUS(I)))*OLDP
            ELSE
               PROD = PROD*ABS(LPLUS(I))
            END IF
            OLDP = PROD
            ZNM2 = ZNM2 + PROD**2
            TMP = MAX( TMP, ABS( WORK( I ) * PROD ))
 16      CONTINUE
         RRR2 = TMP/( SPDIAM * SQRT( ZNM2 ) )
         IF (RRR2.LE.MAXGROWTH2) THEN
            SIGMA = RSIGMA
            SHIFT = SRIGHT
            GOTO 100
         ENDIF
      END IF
      ENDIF

 50   CONTINUE

      IF (KTRY.LT.KTRYMAX) THEN
*        If we are here, both shifts failed also the RRR test.
*        Back off to the outside
         LSIGMA = MAX( LSIGMA - LDELTA,
     $     LSIGMA - LDMAX)
         RSIGMA = MIN( RSIGMA + RDELTA,
     $     RSIGMA + RDMAX )
         LDELTA = TWO * LDELTA
         RDELTA = TWO * RDELTA
         KTRY = KTRY + 1
         GOTO 5
      ELSE
*        None of the representations investigated satisfied our
*        criteria. Take the best one we found.
         IF((SMLGROWTH.LT.FAIL).OR.NOFAIL) THEN
            LSIGMA = BESTSHIFT
            RSIGMA = BESTSHIFT
            FORCER = .TRUE.
            GOTO 5
         ELSE
            INFO = 1
            RETURN
         ENDIF
      END IF

 100  CONTINUE
      IF (SHIFT.EQ.SLEFT) THEN
      ELSEIF (SHIFT.EQ.SRIGHT) THEN
*        store new L and D back into DPLUS, LPLUS
         CALL SCOPY( N, WORK, 1, DPLUS, 1 )
         CALL SCOPY( N-1, WORK(N+1), 1, LPLUS, 1 )
      ENDIF

      RETURN
*
*     End of SLARRF
*
      END


      subroutine eplane(ibpln,iepln,slplen,alpha,m,ealpha)
c
c     + + + PURPOSE + + +
c     Calculates the equivalent depth discharge coefficient for
c     using the equivalent plane method; this is for handling
c     multiple strips down the hillslope.
c
c     ====================================================================
c     *  Note: The only equation that Chezy was used for is:             *
c     *          alphq = (chezy(i)*sqrt(avgslp(i)))**power2              *
c     *                                                                  *
c     *        The equation for Chezy is:                                *
c     *          chezy(i) = alpha(i)/sqrt(avgslp(i))                     *
c     *                                                                  *
c     *        If the two equations are combined into:                   *
c     *          sdst  = sdst + (suml*alpha(i)**power2)/(tmpvr1-tmpvr2)  *
c     *                                                                  *
c     *        CHEZY(I) & AVGSLP(I) are not needed.  CRM 4/11/91         *
c     ====================================================================
c
c     Called from IRS
c     Author(s): Hernandez, Stone
c     Reference in User Guide:
c
c     Changes:
c         1) Local vars. AVS, SUMS, DSTT, CHEZY(20), DFL, SML &
c            POWER1 not used -- removed from code.
c         2) XNPLN, AVGSLP, & REMAX not needed -- removed from
c            parameter list. Corresponding changes made in call
c            from IRS.
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/09/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pmxpln.inc'
c       read: mxplan
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      integer ibpln, iepln
      real slplen(mxplan), alpha(mxplan), m, ealpha
c
c     + + + ARGUMENT DEFINITIONS + + +
c     ibpln  - beginning segment (plane) number
c     iepln  - ending segment (plane) number
c     slplen - length of each plane (m)
c     alpha  - alpha for individual segment
c     m      - 3/2
c     ealpha - equivalent alpha for combined segments
c
c     + + + LOCAL VARIABLES + + +
      real suml, power2, power3, cml, tmpvr1, sdst, tmpvr2
      integer i
c
c     + + + LOCAL DEFINITIONS + + +
c     suml   - total length (m) of all the segments
c     power2 - 1./m
c     power3 - (m+1.)/m; ie, power2 + 1.
c     cml    - cumulative length (through current segment in loop)
c     tmpvr1 - temporary storage variable, changed each time through loop.
c     sdst   - WAS average storage at equilibrium (modified during recoding)
c     tmpvr2 - holds value of TMPVR1 previous time through the loop.
c
c     + + + END SPECIFICATIONS + + +
c
      suml = 0.
      do 10 i = ibpln, iepln
        suml = suml + slplen(i)
   10 continue
c
c     Computation of exponents
c
      power2 = 1. / m
      power3 = power2 + 1.
c
      cml = 0.
      sdst = 0.
      tmpvr2 = 0.
      do 20 i = ibpln, iepln
        cml = cml + slplen(i)
        tmpvr1 = cml ** power3
        sdst = sdst + (tmpvr1-tmpvr2) / (alpha(i)**power2)
        tmpvr2 = tmpvr1
   20 continue
c
c     Computation of equivalent alpha
c
      ealpha = (suml/sdst) ** m * suml
c
      return
      end


      SUBROUTINE SBGROW( ATMXYZ, ATMVDW,
     &                   AXIS, RADMAX, BOXDIM, CENTRE)
      IMPLICIT NONE
      SAVE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 1996 Oliver Smart & Birkbeck College, All rights reserved    *
C *                                                                  *
C ********************************************************************

C This s/r finds value the radmax of a "sphere-box" (oss i005) with
C fixed boxdim etc. so that an atom of radius atmvdw centred on
C atmxyz is touched.

C position and radius of atom
      DOUBLE PRECISION			ATMXYZ(3), ATMVDW

C centre of sphere box
      DOUBLE PRECISION			CENTRE(3)

C unit vector giving directions of axes which define sphere box
C first axis is vector (axis(1,1),axis(2,1),axis(3,1)
C N.B. no check is made in this s/r that axes are unit
C and orthogonal - This must be made certain in calling routine.
      DOUBLE PRECISION			AXIS(3,3)

C radius of sphere box, its additional dimensions along the three axis
      DOUBLE PRECISION			RADMAX, BOXDIM(3)

C internal vbles ***********************

C a distance
      DOUBLE PRECISION 			DIST

C the vector from centre to point (cartesian)
      DOUBLE PRECISION			DISP(3)

C components of DISP along axis(*,1), axis(*,2) and axis(*,3)
      DOUBLE PRECISION			COMP(3)

C closest point in "axis" units
      DOUBLE PRECISION			AXISCL(3)

C x,y,z loop count
       INTEGER				XCOUNT

C end of decs **************************

C the vector from centre to point
      DISP(1) = ATMXYZ(1) - CENTRE(1)
      DISP(2) = ATMXYZ(2) - CENTRE(2)
      DISP(3) = ATMXYZ(3) - CENTRE(3)

C work out components along the various axes
      CALL DDOT( DISP, AXIS(1,1), COMP(1))
      CALL DDOT( DISP, AXIS(1,2), COMP(2))
      CALL DDOT( DISP, AXIS(1,3), COMP(3))
C*      write(*,*) 'comp''s ', comp

C closest point on (or inside) box in axis units
      DO 10 XCOUNT = 1, 3
        IF (COMP(XCOUNT).GT.0.) THEN
          AXISCL(XCOUNT) = MIN(COMP(XCOUNT), BOXDIM(XCOUNT))
        ELSE
          AXISCL(XCOUNT) = MAX(COMP(XCOUNT),-BOXDIM(XCOUNT))
        ENDIF
10    CONTINUE

C make comp's vector from axiscl to point
      COMP(1) = COMP(1) - AXISCL(1)
      COMP(2) = COMP(2) - AXISCL(2)
      COMP(3) = COMP(3) - AXISCL(3)
C*      write(*,*) 'comp vector ', comp

C work out length of this
      DIST = SQRT(COMP(1)**2+ COMP(2)**2 + COMP(3)**2)
C*      write(*,*) ' dist', dist
C maximum radius given by:
C dist = radmax + atmvdw
      RADMAX = DIST-ATMVDW
C n.b. may be negative if atom overlap the box

      RETURN
      END


subroutine find_index(ip,IPP)
    !find particle index for C-grid variable and their distance to faces
    use global, only: pi2f,pj2f,pk2f,pi2c,pj2c,pk2c,xyz, &
        dif, djf, dkf, dic, djc, dkc,Nx,Nz,Ny
    integer*8, intent(in) :: ip,IPP
    real*8 :: x
    ! these ifs make sure the index does not go beyond the allowed values, otherwise
    ! segmentation error occurs unpredicted

    !if (xyz(ip,1)>Nx+1) then
    !    xyz(ip,1)=Nx+0.5
    !elseif (xyz(ip,1)<-1) then
    !    xyz(ip,1)=-0.5
    !endif
    if (xyz(ip,2,IPP)<Ny-1) then
        x=mod(xyz(ip,1,IPP),real(Nx-1,8))
        !if (xyz(ip,3)>Nz-0.5) then
        !    xyz(ip,3)=Nz-1.5
        !elseif (xyz(ip,3)<-1) then
        !    xyz(ip,3)=0.0
        !endif

        ! pi2f(ip)=floor(xyz(ip,1))
        pi2f(ip,IPP)=floor(x)
        pj2f(ip,IPP)=floor(xyz(ip,2,IPP))
        pk2f(ip,IPP)=floor(xyz(ip,3,IPP))
        ! pi2c(ip)=floor(xyz(ip,1)-0.5d0)
        pi2c(ip,IPP)=floor(x-0.5d0)
        pj2c(ip,IPP)=floor(xyz(ip,2,IPP)-0.5d0)
        pk2c(ip,IPP)=floor(xyz(ip,3,IPP)-0.5d0)

        ! dif(ip) = xyz(ip,1)-pi2f(ip)
        dif(ip,IPP) = x-pi2f(ip,IPP)
        djf(ip,IPP) = xyz(ip,2,IPP)-pj2f(ip,IPP)
        dkf(ip,IPP) = xyz(ip,3,IPP)-pk2f(ip,IPP)

        ! dic(ip) = xyz(ip,1)-pi2c(ip)-0.5d0
        dic(ip,IPP) = x-pi2c(ip,IPP)-0.5d0
        djc(ip,IPP) = xyz(ip,2,IPP)-pj2c(ip,IPP)-0.5d0
        dkc(ip,IPP) = xyz(ip,3,IPP)-pk2c(ip,IPP)-0.5d0

        !if (maxval(pj2f(ipts(1):ipts(2)))>321 .or. minval(pj2f(ipts(1):ipts(2)))<-1 ) then
        !   print*, "something wrong, maxval(pj2f)"
        !endif
        !    if (pi2f(ip)>Nx-1 .or. pi2f(ip)<-1) then
        !       print*, 'something wrong in pi2f'
        !    endif
        if (pk2f(ip,IPP)<-2 .or. pk2f(ip,IPP)>41) then
            xyz(ip,3,IPP)=mod(abs(xyz(ip,3,IPP)),real(Nz-1,8))
            print*, "something wrong in pk2f",pk2f(ip,IPP),'changed the vertical coordinate to',xyz(ip,3,IPP)
        endif
    endif
end subroutine find_index


MODULE korc_avalanche
  USE korc_types
  USE korc_constants
  USE korc_HDF5
  USE korc_hpc
  USE korc_fields
  USE korc_profiles
  USE korc_coords
  USE korc_input

  IMPLICIT NONE

  TYPE, PRIVATE :: AVALANCHE_PDF_PARAMS
     REAL(rp) :: max_pitch_angle
     !! Maximum pitch angle of sampled PDF in degrees
     REAL(rp) :: min_pitch_angle
     !! Minimum pitch angle of sampled PDF in degrees
     REAL(rp) :: min_energy
     !! Minimum energy of sampled PDF in MeV
     REAL(rp) :: max_energy
     !! Maximum energy of sampled PDF in MeV
     REAL(rp) :: min_p
     !! Minimum momentum of sampled PDF
     REAL(rp) :: max_p
     !! Maximum momentum of sampled PDF
     REAL(rp) :: ne
     !! Background electron density in m^-3
     REAL(rp) :: Zeff
     !! Effective atomic number of ions
     REAL(rp) :: Ec
     !! Critical electric field in V/m
     REAL(rp) :: Epar
     !! Parallel electric field in V/m
     REAL(rp) :: Ebar
     !! Epar/Ec
     REAL(rp) :: Te
     !! Background electron temperature in eV
     REAL(rp) :: lD
     !! Debye length
     REAL(rp) :: bmin
     !! Maximum approach radius
     REAL(rp) :: CoulombLog
     !! Coulomb Logarithm
     REAL(rp) :: Tau
     !! Collisional time

     REAL(rp) :: dth
     !! Variance of sampling normal variate for pitch angle
     REAL(rp) :: dp
     !! Variance of sampling normal variate for momentum
     REAL(rp) :: dR
     !! Variance of sampling normal variate for R location
     REAL(rp) :: dZ
     !! Variance of sampling normal variate for Z location

     REAL(rp) :: fo
     REAL(rp) :: alpha
     REAL(rp) :: cz
     REAL(rp) :: C1
     REAL(rp) :: C2
  END TYPE AVALANCHE_PDF_PARAMS

  TYPE(AVALANCHE_PDF_PARAMS), PRIVATE :: aval_params
  REAL(rp), PRIVATE, PARAMETER :: minmax_buffer_size = 10.0_rp

  PUBLIC :: get_avalanche_distribution,&
       get_Avalanche_4D
  PRIVATE :: initialize_avalanche_params,&
       save_avalanche_params,&
       fRE,&
       sample_distribution,&
       indicator,&
       PSI_ROT,&
       random_norm,&
       update_avalanche_params,&
       Avalanche_4D

CONTAINS

  SUBROUTINE get_avalanche_distribution(params,g,eta,go,etao)
    TYPE(KORC_PARAMS), INTENT(IN) :: params
    REAL(rp), DIMENSION(:), ALLOCATABLE, INTENT(INOUT) :: g
    REAL(rp), DIMENSION(:), ALLOCATABLE, INTENT(INOUT) :: eta
    REAL(rp), INTENT(OUT) :: go
    REAL(rp), INTENT(OUT) :: etao

    call initialize_avalanche_params(params)

    call save_avalanche_params(params)

    call sample_distribution(params,g,eta,go,etao)
  END SUBROUTINE get_avalanche_distribution

  SUBROUTINE get_Avalanche_4D(params,spp,P,F)
    TYPE(KORC_PARAMS), INTENT(IN) :: params
    TYPE(SPECIES), INTENT(INOUT)  :: spp
    TYPE(PROFILES), INTENT(IN)    :: P
    TYPE(FIELDS), INTENT(IN)                                   :: F
    !! An instance of the KORC derived type FIELDS.

    call initialize_avalanche_params(params)

    call save_avalanche_params(params)

    call Avalanche_4D(params,spp,P,F)
  END SUBROUTINE get_Avalanche_4D

  SUBROUTINE initialize_avalanche_params(params)
    TYPE(KORC_PARAMS), INTENT(IN) :: params
    !REAL(rp) :: max_pitch_angle
    !REAL(rp) :: min_pitch_angle
    !REAL(rp) :: max_energy
    !REAL(rp) :: min_energy
    !REAL(rp) :: ne
    !REAL(rp) :: Zeff
    !REAL(rp) :: Epar
    !REAL(rp) :: Te
    !REAL(rp) :: dth
    !REAL(rp) :: dp
    !REAL(rp) :: dR
    !REAL(rp) :: dZ
    !NAMELIST /AvalancheGenerationPDF/ max_pitch_angle,min_pitch_angle, &
    !     max_energy,min_energy,ne,Zeff,Epar,Te,dth,dp,dR,dZ

    !open(unit=default_unit_open,file=TRIM(params%path_to_inputs), &
    !     status='OLD',form='formatted')
    !read(default_unit_open,nml=AvalancheGenerationPDF)
    !close(default_unit_open)

    aval_params%dth = dth_aval
    aval_params%dp  = dp_aval
    aval_params%dR  = dR_aval/params%cpp%length
    aval_params%dZ  = dZ_aval/params%cpp%length

    aval_params%max_pitch_angle = max_pitch_angle_aval
    aval_params%min_pitch_angle = min_pitch_angle_aval
    aval_params%max_energy = max_energy_aval*C_E ! In Joules
    aval_params%ne = ne_aval
    aval_params%Zeff = Zeff_aval
    aval_params%Te = Te_aval*C_E ! In Joules

    aval_params%lD = SQRT(C_E0*aval_params%Te/(aval_params%ne*C_E**2))
    aval_params%bmin = aval_params%Zeff/(12.0_rp*C_PI*aval_params%ne* &
         aval_params%lD**2)
    aval_params%CoulombLog = LOG(aval_params%lD/aval_params%bmin)
    aval_params%Tau = 1.0_rp/(4.0_rp*C_PI*C_C*C_RE**2*aval_params%ne* &
         aval_params%CoulombLog)

    aval_params%Ec = C_ME*C_C/(C_E*aval_params%Tau)
    aval_params%Epar = Epar_aval
    aval_params%Ebar = aval_params%Epar/aval_params%Ec

    if (min_energy_aval .EQ. 0.0_rp) then
       aval_params%max_p = SQRT((aval_params%max_energy/(C_ME*C_C**2))**2 &
            - 1.0_rp)
       ! In units of mec^2
       aval_params%min_p = SQRT(aval_params%Ebar - 1.0_rp)
       ! In units of mec^2

       aval_params%min_energy = SQRT(1.0_rp + aval_params%min_p**2)*C_ME*C_C**2
    else
       aval_params%min_energy = min_energy_aval*C_E
       ! In Joules

       aval_params%max_p = SQRT((aval_params%max_energy/(C_ME*C_C**2))**2 - 1.0_rp)
       ! In units of mec^2
       aval_params%min_p = SQRT((aval_params%min_energy/(C_ME*C_C**2))**2 - 1.0_rp)
       ! In units of mec^2
    end if

    aval_params%alpha = (aval_params%Ebar - 1.0_rp)/(1.0_rp + aval_params%Zeff)
    aval_params%cz = SQRT(3.0_rp*(aval_params%Zeff + 5.0_rp)/C_PI)* &
         aval_params%CoulombLog
    aval_params%fo = aval_params%alpha/aval_params%cz
    aval_params%C1 = 0.5_rp*aval_params%alpha
    aval_params%C2 = 1.0_rp/aval_params%cz - aval_params%C1
  END SUBROUTINE initialize_avalanche_params

  FUNCTION deg2rad(x)
    REAL(rp), INTENT(IN) :: x
    REAL(rp) :: deg2rad

    deg2rad = C_PI*x/180.0_rp
  END FUNCTION deg2rad

  FUNCTION fRE(x,p)
    REAL(rp), INTENT(IN) :: x ! x = cos(pitch)
    REAL(rp), INTENT(IN) :: p ! momentum
    REAL(rp) :: fRE

    fRE = aval_params%fo*p*EXP(-p*(aval_params%C2*x + aval_params%C1/x))/x
  END FUNCTION fRE

  FUNCTION log10fRE(x,p)
    REAL(rp), INTENT(IN) :: x ! x = cos(pitch)
    REAL(rp), INTENT(IN) :: p ! momentum
    REAL(rp) :: log10fRE

    log10fRE = LOG(fRE(x,p))
  END FUNCTION log10fRE

  SUBROUTINE sample_distribution(params,g,eta,go,etao)
    TYPE(KORC_PARAMS), INTENT(IN) :: params
    REAL(rp), DIMENSION(:), ALLOCATABLE, INTENT(INOUT) :: g
    REAL(rp), DIMENSION(:), ALLOCATABLE, INTENT(INOUT) :: eta
    REAL(rp), INTENT(OUT) :: go
    REAL(rp), INTENT(OUT) :: etao
    REAL(rp), DIMENSION(:), ALLOCATABLE :: p
    REAL(rp) :: chi, chi_test
    REAL(rp) :: p_buffer, p_test
    REAL(rp) :: eta_buffer, eta_test
    REAL(rp) :: ratio, rand_unif
    REAL(rp), DIMENSION(:), ALLOCATABLE :: p_samples
    REAL(rp), DIMENSION(:), ALLOCATABLE :: eta_samples
    REAL(rp), DIMENSION(:), ALLOCATABLE :: p_tmp
    REAL(rp), DIMENSION(:), ALLOCATABLE :: eta_tmp
    REAL(rp) :: minmax,min_p, max_p, min_pitch_angle, max_pitch_angle
    REAL(4), DIMENSION(2) :: tarray
    REAL(4) :: time_elapsed
    REAL(rp) :: deta
    REAL(rp) :: dp
    LOGICAL :: lp,leta
    INTEGER :: num_accepted
    INTEGER :: ii,jj,ppp,nsamples
    INTEGER :: mpierr

    ppp = SIZE(g)
    nsamples = ppp*params%mpi_params%nmpi
    ALLOCATE(p(ppp))

    deta = (aval_params%max_pitch_angle - aval_params%min_pitch_angle)/100.0_rp
    dp = (aval_params%max_p - aval_params%min_p)/100.0_rp

    do jj=1_idef,INT(minmax_buffer_size,idef)
       minmax = aval_params%min_p - REAL(jj,rp)*dp
       if (minmax.GT.0.0_rp) then
          min_p = minmax
       end if
    end do

    max_p = aval_params%max_p + minmax_buffer_size*dp

    if (aval_params%min_pitch_angle.GE.korc_zero) then
       do jj=1_idef,INT(minmax_buffer_size,idef)
          minmax = aval_params%min_pitch_angle -  REAL(jj,rp)*deta
          if (minmax.GT.0.0_rp) then
             min_pitch_angle = minmax
          end if
       end do
    else
       min_pitch_angle = aval_params%min_pitch_angle
    end if

    do jj=1_idef,INT(minmax_buffer_size,idef)
       minmax = aval_params%max_pitch_angle + REAL(jj,rp)*deta
       if (minmax.LE.90.0_rp) then
          max_pitch_angle = minmax
       else
          max_pitch_angle = aval_params%max_pitch_angle
          EXIT
       end if
    end do

    if (params%mpi_params%rank.EQ.0_idef) then
       ALLOCATE(p_samples(nsamples))
       ! Number of samples to distribute among all MPI processes
       ALLOCATE(eta_samples(nsamples))
       ! Number of samples to distribute among all MPI processes
       ALLOCATE(p_tmp(nsamples))
       ! Number of samples to distribute among all MPI processes
       ALLOCATE(eta_tmp(nsamples))
       ! Number of samples to distribute among all MPI processes

       ! Transient !
       call RANDOM_SEED()

       call RANDOM_NUMBER(rand_unif)
       eta_buffer = aval_params%min_pitch_angle + (aval_params%max_pitch_angle  &
            - aval_params%min_pitch_angle)*rand_unif

       call RANDOM_NUMBER(rand_unif)
       p_buffer = aval_params%min_p + (aval_params%max_p - aval_params%min_p)* &
            rand_unif

       ii=2_idef
       do while (ii .LE. 1000_idef)
          eta_test = eta_buffer + random_norm(0.0_rp,deta)
          do while ((ABS(eta_test) .GT. aval_params%max_pitch_angle).OR. &
               (ABS(eta_test) .LT. aval_params%min_pitch_angle))
             eta_test = eta_buffer + random_norm(0.0_rp,deta)
          end do
          chi_test = COS(deg2rad(eta_test))
          chi = COS(deg2rad(eta_buffer))

          p_test = p_buffer + random_norm(0.0_rp,dp)
          do while ((p_test.LT.aval_params%min_p).OR.(p_test.GT.aval_params%max_p))
             p_test = p_buffer + random_norm(0.0_rp,dp)
          end do

          ratio = fRE(chi_test,p_test)/fRE(chi,p_buffer)

          if (ratio .GE. 1.0_rp) then
             p_buffer = p_test
             eta_buffer = eta_test
             ii = ii + 1_idef
          else
             call RANDOM_NUMBER(rand_unif)
             if (rand_unif .LT. ratio) then
                p_buffer = p_test
                eta_buffer = eta_test
                ii = ii + 1_idef
             end if
          end if
       end do
       ! Transient !

       call RANDOM_SEED()
       call RANDOM_NUMBER(rand_unif)

       eta_tmp(1) = eta_buffer
       p_tmp(1) = p_buffer

       num_accepted = 0_idef
       do while(num_accepted.LT.nsamples)
          ii=2_idef
          do while (ii .LE. nsamples)
             eta_test = eta_tmp(ii-1) + random_norm(0.0_rp,deta)
             do while ((ABS(eta_test) .GT. max_pitch_angle).OR.(ABS(eta_test) &
                  .LT. min_pitch_angle))
                eta_test = eta_tmp(ii-1) + random_norm(0.0_rp,deta)
             end do
             chi_test = COS(deg2rad(eta_test))
             chi = COS(deg2rad(eta_tmp(ii-1)))

             p_test = p_tmp(ii-1) + random_norm(0.0_rp,dp)
             do while ((p_test.LT.min_p).OR.(p_test.GT.max_p))
                p_test = p_tmp(ii-1) + random_norm(0.0_rp,dp)
             end do

             ratio = fRE(chi_test,p_test)/fRE(chi,p_tmp(ii-1))

             if (ratio .GE. 1.0_rp) then
                p_tmp(ii) = p_test
                eta_tmp(ii) = eta_test
                ii = ii + 1_idef
             else
                call RANDOM_NUMBER(rand_unif)
                if (rand_unif .LT. ratio) then
                   p_tmp(ii) = p_test
                   eta_tmp(ii) = eta_test
                   ii = ii + 1_idef
                end if
             end if
          end do

          eta_tmp = ABS(eta_tmp)

          ii = 1_idef
          do while ( (ii.LT.nsamples).AND.(num_accepted.LT.nsamples) )
             lp = (p_tmp(ii).LE.aval_params%max_p).AND.(p_tmp(ii).GE. &
                  aval_params%min_p)
             leta = (eta_tmp(ii).LE.aval_params%max_pitch_angle).AND. &
                  (eta_tmp(ii).GE.aval_params%min_pitch_angle)
             if (lp.AND.leta) then
                num_accepted = num_accepted + 1_idef
                p_samples(num_accepted) = p_tmp(ii)
                eta_samples(num_accepted) = eta_tmp(ii)
             end if
             ii = ii + 1_idef
          end do

          eta_tmp(1) = eta_tmp(ii)
          p_tmp(1) = p_tmp(ii)
       end do

       go = SUM(SQRT(1.0_rp + p_samples**2))/nsamples
       etao = SUM(eta_samples)/nsamples

    end if

    CALL MPI_SCATTER(p_samples,ppp,MPI_REAL8,p,ppp,MPI_REAL8,0, &
         MPI_COMM_WORLD,mpierr)

    CALL MPI_SCATTER(eta_samples,ppp,MPI_REAL8,eta,ppp,MPI_REAL8, &
         0,MPI_COMM_WORLD,mpierr)

    CALL MPI_BCAST(go,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)

    CALL MPI_BCAST(etao,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)

    call MPI_BARRIER(MPI_COMM_WORLD,mpierr)

    g = SQRT(1.0_rp + p**2)

    DEALLOCATE(p)
    if (params%mpi_params%rank.EQ.0_idef) then
       DEALLOCATE(p_samples)
       DEALLOCATE(eta_samples)
    end if
  END SUBROUTINE sample_distribution

  FUNCTION PSI_ROT(R,R0,sigR,Z,Z0,sigZ,theta)
    !! Calculates value of argument of 2D Gaussian spatial distribution with
    !! with counter-clockwise rotation.
    REAL(rp), INTENT(IN) 	:: R
    !! R-coordinate of MH sampled location
    REAL(rp), INTENT(IN) 	:: R0
    !! R-coordinate of center of 2D Gaussian
    REAL(rp), INTENT(IN) 	:: sigR
    !! Variance of first dimension of 2D Gaussian
    REAL(rp), INTENT(IN) 	:: Z
    !! Z-coordinate of MH sampled location
    REAL(rp), INTENT(IN) 	:: Z0
    !! Z-coordinate of center of 2D Gaussian
    REAL(rp), INTENT(IN) 	:: sigZ
    !! Variance of second dimension of 2D Gaussian
    REAL(rp), INTENT(IN) 	:: theta
    !! Angle of counter-clockwise rotation (in radians), of 2D Gaussian
    !! distribution relative to R,Z
    REAL(rp) 		:: PSI_ROT
    !! Argument of exponential comprising 2D Gaussian distribution

    PSI_ROT=(R-R0)**2*((cos(theta))**2/(2*sigR**2)+(sin(theta))**2/ &
         (2*sigZ**2))+2*(R-R0)*(Z-Z0)*cos(theta)*sin(theta)*(1/ &
         (2*sigR**2)-1/(2*sigZ**2))+(Z-Z0)**2*((sin(theta))**2/ &
         (2*sigR**2)+(cos(theta))**2/(2*sigZ**2))

  END FUNCTION PSI_ROT

  FUNCTION indicator(psi,psi_max)
    !! Compares argument psi to chosen psi_max, returning step function.
    REAL(rp), INTENT(IN)  :: psi
    REAL(rp), INTENT(IN)  :: psi_max
    REAL(rp)              :: indicator

    IF (psi.LT.psi_max) THEN
       indicator=1
    ELSE
       indicator=0
    END IF

  END FUNCTION indicator

  FUNCTION random_norm(mean,sigma)
    REAL(rp), INTENT(IN) :: mean
    REAL(rp), INTENT(IN) :: sigma
    REAL(rp)             :: random_norm
    REAL(rp)             :: rand1, rand2

    call RANDOM_NUMBER(rand1)
    call RANDOM_NUMBER(rand2)

    random_norm = mean+sigma*SQRT(-2.0_rp*LOG(rand1))*COS(2.0_rp*C_PI*rand2);
  END FUNCTION random_norm

SUBROUTINE update_avalanche_params(params,prtcls)
  !! Updates the avalanche parameters aval_params% at each step
  !! in the MCMC after the profiles are interpolated at the sampled
  !! R,Z location.
  TYPE(KORC_PARAMS), INTENT(IN) 	:: params
  !! Core KORC simulation parameters.
  TYPE(PARTICLES), INTENT(IN) :: prtcls
  !! An instance of PARTICLES containing the variables of a
  !! given species. Call to this subroutine generally passes spp%vars.

  aval_params%ne = prtcls%ne(1)*params%cpp%density
  aval_params%Zeff = prtcls%Zeff(1)
  aval_params%Te = prtcls%Te(1)*params%cpp%temperature ! In Joules

  aval_params%lD = SQRT(C_E0*aval_params%Te/(aval_params%ne*C_E**2))
  aval_params%bmin = aval_params%Zeff/(12.0_rp*C_PI*aval_params%ne* &
       aval_params%lD**2)
  aval_params%CoulombLog = LOG(aval_params%lD/aval_params%bmin)
  aval_params%Tau = 1.0_rp/(4.0_rp*C_PI*C_C*C_RE**2*aval_params%ne* &
       aval_params%CoulombLog)

  aval_params%Ec = C_ME*C_C/(C_E*aval_params%Tau)
  aval_params%Ebar = aval_params%Epar/aval_params%Ec

  aval_params%alpha = (aval_params%Ebar - 1.0_rp)/(1.0_rp +&
       aval_params%Zeff)
  aval_params%cz = SQRT(3.0_rp*(aval_params%Zeff + 5.0_rp)/C_PI)* &
       aval_params%CoulombLog
  aval_params%fo = aval_params%alpha/aval_params%cz
  aval_params%C1 = 0.5_rp*aval_params%alpha
  aval_params%C2 = 1.0_rp/aval_params%cz - aval_params%C1

END SUBROUTINE update_avalanche_params

subroutine Avalanche_4D(params,spp,P,F)
  !! @note Subroutine that generates a 2D Gaussian distribution in an
  !! elliptic torus as the initial spatial condition of a given particle
  !! species in the simulation. @endnote
  TYPE(KORC_PARAMS), INTENT(IN) 	:: params
  !! Core KORC simulation parameters.
  TYPE(SPECIES), INTENT(INOUT) 		:: spp
  !! An instance of the derived type SPECIES containing all the parameters
  !! and simulation variables of the different species in the simulation.
  TYPE(PROFILES), INTENT(IN)            :: P
  !! An instance of the KORC derived type PROFILES.
  TYPE(FIELDS), INTENT(IN)                                   :: F
  !! An instance of the KORC derived type FIELDS.
  REAL(rp), DIMENSION(:), ALLOCATABLE 	:: R_samples
  !! Major radial location of all samples
  REAL(rp), DIMENSION(:), ALLOCATABLE 	:: PHI_samples
  !! Azimuithal angle of all samples
  REAL(rp), DIMENSION(:), ALLOCATABLE 	:: Z_samples
  !! Vertical location of all samples
  REAL(rp), DIMENSION(:), ALLOCATABLE 	:: P_samples
  !! Magnitude of momentum of all samples
  REAL(rp), DIMENSION(:), ALLOCATABLE 	:: T_samples
  !! Pitch angle of all samples
  REAL(rp), DIMENSION(:), ALLOCATABLE   :: mom
  !! Magnitude of momentum of samples on individual mpi process
  REAL(rp) 				:: psi_max_buff
  !! Value of buffer above desired maximum argument of 2D Gaussian spatial
  !! profile
  REAL(rp) 				:: minmax
  !! Temporary variable used for setting buffers
  REAL(rp) 				:: max_p
  !! Maximum domain for momentum sampling including buffer
  REAL(rp) 				:: min_p
  !! Minimum domain for momentum sampling including buffer
  REAL(rp) 				:: max_pitch_angle
  !! Maximum domain for pitch angle sampling including buffer
  REAL(rp) 				:: min_pitch_angle
  !! Minimum domain for pitch angle sampling including buffer
  REAL(rp) 				:: theta_rad
  !! Angle of rotation of 2D Gaussian spatial distribution in radians
  REAL(rp) 				:: R_buffer
  !! Previous sample of R location
  REAL(rp) 				:: Z_buffer
  !! Previous sample of Z location
  REAL(rp) 				:: P_buffer
  !! Previous sample of momentum
  REAL(rp) 				:: T_buffer
  !! Previous sample of pitch angle
  REAL(rp) 				:: R_test
  !! Present sample of R location
  REAL(rp) 				:: Z_test
  !! Present sample of Z location
  REAL(rp) 				:: P_test
  !! Present sample of momentum
  REAL(rp) 				:: T_test
  !! Present sample of pitch angle
  REAL(rp) 				:: psi0
  !! Previous value of 2D Gaussian argument based on R_buffer, Z_buffer
  REAL(rp) 				:: psi1
  !! Present value of 2D Gaussian argument based on R_test, Z_test
  REAL(rp) 				:: fRE0
  !! Evaluation of Avalanche distribution with previous sample
  REAL(rp) 				:: fRE1
  !! Evaluation of Avalanche distribution with present sample
  REAL(rp) 				:: rand_unif
  !! Uniform random variable [0,1]
  REAL(rp) 				:: ratio
  !! MH selection criteria
  INTEGER				:: nsamples
  !! Total number of samples to be distributed over all mpi processes
  INTEGER 				:: ii
  !! Sample iterator.
  INTEGER 				:: mpierr
  !! mpi error indicator

  ALLOCATE(mom(spp%ppp))

  nsamples = spp%ppp*params%mpi_params%nmpi

  psi_max_buff = spp%psi_max*1.1_rp

  theta_rad=C_PI*spp%theta_gauss/180.0_rp

  ! buffer at minimum p boundary
  do ii=1_idef,INT(minmax_buffer_size,idef)
     minmax = aval_params%min_p - REAL(ii,rp)*(aval_params%max_p- &
       aval_params%min_p)/100_rp
     if (minmax.GT.0.0_rp) then
        min_p = minmax
     end if
  end do

  ! buffer at maximum p boundary
  max_p = aval_params%max_p + minmax_buffer_size*(aval_params%max_p- &
       aval_params%min_p)/100_rp

  ! buffer at minimum pitch angle boundary
  if (aval_params%min_pitch_angle.GE.korc_zero) then
     do ii=1_idef,INT(minmax_buffer_size,idef)
        minmax = aval_params%min_pitch_angle - REAL(ii,rp)* &
             (aval_params%max_pitch_angle-aval_params%min_pitch_angle)/100_rp
        if (minmax.GT.0.0_rp) then
           min_pitch_angle = minmax
        end if
     end do
  else
     min_pitch_angle = aval_params%min_pitch_angle
  end if

  ! buffer at maximum pitch angle boundary
  do ii=1_idef,INT(minmax_buffer_size,idef)
     minmax = aval_params%max_pitch_angle + REAL(ii,rp)* &
          (aval_params%max_pitch_angle-aval_params%min_pitch_angle)/100_rp
     if (minmax.LE.180.0_rp) then
        max_pitch_angle = minmax
     end if
  end do

  if (params%mpi_params%rank.EQ.0_idef) then
     ALLOCATE(R_samples(nsamples))
     ! Number of samples to distribute among all MPI processes
     ALLOCATE(PHI_samples(nsamples))
     ! Number of samples to distribute among all MPI processes
     ALLOCATE(Z_samples(nsamples))
     ! Number of samples to distribute among all MPI processes
     ALLOCATE(P_samples(nsamples))
     ! Number of samples to distribute among all MPI processes
     ALLOCATE(T_samples(nsamples))
     ! Number of samples to distribute among all MPI processes

     ! Transient !

     R_buffer = spp%Ro
     Z_buffer = spp%Zo

     call RANDOM_NUMBER(rand_unif)
     T_buffer = min_pitch_angle + (max_pitch_angle  &
          - min_pitch_angle)*rand_unif

     call RANDOM_NUMBER(rand_unif)
     P_buffer = min_p + (max_p - min_p)*rand_unif

!     write(output_unit_write,'("length norm: ",E17.10)') params%cpp%length

     ii=1_idef
     do while (ii .LE. 1000_idef)

!        write(output_unit_write,'("burn:",I15)') ii

        R_test = R_buffer + random_norm(0.0_rp,aval_params%dR)
        Z_test = Z_buffer + random_norm(0.0_rp,aval_params%dZ)
        P_test = P_buffer + random_norm(0.0_rp,aval_params%dp)
        T_test = T_buffer + random_norm(0.0_rp,aval_params%dth)

        ! Test that pitch angle and momentum are within chosen boundary
        do while ((T_test .GT. aval_params%max_pitch_angle).OR. &
             (T_test .LT. aval_params%min_pitch_angle))
           T_test = T_buffer + random_norm(0.0_rp,aval_params%dth)
        end do

        do while ((P_test.LT.aval_params%min_p).OR. &
             (P_test.GT.aval_params%max_p))
           P_test = P_buffer + random_norm(0.0_rp,aval_params%dp)
        end do

        ! initialize 2D gaussian argument and distribution function, or
        ! copy from previous sample
        if (ii==1) then
           psi0=PSI_ROT(R_buffer,spp%Ro,spp%sigmaR,Z_buffer,spp%Zo, &
                spp%sigmaZ,theta_rad)

           ! Repetedly put location of sample into first entry of spp%vars%Y,
           ! beacause spp%vas%X isn't filled until the end of this subrouting.
           ! This allows us to use the machinery for calling PSPLINES
           ! interpolation routines here also.
           spp%vars%Y(1,1)=R_buffer
           spp%vars%Y(1,2)=0
           spp%vars%Y(1,3)=Z_buffer

           call get_profiles(params,spp%vars,P,F)

!           write(output_unit_write,'("ne",E17.10)') spp%vars%ne(1)
!           write(output_unit_write,'("Te",E17.10)') spp%vars%Te(1)
!           write(output_unit_write,'("Zeff",E17.10)') spp%vars%Zeff(1)

           ! Update avalanche parameters with interpolated fields to be used
           ! in call to avalanche distribution function
           call update_avalanche_params(params,spp%vars)

           fRE0=fRE(cos(deg2rad(T_buffer)),P_buffer)
        else
           psi0=psi1
           fRE0=fRE1
        end if

        psi1=PSI_ROT(R_test,spp%Ro,spp%sigmaR,Z_test,spp%Zo, &
             spp%sigmaZ,theta_rad)

        spp%vars%Y(1,1)=R_test
        spp%vars%Y(1,2)=0
        spp%vars%Y(1,3)=Z_test

        call get_profiles(params,spp%vars,P,F)

        call update_avalanche_params(params,spp%vars)

        fRE1=fRE(COS(deg2rad(T_test)),P_test)

!        write(output_unit_write,'("psi0: ",E17.10)') psi0
!        write(output_unit_write,'("psi1: ",E17.10)') psi1

        ! Calculate acceptance ratio for MH algorithm. fRE function
        ! incorporates p^2 factor of spherical coordinate Jacobian
        ! for velocity phase space, factors of sin(pitch angle) for velocity
        ! phase space and cylindrical coordinate Jacobian R for spatial
        ! phase space incorporated here.
        ratio = indicator(psi1,spp%psi_max)*R_test*EXP(-psi1)* &
             sin(deg2rad(T_test))*fRE1/(R_buffer*EXP(-psi0)* &
             sin(deg2rad(T_buffer))*fRE0)

        if (ratio .GE. 1.0_rp) then
           R_buffer = R_test
           Z_buffer = Z_test
           P_buffer = P_test
           T_buffer = T_test
           ii = ii + 1_idef
        else
           call RANDOM_NUMBER(rand_unif)
           if (rand_unif .LT. ratio) then
              R_buffer = R_test
              Z_buffer = Z_test
              P_buffer = P_test
              T_buffer = T_test
              ii = ii + 1_idef
           end if
        end if
     end do
     ! Transient !

     ii=1_idef
     do while (ii .LE. nsamples)

!        write(output_unit_write,'("sample:",I15)') ii

        if (modulo(ii,10000).eq.0) then
           write(output_unit_write,'("Sample: ",I10)') ii
        end if

        R_test = R_buffer + random_norm(0.0_rp,aval_params%dR)
        Z_test = Z_buffer + random_norm(0.0_rp,aval_params%dZ)
        P_test = P_buffer + random_norm(0.0_rp,aval_params%dp)
        T_test = T_buffer + random_norm(0.0_rp,aval_params%dth)

        ! Selection boundary is set with buffer region
        do while ((T_test .GT. max_pitch_angle).OR. &
             (T_test .LT. min_pitch_angle))
           if (T_test.lt.0) then
              T_test=abs(T_test)
              exit
           end if
           T_test = T_buffer + random_norm(0.0_rp,aval_params%dth)
        end do

        do while ((P_test.LT.min_p).OR.(P_test.GT.max_p))
           if (P_test.lt.0) then
              P_test=abs(P_test)
              exit
           end if
           P_test = P_buffer + random_norm(0.0_rp,aval_params%dp)
        end do

        psi0=psi1
        fRE0=fRE1

        psi1=PSI_ROT(R_test,spp%Ro,spp%sigmaR,Z_test,spp%Zo, &
             spp%sigmaZ,theta_rad)

        spp%vars%Y(1,1)=R_test
        spp%vars%Y(1,2)=0
        spp%vars%Y(1,3)=Z_test

        call get_profiles(params,spp%vars,P,F)

        call update_avalanche_params(params,spp%vars)

        fRE1=fRE(COS(deg2rad(T_test)),P_test)

        ratio = indicator(psi1,psi_max_buff)*R_test*EXP(-psi1)* &
             sin(deg2rad(T_test))*fRE1/(R_buffer*EXP(-psi0)* &
             sin(deg2rad(T_buffer))*fRE0)

        if (ratio .GE. 1.0_rp) then
           R_buffer = R_test
           Z_buffer = Z_test
           P_buffer = P_test
           T_buffer = T_test
        else
           call RANDOM_NUMBER(rand_unif)
           if (rand_unif .LT. ratio) then
              R_buffer = R_test
              Z_buffer = Z_test
              P_buffer = P_test
              T_buffer = T_test
           end if
        end if

        ! Only accept sample if it is within desired boundary, but
        ! add to MC above if within buffer. This helps make the boundary
        ! more defined.
        IF ((INT(indicator(psi1,spp%psi_max)).EQ.1).AND. &
             (P_buffer.LE.aval_params%max_p).AND. &
             (P_buffer.GE.aval_params%min_p).AND. &
             (T_buffer.LE.aval_params%max_pitch_angle).AND. &
             (T_buffer.GE.aval_params%min_pitch_angle)) THEN
           R_samples(ii) = R_buffer
           Z_samples(ii) = Z_buffer
           P_samples(ii) = P_buffer
           T_samples(ii) = T_buffer
           ! Sample phi location uniformly
           call RANDOM_NUMBER(rand_unif)
           PHI_samples(ii) = 2.0_rp*C_PI*rand_unif
           ii = ii + 1_idef
        END IF

     end do

!  if (minval(R_samples(:)).lt.1._rp/params%cpp%length) stop 'error with sample'
!  write(output_unit_write,'("R_sample: ",E17.10)') R_samples(:)*params%cpp%length

  end if

  CALL MPI_SCATTER(R_samples*cos(PHI_samples),spp%ppp,MPI_REAL8, &
       spp%vars%X(:,1),spp%ppp,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
  CALL MPI_SCATTER(R_samples*sin(PHI_samples),spp%ppp,MPI_REAL8, &
       spp%vars%X(:,2),spp%ppp,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
  CALL MPI_SCATTER(Z_samples,spp%ppp,MPI_REAL8, &
       spp%vars%X(:,3),spp%ppp,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
  CALL MPI_SCATTER(P_samples,spp%ppp,MPI_REAL8, &
       mom,spp%ppp,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
  CALL MPI_SCATTER(T_samples,spp%ppp,MPI_REAL8, &
       spp%vars%eta,spp%ppp,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)

  call MPI_BARRIER(MPI_COMM_WORLD,mpierr)

!  write(output_unit_write,'("X_X: ",E17.10)') spp%vars%X(:,1)*params%cpp%length

  ! gamma is kept for each particle, not the momentum
  spp%vars%g = SQRT(1.0_rp + mom**2)

  if (params%orbit_model(1:2).eq.'GC') call cart_to_cyl(spp%vars%X,spp%vars%Y)

!  write(output_unit_write,'("Y_R: ",E17.10)') spp%vars%Y(:,1)*params%cpp%length

!  if (minval(spp%vars%Y(:,1)).lt.1._rp/params%cpp%length) stop 'error with avalanche'

  DEALLOCATE(mom)
  if (params%mpi_params%rank.EQ.0_idef) then
     DEALLOCATE(R_samples)
     DEALLOCATE(Z_samples)
     DEALLOCATE(PHI_samples)
     DEALLOCATE(P_samples)
     DEALLOCATE(T_samples)
  end if

end subroutine Avalanche_4D

SUBROUTINE save_avalanche_params(params)
  TYPE(KORC_PARAMS), INTENT(IN) :: params
  CHARACTER(MAX_STRING_LENGTH) :: filename
  CHARACTER(MAX_STRING_LENGTH) :: gname
  CHARACTER(MAX_STRING_LENGTH), DIMENSION(:), ALLOCATABLE :: attr_array
  CHARACTER(MAX_STRING_LENGTH) :: dset
  CHARACTER(MAX_STRING_LENGTH) :: attr
  INTEGER(HID_T) :: h5file_id
  INTEGER(HID_T) :: group_id
  INTEGER :: h5error
  REAL(rp) :: units

  if (params%mpi_params%rank .EQ. 0) then
     filename = TRIM(params%path_to_outputs) // "avalanche_parameters.h5"
     call h5fcreate_f(TRIM(filename), H5F_ACC_TRUNC_F, h5file_id, h5error)

     gname = "pdf_params"
     call h5gcreate_f(h5file_id, TRIM(gname), group_id, h5error)

     dset = TRIM(gname) // "/max_pitch_angle"
     attr = "Maximum pitch angle in avalanche PDF (degrees)"
     call save_to_hdf5(h5file_id,dset,aval_params%max_pitch_angle,attr)

     dset = TRIM(gname) // "/min_pitch_angle"
     attr = "Minimum pitch angle in avalanche PDF (degrees)"
     call save_to_hdf5(h5file_id,dset,aval_params%min_pitch_angle,attr)

     dset = TRIM(gname) // "/min_energy"
     attr = "Minimum energy in avalanche PDF (eV)"
     units = 1.0_rp/C_E
     call save_to_hdf5(h5file_id,dset,units*aval_params%min_energy,attr)

     dset = TRIM(gname) // "/max_energy"
     attr = "Maximum energy in avalanche PDF (eV)"
     units = 1.0_rp/C_E
     call save_to_hdf5(h5file_id,dset,units*aval_params%max_energy,attr)

     dset = TRIM(gname) // "/max_p"
     attr = "Maximum momentum in avalanche PDF (me*c^2)"
     call save_to_hdf5(h5file_id,dset,aval_params%max_p,attr)

     dset = TRIM(gname) // "/min_p"
     attr = "Maximum momentum in avalanche PDF (me*c^2)"
     call save_to_hdf5(h5file_id,dset,aval_params%min_p,attr)

     dset = TRIM(gname) // "/ne"
     attr = "Background electron density (m^-3)"
     call save_to_hdf5(h5file_id,dset,aval_params%ne,attr)

     dset = TRIM(gname) // "/Zeff"
     attr = "Effective atomic number of ions."
     call save_to_hdf5(h5file_id,dset,aval_params%Zeff,attr)

     dset = TRIM(gname) // "/Ec"
     attr = "Critical electric field in (V/m)"
     call save_to_hdf5(h5file_id,dset,aval_params%Ec,attr)

     dset = TRIM(gname) // "/Epar"
     attr = "Parallel electric field in (V/m)"
     call save_to_hdf5(h5file_id,dset,aval_params%Epar,attr)

     dset = TRIM(gname) // "/Te"
     attr = "Background electron temperature (eV)"
     units = 1.0_rp/C_E
     call save_to_hdf5(h5file_id,dset,units*aval_params%Te,attr)

     dset = TRIM(gname) // "/lambda_D"
     attr = "Debye length (m)"
     call save_to_hdf5(h5file_id,dset,aval_params%lD,attr)

     dset = TRIM(gname) // "/bmin"
     attr = "Maximum approach radius (m)"
     call save_to_hdf5(h5file_id,dset,aval_params%bmin,attr)

     dset = TRIM(gname) // "/Clog"
     attr = "Coulomb logarithm"
     call save_to_hdf5(h5file_id,dset,aval_params%CoulombLog,attr)

     dset = TRIM(gname) // "/Tau"
     attr = "Collision time (s)"
     call save_to_hdf5(h5file_id,dset,aval_params%Tau,attr)

     call h5gclose_f(group_id, h5error)

     call h5fclose_f(h5file_id, h5error)
  end if
END SUBROUTINE save_avalanche_params

END MODULE korc_avalanche