MODULE MomentEquationsLimiterUtilitiesModule_DG

  USE KindModule, ONLY: &
    DP
  USE ProgramHeaderModule, ONLY: &
    nDOFX, nDOF, &
    nX, nNodesX, &
    nE, nNodesE
  USE ReferenceElementModule, ONLY: &
    Weights_q
  USE UtilitiesModule, ONLY: &
    NodeNumberX, &
    NodeNumber
  USE PolynomialBasisModule_Lagrange, ONLY: &
    L_E, L_X1, L_X2, L_X3
  USE PolynomialBasisMappingModule, ONLY: &
    MapNodalToModal_Radiation, &
    MapModalToNodal_Radiation
  USE MeshModule, ONLY: &
    MeshE, &
    MeshX
  USE RadiationFieldsModule, ONLY: &
    nSpecies, &
    uCR, iCR_N, nCR, &
    Discontinuity

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: InitializeDiscontinuityDetector
  PUBLIC :: DetectDiscontinuities
  PUBLIC :: PackSpatialNodes
  PUBLIC :: UnpackSpatialNodes
  PUBLIC :: SolveTheta_Bisection

  LOGICAL, PARAMETER :: UseDiscontinuityDetector = .TRUE.
  REAL(DP), DIMENSION(:,:), ALLOCATABLE :: Lagrange_X1_P
  REAL(DP), DIMENSION(:,:), ALLOCATABLE :: Lagrange_X1_M

CONTAINS

  SUBROUTINE InitializeDiscontinuityDetector

    INTEGER  :: iNodeE, iNodeX1, iNodeX2, iNodeX3, iNode
    INTEGER  :: jNodeE, jNodeX1, jNodeX2, jNodeX3, jNode
    REAL(DP) :: eta_E, eta_X1, eta_X2, eta_X3

    ALLOCATE( Lagrange_X1_P(nDOF,nDOF) )
    ALLOCATE( Lagrange_X1_M(nDOF,nDOF) )

    DO jNodeX3 = 1, nNodesX(3)
      DO jNodeX2 = 1, nNodesX(2)
        DO jNodeX1 = 1, nNodesX(1)
          DO jNodeE = 1, nNodesE

            jNode = NodeNumber( jNodeE, jNodeX1, jNodeX2, jNodeX3 )

            eta_E  = MeshE    % Nodes(jNodeE)
            eta_X1 = MeshX(1) % Nodes(jNodeX1)
            eta_X2 = MeshX(2) % Nodes(jNodeX2)
            eta_X3 = MeshX(3) % Nodes(jNodeX3)

            DO iNodeX3 = 1, nNodesX(3)
              DO iNodeX2 = 1, nNodesX(2)
                DO iNodeX1 = 1, nNodesX(1)
                  DO iNodeE = 1, nNodesE

                    iNode = NodeNumber( iNodeE, iNodeX1, iNodeX2, iNodeX3 )

                    Lagrange_X1_P(iNode,jNode) &
                      = L_E(iNodeE) % P( eta_E ) &
                        * L_X1(iNodeX1) % P( eta_X1 + 1.0_DP ) &
                          * L_X2(iNodeX2) % P( eta_X2 ) &
                            * L_X3(iNodeX3) % P( eta_X3 )

                    Lagrange_X1_M(iNode,jNode) &
                      = L_E(iNodeE) % P( eta_E ) &
                        * L_X1(iNodeX1) % P( eta_X1 - 1.0_DP ) &
                          * L_X2(iNodeX2) % P( eta_X2 ) &
                            * L_X3(iNodeX3) % P( eta_X3 )

                  END DO
                END DO
              END DO
            END DO

          END DO
        END DO
      END DO
    END DO

  END SUBROUTINE InitializeDiscontinuityDetector

  SUBROUTINE DetectDiscontinuities

    INTEGER  :: iS, iE, iX1, iX2, iX3, iCR, k
    REAL(DP) :: F_M, F_P
    REAL(DP), PARAMETER :: alpha = 1.5_DP
    REAL(DP), DIMENSION(nCR)      :: uCR_A
    REAL(DP), DIMENSION(nDOF,nCR) :: uCR_M
    REAL(DP), DIMENSION(nDOF,nCR) :: uCR_M_P_X1
    REAL(DP), DIMENSION(nDOF,nCR) :: uCR_M_N_X1

    Discontinuity(:,:,:,:) = 0.0_DP

    IF( .NOT. UseDiscontinuityDetector )THEN

      Discontinuity(:,:,:,:) = 1.0_DP
      RETURN

    END IF

    DO iS = 1, nSpecies

      DO iX3 = 1, nX(3)
        DO iX2 = 1, nX(2)
          !$OMP PARALLEL DO PRIVATE &
          !$OMP&              ( iX1, iE, iCR, k, F_M, F_P, uCR_A, &
          !$OMP&                uCR_M_P_X1, uCR_M, uCR_M_N_X1 )
          DO iX1 = 1, nX(1)
            DO iE = 1, nE

              ! --- Map To Modal Representation ---

              DO iCR = 1, nCR

                CALL MapNodalToModal_Radiation &
                       ( uCR(:,iE,iX1-1,iX2,iX3,iCR,iS), uCR_M_P_X1(:,iCR) )
                CALL MapNodalToModal_Radiation &
                       ( uCR(:,iE,iX1,  iX2,iX3,iCR,iS), uCR_M     (:,iCR) )
                CALL MapNodalToModal_Radiation &
                       ( uCR(:,iE,iX1+1,iX2,iX3,iCR,iS), uCR_M_N_X1(:,iCR) )

              END DO

              ! --- Cell-Averaged Quantities ---

              uCR_A(1:nCR) = uCR_M(1,1:nCR)

              ! --- Detect Discontinuity with Harten's Sub-Cell Method ---

              F_M = 0.0_DP
              F_P = 0.0_DP
              DO k = 1, nDOF

                F_M &
                  = F_M &
                    + Weights_q(k) &
                      * SUM( Lagrange_X1_M(:,k) &
                             * uCR(:,iE,iX1+1,iX2,iX3,iCR_N,iS) )

                F_P &
                  = F_P &
                    + Weights_q(k) &
                      * SUM( Lagrange_X1_P(:,k) &
                             * uCR(:,iE,iX1-1,iX2,iX3,iCR_N,iS) )

              END DO
              F_M = F_M - uCR_A(iCR_N)
              F_P = F_P - uCR_A(iCR_N)

              IF( F_M * F_P <= 0.0_DP )THEN
                LOOP: DO k = 1, nDOF

                  IF( ALL( [ ABS( uCR_M     (k,iCR_N) ), &
                             ABS( uCR_M_P_X1(k,iCR_N) ), &
                             ABS( uCR_M_N_X1(k,iCR_N) ) ] * 1.0d12 &
                           < 1.0_DP ) ) CYCLE LOOP

                  IF( ABS( uCR_M(k,iCR_N) ) &
                      > alpha * ABS( uCR_M_P_X1(k,iCR_N) ) .AND. &
                      ABS( uCR_M(k,iCR_N) ) &
                      > alpha * ABS( uCR_M_N_X1(k,iCR_N) ) ) &
                  THEN
                    Discontinuity(iE,iX1,iX2,iX3) = 1.0_DP
                    EXIT LOOP
                  END IF

                END DO LOOP
              END IF

            END DO ! iE
          END DO ! iX1
          !$OMP END PARALLEL DO
        END DO ! iX2
      END DO ! iX3

    END DO ! iS

  END SUBROUTINE DetectDiscontinuities

  SUBROUTINE PackSpatialNodes( iNodeE, u, uX )

    INTEGER,                    INTENT(in)  :: iNodeE
    REAL(DP), DIMENSION(nDOF),  INTENT(in)  :: u
    REAL(DP), DIMENSION(nDOFX), INTENT(out) :: uX

    INTEGER :: iNodeX1, iNodeX2, iNodeX3
    INTEGER :: iNodeX, iNode

    DO iNodeX3 = 1, nNodesX(3)
      DO iNodeX2 = 1, nNodesX(2)
        DO iNodeX1 = 1, nNodesX(1)

          iNodeX &
            = NodeNumberX( iNodeX1, iNodeX2, iNodeX3 )
          iNode &
            = NodeNumber( iNodeE, iNodeX1, iNodeX2, iNodeX3 )

          uX(iNodeX) = u(iNode)

        END DO
      END DO
    END DO

  END SUBROUTINE PackSpatialNodes

  SUBROUTINE UnpackSpatialNodes( iNodeE, u, uX )

    INTEGER,                    INTENT(in)  :: iNodeE
    REAL(DP), DIMENSION(nDOF),  INTENT(out) :: u
    REAL(DP), DIMENSION(nDOFX), INTENT(in)  :: uX

    INTEGER :: iNodeX1, iNodeX2, iNodeX3
    INTEGER :: iNodeX, iNode

    DO iNodeX3 = 1, nNodesX(3)
      DO iNodeX2 = 1, nNodesX(2)
        DO iNodeX1 = 1, nNodesX(1)

          iNodeX &
            = NodeNumberX( iNodeX1, iNodeX2, iNodeX3 )
          iNode &
            = NodeNumber( iNodeE, iNodeX1, iNodeX2, iNodeX3 )

          u(iNode) = uX(iNodeX)

        END DO
      END DO
    END DO

  END SUBROUTINE UnpackSpatialNodes

  SUBROUTINE SolveTheta_Bisection &
    ( N_K, G1_K, G2_K, G3_K, dN, dG1, dG2, dG3, Tol_G, Theta )

    REAL(DP), INTENT(in)  :: N_K, G1_K, G2_K, G3_K, dN, dG1, dG2, dG3, Tol_G
    REAL(DP), INTENT(out) :: Theta

    LOGICAL  :: Converged
    INTEGER  :: Iter
    REAL(DP) :: a, b, c, ab, Phi_a, Phi_b, Phi_c, Phi_0
    REAL(DP) :: Phi_a0, Phi_b0
    INTEGER,  PARAMETER :: MaxIter = 128
    REAL(DP), PARAMETER :: Tol_ab  = 1.0d-8
    REAL(DP), PARAMETER :: Tol_Phi = 1.0d-8

    a = 0.0_DP
    Phi_a &
      = ThetaFun &
          ( N_K, G1_K, G2_K, G3_K, dN, dG1, dG2, dG3, Tol_G, a )

    Phi_a0 &
      = Phi_a

    b = 1.0_DP
    Phi_b &
      = ThetaFun &
          ( N_K, G1_K, G2_K, G3_K, dN, dG1, dG2, dG3, Tol_G, b )

    Phi_b0 &
      = Phi_b

    Phi_0 = Phi_a
    ab    = b - a

    Converged = .FALSE.
    Iter      = 0
    DO WHILE ( .NOT. Converged )

      Iter = Iter + 1

      ab = 0.5_DP * ab
      c  = a + ab

      Phi_c &
      = ThetaFun &
          ( N_K, G1_K, G2_K, G3_K, dN, dG1, dG2, dG3, Tol_G, c )

      IF( Phi_a * Phi_c < 0.0_DP )THEN

        b     = c
        Phi_b = Phi_c

      ELSE

        a     = c
        Phi_a = Phi_c

      END IF

      IF( ab < Tol_ab .AND. Phi_a / Phi_0 < Tol_Phi ) &
        Converged = .TRUE.

      IF( Iter > MaxIter .AND. .NOT. Converged )THEN
        WRITE(*,*)
        WRITE(*,'(A4,A)') &
          '', 'SolveTheta_Bisection (Moment Equations)'
        WRITE(*,'(A6,A21,I4.4,A11)') &
          '', 'No Convergence After ', Iter, ' Iterations'
        WRITE(*,*)
        WRITE(*,*) '  a, b, ab = ', a, b, ab
        WRITE(*,*) '  Phi_a0, Phi_b0 = ', Phi_a0, Phi_b0
        WRITE(*,*) '  Phi_ai, Phi_bi = ', Phi_a,  Phi_b
        WRITE(*,*) '  N_K, G_K = ', N_K, G1_K, G2_K, G3_K
        WRITE(*,'(A8,ES20.6e3)') 'Tol_G = ', Tol_G
        STOP
      END IF

    END DO

    Theta = a

  END SUBROUTINE SolveTheta_Bisection

  PURE REAL(DP) FUNCTION ThetaFun &
    ( N_K, G1_K, G2_K, G3_K, dN, dG1, dG2, dG3, Tol_G, Theta )

    REAL(DP), INTENT(in) :: N_K, G1_K, G2_K, G3_K
    REAL(DP), INTENT(in) :: dN, dG1, dG2, dG3, Tol_G, Theta

    ThetaFun &
      = N_K+Theta*dN &
        - SQRT( DOT_PRODUCT &
                  ( [G1_K+Theta*dG1,G2_K+Theta*dG2,G3_K+Theta*dG3], &
                    [G1_K+Theta*dG1,G2_K+Theta*dG2,G3_K+Theta*dG3] ) ) &
        - Tol_G

    RETURN
  END FUNCTION ThetaFun

END MODULE MomentEquationsLimiterUtilitiesModule_DG


! simple code for random number sequences
! from numerical recipes..
function ranfb(ix)
  real :: y,ranfb
  integer :: ix,ix1,ix2,ia1,ia2,ic,j1,j2,j3

  ia1=273
  ia2=25301
  ic=226908345

  if (ix.lt.0) ix=-ix
  if (ix.gt.2**30) ix=MOD(ix,2**30)

  ix1=ix/(2**15)
  ix2=ix-ix1*(2**15)
  j1=MOD(ix1*ia2,2**15)*2**15
  j2=MOD(ix2*ia1,2**15)*2**15
  j3=ix2*ia2
  ix=MOD(j1+j2,2**30)
  ix=MOD(ix+j3,2**30)
  ix=MOD(ix+ic,2**30)
  y=FLOAT(ix)

  ranfb=y/2**30

end function

subroutine setRND
  include 'globals.h'
  integer i
  real ranfb
  do i=1,nrndtable
    rndtable(i)=ranfb(rnseed)
  enddo
end subroutine

