      SUBROUTINE MF_RDERIV

c     Differential equations for (R+1)/C where R is the reflection
c     matrix as defined by Budden.  The equations are derived from the
c     differential equations for R given by Budden in Proc. Roy. Soc.
c     (London), A227, pp.516-537 (1955).  Storage into the array
c     'RMTRX' is made so that the equations may be used with either
c     the main set of integration variables, or with the comparison
c     set, X.  Differential equations for the derivatives of (R+1)/C
c     wrt c=COS(THETA) are also used if IDERIV is set non-zero.  Note
c     that the variable called 'R' in this routine is actually (R+1)/C.

      implicit complex (a-h,o-z)

      real           omega,wavenr
      complex        mikov2

      common/mf_flag/iexact,iovflo,kexact,lowg,nodivd,noevct,
     &               nofinl,nointg,nomesh,notlin
     &      /mf_mode/theta,c,s,csq,ssq,omega,wavenr,ideriv
     &      /mf_rmtx/r11,r21,r12,r22,dr11dc,dr21dc,dr12dc,dr22dc,dr11dh,
     &               dr21dh,dr12dh,dr22dh,dr11ch,dr21ch,dr12ch,dr22ch
     &      /mf_rntg/r(8),drdh(8),roe(8),rnd(5)
     &      /mf_smtx/a11,a22,b11,b12,b22,c11,c21,c22,d11,d21,d12,d22,
     &               db11dc,db22dc,dc11dc,dc22dc,dd11dc,dd21dc,dd12dc
     &      /mf_xntg/x(4),dxdh(4)

      dimension      rmtrx(8),deriv(8),rtm(4),drtmdc(4)

      equivalence   (rmtrx(1),r11),(deriv(1),dr11dh)

      call MF_LGTORI (r,rtm,drtmdc,ideriv)

      if (iovflo .ne. 0) RETURN

      mikov2=CMPLX(0.,-.5*wavenr)

      d11r11=d11*r11
      d12r21=d12*r21
      d21r12=d21*r12
      d22r22=d22*r22
      r11r22=r11*r22
      r12r21=r12*r21

      dr11dh=mikov2*(a11+(b11+c11+d11r11+d12r21+d21r12)*r11
     &              +b12*r21+c21*r12+d22*r12r21)
      dr21dh=mikov2*((b22+c11+d11r11+d12r21+d22r22)*r21
     &               +c21*r22+d21*r11r22)
      dr12dh=mikov2*((b11+c22+d11r11+d21r12+d22r22)*r12
     &               +b12*r22+d12*r11r22)
      dr22dh=mikov2*(a22+(b22+c22+d12r21+d21r12+d22r22)*r22
     &              +d11*r12r21)

      if (ideriv .eq. 1) then

         g11r11=dd11dc*r11
         g12r21=dd12dc*r21
         g21r12=dd21dc*r12

         d21r11=d21*r11
         d12r11=d12*r11
         d11r21=d11*r21
         d22r21=d22*r21
         d11r12=d11*r12
         d22r12=d22*r12
         d21r22=d21*r22
         d12r22=d12*r22

         dr11ch=mikov2*((db11dc+dc11dc+g11r11+g12r21+g21r12)*r11
     &                 +(b11+c11+d11r11+d11r11+d12r21+d21r12)*dr11dc
     &                 +(d12r11+b12+d22r12)*dr21dc
     &                 +(d21r11+c21+d22r21)*dr12dc)
         dr21ch=mikov2*((db22dc+dc11dc+g11r11+g12r21)*r21+dd21dc*r11r22
     &                 +(d11r21+d21r22)*dr11dc
     &                 +(b22+c11+d11r11+d12r21+d12r21+d22r22)*dr21dc
     &                 +(d22r21+c21+d21r11)*dr22dc)
         dr12ch=mikov2*((db11dc+dc22dc+g11r11+g21r12)*r12+dd12dc*r11r22
     &                 +(d11r12+d12r22)*dr11dc
     &                 +(b11+c22+d11r11+d21r12+d21r12+d22r22)*dr12dc
     &                 +(d22r12+b12+d12r11)*dr22dc)
         dr22ch=mikov2*((db22dc+dc22dc+g12r21+g21r12)*r22+dd11dc*r12r21
     &                 +(d12r22+d11r12)*dr21dc
     &                 +(d21r22+d11r21)*dr12dc
     &                 +(b22+c22+d12r21+d21r12+d22r22+d22r22)*dr22dc)

      end if

      call MF_TODLGS (drdh,rtm,drtmdc,ideriv)

      RETURN
      END      ! MF_RDERIV


!------------------------------------------------------------------------------
!
! `knock` Source File
!
! knock.f90 source function file. This file contains the subroutine for
! placing the ion currently being fired at the surface within its random
! position distribution. It also assigns the ion's velocity vector, according
! to the assigned beam energy and angle of incidence.
!
!------------------------------------------------------------------------------

MODULE knockmod

  USE prms
  USE data

CONTAINS

!knock(knc,lt) assigns the 'knc'th ion fired at timestep lt to its firing location
  SUBROUTINE knock(knc,lt)

    integer            ::knc, ierr,lt
    real            :: knock_vel
    real            :: ran1
    integer         :: ranindex
    real            :: dr, dx, dy

    knock_vel = 1663.6334*SQRT(eV)  !this is for Ga, in m/s

    dr = TAN(phiz*Pi/180)*(knockz*Lb(3)/10 - Lb(3)/10)
    dx = dr*COS(phixy*Pi/180)*SIN(phiz*Pi/180)
    dy = dr*SIN(phixy*Pi/180)*SIN(phiz*Pi/180)

    if (myid .eq. 0) then
        ranindex = NINT(ran1(ranseed)*Nrand)
        print*,'             |'
        print*,'           .\:/.'
!        print*,'KNOCK    --=>*<=--    RANINDEX', ranindex, 'ion ID', Nsg+knc
        print*,'KNOCK    --=>*<=--    ion ID: ', Nsg+knc
        print*,'           //:\\'
    end if

    call MPI_BCAST(ranindex,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)

    V(Nsg+knc,1) = knock_vel*COS(phixy*Pi/180)*SIN(phiz*Pi/180)
    V(Nsg+knc,2) = knock_vel*SIN(phixy*Pi/180)*SIN(phiz*Pi/180)
    V(Nsg+knc,3) = -1.0*knock_vel*COS(phiz*Pi/180)

    X(Nsg+knc,1) = Xrand(ranindex,1)+Lb(1)/2.0-dx
    X(Nsg+knc,2) = Xrand(ranindex,2)+Lb(2)/2.0-dy
    X(Nsg+knc,3) = knockz*Lb(3)/10.0

  END SUBROUTINE knock

END MODULE knockmod


      subroutine sigma_to_p (ptop, psfc, sigma, p )

c     The purpose of this routine is to take an input sigma level, and its
c     associated pressure top and surface pressure and convert that
c     to pressure dependent on the reference level pressure.

      real ptop
      real psfc
      real sigma
      real p

      p = sigma*(psfc-ptop) + ptop

      return
      end


SUBROUTINE h5kalk(n,nl,L,Br,D,M,A33,B33,A55,B55,C55,I55,k,omega,rho,g,H5)
  IMPLICIT NONE
  !Erklærer variable
  INTEGER::n,nl,i,j
  REAL,DIMENSION(1:nl)::L,Br,D,M,C33,I55,C55
  DOUBLE PRECISION,DIMENSION(1:n)::k,omega
  REAL,DIMENSION(1:n,1:nl)::A33,B33,A55,B55
DOUBLE PRECISION,DIMENSION(1:n,1:nl)::F5A1,F5A2,eta5nevner,F5A
DOUBLE PRECISION,DIMENSION(1:n,1:nl)::eta5A,H5
REAL rho,g

!Beregner eksitasjonskraft F5A
DO i=1,n
   DO j=1,nl
      F5A1(i,j)= (rho*g*EXP(k(i)*(-D(j)))*Br(j) &
           + omega(i)**2 * (A33(i,j)/L(i,j))*exp(k(i)*(-D(j)/2.0)) )

      F5A2(i,j)= (2.0/k(i)) * SIN(k(i)*L(j) / 2.0) - L(j)*COS(k(i)*L(j)/2.0))

      eta5nevner(i,j) = k(i)* SQRT( (C33(j) - (I55(j) &
           + A55(i,j)) * omega(i)**2 )**2 + ( B55(i,j)*omega(i) )**2)
      F5A (i,j) = F5A1 (i,j) * F5A2 (i,j)
   END DO
END DO

!Beregner eta5A
DO i=1,ny
   DO j=1,nl
      eta5A(i,j) = (F5A (i,j)) / eta5nevner(i,j)
   END DO
END DO

!Beregner transferfunksjonen, som er eta5A absolutt
DO i=1,n
   DO j=1,nl
      H5(i,j) = ABS(eta5A(i,j) / k(i) )
   END DO
END DO

!Bygger fil for å sjekke faktorene i eta5-uttrykket
OPEN(52,FILE="eta5sjekk.txt", ACTION="WRITE", STATUS="UNKNOWN")
DO i=1,n
   WRITE(52,*), F5A(i,1), eta5nevner(i,1)
END DO
CLOSE(52)

!Skriver resultat til fil for sjekk/ plott
OPEN(42,FILE="eta5plot.txt",ACTION="WRITE",STATUS="UNKNOWN")
DO i=1,n
   WRITE(42,*) omega(i),eta5A(i,1),eta5A(i,2)
END DO
CLOSE(42)

