module c_dftatom

use iso_c_binding, only: c_int, c_double, c_bool
use averages, only: arit, arit2, rmean, smean
implicit none

contains

subroutine averages_arit(n_long, n_lat, longitude, latitude, field, mask, r) bind(c)
integer(c_int), intent(in), value :: n_long, n_lat
real(c_double), intent(in) :: longitude(n_long), latitude(n_lat), field(n_long, n_lat)
! mask == 0 is .false. and 1 is .true.
integer(c_int), intent(in) :: mask(n_long, n_lat)
real(c_double), intent(out) :: r
logical :: mask2(n_long, n_lat)
where (mask == 0)
    mask2 = .false.
else where
    mask2 = .true.
end where
r = arit(longitude, latitude, field, mask2)
end subroutine

subroutine averages_rmean(n_long, n_lat, longitude, latitude, field, mask, r, m) bind(c)
integer(c_int), intent(in), value :: n_long, n_lat
real(c_double), intent(in) :: longitude(n_long), latitude(n_lat), field(n_long, n_lat)
! mask == 0 is .false. and 1 is .true.
integer(c_int), intent(in) :: mask(n_long, n_lat)
real(c_double), intent(in), value :: r
real(c_double), intent(out) :: m
logical :: mask2(n_long, n_lat)
where (mask == 0)
    mask2 = .false.
else where
    mask2 = .true.
end where
m = rmean(longitude, latitude, field, mask2, r)
end subroutine

subroutine averages_smean(n_long, n_lat, longitude, latitude, field, mask, s, m) bind(c)
integer(c_int), intent(in), value :: n_long, n_lat
real(c_double), intent(in) :: longitude(n_long), latitude(n_lat), field(n_long, n_lat)
! mask == 0 is .false. and 1 is .true.
integer(c_int), intent(in) :: mask(n_long, n_lat)
real(c_double), intent(in), value :: s
real(c_double), intent(out) :: m
logical :: mask2(n_long, n_lat)
where (mask == 0)
    mask2 = .false.
else where
    mask2 = .true.
end where
m = smean(longitude, latitude, field, mask2, s)
end subroutine

subroutine averages_arit2(n_long, n_lat, longitude, latitude, field, mask, r) bind(c)
integer(c_int), intent(in), value :: n_long, n_lat
real(c_double), intent(in) :: longitude(n_long), latitude(n_lat), field(n_long, n_lat)
! mask == 0 is .false. and 1 is .true.
integer(c_int), intent(in) :: mask(n_long, n_lat)
real(c_double), intent(out) :: r
logical :: mask2(n_long, n_lat)
where (mask == 0)
    mask2 = .false.
else where
    mask2 = .true.
end where
r = arit2(longitude, latitude, field, mask2)
end subroutine

end module


      implicit none
      integer ns,nt
      double precision, allocatable :: source(:,:)
      double precision, allocatable :: targ(:,:)
      double precision, allocatable :: charge(:)
      double precision, allocatable :: pot(:),potex(:)
      double precision, allocatable :: grad(:,:),gradex(:,:)

      double precision eps
      integer i,j,k,ntest
      double precision hkrand,thet,pi,erra,ra,thresh
      double precision tmp1,tmp2,tmp3,errg,rg

      pi = atan(1.0d0)*4.0d0

c
cc      initialize printing routine
c
      call prini(6,13)
      write(*,*)
      write(*,*)
      write(*,*) "================================="
      call prin2("This code is an example fortran driver*",i,0)
      call prin2("On output, the code prints sample pot,grad*",i,0)
      write(*,*)
      write(*,*)

      ns = 216

      nt = 216

      allocate(source(3,ns))
      allocate(targ(3,nt))
      allocate(charge(ns))
      allocate(pot(nt))
      allocate(grad(3,nt))

      eps = 1.0d-6

      write(*,*) "=========================================="

c
c
c       example demonstrating use of
c        source to source, charges, pot + gradient
c

c
cc      generate sources uniformly in the unit cube
c
c
      open(unit=33,file='examples/srcloc.txt')
      do i=1,ns
        read(33,*) tmp1,tmp2,tmp3
        source(1,i) = tmp1
        source(2,i) = tmp2
        source(3,i) = tmp3
        charge(i) = hkrand(0)
      enddo
      close(33)

      open(unit=33,file='examples/targloc.txt')
      do i=1,nt
        read(33,*) tmp1,tmp2,tmp3
        targ(1,i) = tmp1
        targ(2,i) = tmp2
        targ(3,i) = tmp3
        pot(i) = 0
        grad(1,i) = 0
        grad(2,i) = 0
        grad(3,i) = 0
      enddo
      close(33)

      call prin2('targ=*',targ,12)

      call lfmm3d_t_c_g(eps,ns,source,charge,
     1      nt,targ,pot,grad)
      call prin2("pot at sources=*",pot,12)
cc      call prin2("grad at sources=*",grad,3*nt)

c
c      test accuracy
c

      ntest = nt
      allocate(potex(ntest),gradex(3,ntest))
      thresh = 1.0d-16
      do i=1,ntest
        potex(i) = 0
        gradex(1,i) = 0
        gradex(2,i) = 0
        gradex(3,i) = 0
      enddo
      call l3ddirectcg(1,source,charge,ns,targ,ntest,
     1       potex,gradex,thresh)

      erra = 0
      ra = 0
      errg = 0
      rg = 0
      do i=1,ntest
         ra = ra + abs(potex(i))**2
         erra = erra + abs(pot(i)-potex(i))**2
         rg = rg + gradex(1,i)**2 + gradex(2,i)**2 + gradex(3,i)**2
         errg = errg + (gradex(1,i)-grad(1,i))**2
         errg = errg + (gradex(2,i)-grad(2,i))**2
         errg = errg + (gradex(3,i)-grad(3,i))**2
      enddo

      call prin2('potex=*',potex,ntest)
      call prin2('pot=*',pot,ntest)
      call prin2('gradex=*',gradex,3*ntest)
      call prin2('grad=*',grad,3*ntest)

      erra = sqrt(erra/ra)
      errg = sqrt(errg/rg)

      call prin2('error=*',erra,1)
      call prin2('error gradient=*',errg,1)

      stop
      end
c----------------------------------------------------------
c
cc
c
c


program meuprog
integer , parameter :: m=4000
integer :: i,j
double precision, allocatable :: a(:,:),b(:,:)
double precision s,soma,t1,t2,mysecond

allocate(a(m,m))
allocate(b(m,m))

s=1.1
soma=0
do i=1,m
        do j=1,m
                if (((j/2)*2).eq.j) then
                        a(i,j)=1
                else
                        a(i,j) = -1
                endif
                b(i,j)=0
        enddo
enddo

t1=mysecond()
do j=1,m
        do i=1,m
                b(i,j) = s * a(i,j)
                soma = soma + b(i,j)
        enddo
enddo
t2=mysecond()

print *,"soma=",soma," Tempo=",t2-t1
stop
end


!***********************************************************************************************************************************
! 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_INIT_CONSTS_N_REF_PARS

    USE MR_KINDS

    USE MR_DEF_RANKS

    USE MR_DEF_CONSTS_N_REF_PARS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_INIT_CONSTS_N_REF_PARS

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFREADION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_INIT_CONSTS_N_REF_PARS( ERROR , ERRMSG )

    USE MR_MOD_FUNC_DS
    USE MR_MOD_FUNC_TCRS

    IMPLICIT NONE

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    INTEGER(KKID_KIND) :: K

    INTEGER(KSID_KIND) :: KS

    COR2 = COR2 / COR

  ! CALCULATE REFERENCE PARAMETERS
    WR = UVR / ( XYR / ZR )
    SR = COR * UVR * XYR / GR
    TUVR = R0 * COR * UVR * ZR
    QSUVR = R0 * COR * XYR * ZR
    KIR = COR * UVR * ZR
    DIR = COR * UVR * UVR

  ! CALCULATE DIMENSIONLESS COMBINATIONS
    RB = UVR / ( COR * XYR )
    RBT = UVR / ( COR * ZR )
    EKXY = VZR / ( COR * XYR * XYR )
    EKZ = VZR / ( COR * ZR * ZR )
    SCXY = DZR / ( COR * XYR * XYR )
    SCZ = DZR / ( COR * ZR * ZR )
    RE = UVR * ZR / V0
    RET = RE / SQRT( RBT )
    FR = UVR * UVR / ( GR * ZR )
    FRD = FR * R0 / ( RR - R0 )
    BPAR = RB * RB / FR
    SURPAR = FR / RB
    SLOPEPAR = ( XYR / ZR ) / SURPAR
    DSPAR = ( ( V0 * V0) / ( GR * (SS-1.0) ) )**(1.0_PARD_KIND/3.0_PARD_KIND) / ZR

   !BLOCK
    IF( NK <= 0 ) THEN
      ERROR = - 1
      ERRMSG = "Invalid number of layers"
      RETURN
    ELSE
    ! CALCULATE DSIGMA
      DSIGMA = 1.0_PARD_KIND / NK
    ! CALCULATE SIGMA COORDINATES
      DO K = 1 , NK
        SIGMA( K ) = (K-NK-0.5_PARD_KIND) * DSIGMA
      END DO
    END IF
   !END BLOCK

   !BLOCK
    IF( NKS < 0 ) THEN
      ERROR = - 1
      ERRMSG = "Invalid number of sediment sizes"
      RETURN
    ELSE IF( NKS == 0 ) THEN
      CONTINUE
    ELSE
    ! CALCULATE DS, TCRS, WS & RBS
      DO KS = 1 , NKS
        DS(KS) = MR_FUNC_DS( D0(KS) )
        TCRS(KS) = MR_FUNC_TCRS( DS(KS) )
      END DO
    END IF
   !END BLOCK

  END SUBROUTINE MR_INIT_CONSTS_N_REF_PARS

  END MODULE MR_MOD_INIT_CONSTS_N_REF_PARS


module mat_class

    use constants, only : wp
    use vec4_class

    !not fully implmented matix class
    !minimum implmented for neural sdf type
    type :: mat
        real(kind=wp) :: vals(4, 4)
        contains

        generic   :: operator(/)     => mat_div_scal
        generic   :: operator(*)     => mat_mult_scal, scal_mult_mat, mat_mult_mat
        generic   :: operator(+)     => mat_add_scal, scal_add_mat
        generic   :: operator(-)     => mat_minus_scal

        procedure, pass(a), private :: mat_div_scal

        procedure, pass(a), private :: mat_mult_mat
        procedure, pass(a), private :: mat_mult_scal
        procedure, pass(b), private :: scal_mult_mat

        procedure, pass(a), private :: mat_add_scal
        procedure, pass(b), private :: scal_add_mat

        procedure, pass(a), private :: mat_minus_scal

    end type mat

    interface mat
        module procedure mat_init
    end interface mat

private
public :: mat
contains

    type(mat) function mat_init(array)

        implicit none

        real(kind=wp) :: array(16)
        integer :: i, cnt

        cnt = 1

        do i = 1, 4
            mat_init%vals(:, i) = array(cnt:cnt+3)
            cnt = cnt + 4
        end do

    end function mat_init

    type(mat) function mat_add_scal(a, b)

        implicit none

        class(mat),    intent(IN) :: a
        real(kind=wp), intent(IN) :: b

        mat_add_scal%vals = a%vals + b

    end function mat_add_scal

    type(mat) function scal_add_mat(a, b)

        implicit none

        class(mat),    intent(IN) :: b
        real(kind=wp), intent(IN) :: a

        scal_add_mat%vals = b%vals + a

    end function scal_add_mat

    type(mat) function mat_minus_scal(a, b)

        implicit none

        class(mat),    intent(IN) :: a
        real(kind=wp), intent(IN) :: b

        mat_minus_scal%vals = a%vals - b

    end function mat_minus_scal

    type(mat) function mat_div_scal(a, b)

        implicit none

        class(mat),    intent(IN) :: a
        real(kind=wp), intent(IN) :: b

        mat_div_scal%vals = a%vals / b

    end function mat_div_scal

    type(mat) function mat_mult_scal(a, b)

        implicit none

        class(mat),    intent(IN) :: a
        real(kind=wp), intent(IN) :: b

        mat_mult_scal%vals = a%vals * b

    end function mat_mult_scal

    type(mat) function scal_mult_mat(a, b)

        implicit none

        class(mat),    intent(IN) :: b
        real(kind=wp), intent(IN) :: a

        scal_mult_mat%vals = b%vals * a

    end function scal_mult_mat

    type(vec4) function mat_mult_mat(a, b)

        use vec4_class

        implicit none

        class(mat), intent(IN) :: a
        type(vec4), intent(IN) :: b

        real(kind=wp) :: tmp(4)

        tmp = matmul(a%vals, [b%x, b%y, b%z, b%p])
        mat_mult_mat = vec4(tmp(1), tmp(2), tmp(3), tmp(4))

    end function mat_mult_mat

end module mat_class

! Program p

!     use mat_class
!     use vec4_class

!     implicit none

!     real(kind=wp) :: array(16)
!     type(mat) :: m
!     type(vec4) :: v4

!     v4 = vec4(1., 1., 1., 1.)

!     array = [1., 1., 1., 1., 2., 2., 2., 2., 3., 3., 3., 3., 4., 4., 4., 4.]
!     m = mat(array)
!     write(*,"(4f9.5)")m%vals

!     m = m + 1.
!     print*," "
!     write(*,"(4f9.5)")m%vals

!     m = 1. + m
!     print*," "
!     write(*,"(4f9.5)")m%vals

!     m = m - 2.
!     print*," "
!     write(*,"(4f9.5)")m%vals

!     m = m / 2.
!     print*," "
!     write(*,"(4f9.5)")m%vals

!     m = m * 2.
!     print*," "
!     write(*,"(4f9.5)")m%vals