function pRND(i)
  include 'globals.h'
  real :: pRND
  integer :: i
  pRND=rndtable(mod(i,nrndtable)+1)
end function


      SUBROUTINE tx2ted
c
c                       PROCESS TX2TP
c                       ------- -----
c
c  Document date: 25 August 1989
c
c          Process TX2TP transform data in the time-space domain to
c  the tau-p space using the "HOP" method for slant stacking refraction
c  data" by Henry,Orcutt, and Parker (GRL, Dec 1980).  The problem of
c  slant-stacking seismic records at a number of ranges to synthesize a
c  tau-p curve is posed as a linear inverse problem for fixed frequency.
c  Using an inner product weighted by (k^2 + b^2)*k (where k is
c  wavenumber and b some real positive number), then the representers
c  are bessel functions of k*range, scaled by 1/(k^2 + b^2), and the
c  model is U(k,w) (vert comp only).  The inverse of the Gram matrix
c  can be found analytically as sums and differences of products of
c  modified bessel functions of b*range.
c         Since the tx to tau-p transformation changes the meaning of
c  shots and rps, TX2TP will output the data using the same SEGY
c  headers as input to it so that shots remain shots and rps remain
c  rps, with the same numbers.  If there are more tau-p traces as
c  input t-x traces, the last t-x trace header is used on the extra
c  tau-p traces.
c  The SEGY trace headers will contain the following information:
c  record ("shot") number   (SEGY word 3)
c  trace number with the record  (SEGY word 4)
c  trace id flag (live trace flag)  (SEGY word 15)
c  p value*1000. (in the tx domain position for range)  (SEGY word 10)
c  tau*1000 of the first output sample (delay in ms) (SEGY word 55)
c  tau of the first output sample (delay in seconds) (SEGY word 46)
c  number of data samples (SEGY word 58)
c  sample interval in microseconds (normal SEGY) (SEGY word 59)
c
c      The input data must be order so that the ranges are monotonically
c  increasing.
c
c  Limitations :  300 input time traces
c                1024 samples within a time trace
c                 300 output p traces
c                 400 taus within a p trace
c
c
c  PARAMETER DICTIONARY
c  --------- ----------
c  SET    - The start and end times of the data to transformation.
c           Data prior to the start time or after the end time will be
c           omitted.
c           Preset = the times of the first input trace.  e.g.  set 3 7
c  SEP    - Start and end p values to calculate.  The sep range should
c           only span the dip components of interest (Yilmaz pg 437)
c           Preset = .2 .7  (1/5 1/1.4)   e.g.  sep .05 .55
c  SETAU  - The start and end taus to calculate.  The first output
c           sample will be at the start tau.
c
c  NP     - The number of p values to calculate.  NP is the increment
c           between the start and end p values.
c           Preset = the number of input time traces
c  OHPATH - Output header pathname.  TX2TP saves all of the SEGY trace
c           headers in a disk file so that the output tau-p traces have
c           the save headers as the input.  The disk file is temporary
c           unless OHPATH is given.  This is particularly important if
c           the data is converted back to tx in a separate SIOSEIS run.
c           Preset = temporary file.    e.g.   ohpath txheaders.line1-2
c  FC     - Cutoff frequency for calculating models.
c           Preset = Nyquist frequency      e.g. fc 125
c  PCNTI  - Percent taper applied to the input data before the forward
c           FFT.
c           Preset = 0.
c  PCNTO  - Percent Taper applied to the models before the inverse FFT.
c           Preset = 0.
c  SHIFT  - The time shift to apply to successive traces.  The shift
c           is accumulative, thus each trace is shifted by SHIFT
c           relative to the previous trace.  The shift represents a
c           constant reduction velocity, i.e. start time for each trace
c           must be delayed by same amount relative to previous trace
c           Required.              e.g.  shift .05
c  PRESTK - When set nonzero, the transformation is done whenever the
c           PRESTK number of "gathers" have been collected.  A "gather" is
c           whenever the "end-of-sort" flag (SEGY header word 51) is -1.
c           Processes SORT and GATHER set the "end-of-sort" flag.
c           Other schemes using DISKIN and HEADER can be used also.
c
c  END    - Terminates each parameter list.
c
c
c
c  Copyright (C) by The Regents of The University of California, 1988
c  ALL RIGHTS RESERVED.
c
c  10/6/94 gmk added Warning message regarding spatial aliasing
c  7 Oct 94 - increase number of input and output traces
c  9 Sep 96 - Add prestk
c
      PARAMETER ( npars = 15 )                                          ! the number of user parameters
      CHARACTER*80 token
      CHARACTER*6 names(npars)
      CHARACTER*1 types(npars)                                          ! the type of parameter
      REAL vals(npars)                                                  ! holds the REAL parameter values
      DIMENSION lvals(npars)                                            ! holds the INTEGER parameter values
      COMMON /edits/ ierror, iwarn, irun, now, icompt
      COMMON /tx2tp/ sshift, sep(2), nnp, setau(2), beta, ffc, ppcnti,
     *               ppcnto, iirev, ffon, dummy, iimft, set(2), lprt,
     *               lunhdr, txprestk, ntx2tp
      INTEGER fon, ffon, txprestk, prestk
      EQUIVALENCE ( shift, vals(1) ),
     3            ( np, lvals(3) ),
     5            ( b, vals(5) ),
     6            ( fc, vals(6) ),
     7            ( pcnti, vals(7) ),
     8            ( pcnto, vals(8) ),
     9            ( irev, lvals(9) ),
     *            ( fon, lvals(10) ),
     1            ( prestk, lvals(11) ),
     2            ( imft, lvals(12) ),
     4            ( lprint, lvals(14) )
      DATA names /'SHIFT ','SEP   ','NP    ','SETAU ','B     ',
     *            'FC    ','PCNTI ','PCNTO ','IREV  ','FON   ',
     *            'PRESTK','IMFT  ','SET   ','LPRINT','OHPATH' /
      DATA types /2*'F','L',5*'F',4*'L','F','L','A' /
c****  there's some weird shit with the segy header (ohpath).  The problem
c****  occurs when tp2tx is in the same procs list and tp2tx wants the
c****  headers.  So, my logic(?) is:  contro sets lunhdr = 0. tx2ted
c****  opens the file and sets lunhdr.  tp2ted only opens a header file
c****  if lunhdr = 0 or the user gave ihpath.
c****
c****    Set the parameter presets and various variable presets
c****
      ntx2tp = 0
      shift = 0.
      b = 2.                                                            ! hidden parameter - scaling factor for representers
      sep(1) = .2
      sep(2) = .7
      np = 0
      fc = 0
      pcnti = 0.
      pcnto = 0.
      irev = 0
      fon = 1
      set(1) = -1.
      set(2) = -1.
      lprint = 0
      setau(1) = 99999.
      prestk = 0
c****
c****     get the user's parameters -  there must be something, at least an "end"
c****
      ntokes = 0                                                        ! count the tokens
  100 CONTINUE
      ns = 0
      CALL getoke( token, nchars )                                      ! get a token and it's length
      CALL upcase( token, nchars )                                      ! convert parameter names to upper case
      IF( nchars .EQ. 0 ) THEN                                          ! anything there?
          CALL rdline                                                   ! nope, get another line
          ntokes = 0
          GOTO 100
      ENDIF
  110 ntokes = ntokes + 1
      DO 200 nparam = 1, npars
         IF( token(1:nchars) .EQ. names(nparam) ) THEN                  ! find the parameter name in our list
  120        CALL getoke( token, nchars )                               ! get the value
             IF( nchars .EQ. 0 ) THEN
                 CALL rdline
                 ntokes = 0
                 GOTO 120
             ENDIF
             ntokes = ntokes + 1
             IF( names(nparam) .EQ. 'OHPATH' ) THEN
                 CALL getfil( 3, lunhdr, token, istat )
                 GOTO 100
             ENDIF
             ns = ns + 1
             CALL upcase( token, nchars )
             CALL dcode( token, nchars, areal, istat )                  ! convert the alpha number to an internal machine number
             IF( istat .NE. 2 ) ierror = ierror + 1                     ! was the an error decoding it?
             IF( names(nparam) .EQ. 'SET' ) THEN                        ! set is an array
                 set(ns) = areal
                 IF( ns .EQ. 1 ) GOTO 120
                 GOTO 100
             ENDIF
             IF( names(nparam) .EQ. 'SEP' ) THEN                        ! sep is an array
                 sep(ns) = areal
                 IF( ns .EQ. 1 ) GOTO 120
                 GOTO 100
             ENDIF
             IF( names(nparam) .EQ. 'SETAU' ) THEN                        ! setau is an array
                 setau(ns) = areal
                 IF( ns .EQ. 1 ) GOTO 120
                 GOTO 100
             ENDIF
             IF( types(nparam) .EQ. 'L' ) THEN
                 lvals(nparam) = areal                                  ! convert the real to INTEGER*4
             ELSE
                 vals(nparam) = areal                                   ! move the real to the parameter
             ENDIF
             GOTO 100
         ENDIF
  200 CONTINUE
      IF( token(1:nchars) .NE. 'END') THEN
          PRINT *,' ***  ERROR  ***  No such parameter as ',
     *      token(1:nchars)
          ierror = ierror + 1
          GOTO 100
      ENDIF
c****
c****    Do some ERROR checking
c****
      IF( sep(1)+sep(2) .EQ. 0 ) THEN
          PRINT *,' ***  ERROR  ***  SEP must be given.'
          ierror = ierror + 1
      ENDIF
      IF( np .LT. 0 .OR. (np .GT. 0 .AND. np .LT. 2 ) )THEN
          PRINT *,' ***  ERROR  ***  NP must be greater than 2.'
          ierror = ierror + 1
      ENDIF
      IF (fc .eq. 0 .OR. fc .GT. 30) THEN
          PRINT *,' ***  WARNING  ***  Spatial Aliasing May Occur'
      ENDIF
c****
c****    finish up the parameter reading
c****
 2000 CONTINUE
      CALL getoke( token, nchars )                                       ! get the next token
      CALL upcase( token, nchars )
      ntokes = ntokes + 1
      IF( nchars .LE. 0 ) THEN
          IF( now .EQ. 1 ) PRINT *,' <  ENTER PARAMETERS  >'
          CALL rdline                                                          ! get a new line of parameters
          ntokes = 0
          GOTO 2000
      ENDIF
      IF( token(1:nchars) .NE. 'END' .OR. nchars .NE. 3 ) THEN
          PRINT *,' ***  ERROR  ***  TX2TP can have only one list .'
          ierror = ierror + 1
      ENDIF
      sshift = shift
      nnp = np
      beta = b
      ffc = fc
      ppcnti = pcnti
      ppcnto = pcnto
      iirev = irev
      iimft = imft
      lprt = lprint
      ffon = fon
      txprestk = prestk
      IF( lunhdr .EQ. 0 ) THEN                                            ! if the user didn't give ohpath, get a temporary file
          CALL getfil( 1, lunhdr, token, istat )
      ENDIF
      IF( IAND(lprint,1) .NE. 0 ) THEN
          PRINT *,' sshifts=',sshifts,' sep=',sep,' nnp=',nnp,
     *      ' setau=',setau,' beta=',beta,' ffc=',ffc
          PRINT *,' ppcnti=',ppcnti,' ppcnto=',ppcnto,' iirev=',
     *      iirev,' fon=',ffon,' set=',set(1),set(2),' lunhdr=',lunhdr
          PRINT *,' prestk=',txprestk
      ENDIF
      RETURN
      END


! calculate bulk's energy band using wannier TB method
  subroutine ek_bulk

     use mpi
     use para

     implicit none

     integer :: ik, i, j
	  integer :: knv3
     integer :: ierr
     real(dp) :: emin
     real(dp) :: emax
     real(Dp) :: k(3)
     real(Dp) :: W(Num_wann)

     ! Hamiltonian of bulk system
     complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)

     ! eigen value of H
	  real(dp), allocatable :: eigv(:,:)
	  real(dp), allocatable :: eigv_mpi(:,:)

     knv3= nk3_band
     allocate( eigv    (Num_wann, knv3))
     allocate( eigv_mpi(Num_wann, knv3))
	  eigv    = 0d0
	  eigv_mpi= 0d0

     do ik= 1+cpuid, knv3, num_cpu

	     if (cpuid==0) print *, ik
        k = k3points(:, ik)

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk(k, Hamk_bulk)

        !> diagonalization by call zheev in lapack
        W= 0d0
        call eigensystem_c( 'N', 'U', Num_wann ,Hamk_bulk, W)

        eigv(:, ik)= W

     enddo

     call mpi_allreduce(eigv,eigv_mpi,size(eigv),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)

     if (cpuid==0)then
        open(unit=14, file='bulkek.dat')

        do i=1, Num_wann
           do ik=1, knv3
              write(14, '(1000f19.9)')k3len(ik),eigv_mpi(i, ik)
           enddo
           write(14, *)' '
        enddo
        close(14)
     endif

     !> minimum and maximum value of energy bands
     emin= minval(eigv_mpi)-0.5d0
     emax= maxval(eigv_mpi)+0.5d0

     !> write script for gnuplot
     if (cpuid==0) then
        open(unit=101, file='bulkek.gnu')
        write(101, '(a)') 'set terminal  postscript enhanced color'
        write(101,'(2a)') '#set palette defined ( 0  "green", ', &
           '5 "yellow", 10 "red" )'
        write(101, '(a)')"set output 'bulkek.eps'"
        write(101, '(a)')'set style data linespoints'
        write(101, '(a)')'unset ztics'
        write(101, '(a)')'unset key'
        write(101, '(a)')'set pointsize 0.8'
        write(101, '(a)')'set view 0,0'
        write(101, '(a)')'set xtics font ",24"'
        write(101, '(a)')'set ytics font ",24"'
        write(101, '(a)')'set ylabel font ",24"'
        write(101, '(a)')'set ylabel "Energy (eV)"'
        write(101, '(a, f8.5, a)')'set xrange [0: ', maxval(k3len), ']'
        write(101, '(a, f8.5, a, f8.5, a)')'set yrange [', emin, ':', emax, ']'
        write(101, 202, advance="no") (k3line_name(i), k3line_stop(i), i=1, nk3lines)
        write(101, 203)k3line_name(nk3lines+1), k3line_stop(nk3lines+1)

        do i=1, nk3lines-1
           write(101, 204)k3line_stop(i+1), emin, k3line_stop(i+1), emax
        enddo
        write(101, '(2a)')"plot 'bulkek.dat' u 1:2 ",  &
            "w lp lw 2 pt 7  ps 0.2"
        close(101)
     endif

     202 format('set xtics (',:20('"',A3,'" ',F8.5,','))
     203 format(A3,'" ',F8.5,')')
     204 format('set arrow from ',F8.5,',',F10.5,' to ',F8.5,',',F10.5, ' nohead')

   return
   end subroutine ek_bulk