RETURN
END SUBROUTINE


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! 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.

!>    @brief linear system solver [x]:=[A^-1]x[b], dense matrix (quadratic)
!>    @param[in] NIJK system size
!>    @param[in] NRHS number of right sides/solutions
!>    @param[in] A system matrix
!>    @param[in] B rigth side
!>    @param[out] X solution
!#>   @details
      SUBROUTINE dense_solve(nijk,nrhs,a,b,x)
        use mod_linfos
        IMPLICIT NONE
        INTEGER nijk, nrhs, isnull
        INTEGER, ALLOCATABLE :: pivots(:)
        DOUBLE PRECISION, ALLOCATABLE :: tmp(:), tmpm(:,:)
        INTEGER error
        DOUBLE PRECISION a(nijk,nijk), b(nijk,nrhs)
        DOUBLE PRECISION x(nijk,nrhs), enough, enough2

        IF ((8.0D0*dble(2*nijk+nijk*nijk))>2.0D9) THEN
          WRITE(*,'(A,A,F9.4,A)') &
            'Error: array to large for direct dense', &
            ' matrix solver (', 8.0D0*dble(2*nijk+nijk*nijk)/1024.0D0 &
            **3, ' GBytes).'
          STOP
        END IF

        ALLOCATE(pivots(nijk))
        ALLOCATE(tmp(nijk))
        ALLOCATE(tmpm(nijk,nijk))
        error = 0
        CALL set_ival(nijk,0,pivots)

!     right side to [X]
        CALL dcopy(nijk*nrhs,b,1,x,1)
!     copy matrix
        CALL dcopy(nijk*nijk,a,1,tmpm,1)

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

!     solve dense matrix
        CALL dgesv(nijk,nrhs,a,nijk,pivots,x,nijk,error)

        IF (error>0) THEN
          WRITE(*,*) ' dense PLU: ', error, 'errors were found.'
        ELSE IF (linfos(4)>=1) THEN
!aw        write(*,*) ' dense PLU finished.'
        END IF

        IF ((linfos(4)>=1) .AND. (nrhs==1)) THEN
!       MVP
!       [tmp]==[r]:=[A]x[x]
          CALL dgemv('N',nijk,nijk,1.0D0,tmpm,nijk,x,1,0.0D0,tmp,1)

          enough = 0.0D0
          isnull = 0
          enough2 = 0.0D0
          CALL s_ddot(nijk,b,b,enough)
          CALL test_zero(enough,1,isnull)
          IF (isnull/=1) THEN
            CALL s_ddot(nijk,tmp,tmp,enough2)
            enough2 = abs(enough-enough2)/(enough)
          END IF

!       [r]:=[w]-[A]x[x]
          CALL dscal(nijk,-1.0D0,tmp,1)
          CALL daxpy(nijk,1.0D0,b,1,tmp,1)

          enough = 0.0D0
          CALL s_ddot(nijk,tmp,tmp,enough)
          WRITE(*,'(2(a,e12.5))') '   PLU: nrm2(R)', dsqrt(enough), &
            ' rel=', enough2
        END IF

!     restore matrix (only needed for debug)
        CALL dcopy(nijk*nijk,tmpm,1,a,1)

        DEALLOCATE(pivots)
        DEALLOCATE(tmp)
        DEALLOCATE(tmpm)

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

        RETURN
      END


! Run with -np 4 and s = 17, better use MPI_SUM.
program scan
    use mpi_f08
    implicit none
    type(MPI_Comm) :: comm
    integer :: my_rank, n_ranks, full_s, remainder, quotient, size, disp, b, e

    call MPI_Init()
    comm = MPI_COMM_WORLD
    call MPI_Comm_size(comm, n_ranks)
    call MPI_Comm_rank(comm, my_rank)

    if (my_rank == 0) read *, full_s
    call MPI_Bcast(full_s, 1, MPI_INTEGER, 0, comm)

    remainder = modulo(full_s, n_ranks)
    quotient  = (full_s - remainder) / n_ranks

    size = quotient + merge(1, 0, my_rank < remainder)
    disp = 0

    call MPI_Exscan(size, disp, 1, MPI_INTEGER, MPI_SUM, comm)
    b = disp + 1
    call MPI_Scan(size, e, 1, MPI_INTEGER, MPI_SUM, comm)

    call print_vals()

    call MPI_Finalize()

contains

    subroutine print_vals()
        integer :: rnk

        do rnk = 0, n_ranks - 1
            if (rnk == my_rank) then
                print '(3(a, i0))', "Rank ", rnk, ", b:e=", b, ":", e
            end if
            call MPI_Barrier(comm)
        end do
        if (my_rank == 0) print *
    end subroutine print_vals

end program scan


      subroutine rand(rnd)
c
c     + + + PURPOSE + + +
c    This subroutine generates random number between 0 and 1 using
c    the multiplicative congruential method. It is called from FN
c    PSIINV to restart at a random value for variable U when function
c    PSI is zero.
c
c     Called from PSIINV.
c     Author(s): Shirley, Stone
c     Reference in User Guide:
c
c     Changes:
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/25/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real rnd
c
c     + + + ARGUMENT DEFINITIONS + + +
c     rnd    - random number between 0 and 1.
c
c     + + + PARAMETERS + + +
c
c     + + + COMMON BLOCKS + + +
      include 'crndm.inc'
c       read: aa,mrnd
c     modify: xrand
c
c     + + + LOCAL VARIABLES + + +
      double precision u
      real v
c
c     + + + LOCAL DEFINITIONS + + +
c     u      - xrand/MRND
c     v      - the whole-number part of U
c
c     + + + SAVES + + +
      save /rndm/
c
c     + + + END SPECIFICATIONS + + +
c
c
c***********************************************************************
c
c     This routine computes random numbers by a multiplicative
c     congruential method:
c
c        xrand = AA*(xrand mod MRND),  RND = xrand/MRND
c
c***********************************************************************
c Note: BGNRND should be used to initialize xrand.  The check made there
c       (that AA*MRND and AA can be represented exactly in xrand and U),
c       ensures that sucessive values of xrand can be calculated exactly.
c***********************************************************************
c
      xrand = aa * xrand
c
c------find xrand mod MRND
      u = xrand / mrnd
      v = aint(u)
cWarning from ftnchek
c     65       v = aint(u)
c     ^
cWarning near line 65 col 9: dble truncated to real
      xrand = xrand - v * mrnd
c
      if (xrand.lt.0.d0) then
        v = v - 1.
        xrand = xrand + mrnd
      end if
c
      rnd = u - v
cWarning from ftnchek
c     73       rnd = u - v
c     ^
cWarning near line 73 col 11: dble truncated to real
c
      return
      end


MODULE Circle
USE Constants, ONLY : ZOOM
!---------------------------------------------------------------------
!
!  Module containing definitions of variables needed to
!  compute the area of a circle of radius r
!
!---------------------------------------------------------------------
   REAL, PARAMETER :: Pi = 3.1415927 * ZOOM
   REAL :: radius
END MODULE Circle


!*==sggbal.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SGGBAL
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SGGBAL + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
!                          RSCALE, WORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOB
!       INTEGER            IHI, ILO, INFO, LDA, LDB, N
!       ..
!       .. Array Arguments ..
!       REAL               A( LDA, * ), B( LDB, * ), LSCALE( * ),
!      $                   RSCALE( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SGGBAL balances a pair of general real matrices (A,B).  This
!> involves, first, permuting A and B by similarity transformations to
!> isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
!> elements on the diagonal; and second, applying a diagonal similarity
!> transformation to rows and columns ILO to IHI to make the rows
!> and columns as close in norm as possible. Both steps are optional.
!>
!> Balancing may reduce the 1-norm of the matrices, and improve the
!> accuracy of the computed eigenvalues and/or eigenvectors in the
!> generalized eigenvalue problem A*x = lambda*B*x.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOB
!> \verbatim
!>          JOB is CHARACTER*1
!>          Specifies the operations to be performed on A and B:
!>          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
!>                  and RSCALE(I) = 1.0 for i = 1,...,N.
!>          = 'P':  permute only;
!>          = 'S':  scale only;
!>          = 'B':  both permute and scale.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrices A and B.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the input matrix A.
!>          On exit,  A is overwritten by the balanced matrix.
!>          If JOB = 'N', A is not referenced.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is REAL array, dimension (LDB,N)
!>          On entry, the input matrix B.
!>          On exit,  B is overwritten by the balanced matrix.
!>          If JOB = 'N', B is not referenced.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] ILO
!> \verbatim
!>          ILO is INTEGER
!> \endverbatim
!>
!> \param[out] IHI
!> \verbatim
!>          IHI is INTEGER
!>          ILO and IHI are set to integers such that on exit
!>          A(i,j) = 0 and B(i,j) = 0 if i > j and
!>          j = 1,...,ILO-1 or i = IHI+1,...,N.
!>          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
!> \endverbatim
!>
!> \param[out] LSCALE
!> \verbatim
!>          LSCALE is REAL array, dimension (N)
!>          Details of the permutations and scaling factors applied
!>          to the left side of A and B.  If P(j) is the index of the
!>          row interchanged with row j, and D(j)
!>          is the scaling factor applied to row j, then
!>            LSCALE(j) = P(j)    for J = 1,...,ILO-1
!>                      = D(j)    for J = ILO,...,IHI
!>                      = P(j)    for J = IHI+1,...,N.
!>          The order in which the interchanges are made is N to IHI+1,
!>          then 1 to ILO-1.
!> \endverbatim
!>
!> \param[out] RSCALE
!> \verbatim
!>          RSCALE is REAL array, dimension (N)
!>          Details of the permutations and scaling factors applied
!>          to the right side of A and B.  If P(j) is the index of the
!>          column interchanged with column j, and D(j)
!>          is the scaling factor applied to column j, then
!>            LSCALE(j) = P(j)    for J = 1,...,ILO-1
!>                      = D(j)    for J = ILO,...,IHI
!>                      = P(j)    for J = IHI+1,...,N.
!>          The order in which the interchanges are made is N to IHI+1,
!>          then 1 to ILO-1.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (lwork)
!>          lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
!>          at least 1 when JOB = 'N' or 'P'.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realGBcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  See R.C. WARD, Balancing the generalized eigenvalue problem,
!>                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE SGGBAL(Job,N,A,Lda,B,Ldb,Ilo,Ihi,Lscale,Rscale,Work,   &
     &                  Info)
      IMPLICIT NONE
