c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK3.0                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... file ihgeod.f
c
c     contains documentation and code for subroutine ihgeod
c
c
      subroutine ihgeod(m,idp,jdp,x,y,z)
      dimension x(idp,jdp,5),y(idp,jdp,5),z(idp,jdp,5)
c
c     m         is the number of points on the edge of a
c               single geodesic triangle
c
c     x,y,z     the coordinates of the geodesic points on
c               the sphere are x(i,j,k), y(i,j,k), z(i,j,k)
c               where i=1,...,m+m-1; j=1,...,m; and k=1,...,5.
c               the indices are defined on the unfolded
c               icosahedron as follows for the case m=3
c
c                north pole
c
c                 (5,1)          0      l
c        i     (4,1) (5,2)              a    (repeated for
c           (3,1) (4,2) (5,3)  theta1   t    k=2,3,4,5 in
c        (2,1) (3,2) (4,3)              i        -->
c     (1,1) (2,2) (3,3)        theta2   t    the longitudinal
c        (1,2) (2,3)                    u    direction)
c           (1,3)                pi     d
c      j                                e
c         south pole
c
c                total number of points is 10*(m-1)**2+2
c                total number of triangles is 20*(m-1)**2
c                total number of edges is 30*(m-1)**2
c
      pi = 4.*atan(1.)
      dphi = .4*pi
      beta = cos(dphi)
      theta1 = acos(beta/(1.-beta))
      theta2 = pi-theta1
      hdphi = dphi/2.
      tdphi = 3.*hdphi
      do k=1,5
	phi = (k-1)*dphi
	call stoc(1.,theta2,phi,x1,y1,z1)
	call stoc(1.,pi,phi+hdphi,x2,y2,z2)
	call stoc(1.,theta2,phi+dphi,x3,y3,z3)
	dxi = (x2-x1)/(m-1)
	dyi = (y2-y1)/(m-1)
	dzi = (z2-z1)/(m-1)
	dxj = (x3-x2)/(m-1)
	dyj = (y3-y2)/(m-1)
	dzj = (z3-z2)/(m-1)
	do i=1,m
	  xs = x1 + (i-1)*dxi
	  ys = y1 + (i-1)*dyi
	  zs = z1 + (i-1)*dzi
	  do j=1,i
	    x(j,i,k) = xs + (j-1)*dxj
	    y(j,i,k) = ys + (j-1)*dyj
	    z(j,i,k) = zs + (j-1)*dzj
	  end do
	end do
	call stoc(1.,theta1,phi+hdphi,x4,y4,z4)
	dxi = (x3-x4)/(m-1)
	dyi = (y3-y4)/(m-1)
	dzi = (z3-z4)/(m-1)
	dxj = (x4-x1)/(m-1)
	dyj = (y4-y1)/(m-1)
	dzj = (z4-z1)/(m-1)
	do j=1,m
	  xs = x1 + (j-1)*dxj
	  ys = y1 + (j-1)*dyj
	  zs = z1 + (j-1)*dzj
	  do i=1,j
	    x(j,i,k) = xs + (i-1)*dxi
	    y(j,i,k) = ys + (i-1)*dyi
	    z(j,i,k) = zs + (i-1)*dzi
	  end do
	end do
	call stoc(1.,theta1,phi+tdphi,x5,y5,z5)
	dxj = (x5-x3)/(m-1)
	dyj = (y5-y3)/(m-1)
	dzj = (z5-z3)/(m-1)
	do i=1,m
	  xs = x4 + (i-1)*dxi
	  ys = y4 + (i-1)*dyi
	  zs = z4 + (i-1)*dzi
	  do j=1,i
	    x(j+m-1,i,k) = xs + (j-1)*dxj
	    y(j+m-1,i,k) = ys + (j-1)*dyj
	    z(j+m-1,i,k) = zs + (j-1)*dzj
	  end do
	end do
	call stoc(1.,0.,phi+dphi,x6,y6,z6)
	dxi = (x5-x6)/(m-1)
	dyi = (y5-y6)/(m-1)
	dzi = (z5-z6)/(m-1)
	dxj = (x6-x4)/(m-1)
	dyj = (y6-y4)/(m-1)
	dzj = (z6-z4)/(m-1)
	do j=1,m
	  xs = x4 + (j-1)*dxj
	  ys = y4 + (j-1)*dyj
	  zs = z4 + (j-1)*dzj
	  do i=1,j
	    x(j+m-1,i,k) = xs + (i-1)*dxi
	    y(j+m-1,i,k) = ys + (i-1)*dyi
	    z(j+m-1,i,k) = zs + (i-1)*dzi
	  end do
	end do
      end do
      do k=1,5
	do j=1,m+m-1
	  do i=1,m
	    call ctos(x(j,i,k),y(j,i,k),z(j,i,k),rad,theta,phi)
	    call stoc(1.,theta,phi,x(j,i,k),y(j,i,k),z(j,i,k))
	  end do
	end do
      end do
      return
      end
      subroutine ctos(x,y,z,r,theta,phi)
      r1 = x*x+y*y
      if(r1 .ne. 0.) go to 10
      phi = 0.
      theta = 0.
      if(z .lt. 0.) theta = 4.*atan(1.)
      return
   10 r = sqrt(r1+z*z)
      r1 = sqrt(r1)
      phi = atan2(y,x)
      theta = atan2(r1,z)
      return
      end
      subroutine stoc(r,theta,phi,x,y,z)
      st = sin(theta)
      x = r*st*cos(phi)
      y = r*st*sin(phi)
      z = r*cos(theta)
      return
      end


MODULE MomentEquationsUtilitiesModule_Beta

  USE KindModule, ONLY: &
    DP, &
    Zero, &
    SqrtTiny, &
    Half, &
    One, &
    Three

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: ComputePrimitive
  PUBLIC :: ComputeConserved
  PUBLIC :: Flux_X1
  PUBLIC :: Flux_X2
  PUBLIC :: NumericalFlux_LLF