!     ! m = 2. * m
!     ! print*," "
!     ! write(*,"(4f9.5)")m%vals

!     v4 = m * v4
!     print*," "
!     write(*,"(4f9.5)")v4
! end program p


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE ENGSTR (NNUM, NSIG, RNUM, RSTR, LSTR)
C=======================================================================

C   --*** ENGSTR *** (STRLIB) Convert real numbers to strings
C   --   Written by Amy Gilkey - revised 02/14/86
C   --
C   --ENGSTR converts a set of real numbers into engineering notation
C   --strings.  The real numbers are not compared in any way to get a
C   --consistent set of exponents, etc.
C   --
C   --Parameters:
C   --   NNUM - IN - the number of numbers in the array set
C   --   NSIG - IN - the maximum number of significant digits, max of 8
C   --   RNUM - IN - the array of real numbers to be converted
C   --   RSTR - OUT - the set of real number strings
C   --   LSTR - OUT - the maximum length of the number strings

C   --Routines Called:
C   --   IENGRX - (included) Get engineering notation exponent

      INTEGER NNUM
      INTEGER NSIG
      REAL RNUM(*)
      CHARACTER*(*) RSTR(*)
      INTEGER LSTR

      CHARACTER*10 SCRFMT
      CHARACTER*20 SCRSTR
      CHARACTER*15 FFMT