c     # ----------------------------------------------------------
c     # Interpolation routines - (i,j,mq) ordering
c     # ----------------------------------------------------------
c     # interpolate_face_ghost
c     # interpolate_corner_ghost
c     # interpolate_to_fine_patch
c     #
c     # Other routines :
c     # compute_slopes (for limited function reconstruction)
c     # fixcapaq (to preserve conservation)
c     #
c     # Note that fixcapaq is only used when regridding;  ghost
c     # cell interpolation is not conservative in the mapped case.
c     # (Should it be?  We are going to correct the flux mixmatch
c     # anyhow, so maybe the accuracy of the ghost cell values is
c     # more important.)
c     # ----------------------------------------------------------

c     # ----------------------------------------------------------
c     # This routine is used for both mapped and non-mapped
c     # cases.
c     # ----------------------------------------------------------
      subroutine user_fort_interpolate_face
     &      (mx,my,mbc,meqn,
     &      qcoarse,qfine,
     &      idir,iface_coarse,num_neighbors,refratio,igrid,
     &      transform_ptr)
      implicit none
      integer mx,my,mbc,meqn,refratio,igrid,idir,iface_coarse
      integer num_neighbors
      integer*8 transform_ptr
      double precision qfine(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision qcoarse(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      integer mq,r2, m
      integer i, ic1, ic2, ibc, ifine,i1
      integer j, jc1, jc2, jbc, jfine,j1
      integer ic_add, jc_add, ic, jc, mth
      double precision gradx, grady, qc, sl, sr, value
      double precision compute_slopes

c     # This should be refratio*refratio.
      integer rr2
      parameter(rr2 = 4)
      integer i2(0:rr2-1),j2(0:rr2-1)
      logical is_valid_interp
      logical skip_this_grid

      integer a(2,2)
      integer ii,jj,dc(2),df(2,0:rr2-1),iff,jff
      double precision shiftx(0:rr2-1),shifty(0:rr2-1)

      mth = 5
      r2 = refratio*refratio
      if (r2 .ne. rr2) then
         write(6,*) 'average_face_ghost (claw2d_utils.f) ',
     &         '  Refratio**2 is not equal to rr2'
         stop
      endif

      call build_transform(transform_ptr,a)

c     # This needs to be written for refratios .ne. 2.
      m = 0
      do jj = 0,1
         do ii = 0,1
c           # Direction on coarse grid
            dc(1) = ii
            dc(2) = jj

c           # Direction on fine grid (converted using metric). Divide
c           # by refratio to scale length to unit vector
            df(1,m) = (a(1,1)*dc(1) + a(1,2)*dc(2))/refratio
            df(2,m) = (a(2,1)*dc(1) + a(2,2)*dc(2))/refratio

c           # Map (0,1) to (-1/4,1/4) (locations of fine grid points)
            shiftx(m) = (ii-0.5d0)/2.d0
            shifty(m) = (jj-0.5d0)/2.d0
            m = m + 1
         enddo
      enddo
c     # Create map :

      do mq = 1,meqn
         if (idir .eq. 0) then
c           # this ensures that we get 'hanging' corners

            if (iface_coarse .eq. 0) then
               ic = 1
            elseif (iface_coarse .eq. 1) then
               ic = mx
            endif
            do jc = 1,mx
               i1 = ic
               j1 = jc
               call fclaw2d_transform_face_half(i1,j1,i2,j2,
     &               transform_ptr)
               skip_this_grid = .false.
               do m = 0,r2-1
                  if (.not. is_valid_interp(i2(m),j2(m),mx,my,mbc))
     &                  then
                     skip_this_grid = .true.
                     exit
                  endif
               enddo
               if (.not. skip_this_grid) then
                  qc = qcoarse(ic,jc,mq)
c                 # Compute limited slopes in both x and y. Note we are not
c                 # really computing slopes, but rather just differences.
c                 # Scaling is accounted for in 'shiftx' and 'shifty', below.
                  sl = (qc - qcoarse(ic-1,jc,mq))
                  sr = (qcoarse(ic+1,jc,mq) - qc)
                  gradx = compute_slopes(sl,sr,mth)

                  sl = (qc - qcoarse(ic,jc-1,mq))
                  sr = (qcoarse(ic,jc+1,mq) - qc)
                  grady = compute_slopes(sl,sr,mth)

                  do m = 0,rr2-1
                     iff = i2(0) + df(1,m)
                     jff = j2(0) + df(2,m)
                     value = qc + gradx*shiftx(m) + grady*shifty(m)
                     qfine(iff,jff,mq) = value
                  enddo
               endif
            enddo
         else
            if (iface_coarse .eq. 2) then
               jc = 1
            elseif (iface_coarse .eq. 3) then
               jc = my
            endif
            do ic = 1,mx
    1          i1 = ic
               j1 = jc
               call fclaw2d_transform_face_half(i1,j1,i2,j2,
     &               transform_ptr)
c              # ---------------------------------------------
c              # Two 'half-size' neighbors will be passed into
c              # this routine.  Only half of the coarse grid ghost
c              # indices will be valid for the particular grid
c              # passed in.  We skip those ghost cells that will
c              # have to be filled in by the other half-size
c              # grid.
c              # ---------------------------------------------
               skip_this_grid = .false.
               do m = 0,r2-1
                  if (.not. is_valid_interp(i2(m),j2(m),mx,my,mbc))
     &                  then
                     skip_this_grid = .true.
                     exit
                  endif
               enddo
               if (.not. skip_this_grid) then
                  qc = qcoarse(ic,jc,mq)

                  sl = (qc - qcoarse(ic-1,jc,mq))
                  sr = (qcoarse(ic+1,jc,mq) - qc)
                  gradx = compute_slopes(sl,sr,mth)

                  sl = (qc - qcoarse(ic,jc-1,mq))
                  sr = (qcoarse(ic,jc+1,mq) - qc)
                  grady = compute_slopes(sl,sr,mth)

                  do m = 0,rr2-1
                     iff = i2(0) + df(1,m)
                     jff = j2(0) + df(2,m)
                     value = qc + gradx*shiftx(m) + grady*shifty(m)
                     qfine(iff,jff,mq) = value
                  enddo

               endif                    !! Don't skip this grid
            enddo                       !! i loop
         endif                          !! end idir branch
      enddo                             !! endo mq loop

      end

      subroutine user_fort_interpolate_corner
     &      (mx,my,mbc,meqn,
     &      refratio,
     &      qcoarse,qfine,icorner_coarse,transform_ptr)
      implicit none

      integer mx,my,mbc,meqn,icorner_coarse,refratio
      integer*8 transform_ptr
      double precision qcoarse(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision qfine(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      integer ic, jc, mq, ibc,jbc, mth,i,j
      double precision qc, sl, sr, gradx, grady
      double precision compute_slopes, value

c     # This should be refratio*refratio.
      integer i1,j1,m, r2
      integer rr2
      parameter(rr2 = 4)
      integer i2(0:rr2-1),j2(0:rr2-1)

      integer a(2,2)
      integer ii,jj,iff,jff,dc(2),df(2,0:rr2-1)
      double precision shiftx(0:rr2-1), shifty(0:rr2-1)
      logical check_indices

      r2 = refratio*refratio
      if (r2 .ne. rr2) then
         write(6,*) 'average_corner_ghost (claw2d_utils.f) ',
     &         '  Refratio**2 is not equal to rr2'
         stop
      endif

      call build_transform(transform_ptr,a)

      m = 0
      do jj = 0,1
         do ii = 0,1
c           # Direction on coarse grid
            dc(1) = ii
            dc(2) = jj

c           # Direction on fine grid (converted using metric). Divide
c           # by 2 (refratio) to scale length to unit vector
            df(1,m) = (a(1,1)*dc(1) + a(1,2)*dc(2))/2
            df(2,m) = (a(2,1)*dc(1) + a(2,2)*dc(2))/2

c           # Map (0,1) to (-1/4,1/4) (locations of fine grid points)
            shiftx(m) = (ii-0.5d0)/2.d0
            shifty(m) = (jj-0.5d0)/2.d0
            m = m + 1
         enddo
      enddo

      mth = 5

      if (icorner_coarse .eq. 0) then
         ic = 1
         jc = 1
      elseif (icorner_coarse .eq. 1) then
         ic = mx
         jc = 1
      elseif (icorner_coarse .eq. 2) then
         ic = 1
         jc = my
      elseif (icorner_coarse .eq. 3) then
         ic = mx
         jc = my
      endif

c     # Interpolate coarse grid corners to fine grid corner ghost cells
      i1 = ic
      j1 = jc
      call fclaw2d_transform_corner_half(i1,j1,i2,j2,
     &      transform_ptr)

      do mq = 1,meqn
         qc = qcoarse(ic,jc,mq)

c        # Compute limited slopes in both x and y. Note we are not
c        # really computing slopes, but rather just differences.
c        # Scaling is accounted for in 'shiftx' and 'shifty', below.
         sl = (qc - qcoarse(ic-1,jc,mq))
         sr = (qcoarse(ic+1,jc,mq) - qc)
         gradx = compute_slopes(sl,sr,mth)

         sl = (qc - qcoarse(ic,jc-1,mq))
         sr = (qcoarse(ic,jc+1,mq) - qc)
         grady = compute_slopes(sl,sr,mth)

         do m = 0,rr2-1
            iff = i2(0) + df(1,m)
            jff = j2(0) + df(2,m)
            value = qc + gradx*shiftx(m) + grady*shifty(m)
            qfine(iff,jff,mq) = value
         enddo

      enddo

      end

c     # Conservative intepolation to fine grid patch
      subroutine user_fort_interpolate2fine
     &     (mx,my,mbc,meqn,
     &      qcoarse, qfine, areacoarse, areafine, igrid, manifold)
      implicit none

      integer mx,my,mbc,meqn
      integer igrid, manifold

      double precision qcoarse(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision qfine(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      double precision areacoarse(-mbc:mx+mbc+1,-mbc:my+mbc+1)
      double precision   areafine(-mbc:mx+mbc+1,-mbc:my+mbc+1)

      integer ii, jj, i,j, i1, i2, j1, j2, ig, jg, mq, mth
      integer ic,jc,ic_add, jc_add
      double precision qc, shiftx, shifty, sl, sr, gradx, grady
      double precision compute_slopes

      integer p4est_refineFactor,refratio

      p4est_refineFactor = 2
      refratio = 2

c     # Use limiting done in AMRClaw.
      mth = 5

c     # Get (ig,jg) for grid from linear (igrid) coordinates
      ig = mod(igrid,refratio)
      jg = (igrid-ig)/refratio

      i1 = 1-ig
      i2 = mx/p4est_refineFactor + (1-ig)
      ic_add = ig*mx/p4est_refineFactor

      j1 = 1-jg
      j2 = my/p4est_refineFactor + (1-jg)
      jc_add = jg*my/p4est_refineFactor

      do mq = 1,meqn
         do i = i1,i2
            do j = j1,j2
               ic = i + ic_add
               jc = j + jc_add
               qc = qcoarse(ic,jc,mq)

c              # Compute limited slopes in both x and y. Note we are not
c              # really computing slopes, but rather just differences.
c              # Scaling is accounted for in 'shiftx' and 'shifty', below.
               sl = (qc - qcoarse(ic-1,jc,mq))
               sr = (qcoarse(ic+1,jc,mq) - qc)
               gradx = compute_slopes(sl,sr,mth)

               sl = (qc - qcoarse(ic,jc-1,mq))
               sr = (qcoarse(ic,jc+1,mq) - qc)
               grady = compute_slopes(sl,sr,mth)

c              # Fill in refined values on coarse grid cell (ic,jc)
               do ii = 1,refratio
                  do jj = 1,refratio
                     shiftx = (ii - refratio/2.d0 - 0.5d0)/refratio
                     shifty = (jj - refratio/2.d0 - 0.5d0)/refratio
                     qfine((i-1)*refratio + ii,(j-1)*refratio + jj,mq)
     &                     = qc + shiftx*gradx + shifty*grady
                  enddo
               enddo
            enddo
         enddo
      enddo

      if (manifold .ne. 0) then
         call fc2d_clawpack46_fort_fixcapaq2(mx,my,mbc,meqn,
     &         qcoarse,qfine, areacoarse,areafine,igrid)
      endif

      end

c     # ------------------------------------------------------
c     # So far, this is only used by the interpolation from
c     # coarse to fine when regridding.  But maybe it should
c     # be used by the ghost cell routines as well?
c     # ------------------------------------------------------
      subroutine user_fort_fixcapaq2(mx,my,mbc,meqn,
     &      qcoarse,qfine, areacoarse,areafine,igrid)
      implicit none

      integer mx,my,mbc,meqn, refratio, igrid
      integer p4est_refineFactor

      double precision qcoarse(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision qfine(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision areacoarse(-mbc:mx+mbc+1,-mbc:my+mbc+1)
      double precision   areafine(-mbc:mx+mbc+1,-mbc:my+mbc+1)

      integer i,j,ii, jj, ifine, jfine, m, ig, jg, ic_add, jc_add
      double precision kf, kc, r2, sum, cons_diff, qf, qc

      p4est_refineFactor = 2
      refratio = 2

c     # Get (ig,jg) for grid from linear (igrid) coordinates
      ig = mod(igrid,refratio)
      jg = (igrid-ig)/refratio

c     # Get rectangle in coarse grid for fine grid.
      ic_add = ig*mx/p4est_refineFactor
      jc_add = jg*my/p4est_refineFactor

c     # ------------------------------------------------------
c     # This routine ensures that the interpolated solution
c     # has the same mass as the coarse grid solution
c     # -------------------------------------------------------

      r2 = refratio*refratio
      do m = 1,meqn
         do i = 1,mx/p4est_refineFactor
            do j = 1,my/p4est_refineFactor
               sum = 0.d0
               do ii = 1,refratio
                  do jj = 1,refratio
                     ifine = (i-1)*refratio + ii
                     jfine = (j-1)*refratio + jj
                     kf = areafine(ifine,jfine)
                     qf = qfine(ifine,jfine,m)
                     sum = sum + kf*qf
                  enddo
               enddo

               kc = areacoarse(i+ic_add,j+jc_add)
               qc = qcoarse(i+ic_add, j+jc_add,m)
               cons_diff = (qc*kc - sum)/r2

               do ii = 1,refratio
                  do jj = 1,refratio
                     ifine  = (i-1)*refratio + ii
                     jfine  = (j-1)*refratio + jj
                     kf = areafine(ifine,jfine)
                     qfine(ifine,jfine,m) = qfine(ifine,jfine,m) +
     &                     cons_diff/kf
                  enddo
               enddo
            enddo  !! end of meqn
         enddo
      enddo

      end


************************************************************************
*    Author: J. Campbell, January 2014                                 *
*                                                                      *
*    Virtual amplitude for the tri-photon process                      *
*    q(i1)^- + qb(i2)^+ + gamma(i3)^+ + gamma(i4)^+ + gamma(i5)^-      *
*                                                                      *
*    Adapted from the original routine of C. Williams, March 2013      *
*                                                                      *
************************************************************************
      double complex function virt_trigam(i1,i2,i3,i4,i5,za,zb)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      include 'epinv.f'
      include 'epinv2.f'
      include 'scale.f'
      integer i1,i2,i3,i4,i5
      double complex Vcc,Fcc,A5LO,zab,zab2,trigam
      double complex Vpole,Alo,Lsm1,L0,L1,lnrat,l12,l25

c--- statement functions
      zab(i1,i2,i3)=+za(i1,i2)*zb(i2,i3)
      zab2(i1,i2,i3,i4)=zab(i1,i2,i4)+zab(i1,i3,i4)

      l12=lnrat(musq,-s(i1,i2))
      l25=lnrat(musq,-s(i2,i5))
      Alo=trigam(i1,i2,i3,i4,i5,za,zb)

      Vpole=-(epinv**2+epinv*l12+0.5d0*l12**2)
     &     -(3d0/2d0*(epinv+l25+2d0))

      virt_trigam=
     & +Vpole*Alo

     & +(za(i1,i3)**3*za(i2,i4)*za(i4,i5)**2
     &  -za(i1,i4)**3*za(i2,i3)*za(i3,i5)**2)
     &  /(za(i1,i3)*za(i1,i4)*za(i2,i3)*za(i2,i4)*za(i3,i4)**3)
     &  *Lsm1(-s(i3,i5),-s(i1,i2),-s(i4,i5),-s(i1,i2))
     & -(za(i1,i2)*za(i4,i5))**2/(za(i1,i3)*za(i2,i4)**3*za(i3,i4))
     &  *Lsm1(-s(i4,i5),-s(i1,i3),-s(i2,i5),-s(i1,i3))
     & +(za(i1,i2)*za(i3,i5))**2/(za(i1,i4)*za(i2,i3)**3*za(i3,i4))
     &  *Lsm1(-s(i3,i5),-s(i1,i4),-s(i2,i5),-s(i1,i4))
     & +za(i1,i5)**2/(za(i1,i4)*za(i2,i3)*za(i3,i4))
     &  *Lsm1(-s(i4,i5),-s(i2,i3),-s(i1,i5),-s(i2,i3))
     & -za(i1,i5)**2/(za(i1,i3)*za(i2,i4)*za(i3,i4))
     &  *Lsm1(-s(i3,i5),-s(i2,i4),-s(i1,i5),-s(i2,i4))
     & -(za(i1,i2)*za(i3,i5))**2
     &  /(za(i1,i3)*za(i2,i3)**2*za(i2,i4)*za(i3,i4))
     &  *Lsm1(-s(i1,i3),-s(i4,i5),-s(i1,i2),-s(i4,i5))
     & +(za(i1,i2)*za(i4,i5))**2
     &  /(za(i1,i4)*za(i2,i4)**2*za(i2,i3)*za(i3,i4))
     &  *Lsm1(-s(i1,i4),-s(i3,i5),-s(i1,i2),-s(i3,i5))
     & -za(i1,i5)**2/(za(i2,i4)*za(i1,i3)*za(i3,i4))
     &  *Lsm1(-s(i1,i2),-s(i3,i5),-s(i2,i4),-s(i3,i5))
     & +za(i1,i5)**2/(za(i2,i3)*za(i1,i4)*za(i3,i4))
     &  *Lsm1(-s(i1,i2),-s(i4,i5),-s(i2,i3),-s(i4,i5))

     & -za(i1,i2)*za(i2,i5)**2*zb(i3,i2)/(za(i2,i3)*za(i2,i4)**2)
     &  *L0(-s(i1,i3),-s(i4,i5))/s(i4,i5)
     & -za(i1,i2)*za(i2,i5)**2*zb(i4,i2)/(za(i2,i4)*za(i2,i3)**2)
     &  *L0(-s(i1,i4),-s(i3,i5))/s(i3,i5)
     & +za(i1,i2)*za(i4,i5)**2*zb(i4,i3)/(za(i2,i4)**2*za(i3,i4))
     &  *L0(-s(i1,i3),-s(i2,i5))/s(i2,i5)
     & +za(i1,i3)*za(i4,i5)**2*zb(i4,i3)**2/(2d0*za(i2,i4)*za(i3,i4))
     &  *L1(-s(i1,i3),-s(i2,i5))/s(i2,i5)**2
     & +za(i1,i2)*za(i3,i5)**2*zb(i4,i3)/(za(i2,i3)**2*za(i3,i4))
     &  *L0(-s(i1,i4),-s(i2,i5))/s(i2,i5)
     & -za(i1,i4)*za(i3,i5)**2*zb(i4,i3)**2/(2d0*za(i2,i3)*za(i3,i4))
     &  *L1(-s(i1,i4),-s(i2,i5))/s(i2,i5)**2
     & -za(i1,i2)*za(i1,i5)*za(i2,i5)/(za(i1,i3)*za(i2,i3)*za(i2,i4)**2)
     &  *lnrat(-s(i4,i5),-s(i2,i5))
     & -za(i1,i2)*za(i1,i5)*za(i2,i5)/(za(i1,i4)*za(i2,i4)*za(i2,i3)**2)
     &  *lnrat(-s(i3,i5),-s(i2,i5))

     & +0.5d0*zb(i3,i4)/zb(i2,i5)*(za(i1,i5)/(za(i2,i5)*za(i3,i4))
     &   *(za(i3,i5)/za(i2,i3)+za(i4,i5)/za(i2,i4))
     &  +(zb(i2,i3)/za(i2,i4)-zb(i2,i4)/za(i2,i3))/zb(i1,i5))

c      write(6,*) 'virt_trigam,virt_trigam/Alo         ',
c     & virt_trigam,virt_trigam/Alo

      return
      end


*deck aratio_tet
      subroutine aratio_tet(xl1,yl1,zl1,
     *                      xl2,yl2,zl2,
     *                      xl3,yl3,zl3,
     *                      xl4,yl4,zl4,
     *                      arattet,epsilon_notused)
C
C
C #####################################################################
C
C     PURPOSE -
C
C        Finds the aspect ratio of a tet.
C
C     INPUT ARGUMENTS -
C
C        (x1,y1,z1),...,(x4,y4,z4) - The coordinates of the tet.
C        epsilon_notused                   - result if calculation is singular.
C
C     OUTPUT ARGUMENTS -
C
C        arattet : The aspect ratio of the tet.
C
C     CHANGE HISTORY -
C
C $Log: aratio_tet.f,v $
C Revision 2.00  2007/11/05 19:45:46  spchu
C Import to CVS
C
CPVCS
CPVCS       Rev 1.2   Fri Jan 08 16:59:12 1999   kuprat
CPVCS    We now prevent zero divides using SAFE.
CPVCS
CPVCS       Rev 1.1   Wed Dec 23 11:50:24 1998   kuprat
CPVCS    We now properly handle singular tets.
CPVCS
CPVCS       Rev 1.0   Fri Aug 29 14:11:32 1997   dcg
CPVCS    Initial revision.
C
C ######################################################################
C
C
      implicit none
C
      include "consts.h"
      include "local_element.h"
C
C      character*132 logmess
C      integer icscode

      real*8 xl1,yl1,zl1,xl2,yl2,zl2,xl3,yl3,zl3,xl4,yl4,zl4
      real*8 arattet
      real*8 xb,yb,zb,xc,yc,zc,xd,yd,zd,xn,yn,zn,x2,y2,z2,q,
     * xa,ya,za,dvor,qvor2,rcir
      real*8 ac1,bc1,cc1,dc1,ac2,bc2,cc2,dc2,ac3,bc3,cc3,dc3,
     *   ac4,bc4,cc4,dc4,dn1,dn2,dn3,dn4
      real*8 a11,a12,a13,d1,a21,a22,a23,a31,a32,a33,d3,d2
      real*8 qdet,rx,ry,rz,rinsc

      real*8 epsilon_notused
      real*8 a,d
      real*8 x1,x3,y1,y3,z1,z3

C  MACROS.
C
      include "statementfunctions.h"
      a(x1,x2,x3,y1,y2,y3) = x1*(y2-y3) - y1*(x2-x3) + x2*y3 - y2*x3
      d(x1,x2,x3,y1,y2,y3,z1,z2,z3) = y1*(x2*z3 - z2*x3)
     &         - x1*(y2*z3 - z2*y3) - z1*(x2*y3 - y2*x3)
C
C ######################################################################
C
C
C  Calculation of "rcir", the radius of the
C  circumscribed sphere of the tet.
C
      xb = xl3 - xl2
      yb = yl3 - yl2
      zb = zl3 - zl2
      xc = xl4 - xl2
      yc = yl4 - yl2
      zc = zl4 - zl2
      xd = xl1 - xl2
      yd = yl1 - yl2
      zd = zl1 - zl2
      xn =   yb*zc - yc*zb
      yn = -(xb*zc - xc*zb)
      zn =   xb*yc - xc*yb
      x2 =   yn*zb - yb*zn
      y2 = -(xn*zb - xb*zn)
      z2 =   xn*yb - xb*yn
      q = -0.5*(xc*xb+yc*yb+zc*zb-xc*xc-yc*yc-zc*zc)/
     *          safe(x2*xc+y2*yc+z2*zc)
      xa = q*x2 + 0.5*xb
      ya = q*y2 + 0.5*yb
      za = q*z2 + 0.5*zb
      dvor = -0.5*(xd*xd + yd*yd + zd*zd)
      qvor2 = -(xd*xa+yd*ya+zd*za+dvor)/
     *         safe(xd*xn+yd*yn+zd*zn)

      rcir = sqrt( (qvor2*xn + xa)**2
     *           + (qvor2*yn + ya)**2
     *           + (qvor2*zn + za)**2 )
C
C  Calculation of "rinsc", the radius of the inscribed
C  sphere of the tet.
C
      ac1 = a(yl2,yl4,yl3,zl2,zl4,zl3)
      bc1 = a(zl2,zl4,zl3,xl2,xl4,xl3)
      cc1 = a(xl2,xl4,xl3,yl2,yl4,yl3)
      dc1 = d(xl2,xl4,xl3,yl2,yl4,yl3,zl2,zl4,zl3)
      ac2 = a(yl1,yl4,yl2,zl1,zl4,zl2)
      bc2 = a(zl1,zl4,zl2,xl1,xl4,xl2)
      cc2 = a(xl1,xl4,xl2,yl1,yl4,yl2)
      dc2 = d(xl1,xl4,xl2,yl1,yl4,yl2,zl1,zl4,zl2)
      ac3 = a(yl1,yl2,yl3,zl1,zl2,zl3)
      bc3 = a(zl1,zl2,zl3,xl1,xl2,xl3)
      cc3 = a(xl1,xl2,xl3,yl1,yl2,yl3)
      dc3 = d(xl1,xl2,xl3,yl1,yl2,yl3,zl1,zl2,zl3)
      ac4 = a(yl1,yl3,yl4,zl1,zl3,zl4)
      bc4 = a(zl1,zl3,zl4,xl1,xl3,xl4)
      cc4 = a(xl1,xl3,xl4,yl1,yl3,yl4)
      dc4 = d(xl1,xl3,xl4,yl1,yl3,yl4,zl1,zl3,zl4)
      dn1 = sqrt(ac1**2 + bc1**2 + cc1**2)
      dn2 = sqrt(ac2**2 + bc2**2 + cc2**2)
      dn3 = sqrt(ac3**2 + bc3**2 + cc3**2)
      dn4 = sqrt(ac4**2 + bc4**2 + cc4**2)

      ac1 = ac1/safe(dn1)
      bc1 = bc1/safe(dn1)
      cc1 = cc1/safe(dn1)
      dc1 = dc1/safe(dn1)
      ac2 = ac2/safe(dn2)
      bc2 = bc2/safe(dn2)
      cc2 = cc2/safe(dn2)
      dc2 = dc2/safe(dn2)
      ac3 = ac3/safe(dn3)
      bc3 = bc3/safe(dn3)
      cc3 = cc3/safe(dn3)
      dc3 = dc3/safe(dn3)
      ac4 = ac4/safe(dn4)
      bc4 = bc4/safe(dn4)
      cc4 = cc4/safe(dn4)
      dc4 = dc4/safe(dn4)

      a11 = ac1 - ac2
      a12 = bc1 - bc2
      a13 = cc1 - cc2
      d1  = dc2 - dc1
      a21 = ac1 - ac3
      a22 = bc1 - bc3
      a23 = cc1 - cc3
      d2  = dc3 - dc1
      a31 = ac1 - ac4
      a32 = bc1 - bc4
      a33 = cc1 - cc4
      d3  = dc4 - dc1

      qdet = (a12*a23 - a13*a22)*a31
     *     + (a13*a21 - a11*a23)*a32
     *     + (a11*a22 - a12*a21)*a33

      rx = ( (a22*a33 - a23*a32)*d1
     *   +   (a13*a32 - a12*a33)*d2
     *   +   (a12*a23 - a13*a22)*d3 )/safe(qdet)

      ry = ( (a23*a31 - a21*a33)*d1
     *   +   (a11*a33 - a13*a31)*d2
     *   +   (a13*a21 - a11*a23)*d3 )/safe(qdet)

      rz = ( (a21*a32 - a22*a31)*d1
     *     + (a12*a31 - a11*a32)*d2
     *     + (a11*a22 - a12*a21)*d3 )/safe(qdet)

      rinsc =  ac1*rx + bc1*ry + cc1*rz + dc1

      arattet = dabs(3.d0*rinsc/safe(rcir))

c$$$      if (.not.(arattet.ge.epsilon_notused.and.arattet.le.1.d50)) then
c$$$         arattet=epsilon_notused
c$$$      endif

      return
      end


      SUBROUTINE CLIN EQ
     &          (a,b,x,n,n dim,iflag,err)

c***********************************************************************
c                         subroutine clineq
c***********************************************************************

c  Program Source:  Naval Ocean Systems Center - Code 542

c  Date:
c     05 Apr 1990

c  Function:
c     Solves simultaneous linear equations of the form:
c         A*X=L*U*X=B
c     for COMPLEX*16 variables

c     Uses L-U decomposition to find the triangular matrices L and U
c     such that L*U=A.  The matrices L and U are stored in A. This form
c     is used with back substitution to find the solution X of:
c         A*X=L*U*X=B.

c  Parameters passed:
c     a                [c,nxn] matrix A
c     b                [c,n]   matrix B
c     n                [i]     number of elements in the matrices
c     n dim            [i]     dimension of the matrices in the calling
c                              routine
c     iflag            [i]  =0 indicates that the matrix A has not been
c                              decomposed into L and U; after it has
c                              been decomposed, it is replaced by the
c                              matrices L and U;
c                           =1 indicates that the matrix A has already
c                              been decomposed into L and U

c  Parameters returned:
c     x                [c,n]   matrix X; the solution vector
c     err              [r]     relative error of the solution vector

c  Common blocks referenced:

c  Functions and subroutines referenced:
c     cdabs

c  References:

c  Change History:

c*******************!***************************************************

      implicit      real*8 (a-h,o-z)

      parameter    (max dim=51)

      complex *  16 a(n dim,n dim),b(n dim),x(n dim),t

      dimension     irow(max dim), q(max dim)

      character*200 error_msg

      if (n .gt. max dim) then
         write(error_msg,
     &       '(''[CLIN EQ]: '',
     &         ''matrix size greater than '',i2)') max dim
         call LWPC_ERROR ('ERROR',error_msg)
      end if

      if (n .eq. 1) then
         x(1)=b(1)/a(1,1)
         RETURN
      end if

      if (iflag .eq. 0) then
         do i=1,n
            q(i)=0.d0
            do j=1,n
               qq=CDABS(a(i,j))
               if (q(i) .lt. qq)  q(i)=qq
            end do
            if (q(i) .eq. 0.d0) then
               loop=40
               write(error_msg,
     &             '(''[CLIN EQ]: '',
     &               ''matrix is singular at loop '',i3)') loop
               call LWPC_ERROR ('ERROR',error_msg)
            end if
         end do
         err=1.d-15
         ppiv=0.d0
         do i=1,n
            irow(i)=i
         end do

         do l=1,n
            pivot=0.d0
            k=l-1
            do i=l,n
               if (k .ge. 1) then
                  do j=1,k
                     a(i,l)=a(i,l)-a(j,l)*a(i,j)
                  end do
               end if
               f=CDABS(a(i,l))/q(i)
               if (pivot .le. f) then
                  pivot=f
                  npivot=i
               end if
            end do
            if (pivot .eq. 0.d0) then
               loop=240
               write(error_msg,
     &             '(''[CLIN EQ]: '',
     &               ''matrix is singular at loop '',i3)') loop
               call LWPC_ERROR ('ERROR',error_msg)
            end if
            if (ppiv .gt. pivot) err=err*ppiv/pivot
            ppiv=pivot
            if (npivot .ne. l) then
               q(npivot)=q(l)
               j=irow(l)
               irow(l)=irow(npivot)
               irow(npivot)=j
               do i=1,n
                  t=a(l,i)
                  a(l,i)=a(npivot,i)
                  a(npivot,i)=t
               end do
            end if
            if (l .ne. n) then
               t=1.d0/a(l,l)
               k=l+1
               m=l-1
               do i=k,n
                  if (m .ge. 1) then
                     do j=1,m
                        a(l,i)=a(l,i)-a(l,j)*a(j,i)
                     end do
                  end if
                  a(l,i)=t*a(l,i)
               end do
            end if
         end do
         if (err .gt. 1.d-5)then
            write(error_msg,
     &          '(''[CLIN EQ]: '',
     &            ''Has decomposed an ill-conditioned matrix. '',
     &            ''The relative error is '',1pe12.2)') err
               call LWPC_ERROR ('WARNING',error_msg)
          endif
      end if

      do i=2,n
         x(i)=0.d0
      end do
      j=irow(1)
      x(1)=b(j)/a(1,1)
      do i=2,n
         j=irow(i)
         k=i-1
         do l=1,k
            x(i)=x(i)+a(i,l)*x(l)
         end do
         x(i)=(b(j)-x(i))/a(i,i)
      end do
      k=n-1
      do i=1,k
         j=n-i
         m=j+1
         do l=m,n
            x(j)=x(j)-x(l)*a(j,l)
         end do
      end do

      RETURN
      END      ! CLIN EQ


      double precision function hzgamwidth(mh)
      implicit none
      include 'constants.f'
      include 'masses.f'
      include 'ewcouple.f'
      double precision mh,mhsq
      double complex f0DDHK

      mhsq=mh**2

      hzgamwidth=esq*Gf**2*wmass**2*xw/256d0/pi**5
     & *mh**3*(1d0-zmass**2/mhsq)**3*abs(f0DDHK(mhsq,zmass**2))**2

      return
      end


      subroutine taukap
c******************************************************************************
c     This routine calculates the line absorption coefficient and the line
c     opacity at wavelength *wave* for all lines in the spectrum
c******************************************************************************

      implicit real*8 (a-h,o-z)
      include 'Atmos.com'
      include 'Linex.com'
      include 'Dummy.com'

c*****compute the total line opacity at each depth
      do i=1,ntau
         kapnu(i) = 0.0
         do j=lim1,lim2
            v = 2.997929d10*dabs(wave-wave1(j))/
     .             (wave1(j)*dopp(j,i))
            kapnu(i) = kapnu(i) + kapnu0(j,i)*voigt(a(j,i),v)
         enddo

         dummy1(i) = tauref(i)*kapnu(i)/(0.4343*kapref(i))

c*****do the same for the strong lines
         if (dostrong .gt. 0) then
            do j=nlines+1,nlines+nstrong
               v = 2.997929d10*dabs(wave-wave1(j))/
     .             (wave1(j)*dopp(j,i))
               kapnu(i) = kapnu(i) + kapnu0(j,i)*voigt(a(j,i),v)
            enddo
         endif

         dummy1(i) = tauref(i)*kapnu(i)/(0.4343*kapref(i))
      enddo

c*****compute the optical depths
      first = tauref(1)*kapnu(1)/kapref(1)
      dummy1(1) = rinteg(xref,dummy1,taunu,ntau,0.)
      taunu(1) = first
      do i=2,ntau
         taunu(i) = taunu(i-1) + taunu(i)
      enddo

      return
      end


      SUBROUTINE DRKAPM (ARG,INDX,RESLT)
C
C     THIS SUBROUTINE COMPUTES THE DERVIATIVE OF KAPPA MINUS
C
      COMPLEX         AI,ARG,RESLT,BSYCON,C1,C2,C2TEST,AT2,AT3,ALP0,
     1                ALP,ALN
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /SYSTEM/ SYSBUF,IBBOUT
      COMMON /BLK1  / SCRK,SPS,SNS,DSTR,AI,PI,DEL,SIGMA,BETA,RES
      COMMON /BLK2  / BSYCON
C
      PI2  = 2.0*PI
      A1   = PI2/(SPS-SNS)
      A2   =-A1
      GAM0 = SPS*DEL - SIGMA
      B1   = GAM0/(SPS-SNS)
      C1   = CEXP(-AI*ARG/2.0*(SPS-SNS))
      C2Q  = GAM0/DSTR - SCRK
      C3Q  = GAM0/DSTR + SCRK
      S1   = SPS/(DSTR**2)
      S2   = SNS/DSTR
      NN   = 0
      CSEC = C2Q*C3Q
      IF (CSEC .LT. 0.0) NN = 1
      T1   = GAM0*S1
      T2   = S2*SQRT(ABS(CSEC))
      IF (C2Q.LT.0.0 .AND. C3Q.LT.0.0) T2 =-T2
      IF (NN .EQ. 0) ALP0 = T1 + T2
      IF (NN .EQ. 1) ALP0 = CMPLX(T1,T2)
      RINDX = INDX
      IF (INDX .EQ. 0) GO TO 10
      C2   = C1*B1/ALP0*CSIN(PI/A1*(ARG-B1))/(A1*RINDX+B1-ARG)*
     1       (1.0+(ALP0-B1)/(B1-ARG))/(SIN(PI*B1/A1))*BSYCON
      GO TO 20
   10 CONTINUE
      C2   = C1*B1/ALP0*CSIN(PI/A1*(ARG-B1))/((B1-ALP0)*SIN(PI*B1/A1))*
     1       BSYCON
   20 CONTINUE
      C2TEST = 0.0
      DO 30 I = 1,200
      R    = I
      IF (INDX.LT.0 .AND. ABS(RINDX).EQ.R) GO TO 30
      IF (INDX.GT.0 .AND. RINDX.EQ.R) GO TO 30
      GAMP = PI2*R + GAM0
      GAMN =-PI2*R + GAM0
      C2P  = GAMP/DSTR - SCRK
      C2Q  = GAMP/DSTR + SCRK
      C2N  = GAMN/DSTR - SCRK
      C3Q  = GAMN/DSTR + SCRK
      NN   = 0
      CSEC = C2P*C2Q
      IF (CSEC .LT. 0.0) NN = 1
      T1   = GAMP*S1
      T2   = S2*SQRT(ABS(CSEC))
      IF (C2P.LT.0.0 .AND. C2Q.LT.0.0) T2 =-T2
      IF (NN .EQ. 0) ALP = T1 + T2
      IF (NN .EQ. 1) ALP = CMPLX(T1,T2)
      NN   = 0
      CSEC = C2N*C3Q
      IF (CSEC .LT. 0.0) NN = 1
      T1   = GAMN*S1
      T2   = S2*SQRT(ABS(CSEC))
      IF (C2N.LT.0.0 .AND. C3Q.LT.0.0) T2 =-T2
      IF (NN .EQ. 0) ALN = T1 + T2
      IF (NN .EQ. 1) ALN = CMPLX(T1,T2)
      AT2  = (ALP-A1*R-B1)/(A1*R+B1-ARG)
      AT3  = (ALN-A2*R-B1)/(A2*R+B1-ARG)
      C2   = C2*(1.0+AT2)*(1.0+AT3)
      IF (CABS((C2-C2TEST)/C2) .LT. 0.0009) GO TO 40
      C2TEST = C2
   30 CONTINUE
      GO TO 50
   40 CONTINUE
      RESLT = C2
      RETURN
C
   50 CONTINUE
      WRITE  (IBBOUT,60) UFM
   60 FORMAT (A23,' - AMG MODULE -SUBROUTINE DRKAPM')
      CALL MESAGE (-61,0,0)
      RETURN
      END


    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    CompMolAllSolnPhases.f90
    !> \brief   Compute the number of moles of all stable pure condensed and solution phases.
    !> \author  M.H.A. Piro
    !> \date    June 20, 2012
    !> \sa      AddSolnPhase.f90
    !> \sa      SwapSolnPhase.f90
    !> \sa      SwapSolnForPureConPhase.f90
    !> \sa      CompMolSolnPhase.f90
    !
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   06/20/2012      M.H.A. Piro         Original code
    !   01/31/2013      M.H.A. Piro         Previously, every row of A was divided by the corresponding value of b
    !                                        (which set b = 1D0) in an attempt to minimize numerical error.  The
    !                                        problem with this approach is that the number of moles of a system
    !                                        component is zero when it is an electron (i.e., a SUBL phase).
    !                                        The A matrix is no longer divided by b and the b vector is not 1.
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to estimate the number of moles of each solution and pure
    !! condensed phase in the system.  The stoichiometry of each solution phase and (obviously) pure condensed
    !! phase is fixed and this subroutine determines a particular combination of molar quantities that minimizes
    !! the mass balance residuals using a Linear Leasr Squares (LLS) technique.
    !!
    !! This subroutine addresses a particular issue that occasionally arises when a pure condensed phase is
    !! driven out of the system (when it should), but it also drives a solution phase to almost be removed when
    !! it shouldn't.  At this point, the system may have sufficiently diverged that it may be impossible for
    !! the system to recover.  The element potentials may be close to the equilibrium values, but the molar
    !! quantities of solution speices are way off.  This subroutine therefore fixes the chemical potentials
    !! and determines the best combination of molar quantities of the phases.
    !
    !
    ! Pertinent variables:
    ! ====================
    !
    ! iAssemblage               Integer vector containing the indices of phases at equilibrium
    ! dStoichSpecies            The number of atoms of a particular element for a particular species.
    ! dMolesElement             Total number of moles of an element, where the coefficient corresponds to the
    !                           atomic number (e.g., dMolesElement(92) refers to uranium).
    ! dMolesPhase               Number of moles of a phase at equilibrium
    ! dEffStoichSolnPhase       The effective stoichiometry of a solution phase
    ! dSumMolFractionSoln       Sum of all mole fractions within a solution phase.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine CompMolAllSolnPhases

    USE ModuleThermoIO, ONLY: INFOThermo
    USE ModuleThermo
    USE ModuleGEMSolver

    implicit none

    integer                               :: i, j, k, M, N, MN
    integer                               :: NRHS, LDA, LDB, INFO, LWORK
    real(8)                               :: dURF, dTemp
    real(8),  dimension(:,:), allocatable :: A
    real(8),  dimension(:),   allocatable :: B
    real(8),  dimension(:),   allocatable :: WORK
    character                             :: TRANS

    ! Return if there aren't any solution phases:
    if (nSolnPhases == 0) return

    ! Initialize variables:
    TRANS     = 'N'
    INFO      = 0
    NRHS      = 1
    M         = nElements
    N         = nSolnPhases + nConPhases
    LDA       = MAX(1,M)
    LDB       = MAX(1,M,N)
    MN        = MIN(M,N)
    LWORK     = MAX(1,MN + MAX(MN, NRHS))
    dURF      = 0.5D0

    ! Allocate memory:
    allocate(A(M,N))
    allocate(B(M))
    allocate(WORK(LWORK))

    ! Initialize allocatable variables:
    A        = 0D0
    B        = 0D0
    WORK     = 0D0

    ! Construct matrix A representing the "effective stoichiometry" of each solution phase:
    do j = 1, nSolnPhases

        ! Absolute solution phase index:
        k = -iAssemblage(nElements - j + 1)

        ! Compute the stoichiometry of this solution phase:
        call CompStoichSolnPhase(k)

        do i = 1,nElements
           A(i,j) = dEffStoichSolnPhase(k,i)
        end do

    end do

    ! Construct matrix A representing the stoichiometry of each pure condensed phase:
    do j = nSolnPhases + 1, nSolnPhases + nConPhases
        k = iAssemblage(j - nSolnPhases)

        do i = 1, nElements
            A(i,j) = dStoichSpecies(k,i)
        end do
    end do

    ! Apply the right hand side vector:
    do i = 1, nElements
        B(i) = dMolesElement(i)
    end do

    ! This routine solves the Linear Least Squares (LLS) problem using QR or LQ factorization
    ! in double precision:
    call DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )

    ! Update the estimated number of moles of each solution phase:
    LOOP_SolnPhases: do k = 1, nSolnPhases
        j = nElements - k + 1
        dTemp = dMolesPhase(j)

        if (dMolesPhase(j) <= 0D0) then
            dMolesPhase(j) = dURF * B(k)
            dMolesPhase(j) = DMIN1(dMolesPhase(j),dTolerance(10))
        elseif (dMolesPhase(j) > 0D0) then
            if (B(k) > 0D0) dMolesPhase(j) = dURF * B(k) + (1D0 - dURF) * dMolesPhase(j)
        end if

        dMolesPhase(j) = DMAX1(dMolesPhase(j),dTolerance(9))
        dMolesPhase(j) = DMIN1(dMolesPhase(j),10D0*dTolerance(10))

        if (dTemp > 0D0) then
            dTemp = dMolesPhase(j) / dTemp
            j = -iAssemblage(j)
            do i = nSpeciesPhase(j-1) + 1, nSpeciesPhase(j)
                dMolesSpecies(i) = dMolesSpecies(i) * dTemp
            end do
        end if

    end do LOOP_SolnPhases

    ! Deallocate memory:
    i = 0
    deallocate(A, B, WORK, STAT = i)

    ! Check for any issues and report an error if appropriate:
    if (i /= 0) INFOThermo = 26

    return

end subroutine CompMolAllSolnPhases


      SUBROUTINE MB01OO( UPLO, TRANS, N, H, LDH, X, LDX, E, LDE, P, LDP,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute either P or P', with P defined by the matrix formula
C
C        P = op( H )*X*op( E )',
C
C     where H is an upper Hessenberg matrix, X is a symmetric matrix,
C     E is an upper triangular matrix, and op( M ) is one of
C
C        op( M ) = M   or   op( M ) = M'.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the symmetric matrix X is
C             given as follows:
C             = 'U':  the upper triangular part is given;
C             = 'L':  the lower triangular part is given.
C
C     TRANS   CHARACTER*1
C             Specifies the operation to be performed as follows:
C             = 'N':         compute P  = H*X*E';
C             = 'T' or 'C':  compute P' = E'*X*H.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices H, X, E, and P.  N >= 0.
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,N)
C             On entry, the leading N-by-N upper Hessenberg part of this
C             array must contain the upper Hessenberg matrix H.
C             The remaining part of this array is not referenced.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= MAX(1,N).
C
C     X       (input) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix X and the strictly
C             lower triangular part of the array is not referenced.
C             On entry, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix X and the strictly
C             upper triangular part of the array is not referenced.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= MAX(1,N).
C
C     E       (input) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N upper triangular part of this
C             array must contain the upper triangular matrix E.
C             The remaining part of this array is not referenced.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,N).
C
C     P       (output) DOUBLE PRECISION array, dimension (LDP,N)
C             On exit, the leading N-by-N part of this array contains
C             the computed matrix P  = H*X*E', if TRANS = 'N', or
C             the computed matrix P' = E'*X*H, if TRANS = 'T'.
C
C     LDP     INTEGER
C             The leading dimension of the array P.  LDP >= MAX(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -k, the k-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix expression is efficiently evaluated taking the
C     structure into account, and using BLAS and SLICOT routines.
C     Let W = H*X, or W = X*H, computed using SLICOT Library routine
C     MB01OS. The result is then obtained calling BLAS 3 routine DTRMM.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately N**3 operations.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2019.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDE, LDH, LDP, LDX, N
      CHARACTER         TRANS, UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION  E(LDE,*), H(LDH,*), P(LDP,*), X(LDX,*)
C     .. Local Scalars ..
      LOGICAL           LTRANS, LUPLO
      CHARACTER         SIDE
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DTRMM, MB01OS, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      LUPLO  = LSAME( UPLO, 'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF ( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -1
       ELSE IF ( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF ( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF ( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF ( LDP.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01OO', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
C
C     Compute W := H*X, if TRANS = 'N'.
C     Compute W := X*H, if TRANS = 'T'.
C
      CALL MB01OS( UPLO, TRANS, N, H, LDH, X, LDX, P, LDP, INFO )
C
C     Compute P = W*E' = H*X*E', if TRANS = 'N', or
C     compute P = E'*W = E'*X*H, if TRANS = 'T'.
C
      IF ( LTRANS ) THEN
         SIDE = 'Left'
      ELSE
         SIDE = 'Right'
      END IF
C
      CALL DTRMM( SIDE, 'Upper', 'Tran', 'NoDiag', N, N, ONE, E, LDE, P,
     $            LDP )
C
      RETURN
C *** Last line of MB01OO ***
      END


subroutine correction_coarse(u, v, uf, vf, pc, p, auf_bar, avf_bar, p_uf, p_vf, d_u, d_v, dx, dy, imax, jmax, alphap)
!use variables
use kind_parameters
implicit none

!! Input variables

integer, intent(in):: imax, jmax
real(kind=dp), dimension(imax, jmax):: u, v, pc, p, d_u, d_v
real(kind=dp), dimension(imax-1, jmax):: uf, auf_bar, p_uf, pc_uf
real(kind=dp), dimension(imax, jmax-1):: vf, avf_bar, p_vf, pc_vf
real(kind=dp):: dx(imax), dy(jmax)
real(kind=dp):: alphap

!! Other local variables
integer:: iu, ju, ip, jp, iv, jv
real(kind=dp):: fe_area, fn_area
!real(kind=dp):: sum_num, sum_den
!real(kind=dp):: massflux_in, massflux_out, massflux_out_nom, massflux_out_den

!write(*,*) 'alphap = ', alphap

! Correct face velocities

do ju = 2,jmax-1

      do iu = 2,imax-2

            uf(iu,ju) = uf(iu,ju) + dy(ju)/auf_bar(iu,ju)*(pc(iu,ju)-pc(iu+1,ju))

      end do

end do

do jv = 2,jmax-2

      do iv=2,imax-1

            vf(iv,jv) = vf(iv,jv) + dx(iv)/avf_bar(iv,jv)*(pc(iv,jv)-pc(iv,jv+1))

      end do

end do

do jp = 2,jmax-1

     do ip = 2,imax-1

            p(ip,jp) = p(ip,jp) + alphap*pc(ip,jp)

     end do

end do

do jp=2,jmax-1

!    p(1,jp) = (15.0*p(2,jp) - 10.0*p(3,jp) + 3.0*p(4,jp))/8.0d0
!    p(imax,jp) = (15.0*p(imax-1,jp) - 10.0*p(imax-2,jp) + 3.0*p(imax-3,jp))/8.0d0
    !p(1,jp) = p(2,jp) + delx(1)*(p(2,jp) - p(3,jp))/delx(2)
    !p(imax,jp) = p(imax-1,jp) + delx(imax-1)*(p(imax-1,jp) - p(imax-2,jp))/delx(imax-2)
    p(1,jp) = p(2,jp)
    p(imax,jp) = p(imax-1,jp)

    !pc(1,jp) = (15.0*pc(2,jp) - 10.0*pc(3,jp) + 3.0*pc(4,jp))/8.0d0
    !pc(imax,jp) = (15.0*pc(imax-1,jp) - 10.0*pc(imax-2,jp) + 3.0*pc(imax-3,jp))/8.0d0

    !pc(1,jp) = pc(2,jp) + delx(1)*(pc(2,jp) - pc(3,jp))/delx(2)
    !pc(1,jp) = ((xp(1) - xp(2))*pc(3,jp) - (xp(1) - xp(3))*pc(2,jp))/(xp(3) - xp(2))
    !pc(imax,jp) = pc(imax-1,jp) + delx(imax-1)*(pc(imax-1,jp) - pc(imax-2,jp))/delx(imax-2)
    pc(1,jp) = pc(2,jp)
    pc(imax,jp) = pc(imax-1,jp)

end do

do ip=2,imax-1

!      p(ip,1) = (15.0*p(ip,2) - 10.0*p(ip,3) + 3.0*p(ip,4))/8.0d0
!      p(ip,jmax) = (15.0*p(ip,jmax-1) - 10.0*p(ip,jmax-2) + 3.0*p(ip,jmax-3))/8.0d0
     !p(ip,1) = p(ip,2) + dely(2)*(p(ip,2) - p(ip,3))/dely(2)
     !p(ip,1) = ((yp(1) - yp(2))*p(ip,3) - (yp(1) - yp(3))*p(ip,2))/(yp(3) - yp(2))
     !p(ip,jmax) = ((yp(jmax) - yp(jmax-1))*p(ip,jmax-2) - (yp(jmax) - yp(jmax-2))*p(ip,jmax-1))/(yp(jmax-2) - yp(jmax-1))
     !p(ip,jmax) = p(ip,jmax-1) + dely(jmax-1)*(p(ip,jmax-1) - p(ip,jmax-2))/dely(jmax-2)
     p(ip,1) = p(ip,2)
     p(ip,jmax) = p(ip,jmax-1)

     !pc(ip,1) = (15.0*pc(ip,2) - 10.0*pc(ip,3) + 3.0*pc(ip,4))/8.0d0
     !pc(ip,jmax) = (15.0*pc(ip,jmax-1) - 10.0*pc(ip,jmax-2) + 3.0*pc(ip,jmax-3))/8.0d0
     !pc(ip,1) = ((yp(1) - yp(2))*pc(ip,3) - (yp(1) - yp(3))*pc(ip,2))/(yp(3) - yp(2))
     !pc(ip,jmax) = ((yp(jmax) - yp(jmax-1))*pc(ip,jmax-2) - (yp(jmax) - yp(jmax-2))*pc(ip,jmax-1))/(yp(jmax-1) - yp(jmax-2))

     !pc(ip,1) = pc(ip,2) + dely(1)*(pc(ip,2) - pc(ip,3))/dely(2)
     !pc(ip,jmax) = pc(ip,jmax-1) + dely(jmax-1)*(pc(ip,jmax-1) - pc(ip,jmax-2))/dely(jmax-2)
     pc(ip,1) = pc(ip,2)
     pc(ip,jmax) = pc(ip,jmax-1)

end do

! Calculate pressure and pressure correction values at interface

do jp = 2,jmax-1

     do ip = 2,imax-1

            fe_area = dx(ip+1)/(dx(ip+1)+dx(ip))
            p_uf(ip,jp) = fe_area*p(ip,jp) + (1.0d0-fe_area)*p(ip+1,jp)
            pc_uf(ip,jp) = fe_area*pc(ip,jp) + (1.0d0-fe_area)*pc(ip+1,jp)

      end do

end do

do jp = 2,jmax-1

    do ip = 2,imax-1

            fn_area = dy(jp+1)/(dy(jp+1)+dy(jp))
            p_vf(ip,jp) = fn_area*p(ip,jp) + (1.0d0-fn_area)*p(ip,jp+1)
            pc_vf(ip,jp) = fn_area*pc(ip,jp) + (1.0d0-fn_area)*pc(ip,jp+1)

    end do

end do

!pc_uf(imax-1,:) = pc_uf(imax-2,:)
!pc_uf(1,:) = pc_uf(2,:)
!pc_vf(:,jmax-1) = pc_vf(:,jmax-2)
!pc_vf(:,1) = pc_vf(:,2)

!pc_uf(imax-1,:) = pc(imax,:)
!pc_uf(1,:) = pc(1,:)
!pc_uf(1,:) = pc_uf(2,:)
!pc_uf(imax-1,:) = pc_uf(imax-2,:)
!pc_uf(1,:) = pc_uf(2,:) + dx(2)*(pc_uf(2,:) - pc_uf(3,:))/dx(3)
!p(imax,jp) = p(imax-1,jp) + delx(imax-1)*(p(imax-1,jp) - p(imax-2,jp))/delx(imax-2)
!pc_vf(:,jmax-1) = pc(:,jmax)
pc_vf(:,1) = pc(:,1)
p_vf(:,1) = p(:,1)
!pc_vf(:,1) = pc_vf(:,2)
!pc_vf(:,jmax-1) = pc_vf(:,jmax-2)
!pc_vf(:,1) = pc_vf(:,2) + dy(2)*(pc_vf(:,2) - pc_vf(:,3))/dy(3)

!p_uf(imax-1,:) = p(imax,:)
p_uf(1,:) = p(1,:)
pc_uf(1,:) = pc(1,:)
!p_uf(1,:) = p_uf(2,:) + dx(2)*(p_uf(2,:) - p_uf(3,:))/dx(3)
!p_vf(:,jmax-1) = p(:,jmax)
!p_vf(:,1) = p(:,1)
!p_vf(:,1) = p_vf(:,2) + dy(2)*(p_vf(:,2) - p_vf(:,3))/dy(3)

! Correct nodal velocities using pressure correction at interfaces

do ju = 2,jmax-1

      do iu = 2,imax-1

            u(iu,ju) = u(iu,ju) + d_u(iu,ju)*(pc_uf(iu-1,ju)-pc_uf(iu,ju))

      end do

end do

do jv = 2,jmax-1

      do iv=2,imax-1

	     v(iv,jv) = v(iv,jv) + d_v(iv,jv)*(pc_vf(iv,jv-1)-pc_vf(iv,jv))

      end do

end do

!u(1,:) = u(2,:)
!u(iumax,:) = u(iumax-1,:)
!
!uf(1,:) = uf(2,:)
!uf(iumax-1,:) = uf(iumax-2,:)

!uf(1,:) = u(1,:)
!uf(iumax-1,:) = u(iumax,:)

!v(1,:) = v(2,jv)
!v(ivmax,:) = v(ivmax-1,jv)

!vf(1,1:jvmax-1) = v(1,1:jvmax-1)
!vf(ivmax,1:jvmax-1) = v(ivmax,1:jvmax-1)

!vf(1,1:jvmax-1) = vf(2,1:jvmax-1)
!vf(ivmax,1:jvmax-1) = vf(ivmax-1,1:jvmax-1)

end subroutine


C
      SUBROUTINE SHELLG(GLAT,GLON,ALT,DIMO,FL,ICODE,B0)
c  ------------------------------------------------------------------------
c  Part of "poa_calfos" (STECF/IPMG)
c  Part of "NEWBILCAL" program to produce IGRF geomagnetic model (GSFC)
c
c  History:
c  --------
c  Version   Date        Author          Description
c      1.0       Jul 00  M. Rosa         POA calibration code
c  ------------------------------------------------------------------------
C--------------------------------------------------------------------
C CALCULATES L-VALUE FOR SPECIFIED GEODAETIC COORDINATES, ALTITUDE
C AND GEMAGNETIC FIELD MODEL.
C REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTER, INTERNAL NOTE
C      NO. 67, 1970.
C      G. KLUGE, COMPUTER PHYSICS COMMUNICATIONS 3, 31-35, 1972
C--------------------------------------------------------------------
C CHANGES (D. BILITZA, NOV 87):
C   - USING CORRECT DIPOL MOMENT I.E.,DIFFERENT COMMON/MODEL/
C   - USING IGRF EARTH MAGNETIC FIELD MODELS FROM 1945 TO 1990
C--------------------------------------------------------------------
C  INPUT:  ENTRY POINT SHELLG
C               GLAT  GEODETIC LATITUDE IN DEGREES (NORTH)
C                GLON  GEODETIC LONGITUDE IN DEGREES (EAST)
C                ALT   ALTITUDE IN KM ABOVE SEA LEVEL
C
C          ENTRY POINT SHELLC
C              V(3)  CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM)
C                     X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE
C                     Y-AXIS POINTING TO EQUATOR AT 90 LONG.
C                     Z-AXIS POINTING TO NORTH POLE
C
C          DIMO             DIPOL MOMENT IN GAUSS (NORMALIZED TO EARTH RADIUS)
C
C          COMMON
C              X(3)       NOT USED
C              H(144)       FIELD MODEL COEFFICIENTS ADJUSTED FOR SHELLG
C-----------------------------------------------------------------------
C  OUTPUT: FL          L-VALUE
C          ICODE         =1 NORMAL COMPLETION
C                     =2 UNPHYSICAL CONJUGATE POINT (FL MEANINGLESS)
C                     =3 SHELL PARAMETER GREATER THAN LIMIT UP TO
C                        WHICH ACCURATE CALCULATION IS REQUIRED;
C                        APPROXIMATION IS USED.
C           B0          MAGNETIC FIELD STRENGTH IN GAUSS
C-----------------------------------------------------------------------
      REAL*4 V(3),U(3,3),P(8,100),SP(3)
      REAL*4 X(3),H(144)
      REAL*4 UMR,ERAD,AQUAD,BQUAD

      INTEGER icode,i,n
      REAL*4 glat,glon,alt,steq,iequ
      REAL*4 fl,b0,rmin,rmax,step,bequ,rlat,ct,st,d,rlon,rq
      REAL*4 r3h,bq2,r2,bq3,r3,bq1,r1,zz,step12,step2,fi,oradik,oterm
      REAL*4 stp,z,c0,c1,c2
      REAL*4 c3,d0,d1,d2,e0,e1,e2,t,hli,zq,r,ff,radik,term,dimob0,xx,gg

      REAL*8 dimo

      COMMON /SHCOMM/  X,H
      COMMON /FIDB0/ SP
      COMMON /GENER/ UMR,ERAD,AQUAD,BQUAD
C
C-- RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF ICODE=2 AND 3
C-- STEP IS STEP SIZE FOR FIELD LINE TRACING
C-- STEQ IS STEP SIZE FOR INTEGRATION
      DATA RMIN,RMAX       /0.05,1.01/
      DATA STEP,STEQ       /0.20,0.03/
      DATA U/                 +0.3511737,-0.9148385,-0.1993679,
     1                        +0.9335804,+0.3583680,+0.0000000,
     2                        +0.0714471,-0.1861260,+0.9799247/
      BEQU=1.E10

C*****ENTRY POINT  SHELLG  TO BE USED WITH GEODETIC CO-ORDINATES
      RLAT=GLAT*UMR
      CT=SIN(RLAT)
      ST=COS(RLAT)
      D=SQRT(AQUAD-(AQUAD-BQUAD)*CT*CT)
      X(1)=(ALT+AQUAD/D)*ST/ERAD
      X(3)=(ALT+BQUAD/D)*CT/ERAD
      RLON=GLON*UMR
      X(2)=X(1)*SIN(RLON)
      X(1)=X(1)*COS(RLON)
      GOTO9

C*****ENTRY POINT  SHELLC  TO BE USED WITH CARTESIAN CO-ORDINATES
      ENTRY SHELLC(V,FL,B0)
      X(1)=V(1)
      X(2)=V(2)
      X(3)=V(3)
C*****CONVERT TO DIPOL-ORIENTED CO-ORDINATES
9     RQ=1./(X(1)*X(1)+X(2)*X(2)+X(3)*X(3))
      R3H=SQRT(RQ*SQRT(RQ))
      P(1,2)=(X(1)*U(1,1)+X(2)*U(2,1)+X(3)*U(3,1))*R3H
      P(2,2)=(X(1)*U(1,2)+X(2)*U(2,2)            )*R3H
      P(3,2)=(X(1)*U(1,3)+X(2)*U(2,3)+X(3)*U(3,3))*RQ
C*****FIRST THREE POINTS OF FIELD LINE
      STEP=-SIGN(STEP,P(3,2))
      CALL STOER(P(1,2),BQ2,R2)
      B0=SQRT(BQ2)
      P(1,3)=P(1,2)+0.5*STEP*P(4,2)
      P(2,3)=P(2,2)+0.5*STEP*P(5,2)
      P(3,3)=P(3,2)+0.5*STEP
      CALL STOER(P(1,3),BQ3,R3)
      P(1,1)=P(1,2)-STEP*(2.*P(4,2)-P(4,3))
      P(2,1)=P(2,2)-STEP*(2.*P(5,2)-P(5,3))
      P(3,1)=P(3,2)-STEP
      CALL STOER(P(1,1),BQ1,R1)
      P(1,3)=P(1,2)+STEP*(20.*P(4,3)-3.*P(4,2)+P(4,1))/18.
      P(2,3)=P(2,2)+STEP*(20.*P(5,3)-3.*P(5,2)+P(5,1))/18.
      P(3,3)=P(3,2)+STEP
      CALL STOER(P(1,3),BQ3,R3)
C*****INVERT SENSE IF REQUIRED
      IF(BQ3.LE.BQ1)GOTO2
      STEP=-STEP
      R3=R1
      BQ3=BQ1
      DO 1 I=1,7
      ZZ=P(I,1)
      P(I,1)=P(I,3)
1     P(I,3)=ZZ
C*****SEARCH FOR LOWEST MAGNETIC FIELD STRENGTH
2     IF(BQ1.LT.BEQU) THEN
       BEQU=BQ1
       IEQU=1
       ENDIF
      IF(BQ2.LT.BEQU) THEN
       BEQU=BQ2
       IEQU=2
       ENDIF
      IF(BQ3.LT.BEQU) THEN
       BEQU=BQ3
       IEQU=3
       ENDIF
C*****INITIALIZATION OF INTEGRATION LOOPS
      STEP12=STEP/12.
      STEP2=STEP+STEP
      STEQ=SIGN(STEQ,STEP)
      FI=0.
      ICODE=1
      ORADIK=0.
      OTERM=0.
      STP=R2*STEQ
      Z=P(3,2)+STP
      STP=STP/0.75
      P(8,1)=STEP2*(P(1,1)*P(4,1)+P(2,1)*P(5,1))
      P(8,2)=STEP2*(P(1,2)*P(4,2)+P(2,2)*P(5,2))
C*****MAIN LOOP (FIELD LINE TRACING)
      DO 3 N=3,3333
C*****CORRECTOR (FIELD LINE TRACING)
      P(1,N)=P(1,N-1)+STEP12*(5.*P(4,N)+8.*P(4,N-1)-P(4,N-2))
      P(2,N)=P(2,N-1)+STEP12*(5.*P(5,N)+8.*P(5,N-1)-P(5,N-2))
C*****PREPARE EXPANSION COEFFICIENTS FOR INTERPOLATION
C*****OF SLOWLY VARYING QUANTITIES
      P(8,N)=STEP2*(P(1,N)*P(4,N)+P(2,N)*P(5,N))
      C0=P(1,N-1)**2+P(2,N-1)**2
      C1=P(8,N-1)
      C2=(P(8,N)-P(8,N-2))*0.25
      C3=(P(8,N)+P(8,N-2)-C1-C1)/6.0
      D0=P(6,N-1)
      D1=(P(6,N)-P(6,N-2))*0.5
      D2=(P(6,N)+P(6,N-2)-D0-D0)*0.5
      E0=P(7,N-1)
      E1=(P(7,N)-P(7,N-2))*0.5
      E2=(P(7,N)+P(7,N-2)-E0-E0)*0.5
C*****INNER LOOP (FOR QUADRATURE)
4     T=(Z-P(3,N-1))/STEP
      IF(T.GT.1.)GOTO5
      HLI=0.5*(((C3*T+C2)*T+C1)*T+C0)
      ZQ=Z*Z
      R=HLI+SQRT(HLI*HLI+ZQ)
      IF(R.LE.RMIN)GOTO30
      RQ=R*R
      FF=SQRT(1.+3.*ZQ/RQ)
      RADIK=B0-((D2*T+D1)*T+D0)*R*RQ*FF
      IF(R-RMAX)44,44,45
45    ICODE=2
      RADIK=RADIK-12.*(R-RMAX)**2
44    IF(RADIK+RADIK.LE.ORADIK) GOTO 10
      TERM=SQRT(RADIK)*FF*((E2*T+E1)*T+E0)/(RQ+ZQ)
      FI=FI+STP*(OTERM+TERM)
      ORADIK=RADIK
      OTERM=TERM
      STP=R*STEQ
      Z=Z+STP
      GOTO4
C*****PREDICTOR (FIELD LINE TRACING)
5     P(1,N+1)=P(1,N)+STEP12*(23.*P(4,N)-16.*P(4,N-1)+5.*P(4,N-2))
      P(2,N+1)=P(2,N)+STEP12*(23.*P(5,N)-16.*P(5,N-1)+5.*P(5,N-2))
      P(3,N+1)=P(3,N)+STEP
      CALL STOER(P(1,N+1),BQ3,R3)
C*****SEARCH FOR LOWEST MAGNETIC FIELD STRENGTH
      IF(BQ3.LT.BEQU) THEN
       IEQU=N+1
       BEQU=BQ3
       ENDIF
3     CONTINUE
10    IF(IEQU.lt.2) IEQU=2
      SP(1)=P(1,IEQU-1)
      SP(2)=P(2,IEQU-1)
      SP(3)=P(3,IEQU-1)
      IF(ORADIK.LT.1E-15)GOTO11
      FI=FI+STP/0.75*OTERM*ORADIK/(ORADIK-RADIK)
C
C-- The minimal allowable value of FI was changed from 1E-15 to 1E-12,
C-- because 1E-38 is the minimal allowable arg. for ALOG in our envir.
C-- D. Bilitza, Nov 87.
C
11    FI=0.5*ABS(FI)/SQRT(B0)+1E-12
C*****COMPUTE L FROM B AND I.  SAME AS CARMEL IN INVAR.
C-- Correct dipole moment is used here. D. Bilitza, Nov 87.
      DIMOB0=DIMO/B0
      XX=ALOG(FI*FI*FI/DIMOB0)
      IF(XX.GT.23.0) GOTO 776
      IF(XX.GT.11.7) GOTO 775
      IF(XX.GT.+3.0) GOTO 774
      IF(XX.GT.-3.0) GOTO 773
      IF(XX.GT.-22.) GOTO 772
  771 GG=3.33338E-1*XX+3.0062102E-1
      GOTO777
  772 GG=((((((((-8.1537735E-14*XX+8.3232531E-13)*XX+1.0066362E-9)*XX+
     18.1048663E-8)*XX+3.2916354E-6)*XX+8.2711096E-5)*XX+1.3714667E-3)*
     2XX+1.5017245E-2)*XX+4.3432642E-1)*XX+6.2337691E-1
      GOTO777
  773 GG=((((((((2.6047023E-10*XX+2.3028767E-9)*XX-2.1997983E-8)*XX-
     15.3977642E-7)*XX-3.3408822E-6)*XX+3.8379917E-5)*XX+1.1784234E-3)*
     2XX+1.4492441E-2)*XX+4.3352788E-1)*XX+6.228644E-1
      GOTO777
  774 GG=((((((((6.3271665E-10*XX-3.958306E-8)*XX+9.9766148E-07)*XX-
     11.2531932E-5)*XX+7.9451313E-5)*XX-3.2077032E-4)*XX+2.1680398E-3)*
     2XX+1.2817956E-2)*XX+4.3510529E-1)*XX+6.222355E-1
      GOTO777
  775 GG=(((((2.8212095E-8*XX-3.8049276E-6)*XX+2.170224E-4)*XX-6.7310339
     1E-3)*XX+1.2038224E-1)*XX-1.8461796E-1)*XX+2.0007187E0
      GOTO777
  776 GG=XX-3.0460681E0
  777 FL=EXP(ALOG((1.+EXP(GG))*DIMOB0)/3.0)
      RETURN
C*****APPROXIMATION FOR HIGH VALUES OF L.
30    ICODE=3
      T=-P(3,N-1)/STEP
      FL=1./(ABS(((C3*T+C2)*T+C1)*T+C0)+1E-15)
      RETURN
      END
C


! This test was created from ..\problem-specifications\exercises\armstrong-numbers\canonical-data.json
!

program armstrong_numbers_test_main
  use TesterMain
  use armstrong_numbers
  implicit none

  ! Test 1: Zero is an Armstrong number
  call assert_equal(.true., isArmstrongNumber(0), "Zero is an Armstrong number")
  ! Test 2: Single digit numbers are Armstrong numbers
  call assert_equal(.true., isArmstrongNumber(5), "Single digit numbers are Armstrong numbers")
  ! Test 3: There are no 2 digit Armstrong numbers
  call assert_equal(.false., isArmstrongNumber(10), "There are no 2 digit Armstrong numbers")
  ! Test 4: Three digit number that is an Armstrong number
  call assert_equal(.true., isArmstrongNumber(153), "Three digit number that is an Armstrong number")
  ! Test 5: Three digit number that is not an Armstrong number
  call assert_equal(.false., isArmstrongNumber(100), "Three digit number that is not an Armstrong number")
  ! Test 6: Four digit number that is an Armstrong number
  call assert_equal(.true., isArmstrongNumber(9474), "Four digit number that is an Armstrong number")
  ! Test 7: Four digit number that is not an Armstrong number
  call assert_equal(.false., isArmstrongNumber(9475), "Four digit number that is not an Armstrong number")
  ! Test 8: Seven digit number that is an Armstrong number
  call assert_equal(.true., isArmstrongNumber(9926315), "Seven digit number that is an Armstrong number")
  ! Test 9: Seven digit number that is not an Armstrong number
  call assert_equal(.false., isArmstrongNumber(9926314), "Seven digit number that is not an Armstrong number")

  call test_report()

end program


! { dg-do compile }
! PR 44693 - check for invalid dim even in functions.
! Based on a test case by Dominique d'Humieres.
subroutine test1(esss,Ix,Iyz, n)
  real(kind=kind(1.0d0)), dimension(n), intent(out) :: esss
  real(kind=kind(1.0d0)), dimension(n,n,n) :: sp
  real(kind=kind(1.0d0)), dimension(n,n) :: Ix,Iyz
  esss = sum(Ix * Iyz, 0) ! { dg-error "is not a valid dimension index" }
  esss = sum(Ix * Iyz, 1)
  esss = sum(Ix * Iyz, 2)
  esss = sum(Ix * Iyz, 3) ! { dg-error "is not a valid dimension index" }
  sp = spread (ix * iyz, 0, n) ! { dg-error "is not a valid dimension index" }
  sp = spread (ix * iyz, 1, n)
  sp = spread (ix * iyz, 2, n)
  sp = spread (ix * iyz, 3, n)
  sp = spread (ix * iyz, 4, n) ! { dg-error "is not a valid dimension index" }
end subroutine


      SUBROUTINE DASQRTB( A, B, C )
*
*  -- PBLAS auxiliary routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C
*     ..
*
*  Purpose
*  =======
*
*  DASQRTB computes c := a * sqrt( b ) where a, b and c are scalars.
*
*  Arguments
*  =========
*
*  A       (input) DOUBLE PRECISION
*          On entry, A specifies the scalar a.
*
*  B       (input) DOUBLE PRECISION
*          On entry, B specifies the scalar b.
*
*  C       (output) DOUBLE PRECISION
*          On entry, C specifies the scalar c. On exit, c is overwritten
*          by the product of a and the square root of b.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC          SQRT
*     ..
*     .. Executable Statements ..
*
      C = A * SQRT( B )
*
      RETURN
*
*     End of DASQRTB
*
      END


C$Procedure      NPARSI ( Integer parsing of a character string)

      SUBROUTINE NPARSI (  STRING,  N, ERROR, PNTER)

C$ Abstract
C
C     Parse a character string that represents a number and return
C     the FORTRAN-truncated integer value.
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      ALPHANUMERIC
C      CONVERSION
C      PARSING
C
C$ Declarations

      CHARACTER*(*)    STRING
      INTEGER          N
      CHARACTER*(*)    ERROR
      INTEGER          PNTER

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  ---------------------------------------------------
C     STRING     I   Character string representing a numeric value.
C     N          O   Translated integer value of STRING.
C     ERROR      O   Message indicating what errors have occurred.
C     PNTER      O   Position in character string where an error
C                    occurred.
C
C$ Detailed_Input
C
C     STRING     A character string that represents a numeric value.
C                Commas and spaces may be used in this string for
C                ease of reading and writing the number.  They
C                are treated as insignificant but non-error-producing
C                characters.
C
C                For exponential representation and of the characters
C                'E','D','e','d' may be used.
C
C                The following are legitimate numeric expressions
C
C                 +12.2 e-1
C                 -3. 1415 9276
C                 1e12
C                 E10
C
C                The program also recognizes the following  mnemonics
C                'PI', 'pi', 'Pi', 'pI'
C                '+PI', '+pi', '+Pi', '+pI'
C                '-PI', '-pi', '-Pi', '-pI'
C                and returns the value ( + OR - ) 3 as appropriate.
C
C$ Detailed_Output
C
C     N          Integer parsed value of input string  ( with
C                the implied limits on precision).  If an error is
C                encountered, N is not changed from whatever the
C                input value was.  If the input string has a fractional
C                part, the fractional part will be truncated.  Thus
C                3.18 is interpreted as 3.  -4.98 is interpreted as -4.
C
C     ERROR      This is a message indicating that the string could
C                not be parsed due to ambiguous use of symbols or
C                due to a string representing a number too large for
C                VAX double precision or integer variables. If no
C                error occurred, ERROR is blank.
C
C                In particular, blank strings, or strings that do not
C                contain either a digit or exponent character will
C                be regarded as errors.
C
C     PNTER      This indicates which character was being used when
C                the error occurred. If no error occurred, PNTER is 0.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C     Basically, all this routine does is pass the input string to
C     NPARSD which does the parsing in double precision.  If nothing
C     goes wrong in the double precision parsing of the number, the
C     returned value is checked to determine whether or not it will fit
C     into a VAX integer.  If it doesn't, an error message is returned.
C
C$ Examples
C
C     Let   LINE = 'DELTA_T_A       =   32'
C
C     The following code fragment parses the line and obtains the
C     integer value.
C
C
C        CALL NEXTWD ( LINE,  FIRST,  REST )
C        CALL NEXTWD ( REST, SECOND,  REST )
C        CALL NEXTWD ( REST,  THIRD,  REST )
C
C        CALL NPARSI (  THIRD,  VALUE, ERROR, POINTR )
C
C$ Restrictions
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1) If the string is non-numeric, PNTER indicates the location in
C        the string where the error occurred, and ERROR contains a
C        descriptive error message.
C
C     2) If the string is blank, ERROR is returned with a message
C        indicating the problem and PNTER will have a non-zero value.
C
C     3) If the string represents a number that is outside the range
C        of representable integers, as defined by INTMIN() and INTMAX(),
C        ERROR is returned with a message and PNTER is set to the value
C        1, as the entire numeric string is at fault.
C
C$ Files
C
C     None.
C
C$ Author_and_Institution
C
C     K.R. Gehringer  (JPL)
C     H.A. Neilan     (JPL)
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 2.1.0, 29-APR-1996 (KRG)
C
C        This subroutine was modified to return a non-zero value of
C        PNTER when the value returned by NPARSD is not a representable
C        integer, as defined by INTMIN() and INTMAX(). The value
C        returned is one (1), since the entire input string was not
C        correct.
C
C        The test for an error from NPARSD was also changed. It now
C        uses the integer PNTER returned from NPARSD rather then the
C        character string ERROR. This should pose no problems because
C        PNTER is non-zero if and only if there was an error and an
C        error message was assigned to ERROR.
C
C        Some extra, and unnecessary, assignments were deleted. The
C        assignments were:
C
C           X = DBLE ( N )
C
C           ERROR = ' '
C
C        which converted the input argument into a double before
C        calling NPARSD with X and initialized the error message
C        to be blank. NPARSD sets the value for X, ERROR, and PNTER
C        unless an error occurs, in which case X is not changed.
C        So, it is not necessary to initialize ERROR, PNTER, or X.
C
C        Finally, the values of INTMIN and INTMAX are only set on the
C        first call to the routine. They are now SAVEd.
C
C-    SPICELIB Version 2.0.0, 15-OCT-1992 (WLT)
C
C        The abstract of this routine was modified to reflect what
C        the routine actually does---truncate the value to an
C        integer.
C
C        In addition, a blank string is no longer considered to be
C        valid input.
C
C        Finally the instances of DFLOAT in the previous version were
C        replaced by the standard intrinsic function DBLE and the
C        function DINT was replaced by IDINT in one place to make types
C        match up on both sides of an assignment.
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)
C
C-&

C$ Index_Entries
C
C     parse a character_string to an integer
C
C-&

C
C$ Revisions
C
C-    SPICELIB Version 2.1.0, 29-APR-1996 (KRG)
C
C        This subroutine was modified to return a non-zero value of
C        PNTER when the value returned by NPARSD is not a representable
C        integer, as defined by INTMIN() and INTMAX(). The value
C        returned is one (1), since the entire input string was not
C        correct.
C
C        The test for an error from NPARSD was also changed. It now
C        uses the integer PNTER returned from NPARSD rather then the
C        character string ERROR. This should pose no problems because
C        PNTER is non-zero if and only if there was an error and an
C        error message was assigned to ERROR.
C
C        Some extra, and unnecessary, assignments were deleted. The
C        assignments were:
C
C           X = DBLE ( N )
C
C           ERROR = ' '
C
C        which converted the input argument into a double before
C        calling NPARSD with X and initialized the error message
C        to be blank. NPARSD sets the value for X, ERROR, and PNTER
C        unless an error occurs, in which case X is not changed.
C        So, it is not necessary to initialize ERROR, PNTER, or X.
C
C        Finally, the values of INTMIN and INTMAX are only set on the
C        first call to the routine. They are now SAVEd.
C
C-    SPICELIB Version 2.0.0, 15-OCT-1992 (WLT)
C
C        The abstract of this routine was modified to reflect what
C        the routine actually does---truncate the value to an
C        integer.
C
C        In addition, a blank string is no longer considered to be
C        valid input.
C
C        Finally the instances of DFLOAT in the previous version were
C        replaced by the standard intrinsic function DBLE and the
C        function DINT was replaced by IDINT in one place to make types
C        match up on both sides of an assignment.
C
C-     Beta Version 1.2.0, 23-FEB-1989 (WLT)
C
C         Due to a programming error, the routine was not leaving N
C         unchanged if the input string was blank.  This bug was
C         fixed and the exceptional case noted in exceptions.
C
C-     Beta Version 1.1.0, 28-OCT-1988 (HAN)
C
C         Peter Wolff (JPL) informed the NAIF staff that he found
C         an "IMPLICIT NONE" statement in the ANSI Standard Fortran
C         77 version of this routine. Because the statement is a
C         VAX extension not used by NAIF, the statement was removed.
C
C-&

C
C     SPICELIB functions
C

      INTEGER               INTMAX
      INTEGER               INTMIN

C
C     Local Variables
C
      DOUBLE PRECISION      XMNINT
      DOUBLE PRECISION      XMXINT
      DOUBLE PRECISION      X

      LOGICAL               FIRST
C
C     Saved Variables
C
      SAVE                  FIRST
      SAVE                  XMNINT
      SAVE                  XMXINT
C
C     Initial values
C
      DATA                  FIRST / .TRUE. /
C
C     If this is the first time NPARSI has been called, initialize
C     bounds for the range of integers.
C
      IF ( FIRST ) THEN

         FIRST  = .FALSE.
         XMXINT =  DBLE ( INTMAX () )
         XMNINT =  DBLE ( INTMIN () )

      END IF
C
C     NPARSD will define ERROR and PNTER if there is an error,
C     so we do not need to initialize them here.
C
      CALL NPARSD ( STRING, X, ERROR, PNTER )

      IF ( PNTER .EQ. 0 ) THEN

         IF (     ( DINT(X) .LT. XMNINT )
     .       .OR. ( DINT(X) .GT. XMXINT ) ) THEN

            PNTER = 1
            ERROR = 'NPARSI: Value entered is beyond the bounds of '//
     .              'representable integers.'

         ELSE

            N = IDINT(X)

         END IF

      END IF

      RETURN
      END