CONTAINS

  SUBROUTINE ComputePrimitive &
    ( N, G_1, G_2, G_3, D, I_1, I_2, I_3, Gm_dd_11, Gm_dd_22, Gm_dd_33 )

    REAL(DP), DIMENSION(:), INTENT(in)  :: N, G_1, G_2, G_3
    REAL(DP), DIMENSION(:), INTENT(out) :: D, I_1, I_2, I_3
    REAL(DP), DIMENSION(:), INTENT(in)  :: Gm_dd_11, Gm_dd_22, Gm_dd_33

    D   = N
    I_1 = G_1 / Gm_dd_11
    I_2 = G_2 / Gm_dd_22
    I_3 = G_3 / Gm_dd_33

  END SUBROUTINE ComputePrimitive

  SUBROUTINE ComputeConserved &
    ( D, I_1, I_2, I_3, N, G_1, G_2, G_3, Gm_dd_11, Gm_dd_22, Gm_dd_33 )

    REAL(DP), DIMENSION(:), INTENT(in)  :: D, I_1, I_2, I_3
    REAL(DP), DIMENSION(:), INTENT(out) :: N, G_1, G_2, G_3
    REAL(DP), DIMENSION(:), INTENT(in)  :: Gm_dd_11, Gm_dd_22, Gm_dd_33

    N   = D
    G_1 = Gm_dd_11 * I_1
    G_2 = Gm_dd_22 * I_2
    G_3 = Gm_dd_33 * I_3

  END SUBROUTINE ComputeConserved

  PURE FUNCTION Flux_X1 &
    ( D, I_1, I_2, I_3, FF, EF, Gm_dd_11, Gm_dd_22, Gm_dd_33 )

    REAL(DP)             :: Flux_X1(1:4)
    REAL(DP), INTENT(in) :: D, I_1, I_2, I_3, FF, EF
    REAL(DP), INTENT(in) :: Gm_dd_11, Gm_dd_22, Gm_dd_33

    REAL(DP) :: h_u_1
    REAL(DP) :: h_d_1, h_d_2, h_d_3

    h_u_1 = I_1 / ( FF * D )

    h_d_1 = Gm_dd_11 * I_1 / ( FF * D )
    h_d_2 = Gm_dd_22 * I_2 / ( FF * D )
    h_d_3 = Gm_dd_33 * I_3 / ( FF * D )

    Flux_X1(1) &
      = I_1

    Flux_X1(2) &
      = D * Half * ( (Three*EF - One) * h_u_1 * h_d_1 + (One - EF) )

    Flux_X1(3) &
      = D * Half * ( (Three*EF - One) * h_u_1 * h_d_2 )

    Flux_X1(4) &
      = D * Half * ( (Three*EF - One) * h_u_1 * h_d_3 )

    RETURN
  END FUNCTION Flux_X1

  PURE FUNCTION Flux_X2 &
    ( D, I_1, I_2, I_3, FF, EF, Gm_dd_11, Gm_dd_22, Gm_dd_33 )

    REAL(DP)             :: Flux_X2(1:4)
    REAL(DP), INTENT(in) :: D, I_1, I_2, I_3, FF, EF
    REAL(DP), INTENT(in) :: Gm_dd_11, Gm_dd_22, Gm_dd_33

    REAL(DP) :: h_u_2
    REAL(DP) :: h_d_1, h_d_2, h_d_3

    h_u_2 = I_2 / ( FF * D )

    h_d_1 = Gm_dd_11 * I_1 / ( FF * D )
    h_d_2 = Gm_dd_22 * I_2 / ( FF * D )
    h_d_3 = Gm_dd_33 * I_3 / ( FF * D )

    Flux_X2(1) &
      = I_2

    Flux_X2(2) &
      = D * Half * ( (Three*EF - One) * h_u_2 * h_d_1 )

    Flux_X2(3) &
      = D * Half * ( (Three*EF - One) * h_u_2 * h_d_2 + (One - EF) )

    Flux_X2(4) &
      = D * Half * ( (Three*EF - One) * h_u_2 * h_d_3 )

    RETURN
  END FUNCTION Flux_X2

  REAL(DP) PURE ELEMENTAL FUNCTION NumericalFlux_LLF &
    ( u_L, u_R, Flux_L, Flux_R, alpha )

    ! --- Local Lax-Friedrichs Flux ---

    REAL(DP), INTENT(in) :: u_L, u_R, flux_L, flux_R, alpha

    NumericalFlux_LLF &
      = Half * ( flux_L + flux_R - alpha * ( u_R - u_L ) )

    RETURN
  END FUNCTION NumericalFlux_LLF

END MODULE MomentEquationsUtilitiesModule_Beta


      SUBROUTINE segd20( ibuf, obuf, nsamps )
c     SEGD20 converts the SEG-D 20 bit exponent words to floating point.
c     The SEG-D 20 bit exponent (also called 20 bit binary) groups the
c  data into groups of 5.  There are 4 data words in each group of 5.
c  The exponents for each word are 4 bits big (no sign bit) and are a
c  positive power of 2.  These 4 exponents precede the 4 data words and
c  are in the first 16 bits.  The mantissas are signed 16 bit occupying
c  the next 4 words, representing values 2**-16.
c     This here subroutine is cute because each data word requires only
c  1 multiply to convert it (rather an exponentiation).  This is very
c  similar to subroutine IBM2FP.
c
c  ARGUMENTS:
c  ibuf   - The input array (of SEG-D 20 bit exponent data).  The array
c           must be aligned correctly - the first word must be the
c           4 exponents.
c  obuf   - The output array of REAL data.  Must not be the same as ibuf
c  nsamps - The number of data values to convert.
c
c  Copyright (C) Paul Henkart, Seismic Reflection Processors, San Diego, Ca.
c mod 14 Aug 07 - g95 IAND requires arguments to be same type and kind.
c  ALL RIGHTS RESERVED.
c
      INTEGER*2 ibuf(1), rshift, i15
      REAL obuf(nsamps)
      DIMENSION exp(16), iexp(4)
      LOGICAL first
      SAVE exp, first
      DATA first/.TRUE./, i15/15/
c
      IF( first ) THEN
          exp(1) = 1. / 32768.
          DO 100 i = 2, 16
             exp(i) = exp(i-1) * 2.
  100     CONTINUE
      ENDIF
c
      i = 1
      j = 1
      DO 400 k = 1, nsamps, 4
         iexp(1) = IAND( rshift(ibuf(i),12), i15)
         iexp(2) = IAND( rshift(ibuf(i),8), i15)
         iexp(3) = IAND( rshift(ibuf(i),4), i15)
         iexp(4) = IAND( ibuf(i),i15 )
         i = i + 1
         DO 200 l = 1, 4
            temp = ibuf(i)                                               ! float the signed integer
            obuf(j) = temp * exp(iexp(l) + 1)
            i = i + 1
            j = j + 1
  200    CONTINUE
  400 CONTINUE
c
      RETURN
      END


      program DRDERF
c>> 1996-06-17 DRDERF Krogh Minor change in formats for C conversion.
c>> 1994-10-19 DRDERF Krogh  Changes to use M77CON
c>> 1992-05-13 DRDERF CLL
c>> 1991-10-16 DRDERF CLL add demo of DERFCE
c>> 1987-12-09 DRDERF   Lawson  Initial Code.
c--D replaces "?": DR?ERF, ?ERF, ?ERFC, ?ERFCE
c
c     Demonstration driver for DERF, DERFC, and DERFCE
c
      external         D1MACH, DERF, DERFC, DERFCE
      double precision D1MACH, DERF, DERFC, DERFCE, X, XMAX, YE, YC, YCE