C   --Do not try to use a common exponent, but use engineering notation

      WRITE (SCRFMT, 10, IOSTAT=IDUM) NSIG+7, NSIG
   10 FORMAT ('(0PE', I2.2, '.', I2.2, ')')

      LSTR = 0
      DO 40 I = 1, NNUM
         WRITE (SCRSTR(1:NSIG+7), SCRFMT, IOSTAT=IDUM) RNUM(I)
         READ (SCRSTR(NSIG+5:NSIG+7), '(I3)', IOSTAT=IDUM) IE
         ISIGN = 0
         IF (RNUM(I) .LT. 0.0) ISIGN = 1

         NEWEXP = IENGRX (IE, IE)

         EXPDIV = 10.0 ** NEWEXP

         NWHOLE = MAX (0, IE - NEWEXP)
         NFRAC = MAX (0, MIN (NEWEXP - IE + NSIG,
     &      NSIG - (IE - NEWEXP)))
         NTOTAL = ISIGN + NWHOLE + 1 + NFRAC

         WRITE (FFMT, 20, IOSTAT=IDUM) NTOTAL, NFRAC
   20    FORMAT ('(F', I2.2, '.', I2.2, ')')
         WRITE (FFMT(8:15), 30, IOSTAT=IDUM) NEWEXP
   30    FORMAT (',''E', SP, I3.2, ''')')
         LSTR = MAX (LSTR, NTOTAL+4)

         WRITE (RSTR(I), FFMT, IOSTAT=IDUM) RNUM(I)/EXPDIV
   40 CONTINUE

      RETURN
      END


module rate_module
   use precision_module, only : wp
   use input_module
   use constants_module
   use error_module
   implicit none
   public

contains
!==================================================================================
!====================== MICROCANONICAL RATE CONSTANT k(E) =========================
!==================================================================================
subroutine nast_en_rate(dosR,dosX,dosTP,probLZ,probWC,probZN,nosLZ,nosWC,nosZN)

real(wp)                             :: WCsto,LZsto,ZNsto
real(wp), allocatable                :: nosWC_TP(:), nosZN_TP(:)
real(wp), allocatable                :: nosWC_X (:), nosZN_X (:)
real(wp), allocatable                :: rateLZ(:),  rateWC(:),  rateZN(:)
real(wp), dimension(:), intent(in)   :: dosR, dosX, dosTP
real(wp), dimension(:), intent(in)   :: probLZ, probWC, probZN
real(wp), dimension(:), intent(out)  :: nosLZ, nosWC, nosZN
integer                              :: i, j

allocate (nosWC_X  (maxn))
allocate (nosZN_X  (maxn))
allocate (nosWC_TP (maxn))
allocate (nosZN_TP (maxn))
allocate (rateLZ   (maxn))
allocate (rateWC   (maxn))
allocate (rateZN   (maxn))

nosWC_X  = zero
nosZN_X  = zero
nosWC_TP = zero
nosZN_TP = zero
rateLZ   = zero
rateWC   = zero
rateZN   = zero

!**********************************************************************
!   OVER-THE-BARRIER CONTRIBUTION TO THE RATE
!      (over-the-barrier number of states)
!**********************************************************************
if (maxn.gt.binX) then
  do i=1+binX, maxn !start from MECP bin
    LZsto = zero
    WCsto = zero
    ZNsto = zero
    do j=1+binX, i ! NOS above crossing point at i-th bin
      LZsto = probLZ(j)*dosX(i-j+1+binX) + LZsto
      WCsto = probWC(j)*dosX(i-j+1+binX) + WCsto
      ZNsto = probZN(j)*dosX(i-j+1+binX) + ZNsto
    enddo
    nosLZ(i)   = LZsto/autocm
    nosWC_X(i) = WCsto/autocm
    nosZN_X(i) = ZNsto/autocm
 enddo
endif

!**********************************************************************
!   TUNNELING CONTRIBUTION TO THE RATE         ^_^
!      (tunneling number of states)
!**********************************************************************
! Number of states at each turning point is approximated by single point with
! properties taken at MECP.

do i=1, maxn
  WCsto = zero
  ZNsto = zero
  if (i.le.binX) then
    do j=1, i
      WCsto = probWC(j)*dosTP(i-j+1) + WCsto
      ZNsto = probZN(j)*dosTP(i-j+1) + ZNsto
    enddo
  else
    do j=1, binX
      WCsto = probWC(j)*dosTP(i-j+1) + WCsto
      ZNsto = probZN(j)*dosTP(i-j+1) + ZNsto
    end do
  end if
   nosWC_TP(i) = WCsto/autocm
   nosZN_TP(i) = ZNsto/autocm
end do

!*****************************************
!        TOTAL NUMBER OF STATES
!*****************************************
nosWC = nosWC_X + nosWC_TP
nosZN = nosZN_X + nosZN_TP

!*****************************************
!      Microcanonical Rate Constant
!*****************************************
!binZPE = 0 if either zpe = 0 or zpe = 1 correction is used.
do i=1, maxn-binZPE
  if (dosR(i).ne.zero) then
    rateLZ(i) = degenR*nosLZ(i+binZPE)/(dosR(i)*planck_hsec)
    rateWC(i) = degenR*nosWC(i+binZPE)/(dosR(i)*planck_hsec)
    rateZN(i) = degenR*nosZN(i+binZPE)/(dosR(i)*planck_hsec)
  end if
end do

open(1451,file='energy_rates.out')

if (zn) then
  write(1451,'(A,5x,A,5x,A,5x,A)') 'E, cm-1','rate LZ','rate WC','rate ZN'

 do i=1, maxn
   write(1451,'(I5,3es24.7)') i, rateLZ(i), rateWC(i), rateZN(i)
 end do
else
 write(1451,'(A,5x,A,5x,A)') 'E, cm-1','rate LZ','rate WC'
 do i=1, maxn
   write(1451,'(I5,2es24.7)') i, rateLZ(i), rateWC(i)
 end do
end if

close(1451)

if (printmore) then
  open(1415,file='effective_number_of_states.out')
  write(1415,'(A,5x,A,5x,A)') 'E, cm-1','nosLZ','nosWC'
  do i=1, maxn
    write(1415,'(I5,2es24.7)') i, nosLZ(i), nosWC(i)
  enddo

  close(1415)

end if

write(66,'(A,I1,A)') '     (The forward rate constant k(E) is multiplied by &
reaction path degeneracy equal to ',int(degenR),' ).'

deallocate (nosWC_X)
deallocate (nosZN_X)
deallocate (nosWC_TP)
deallocate (nosZN_TP)
deallocate (rateLZ)
deallocate (rateWC)
deallocate (rateZN)

end subroutine nast_en_rate
!=====================================================================================
subroutine nast_en_rate_split(dosR,dosX,probLZS,nosLZS)
   real(wp), allocatable                 :: LZSsto(:)
   real(wp), allocatable                 :: rateLZS(:,:)
   real(wp), dimension(:), intent(in)    :: dosR, dosX
   real(wp), dimension(:,:), intent(in)  :: probLZS
   real(wp), dimension(:,:), intent(out) :: nosLZS
   integer                               :: i, j

   allocate (rateLZS  (maxn,icp))
   allocate (LZSsto   (icp))

   rateLZS = zero

   !**********************************************************************
!   OVER-THE-BARRIER CONTRIBUTION TO THE RATE
!      (over-the-barrier number of states)
!**********************************************************************
   if (maxn.gt.binX) then
      do i=1+binX, maxn !start from MECP bin
         LZSsto = zero
           do j=1+binX, i ! NOS above crossing point at i-th bin
              LZSsto(:) = probLZS(j,:)*dosX(i-j+1+binX) + LZSsto(:)
           enddo
         nosLZS(i,:)   = LZSsto(:)/autocm
      enddo
  endif

     !*****************************************
   !      Microcanonical Rate Constant
   !*****************************************
   !binZPE = 0 if no ZPE correction or ZPE1 correction is used
  do i=1, maxn-binZPE
   if (dosR(i).ne.zero) then !Eq. (1) ref_1
      rateLZS(i,:) = degenR*nosLZS(i+binZPE,:)/(dosR(i)*planck_hsec)
   end if
  end do

  open(556,file='split_energy_rate.out')
  write(556,'(a)', advance="no") "Energy(cm-1)"
  write(556, '(4X,I2,A,I2,A,I2,A,I2)', advance="no") mults(1), "_", 1, &
                                                   "  ->",mults(2), "_", 1
  do i=2, icp
   write(556, '(11X,I2,A,I2,A,I2,A,I2)', advance="no") mults(1), "_", 1+floor((real(i)-1)/3), &
                                            " ->", mults(2), "_", mod(i-1,3)+1+floor((real(i)-1)/3)
  end do

  write(556,'(/)')

  do i=1, maxn
      write(556,*) i, rateLZS(i,:)
  enddo
close(556)

deallocate (rateLZS)
deallocate (LZSsto)

end subroutine nast_en_rate_split
!============================================================================
subroutine tst_en_rate(dosR,dosX,nosTST)
implicit none

   integer                            :: i
   real(wp), allocatable              :: rateTST(:)
   real(wp), allocatable, intent(in)  :: dosR(:), dosX(:)
   !real(wp), allocatable, intent(out) :: nosTST(:)
   real(wp), dimension(:), intent(out) :: nosTST

   allocate (rateTST  (maxn))

   write(66,'(/,A)') 'Calculating microcanonical TST rate constant.'

   nosTST = zero
   rateTST = zero

   do i = 1+binX, maxn ! Start from the MECP bin
      nosTST(i) = sum(dosX(1+binX:i))
   end do

   nosTST = nosTST/autocm

   !do i = 1, maxn-binZPE
   !   if (dosR(i) .ne. 0.0d0) then
   !      rateTST(i) = degen*nosTST(i+binZPE)*autoev/(dosR(i)*planck)
   !   end if
   !enddo

   where (dosR .ne. zero)
       rateTST(1:maxn-binZPE) = degenR*nosTST(1+binZPE:maxn)&
       *autoev/(dosR(1:maxn-binZPE)*planck)
   end where

   open(322,file='energy_tst_rate.out')
      write(322,'(a)') 'E, cm-1     ', &
                    'TST rate'
   do i=1, maxn
      write(322,200) i, rateTST(i)
   enddo
   close(322)
  200 format('',i5,es24.7)

  write(66,'(A)') '................................... Done.'
  write(66,'(/,A,I1,A)') '     (The forward rate constant k(E) is multiplied by &
 reaction path degeneracy equal to ',int(degenR),' )'

end subroutine tst_en_rate
!==================================================================================
!============== MACROCANONICAL (THERMAL) RATE CONSTANT k(T) =======================
!==================================================================================
subroutine nast_can_rate(dosR,nosLZ,nosWC,nosZN)
   implicit none
   character(len=33)                       :: printLZ, printWC, printZN
   integer                                 :: i,j,T_n_points
   real(wp)                                :: qR, kbt, Temp
   real(wp)                                :: trateLZ, trateWC, trateZN
   real(wp), dimension(:), intent(in)      :: dosR, nosLZ, nosWC, nosZN

   Temp = zero
   kbt = zero

   if (zn) then
       write(66, 200)
   else
       write(66, 201)
   end if

    do j = 0, Tpoints
      Temp = T1 + dble(j)*Tstep

      trateLZ = zero
      trateWC = zero
      trateZN = zero

      qR      = zero !Partition function for reactants
      kbt = kb_hartK*Temp !kb is Boltzmann constant

      do i=1, maxn
        qR=qR + dosR(i)*exp(-dble(i)/(autocm*kbt))
      enddo

      do i=1, maxn
        trateLZ  = trateLZ + nosLZ(i)*exp(-dble(i)/(autocm*kbt))
        trateWC  = trateWC + nosWC(i)*exp(-dble(i)/(autocm*kbt))
        trateZN  = trateZN + nosZN(i)*exp(-dble(i)/(autocm*kbt))
      end do

      trateLZ = trateLZ/(planck_hsec*qR)
      trateWC = trateWC/(planck_hsec*qR)
      trateZN = trateZN/(planck_hsec*qR)

      if (zn) then
         write(printLZ,'(es24.2)') trateLZ
         write(printWC,'(es24.2)') trateWC
         write(printZN,'(es24.2)') trateZN
         write(66, 202) Temp, trim(adjustl(adjustr(printLZ))), &
                              trim(adjustl(adjustr(printWC))), &
                              trim(adjustl(adjustr(printZN)))
      else
         write(printLZ,'(es24.2)') trateLZ
         write(printWC,'(es24.2)') trateWC
         write(66, 203) Temp, trim(adjustl(adjustr(printLZ))), &
                              trim(adjustl(adjustr(printWC)))
      end if

    enddo

  200 format(/,/,13x,'Canonical rate constant, k(T).',/,/,&
            5x,'T(K)',3x,'Landau-Zener',3x,'Weak Coupling',3x,'Zhu Nakamura',/)
  201 format(/,/,13x,'Canonical rate constant, k(T)',/,/,&
            5x,'T(K)',3X,'Landau-Zener',3x,'Weak Coupling',/)

  202 format(4x,f7.1,4x,a,8x,a,8x,a)
  203 format(4x,f7.1,4x,a,8x,a)

end subroutine nast_can_rate
!================================================================
subroutine tst_can_rate(dosR,nosTST)
   implicit none
   character(len=33)                          :: printTST
   integer                                    :: i,j,T_n_points
   real(wp)                                   :: qR, kbt, Temp
   real(wp)                                   :: trateTST
   real(wp), allocatable, intent(in)          :: dosR(:)
   real(wp), allocatable, intent(in)          :: nosTST(:)

   Temp = zero
   kbt = zero

   write(66, 201)

   do j = 0, Tpoints
      Temp = T1 + dble(j)*Tstep

      trateTST = zero

      qR      = zero !Partition function for reactants
      kbt = kb_hartK*Temp !kb is Boltzmann constant

      do i=1, maxn
        qR=qR + dosR(i)*exp(-dble(i)/(autocm*kbt))
      enddo

      do i=1, maxn
        trateTST  = trateTST + nosTST(i)*exp(-dble(i)/(autocm*kbt))
      end do

      trateTST = trateTST/(planck_hsec*qR)
      write(printTST,'(es24.2)') trateTST
      write(66, 203) Temp, trim(adjustl(adjustr(printTST)))

   enddo

  201 format(/,/,13x,'Canonical rate constant, k(T)',/,/,&
            5x,'T(K)',5x,'TST rate constant',/)

  203 format(2x,f7.1,5x,a)
end subroutine tst_can_rate
!==================================================================================
!================ MICROCANONICAL REVERSE RATE CONSTANT k(E) =======================
!==================================================================================
subroutine nast_en_rate_rev(dosP_full,dosX_full,dosX_TP_rev,probLZ_rev,probWC_rev,nosLZ_full,nosWC_full)

 real(wp), dimension(:), intent(in)  :: dosP_full,dosX_full,dosX_TP_rev,probLZ_rev,probWC_rev
 real(wp), dimension(:), intent(out) :: nosLZ_full,nosWC_full
 real(wp), allocatable               :: REVrateLZ(:), REVrateWC(:),nosWC_X(:),nosWC_TP(:)
 integer                             :: i,j
 real(wp)                            :: LZsto,WCsto,p

 allocate (REVrateLZ     (maxn+binGAP))
 allocate (REVrateWC     (maxn+binGAP))
 allocate (nosWC_X       (maxn+binGAP))
 allocate (nosWC_TP      (maxn+binGAP))

nosLZ_full = zero
nosWC_full = zero
nosWC_X    = zero
nosWC_TP   = zero
REVrateLZ  = zero
REVrateWC  = zero

!************************************
!   Over the barrier contribution   *
!   to the resverse rate constant.  *
!   Calculating over-the-barrier    *
!   number of states.               *
!************************************

if (maxn+binGAP.gt.binXrev) then
  do i=1+binXrev, maxn+binGAP !start from MECP bin.
    LZsto = zero
    WCsto = zero
    do j=1+binXrev, i ! NOS above crossing point at i-th bin
     LZsto = probLZ_rev(j)*dosX_full(i-j+1+binXrev) + LZsto
     WCsto = probWC_rev(j)*dosX_full(i-j+1+binXrev) + WCsto
    end do
    nosLZ_full(i)   = LZsto/autocm
    nosWC_X(i)      = WCsto/autocm
  end do
end if

 write(66,'(/,a)') 'Calculating reverse rate constant.'
 write(66,'(/,a,I2)') 'The reverse rate constant k(E) is multiplied by &
           reaction path degeneracy equals to ',int(degenP)

!************************************
!   Tunneling contribution          *
!   to the resverse rate constant.  *
!   Calculating tunneling           *
!   number of states.               *
!************************************
! Number of states at each turning point is approximated by single point
! with properties taken at MECP.

do i = binGAP+1, maxn + binGAP
  WCsto = zero
  if (i .le. binXrev) then
    do j = binGAP+1, i
     WCsto = probWC_rev(j)*dosX_TP_rev(i-j+binGAP+1) + WCsto
    end do
  else
    do j  = binGAP+1, binXrev
     WCsto = probWC_rev(j)*dosX_TP_rev(i-j+binGAP+1) + WCsto
    end do
  end if
  nosWC_TP(i) = WCsto/autocm
end do

!*****************************
!   Total number of states
!*****************************

nosWC_full = nosWC_X + nosWC_TP

! Microcanonical reverse rate constant.

do i = 1, maxn + binGAP
  if (dosP_full(i).ne.0.0d0) then
    REVrateLZ(i) = degenP*nosLZ_full(i)/(dosP_full(i)*planck_hsec)
    REVrateWC(i) = degenP*nosWC_full(i)/(dosP_full(i)*planck_hsec)
  end if
end do

open(144,file='energy_rate_reverse.out')
write(144,'(a,4x,a,4x,a)') 'E, cm-1','Reverse rate LZ','Reverse rate WC'

do i = 1, maxn + binGAP
  write(144,200) i, REVrateLZ(i), REVrateWC(i)
end do

if (printmore) then
  open(1444,file='effective_number_of_states_rev.out')
  write(1444,'(a,4x,a,4x,a)') 'E, cm-1','LZ','WC'

  do i = 1, maxn + binGAP
    write(1444,'(i5,es24.7,4x,es24.7)') i,nosLZ_full(i),nosWC_full(i)
  end do

close(1444)
end if

deallocate (REVrateLZ)
deallocate (REVrateWC)

close(144)
200 format(i5,2es24.15)

end subroutine nast_en_rate_rev
!==============================================================================
!============= MACROCANONICAL (THERMAL) REVERSE RATE CONSTNAT k(T) ============
!==============================================================================
subroutine nast_can_rate_rev(dosP_full,nosLZ_full,nosWC_full)

implicit none
real(wp), dimension(:), intent(in)  :: dosP_full,nosLZ_full,nosWC_full
character(len=33)                   :: printLZ, printWC
integer                             :: i,j
real(wp)                            :: qP_full,kbt, temp
real(wp)                            :: rev_trateLZ, rev_trateWC

temp = zero
kbt = zero

write(66, 201)

do j = 0, Tpoints

  temp = T1 + dble(j)*Tstep
  rev_trateLZ = zero
  rev_trateWC = zero
  qP_full = zero
  kbt = kb_hartK*Temp !kb is Boltzmann constant

  do i=1, maxn+binGAP
    qP_full = qP_full + dosP_full(i)*exp(-dble(i)/(autocm*kbt))
    rev_trateLZ = rev_trateLZ + nosLZ_full(i)*exp(-dble(i)/(autocm*kbt))
    rev_trateWC = rev_trateWC + nosWC_full(i)*exp(-dble(i)/(autocm*kbt))
  end do

  rev_trateLZ = rev_trateLZ/(planck_hsec*qP_full)
  rev_trateWC = rev_trateWC/(planck_hsec*qP_full)

  write(printLZ,'(es24.2)') rev_trateLZ
  write(printWC,'(es24.2)') rev_trateWC
  write(66, 203) Temp, trim(adjustl(adjustr(printLZ))), &
                         trim(adjustl(adjustr(printWC)))

end do

201 format(/,/,13X,'Canonical reverse rate constant, k(T)',/,/,&
           5x,'T(K)',5x,'Landau-Zener',5x,'Weak Coupling',/)
203 format(4x,f7.1,4x,a,8x,a)

end subroutine nast_can_rate_rev

! Traditional TST microcanonical reverse rate constant.

subroutine tst_en_rate_rev(dosP_full,dosX_full,nosTST_full)
implicit none

real(wp), dimension(:), intent(in)  :: dosP_full, dosX_full
real(wp), dimension(:), intent(out) :: nosTST_full
real(wp), allocatable               :: rateTST_rev(:)
integer                             :: i

allocate (rateTST_rev  (maxn+binGAP))
nosTST_full = zero
rateTST_rev = zero
write(66,'(/,A)') 'Calculating microcanonical TST reverse rate constant.'

do i = 1+binXrev, maxn+binGAP
  nosTST_full(i) = sum(dosX_full(1+binXrev:i))
end do

nosTST_full = nosTST_full/autocm

where (dosP_full .ne. zero)
     rateTST_rev(1:maxn+binGAP-binZPE) = degenP*nosTST_full(1+binZPE:maxn+binGAP)&
     *autoev/(dosP_full(1:maxn+binGAP-binZPE)*planck)
end where

open (307, file = 'energy_tst_rate_rev.out')
write(307,'(a,4x,a)') 'E, cm-1','TST reverse rate'
do i = 1, maxn + binGAP
  write(307,199) i, rateTST_rev(i)
enddo
close(307)
199 format('',i5,es24.7)

write(66,'(A)') '................................... Done.'
write(66,'(/,A,I1,A)') '     (The reverse TST rate constant k(E) is multiplied by &
reaction path degeneracy equal to ',int(degenP),' ).'

end subroutine tst_en_rate_rev

! Traditional TST canonical reverse rate constant.

subroutine tst_can_rate_rev(dosP_full,nosTST_full)
implicit none

real(wp), dimension(:), intent(in)  :: dosP_full, nosTST_full
character(len=33)                   :: printTST_rev
real(wp)                            :: qP_full, trateTST_rev, temp, kbt
integer                             :: i,j

temp = zero
kbt = zero
write (66, 201)

do j = 0, Tpoints
  temp = T1 + dble(j)*Tstep
  trateTST_rev = zero
  qP_full = zero
  kbt = kb_hartK*Temp !kb is Boltzmann constant

  do i=1, maxn+binGAP
    qP_full = qP_full + dosP_full(i)*exp(-dble(i)/(autocm*kbt))
    trateTST_rev  = trateTST_rev + nosTST_full(i)*exp(-dble(i)/(autocm*kbt))
  end do

  trateTST_rev = trateTST_rev/(planck_hsec*qP_full)
  write(printTST_rev,'(es24.2)') trateTST_rev
  write(66, 203) temp, trim(adjustl(adjustr(printTST_rev)))

end do

201 format(/,/,13x,'Canonical TST reverse rate constant, k(T).',/,/&
            5x,'T(K)',3x,'TST reverse',/)
203 format(4x,f7.1,4x,a)

end subroutine tst_can_rate_rev

end module rate_module


	SUBROUTINE Pnl

C CALCULATES PERCEIVED NOISE LEVEL OF SPECTRA BASED ON
C 1/3 OCTAVE BANDS FROM 50 Hz TO 10 kHz.
c
c                         Dave McCurdy; modified for use with a
c                         single spectrum by BMS, Oct 20 1992
c           Corrected April 2 1993 (based on CR-2376;
c     Handbook of Noise Metrics - Karl S. Pearsons and Ricarda L. Bennett
c                               (April 1974)
c           Re-Corrected May 25 1993
C
c Tables defined in pnldata.f
c
C NOTE:  This program for computing PNL differs from 'PNL2' in that
C       this one also uses tables M1,L1,M2,L2 in the computations.
C       (Minimum Noy is .1)
C
C FOR L1 .LE. L .LT. L2     Noy=10**(M1*(L-L1))
C WRONG!!!!  FOR L2 .LE. L .LT. L3     Noy=10**(M2*(L-L2))
C Corrected is FOR L2 .LE. L .LT. L3     Noy=10**(M2*(L-L3))
c plus L3a in this formulation differs from the FAR 36 version used in PNL2
c plus LCa in this formulation differs from the FAR 36 version used in PNL2
c plus M3a in this formulation differs from the FAR 36 version used in PNL2
C FOR L3 .LE. L .LT. Lc     Noy=10**(M3*(L-L3))
C FOR Lc .LE. L .LE. 150    Noy=10**(M4*(L-L4))

c L=level (43 1/3 octave bands)
c SPL=calculated loudness level (calculated from L for bands 1 to 40)
        REAL*4 L(43),SPL
        COMMON /CRUX/ SPL,L

C CONTAINS DATA TABLES FOR PNL CALCULATIONS
	INCLUDE 'pnl_pl.cmn'

	REAL*4 Lvalue

	Noys=0.
	Xmaxx=0.
	DO 1069 I=17,40
	   Lvalue=L(I)
	   J=I-16
	   Noy(J)=0.
c Wherever this code came from, it differs slightly and probably undetectably
c from CR-2376 as I (BMS) read it; in order to bring them into line
c I am adding the next two IF statements, May 25 1993 - so who cares anyway?
	   if (Lvalue .ge. Tabl1(j)) then
	    if (Lvalue .gt. 150.0) then
                   print *,'Noy value undefined in CR-2376'
	           print *,'I shall make up a value ...'
	    endif
	    IF (Lvalue .LT. Tabl3a(J)) THEN
	      Y=Lvalue-Tabl2(J)
	      IF (Y .LT. 0) THEN
	         Noy(J)=.1*10.**(Tabm1(J)*(Lvalue-Tabl1(J)))
	      ELSE
	         Noy(J)=10.**(Tabm2(J)*(Lvalue-Tabl3a(J)))
	      ENDIF
	    ELSE
	      X=Lvalue-Tablca(J)
	      IF ((X .LE. 0) .AND. (J .LE. 9 .OR. J .GT. 22)) THEN
	         Noy(J)=10.**(Tabm3a(J)*(Lvalue-Tabl3a(J)))
	      ELSE
	         Noy(J)=10.**(Tabm4(J)*(Lvalue-Tabl4(J)))
	      ENDIF
	    ENDIF
	    Noys=Noys+Noy(J)
	   endif
 1069	CONTINUE

	Xmaxx=Noy(1)

	DO 1075 M=2,24
	   Xmaxx=AMAX1(Xmaxx,Noy(M))
 1075	CONTINUE

	Nn=Xmaxx+.15*(Noys-Xmaxx)
c May 25 1993; the following code rewritten
        IF (Nn .EQ. 0.) then
	   PRINT *,'N=0 WITH NOYS',Noys,'AND XMAX=',Xmaxx
	   Spl = 0.
	else
	   Spl=40.+ALOG10(Nn)/.03010299957
	endif

	RETURN
	END


! Estimates of the thermal and hydraulic parameters
subroutine calc_parameters
USE Declarations
implicit none
real(dp) :: viscosity, &  ! Kinematic viscosity of water [m2/s]
        &   k_w           ! Thermal conductivity of water [W/(K m)]

viscosity = 1.787e-6_dp

do j = 1,M-1
   do i = 1,N-1

      S(i,j) = max((water_content(i,j,1)-irreducible)/(porosity(i,j)-irreducible),0._dp)

      k_w = (1.32_dp + 0.00559_dp * T(i,j,1) - 0.0000263*T(i,j,1)**2)/0.2389_dp

      !================ Effective thermal conductivity, (Calonne et al., 2011) [W/m K] ===============================
      k_eff(i,j) = (2.5e-6_dp*(dry_density(i,j)*dry_density(i,j))-1.23e-4_dp*dry_density(i,j)+0.024_dp) * &
                 & (1._dp - water_content(i,j,1)) + k_w * water_content(i,j,1)

      !================== Hydraulic conductivity of saturated snow (Calonne et al., 2012)  =====================
      Ks(i,j) = 9.81_dp / viscosity * 3.0_dp * (grain_opt(i,j)*0.5_dp)**2 &
         & * dexp(-0.013_dp*dry_density(i,j))

      !================== Van Genuchten parameters  =========================================
      alpha(i,j) = 4.4e6_dp * (grain_classic(i,j)/dry_density(i,j))**(0.98_dp)    ! (Yamaguchi et al., 2012)
      nn(i,j) = 1.0_dp + 2.7e-3_dp * (grain_classic(i,j)/dry_density(i,j))**(-0.61_dp)
      mm(i,j) = 1.0_dp - 1.0_dp/nn(i,j)

      alpha_wetting(i,j) = 2._dp * alpha(i,j)

      !================ Hydraulic conductivity for unsaturated snow ===============================
      !============================= Mualem-VG model ===========================================
      K(i,j) = Ks(i,j)*dsqrt(S(i,j))*(1.0_dp-(1.0_dp-S(i,j)** &
         & (1.0_dp/mm(i,j)))**mm(i,j))**2

   enddo
enddo

! ================= Estimation of the hydraulic conductivity by arithmetic mean ======================
! =================== and arithmetic mean for effective thermal conductivity at the cell interfaces ==
if (M .gt. 2) then ! more than one snow layer
   do j = 1,M-1
      do i = 1,N-1
         if (i .ne. 1 .and. i .ne. N-1 .and. j .ne. 1 .and. j .ne. M-1) then

            !====================== Middle cells ========================
            K_south(i,j) = (K(i,j)+K(i,j-1))*(0.5_dp)
            K_north(i,j) = (K(i,j)+K(i,j+1))*(0.5_dp)
            K_east(i,j) = (K(i,j)+K(i+1,j))*(0.5_dp)
            K_west(i,j) = (K(i-1,j)+K(i,j))*(0.5_dp)

            k_eff_west(i,j) = (0.5_dp)*(k_eff(i,j)+k_eff(i-1,j))
            k_eff_east(i,j) = (0.5_dp)*(k_eff(i,j)+k_eff(i+1,j))
            k_eff_north(i,j) = (0.5_dp)*(k_eff(i,j)+k_eff(i,j+1))
            k_eff_south(i,j) = (0.5_dp)*(k_eff(i,j)+k_eff(i,j-1))
         endif

         if (i .ne. 1 .and. i .ne. N-1 .and. j .eq. 1) then
            !============ Lower boundary except west and east cells ============
            K_east(i,1) = (K(i,1)+K(i+1,1))*(0.5_dp)
            K_west(i,1) = (K(i-1,1)+K(i,1))*(0.5_dp)
            K_north(i,1) = (K(i,1)+K(i,2))*(0.5_dp)
            K_south(i,1) = K(i,1)

            k_eff_west(i,1) = (0.5_dp)*(k_eff(i,1)+k_eff(i-1,1))
            k_eff_east(i,1) = (0.5_dp)*(k_eff(i,1)+k_eff(i+1,1))
            k_eff_north(i,1) = (0.5_dp)*(k_eff(i,1)+k_eff(i,2))
            k_eff_south(i,1) = k_eff(i,1)
         endif

         if (i .ne. 1 .and. i .ne. N-1 .and. j .eq. M-1) then
            !======= upper boundary except west and east cells ================
            K_north(i,M-1) = K(i,M-1)
            K_south(i,M-1) = (K(i,M-1)+K(i,M-2))*(0.5_dp)
            K_east(i,M-1) = (K(i,M-1)+K(i+1,M-1))*(0.5_dp)
            K_west(i,M-1) = (K(i-1,M-1)+K(i,M-1))*(0.5_dp)

            k_eff_west(i,M-1) = (0.5_dp)*(k_eff(i,M-1)+k_eff(i-1,M-1))
            k_eff_east(i,M-1) = (0.5_dp)*(k_eff(i,M-1)+k_eff(i+1,M-1))
            k_eff_north(i,M-1) = k_eff(i,M-1)
            k_eff_south(i,M-1) = (0.5_dp)*(k_eff(i,M-1)+k_eff(i,M-2))
         endif

         if (j .ne. 1 .and. j .ne. M-1 .and. i .eq. N-1) then
            !============ Right boundary except north and south cells ============
            if (choice_lat_BC .eq. 0) then
               K_east(N-1,j) = (K(N-1,j)+K(1,j))*0.5_dp
            else
               K_east(N-1,j) = K(N-1,j)
            endif
            K_west(N-1,j) = (K(N-2,j)+K(N-1,j))*(0.5_dp)
            K_south(N-1,j) = (K(N-1,j)+K(N-1,j-1))*(0.5_dp)
            K_north(N-1,j) = (K(N-1,j)+K(N-1,j+1))*(0.5_dp)

            k_eff_west(N-1,j) = (0.5_dp)*(k_eff(N-1,j)+k_eff(N-2,j))
            k_eff_east(N-1,j) = k_eff(N-1,j)
            k_eff_north(N-1,j) = (0.5_dp)*(k_eff(N-1,j)+k_eff(N-1,j+1))
            k_eff_south(N-1,j) = (0.5_dp)*(k_eff(N-1,j)+k_eff(N-1,j-1))
         endif

         if (j .ne. 1 .and. j .ne. M-1 .and. i .eq. 1) then
            !========= Left boundary except north and south cells ==================
            K_east(1,j) = (K(1,j)+K(2,j))*(0.5_dp)
            if (choice_lat_BC .eq. 0) then
               K_west(1,j) = (K(N-1,j)+K(1,j))*0.5_dp
            else
               K_west(1,j) = K(1,j)
            endif
            K_south(1,j) = (K(1,j)+K(1,j-1))*(0.5_dp)
            K_north(1,j) = (K(1,j)+K(1,j+1))*(0.5_dp)

            k_eff_west(1,j) = k_eff(1,j)
            k_eff_east(1,j) = (0.5_dp)*(k_eff(1,j)+k_eff(2,j))
            k_eff_north(1,j) = (0.5_dp)*(k_eff(1,j)+k_eff(1,j+1))
            k_eff_south(1,j) = (0.5_dp)*(k_eff(1,j)+k_eff(1,j-1))
         endif

         if (j .eq. 1 .and. i .eq. 1) then
            !=========== Lower left cell =========================
            K_east(1,1) = (K(1,1)+K(2,1))*(0.5_dp)
            K_north(1,1) = (K(1,1)+K(1,2))*(0.5_dp)
            if (choice_lat_BC .eq. 0) then
               K_west(1,1) = (K(N-1,1)+K(1,1))*0.5_dp
            else
               K_west(1,1) = K(1,1)
            endif
            K_south(1,1) = K(1,1)

            k_eff_west(1,1) = k_eff(1,1)
            k_eff_east(1,1) = (0.5_dp)*(k_eff(1,1)+k_eff(2,1))
            k_eff_north(1,1) = (0.5_dp)*(k_eff(1,1)+k_eff(1,2))
            k_eff_south(1,1) = k_eff(1,1)
         endif

        if (j .eq. M-1 .and. i .eq. 1) then
            !========== Upper left cell ====================
            K_south(1,M-1) = (K(1,M-1)+K(1,M-2))*(0.5_dp)
            K_east(1,M-1) = (K(1,M-1)+K(2,M-1))*(0.5_dp)
            if (choice_lat_BC .eq. 0) then
               K_west(1,M-1) = (K(N-1,M-1)+K(1,M-1))*0.5_dp
            else
               K_west(1,M-1) = K(1,M-1)
            endif
            K_north(1,M-1) = K(1,M-1)

            k_eff_west(1,M-1) = k_eff(1,M-1)
            k_eff_east(1,M-1) = (0.5_dp)*(k_eff(1,M-1)+k_eff(2,M-1))
            k_eff_north(1,M-1) = k_eff(1,M-1)
            k_eff_south(1,M-1) = (0.5_dp)*(k_eff(1,M-1)+k_eff(1,M-2))
         endif

         if (j .eq. 1 .and. i .eq. N-1) then
            !=========== Lower right cell=======================
            K_north(N-1,1) = (K(N-1,1)+K(N-1,2))*(0.5_dp)
            K_west(N-1,1) = (K(N-2,1)+K(N-1,1))*(0.5_dp)
            if (choice_lat_BC .eq. 0) then
               K_east(N-1,1) = (K(N-1,1)+K(1,1))*(0.5_dp)
            else
               K_east(N-1,1) = K(N-1,1)
            endif
            K_south(N-1,1) = K(N-1,1)

            k_eff_west(N-1,1) = (0.5_dp)*(k_eff(N-1,1)+k_eff(N-2,1))
            k_eff_east(N-1,1) = k_eff(N-1,1)
            k_eff_north(N-1,1) = (0.5_dp)*(k_eff(N-1,1)+k_eff(N-1,2))
            k_eff_south(N-1,1) = k_eff(N-1,1)
         endif

         if (j .eq. M-1 .and. i .eq. N-1) then
            !======= Upper right cell =================
            K_south(N-1,M-1) = (K(N-1,M-1)+K(N-1,M-2))*(0.5_dp)
            K_west(N-1,M-1) = (K(N-2,M-1)+K(N-1,M-1))*(0.5_dp)
            if (choice_lat_BC .eq. 0) then
               K_east(N-1,M-1) = (K(N-1,M-1)+K(1,M-1))*(0.5_dp)
            else
               K_east(N-1,M-1) = K(N-1,M-1)
            endif
            K_north(N-1,M-1) = K(N-1,M-1)

            k_eff_west(N-1,M-1) = (0.5_dp)*(k_eff(N-1,M-1)+k_eff(N-2,M-1))
            k_eff_east(N-1,M-1) = k_eff(N-1,M-1)
            k_eff_north(N-1,M-1) = k_eff(N-1,M-1)
            k_eff_south(N-1,M-1) = (0.5_dp)*(k_eff(N-1,M-1)+k_eff(N-1,M-2))
         endif
      enddo
   enddo

else   ! M = 2, i.e. one layer
   !======== right cell =====================
   K_north(N-1,1) = K(N-1,1)
   K_west(N-1,1) = (K(N-2,1)+K(N-1,1))*(0.5_dp)
   if (choice_lat_BC .eq. 0) then
      K_east(N-1,1) = (K(N-1,1)+K(1,1))*0.5_dp
   else
      K_east(N-1,1) = K(N-1,1)
   endif
   K_south(N-1,1) = K(N-1,1)

   k_eff_west(N-1,1) = (0.5_dp)*(k_eff(N-1,1)+k_eff(N-2,1))
   k_eff_east(N-1,1) = k_eff(N-1,1)
   k_eff_north(N-1,1) = k_eff(N-1,1)
   k_eff_south(N-1,1) = k_eff(N-1,1)

   ! ============= left cell ========================
   K_east(1,1) = (K(1,1)+K(2,1))*(0.5_dp)
   K_north(1,1)= K(1,1)
   if (choice_lat_BC .eq. 0) then
      K_west(1,1) = (K(N-1,1)+K(1,1))*0.5_dp
   else
      K_west(1,1) = K(1,1)
   endif
   K_south(1,1) = K(1,1)

   k_eff_west(1,1) = k_eff(1,1)
   k_eff_east(1,1) = (0.5_dp)*(k_eff(1,1)+k_eff(2,1))
   k_eff_north(1,1) = k_eff(1,1)
   k_eff_south(1,1) = k_eff(1,1)

   !================ Middle cells =====================
   K_east(2:N-2,1) = (K(2:N-2,1)+K(3:N-1,1))*(0.5_dp)
   K_west(2:N-2,1) = (K(1:N-3,1)+K(2:N-2,1))*(0.5_dp)
   K_north(2:N-2,1) = K(2:N-2,1)
   K_south(2:N-2,1) = K(2:N-2,1)

   k_eff_west(2:N-2,1) = (0.5_dp)*(k_eff(2:N-2,1)+k_eff(1:N-3,1))
   k_eff_east(2:N-2,1) = (0.5_dp)*(k_eff(2:N-2,1)+k_eff(3:N-1,1))
   k_eff_north(2:N-2,1) = k_eff(2:N-2,1)
   k_eff_south(2:N-2,1) = k_eff(2:N-2,1)

endif

RETURN
end


      double precision function r(p,i,j)
c----calculate the jets separation between p(i) and p(j)
      implicit none
      include 'constants.f'
      double precision p(mxpart,4),r1,r2,dely,delphi,ei,ej,pti2,ptj2
      integer i,j

      pti2=p(i,1)**2+p(i,2)**2
      ptj2=p(j,1)**2+p(j,2)**2

      ei=dsqrt(pti2+p(i,3)**2)
      ej=dsqrt(ptj2+p(j,3)**2)

      r1= (ei+p(i,3))*(ej-p(j,3))/
     &   ((ej+p(j,3))*(ei-p(i,3)))
      dely=0.5d0*dlog(r1)

      r2= (p(i,1)*p(j,1)+p(i,2)*p(j,2))/dsqrt(pti2*ptj2)
      if (r2 .gt. +0.9999999D0) r2=+1D0
      if (r2 .lt. -0.9999999D0) r2=-1D0
      delphi=dacos(r2)

      r=dsqrt(dely**2+delphi**2)

      return
      end


      FUNCTION F6211(I,A,B,X)
      DIMENSION  X(1)
      XX = X(I)
      IF ( (B * XX) ** 2 - A ** 2 ) 100,1,200
    1 CONTINUE
      IF (A .NE. B * XX) GO TO 50
      F6211=0.5* (ALOG(ABS(2.0 * B * XX))) ** 2
      RETURN
   50 CONTINUE
      F6211 = 0.0
      RETURN
  100 CONTINUE
      F6211 = ALOG(ABS(A)) * ALOG(ABS(XX))
      C1 =-B * XX / A
      C2 = 1.0
      J = 0
  110 J = J + 1
      AAJ = J
      C2 = C2 * C1
      C3 = C2 / (AAJ ** 2)
      F6211 = F6211 - C3
      IF (ABS(C3) .GT. 0.000001) GO TO 110
      RETURN
  200 CONTINUE
      F6211 = (ALOG(ABS(B * XX)) ** 2) / 2.0
      C1 =-A / (B * XX)
      C2 = 1.0
      J = 0
  210 J = J + 1
      AAJ = J
      C2 = C2 * C1
      C3 = C2 / (AAJ ** 2)
      F6211 = F6211 + C3
      IF (ABS(C3) .GT. 0.000001) GO TO 210
      RETURN
      END


cc Copyright (C) 2009: Zydrunas Gimbutas and Hong Xiao
cc Contact: Zydrunas Gimbutas <gimbutas@cims.nyu.edu>
cc          Hong Xiao <hxiao@ucdavis.edu>
cc
cc This software is being released under a modified FreeBSD license
cc (see COPYING in home directory).
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c       Orthogonal polynomials on the standard tetrahedron
c
c       (-1,-1/Sqrt[3],-1/Sqrt[6]), (0,2/Sqrt[3],-1/Sqrt[6]),
c       (1,-1/Sqrt[3],-1/Sqrt[6]),  and (0,0,3/Sqrt[6])
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c       This file contains a set of subroutines for the handling
c       of the evaluation of orthogonal polynomials on the standard
c       tetrahedron.  It contains 2 user-callable subroutines.
c
c   ortho3eva - evaluates at the user-supplied point w
c       a collection of polynomials (of x,y,z) orthogonal on the
c       standard tetrahedron
c
c   ortho3eva4 - evaluates at the user-supplied point w a collection
c       of polynomials (of x,y,z) orthogonal on the standard tetrahedron,
c       together with their derivatives with respect to x, y, and z.
c
c
c     NOTE: experimental code, needs better memory management!!!
c
c
c
        subroutine ortho3eva(maxorder,xyz,fvals,ncount)
c
        implicit none
c
        real *8 xyz(3)
c
        real *8 fvals(1),derxs(1),derys(1),derzs(1),
     1     f2s(1400 00),f3s(1400 00)
c
        real *8 f1(1400 00),
     1     dersx1(1400 00),dersy1(1400 00),
     2     dxs(1400 00), dys(1400 00)
c
        real *8 dummy1(1400 00),dummy2(1400 00)

        integer maxorder,ncount,needle,mp,mmax,n,k,m
        real *8 zold,yold,xold,zero,done,s6,s3,x,y,z,u,v,w,
     1     par1,par2,par5,xa,yb,par7,fval,derx,par6,q1,q2,q3,dery,
     2     derz,rr,scale,derynew,derznew

c
c       This subroutine evaluates the Koornwinder's
c       orthogonal polynomial up to order maxorder
c       on the standard tetrahedron with the  vertices
c
c          (-1,-1/Sqrt[3],-1/Sqrt[6]), (0,2/Sqrt[3],-1/Sqrt[6]),
c          (1,-1/Sqrt[3],-1/Sqrt[6]),  and
c          (0,0,3/Sqrt[6])
c
c       at the user specified point xyz=(xold,yold,zold),  together
c       with their derivatives with respect to xold, yold, and zold.
c       The polynomials are ordered by their order, and in each order,
c       they are ordered lexicographically in terms of their indices
c       (m,n,k).   The total number of polynomials should be
c       (6+11m+6 m^2 + m^3)/6.
c
c
c       This subroutine is based on the Koornwinder's representation
c       of the orthogonal polynomials on the right triangle
c
c       (-1,-1,-1), (-1,1,-1), (1,-1,-1),(-1,-1,1)                    (2)
c       which is given by the formula
c
c       K_mnk(x,y,z) =
c            P_m ((2x+2+y+z)/(-y-z)) * ((-y-z)/2)^m *
C                  P_n^{2m+1,0}((2y+1+z)/(1-z)) * ((1-z)/2)^{n}
C                  P_k^{2m+2n+2,0} (z)
c       with (x,y,z) transformed as
c       x = -1/2 + xold -yold/s3 - zold/s6
c       y = -1/2 + 2/s3 * yold - zold/s6
c       z = -1/2 + s6/2 * zold
c       and
c       s3=sqrt(3)
c       s6=sqrt(6).
c       Futhermore, P_m are the Legendge polynomials of order m
c       and P_n^{2m+1,0} are the Jacobi polynomials of order n with
c       the parameters alpha=2*m+1 and beta=0, etc.
c
C
c
c                   Input parameters:
c
c  mmax - the maximum order to which the polynomials are to be evaluated;
c  z - the location in R^3 where the polynomials are to be evaluated;
c       normally, expected to be inside (including boundary) the
c       standard triangle (1) above.
c  w - the work array. must be at least mmax+1+(mmax+1)**2 long
c
c                   Output parameters:
c
c  fval - the orthogonal polynomial evaluated at the point z
c  derx - the derivative with respect to x of the polynomial
c  dery - the partial derivative with respect to y of the polynomial
c  derz - the derivative with respect to y of the polynomial
c

c       . . . allocate memory for the work arrays
c
c
c
        xold=xyz(1)
        yold=xyz(2)
        zold=xyz(3)

c
c       convert the coordinates onto the right tetrahedron
c

ccc        call prinf("evas: just entering *",1,1)

        zero=0
        done=1
        s6=sqrt(6*done)
        s3=sqrt(3*done)
c
          x=-done/2 + xold - yold/s3 - zold/s6
          y=-done/2 + 2*yold/s3 - zold/s6
          z=-done/2 + zold*s6/2
c
           u=(2*x+2+y+z)/(-y-z)
           v=(2*y+1+z)/(1-z)
           w=z
CCC

        par1=(2*x+2+y+z)/2
        par2=(-y-z)/2

ccc        call prinf("evas: before klegeypols *",2,1)

c
c       gives one extra function values, since the order starts at 0.
c
        call klegeypols3(par1,par2,maxorder,f1,dersx1,dersy1)

c
c
c       get f2s, (maxorder+1)**2 of them
c
        par5=(2*y+1+z)/(1-z)

        needle=1

        do 3400 m=0,maxorder

        par6=2*m+1

        xa=(2*y+1+z)/2.0d0
        yb=(1-z)/2.0d0

        call kjacoypols3(xa,yb,par6,zero,(maxorder-m),f2s(needle),
     1     dxs(needle),dys(needle))

        needle=needle+maxorder+1

ccc        call prin2("f2=*",f2s,(maxorder+1)*(maxorder+1))

c
 3400   continue
c

ccc        call prinf("evas: after f2s=*",needle,1)

c
c       get f3s, (maxorder+1)**2 of them
c
        needle=1
        do 3600 mp=2,2*maxorder+2,2
c
c
        par7=mp

        call kjacoypols3(z,done,par7,zero,(maxorder+1-mp/2),
     1     f3s(needle),dummy1(needle),dummy2)

        needle=needle+maxorder+1

ccc        call prin2("f3=*",f3s,(maxorder+1)*(maxorder+1))

 3600   continue

ccc        call prinf("evas: after f3s=*",needle,1)
c
c
        ncount=0

        do 6000 mmax=0,maxorder
c
        do 5000 m=0,mmax
c
        do 4000 n=0,mmax-m
c
        k=mmax-m-n
        ncount=ncount+1

        fval=f1(m+1)*f2s(n+1 + m*(maxorder+1))*
     1     f3s(k+1 + (m+n)*(maxorder+1))

c
c       partial derivative for x
c
        derx = dersx1(m+1) * f2s(n+1 + m*(maxorder+1)) *
     1     f3s(k+1 + (m+n)*(maxorder+1))

c
c       partial derivative for y
c

        q1=(0.5d0 * dersx1(m+1) -0.5d0*dersy1(m+1))*
     1     f2s(n+1 +  m*(maxorder+1)) * f3s(k+1  + (m+n)*(maxorder+1))

        q2=dxs(n+1  +  m*(maxorder+1))*f1(m+1) *
     1     f3s(k+1  + (m+n)*(maxorder+1))

        dery=q1+q2

c
c       partial derivative for z
c

        q1=(0.5d0 * dersx1(m+1) - 0.5d0*dersy1(m+1))*
     1     f2s(n+1 +  m*(maxorder+1) )* f3s(k+1  + (m+n)*(maxorder+1) )

        q2=(0.5d0*dxs(n+1  +  m*(maxorder+1)) - 0.5d0 *
     1     dys(n+1  +  m*(maxorder+1)) ) *f1(m+1)*
     1     f3s(k+1  + (m+n)*(maxorder+1))

        q3=f1(m+1)*f2s(n+1  +  m*(maxorder+1)) *
     1     dummy1(k+1 + (m+n)*(maxorder+1))

        derz=q1+q2+q3

c
c       scaling
c
	rr= 4.0d0/3

ccc        mmax=m+n+k

ccc	scale=sqrt(rr/(done*2*mmax/3+1)/((2.0d0*m+1)*(n+m+1)))
	scale=sqrt(rr/(done*2*mmax/3+1)/((2.0d0*m+1)*(n+m+1))
     1     /sqrt(2.0d0))

        fvals(ncount)=fval/scale

 4000   continue

 5000   continue

 6000   continue

ccc        call prinf("evas: after loops, ncount=*",ncount,1)

        return
        end
c
c
c
c
c
        subroutine ortho3eva4(maxorder,xyz,fvals,
     1     derxs,derys,derzs,ncount)

        implicit none
c
        real *8 xyz(3)
c
        real *8 fvals(1),derxs(1),derys(1),derzs(1),
     1     f2s(1400 00),f3s(1400 00)
c
        real *8 f1(1400 00),
     1     dersx1(1400 00),dersy1(1400 00),
     2     dxs(1400 00), dys(1400 00)
c
        real *8 dummy1(1400 00),dummy2(1400 00)

        integer maxorder,ncount,needle,mp,mmax,n,k,m
        real *8 zold,yold,xold,zero,done,s6,s3,x,y,z,u,v,w,
     1     par1,par2,par5,xa,yb,par7,fval,derx,par6,q1,q2,q3,dery,
     2     derz,rr,scale,derynew,derznew

c
c       This subroutine evaluates the Koornwinder's
c       orthogonal polynomial up to order maxorder
c       on the standard tetrahedron with the  vertices
c
c          (-1,-1/Sqrt[3],-1/Sqrt[6]), (0,2/Sqrt[3],-1/Sqrt[6]),
c          (1,-1/Sqrt[3],-1/Sqrt[6]),  and
c          (0,0,3/Sqrt[6])
c
c       at the user specified point xyz=(xold,yold,zold),  together
c       with their derivatives with respect to xold, yold, and zold.
c       The polynomials are ordered by their order, and in each order,
c       they are ordered lexicographically in terms of their indices
c       (m,n,k).   The total number of polynomials should be
c       (6+11m+6 m^2 + m^3)/6.
c
c
c       This subroutine is based on the Koornwinder's representation
c       of the orthogonal polynomials on the right triangle
c
c       (-1,-1,-1), (-1,1,-1), (1,-1,-1),(-1,-1,1)                    (2)
c       which is given by the formula
c
c       K_mnk(x,y,z) =
c            P_m ((2x+2+y+z)/(-y-z)) * ((-y-z)/2)^m *
C                  P_n^{2m+1,0}((2y+1+z)/(1-z)) * ((1-z)/2)^{n}
C                  P_k^{2m+2n+2,0} (z)
c       with (x,y,z) transformed as
c       x = -1/2 + xold -yold/s3 - zold/s6
c       y = -1/2 + 2/s3 * yold - zold/s6
c       z = -1/2 + s6/2 * zold
c       and
c       s3=sqrt(3)
c       s6=sqrt(6).
c       Futhermore, P_m are the Legendge polynomials of order m
c       and P_n^{2m+1,0} are the Jacobi polynomials of order n with
c       the parameters alpha=2*m+1 and beta=0, etc.
c
C
c
c                   Input parameters:
c
c  mmax - the maximum order to which the polynomials are to be evaluated;
c  z - the location in R^3 where the polynomials are to be evaluated;
c       normally, expected to be inside (including boundary) the
c       standard triangle (1) above.
c  w - the work array. must be at least mmax+1+(mmax+1)**2 long
c
c                   Output parameters:
c
c  fval - the orthogonal polynomial evaluated at the point z
c  derx - the derivative with respect to x of the polynomial
c  dery - the partial derivative with respect to y of the polynomial
c  derz - the derivative with respect to y of the polynomial
c

c       . . . allocate memory for the work arrays
c
c
c
        xold=xyz(1)
        yold=xyz(2)
        zold=xyz(3)

c
c       convert the coordinates onto the right tetrahedron
c

ccc        call prinf("evas: just entering *",1,1)

        zero=0
        done=1
        s6=sqrt(6*done)
        s3=sqrt(3*done)
c
          x=-done/2 + xold - yold/s3 - zold/s6
          y=-done/2 + 2*yold/s3 - zold/s6
          z=-done/2 + zold*s6/2
c
           u=(2*x+2+y+z)/(-y-z)
           v=(2*y+1+z)/(1-z)
           w=z
CCC

        par1=(2*x+2+y+z)/2
        par2=(-y-z)/2

ccc        call prinf("evas: before klegeypols *",2,1)

c
c       gives one extra function values, since the order starts at 0.
c
        call klegeypols3(par1,par2,maxorder,f1,dersx1,dersy1)

c
c
c       get f2s, (maxorder+1)**2 of them
c
        par5=(2*y+1+z)/(1-z)

        needle=1

        do 3400 m=0,maxorder

        par6=2*m+1

        xa=(2*y+1+z)/2.0d0
        yb=(1-z)/2.0d0

        call kjacoypols3(xa,yb,par6,zero,(maxorder-m),f2s(needle),
     1     dxs(needle),dys(needle))

        needle=needle+maxorder+1

ccc        call prin2("f2=*",f2s,(maxorder+1)*(maxorder+1))

c
 3400   continue
c

ccc        call prinf("evas: after f2s=*",needle,1)

c
c       get f3s, (maxorder+1)**2 of them
c
        needle=1
        do 3600 mp=2,2*maxorder+2,2
c
c
        par7=mp

        call kjacoypols3(z,done,par7,zero,(maxorder+1-mp/2),
     1     f3s(needle),dummy1(needle),dummy2)

        needle=needle+maxorder+1

ccc        call prin2("f3=*",f3s,(maxorder+1)*(maxorder+1))

 3600   continue

ccc        call prinf("evas: after f3s=*",needle,1)
c
c
        ncount=0

        do 6000 mmax=0,maxorder
c
        do 5000 m=0,mmax
c
        do 4000 n=0,mmax-m
c
        k=mmax-m-n
        ncount=ncount+1

        fval=f1(m+1)*f2s(n+1 + m*(maxorder+1))*
     1     f3s(k+1 + (m+n)*(maxorder+1))

c
c       partial derivative for x
c
        derx = dersx1(m+1) * f2s(n+1 + m*(maxorder+1)) *
     1     f3s(k+1 + (m+n)*(maxorder+1))

c
c       partial derivative for y
c

        q1=(0.5d0 * dersx1(m+1) -0.5d0*dersy1(m+1))*
     1     f2s(n+1 +  m*(maxorder+1)) * f3s(k+1  + (m+n)*(maxorder+1))

        q2=dxs(n+1  +  m*(maxorder+1))*f1(m+1) *
     1     f3s(k+1  + (m+n)*(maxorder+1))

        dery=q1+q2

c
c       partial derivative for z
c

        q1=(0.5d0 * dersx1(m+1) - 0.5d0*dersy1(m+1))*
     1     f2s(n+1 +  m*(maxorder+1) )* f3s(k+1  + (m+n)*(maxorder+1) )

        q2=(0.5d0*dxs(n+1  +  m*(maxorder+1)) - 0.5d0 *
     1     dys(n+1  +  m*(maxorder+1)) ) *f1(m+1)*
     1     f3s(k+1  + (m+n)*(maxorder+1))

        q3=f1(m+1)*f2s(n+1  +  m*(maxorder+1)) *
     1     dummy1(k+1 + (m+n)*(maxorder+1))

        derz=q1+q2+q3

c
c       scaling
c
	rr= 4.0d0/3

ccc        mmax=m+n+k

ccc	scale=sqrt(rr/(done*2*mmax/3+1)/((2.0d0*m+1)*(n+m+1)))
	scale=sqrt(rr/(done*2*mmax/3+1)/((2.0d0*m+1)*(n+m+1))
     1     /sqrt(2.0d0))

        fvals(ncount)=fval/scale
        derxs(ncount)=derx/scale
        derys(ncount)=dery/scale
        derzs(ncount)=derz/scale

c
c       the final scaling for the derivatives
c
        derynew = -1.0d0/s3*derxs(ncount) + 2.0d0/s3*derys(ncount)
        derznew = -1.0d0/s6*derxs(ncount) - 1.0d0/s6*derys(ncount)
     1     + s6/2.0d0*derzs(ncount)

        derys(ncount)=derynew
        derzs(ncount)=derznew

 4000   continue

 5000   continue

 6000   continue

ccc        call prinf("evas: after loops, ncount=*",ncount,1)

        return
        end
c
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
        subroutine klegeypols3(x,y,n,pols,dersx,dersy)
        implicit real *8 (a-h,o-z)
        dimension pols(1),dersx(1),dersy(1)
c
c     evaluate a sequence of scaled Legendre polynomials P_n(x/y) y^n,
c     with the parameter y \in [0..1], together with their derivatives
c     with respect to the parameters x and y.
c
c       ... if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        dersx(1)=0
        dersy(1)=0
        if(n .eq. 0) return
c
        pols(2)=x
        dersx(2)=1
        dersy(2)=0
        return
 1200 continue
c
c       n is greater than 1. conduct recursion
c
        pols(1)=1
        dersx(1)=0
        dersy(1)=0
        pols(2)=x
        dersx(2)=1
        dersy(2)=0
c
        pkm1=1
        pk=x
        dkm1=0
        dk=1
        ykm1=0
        yk=0
c
        pk=1
        pkp1=x
        dk=0
        dkp1=1
        yk=0
        ykp1=0
c
        do 2000 k=1,n-1
c
        pkm1=pk
        pk=pkp1
        dkm1=dk
        dk=dkp1
        ykm1=yk
        yk=ykp1
c
        pkp1=( (2*k+1)*x*pk-k*pkm1*y*y )/(k+1)
        dkp1=( (2*k+1)*(x*dk+pk)-k*dkm1*y*y )/(k+1)
        ykp1=( (2*k+1)*(x*yk)-k*(pkm1*2*y+ykm1*y*y) )/(k+1)
        pols(k+2)=pkp1
        dersx(k+2)=dkp1
        dersy(k+2)=ykp1
 2000 continue
c
        return
        end
c
c
c
c
c
c
c
        subroutine kjacoypols3(x,y,a,b,n,pols,dersx,dersy)
        implicit real *8 (a-h,o-z)
        dimension pols(1),dersx(1),dersy(1)
c
c       evaluates a bunch of Jacobi polynomials multiplied by
c       specific polynomials given by the formula
c
c       P_n^{(a,b)} (x/y) y^n
c
c       at the user-provided point x/y with alpha=a, beta=b.
c       n is the max order  of these Jacobi polynomials.
c       Partial derivatives of x and y are also returned in
c       the arrays dersx and dersy.
c

c
c       ... if n=0 or n=1 - exit
c

        if(n .ge. 2) goto 1200
        pols(1)=1
        dersx(1)=0
        dersy(1)=0
        if(n .eq. 0) return
c
        pols(2)=(a/2-b/2)*y+(1+a/2+b/2)*x
        dersx(2)=(1+a/2+b/2)
        dersy(2)=(a/2-b/2)
        return
 1200   continue
c
        pols(1)=1
        dersx(1)=0
        dersy(1)=0

        pols(2)=(a/2-b/2)*y+(1+a/2+b/2)*x
        dersx(2)=(1+a/2+b/2)
        dersy(2)=(a/2-b/2)
c
c       n is greater than 2. conduct recursion
c
        pkm1=1
        dxkm1=0
        dykm1=0

        pk=(a/2-b/2)*y+(1+a/2+b/2)*x
        dxk=1+a/2+b/2
        dyk=a/2-b/2

        pk=1
        dxk=0
        dyk=0

        pkp1=(a/2-b/2)*y+(1+a/2+b/2)*x
        dxkp1=1+a/2+b/2
        dykp1=a/2-b/2

c
        do 2000 k=2,n
c
        pkm1=pk
        dxkm1=dxk
        dykm1=dyk

        pk=pkp1
        dxk=dxkp1
        dyk=dykp1

        alpha=(2*k+a+b-1)*(a**2-b**2)*y
     1     +(2*k+a+b-1)*(2*k+a+b-2)*(2*k+a+b)*x
        beta=2*(k+a-1)*(k+b-1)*(2*k+a+b) *y*y

        pkp1=(alpha*pk-beta*pkm1)/(2*k*(k+a+b)*(2*k+a+b-2))

        dxkp1=(alpha*dxk-beta*dxkm1)/(2*k*(k+a+b)*(2*k+a+b-2)) +
     1     (2*k+a+b-1)*(2*k+a+b-2)*(2*k+a+b) * pk
     2     /(2*k*(k+a+b)*(2*k+a+b-2))

        dykp1=(alpha*dyk-beta*dykm1)/(2*k*(k+a+b)*(2*k+a+b-2)) +
     $     (2*k+a+b-1)*(a**2-b**2) *  pk /(2*k*(k+a+b)*(2*k+a+b-2)) -
     1     2*y *2*(k+a-1)*(k+b-1)*(2*k+a+b) * pkm1
     2     /(2*k*(k+a+b)*(2*k+a+b-2))

        pols(k+1)=pkp1
        dersx(k+1)=dxkp1
        dersy(k+1)=dykp1

 2000   continue
c
        return
        end


      subroutine hdrive(alpha,m,xlen,run,peak)
c
c     + + + PURPOSE + + +
c     Computes the runoff hydrograph on a plane using the
c     kinematic wave model.  The solution is by the method
c     of characteristics.
c     The lateral inflow (rainfall excess) is presented as a
c     positive step function up to a given time and is zero
c     thereafter. (If step value is given as zero, it is set
c     to 1.e-8.)
c
c     Called from IRS.
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/26/91 - 04/29/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real alpha, m, xlen, run, peak
c
c     + + + ARGUMENT DEFINITIONS + + +
c     alpha  - depth discharge coefficient
c     m      - depth discharge exponent
c     xlen   - length of equivalent plane
c     run    - runoff volume
c     peak   - peak discharge
c
c     + + + PARAMETERS + + +
c
      include 'pmxelm.inc'
      include 'pmxtim.inc'
      include 'pmxpln.inc'
c
c     + + + COMMON BLOCKS + + +
      include 'cdata3.inc'
c     modify: dt, nqt
c
      include 'chydrol.inc'
c       read: durexr
c      write: durrun
c
      include 'cintgrl.inc'
c      write: ii
c
      include 'cpass2.inc'
c        read: t(mxtime)
      include 'cpass3.inc'
c        read: ns
c       write: nq
      include 'cpass4.inc'
c      modify: tq1(mxtime),q(mxtime),qtot(mxtime)
c
c     + + + LOCAL VARIABLES + + +
      real qsum, qlast, qtmax, t1, t2, d
      integer begrun, i
c
c     + + + LOCAL DEFINITIONS + + +
c     begrun - flag for beginning of runoff
c     qsum   - sum of all Q(I)'s
c     qlast  - value of the last Q(I)
c     i      - counter in L0 Loop
c     qtmax  - 95% of runoff volume used to stop hydrograph computations
c     t1     - previous value of T2
c     t2     - current time step
c     d      - flow depth
c
c     + + + SUBROUTINES CALLED + + +
c     bgnrnd
c
c     + + + FUNCTION DECLARATIONS + + +
      real hdepth
c
c     + + + END SPECIFICATIONS + + +
c
c
c******************************************************************
c                                                                 *
c     Subroutine INIT reads in plane parameters and rainfall      *
c     excess values, c and initializes for calls to subroutine h. *
c     Subroutine h computes depth of flow on the plane.           *
c                                                                 *
c******************************************************************
c
c
      peak = 0.
      begrun = 0
      nqt = 0
      ii = 1
c
      call bgnrnd(1842.)
c
      dt = 60.
      nq = ns + 10
      qsum = 0.
      qlast = 0.
c
      do 10 i = 1, mxtime
        qtot(i) = 0.
   10 continue
c
      qtmax = .95 * run
c
c     *** BEGIN L0 LOOP ***
c
c     Step through the rainfall excess times, get the flow depth and compute
c     the hydrograph.
c
      i = 0
   20 i = i + 1
c
      if (i.le.(ns+1)) then
        t2 = t(i)
      else
        t2 = t2 + dt
      end if
c
      d = hdepth(t2,xlen)
      tq1(i) = t2
c
      if (begrun.eq.0.and.d.gt.0.) then
        begrun = 1
      end if
c
      q(i) = alpha * d ** m
c
      if (i.gt.1) then
        qsum = qsum + (q(i)+qlast) * (t2-t1) / 2.0
c       warning from ftnchek
c       Variables may be used before set in module HDRIVE:
c       T1
        qtot(i+1) = qsum
      end if
c
      qlast = q(i)
      t1 = t2
      if (q(i).gt.peak) peak = q(i)
c
c     *** END L0 LOOP ***
      if ((i.lt.(mxtime-1)).and.(i.lt.ns+200).and.
     1    ((qtot(i+1)/xlen).lt.qtmax)) go to 20
c
c
      nqt = i + 1
      tq1(nqt) = t2 + dt
      d = hdepth(tq1(nqt),len)
      q(nqt) = alpha * d ** m
c
      peak = peak / xlen
c
      return
      end


Module CDM_fiber_mod
  ! Continuum damage mechanics fiber damage calculations

Contains

  Pure Subroutine FiberTenDmg(eps, ndir, E1, XT, GXT, n, m, Lc, rfT, d1T, d1C, STATUS)
    ! The purpose of this subroutine is to evaluate fiber damage.
    ! This subroutine is for tension-only fiber damage.

    ! Arguments
    Double Precision, intent(IN) :: E1                        ! Stiffness
    Double Precision, intent(IN) :: XT                        ! Strength
    Double Precision, intent(IN) :: GXT                       ! Toughness
    Double Precision, intent(IN) :: n, m                      ! Coefficients for bi-linear softening
    Double Precision, intent(IN) :: eps(ndir,ndir)            ! Strain
    Double Precision, intent(IN) :: Lc
    Double Precision, intent(IN) :: d1C                       ! CDM compressive fiber damage variable
    Integer, intent(IN) :: ndir

    Double Precision, intent(INOUT) :: rfT                    ! Fiber tension damage threshold, state variable (CDM_FIfT)
    Double Precision, intent(INOUT) :: d1T                    ! Fiber direction damage variables for tension
    Integer, intent(OUT) :: STATUS                            ! Element deletion

    ! Locals
    Double Precision :: FIfT                        ! Fiber direction failure index
    Double Precision :: d1MAX                       ! Maximum value for damage variables
    Double Precision :: eps_rfT                     ! strain corresponding to the maximum historical failure criterion
    Double Precision :: eps_0, eps_f_1, eps_f_2     ! strains for damage variable calculations
    Double Precision :: dmg_1, dmg_2                ! individual damage variables for bi-linear softening
    Double Precision :: d1T_temp                    ! Stores the old value of d1T

    Double Precision, Parameter :: zero=0.d0, one=1.d0, two=2.d0
    ! -------------------------------------------------------------------- !

    ! Initialize
    d1MAX = one
    d1T = MAX(d1T, d1C)
    d1T_temp = d1T
    STATUS = 1

    ! Fiber tension failure criterion
    FIfT = E1/XT*eps(1,1)

    ! Update damage threshold
    If (FIfT > rfT) rfT = FIfT

    ! Determine d1T if damage has occurred
    If (rfT > one) Then

      eps_rfT = rfT*XT/E1

      ! Calculate constants
      eps_0 = XT/E1
      eps_f_1 = two*GXT*m/(XT*n*Lc)
      eps_f_2 = two*GXT*(one - m)/(XT*(one - n)*Lc)

      ! Calculate damage in each linear softening law
      dmg_1 = MIN(one, eps_f_1*(eps_rfT - eps_0)/eps_rfT/(eps_f_1 - eps_0))
      dmg_2 = MIN(one, eps_f_2*(eps_rfT - eps_0)/eps_rfT/(eps_f_2 - eps_0))

      ! Find the combined damage variable, d1T
      d1T = n*(dmg_1 - dmg_2) + dmg_2

      ! Prevent healing; If the current damage is less than previous damage, use previous damage
      If (d1T < d1T_temp) d1T = d1T_temp

      ! Delete element when it becomes fully damaged
      If (d1T >= d1MAX) Then
        d1T = d1MAX
        STATUS = 0
      End If

    Else
      ! This is only executed before any damage has occurred
      ! Since rfT is that state variable, it acts as the failure index before damage
      rfT = FIfT

    End If

    Return
  End Subroutine FiberTenDmg

  Pure Subroutine FiberCompDmg(eps,ndir,E1,XC,GXC,n,m,Lc,rfT,rfC,d1T,d1C,STATUS)
    ! The purpose of this subroutine is to evaluate fiber damage.
    ! This subroutine is for compression-only fiber damage.

    ! Arguments
    Double Precision, intent(IN) :: E1                        ! Stiffness
    Double Precision, intent(IN) :: XC                        ! Strength
    Double Precision, intent(IN) :: GXC                       ! Toughness
    Double Precision, intent(IN) :: n, m                      ! Coefficients for bi-linear softening
    Double Precision, intent(IN) :: eps(ndir,ndir)            ! Strain
    Double Precision, intent(IN) :: Lc
    Integer, intent(IN) :: ndir

    Double Precision, intent(INOUT) :: rfC                      ! Fiber compression damage threshold, state variable
    Double Precision, intent(INOUT) :: rfT                      ! Fiber tension damage threshold, state variable
    Double Precision, intent(INOUT) :: d1C                      ! Fiber direction damage variables for compression
    Double Precision, intent(INOUT) :: d1T                      ! Fiber direction damage variables for tension
    Integer, intent(OUT) :: STATUS                              ! Element deletion

    ! Locals
    Double Precision :: FIfC                        ! Fiber direction failure index
    Double Precision :: d1MAX                       ! Maximum value for damage variables
    Double Precision :: eps_rfC                     ! strain corresponding to the maximum historical failure criterion
    Double Precision :: eps_0, eps_f_1, eps_f_2     ! strains for damage variable calculations
    Double Precision :: dmg_1, dmg_2                ! individual damage variables for bi-linear softening
    Double Precision :: d1C_temp                    ! Stores the old value of d1C

    Double Precision, Parameter :: zero=0.d0, one=1.d0, two=2.d0
    ! -------------------------------------------------------------------- !

    ! Initialize
    d1MAX = one
    d1C_temp = d1C
    STATUS = 1

    ! Fiber compression failure criterion
    FIfC = -E1/XC*eps(1,1)

    ! Update damage threshold
    If (FIfC > rfC) Then
      rfC = FIfC

      ! For load reversal
      If (rfC > rfT) rfT = rfC
    End If

    ! Determine d1C if damage has occurred
    If (rfC > one) Then

      eps_rfC = rfC*XC/E1

      ! Calculate constants
      eps_0 = XC/E1
      eps_f_1 = two*GXC*m/(XC*n*Lc)
      eps_f_2 = two*GXC*(one - m)/(XC*(one - n)*Lc)

      ! Calculate damage in each linear softening law
      dmg_1 = MIN(one, eps_f_1*(eps_rfC - eps_0)/eps_rfC/(eps_f_1 - eps_0))
      dmg_2 = MIN(one, eps_f_2*(eps_rfC - eps_0)/eps_rfC/(eps_f_2 - eps_0))

      ! Find the combined damage variable, d1T
      d1C = n*(dmg_1 - dmg_2) + dmg_2

      ! Prevent healing; If the current damage is less than previous damage, use previous damage
      If (d1C < d1C_temp) d1C = d1C_temp

      ! Delete element when it becomes fully damaged
      If (d1C >= d1MAX) Then
        d1C = d1MAX
        STATUS = 0
      End If

    Else
      ! This is only executed before any damage has occurred
      ! Since rfC is that state variable, it acts as the failure index before damage
      rfC = FIfC

      ! If there's no damage in tension, set rfT to zero
      If (d1T <= zero) rfT = zero

    End If

    Return
  End Subroutine FiberCompDmg

End Module CDM_fiber_mod


      subroutine rectpatch(rdata)

C     RETURNS CALCULATED LINE OF LATITUDE 0. AND LONGITUDE AT SAMPLE 1

      REAL*8 PI,CONST,REQ,SCALE,RSAMP,RLAT
      real rdata(40)
      DATA pi/3.141592653589793D0/
C==================================================================
      call mve(4,1,rdata(39),l,1,1)
      if(l.ne.10)return
      SCALE=rdata(7)   ! KM/PIXEL
      req=rdata(26)
      flag=-999
      RLINE=rdata(2)
      RSAMP=rdata(1)
      RLAT=rdata(3)
      RLON=rdata(6)
      IF(RLAT.EQ.0..AND.RSAMP.EQ.1.)RETURN
      CONST=SCALE/REQ/PI*180.  !DEGREES/PIXEL

C     CALCULATE LONGITUDE
      RLON=RLON+CONST*(RSAMP-1.)
      if(rlon.eq.0.)rlon=360.
      IF(RLON .GT. 360.) RLON=AMOD(360.+RLON,360.)

C     CALCULATE LINE OF EQUATOR
      RLINE=RLINE+RLAT/CONST
      rdata(1)=1.
      rdata(2)=RLINE
      rdata(3)=0.
      rdata(6)=RLON
      if(rdata(6).eq.0.)rdata(6)=360.
      RETURN
      END


      subroutine runC_iii(j,i1,i2,i3,DetGr,Xtwiddle0,Gtwiddle,
     . Shat4,N0)
      implicit none
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,j,i1,i2,i3,n,np
      parameter(np=2)
      double precision DetGr,Xtwiddle0(np),Gtwiddle(np,np)
      double complex Shat4(np,z3max,-2:0),Shat4s(np,z3max,-2:0)

      do ep=-2,0
      do n=1,np
      Shat4s(n,z3(i1,i2,i3),ep)=Shat4(n,z3(i1,i2,i3),ep)
     .   -2d0*(delta(n,i1)*Cv(N0+czzii(z2(i2,i3)),ep)
     .        +delta(n,i2)*Cv(N0+czzii(z2(i1,i3)),ep)
     .        +delta(n,i3)*Cv(N0+czzii(z2(i1,i2)),ep))
c      if ((ep.eq.-1) .and. (z3(i1,i2,i3) .eq. z3(2,2,2))) then
c      write(6,'(a8,4i3,2(f20.15))') 'Shat4s ',n,i1,i2,i3,
c     .         Shat4(n,z3(i1,i2,i3),ep)
c      write(6,'(a8,4i3,2(f20.15))') 'Shat4s ',n,i1,i2,i3,
c     .        -2d0*delta(n,i1)*Cv(N0+czzii(z2(i2,i3)),ep)
c      write(6,'(a8,4i3,2(f20.15))') 'Shat4s ',n,i1,i2,i3,
c     .        -2d0*delta(n,i2)*Cv(N0+czzii(z2(i1,i3)),ep)
c      write(6,'(a8,4i3,2(f20.15))') 'Shat4s ',n,i1,i2,i3,
c     .        -2d0*delta(n,i3)*Cv(N0+czzii(z2(i1,i2)),ep)
c      endif
      enddo
      Cv(ciii(z3(i1,i2,i3))+N0,ep)=-(
     . +Gtwiddle(j,1)*Shat4s(1,z3(i1,i2,i3),ep)
     . +Gtwiddle(j,2)*Shat4s(2,z3(i1,i2,i3),ep)
     . -DetGr*Cv(ciiii(z4(j,i1,i2,i3))+N0,ep))/Xtwiddle0(j)

c      if (ep .eq. -1) then
c      write(6,*) 'Ciii ',j,i1,i2,i3,
c     . +Gtwiddle(j,1)*Shat4s(1,z3(i1,i2,i3),ep)/Xtwiddle0(j)
c      write(6,*) 'Ciii ',j,i1,i2,i3,
c     . +Gtwiddle(j,2),Shat4s(2,z3(i1,i2,i3),ep),Xtwiddle0(j)
c      write(6,*) 'Ciii ',j,i1,i2,i3,
c     . -DetGr*Cv(ciiii(z4(j,i1,i2,i3))+N0,ep)/Xtwiddle0(j)
c      endif

      enddo

c      pause

      return
      end


C$Procedure CLIGHT ( C, Speed of light in a vacuum )

      DOUBLE PRECISION FUNCTION CLIGHT ( )

C$ Abstract
C
C     Return the speed of light in a vacuum (IAU official
C     value, in km/sec).
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONSTANTS
C
C$ Declarations
C
C     None.
C
C$ Brief_I/O
C
C     The function returns the speed of light in vacuo (km/sec).
C
C$ Detailed_Input
C
C     None.
C
C$ Detailed_Output
C
C     The function returns the IAU official value for the speed of light
C     in vacuo: 299792.458 km/sec.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The function always returns the constant value shown above.
C
C$ Examples
C
C     Find the light time corresponding to the length of a given
C     3-dimensional position vector. Length units are km.
C
C     To use CLIGHT, declare it as having double precision type:
C
C        DOUBLE PRECISION      CLIGHT
C
C     Let POS be a 3-vector of interest; let TAU be the light time.
C     VNORM is the SPICELIB function that returns the norm of a
C     3-vector.
C
C        DOUBLE PRECISION      VNORM
C        DOUBLE PRECISION      TAU
C        DOUBLE PRECISION      POS (3 )
C
C     Find the light time:
C
C        TAU = VNORM ( POS ) / CLIGHT ()
C
C     Note that the SPK readers
C
C        SPKEZR
C        SPKEZ
C        SPKPOS
C        SPKEZP
C
C     return the one-way light time between target and observer
C     as an output.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     W.L. Taber      (JPL)
C     I.M. Underwood  (JPL)
C
C$ Version
C
C-     SPICELIB Version 1.0.2, 08-JAN-2008 (NJB)
C
C         Example section was updated to remove references to SPKAPP
C         and BODMAT.
C
C-     SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU)
C
C-&

C$ Index_Entries
C
C     c speed of light in a vacuum
C
C-&

C
C     Just like it says.
C
      CLIGHT = 299792.458D0

      RETURN
      END


MODULE calculate
    USE constants, ONLY: nl_name, G
    IMPLICIT NONE
    PRIVATE
    PUBLIC initial_guess, construct_matrix, construct_b, solve, rel_err

CONTAINS

    SUBROUTINE initial_guess(n_body, n, m, x0, xf, u)
        INTEGER :: n_body, n, m, i
        DOUBLE PRECISION :: x0(3,n_body), xf(3, n_body), u(m), dx(3,n_body)
        dx = (xf - x0)/n
        u = 0
        DO i=0,n-1
            u(i*3*n_body+1:(i+1)*3*n_body) = RESHAPE(x0+i*dx, (/3*n_body/))
        END DO
!       DO i = n*n_body*3+1,m
!           u(i) = 1
!       END DO
    END SUBROUTINE

    SUBROUTINE construct_matrix(masses, dt, n_body, n, m, A)
        INTEGER :: n_body, n, m, i, offset, body_idx
        DOUBLE PRECISION :: masses(n_body), dt, A(m,m), mass
        A = 0
        offset = 3*n_body*n
        !initialize boundary conditions
        DO i=1,n_body*3
            A(i,i) = 1
            A(i+offset,i) = 1/dt
            A(i+offset,i+3*n_body) = -1/dt
        END DO
        DO i=n_body*(n-1)*3+1,n*n_body*3
            A(i,i) = 1
            A(i+offset,i) = -1/dt
            A(i+offset,i-3*n_body) = 1/dt
        END DO

        DO i = n_body*3+1, offset - n_body*3
        ! initialize inertia
            body_idx = MOD(i, n_body)/3
            IF (body_idx .EQ. 0) THEN
                body_idx = n_body
            END IF
            mass = masses(body_idx)
            A(i, offset+i-n_body*3) = -mass/(2*dt)
            A(i, offset+i+n_body*3) = mass/(2*dt)
        ! initialize  derivative
            A(offset+i, i-n_body*3) = 1/(2*dt)
            A(offset+i, i+n_body*3) = -1/(2*dt)
        END DO

        DO i = offset+1, m
            A(i,i) = 1
        END DO
!       DO i = 1, m
!           PRINT *, A(i,:)
!       END DO

    END SUBROUTINE

    SUBROUTINE construct_b(u_bar, masses, n_body, m, n, b)
        INTEGER :: n_body, m, n, body_idx, t_idx, i, k, coord_body_idx
        DOUBLE PRECISION :: u_bar(m), masses(n_body), b(m), r(3), norm_r
        DOUBLE PRECISION, EXTERNAL :: DNRM2
        b = 0
        ! boundary condition
        b(1:3*n_body) = u_bar(1:3*n_body)
        b(3*n_body*(n-1)+1:3*n_body*n) = u_bar(3*n_body*(n-1)+1:3*n_body*n)

        ! gravitational attraction
        DO i = n_body*3+1, 3*n_body*(n-1), 3
            body_idx = MOD(i, n_body)/3 + 1
            t_idx = i/(n_body*3)
            IF (body_idx .EQ. 0) THEN
                body_idx = n_body
            END IF
            coord_body_idx = MOD(i,3)-1
            IF (coord_body_idx .EQ. -1) THEN
                coord_body_idx = 2
            END IF
            DO k = 1,n_body
                IF (body_idx .NE. k) THEN
                    r = u_bar(3*n_body*t_idx+k*3:3*n_body*t_idx+k*3+2) &
                        -u_bar(i:i+2)
                    norm_r = DNRM2(3, r, 1)
                    b(i:i+2) = b(i:i+2) + r/norm_r*G*masses(body_idx)/norm_r* &
                        masses(k)/norm_r
                END IF
            END DO
        END DO

    END SUBROUTINE

    SUBROUTINE solve(A, b, m, u_star, FERR)
        INTEGER :: m, i
        INTEGER :: pivot(m), IWORK(m), INFO, RANK
        DOUBLE PRECISION :: A(m,m), AF(m,m), b(m), u_star(m), R(m), C(m), &
            RCOND, FERR, BERR(1), WORK(4*m), S(m)
        CHARACTER :: EQUED
        CALL DGESVX('E', 'N', m, 1, A, m, AF, m, pivot, EQUED, R, C, b, m, &
            u_star, m, RCOND, FERR, BERR, WORK, IWORK, INFO)
!       CALL DGELSD(m, m, 1, A, m, b, m, S, RCOND, RANK, WORK, m*m, IWORK, INFO)
        PRINT *, INFO
!       PRINT *, SUM(A(INFO,:))
!       PRINT *, SUM(AF(220,:))
!       DO i = 1, m
!           IF (MAXVAL(A(i,:)) .EQ. 0) THEN
!               PRINT *, i
!           END IF
!       END DO
        PRINT *, FERR
        PRINT *, RCOND
    END SUBROUTINE

    SUBROUTINE rel_err(u_star, u_bar, m, error)
        INTEGER :: m
        DOUBLE PRECISION :: u_star(m), u_bar(m), error
        error = NORM2(u_star-u_bar)/NORM2(u_bar) - 1
    END SUBROUTINE

END MODULE


subroutine modelB_function1(in_val, in_val_copy, out_val)
  ! Only valid if in_val <= 2
  real, intent(in) :: in_val
  real, intent(out) :: in_val_copy
  real, intent(out) :: out_val
  in_val_copy = in_val
  out_val = in_val**2
  print *, "modelB_function1(", in_val, ") = ", out_val
end subroutine modelB_function1


module random

implicit none

interface
  module subroutine rand_init(repeatable, image_distinct)
  logical, intent(in) :: repeatable, image_distinct
  end subroutine rand_init
end interface

contains

impure elemental integer function randint(lo, hi)
integer, intent(in) :: lo, hi
real :: r

call random_number(r)

randint = floor(r * (hi + 1 - lo)) + lo

end function randint

end module random


   Module Precision

   Implicit None
   Integer, Parameter :: dp = Selected_Real_Kind(15,307)
   Integer, Parameter :: pr = dp

!===================================================!
!  The precision we work in corresponds to double   !
!  precision, according to Paul; he gets this from  !
!  http://www.nsc.liu.se/~boein/f77to90/c13.html    !
!                                                   !
!  We've chosen the kind that gives us at least 15  !
!  decimal places and exponents in [-307,307].      !
!===================================================!

   End Module Precision


program testmergesort
        integer lst(10)
        lst = (/ 10, 9, 8, 4, 5, 6, 7, 3, 2, 1 /)
        call mergesort(lst, 0, 10)
        call show(lst)
end program testmergesort

subroutine _merge(lst, a, middle, b)
        integer a
        integer b
        integer middle
        integer lst(10)
        integer tmp(10)
        integer ai
        integer bi
        integer ti
        integer x
        ai = a
        bi = middle
        ti = a

        do while ((ai .lt. middle) .or. (bi .lt. b))
                if (ai .eq. middle) then
                        tmp(ti+1) = lst(bi+1)
                        bi = bi + 1
                else if (bi .eq. b) then
                        tmp(ti+1) = lst(ai+1)
                        ai = ai + 1
                else if (lst(ai+1) .lt. lst(bi+1)) then
                        tmp(ti+1) = lst(ai+1)
                        ai = ai + 1
                else
                        tmp(ti+1) = lst(bi+1)
                        bi = bi + 1
                end if
                ti = ti + 1
        end do
        do x = a, b - 1
                lst(x + 1) = tmp(x + 1)
        end do
end

recursive subroutine mergesort(lst, a, b)
        integer a
        integer b
        integer lst(10)
        integer diff
        diff = b - a
        if (diff .lt. 2) then
                return
        else
                diff = diff / 2
                call mergesort(lst, a, a + diff)
                call mergesort(lst, a + diff, b)
                call _merge(lst, a, a + diff, b)
        endif
end

subroutine show(lst)
        integer lst(10)
        integer x
        do x = 1, 10
                print 100, lst(x)
        end do

100 format (i0)
end


!> \brief \b LA_CONSTANTS is a module for the scaling constants for the compiled Fortran single and double precisions
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Authors:
!  ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date May 2016
!
!> \ingroup OTHERauxiliary
!
!> \par Contributors:
!  ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!> Nick Papior, Technical University of Denmark, DK
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!>  Blue, James L. (1978)
!>  A Portable Fortran Program to Find the Euclidean Norm of a Vector
!>  ACM Trans Math Softw 4:15--23
!>  https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!
module LA_CONSTANTS
!  -- LAPACK auxiliary module --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--

!  Standard constants for
   integer, parameter :: sp = kind(1.e0)

   real(sp), parameter :: szero = 0.0_sp
   real(sp), parameter :: shalf = 0.5_sp
   real(sp), parameter :: sone = 1.0_sp
   real(sp), parameter :: stwo = 2.0_sp
   real(sp), parameter :: sthree = 3.0_sp
   real(sp), parameter :: sfour = 4.0_sp
   real(sp), parameter :: seight = 8.0_sp
   real(sp), parameter :: sten = 10.0_sp
   complex(sp), parameter :: czero = ( 0.0_sp, 0.0_sp )
   complex(sp), parameter :: chalf = ( 0.5_sp, 0.0_sp )
   complex(sp), parameter :: cone = ( 1.0_sp, 0.0_sp )
   character*1, parameter :: sprefix = 'S'
   character*1, parameter :: cprefix = 'C'

!  Scaling constants
   real(sp), parameter :: sulp = epsilon(0._sp)
   real(sp), parameter :: seps = sulp * 0.5_sp
   real(sp), parameter :: ssafmin = real(radix(0._sp),sp)**max( &
      minexponent(0._sp)-1, &
      1-maxexponent(0._sp) &
   )
   real(sp), parameter :: ssafmax = sone / ssafmin
   real(sp), parameter :: ssmlnum = ssafmin / sulp
   real(sp), parameter :: sbignum = ssafmax * sulp
   real(sp), parameter :: srtmin = sqrt(ssmlnum)
   real(sp), parameter :: srtmax = sqrt(sbignum)

!  Blue's scaling constants
   real(sp), parameter :: stsml = real(radix(0._sp), sp)**ceiling( &
       (minexponent(0._sp) - 1) * 0.5_sp)
   real(sp), parameter :: stbig = real(radix(0._sp), sp)**floor( &
       (maxexponent(0._sp) - digits(0._sp) + 1) * 0.5_sp)
!  ssml >= 1/s, where s was defined in https://doi.org/10.1145/355769.355771
!  The correction was added in https://doi.org/10.1145/3061665 to scale denormalized numbers correctly
   real(sp), parameter :: sssml = real(radix(0._sp), sp)**( - floor( &
       (minexponent(0._sp) - digits(0._sp)) * 0.5_sp))
!  sbig = 1/S, where S was defined in https://doi.org/10.1145/355769.355771
   real(sp), parameter :: ssbig = real(radix(0._sp), sp)**( - ceiling( &
       (maxexponent(0._sp) + digits(0._sp) - 1) * 0.5_sp))

!  Standard constants for
   integer, parameter :: dp = kind(1.d0)

   real(dp), parameter :: dzero = 0.0_dp
   real(dp), parameter :: dhalf = 0.5_dp
   real(dp), parameter :: done = 1.0_dp
   real(dp), parameter :: dtwo = 2.0_dp
   real(dp), parameter :: dthree = 3.0_dp
   real(dp), parameter :: dfour = 4.0_dp
   real(dp), parameter :: deight = 8.0_dp
   real(dp), parameter :: dten = 10.0_dp
   complex(dp), parameter :: zzero = ( 0.0_dp, 0.0_dp )
   complex(dp), parameter :: zhalf = ( 0.5_dp, 0.0_dp )
   complex(dp), parameter :: zone = ( 1.0_dp, 0.0_dp )
   character*1, parameter :: dprefix = 'D'
   character*1, parameter :: zprefix = 'Z'

!  Scaling constants
   real(dp), parameter :: dulp = epsilon(0._dp)
   real(dp), parameter :: deps = dulp * 0.5_dp
   real(dp), parameter :: dsafmin = real(radix(0._dp),dp)**max( &
      minexponent(0._dp)-1, &
      1-maxexponent(0._dp) &
   )
   real(dp), parameter :: dsafmax = done / dsafmin
   real(dp), parameter :: dsmlnum = dsafmin / dulp
   real(dp), parameter :: dbignum = dsafmax * dulp
   real(dp), parameter :: drtmin = sqrt(dsmlnum)
   real(dp), parameter :: drtmax = sqrt(dbignum)

!  Blue's scaling constants
   real(dp), parameter :: dtsml = real(radix(0._dp), dp)**ceiling( &
       (minexponent(0._dp) - 1) * 0.5_dp)
   real(dp), parameter :: dtbig = real(radix(0._dp), dp)**floor( &
       (maxexponent(0._dp) - digits(0._dp) + 1) * 0.5_dp)
!  ssml >= 1/s, where s was defined in https://doi.org/10.1145/355769.355771
!  The correction was added in https://doi.org/10.1145/3061665 to scale denormalized numbers correctly
   real(dp), parameter :: dssml = real(radix(0._dp), dp)**( - floor( &
       (minexponent(0._dp) - digits(0._dp)) * 0.5_dp))
!  sbig = 1/S, where S was defined in https://doi.org/10.1145/355769.355771
   real(dp), parameter :: dsbig = real(radix(0._dp), dp)**( - ceiling( &
       (maxexponent(0._dp) + digits(0._dp) - 1) * 0.5_dp))

end module LA_CONSTANTS


program elemental_main
  use elemental_procedure
  implicit none

  integer, parameter   :: n=5
  real, dimension(n,n) :: a,b,c
  real, dimension(n)   :: t,u,v

  call random_number(a)
  call random_number(b)
  call random_number(t)
  call random_number(u)
  c = f(a,b)
  v = f(t,u)

  print*, 'c = ', c
  print*, 'v = ', v
end program elemental_main