!*--SGGBAL181
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Job
      INTEGER Ihi , Ilo , Info , Lda , Ldb , N
!     ..
!     .. Array Arguments ..
      REAL A(Lda,*) , B(Ldb,*) , Lscale(*) , Rscale(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , HALF , ONE
      PARAMETER (ZERO=0.0E+0,HALF=0.5E+0,ONE=1.0E+0)
      REAL THREE , SCLFAC
      PARAMETER (THREE=3.0E+0,SCLFAC=1.0E+1)
!     ..
!     .. Local Scalars ..
      INTEGER i , icab , iflow , ip1 , ir , irab , it , j , jc , jp1 ,  &
     &        k , kount , l , lcab , lm1 , lrab , lsfmax , lsfmin , m , &
     &        nr , nrp2
      REAL alpha , basl , beta , cab , cmax , coef , coef2 , coef5 ,    &
     &     cor , ew , ewc , gamma , pgamma , rab , sfmax , sfmin , sum ,&
     &     t , ta , tb , tc
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ISAMAX
      REAL SDOT , SLAMCH
      EXTERNAL LSAME , ISAMAX , SDOT , SLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL SAXPY , SSCAL , SSWAP , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , INT , LOG10 , MAX , MIN , REAL , SIGN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      Info = 0
      IF ( .NOT.LSAME(Job,'N') .AND. .NOT.LSAME(Job,'P') .AND.          &
     &     .NOT.LSAME(Job,'S') .AND. .NOT.LSAME(Job,'B') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -4
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -6
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SGGBAL',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) THEN
         Ilo = 1
         Ihi = N
         RETURN
      ENDIF
!
      IF ( N==1 ) THEN
         Ilo = 1
         Ihi = N
         Lscale(1) = ONE
         Rscale(1) = ONE
         RETURN
      ENDIF
!
      IF ( LSAME(Job,'N') ) THEN
         Ilo = 1
         Ihi = N
         DO i = 1 , N
            Lscale(i) = ONE
            Rscale(i) = ONE
         ENDDO
         RETURN
      ENDIF
!
      k = 1
      l = N
!
      IF ( LSAME(Job,'S') ) GOTO 800
!
 100  lm1 = l - 1
      DO i = l , 1 , -1
         DO j = 1 , lm1
            jp1 = j + 1
            IF ( A(i,j)/=ZERO .OR. B(i,j)/=ZERO ) GOTO 150
         ENDDO
         j = l
         GOTO 200
!
 150     DO j = jp1 , l
            IF ( A(i,j)/=ZERO .OR. B(i,j)/=ZERO ) GOTO 300
         ENDDO
         j = jp1 - 1
!
 200     m = l
         iflow = 1
         GOTO 700
 300  ENDDO
!
 400  DO j = k , l
         DO i = k , lm1
            ip1 = i + 1
            IF ( A(i,j)/=ZERO .OR. B(i,j)/=ZERO ) GOTO 450
         ENDDO
         i = l
         GOTO 500
 450     DO i = ip1 , l
            IF ( A(i,j)/=ZERO .OR. B(i,j)/=ZERO ) GOTO 600
         ENDDO
         i = ip1 - 1
 500     m = k
         iflow = 2
         GOTO 700
 600  ENDDO
      GOTO 800
!
!     Permute rows M and I
!
 700  Lscale(m) = i
      IF ( i/=m ) THEN
         CALL SSWAP(N-k+1,A(i,k),Lda,A(m,k),Lda)
         CALL SSWAP(N-k+1,B(i,k),Ldb,B(m,k),Ldb)
      ENDIF
!
!     Permute columns M and J
!
      Rscale(m) = j
      IF ( j/=m ) THEN
         CALL SSWAP(l,A(1,j),1,A(1,m),1)
         CALL SSWAP(l,B(1,j),1,B(1,m),1)
      ENDIF
!
      IF ( iflow==1 ) THEN
!
!     Permute the matrices A and B to isolate the eigenvalues.
!
!     Find row with one nonzero in columns 1 through L
!
         l = lm1
         IF ( l/=1 ) GOTO 100
!
         Rscale(1) = ONE
         Lscale(1) = ONE
      ELSEIF ( iflow==2 ) THEN
!
!     Find column with one nonzero in rows K through N
!
         k = k + 1
         GOTO 400
      ENDIF
!
 800  Ilo = k
      Ihi = l
!
      IF ( LSAME(Job,'P') ) THEN
         DO i = Ilo , Ihi
            Lscale(i) = ONE
            Rscale(i) = ONE
         ENDDO
         RETURN
      ENDIF
!
      IF ( Ilo==Ihi ) RETURN
!
!     Balance the submatrix in rows ILO to IHI.
!
      nr = Ihi - Ilo + 1
      DO i = Ilo , Ihi
         Rscale(i) = ZERO
         Lscale(i) = ZERO
!
         Work(i) = ZERO
         Work(i+N) = ZERO
         Work(i+2*N) = ZERO
         Work(i+3*N) = ZERO
         Work(i+4*N) = ZERO
         Work(i+5*N) = ZERO
      ENDDO
!
!     Compute right side vector in resulting linear equations
!
      basl = LOG10(SCLFAC)
      DO i = Ilo , Ihi
         DO j = Ilo , Ihi
            tb = B(i,j)
            ta = A(i,j)
            IF ( ta/=ZERO ) ta = LOG10(ABS(ta))/basl
            IF ( tb/=ZERO ) tb = LOG10(ABS(tb))/basl
            Work(i+4*N) = Work(i+4*N) - ta - tb
            Work(j+5*N) = Work(j+5*N) - ta - tb
         ENDDO
      ENDDO
!
      coef = ONE/REAL(2*nr)
      coef2 = coef*coef
      coef5 = HALF*coef2
      nrp2 = nr + 2
      beta = ZERO
      it = 1
      DO
!
!     Start generalized conjugate gradient iteration
!
!
         gamma = SDOT(nr,Work(Ilo+4*N),1,Work(Ilo+4*N),1)               &
     &           + SDOT(nr,Work(Ilo+5*N),1,Work(Ilo+5*N),1)
!
         ew = ZERO
         ewc = ZERO
         DO i = Ilo , Ihi
            ew = ew + Work(i+4*N)
            ewc = ewc + Work(i+5*N)
         ENDDO
!
         gamma = coef*gamma - coef2*(ew**2+ewc**2) - coef5*(ew-ewc)**2
         IF ( gamma==ZERO ) EXIT
         IF ( it/=1 ) beta = gamma/pgamma
         t = coef5*(ewc-THREE*ew)
         tc = coef5*(ew-THREE*ewc)
!
         CALL SSCAL(nr,beta,Work(Ilo),1)
         CALL SSCAL(nr,beta,Work(Ilo+N),1)
!
         CALL SAXPY(nr,coef,Work(Ilo+4*N),1,Work(Ilo+N),1)
         CALL SAXPY(nr,coef,Work(Ilo+5*N),1,Work(Ilo),1)
!
         DO i = Ilo , Ihi
            Work(i) = Work(i) + tc
            Work(i+N) = Work(i+N) + t
         ENDDO
!
!     Apply matrix to vector
!
         DO i = Ilo , Ihi
            kount = 0
            sum = ZERO
            DO j = Ilo , Ihi
               IF ( A(i,j)/=ZERO ) THEN
                  kount = kount + 1
                  sum = sum + Work(j)
               ENDIF
               IF ( B(i,j)/=ZERO ) THEN
                  kount = kount + 1
                  sum = sum + Work(j)
               ENDIF
            ENDDO
            Work(i+2*N) = REAL(kount)*Work(i+N) + sum
         ENDDO
!
         DO j = Ilo , Ihi
            kount = 0
            sum = ZERO
            DO i = Ilo , Ihi
               IF ( A(i,j)/=ZERO ) THEN
                  kount = kount + 1
                  sum = sum + Work(i+N)
               ENDIF
               IF ( B(i,j)/=ZERO ) THEN
                  kount = kount + 1
                  sum = sum + Work(i+N)
               ENDIF
            ENDDO
            Work(j+3*N) = REAL(kount)*Work(j) + sum
         ENDDO
!
         sum = SDOT(nr,Work(Ilo+N),1,Work(Ilo+2*N),1)                   &
     &         + SDOT(nr,Work(Ilo),1,Work(Ilo+3*N),1)
         alpha = gamma/sum
!
!     Determine correction to current iteration
!
         cmax = ZERO
         DO i = Ilo , Ihi
            cor = alpha*Work(i+N)
            IF ( ABS(cor)>cmax ) cmax = ABS(cor)
            Lscale(i) = Lscale(i) + cor
            cor = alpha*Work(i)
            IF ( ABS(cor)>cmax ) cmax = ABS(cor)
            Rscale(i) = Rscale(i) + cor
         ENDDO
         IF ( cmax<HALF ) EXIT
!
         CALL SAXPY(nr,-alpha,Work(Ilo+2*N),1,Work(Ilo+4*N),1)
         CALL SAXPY(nr,-alpha,Work(Ilo+3*N),1,Work(Ilo+5*N),1)
!
         pgamma = gamma
         it = it + 1
         IF ( it>nrp2 ) EXIT
      ENDDO
!
!     End generalized conjugate gradient iteration
!
      sfmin = SLAMCH('S')
      sfmax = ONE/sfmin
      lsfmin = INT(LOG10(sfmin)/basl+ONE)
      lsfmax = INT(LOG10(sfmax)/basl)
      DO i = Ilo , Ihi
         irab = ISAMAX(N-Ilo+1,A(i,Ilo),Lda)
         rab = ABS(A(i,irab+Ilo-1))
         irab = ISAMAX(N-Ilo+1,B(i,Ilo),Ldb)
         rab = MAX(rab,ABS(B(i,irab+Ilo-1)))
         lrab = INT(LOG10(rab+sfmin)/basl+ONE)
         ir = Lscale(i) + SIGN(HALF,Lscale(i))
         ir = MIN(MAX(ir,lsfmin),lsfmax,lsfmax-lrab)
         Lscale(i) = SCLFAC**ir
         icab = ISAMAX(Ihi,A(1,i),1)
         cab = ABS(A(icab,i))
         icab = ISAMAX(Ihi,B(1,i),1)
         cab = MAX(cab,ABS(B(icab,i)))
         lcab = INT(LOG10(cab+sfmin)/basl+ONE)
         jc = Rscale(i) + SIGN(HALF,Rscale(i))
         jc = MIN(MAX(jc,lsfmin),lsfmax,lsfmax-lcab)
         Rscale(i) = SCLFAC**jc
      ENDDO
!
!     Row scaling of matrices A and B
!
      DO i = Ilo , Ihi
         CALL SSCAL(N-Ilo+1,Lscale(i),A(i,Ilo),Lda)
         CALL SSCAL(N-Ilo+1,Lscale(i),B(i,Ilo),Ldb)
      ENDDO
!
!     Column scaling of matrices A and B
!
      DO j = Ilo , Ihi
         CALL SSCAL(Ihi,Rscale(j),A(1,j),1)
         CALL SSCAL(Ihi,Rscale(j),B(1,j),1)
      ENDDO
!
!
!     End of SGGBAL
!
      END SUBROUTINE SGGBAL


! This file is part of HolmMHD
! Copyright (C) 2019 Daniel Verscharen (d.verscharen@ucl.ac.uk)
!All rights reserved.
!
!Redistribution and use in source and binary forms, with or without
!modification, are permitted provided that the following conditions are met:
!
!1. Redistributions of source code must retain the above copyright notice, this
!   list of conditions and the following disclaimer.
!2. 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.
!
!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 OWNER 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.
!
!The views and conclusions contained in the software and documentation are those
!of the authors and should not be interpreted as representing official policies,
!either expressed or implied, of the HolmMHD project.

subroutine initialise(rho,U,B,P)
use globals
implicit none
include "mpif.h"      !Include MPI library variables

integer :: i,j,k, RBi,RBj,RBk, RBnumrun, num_RB, ix,iy,iz, error, RBnum
double precision :: rho(-1:Nx+2,-1:Ny+2,-1:Nz+2),U(3,-1:Nx+2,-1:Ny+2,-1:Nz+2)
double precision :: B(3,-2:Nx+2,-2:Ny+2,-2:Nz+2),P(-1:Nx+2,-1:Ny+2,-1:Nz+2),r,Uampl,phi
double precision :: energ(-1:Nx+2,-1:Ny+2,-1:Nz+2)
double precision :: x,y,z,xB,yB,zB
double precision :: kx,ky,kz,phase,Bamp
double precision :: Bsq,Usq,Binter(3)
integer,parameter :: seed = 86456

num_RB=RBx*RBy*RBz
RBnumrun=((iproc*num_RB)/nproc)+1
call RBcoord(RBnumrun,RBi,RBj,RBk)

!! Spherical hydro-blast wave:
!! Example on Mac: RBx=2, RBy=2, RBz=1, Nx=60, Ny=90, Nz=2
! dx=1.d0/(Nx*RBx)
! dy=1.5d0/(Ny*RBy)
!
! rho=1.d0
! gamma=5.d0/3.d0
! P=0.1d0
! U=0.d0
! B=0.d0
!
!
! do i=1,Nx
! do j=1,Ny
! 	x=dx*(i-1+(RBi-1)*Nx)
! 	y=dy*(j-1+(RBj-1)*Ny)
!
! 	if (((x-0.5d0)*(x-0.5d0)+(y-0.75d0)*(y-0.75d0)).LE.0.01)  P(i,j,:)=10.d0
!
! enddo
! enddo

! !Orszag-Tang vortex:
!! Example on Mac: RBx=2, RBy=2, RBz=1, Nx=90, Ny=90, Nz=2
! dx=1.d0/(RBx*Nx)
! dy=1.d0/(RBy*Ny)
! dz=0.01d0/(RBz*Nz)
!
! rho=25.d0/(36.d0*M_PI)
! P=5.d0/(12.d0*M_PI)
!
! U=0.d0
! B=0.d0
! ! Redefine step sizes:
! do i=1,Nx
! do j=1,Ny
!	x=dx*(i-1+(RBi-1)*Nx)
!	y=dy*(j-1+(RBj-1)*Ny)
!
! xB=x-0.5*dx
! yB=y-0.5*dy
!
! U(1,i,j,:)=-sin(2.d0*M_PI*y)
! U(2,i,j,:)=sin(2.d0*M_PI*x)
!
! B(1,i,j,:)=-sin(2.d0*M_PI*yB)*sqrt(4.d0*M_PI)
! B(2,i,j,:)=sin(4.d0*M_PI*xB)*sqrt(4.d0*M_PI)
! enddo
! enddo

!! Kelvin-Helmholtz instability:
!! Example on Mac: RBx=2, RBy=2, RBz=1, Nx=150, Ny=150, Nz=2
dx=1.d0/(RBx*Nx)
dy=1.d0/(RBy*Ny)
dz=0.01d0/(RBz*Nz)

P=2.5d0
gamma=1.4d0
rho=2.d0
U=0.d0
B=0.d0
B(1,:,:,:)=0.5d0
U(1,:,:,:)=0.5d0

call srand(seed)

do i=1,Nx
do j=1,Ny
do k=1,Nz
		x=dx*(i-1+(RBi-1)*Nx)
		y=dy*(j-1+(RBj-1)*Ny)
		z=dz*(k-1+(RBk-1)*Nz)

	 if ((y.GT.0.25d0).AND.(y.LT.0.75d0)) then
		 rho(i,j,k)=1.d0
		 U(1,i,j,k)=-0.5d0
	 endif

  ! add a random seed for the instability:

  U(1,i,j,k)=U(1,i,j,k)+0.1d0*(rand()-0.5d0)
  U(2,i,j,k)=U(2,i,j,k)+0.1d0*(rand()-0.5d0)
enddo
enddo
enddo

!! Alfven wave
!! Example on Mac: RBx=1, RBy=1, RBz=4, Nx=2, Ny=2, Nz=50
! dx=0.01d0/(RBx*Nx)
! dy=0.01d0/(RBy*Ny)
! dz=2.d0/(RBz*Nz)
!
! P=1.d0
! rho=1.d0
! U=0.d0
! B=0.d0
! B(3,:,:,:)=1.d0
! kz=2.d0*2.d0*M_PI/(dz*Nz*RBz)
! do k=1,Nz
! 	z=dz*(k-1+(RBk-1)*Nz)
! 	zB=z-0.5*dz
!
! 	B(1,:,:,k)=0.1d0*cos(kz*zB)*sqrt(4.d0*M_PI)
! 	B(2,:,:,k)=0.1d0*sin(kz*zB)*sqrt(4.d0*M_PI)
! 	U(1,:,:,k)=-0.1d0*cos(kz*z)
! 	U(2,:,:,k)=-0.1d0*sin(kz*z)
! enddo

!! Counter-propagating Alfven waves
!! Example on Mac: RBx=1, RBy=1, RBz=4, Nx=40, Ny=40, Nz=20
! dx=1.d0/(RBx*Nx)
! dy=1.d0/(RBy*Ny)
! dz=15.d0/(RBz*Nz)
!
! P=1.d0
! rho=1.d0
! U=0.d0
! B=0.d0
! B(3,:,:,:)=1.d0
! kx=2.d0*2.d0*M_PI/(dx*Nx*RBx)
! kz=2.d0*2.d0*M_PI/(dz*Nz*RBz)
! do i=1,Nx
! do j=1,Ny
! do k=1,Nz
! 	x=dx*(i-1+(RBi-1)*Nx)
! 	y=dy*(j-1+(RBj-1)*Ny)
! 	z=dz*(k-1+(RBk-1)*Nz)
! 	xB=x-0.5d0*dx
! 	yB=y-0.5d0*dy
! 	zB=z-0.5d0*dz
!
! 	B(2,i,j,k)=exp(-(zB-2.d0)**2/2.d0)*0.1d0*cos(kx*xB+kz*zB)*sqrt(4.d0*M_PI)
! 	U(2,i,j,k)=-exp(-(z-2.d0)**2/2.d0)*0.1d0*cos(kx*x+kz*z)
!
! 	B(1,i,j,k)=exp(-(zB-13.d0)**2/2.d0)*0.1d0*cos(kx*yB+kz*zB)*sqrt(4.d0*M_PI)
! 	U(1,i,j,k)=exp(-(z-13.d0)**2/2.d0)*0.1d0*cos(kx*y+kz*z)
! enddo
! enddo
! enddo

!! MHD aligned rotor:
!! Example on Mac: RBx=2, RBy=2, RBz=1, Nx=50, Ny=50, Nz=2
! dx=1.d0/(RBx*Nx)
! dy=1.d0/(RBy*Ny)
! dz=0.01d0/(RBz*Nz)
!
! P=1.d0
! rho=1.d0
! gamma=1.4d0
! B=0.d0
! U=0.d0
! B(1,:,:,:)=5.d0
!
! do i=1,Nx
! do j=1,Ny
! 	x=dx*(i-1+(RBi-1)*Nx)
! 	y=dy*(j-1+(RBj-1)*Ny)
!
! 	r=sqrt((x-0.5d0)*(x-0.5d0)+(y-0.5d0)*(y-0.5d0))
! 	if ((x-0.5d0).EQ.0.d0) then
! 		phi=0.5d0*M_PI
! 		if ((y-0.5d0).LT.0.d0) phi=-0.5d0*M_PI
! 	else
! 		phi=atan((y-0.5d0)/(x-0.5d0))
! 	endif
!
!
! 	if (r.LE.0.1d0) then
! 		rho(i,j,:)=10.d0
! 		U(1,i,j,:)=-2.d0*r*sin(phi)
! 		U(2,i,j,:)=2.d0*r*cos(phi)
! 		if ((x-0.5d0).LT.0.d0) then
! 			U(1,i,j,:)=-U(1,i,j,:)
! 			U(2,i,j,:)=-U(2,i,j,:)
! 		endif
! 	endif
!
! 	if ((r.LE.0.115d0).AND.(r.GT.0.1d0)) then
! 		rho(i,j,:)=10.d0-9.d0*(r-0.1d0)/0.015d0
! 		Uampl=(2.d0-1.d0*(r-0.1d0)/0.015d0)*0.1d0
! 		U(1,i,j,:)=-Uampl*sin(phi)
! 		U(2,i,j,:)=Uampl*cos(phi)
! 		if ((x-0.5d0).LT.0.d0) then
! 			U(1,i,j,:)=-U(1,i,j,:)
! 			U(2,i,j,:)=-U(2,i,j,:)
! 		endif
! 	endif
! enddo
! enddo

!!Isotropic turbulence initialisation:
!!Setup similar to Wan et al., PhPl 23, 042307, 2016
!! Example on Mac: RBx=2, RBy=2, RBz=2, Nx=30, Ny=30, Nz=30
! dx=1.d0/(RBx*Nx)
! dy=1.d0/(RBy*Ny)
! dz=1.d0/(RBz*Nz)
!
! P=1.d0
! rho=1.d0
! U=0.d0
! B=0.d0
! B(3,:,:,:)=1.d0
!
! do ix=-2,2
! do iy=-2,2
! do iz=-2,2
!
!
! kx=(2.d0*ix)*M_PI/(dx*Nx*RBx)
! ky=(2.d0*iy)*M_PI/(dy*Ny*RBy)
! kz=(2.d0*iz)*M_PI/(dz*Nz*RBz)
!
!
! if (master) phase=2.d0*M_PI*rand()
! call mpi_bcast(phase, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, error)
!
!
! if (sqrt(kx*kx+ky*ky+kz*kz).NE.0.d0) then
! 	Bamp=10.d0*(sqrt(kx*kx+ky*ky+kz*kz))**(-10.d0/3.d0)
! else
! 	Bamp=0.d0
! endif
!
! do i=1,Nx
! do j=1,Ny
! do k=1,Nz
! 	x=dx*(i-1+(RBi-1)*Nx)
! 	y=dy*(j-1+(RBj-1)*Ny)
! 	z=dz*(k-1+(RBk-1)*Nz)
! 	xB=x-0.5*dx
! 	yB=y-0.5*dy
!
! 	if (sqrt(kx*kx+ky*ky).NE.0.d0) then
! 		B(1,i,j,k)=B(1,i,j,k)-Bamp*cos(kx*xB+ky*y+kz*z-phase)*(ky/(sqrt(kx*kx+ky*ky)))*sqrt(4.d0*M_PI)
! 		B(2,i,j,k)=B(2,i,j,k)+Bamp*cos(kx*x+ky*yB+kz*z-phase)*(kx/(sqrt(kx*kx+ky*ky)))*sqrt(4.d0*M_PI)
! 		if (kz.GE.0.d0) then
! 			U(1,i,j,k)=U(1,i,j,k)+Bamp*cos(kx*x+ky*y+kz*z-phase)*(ky/(sqrt(kx*kx+ky*ky)))
! 			U(2,i,j,k)=U(2,i,j,k)-Bamp*cos(kx*x+ky*y+kz*z-phase)*(kx/(sqrt(kx*kx+ky*ky)))
! 		else
! 			U(1,i,j,k)=U(1,i,j,k)-Bamp*cos(kx*x+ky*y+kz*z-phase)*(ky/(sqrt(kx*kx+ky*ky)))
! 			U(2,i,j,k)=U(2,i,j,k)+Bamp*cos(kx*x+ky*y+kz*z-phase)*(kx/(sqrt(kx*kx+ky*ky)))
! 		endif
! 	elseif (kz.NE.0.d0) then
! 		B(1,i,j,k)=B(1,i,j,k)+Bamp*cos(kz*z-phase)*sqrt(4.d0*M_PI)
! 		if (kz.GT.0.d0) then
! 			U(1,i,j,k)=U(1,i,j,k)-Bamp*cos(kz*z-phase)
! 		else
! 			U(1,i,j,k)=U(1,i,j,k)+Bamp*cos(kz*z-phase)
! 		endif
! 	endif
!
! enddo
! enddo
! enddo
!
!
! enddo
! enddo
! enddo

end subroutine


module mod_gridspace
#include <messenger.h>
    use mod_kinds,  only: rk, ik
    implicit none

contains

    !>  Compute a linear distribution of a given number of values between
    !!  two upper and lower values.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/14/2016
    !!
    !------------------------------------------------------------------------
    function linspace(xmin,xmax,nvals) result(vals)
        real(rk),       intent(in)  :: xmin
        real(rk),       intent(in)  :: xmax
        integer(ik),    intent(in)  :: nvals

        real(rk), dimension(nvals)  :: vals
        real(rk)                    :: interval, dval
        integer(ik)                 :: ival

        if ( nvals < 2 ) call chidg_signal(FATAL,"linspace: number of grid-space values is fewer than two.")

        !
        ! Compute linear interval
        !
        interval = xmax-xmin
        dval     = interval/real((nvals-1),rk)

        do ival = 1,nvals
            vals(ival) = xmin + real((ival-1),rk)*dval
        end do

    end function linspace
    !************************************************************************

end module mod_gridspace


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_UNIT_ENERGY

    USE MR_KINDS

    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_FIELD_VARS
    USE MR_DEF_ACTIVITY

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_UNIT_ENERGY

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_UNIT_ENERGY( NI , NJ , NK , UNIT_ENERGY )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2) :: UNIT_ENERGY

    INTEGER(IJID_KIND) :: I , J
    INTEGER            :: DIM
    INTEGER(KKID_KIND) :: K

    !BLOCK
      DO DIM = 1 , 2

        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            !BLOCK
              UNIT_ENERGY( I , J ,DIM) = 0.0
            !END BLOCK
          END DO
        END DO

      END DO
    !END BLOCK

    DO K = 1 , NK

      DO DIM = 1 , 2

        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
              UNIT_ENERGY( I , J ,DIM) = UNIT_ENERGY( I , J ,DIM) +   &
              & DSIGMA * H( I , J ) *   &
              & 0.5 * GUV( I , J ,DIM,DIM) * UV( I , J ,DIM, K ) * UV( I , J ,DIM, K )
            END IF
          END DO
        END DO

      END DO

    END DO

  END SUBROUTINE MR_CALC_UNIT_ENERGY

  END MODULE MR_MOD_CALC_UNIT_ENERGY


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! 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 and documentation.

! 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.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE GEN_T0L (RGRID_ROW, ICORD, THETAD, PHID, T0L )

! Generates 3x3 transformation matrix, T0L, to basic (0) coordinate system from another coordinate system (L) with internal coord
! system number ICORD at the grid whose RGRID data is at row RGRID_ROW in array RGRID. Thus, if U0 is a basic system vector
! and UL is a vector in coord system L, then:

!                       U0 = T0L*UL                      (1)

! In the RCORD database, we have transformations, T0P, that transform a vector to basic (0) from the principal
! directions (P) of some other coordinate system. If the local (L) system is rectangular then T0P is T0L and all we
! have to do is get T0P from RCORD. However, if the local system is cylindrical or spherical, then we have to also
! transform from the point at R, THETA, Z (cylindrical) or R, THETA, PHI (spherical) to the respective principal axes
! of that cylindrical or spherical system. Thus, we can write eqn (1) as:

!                       U0 = T0P*UP                      (2)
! and
!                       UP = TPL*UL                      (3)

! Substituting (3) into (2) and comparing with (1) it is seen that:

!                      T0L = T0P*TPL

! For a rectangular system, TPL is the identity matrix.

! For a cylindrical system TPL is the matrix in the relationship:

!              |UPx|   |cos(THETA) -sin(THETA) 0 ||Ur    |
!              |UPy| = |sin(THETA)  cos(THETA) 0 ||Utheta|
!              |UPz|   |     0           0     1 ||Uz    |

! where UPx, UPy, UPz are the displacements in the principal directiona of the cylindrical system and Ur, Utheta, Uz
! are the cylindrical system displacements at some cordinate location R, THETA, Z in the cylindrical system.

! For a spherical system TPL is the matrix in the relationship:

!  |UPx|   |sin(THETA)*cos(PHI) cos(THETA)*cos(PHI) -sin(PHI) ||Ur    |
!  |UPy| = |sin(THETA)*sin(PHI) cos(THETA)*sin(PHI)  cos(PHI) ||Utheta|
!  |UPz|   |    cos(THETA)          -sin(THETA)         0     ||Uphi  |

! where UPx, UPy, UPz are the displacements in the principal directions of the spherical system and Ur, Utheta, Uphi
! are the spherical system displacements at some coordinate location R, THETA, PHI in the spherical system.

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE CONSTANTS_1, ONLY           :  ZERO, ONE, ONE80, PI
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, F04, f06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM
      USE PARAMS, ONLY                :  EPSIL
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  GEN_T0L_BEGEND
      USE MODEL_STUF, ONLY            :  RGRID, CORD, RCORD

      USE GEN_T0L_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'GEN_T0L'

      INTEGER(LONG), INTENT(IN)       :: RGRID_ROW         ! Row number in array RGRID where the RGRID data is stored for the grid
!                                                            point whose coord transformation we seek. Since RGRID (at this point)
!                                                            is sorted in grid numerical order, RGRID_ROW will be the same as what
!                                                            we would get from subr GET_ARRAY_ROW_NUM with actual grid equal to
!                                                            the grid whose transformation we seek.
      INTEGER(LONG), INTENT(IN)       :: ICORD             ! Internal coord ID for coord sys L
      INTEGER(LONG)                   :: I,J,K             ! DO loop indices
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = GEN_T0L_BEGEND

      REAL(DOUBLE),  INTENT(OUT)      :: THETAD,PHID       ! Azimuth and elevation angles (deg) for cylindrical/spherical coord sys
      REAL(DOUBLE),  INTENT(OUT)      :: T0L(3,3)          ! 3 x 3 coord transformation matrix described above
      REAL(DOUBLE)                    :: CT,ST,CP,SP       ! SIN or COS of THETA or PHI
      REAL(DOUBLE)                    :: EPS1              ! EPSIL(1), a small number for comparison to zero
      REAL(DOUBLE)                    :: RAD               ! Rad from origin of sph or cyl coord. sys. ICORD to grid point RGRID_ROW
      REAL(DOUBLE)                    :: RADXY             ! Radius for calculating azimuth angle
      REAL(DOUBLE)                    :: RDEG              ! Number of degrees in a radian
      REAL(DOUBLE)                    :: THETA,PHI         ! Radian values for THETAD, PHID
      REAL(DOUBLE)                    :: T0P(3,3)          ! 3 x 3 transformation matrix described above
      REAL(DOUBLE)                    :: TPL(3,3)          ! 3 x 3 transformation matrix described above
      REAL(DOUBLE)                    :: XR0(3)            ! Array of relative coords of RGRID_ROW and origin of coord system ICORD
!                                                            in basic coords.
      REAL(DOUBLE)                    :: XRP(3)            ! Array of relative coords of RGRID_ROW and origin of coord system ICORD
!                                                            in local coord system L.

      INTRINSIC                       :: DASIN, DATAN2, DSIN, DCOS

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Initialize outputs

      THETAD = ZERO
      PHID   = ZERO

      DO I=1,3
         DO J=1,3
            T0L(I,J) = ZERO
         ENDDO
      ENDDO

! If ICORD is rectangular, then no more transformation is needed. If it is cylindrical or spherical, more transformation is needed
! and depends on the location of the grid at RGRID_ROW and the location of the origin of system ICORD (both locations in basic sys).
! The location of the grid at RGRID_ROW in basic is in RGRID(RGRID_ROW,1-3). The location of the origin of system ICORD in the basic
! system is in RCORD (first 3 words of the row ICORD).

! Set elements of T0P to the coord. sys. transf. matrix found.
! If rectangular, we are finished.

      EPS1   = EPSIL(1)
      RDEG   = ONE80/PI

      DO I=1,3
         DO J=1,3
            K = 3 + 3*(I-1) + J
            T0P(I,J) = RCORD(ICORD,K)
         ENDDO
      ENDDO
                                                           ! If 11 or 21 then rectangular
      IF ((CORD(ICORD,1) == 11) .OR. (CORD(ICORD,1) == 21)) THEN
         DO I=1,3
            DO J=1,3
               T0L(I,J) = T0P(I,J)
            ENDDO
         ENDDO

      ELSE                                                 ! Not Rectangular

! Get relative coordinates of RGRID_ROW and origin of ICORD in basic coordinate system.

         XR0(1) = RGRID(RGRID_ROW,1) - RCORD(ICORD,1)
         XR0(2) = RGRID(RGRID_ROW,2) - RCORD(ICORD,2)
         XR0(3) = RGRID(RGRID_ROW,3) - RCORD(ICORD,3)

! Transform relative coords from basic to the local coordinate system. Relative coords (3 of them) in local system are in
! XRP. Relative coords in basic system are in XR0. The transformation is: XRP = T0P(transpose)*XR0. (Note: XR0 = T0P*XRP)

         CALL MATMULT_FFF_T ( T0P, XR0, 3, 3, 1, XRP )

! Initialize TPL

         DO I=1,3
            DO J=1,3
               TPL(I,J) = ZERO
            ENDDO
         ENDDO

! **********************************************************************************************************************************
! Calculate T0L = T0P*TPL for cylindrical and spherical systems. Note that if the radius to the grid point (from the
! coord system) is zero, we define THETA = 0

         IF (CORD(ICORD,1) == 22) THEN                     ! Cylindrical
            RAD = DSQRT(XRP(1)*XRP(1) + XRP(2)*XRP(2))
            IF (DABS(RAD) < EPS1) THEN
               DO I=1,3
                  DO J=1,3
                     T0L(I,J) = T0P(I,J)
                     tpl(i,j) = zero
                     tpl(i,i) = one
                  ENDDO
               ENDDO
            ELSE
               THETA    = DATAN2(XRP(2),XRP(1))
               THETAD   = RDEG*THETA
               CT       = DCOS(THETA)
               ST       = DSIN(THETA)
               TPL(1,1) =  CT
               TPL(1,2) = -ST
               TPL(1,3) =  ZERO
               TPL(2,1) =  ST
               TPL(2,2) =  CT
               TPL(2,3) =  ZERO
               TPL(3,1) =  ZERO
               TPL(3,2) =  ZERO
               TPL(3,3) =  ONE
               CALL MATMULT_FFF ( T0P, TPL, 3, 3, 3, T0L )
            ENDIF
         ELSE IF (CORD(ICORD,1) == 23) THEN                ! Spherical
            RAD   = DSQRT(XRP(1)*XRP(1) + XRP(2)*XRP(2) + XRP(3)*XRP(3))
            RADXY = DSQRT(XRP(1)*XRP(1) + XRP(2)*XRP(2))
            IF ((DABS(RAD) < EPS1) .OR. (DABS(RADXY) < EPS1)) THEN
               THETA  = ZERO
               PHI    = ZERO
               CT     = ONE
               ST     = ZERO
               CP     = ONE
               SP     = ZERO
               DO I=1,3
                  DO J=1,3
                     T0L(I,J) = T0P(I,J)
                  ENDDO
               ENDDO
            ELSE
               THETA    =  DASIN(RADXY/RAD)
               PHI      =  DATAN2(XRP(2),XRP(1))
               CT       =  DCOS(THETA)
               ST       =  DSIN(THETA)
               CP       =  DCOS(PHI)
               SP       =  DSIN(PHI)
               PHID     =  RDEG*PHI
               THETAD   =  RDEG*THETA
               TPL(1,1) =  ST*CP
               TPL(1,2) =  CT*CP
               TPL(1,3) = -SP
               TPL(2,1) =  ST*SP
               TPL(2,2) =  CT*SP
               TPL(2,3) =  CP
               TPL(3,1) =  CT
               TPL(3,2) = -ST
               TPL(3,3) =  ZERO
               CALL MATMULT_FFF ( T0P, TPL, 3, 3, 3, T0L )
            ENDIF
         ENDIF

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************

! **********************************************************************************************************************************

      END SUBROUTINE GEN_T0L


!----------------------------------------------------------------------------
!  This subroutine solves a Volterra integro-differential equation of
!  the second kind,
!              [i*d/dt-h(t)]G(t,t') = delta(t,t') + (K*G)(t,t'),
!  for t=n*dt or t'=n*dt, using 2^nd implicit Runge-Kutta method.
!----------------------------------------------------------------------------
!K = contour_GF
!H = H_0 + Sigma_HF
subroutine vide_kb_contour_gf_K(H,K,G,dG,dG_new,params)
  complex(8),dimension(:)             :: H
  type(kb_contour_gf),intent(in)      :: K
  type(kb_contour_gf),intent(inout)   :: G
  type(kb_contour_dgf),intent(inout)  :: dG
  type(kb_contour_dgf)                :: dG_new
  type(kb_contour_params),intent(in)  :: params
  integer                             :: N,L
  real(8)                             :: dt,dtau
  integer                             :: i,j,itau,jtau,s
  complex(8),dimension(:),allocatable :: KxG
  complex(8)                          :: dG_less
  !
  N   = params%Nt                 !<== work with the ACTUAL size of the contour
  L   = params%Ntau
  dt  = params%dt
  dtau= params%dtau
  !
  allocate(KxG(0:max(N,L)))
  !
  !TYPE: X=RET,LESS,LMIX (R,<,\LMIX)
  !i d/dt G^x(t,:)  = h(t)G^x(t,:) + Q^x(t,:) + int_{0,t'}^{t}K^R(t,s)G^x(s,:)ds
  !
  !
  !ret component
  ! d/dt G^R(t,:) = -i*h(t)*G^R(t,:) -i*delta(t,:) - i\int_{:}^t K^R(t,s)*G^R(s,:)ds
  ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  G%ret(N,N)=-xi
  dG_new%ret(N)=-xi*H(N)*G%ret(N,N)
  do j=1,N-1
     G%ret(N,j)=G%ret(N-1,j) + 0.5d0*dt*dG%ret(j)
     !
     KxG(0:)=zero
     do s=j,N-1
        KxG(s)=K%ret(N,s)*G%ret(s,j)
     enddo
     dG_new%ret(j)=-xi*dt*kb_half_trapz(KxG(0:),j,N-1)
     !
     G%ret(N,j)=G%ret(N,j) + 0.5d0*dt*dG_new%ret(j)
     G%ret(N,j)=G%ret(N,j)/(1.d0 + 0.5d0*xi*dt*H(N) + 0.25d0*xi*dt**2*K%ret(N,N))
     !
     dG_new%ret(j)=dG_new%ret(j) - xi*H(N)*G%ret(N,j) - 0.5d0*xi*dt*K%ret(N,N)*G%ret(N,j)
  enddo
  !
  !Lmix component
  !d/dt G^\lmix(t,:) = -i*H(t)*G^\lmix(t,:) -i\int_0^\beta K^\lmix(t,s)*G^M(s,:)ds -i\int_0^t K^R(t,s)G^\lmix(s,:)ds
  ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  do jtau=0,L
     G%lmix(N,jtau)=G%lmix(N-1,jtau)+0.5d0*dt*dG%lmix(jtau)
     !
     KxG(0:)=zero
     do s=0,jtau
        KxG(s)=K%lmix(N,s)*G%mats(s+L-jtau)
     end do
     dG_new%lmix(jtau)=xi*dtau*kb_trapz(KxG(0:),0,jtau)
     KxG(0:)=zero
     do s=jtau,L
        KxG(s)=K%lmix(N,s)*G%mats(s-jtau)
     end do
     dG_new%lmix(jtau)=dG_new%lmix(jtau)-xi*dtau*kb_trapz(KxG(0:),jtau,L)!<= add -iQ(t)
     !
     KxG(0:)=zero
     do s=1,N-1
        KxG(s)=K%ret(N,s)*G%lmix(s,jtau)
     end do
     dG_new%lmix(jtau)=dG_new%lmix(jtau)-xi*dt*kb_half_trapz(KxG(0:),1,N-1)
     !
     G%lmix(N,jtau)=G%lmix(N,jtau) + 0.5d0*dt*dG_new%lmix(jtau)
     G%lmix(N,jtau)=G%lmix(N,jtau)/(1.d0 + 0.5d0*xi*dt*H(N) + 0.25d0*xi*dt**2*K%ret(N,N))
     !
     dG_new%lmix(jtau)=dG_new%lmix(jtau)-xi*H(N)*G%lmix(N,jtau)-0.5d0*xi*dt*K%ret(N,N)*G%lmix(N,jtau)
  end do
  !
  !Less component
  !d/dt G^<(t,:) = -i*H(t)*G^<(t,:) -i*[ (-i)*\int_0^\beta K^\lmix(t,s)*G^\rmix(s,:)ds + \int_0^{:}K^<(t,s)*G^A(s,:)ds ]
  !                                 -i*\int_0^t K^R(t,s)*G^<(s,:)ds
  ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  ! G^<(t_{N},t_{j}), d/dt G^<(t_{N},t_{j}) <== lower-right triangle
  do j=1,N-1
     G%less(N,j)=G%less(N-1,j) + 0.5d0*dt*dG%less(j)
     !
     KxG(0:)=zero
     do s=0,L
        KxG(s)=K%lmix(N,s)*get_rmix(G,s,j,L)
     end do
     dG_new%less(j)=-xi*(-xi)*dtau*kb_trapz(KxG(0:),0,L)
     !
     KxG(0:)=zero
     do s=1,j
        KxG(s)=K%less(N,s)*get_adv(G,s,j)
     end do
     dG_new%less(j)=dG_new%less(j)-xi*dt*kb_trapz(KxG(0:),1,j)!<= -iQ(t)
     !
     KxG(0:)=zero
     do s=1,N-1
        KxG(s)=K%ret(N,s)*G%less(s,j)
     end do
     dG_new%less(j)=dG_new%less(j)-xi*dt*kb_half_trapz(KxG(0:),1,N-1)
     !
     G%less(N,j)=G%less(N,j) + 0.5d0*dt*dG_new%less(j)
     G%less(N,j)=G%less(N,j)/(1.d0 + 0.5d0*xi*dt*H(N) + 0.25d0*xi*dt**2*K%ret(N,N))
     !
     dG_new%less(j)=dG_new%less(j)-xi*H(N)*G%less(N,j)-0.5d0*xi*dt*K%ret(N,N)*G%less(N,j)
  end do
  !
  ! G^<(t_{i},t_{N}), d/dt G^<(t_{i},t_{N}) <== upper left triangle
  ! Hermitian conjugate G
  ! if (.not.G%anomalous) then
  do i=1,N-1
     G%less(i,N)=-conjg(G%less(N,i))
  end do
  ! else
  !    do i=1,N-1
  !       G%less(i,N)=G%less(N,i)+G%ret(N,i)
  !    end do
  ! endif
  !
  ! d/dt G^<(t_{N-1},t_{N})
  dG_less=-xi*H(N-1)*G%less(N-1,N)
  !
  KxG(0:)=zero
  do s=0,L
     KxG(s)=K%lmix(N-1,s)*get_rmix(G,s,N,L)
  end do
  dG_less=dG_less-xi*(-xi)*dtau*kb_trapz(KxG(0:),0,L)
  !
  KxG(0:)=zero
  do s=1,N
     KxG(s)=K%less(N-1,s)*get_adv(G,s,N)
  end do
  dG_less=dG_less-xi*dt*kb_trapz(KxG(0:),1,N)
  !
  KxG(0:)=zero
  do s=1,N-1
     KxG(s)=K%ret(N-1,s)*G%less(s,N)
  end do
  dG_less=dG_less-xi*dt*kb_trapz(KxG(0:),1,N-1)
  !
  !G^<(N,N), d/dt G^<(N,N)
  G%less(N,N)=G%less(N-1,N)+0.5d0*dt*dG_less
  !
  KxG(0:)=zero
  do s=0,L
     KxG(s)=K%lmix(N,s)*get_rmix(G,s,N,L)
  end do
  dG_new%less(N)=-xi*(-xi)*dtau*kb_trapz(KxG(0:),0,L)
  !
  KxG(0:)=zero
  do s=1,N
     KxG(s)=K%less(N,s)*get_adv(G,s,N)
  end do
  dG_new%less(N)=dG_new%less(N)-xi*dt*kb_trapz(KxG(0:),1,N)
  !
  KxG(0:)=zero
  do s=1,N-1
     KxG(s)=K%ret(N,s)*G%less(s,N)
  end do
  dG_new%less(N)=dG_new%less(N)-xi*dt*kb_half_trapz(KxG(0:),1,N-1)
  !
  G%less(N,N)=G%less(N,N)+0.5d0*dt*dG_new%less(N)
  G%less(N,N)=G%less(N,N)/(1.d0+0.5d0*xi*dt*H(N)+0.25d0*xi*dt**2*K%ret(N,N))
  !
  dG_new%less(N)=dG_new%less(N)-xi*H(N)*G%less(N,N)-0.5d0*xi*dt*K%ret(N,N)*G%less(N,N)
  !
  deallocate(KxG)
end subroutine vide_kb_contour_gf_K

!K = contour_Sigma
!H = H_0
subroutine vide_kb_contour_gf_Sigma(H0,Sigma,G,dG,dG_new,params)
  complex(8),dimension(:)             :: H0
  type(kb_contour_sigma),intent(in)   :: Sigma
  type(kb_contour_gf),intent(inout)   :: G
  type(kb_contour_dgf),intent(inout)  :: dG
  type(kb_contour_dgf)                :: dG_new
  type(kb_contour_params),intent(in)  :: params
  complex(8),dimension(size(H0))      :: H
  type(kb_contour_gf)                 :: K
  integer                             :: N,L
  real(8)                             :: dt,dtau
  integer                             :: i,j,itau,jtau,s
  complex(8),dimension(:),allocatable :: KxG
  complex(8)                          :: dG_less
  !
  N   = params%Nt                 !<== work with the ACTUAL size of the contour
  L   = params%Ntau
  dt  = params%dt
  dtau= params%dtau
  !
  call allocate_kb_contour_gf(K,params)
  K = Sigma%reg
  H = H0 - Sigma%hf(:)
  !
  call vide_kb_contour_gf_K(H,K,G,dG,dG_new,params)
  !
  call deallocate_kb_contour_gf(K)
end subroutine vide_kb_contour_gf_Sigma


  function mnmacro (molObj, iz, in)

! ======================================================================
!
!   This function calculates the Moller-Nix macroscopic mass excess
!   for (spherical) nuclei lying outside the tabulated range of Z and N.
!   The inputs are the proton and neutron numbers.
!   Uses formula (62) from At. Data Nucl. data Tables 59, 185 (1995).
!   Uses FRLDM, not FRDM.
!
!   Called by: MOLNIX
!
!    Written by A. J. Sierk  LANL  T-2  November, 1997.
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use molnixParams, only: zro, hlf, one, two, thr, fiv, &
         & thrd, twthrd, pi, ato3rd

    implicit none
    class(Molnix),  intent(inout) :: molObj
    integer(int32), intent(in   ) :: in
    integer(int32), intent(in   ) :: iz
    real(real64)                  :: mnmacro

    real(real64) :: a, ai, akf, athrd, b3, bi, deln, delnp, delp, &
         & fkprp, temp, un, wt, xx, yc, yc2, ys, z
    logical      :: nodd, podd

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

    real(real64), parameter :: &
         &  emp = 7.289034d0,  emn = 8.071431d0, &
         &  esq = 1.4399764d0, ael = 1.433d-5, &
         &   rp = 0.80d0,       r0 = 1.16d0, &
         & aype = 0.68d0,       ay = 0.70d0, &
         & rmac = 4.80d0,        h = 6.6d0, &
         &    w = 30.d0,        av = 16.00126d0, &
         &  akv = 1.92240d0,    as = 21.18466d0, &
         &  aks = 2.345d0,      a0 = 2.615d0, &
         &   ca = 0.10289d0

    real(real64), parameter :: d1 = 3.020833333d0
    real(real64), parameter :: d2 = 0.113541666667d0
    real(real64), parameter :: d3 = 0.00126240079d0

    real(real64), parameter :: c1 = thr*esq/(fiv*r0)
    real(real64), parameter :: c4 = 1.25d0*c1*(1.5d0/pi)**twthrd
    real(real64), parameter :: c5 = (2.25d0*pi)**thrd/r0

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

    un = dble(in)
    z = dble(iz)
    a = z + un
    athrd = ato3rd(in + iz)
    if (a < div0Lim .and. a > -div0Lim) then
       a = div0Lim
       write(molObj%io%message,1000) "292, 323"
       call molObj%io%print(4, 3, molObj%io%message)
    end if
    ai = (un - z)/a
    deln = zro
    delnp = zro
    nodd = .false.
    podd = .false.
    if (2*(in/2).ne.in) then
       temp = ato3rd(in)
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(molObj%io%message,1000) "304"
          call molObj%io%print(4, 3, molObj%io%message)
       end if
       deln = rmac/temp
       nodd = .true.
    endif
    delp = zro
    if (2*(iz/2).ne.iz) then
       temp = ato3rd(iz)
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(molObj%io%message,1000) "314"
          call molObj%io%print(4, 3, molObj%io%message)
       end if
       delp = rmac/temp
       podd = .true.
    endif
    wt = zro
    if (nodd .and. podd) then
       if (athrd < div0Lim .and. athrd > -div0Lim) then
          athrd = div0Lim
          write(molObj%io%message,1000) "322, 325"
          call molObj%io%print(4, 3, molObj%io%message)
       end if
       delnp = h/athrd**2
       if (in == iz) wt = one/a
    endif
    akf = c5*ato3rd(iz)/athrd
    xx = akf*rp
    fkprp = -0.125d0*esq*rp**2*(d1 - d2*xx**2 + d3*xx**4)/r0**3
    ys = r0*athrd/aype
    yc = ys*aype/ay
    if (ys < div0Lim .and. ys > -div0Lim) then
       ys = div0Lim
    end if
    if (yc < div0Lim .and. yc > -div0Lim) then
       yc = div0Lim
       write(molObj%io%message,1000) "344"
       call molObj%io%print(4, 3, molObj%io%message)
    end if
    yc2 = yc*yc

    bi = one - thr/ys**2 + (one + ys)*( two + thr * (one + one/ys)/ys) &
         & * exp(-two*ys)
    b3 = one - fiv*(one - 1.875d0*(one - 1.4d0/yc2)/yc - 0.75d0 * &
         & (one + 4.5d0/yc + 7.0d0*(one + hlf/yc)/yc2)*exp(-two*yc)) / &
         & yc2

    mnmacro = emp*z + emn*un - av*a*(one - akv*ai**2) + as*bi*  &
         (one - aks*ai**2)*athrd**2+ a0 + c1*b3*z**2/athrd -  &
         c4*ato3rd(iz)**4/athrd + fkprp*z**2/a - ca*ai*a +  &
         w*(abs(ai) + wt) + delp + deln - delnp - ael*z**2.39d0

    return
! ======================================================================
1000 format("Divide by zero error prevented in 'mnmacro.f90', line(s) ", &
          & A, ".")
! ======================================================================
  end function mnmacro


      subroutine get_azel(tc, prn, stationXYZ,East,North,
     .  localv, Lat,Long,Ht, azimuth,elev,ihr,tod,grange)
      implicit none
      include 'local.inc'
      integer jj, ierr,prn, ihr
      real*8 tc, SatPos(3), toffset, omeg, ghadot,
     . xnew, ynew, localv(3),tod,
     . azimuth, elev, North, East, stationXYZ(3), range2,
     . Lat,Long,Ht, grange
c     starting value
      toffset = 0.07
c     Earth Rotation
      ghadot = 7.2921151467d-5 ! rad/sec, using same one as ICD200
      do jj = 1, 4
        call bcephX(tc-toffset, prn,SatPos,ierr,ihr)
        if (ierr.ne.0) then
          print*, 'orbit error'
        endif
        omeg = -ghadot*toffset
        xnew = SatPos(1)*dcos(omeg) - SatPos(2)*dsin(omeg)
        ynew = SatPos(1)*dsin(omeg) + SatPos(2)*dcos(omeg)
        range2= (xnew - stationXYZ(1))**2 + (ynew
     . - stationXYZ(2))**2 + (SatPos(3)-stationXYZ(3))**2
        toffset = dsqrt(range2)/c
       enddo
       SatPos(1) =  xnew
       SatPos(2) =  ynew
       grange = dsqrt(range2)
       call azel(azimuth, elev, stationXYZ, East, North,
     .        localv, SatPos)
c      write(38,'(3f20.6)') SatPos(1), SatPos(2), SatPos(3)
       end


!***********************************************************************
!                                                                      *
      SUBROUTINE VAC2
!                                                                      *
!   This routine sets up the second-order vacuum polarization poten-   *
!   tial using  equations (1) and (4) of  L Wayne Fullerton and  G A   *
!   Rinker, Jr,  Phys Rev A  13 (1976) 1283-1287.  The  potential is   *
!   accumulated  in  array  TB(I), I = 1, ..., N  which is in COMMON   *
!   block /TATB/ .                                                     *
!                                                                      *
!   Call(s) to: [LIB92]: QUAD.                                         *
!               [RCI92]: FUNK.                                         *
!                                                                      *
!   Written by Farid A Parpia, at Oxford    Last update: 09 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE def_C
      USE grid_C
      USE npar_C
      USE ncdist_C
      USE tatb_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE funk_I
      USE quad_I
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, K
      REAL(DOUBLE) :: EPSI, TWOCV, FACTOR, RI, X, TBI, RK, XK, XI, XM, XP
!-----------------------------------------------
!
!   Overall initialization
!
      EPSI = PRECIS*PRECIS
      TWOCV = CVAC + CVAC
!
!   Potential for a point nucleus: equation (1)
!   (this is also the asymptotoc form for a finite nucleus)
!
      FACTOR = -(2.0D00*Z)/(3.0D00*PI*CVAC)
!
      TB(1) = 0.0D00
!
      I = 1
    1 CONTINUE
      I = I + 1
!
      RI = R(I)
      X = TWOCV*RI
      TBI = (FACTOR/RI)*FUNK(X,1)
!
      IF (ABS(TBI) >= EPSI) THEN
         TB(I) = TBI
         IF (I < N) GO TO 1
      ELSE
         TB(I:N) = 0.0D00
      ENDIF
!
!   Potential for a finite nucleus: equation (4)
!
      IF (NPARM == 2) THEN
!
         FACTOR = -2.0D00/(3.0D00*CVAC**2)
!
!   Set up integrand
!
         TB(1) = 0.0D00
!
         K = 1
    3    CONTINUE
         K = K + 1
!
         RK = R(K)
         XK = TWOCV*RK
!
         TA(1) = 0.0D00
         DO I = 2, MTP
            XI = TWOCV*R(I)
            XM = ABS(XK - XI)
            XP = XK + XI
            TA(I) = (FUNK(XM,0) - FUNK(XP,0))*ZDIST(I)
         END DO
!
         CALL QUAD (X)
!
         X = X*FACTOR/RK
!
!   Get out of loop if the asymptotic value has been attained
!
         IF (ABS(X) >= EPSI) THEN
            IF (ABS((X - TB(K))/X) > 1.0D-05) THEN
               TB(K) = X
               IF (K < N) GO TO 3
            ENDIF
         ENDIF
!
      ENDIF
!
      RETURN
      END SUBROUTINE VAC2