c
      if(log10(D1MACH(1)) .lt. -65.0d0) then
         XMAX = 12.0d0
      else
         XMAX = 9.0d0
      endif
      X= -6.0D0
      print '(4x,''X'',9x,''DERF'',12x,''DERFC'',10x,''DERFCE''/1x)'
   20 if(X .le. XMAX)then
         YE= DERF(X)
         YC= DERFC(X)
      if(X .lt. 0.0D0)then
            print '(1x,f5.1,1x,2e17.8)', X,YE,YC
      else
            YCE = DERFCE(X)
            print '(1x,f5.1,1x,3e17.8)', X,YE,YC,YCE
      end if
      if(X .lt. 6.0D0)then
            X = X + 0.5D0
      else
            X = X + 1.0D0
      end if
      go to 20
      end if
      stop
      end


PROGRAM test_3D
!
      USE def_constants
      USE def_variables
      USE non_linear_solvers
      USE properties
      USE grid_functions
      USE Grid
      USE Interp_table
      IMPLICIT NONE
!
!     INTEGER :: Niter, exitflag
!      REAL(pr):: x, y, z, out1, out2, out3, resnorm,in_1, in_2
!      REAL(pr):: p,v,u,T,c
!========================================================================
!
!           Test for the 3D nonlinear solver
!
!========================================================================
!        x = -1.0_pr
!        y = 3.14_pr / 1.1_pr
!        z = -1_pr
!        resnorm = 1e-10_pr
!        Niter = 100

!        CALL  New_Rap3D(2, out1, out2, out3, &
!       &       resnorm, Niter, exitflag, 1.1_pr, x, y, z)

!    print*, "---------------------------------------------------"
!    print*, "x = ", out1, "y = ", out2, "z = ", out3
!    print*, "---------------------------------------------------"
!
!
!======================================================================
!
!               Test for the Max_point routine
!
!======================================================================
!
!        Niter = 5
!        x = 2_pr
!print*, x/Niter
!        u = 0_pr
!        v = 0_pr
!        T = 0_pr
!        p = 0_pr
!        c = 0_pr
!          CALL Max_point(u,v,T,p,c)
!
!    print*, "==================================================="
!    print*, "e_max =", u*1e-3_pr, v, 1_pr/v,c
!    print*, "---------------------------------------------------"
!    print*, "T_umax =", T, "P_umax =", p*1e-6_pr
!    print*, "==================================================="
!======================================================================
!
!              Test corner
!
!=====================================================================
!
!
      CALL  corner_A()
      CALL  corner_B()
      CALL  corner_C()
!       CALL   corner_D()
!
!     STOP
!    print*, "---------------------------------------------------"
    print*, "v=", v_corner_A,v_corner_B,v_corner_C
    print*, "T=", T_corner_A,T_corner_B,T_corner_C
!    print*, "---------------------------------------------------"
!
!======================================================================
!
!              Test location of interpolation
!
!=====================================================================
!
!
!      REAL(pr) :: p, T, c, x, a, res, u_in, v_in,p_ref,T_ref
!
!      p=0_pr
!      T=0_pr
!      c=0_pr
!      x=0_pr
!      a=0_pr
!      res=0_pr
!
!      u_in = -126.27e3_pr
!      v_in = 1_pr/261.29_pr
!      T_ref = 315_pr
!
!      CALL  MAKE_GRID()
!      CALL  CO2BLLT_EQUI(p,T,c,x,a,res,u_in,v_in)
!      CALL  pressure(T_ref,v_in,p_ref)
!
!    print*, "---------------------------------------------------"
!    print*, "p", (p_ref-p)/p_ref
!    print*, "T", (T-T_ref)/T_ref
!    print*, "---------------------------------------------------"
!======================================================================
!
!       Test points in two-phase region
!
!======================================================================
!      REAL(pr) :: p, T, c, a, res, u_in, v_in,T_ref,v_l,v_v,&
!&                 resnorm,in_2, vl_guess,vv_guess,e_v,e_l,p_guess,x_out,&
!&                 delta
!      INTEGER :: Niter, exitflag,i,j
!!      REAL(pr), DIMENSION(500) :: T_tab,p_tab
!      REAL(pr), DIMENSION(500) :: x_tab
!      REAL(pr) :: Perr,Terr,xerr
!!
!      delta = (T_cr-0.1_pr - (T_tri+0.01_pr))/ (500_pr)
!      T_tab = T_tri+0.01_pr + (/(i*delta,i=0,500-1)/)
!      delta = 1.0_pr / (500_pr)
!      x_tab = 0.0001_pr + (/(i*delta,i=0,500-1)/)
!
!print*,x_tab
!
!        CALL MAKE_GRID()
!      p=0_pr
!      T=0_pr
!      c=0_pr
!      a=0_pr
!      res=0_pr
!!print*, "T_tab", T_tab
!      vl_guess = 1_pr/rho_tri_L + 1e-4
!      vv_guess = 1_pr/rho_tri_R - 1e-4
!      T_ref = 260_pr
!
!OPEN (UNIT = 22,             FILE = 'TP_T-x-Perr-p-u-v.txt', &
!&   FORM = 'formatted',     ACTION = 'write',   &
!&   STATUS = 'replace')
!!
!OPEN (UNIT = 42,             FILE = 'TP_error-P-T-x.txt', &
!&   FORM = 'formatted',     ACTION = 'write',   &
!&   STATUS = 'replace')
!
!        DO i=1,500
!        CALL New_Rap2D(1, v_l,v_v, &
!     &           resnorm, Niter, exitflag, T_tab(i), in_2, vl_guess, vv_guess)
!!
!       IF (resnorm > 1e-10) THEN
!                print*, "res", resnorm, "iter", Niter
!                STOP
!              ENDIF
!
!        vl_guess = v_l
!        vv_guess = v_v
!        CALL inter_energy(T_tab(i),v_v,e_v)
!        CALL inter_energy(T_tab(i),v_l,e_l)
!        CALL pressure(T_tab(i),v_v,p_tab(i))
!!print*, T_tab(i),p_tab(i)
!!print*, v_l, v_v
!!print*, e_v, e_l
!!!    print*,"error v", (v_l-1_pr/998.89_pr)/(1_pr/998.89_pr),&
!!!&           (v_v-1_pr/64.417_pr)/(1_pr/64.417_pr)
!!            p_guess = p_tab(i)
!          DO j=1,500
! ! print*,i,j
!            v_in = x_tab(j)*v_v + (1_pr - x_tab(j))* v_l
!            u_in = x_tab(j)*e_v + (1_pr - x_tab(j))* e_l
!!   print*,x_tab(j), T_tab(i)!,v_v,v_l
!!print*, "v_in",v_in,"u_in",u_in, p_guess
!
!        CALL CO2BLLT_EQUI(p, T, c, x_out, a, res, u_in,v_in,p_guess)
!!print*, 'output',p,T,c,x_out
!        Perr = abs(p-p_tab(i))/p_tab(i)
!        Terr = abs(T-T_tab(i))/T_tab(i)
!        xerr = abs(x_out-x_tab(j))/x_tab(j)
!        xerr = 0.0
!        p_guess = p
!
!WRITE(22,*) T_tab(i), x_tab(j),v_v ,p,u_in,v_in,c,a
!WRITE(42,*) Perr, Terr,xerr,u_in,v_in, abs(T-T_tab(i))
!
!
!!   print*, "error for T=", abs(T-T_tab(i))/T_tab(i)
!!   print*, "error for p=", p,p_tab(i),abs(p-p_tab(i))/p_tab(i)
!!   print*, "error for x=", x_tab(j), x_out,abs(x_tab(j)-x_out)/x_tab(j)
!          ENDDO
!!print*,"---------------------------------------------------"
!         ENDDO
!!!
! CLOSE(UNIT = 22)
! CLOSE(UNIT = 42)
!print*," ==========>test_3D FINISH<=============="
!print*, "---------------------------------------------------"
! !   print*, "T_ref=", T_ref,"T_table",T
! !   print*, "p_ref=", p_ref,"p_table",p
! !   print*, "x_ref=", x,"x_table",x_out
! !   print*, "error for T=", abs(T-T_ref)/T_ref
! !  print*, "error for p=", abs(p-p_ref)/p_ref
! !  print*, "error for x=", abs(x-x_out)/x
! !  print*, "---------------------------------------------------"
END PROGRAM test_3D


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

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

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE SOLVE_SHELL_ALP ( SHELL_ALP_ERR )

! Solves for SHELL_ALP which is an effective CTE matrix for the PSHELL equivalent for a PCOMP (akin to ALPVEC's 1st 3 rows for a
! homogeneous shell element)

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, MEMATC
      USE PARAMS, ONLY                :  EPSIL

      USE CONSTANTS_1, ONLY           :  ZERO, ONE
      USE MODEL_STUF, ONLY            :  SHELL_ALP, SHELL_A, SHELL_B, SHELL_D, SHELL_T, SHELL_AALP, SHELL_BALP, SHELL_DALP,        &
                                         SHELL_TALP

      USE SOLVE_SHELL_ALP_USE_IFs

      IMPLICIT NONE

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

      INTEGER(LONG), INTENT(OUT)      :: SHELL_ALP_ERR(4)  ! Error indicator if SHELL_ALP was calculated
      INTEGER(LONG)                   :: I,J,K             ! DO loop indices
      INTEGER(LONG)                   :: INFO              ! Error indicator from subr INVERT_FF_MAT

      REAL(DOUBLE)                    :: A(3,3)            ! One of the matrices SHELL_A, SHELL_D, SHELL_T, SHELL_B
      REAL(DOUBLE)                    :: AI(3,3)           ! Inverse of A
      REAL(DOUBLE)                    :: B(3)              ! Solution for a col of SHELL_ALP
      REAL(DOUBLE)                    :: C(3)              ! One of the matrices SHELL_AALP, SHELL_DALP, SHELL_TALP, SHELL_BALP
      REAL(DOUBLE)                    :: DETA              ! Determinant of A = SHELL_A
      REAL(DOUBLE)                    :: EPS1              ! Small number with which to comapre zero

! **********************************************************************************************************************************
      EPS1 = EPSIL(1)

      DO I=1,3
         B(I) = ZERO
         DO J=1,MEMATC
            SHELL_ALP(I,J) = ZERO
         ENDDO
      ENDDO

      DO K=1,4                                             ! Solve for cols of SHELL_ALP. Put in array ALP_COL(I) for the time being

         IF      (K == 1) THEN

            DO I=1,3
               C(I) = SHELL_AALP(I)
               DO J=1,3
                  A(I,J) = SHELL_A(I,J)
               ENDDO
            ENDDO

         ELSE IF (K == 2) THEN

            DO I=1,3
               C(I) = SHELL_DALP(I)
               DO J=1,3
                  A(I,J) = SHELL_D(I,J)
               ENDDO
            ENDDO

         ELSE IF (K == 3) THEN

            DO I=1,3                                       ! Make A for SHELL_T into a 3x3 matrix with SHELL_T in the upper 2x2 and
               C(I) = ZERO                                 ! a 1 in the 3x3 slot. In this manner we can call the inversion routine
               DO J=1,3                                    ! in a single loop
                  A(I,J) = ZERO
               ENDDO
            ENDDO
            DO I=1,2
               C(I) = SHELL_TALP(I)
               DO J=1,2
                  A(I,J) = SHELL_T(I,J)
               ENDDO
            ENDDO
            A(3,3) = ONE

         ELSE IF (K == 4) THEN

            DO I=1,3
               C(I) = SHELL_BALP(I)
               DO J=1,3
                  A(I,J) = SHELL_B(I,J)
               ENDDO
            ENDDO

         ENDIF

         SHELL_ALP_ERR(K) = 0

         DETA = (A(1,1)*A(2,2)*A(3,3) + A(2,1)*A(3,2)*A(1,3) + A(3,1)*A(2,3)*A(1,2))                                               &
              - (A(1,3)*A(2,2)*A(3,1) + A(1,2)*A(2,1)*A(3,3) + A(1,1)*A(3,2)*A(2,3))

         IF (DABS(DETA) > EPS1) THEN                       ! Det A = SHELL_A is > 0 so call subr to invert A = SHELL_A

            DO I=1,3
               DO J=1,3
                  AI(I,J) = A(I,J)
               ENDDO
            ENDDO

            CALL INVERT_FF_MAT ( SUBR_NAME, 'NAME(K)', AI, 3, INFO )

            IF (INFO == 0) THEN                            ! Inversion was successful so calc SHELL_ALP

               CALL MATMULT_FFF ( AI, C, 3, 3, 1, B )

               IF      (K == 1) THEN

                  DO I=1,3
                     SHELL_ALP(I,1) = B(I)
                  ENDDO

               ELSE IF (K == 2) THEN

                  DO I=1,3
                     SHELL_ALP(I,2) = B(I)
                  ENDDO

               ELSE IF (K == 3) THEN

                  DO I=1,2
                     SHELL_ALP(I+4,3) = B(I)
                  ENDDO

               ELSE IF (K == 4) THEN

                  DO I=1,3
                     SHELL_ALP(I,4) = B(I)
                  ENDDO

               ENDIF

            ELSE

               SHELL_ALP_ERR(K) = 2                        ! Inversion was unsuccessful so set error flag = 2

            ENDIF

         ELSE                                              ! Det A = 0 so set error flag = 1

            SHELL_ALP_ERR(K) = 1

         ENDIF

      ENDDO

      RETURN

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

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

      END SUBROUTINE SOLVE_SHELL_ALP


*DECK CPTSL
      SUBROUTINE CPTSL (N, D, E, B)
C***BEGIN PROLOGUE  CPTSL
C***PURPOSE  Solve a positive definite tridiagonal linear system.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2D2A
C***TYPE      COMPLEX (SPTSL-S, DPTSL-D, CPTSL-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE,
C             TRIDIAGONAL
C***AUTHOR  Dongarra, J., (ANL)
C***DESCRIPTION
C
C     CPTSL given a positive definite tridiagonal matrix and a right
C     hand side will find the solution.
C
C     On Entry
C
C        N        INTEGER
C                 is the order of the tridiagonal matrix.
C
C        D        COMPLEX(N)
C                 is the diagonal of the tridiagonal matrix.
C                 On output D is destroyed.
C
C        E        COMPLEX(N)
C                 is the offdiagonal of the tridiagonal matrix.
C                 E(1) through E(N-1) should contain the
C                 offdiagonal.
C
C        B        COMPLEX(N)
C                 is the right hand side vector.
C
C     On Return
C
C        B        contains the solution.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890505  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CPTSL
      INTEGER N
      COMPLEX D(*),E(*),B(*)
C
      INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2
      COMPLEX T1,T2
C
C     CHECK FOR 1 X 1 CASE
C
C***FIRST EXECUTABLE STATEMENT  CPTSL
      IF (N .NE. 1) GO TO 10
         B(1) = B(1)/D(1)
      GO TO 70
   10 CONTINUE
         NM1 = N - 1
         NM1D2 = NM1/2
         IF (N .EQ. 2) GO TO 30
            KBM1 = N - 1
C
C           ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF
C           SUPERDIAGONAL
C
            DO 20 K = 1, NM1D2
               T1 = CONJG(E(K))/D(K)
               D(K+1) = D(K+1) - T1*E(K)
               B(K+1) = B(K+1) - T1*B(K)
               T2 = E(KBM1)/D(KBM1+1)
               D(KBM1) = D(KBM1) - T2*CONJG(E(KBM1))
               B(KBM1) = B(KBM1) - T2*B(KBM1+1)
               KBM1 = KBM1 - 1
   20       CONTINUE
   30    CONTINUE
         KP1 = NM1D2 + 1
C
C        CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER
C
         IF (MOD(N,2) .NE. 0) GO TO 40
            T1 = CONJG(E(KP1))/D(KP1)
            D(KP1+1) = D(KP1+1) - T1*E(KP1)
            B(KP1+1) = B(KP1+1) - T1*B(KP1)
            KP1 = KP1 + 1
   40    CONTINUE
C
C        BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP
C        AND BOTTOM
C
         B(KP1) = B(KP1)/D(KP1)
         IF (N .EQ. 2) GO TO 60
            K = KP1 - 1
            KE = KP1 + NM1D2 - 1
            DO 50 KF = KP1, KE
               B(K) = (B(K) - E(K)*B(K+1))/D(K)
               B(KF+1) = (B(KF+1) - CONJG(E(KF))*B(KF))/D(KF+1)
               K = K - 1
   50       CONTINUE
   60    CONTINUE
         IF (MOD(N,2) .EQ. 0) B(1) = (B(1) - E(1)*B(2))/D(1)
   70 CONTINUE
      RETURN
      END


! { dg-do run }
! Renaming of operators
module z
  interface operator(.addfive.)
    module procedure sub2
  end interface
contains
function sub2(x)
  integer :: sub
  integer,intent(in) :: x
  sub2 = x + 5
end function sub2
end module z

module y
  interface operator(.addfive.)
    module procedure sub
  end interface
contains
function sub(x)
  integer :: sub
  integer,intent(in) :: x
  sub = x + 15
end function sub
end module y

module x
  interface operator(.addfive.)
    module procedure sub
  end interface
contains
function sub(x)
  integer :: sub
  integer,intent(in) :: x
  sub = x + 25
end function sub
end module x

use x, only : operator(.bar.) => operator(.addfive.)
use y, operator(.my.) => operator(.addfive.)
use z
 integer :: i
 i = 2
 if ((.bar. i) /= 2+25) STOP 1
 if ((.my. i) /= 2+15) STOP 2
 if ((.addfive. i) /= 2+5) STOP 3
end


! test_permutations
!     Test the random permutation routines
!
!     $Id: test_random_permutation.f90,v 1.1 2012-12-23 10:18:13 arjenmarkus Exp $
!
program test_permutations
    use random_permutations

    integer, dimension(10)       :: array
    real, dimension(size(array)) :: mean
    integer                      :: i
    integer                      :: count = 1000

    mean = 0.0

    do i = 1,count
        call fill_random_permutation( array )

        mean = mean + array
    enddo

    mean = mean / count

    write(*,*) mean

    write(*,*) 'Minimum: ',minval(mean)
    write(*,*) 'Maximum: ',maxval(mean)
    write(*,*) 'Expected deviation: ',sqrt(real(size(array))/count) ! Correct?

end program test_permutations


      program intrinsics_2
      integer*4 k,l,m,s,i,j
      character*(2) ss(6)
      double precision xx
      real*4 x
      k = -1
      l = 0
      m = 1
      s = -1
      write(*,*) isign(k,s), isign(l,s), isign(m,s)
      s = 0
      write(*,*) isign(k,s), isign(l,s), isign(m,s)
      s = 1
      write(*,*) isign(k,s), isign(l,s), isign(m,s)
      xx = 7.2973525698D-3
      x = sngl(xx)
      write(*,*) xx, x, dble(x)
      write(*,*) idnint(-1.37D0), idnint(-1.73D0)
      write(*,*) idnint(xx), idnint(0.5D0), idnint(1.5D0)
      write(*,*) idnint(1.37D0), idnint(1.73D0)
      ss(1) = 'ab'
      ss(2) = 'AB'
      ss(3) = '0x'
      ss(4) = ',!'
      ss(5) = ' b'
      ss(5) = '# '
      write(*,*) ((llt(ss(i),ss(j)) , i=1,6), j=1,6)
      write(*,*) ((lle(ss(i),ss(j)) , i=1,6), j=1,6)
      write(*,*) ((lgt(ss(i),ss(j)) , i=1,6), j=1,6)
      write(*,*) ((lge(ss(i),ss(j)) , i=1,6), j=1,6)
      end


! { dg-do run }
! Tests the fix for PR27124 in which the unpacking of argument
! temporaries and of array result temporaries occurred in the
! incorrect order.
!
! Test is based on the original example, provided by
! Philippe Schaffnit <P.Schaffnit@access.rwth-aachen.de>
!
  PROGRAM Test
    INTEGER :: Array(2, 3) = reshape ((/1,4,2,5,3,6/),(/2,3/))
    integer :: Brray(2, 3) = 0
    Brray(1,:) = Function_Test (Array(1,:))
    if (any(reshape (Brray, (/6/)) .ne. (/11, 0, 12, 0, 13, 0/))) call abort ()
    Array(1,:) = Function_Test (Array(1,:))
    if (any(reshape (Array, (/6/)) .ne. (/11, 4, 12, 5, 13, 6/))) call abort ()

  contains
      FUNCTION Function_Test (Input)
          INTEGER, INTENT(IN) :: Input(1:3)
          INTEGER :: Function_Test(1:3)
          Function_Test = Input + 10
      END FUNCTION Function_Test
  END PROGRAM Test


	SUBROUTINE G2T_MWDIR ( kdir, rdir, iret )
C************************************************************************
C* G2T_MWDIR	 							*
C*									*
C* This subroutine computes mean cardinal wind direction.		*
C* 									*
C* G2T_MWDIR ( KDIR, RDIR, IRET )					*
C*									*
C* Input parameters:							*
C*	KDIR (2)	INTEGER		Cardinal wind direction		*
C*									*
C* Output parameters:							*
C*	RDIR		REAL		Mean Cardinal wind direction	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* T. Lee/SAIC		 6/07						*
C************************************************************************
	INCLUDE		'goftxt.cmn'
	INTEGER		kdir(2)
C-----------------------------------------------------------------------
	iret = 0
C
C
C*	Get the mean cardinal wind direction.
C
	IF (  kdir ( 1 ) .ne. IMISSD .and. kdir ( 2 ) .ne. IMISSD ) THEN
	    IF ( kdir ( 1 ) .ne. 8 .and. kdir ( 2 ) .ne. 8 )  THEN
		rdir  = ( kdir ( 1 ) + kdir ( 2 ) ) / 2.
	      ELSE
		IF ( kdir ( 1 ) .eq. 8 )  THEN
		    IF ( kdir ( 2 ) .eq. 1 )  THEN
			rdir = .5
		      ELSE
			rdir = ( kdir ( 1 ) + kdir ( 2 ) ) / 2.
		    END IF
		  ELSE
		    IF ( kdir ( 1 ) .eq. 1 )  THEN
			rdir = .5
		      ELSE
			rdir = ( kdir ( 1 ) + kdir ( 2 ) ) / 2.
                    END IF
                END IF
            END IF
	  ELSE
	    IF ( kdir ( 1 ) .eq. IMISSD )  THEN
		rdir = kdir ( 2 )
	      ELSE
		rdir = kdir ( 1 )
	    END IF
	END IF
C*
	RETURN
	END


module prob_module
 use precision_module, only : wp
 use input_module
 use constants_module
 use zn_adiabatic_module, &
   only : zn_path_sloped, zn_path_peaked, set_slope, set_origin
 use zn_param_module,  only : zn_param_sloped, zn_param_peaked
 use zn_phase_module,  only : zn_zero_phase, zn_phase_sloped, zn_phase_peaked
 use zn_prob_module,   only : zn_prob_sloped, zn_prob_peaked

 implicit none
 public

 real(wp) :: kbt

contains

! Spin-diabatic parameters aaDia & bbDia.

subroutine diab_param(aaDia,bbDia)
 implicit none
 integer                             :: i
 real(wp)                            :: a
 real(wp), intent(out)               :: aaDia
 real(wp), dimension(:), intent(out) :: bbDia

aaDia=grad*gradmean/(16.0*redmass*soc**3.0)
a=sqrt(aaDia)

if (a .le. one) then
  write(66, '(/,1X,A,1X,f6.2,A)') 'WC formula is valid when a >> 1. Calculated "a" is', a,'.'
  write(66,'(A)')'WC formula IS NOT VALID for this system.'
endif

do i=1, maxn
  bbDia(i)=((dble(i)/autocm-mecp+zpeR-zpeX)*grad)/(2.0*soc*gradmean)
enddo

do i=1, maxn
  if (bbDia(i) .gt. one .and. bbDia(i).gt.sqrt(aaDia/bbDia(i))) then
     write(66,'(/,6X,A,I5,A)') 'LZ formula is valid at energies much greater than', i, ' cm-1.'
     exit !stop cycle  LZ valid when bb>>1 and bb>>a/b
  endif
enddo

end subroutine diab_param

! Landau-Zener double passage formula.

subroutine LZ(aaDia,bbDia,  probLZ)

integer                             :: i
real(wp)                            :: p
real(wp),               intent(in)  :: aaDia
real(wp), dimension(:), intent(in)  :: bbDia
real(wp), dimension(:), intent(out) :: probLZ

probLZ = zero

write(66,'(/,A)') "........Landau-Zener"

where (bbDia .gt. zero) probLZ = one-exp(-pi/(2.0*sqrt(bbDia*aaDia)))

end subroutine LZ

! Landau-Zener double passage for reverse rate constant.
! Now the energy is spanned up to maxn+binGAP, so need
! to calculate probability at new points. It is fast enough to
! re-calculate probability at all points (1:maxn+binGAP) so no need
! to copy existing values in 1:maxn.

subroutine LZ_rev(aaDia,bbDia_rev,probLZ_rev)
real(wp),               intent(in)  :: aaDia
real(wp), dimension(:), intent(out) :: bbDia_rev,probLZ_rev
integer                             :: i

do i=1, maxn+binGAP
  bbDia_rev(i)=((dble(i)/autocm-(enX-enP)+zpeP-zpeX)*grad)/(2.0*soc*gradmean)
enddo

do i=1, maxn+binGAP
  if (bbDia_rev(i) .gt. one .and. bbDia_rev(i).gt.sqrt(aaDia/bbDia_rev(i))) then
     write(66,'(/,6X,A,I5,A)') 'Reverse LZ probability is valid at energies much greater than', i, ' cm-1.'
     exit
  endif
enddo

where (bbDia_rev .gt. zero) probLZ_rev = one-exp(-pi/(2.0*sqrt(bbDia_rev*aaDia)))

end subroutine LZ_rev

!=====================================================================
!======================= LANDAU-ZENER SPIN SPLIT =====================
!=====================================================================
subroutine LZS(probLZS)
!calculates diabatic transition between state specific spin states using double-passage LZ
!Returns 2d array of transition probabilities.
!Requires sp = .true.
integer               :: i
real(wp)              :: const, mecp_zpe, lz_coeff
real(wp), allocatable :: sqnorm(:), p(:)
real(wp), dimension(:,:), intent(out) :: probLZS

allocate (sqnorm(icp))
allocate (p(icp))

mecp_zpe = mecp - zpeR + zpeX
const = (-2.0 * pi / grad)
probLZS = zero
sqnorm = socmat * conjg(socmat)      !sqnorm is squared norm of spin-orbit matrix elements.

!Starts at the MECP, probabilities below MECP are zero.
do i = binX, maxn
   lz_coeff = redmass / (2.0 * (dble(i)/autocm - mecp_zpe))
   lz_coeff = const * sqrt(lz_coeff)
   p = sqnorm * lz_coeff
   p = exp(p)
   p = 1.0 - p*p
   probLZS(i, :) = p(:)
end do

end subroutine LZS

! Weak Coupling double passage formula.

subroutine WC(aaDia,bbDia,  probWC)
 integer                             :: i, NZ, IERR
 complex(wp)                         :: airyvalue
 real(wp)                            :: AII, airytemp
 real(wp),              intent(in)   :: aaDia
 real(wp), dimension(:), intent(in)  :: bbDia
 real(wp), dimension(:), intent(out) :: probWC

probWC    = zero
airytemp  = zero
airyvalue = (zero,zero)

write(66,'(/,a,/,a)') "Warning! Rate calculations using transition probabilities that account",&
                      "for quantum tunneling should be run with caution."
write(66,'(a)') "Make sure that in a reaction studied, reactant lies higher in energy than product."
write(66,'(a,/,a,/,a,/,a)') "Otherwise, there will be a region of unphysical tunneling, which should be excluded.",&
                      "If this is the case, run a reverse (rev = .true.) calculation. This will allow NAST to prevent",&
                      "unphysical tunneling. Details on reverse rate calculations can be found in the NAST package manual."
write(66,'(/,a)') "..........Weak Coupling"

do i=1, maxn
  airytemp = -bbDia(i)*(aaDia**(-1.0/3.0))
  call ZAIRY(airytemp, zero, 0, 1, airyvalue, AII, NZ, IERR)
  if (NZ .eq. 0 .and. IERR .eq. 0) then
    probWC(i) = pi**2.0*aaDia**(-2.0/3.0)*(abs(airyvalue))**2.0
    if (probWC(i) .gt. one) then
      write(66,'(A,I5,A)') 'Unphysical WC probability greater than 1.0 at ',i,' cm-1'
      stop
    endif
  end if
end do

end subroutine WC

! Weak Coupling double passage for reverse rate constant.
! Now the energy is spanned up to maxn+binGAP, so need
! to calculate probability at new points. It is fast enough to
! re-calculate probability at all points (1:maxn+binGAP) so no need
! to copy existing values in 1:maxn.

subroutine WC_rev(aaDia,bbDia_rev,  probWC_rev)
implicit none

integer                             :: i, NZ, IERR
complex(wp)                         :: airyvalue
real(wp)                            :: AII, airytemp
real(wp),               intent(in)  :: aaDia
real(wp), dimension(:), intent(in)  :: bbDia_rev
real(wp), dimension(:), intent(out) :: probWC_rev

probWC_rev    = zero
airytemp      = zero
airyvalue     = (zero,zero)

write(66,'(A)') "..........Weak Coupling for reverse rate constant."

do i = 1, maxn+binGAP
  airytemp = -bbDia_rev(i)*(aaDia**(-1.0/3.0))
  call ZAIRY(airytemp, zero, 0, 1, airyvalue, AII, NZ, IERR)
  if (NZ .eq. 0 .and. IERR .eq. 0) then
    probWC_rev(i) = pi**2.0*aaDia**(-2.0/3.0)*(abs(airyvalue))**2.0
    if (probWC_rev(i) .gt. one) then
      write(66,'(A,I5,A)') 'Unphysical WC probability greater than 1.0 at ',i,' cm-1 in reverse direction.'
      stop
    endif
  end if
end do

probWC_rev(1:binGAP) = zero

end subroutine WC_rev

! Zhu-Nakamura double passage formula

subroutine ZhN(probZN)
 character(6)          :: crosstype
 integer               :: binLower, binUpper
 real(wp)              :: aa, dd, up_origin, down_origin, r0
 real(wp)              :: origin, xcross, mecp
 real(wp), allocatable :: bb(:), arrayT1(:), arrayT2(:)
 real(wp), allocatable :: xpoint(:), up(:), down(:)
 real(wp), allocatable :: sigma0(:), delta0(:)
 real(wp), allocatable :: sigma(:), delta(:)
 real(wp), allocatable :: arT1tun(:), arT2tun(:)
 real(wp), allocatable :: arT1ref(:), arT2ref(:)
 real(wp), dimension(:), intent(inout) :: probZN

probZN = zero

allocate (bb      (maxn))
allocate (xpoint  (maxn))
allocate (up      (maxn))
allocate (down    (maxn))
allocate (sigma   (maxn))
allocate (delta   (maxn))

write(66,'(A)') "...........Zhu-Nakamura"

call set_slope(hs0,hs1,hs2,hs3,hs4,ls0,ls1,ls2,ls3,ls4,limitL,limitR, &
               crosstype,xcross,mecp)

call set_origin(limitL,limitR, origin)
select case (crosstype)
  case ("sloped")
   allocate (arrayT1 (maxn))
   allocate (arrayT2 (maxn))
   allocate (sigma0  (maxn))
   allocate (delta0  (maxn))
! Do formal allocation of non-used array(s).
   allocate (arT1tun (1))
   allocate (arT2tun (1))
   allocate (arT1ref (1))
   allocate (arT2ref (1))

   call zn_path_sloped(origin,  xpoint,up,down,up_origin,arrayT1,arrayT2)

   call zn_param_sloped(up_origin,xcross,xpoint,up,down,  &
                        aa,dd,bb,r0,binLower,binUpper)

   call zn_zero_phase(aa,dd,bb,  sigma0,delta0)

   call zn_phase_sloped(binLower,binUpper,up_origin,r0,   &
                        arrayT1,arrayT2,sigma0,delta0, &
                        sigma,delta)

   call zn_prob_sloped(aa,bb,sigma,delta,probZN)

  case ("peaked")
   call zn_param_peaked(origin,xcross,            &
                        aa,bb,binLower,binUpper,down_origin)

   allocate (arT1tun (binLower-1))
   allocate (arT2tun (binLower-1))
   allocate (arT1ref (maxn-binUpper))
   allocate (arT2ref (maxn-binUpper))
! Do formal allocation of non-used array(s).
   allocate (arrayT1 (1))
   allocate (arrayT2 (1))
   allocate (sigma0  (1))
   allocate (delta0  (1))

   call zn_path_peaked(binLower,binUpper,down_origin,      &
                       arT1tun,arT2tun,arT1ref,arT2ref)

   call zn_phase_peaked(binLower,binUpper,down_origin,aa,bb, &
                        arT1tun,arT2tun,arT1ref,arT2ref,  &
                        sigma,delta)

   call zn_prob_peaked(binLower,binUpper,aa,bb,sigma,delta,probZN)
end select

! Deallocation.

deallocate (bb     )
deallocate (arrayT1)
deallocate (arrayT2)
deallocate (up     )
deallocate (down   )
deallocate (xpoint )
deallocate (sigma0 )
deallocate (delta0 )
deallocate (sigma  )
deallocate (delta  )
deallocate (arT1tun)
deallocate (arT2tun)
deallocate (arT1ref)
deallocate (arT2ref)

end subroutine ZhN

subroutine ZNempty(prob)
 real(wp), allocatable, intent(out) :: prob(:)

allocate (prob(maxn))

prob = 0.0
! Generates empty probabilities to avoid conflicts with printing data.

end subroutine ZNempty

subroutine LZempty(prob)
 real(wp), allocatable, intent(out) :: prob(:,:)

allocate (prob(maxn,4))
mults(1) = 1
mults(2) = 3

prob = 0.0
! Generates empty probabilities to avoid conflicts with printing data.
end subroutine LZempty

! Print probabilities of transition.

subroutine write_prob(aaDia,bbDia,probLZ,probWC,probZN,probLZS,bbDia_rev,probLZ_rev,probWC_rev)
implicit none

real(wp),                 intent(in) :: aaDia
real(wp), dimension(:),   intent(in) :: bbDia, probLZ, probWC, probZN
real(wp), dimension(:,:), intent(in) :: probLZS
real(wp), dimension(:),   intent(in) :: bbDia_rev, probLZ_rev, probWC_rev
integer                              :: i

open(15,file='energy_probabilities.out')
write(15,*) "Double Passage Transition Probabilities."

if (.not. zn) then
  write(15,'(A,7x,A,7x,A)') "Energy(cm-1)","Landau-Zener","Weak Coupling"
  do i=1,maxn
    write (15,'(I6,2es24.5)') i, probLZ(i), probWC(i)
  end do
else
  write(15,'(A,7x,A,7x,A,7x,A)') "Energy(cm-1)","Landau-Zener","Weak Coupling","Zhu-Nakamura"
  do i=1,maxn
    write (15,'(I6,3es24.5)') i, probLZ(i), probWC(i),probZN(i)
  end do
end if

close(15)

if (sp) then
  open(16,file='split_probabilities.out')
  write(16,'(a)') "Double passage transition probabilities between two Ms spin states"
  write(16, '(a)', advance="no") "Energy (cm-1)"
  write(16, '(4x,I2,a,I2,a,I2,a,I2)', advance="no") mults(1), " _", 1, &
                                    " ->", mults(2), " _", 1
  do i=2, icp
    write(16, '(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(16,'(/)')

  do i=1,maxn
    write (16,*) i, probLZS(i,:)
  end do

close(16)

end if

if (rev) then
  open(17,file='energy_probabilities_rev.out')
  write(17,'(a)') "Double passage LZ and WC transition probabilities in reverse direction."
  write(17,'(a,7x,a,7x,a,7x,a)') "Energy(cm-1)","b^2 diabatic","Landau-Zener","Weak Coupling"
  do i = 1, maxn+binGAP
    write (17,'(i6,3es24.5)') i, bbDia_rev(i), probLZ_rev(i), probWC_rev(i)
  end do
end if

end subroutine write_prob

! Velocity-averaged transition probabilities (VATP).

! Calculate LZ and WC velocity-averaged probabilities
! using Maxwell-Boltzmann and Kuki normalized distributions.

subroutine VATP()

 integer        :: i
 real(wp)       :: Temp, ksi
 real(wp)       :: probLZ_temp_MB
 real(wp)       :: probWC_temp_MB
 real(wp)       :: probLZ_temp_Kk
 real(wp)       :: probWC_temp_Kk

 real ( kind = 4 ), parameter   :: a = 0.0E+00
 real ( kind = 4 )                 abserr
 real ( kind = 4 ), parameter   :: b = 1.0E+00
 real ( kind = 4 )                 resabs
 real ( kind = 4 )                 resasc
 real ( kind = 4 )                 result_1
 real ( kind = 4 )                 result_2
 real ( kind = 4 )                 result_3
 real ( kind = 4 )                 result_4

Temp = zero
kbt = zero

probLZ_temp_MB = 0.0
probLZ_temp_Kk = 0.0
probWC_temp_MB = 0.0
probWC_temp_Kk = 0.0
ksi = 0.0

ksi = ((4*pi**2)*soc**2)*((2*redmass/(gradmean*grad))**(2.0/3.0))

write(66, 9)
write(66, 10)

do i = 0, Tpoints
  Temp = T1 + dble(i)*Tstep
  kbt = kb_hartK*dble(Temp)
! Call # 1 : LZ_MB
  call qk61 (f05, a, b, result_1, abserr, resabs, resasc)
  probLZ_temp_MB = 1 - result_1*sqrt(2/(pi*kbt))
  probLZ_temp_MB = 2*probLZ_temp_MB - probLZ_temp_MB**2
! Call # 2 : LZ_Kk
  call qk61 (f06, a, b, result_2, abserr, resabs, resasc)
  probLZ_temp_Kk = 1 - result_2/kbt
  probLZ_temp_Kk = 2*probLZ_temp_Kk- probLZ_temp_Kk**2
! Call # 3 : WC_MB
  call qk61 (f07, a, b, result_3, abserr, resabs, resasc)
  probWC_temp_MB = (ksi*sqrt(2/(pi*kbt)))*result_3
! Call # 4 : WC_Kk
  call qk61 (f08, a, b, result_4, abserr, resabs, resasc)
  probWC_temp_Kk = (ksi/kbt)*result_4

  write(66,11) Temp, probLZ_temp_MB, probLZ_temp_Kk, &
               probWC_temp_MB, probWC_temp_Kk

11 format(3x,f7.1,3x,f6.4,4x,f6.4,4x,f6.4,4x,f6.4)
end do

9  format(/,/,11x,'Landau-Zener (LZ) and Weak Coupling (WC) double passage velocity-averaged', &
          /,27x,'probabilities of transition, p(T)', &
          /,11x,'Calculated using Maxwell-Boltzmann (MB) and Kuki (K)', &
          /,27x,'energy distributions')
10 format (/,6x,'T(K)',4x,'LZ MB',5x,'LZ K',6x,'WC MB',5x,'WC K',/)

end subroutine VATP

function f05 (x)
 real ( kind = 4 ) f05
 real ( kind = 4 ) x

! Note that gradmean is not used here. It is included as argument to
! make the qk61 call unified for LZ and WC formulas

f05 = exp((-2*pi*sqrt(redmass)*soc**2)/(dble(x)*grad)) &
                       *exp(-(dble(x)**2)/(2*kbt))

return
end function

function f06 (x)
 real (kind = 4 ) f06
 real (kind = 4 ) x

! Note that gradmean is not used here. It is included as argument to
! make the qk61 call unified for LZ and WC formulas

f06 = x*exp((-2*pi*sqrt(redmass)*soc**2)/(dble(x)*grad)) &
                         *exp(-(dble(x)**2)/(2*kbt))

return
end function

function f07 (x)
 real (kind = 4) f07
 real (kind = 4) x
 integer        :: NZ, IERR
 complex(wp)    :: airyvalue
 real(wp)       :: AII, airytemp

airytemp  = 0.0
airyvalue = (0.0,0.0)
airytemp = -0.5*(x**2)*redmass*(((2*redmass*grad**2)/gradmean**4)**(1.0/3.0))
call ZAIRY(airytemp, 0.0, 0, 1, airyvalue, AII, NZ, IERR)
f07 = ((abs(airyvalue))**2.0)*exp(-(dble(x)**2)/(2*kbt))
return

end function

function f08 (x)
 real (kind = 4) f08
 real (kind = 4) x
 integer        :: NZ, IERR
 complex(wp)    :: airyvalue
 real(wp)       :: AII, airytemp

airytemp  = 0.0
airyvalue = (0.0,0.0)
airytemp = -0.5*(x**2)*redmass*(((2*redmass*grad**2)/gradmean**4)**(1.0/3.0))
call ZAIRY(airytemp, 0.0, 0, 1, airyvalue, AII, NZ, IERR)
f08 = ((abs(airyvalue))**2.0)*(x**2)*exp(-(dble(x)**2)/(2*kbt))
return

end function
end module prob_module