module quad_submod_mod
    implicit none

    private
    public :: quad

    interface
        module function quad(f, a, b) result(q_f)
            use :: types_mod, only : DP
            use :: quad_func_interface_mod
            implicit none
            procedure(quad_func_t) :: f
            real(kind=DP), intent(in) :: a, b
            real(kind=DP) :: q_f
        end function quad
    end interface

end module quad_submod_mod


      function cdg(y)
c*******************************************
c  Normal N(0,1) distribution function at y
c===========================================
      real y
c*******************************************
      cdg=y*(.70710678)
      if(cdg>=0) then
       if(cdg<=4.3) then
       cdg=.5+erf(cdg)/2.
        else
         cdg=1.
       endif
        elseif(cdg<0.) then
         cdg=-cdg
         if(cdg<=4.3) then
          cdg=.5-erf(cdg)/2.
           else
            cdg=0.
         endif
      endif
      return
      end


C***********************************************************************
C***********************************************************************
C
C   Version:        0.3
C   Last modified:  December 27, 1994
C   Authors:        Joseph W.H. Liu
C
C   Mathematical Sciences Section, Oak Ridge National Laboratory
C
C***********************************************************************
C***********************************************************************
C***************     ETPOST ..... ETREE POSTORDERING     ***************
C***********************************************************************
C***********************************************************************
C
C   WRITTEN BY JOSEPH LIU (SEPT 17, 1986)
C
C   PURPOSE:
C       BASED ON THE BINARY REPRESENTATION (FIRST-SON,BROTHER) OF
C       THE ELIMINATION TREE, A POSTORDERING IS DETERMINED. THE
C       CORRESPONDING PARENT VECTOR IS ALSO MODIFIED TO REFLECT
C       THE REORDERING.
C
C   INPUT PARAMETERS:
C       ROOT            -   ROOT OF THE ELIMINATION TREE (USUALLY IT
C                           IS NEQNS).
C       FSON            -   THE FIRST SON VECTOR.
C       BROTHR          -   THE BROTHR VECTOR.
C
C   UPDATED PARAMETERS:
C       PARENT          -   THE PARENT VECTOR.
C
C   OUTPUT PARAMETERS:
C       INVPOS          -   INVERSE PERMUTATION FOR THE POSTORDERING.
C
C   WORKING PARAMETERS:
C       STACK           -   THE STACK FOR POSTORDER TRAVERSAL OF THE
C                           TREE.
C
C***********************************************************************
C
      SUBROUTINE  ETPOST (  ROOT  , FSON  , BROTHR, INVPOS, PARENT,
     &                      STACK                                   )
C
C***********************************************************************
C
        INTEGER*4           BROTHR(*)     , FSON(*)       ,
     &                      INVPOS(*)     , PARENT(*)     ,
     &                      STACK(*)
C
        INTEGER*4           ROOT
C
C***********************************************************************
C
        INTEGER*4           ITOP  , NDPAR , NODE  , NUM   , NUNODE
C
C***********************************************************************
C
        NUM = 0
        ITOP = 0
        NODE = ROOT
C       -------------------------------------------------------------
C       TRAVERSE ALONG THE FIRST SONS POINTER AND PUSH THE TREE NODES
C       ALONG THE TRAVERSAL INTO THE STACK.
C       -------------------------------------------------------------
  100   CONTINUE
            ITOP = ITOP + 1
            STACK(ITOP) = NODE
            NODE = FSON(NODE)
            IF  ( NODE .GT. 0 )  GO TO 100
C           ----------------------------------------------------------
C           IF POSSIBLE, POP A TREE NODE FROM THE STACK AND NUMBER IT.
C           ----------------------------------------------------------
  200       CONTINUE
                IF  ( ITOP .LE. 0 )  GO TO 300
                NODE = STACK(ITOP)
                ITOP = ITOP - 1
                NUM = NUM + 1
                INVPOS(NODE) = NUM
C               ----------------------------------------------------
C               THEN, TRAVERSE TO ITS YOUNGER BROTHER IF IT HAS ONE.
C               ----------------------------------------------------
                NODE = BROTHR(NODE)
                IF  ( NODE .LE. 0 )  GO TO 200
            GO TO 100
C
  300   CONTINUE
C       ------------------------------------------------------------
C       DETERMINE THE NEW PARENT VECTOR OF THE POSTORDERING.  BROTHR
C       IS USED TEMPORARILY FOR THE NEW PARENT VECTOR.
C       ------------------------------------------------------------
        DO  400  NODE = 1, NUM
            NUNODE = INVPOS(NODE)
            NDPAR = PARENT(NODE)
            IF  ( NDPAR .GT. 0 )  NDPAR = INVPOS(NDPAR)
            BROTHR(NUNODE) = NDPAR
  400   CONTINUE
C
        DO  500  NUNODE = 1, NUM
            PARENT(NUNODE) = BROTHR(NUNODE)
  500   CONTINUE
C
        RETURN
      END


      FUNCTION PCHST (ARG1, ARG2)
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(rprec) :: ARG1, ARG2
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(rprec) :: ONE, ZERO, PCHST
!-----------------------------------------------
!***BEGIN PROLOGUE  PCHST
!***REFER TO  PCHCE,PCHCI,PCHCS,PCHIM
!***ROUTINES CALLED  (NONE)
!***DESCRIPTION
!
!         PCHST:  PCHIP Sign-Testing Routine.
!
!
!     Returns:
!        -1. IF ARG1 and ARG2 are of opposite sign.
!         0. IF either argument is zero.
!        +1. IF ARG1 and ARG2 are of the same sign.
!
!     The object is to DO this without multiplying ARG1*ARG2, to avoid
!     possible over/underflow problems.
!
!  Fortran INTRINSICs used:  SIGN.
!
! ----------------------------------------------------------------------
!
!  Programmed by:  Fred N. Fritsch,  FTS 532-4275, (415) 422-4275,
!                  Mathematics and Statistics Division,
!                  Lawrence Livermore National Laboratory.
!
!  Change record:
!     82-08-05   Converted to SLATEC library version.
!
! ----------------------------------------------------------------------
!
!  Programming notes:
!
!     To produce a Double precision version, simply:
!        a. Change PCHST to DPCHST wherever it occurs,
!        b. Change all references to the fortran intrinsics to their
!           Double presision equivalents,
!        c. Change the Real declarations to Double precision, and
!        d. Change the constants  ZERO  and  ONE  to Double precision.
!***END PROLOGUE  PCHST
!
!  DECLARE LOCAL VARIABLES.
!
      DATA ZERO/0/
      DATA ONE/1/
!
!  PERFORM THE TEST.
!
!***FIRST EXECUTABLE STATEMENT  PCHST
      PCHST = SIGN(ONE,ARG1)*SIGN(ONE,ARG2)
      IF (ARG1==ZERO .OR. ARG2==ZERO) PCHST = ZERO
!
      RETURN
!------------- LAST LINE OF PCHST FOLLOWS ------------------------------
      END FUNCTION PCHST


      subroutine setprob
      implicit double precision (a-h,o-z)
      character*25 fname

      common /compsi/ pi
      common /comvt/ tperiod,pi2

c
c     # compute pi, used in psi.f
      pi = 4.d0 * datan(1.d0)
c
c     # save 2*pi and tperiod in common block for use in b4step2:
c
      pi2 = 2.d0*pi
c
      iunit = 7
      fname = 'setprob.data'
c     # open the unit with new routine from Clawpack 4.4 to skip over
c     # comment lines starting with #:
      call opendatafile(iunit, fname)

      read(7,*) tperiod

      return
      end


 !***********************************************************************************
    SUBROUTINE SortTemplate (imult)
    !c----------------------------------------------------------------------
    !c
    !c----------------------------------------------------------------------
    use varmod
    implicit none

    ! Declare dummy arguments
    INTEGER, INTENT(IN) :: imult

    ! Declare local variables
    INTEGER :: ind,n
    REAL :: xx,yy,zz,hsqd,cont
    REAL, DIMENSION(MAXNOD) :: tmp
    real, DIMENSION(MAXNOD) :: e,f,g,h

    CALL SetRotMat(imult)

    DO ind=1,nltemplate
        xx=ixtemplate(ind)
        yy=iytemplate(ind)
        zz=iztemplate(ind)
        hsqd = 0.0
        DO n=1,3
            cont=rotmat(n,1)*xx+rotmat(n,2)*yy+rotmat(n,3)*zz
            hsqd = hsqd + cont*cont
        END DO
        tmp(ind) = hsqd
    END DO

    call sortem(1,nltemplate,tmp,3,ixtemplate,iytemplate,iztemplate,e,f,g,h)

    end subroutine SortTemplate
    !***********************************************************************************


! output:
! d-> 00000, t-> 00001, h-> 0001, s-> 0010,
! c-> 00110, x-> 00111, m-> 0100, o-> 0101,
! n-> 011, u-> 10000, l-> 10001, a-> 1001,
! r-> 10100, g-> 101010, p-> 101011,
! e-> 1011, i-> 1100, f-> 1101,  -> 111
!
! 00001|0001|1100|0010|111|1100|0010|111|1001|011|
! 111|1011|00111|1001|0100|101011|10001|1011|111|
! 1101|0101|10100|111|0001|10000|1101|1101|0100|
! 1001|011|111|1011|011|00110|0101|00000|1100|011|101010|
!
module huffman
implicit none
type node
  character (len=1 ), allocatable :: sym(:)
  character (len=10), allocatable :: code(:)
  integer                         :: freq
contains
  procedure                       :: show => show_node
end type

type queue
  type(node), allocatable :: buf(:)
  integer                 :: n = 0
contains
  procedure :: extractmin
  procedure :: append
  procedure :: siftdown
end type

contains

subroutine siftdown(this, a)
  class (queue)           :: this
  integer                 :: a, parent, child
  associate (x => this%buf)
  parent = a
  do while(parent*2 <= this%n)
    child = parent*2
    if (child + 1 <= this%n) then
      if (x(child+1)%freq < x(child)%freq ) then
        child = child +1
      end if
    end if
    if (x(parent)%freq > x(child)%freq) then
      x([child, parent]) = x([parent, child])
      parent = child
    else
      exit
    end if
  end do
  end associate
end subroutine

function extractmin(this) result (res)
  class(queue) :: this
  type(node)   :: res
  res = this%buf(1)
  this%buf(1) = this%buf(this%n)
  this%n = this%n - 1
  call this%siftdown(1)
end function

subroutine append(this, x)
  class(queue), intent(inout) :: this
  type(node)                  :: x
  type(node), allocatable     :: tmp(:)
  integer                     :: i
  this%n = this%n +1
  if (.not.allocated(this%buf)) allocate(this%buf(1))
  if (size(this%buf)<this%n) then
    allocate(tmp(2*size(this%buf)))
    tmp(1:this%n-1) = this%buf
    call move_alloc(tmp, this%buf)
  end if
  this%buf(this%n) = x
  i = this%n
  do
    i = i / 2
    if (i==0) exit
    call this%siftdown(i)
  end do
end subroutine

function join(a, b) result(c)
  type(node)             :: a, b, c
  integer                :: i, n, n1
  n1 = size(a%sym)
  n = n1 + size(b%sym)
  c%freq = a%freq + b%freq
  allocate (c%sym(n), c%code(n))
  do i = 1, n1
    c%sym(i) = a%sym(i)
    c%code(i) = "0" // trim(a%code(i))
  end do
  do i = 1, size(b%sym)
    c%sym(i+n1) = b%sym(i)
    c%code(i+n1) = "1" // trim(b%code(i))
  end do
end function

subroutine show_node(this)
  class(node) :: this
  integer     :: i
  write(*, "(*(g0,'-> ',g0,:,', '))", advance="no") &
   (this%sym(i), trim(this%code(i)), i=1,size(this%sym))
  print *
end subroutine

function create(letter, freq) result (this)
  character :: letter
  integer   :: freq
  type(node) :: this
  allocate(this%sym(1), this%code(1))
  this%sym(1) = letter ; this%code(1) = ""
  this%freq = freq
end function
end module

program main
  use huffman
  character (len=*), parameter   :: txt = &
   "this is an example for huffman encoding"
  integer                        :: i, freq(0:255) = 0
  type(queue)                    :: Q
  type(node)                     :: x
  do i = 1, len(txt)
    freq(ichar(txt(i:i))) = freq(ichar(txt(i:i))) + 1
  end do
  do i = 0, 255
    if (freq(i)>0) then
      call Q%append(create(char(i), freq(i)))
    end if
  end do
  do i = 1, Q%n-1
    call Q%append(join(Q%extractmin(),Q%extractmin()))
  end do
  x = Q%extractmin()
  call x%show()
  do i = 1, len(txt)
    do k = 1, size(x%sym)
      if (x%sym(k)==txt(i:i)) exit
     end do
     write (*, "(a,'|')", advance="no")  trim(x%code(k))
  end do
  print *
end program


************************************************************************
* Build B-matrices
*
* Build the B-matrix blocks in the system matrix by exact evaluation.
* This is possible due to the fact that the pressure basis functions
* are piecewise constant and the velocity basis functions
* piecewise linear. So there is an exact quadrature rule!
*
* Works only if Q1~ is used!
*
* In:
*   NEL,
*   NVT,
*   NMT,
*   KVERT,
*   KMID,
*   KADJ,
*   DCORVG  - usual geometry information
*   B1      - array [1..2*NMT] of double
*             Memory for first B-matrix block
*   B2      - array [1..2*NMT] of double
*             Memory for 2nd B-matrix block
*   KCOLB   - array [1..2*NMT] of double
*             Memory for column structure
*   KLDB    - array [1..NMT+1] of double
*             Memory for row structure structure
*
* Out:
*   NB      - Number of entries in the B-matrices
*   B1      - The first NB entries are filled with data
*   B2      - The first NB entries are filled with data
*   KCOL    - The first NB entries are filled with data
*   B1      - Is filled with data
*
* After calling this routine, if the caller allocated memory for the
* B-matrices dynamically, the memory for B1,B2,KCOL can be released
* except for the actual NB entries.
************************************************************************

      SUBROUTINE BBUILD(KVERT,KMID,KADJ,DCORVG,B1,B2,KCOLB,KLDB,
     *                  NB,NEL,NVT,NMT)

      IMPLICIT NONE

C Common blocks

      INCLUDE 'cbasictria.inc'
      INCLUDE 'cout.inc'

C parameters

      INTEGER KVERT(NNVE,*),KMID(NNVE,*),KADJ(NNVE,*)
      DOUBLE PRECISION DCORVG(2,*)
      INTEGER KCOLB(*),KLDB(*)

      INTEGER NB,NEL,NVT,NMT

C local variables

      INTEGER ILD, IADJ, IVEN, IMID, IVT, IVTN, IEL, IVE

      DOUBLE PRECISION B1(*),B2(*)
      DOUBLE PRECISION PX, PY, PXN, PYN, DN1, DN2

      ILD=0

C Loop through all elements

      DO IEL=1,NEL

C On each element loop through the vertices

        DO IVE=1,NNVE

C What's the neighbour element next to the edge
C starting with our current vertex?

          IADJ=KADJ(IVE,IEL)
          IF ((IADJ.LE.0).OR.(IADJ.GE.IEL)) THEN

C What's the next vertex = endpoint of our current edge?

            IVEN=IVE+1
            IF (IVEN.EQ.5) IVEN=1

C Calculate the number of our current vertex, the neighbour
C vertex and the midpoint inbetween...

            IMID=KMID (IVE ,IEL)-NVT
            IVT =KVERT(IVE ,IEL)
            IVTN=KVERT(IVEN,IEL)

C Then the coordinates of the two vertices

            PX =DCORVG(1,IVT)
            PY =DCORVG(2,IVT)
            PXN=DCORVG(1,IVTN)
            PYN=DCORVG(2,IVTN)

C and the length of the edge in X- and Y-direction, resp.

            DN1=-PYN+PY
            DN2= PXN-PX

C calculate the value in the B-matrix in the current row
C by exact quadrature

            ILD=ILD+1
            KLDB (IMID)=ILD
            KCOLB(ILD )=IEL
            B1   (ILD )=DN1
            B2   (ILD )=DN2

            IF (IADJ.GT.0) THEN
              ILD=ILD+1
              KCOLB(ILD)= IADJ
              B1   (ILD)=-DN1
              B2   (ILD)=-DN2
            END IF

          END IF ! ((IADJ.LE.0).OR.(IADJ.GE.IEL))

        END DO ! IVE

      END DO ! IEL

      NB         =ILD
      KLDB(NMT+1)=ILD+1

      END

************************************************************************
* Matrix multiplication routine with B-matrix, matrix-free
*
* Build the matrix-vector-product with the B-matrices elementwise,
* i.e. without existing B-matrices. This realizes IPRECB=2.
*
* Can only be used with Q1~/Q0 !
*
* In:
*   NEL,NVT,NMT,
*   KVERT,
*   KMID,
*   KADJ,
*   DCORVG - usual geometry information
*   DP     - array [1..NEL] of double
*            Pressure vector
*   DF1    - array [1..NMT] of double
*            Velocity/RHS vector, 1st component
*   DF2    - array [1..NMT] of double
*            Velocity/RHS vector, 2nd component
*   A1     - multiplication factor for DF1
*   A2     - multiplication factor for DF2
*
* Out:
*   DFx = A1*Bx*DP + A2*DFx
************************************************************************

      SUBROUTINE BMUL1 (KVERT,KMID,KADJ,DCORVG,DP,DF1,DF2,
     *                  NEL,NVT,NMT,A1,A2)

      IMPLICIT NONE

C Common blocks

      INCLUDE 'cbasictria.inc'

C parameters

      INTEGER KVERT(NNVE,*),KMID(NNVE,*),KADJ(NNVE,*)
      DOUBLE PRECISION DCORVG(2,*)
      INTEGER NEL,NVT,NMT
      DOUBLE PRECISION DP(NEL),DF1(NMT),DF2(NMT),A1,A2

C local variables

      INTEGER IEL, IVE, IVEN, IMID, IVT, IVTN, IADJ
      DOUBLE PRECISION PX, PY, PXN, PYN, DN1, DN2

C     Loop over the elements

      DO IEL=1,NEL

C       Loop over the vertices

        DO IVE=1,NNVE

          IADJ=KADJ(IVE,IEL)

          IF ((IADJ.LE.0).OR.(IADJ.GE.IEL)) THEN

C           Build the entry of the B-matrix by exact quadrature
C           (which luckily exists for Q1~/Q0), like in BBUILD above:

            IVEN=IVE+1
            IF (IVEN.EQ.5) IVEN=1

            IMID=KMID (IVE ,IEL)-NVT
            IVT =KVERT(IVE ,IEL)
            IVTN=KVERT(IVEN,IEL)

            PX =DCORVG(1,IVT)
            PY =DCORVG(2,IVT)
            PXN=DCORVG(1,IVTN)
            PYN=DCORVG(2,IVTN)

            DN1=-PYN+PY
            DN2= PXN-PX

C           Calculate the matrix-vector product

            IF (IADJ.GT.0) THEN
              DF1(IMID)=A2*DF1(IMID)+A1*DN1*(DP(IEL)-DP(IADJ))
              DF2(IMID)=A2*DF2(IMID)+A1*DN2*(DP(IEL)-DP(IADJ))
            ELSE
              DF1(IMID)=A2*DF1(IMID)+A1*DN1*DP(IEL)
              DF2(IMID)=A2*DF2(IMID)+A1*DN2*DP(IEL)
            ENDIF

          END IF ! ((IADJ.LE.0).OR.(IADJ.GE.IEL))

        END DO ! IVE

      END DO ! IEL

      END

************************************************************************
* Matrix multiplication routine. Multiply with B^T, matrix-free.
*
* Build the matrix-vector-product with the B^T-matrices elementwise,
* i.e. without existing B-matrices. This realizes IPRECB=2.
*
* Can only be used with Q1~/Q0 !
*
* In:
*   NEL,NVT,NMT,
*   KVERT,
*   KMID,
*   KADJ,
*   DCORVG - usual geometry information
*   DU1    - array [1..NMT] of double
*            Velocity/RHS vector, 1st component
*   DU2    - array [1..NMT] of double
*            Velocity/RHS vector, 2nd component
*   A1     - multiplication factor for DF1
*
* Out:
*   DFP    - array [1..NEL] of double
*            DFP  =  A1*B^T*DU  =  A1 * (B1^T*DU1 + B2^T*DU2)
************************************************************************

      SUBROUTINE BTMUL1(KVERT,KMID,KADJ,DCORVG,DU1,DU2,DFP,
     *                  NEL,NVT,NMT,A1)

      IMPLICIT NONE

C Common blocks

      INCLUDE 'cbasictria.inc'

C parameters

      INTEGER KVERT(NNVE,*),KMID(NNVE,*),KADJ(NNVE,*)
      DOUBLE PRECISION DCORVG(2,*)
      INTEGER NEL,NVT,NMT
      DOUBLE PRECISION DU1(NMT),DU2(NMT),DFP(NEL),A1

C local variables

      INTEGER IEL, IVE, IVEN, IMID, IVT, IVTN
      DOUBLE PRECISION PX, PY, PXN, PYN, DN1, DN2

C     Loop over the elements

      DO IEL=1,NEL

        DFP(IEL)=0D0

C       Loop over the vertices

        DO IVE=1,NNVE

C         Build the matrix entry as in BBUILD:

          IVEN=IVE+1
          IF (IVEN.EQ.5) IVEN=1

          IMID=KMID (IVE ,IEL)-NVT
          IVT =KVERT(IVE ,IEL)
          IVTN=KVERT(IVEN,IEL)

          PX =DCORVG(1,IVT)
          PY =DCORVG(2,IVT)
          PXN=DCORVG(1,IVTN)
          PYN=DCORVG(2,IVTN)

          DN1=-PYN+PY
          DN2= PXN-PX

          DFP(IEL)=DFP(IEL)+A1*(DN1*DU1(IMID)+DN2*DU2(IMID))

        END DO ! IVE

      END DO ! IEL

      END


PROGRAM rwfnplot
   IMPLICIT NONE

   INTEGER, PARAMETER:: NPTS0 = 5000

   DOUBLE PRECISION pg(NPTS0), qg(NPTS0), rg(NPTS0), pgg(NPTS0)
   DOUBLE PRECISION rg2(NPTS0)
   DOUBLE PRECISION energy, a0
   CHARACTER title*6, orbl*4, nnstr*2, new*3, xa*3, el*5
   CHARACTER leg*50, format_string*50, name*100
   DIMENSION el(30)
   INTEGER np, lp, jp, nn, laky, ll, jj, npts, j, i, nwf

   write (*, *) 'RWFNPLOT'
   write (*, *) 'Program to generate Matlab/GNU Octave and'
   write (*, *) 'Xmgrace files that plot radial orbitals'
   write (*, *) 'Input file:  name.w'
   write (*, *) 'Output files: octave_name.m, xmgrace_name.agr'
   write (*, *)
   write (*, *) 'To plot orbital: press enter'
   write (*, *) 'To remove orbital: type "d" or "D" and press enter'
   write (*, *)
   write (*, *) '                             Jorgen Ekman Jun 2015'
   write (*, *)

   WRITE (*, *) 'Name of state:'
   READ (*, *) name
   OPEN (3, FILE=trim(name)//'.w', STATUS='OLD', FORM='UNFORMATTED')
   OPEN (4, FILE='octave_'//trim(name)//'.m', STATUS='UNKNOWN')
   OPEN (8, FILE='xmgrace_'//trim(name)//'.agr', STATUS='UNKNOWN')

   write (*, *)
   write (*, *) 'To have r on x-axis: type "y" otherwise "n" for sqrt(r)'
   read (*, *) xa
   write (*, *)
   i = 1

   write (4, *) '%     r                   P(r)                   Q(r)'

   ! Xmgrace stuff
   if (xa .eq. 'y  ') then
      write (8, *) '@    xaxis  label "r"'
   else
      write (8, *) '@    xaxis  label "sqrt(r)"'
   end if
   write (8, *) '@    yaxis  label "P(r)"'
   write (8, *) '#     r                   P(r)                   Q(r)'

   write (4, *) 'clf'
   READ (3) title
   IF (title .NE. 'G92RWF') THEN   ! Extra safety
      PRINT *, 'title = ', title, 'does not match G92RWF'
      STOP
   ENDIF

   DO
      READ (3, END=20) nn, laky, energy, npts
      write (nnstr, '(I2)') nn
      IF (laky .GT. 0) THEN
         ll = laky
         jj = -1
      ELSEIF (laky .LE. -1) THEN
         ll = -laky - 1
         jj = 1
      ELSE
         WRITE (*, *) 'Unexpected case in reading mcdf.w'
         STOP
      ENDIF

      if (jj .eq. 1) then
         if (ll .eq. 0) orbl = nnstr//'s '
         if (ll .eq. 1) orbl = nnstr//'p '
         if (ll .eq. 2) orbl = nnstr//'d '
         if (ll .eq. 3) orbl = nnstr//'f '
         if (ll .eq. 4) orbl = nnstr//'g '
         if (ll .eq. 5) orbl = nnstr//'h '
         if (ll .eq. 6) orbl = nnstr//'i '
         if (ll .eq. 7) orbl = nnstr//'k '
         if (ll .eq. 8) orbl = nnstr//'l '
         if (ll .eq. 9) orbl = nnstr//'m '
      else
         if (ll .eq. 1) orbl = nnstr//'p-'
         if (ll .eq. 2) orbl = nnstr//'d-'
         if (ll .eq. 3) orbl = nnstr//'f-'
         if (ll .eq. 4) orbl = nnstr//'g-'
         if (ll .eq. 5) orbl = nnstr//'h-'
         if (ll .eq. 6) orbl = nnstr//'i-'
         if (ll .eq. 7) orbl = nnstr//'k-'
         if (ll .eq. 8) orbl = nnstr//'l-'
         if (ll .eq. 9) orbl = nnstr//'m-'
      end if

      IF (npts .GT. NPTS0) THEN
         WRITE (*, *) 'df2hf: npts .GT. NPTS0'
         STOP
      ENDIF

      READ (3) a0, (pg(j), j=1, npts), (qg(j), j=1, npts)
      READ (3) (rg(j), j=1, npts)

      WRITE (*, '(2x,A,A,$)') orbl, ' = '
      READ (*, '(A)') new
      IF (NEW .NE. 'd  ' .AND. NEW .NE. 'D  ') THEN
         el(i) = orbl

         ! Xmgrace stuff
         if (i - 1 .lt. 10) then
            format_string = "(A,I1,3A)"
         else
            format_string = "(A,I2,3A)"
         end if
         write (leg, format_string) &
            '@    s', i - 1, '  legend  "', el(i), '"'
         write (8, *) trim(leg)
         write (8, *) '# ', el(i)

         i = i + 1
         write (4, *) 'P = ['
         DO j = 1, npts
            rg2(j) = sqrt(rg(j))
            if (xa .eq. 'y  ') then
               if (abs(pg(j)) .gt. 0.0005 .OR. j .EQ. 1) &
                  WRITE (4, '(3D20.10)') rg(j), pg(j), qg(j)
               WRITE (8, '(3D20.10)') rg(j), pg(j), qg(j)
            else
               if (abs(pg(j)) .gt. 0.0005 .OR. j .EQ. 1) &
                  WRITE (4, '(3D20.10)') rg2(j), pg(j), qg(j)
               WRITE (8, '(3D20.10)') rg2(j), pg(j), qg(j)
            end if
         ENDDO
         write (8, *)
         write (4, *) '];'
         write (4, *) 'plot(P(:,1), P(:,2))'
         write (4, *) 'hold all'
      ENDIF
   ENDDO

20 CONTINUE

   nwf = i - 1

   if (xa .eq. 'y  ') then
      write (4, *) 'xlabel (''r'')'
   else
      write (4, *) 'xlabel (''sqrt(r)'')'
   end if

   write (4, *) 'ylabel (''P(r)'')'
   write (4, *) 'grid on'
   write (4, 101, advance='no') 'legend('
   DO i = 1, nwf
      IF (i .LT. nwf) THEN
         write (4, 102, advance='no') '''', el(i), ''','
      ELSE
         write (4, 102, advance='no') '''', el(i), ''')'
      END IF
   ENDDO
101 format(a)
102 format(3a)
   PRINT *, ' Finished.'
   STOP
END


!*==zlascl.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022

!> \brief \b ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZLASCL + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          TYPE
!       INTEGER            INFO, KL, KU, LDA, M, N
!       DOUBLE PRECISION   CFROM, CTO
!       ..
!       .. Array Arguments ..
!       COMPLEX*16         A( LDA, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZLASCL multiplies the M by N complex matrix A by the real scalar
!> CTO/CFROM.  This is done without over/underflow as long as the final
!> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!> A may be full, upper triangular, lower triangular, upper Hessenberg,
!> or banded.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TYPE
!> \verbatim
!>          TYPE is CHARACTER*1
!>          TYPE indices the storage type of the input matrix.
!>          = 'G':  A is a full matrix.
!>          = 'L':  A is a lower triangular matrix.
!>          = 'U':  A is an upper triangular matrix.
!>          = 'H':  A is an upper Hessenberg matrix.
!>          = 'B':  A is a symmetric band matrix with lower bandwidth KL
!>                  and upper bandwidth KU and with the only the lower
!>                  half stored.
!>          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
!>                  and upper bandwidth KU and with the only the upper
!>                  half stored.
!>          = 'Z':  A is a band matrix with lower bandwidth KL and upper
!>                  bandwidth KU. See ZGBTRF for storage details.
!> \endverbatim
!>
!> \param[in] KL
!> \verbatim
!>          KL is INTEGER
!>          The lower bandwidth of A.  Referenced only if TYPE = 'B',
!>          'Q' or 'Z'.
!> \endverbatim
!>
!> \param[in] KU
!> \verbatim
!>          KU is INTEGER
!>          The upper bandwidth of A.  Referenced only if TYPE = 'B',
!>          'Q' or 'Z'.
!> \endverbatim
!>
!> \param[in] CFROM
!> \verbatim
!>          CFROM is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[in] CTO
!> \verbatim
!>          CTO is DOUBLE PRECISION
!>
!>          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
!>          without over/underflow if the final result CTO*A(I,J)/CFROM
!>          can be represented without over/underflow.  CFROM must be
!>          nonzero.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
!>          storage type.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M);
!>             TYPE = 'B', LDA >= KL+1;
!>             TYPE = 'Q', LDA >= KU+1;
!>             TYPE = 'Z', LDA >= 2*KL+KU+1.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          0  - successful exit
!>          <0 - if INFO = -i, the i-th argument had an illegal value.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup complex16OTHERauxiliary
!
!  =====================================================================
      SUBROUTINE ZLASCL(Type,Kl,Ku,Cfrom,Cto,M,N,A,Lda,Info)
      IMPLICIT NONE
!*--ZLASCL148
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Type
      INTEGER Info , Kl , Ku , Lda , M , N
      DOUBLE PRECISION Cfrom , Cto
!     ..
!     .. Array Arguments ..
      COMPLEX*16 A(Lda,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
!     ..
!     .. Local Scalars ..
      LOGICAL done
      INTEGER i , itype , j , k1 , k2 , k3 , k4
      DOUBLE PRECISION bignum , cfrom1 , cfromc , cto1 , ctoc , mul ,   &
     &                 smlnum
!     ..
!     .. External Functions ..
      LOGICAL LSAME , DISNAN
      DOUBLE PRECISION DLAMCH
      EXTERNAL LSAME , DLAMCH , DISNAN
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , MIN
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
!
      IF ( LSAME(Type,'G') ) THEN
         itype = 0
      ELSEIF ( LSAME(Type,'L') ) THEN
         itype = 1
      ELSEIF ( LSAME(Type,'U') ) THEN
         itype = 2
      ELSEIF ( LSAME(Type,'H') ) THEN
         itype = 3
      ELSEIF ( LSAME(Type,'B') ) THEN
         itype = 4
      ELSEIF ( LSAME(Type,'Q') ) THEN
         itype = 5
      ELSEIF ( LSAME(Type,'Z') ) THEN
         itype = 6
      ELSE
         itype = -1
      ENDIF
!
      IF ( itype==-1 ) THEN
         Info = -1
      ELSEIF ( Cfrom==ZERO .OR. DISNAN(Cfrom) ) THEN
         Info = -4
      ELSEIF ( DISNAN(Cto) ) THEN
         Info = -5
      ELSEIF ( M<0 ) THEN
         Info = -6
      ELSEIF ( N<0 .OR. (itype==4 .AND. N/=M) .OR. (itype==5 .AND. N/=M)&
     &         ) THEN
         Info = -7
      ELSEIF ( itype<=3 .AND. Lda<MAX(1,M) ) THEN
         Info = -9
      ELSEIF ( itype>=4 ) THEN
         IF ( Kl<0 .OR. Kl>MAX(M-1,0) ) THEN
            Info = -2
         ELSEIF ( Ku<0 .OR. Ku>MAX(N-1,0) .OR.                          &
     &            ((itype==4 .OR. itype==5) .AND. Kl/=Ku) ) THEN
            Info = -3
         ELSEIF ( (itype==4 .AND. Lda<Kl+1) .OR.                        &
     &            (itype==5 .AND. Lda<Ku+1) .OR.                        &
     &            (itype==6 .AND. Lda<2*Kl+Ku+1) ) THEN
            Info = -9
         ENDIF
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZLASCL',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 .OR. M==0 ) RETURN
!
!     Get machine parameters
!
      smlnum = DLAMCH('S')
      bignum = ONE/smlnum
!
      cfromc = Cfrom
      ctoc = Cto
      DO
!
         cfrom1 = cfromc*smlnum
         IF ( cfrom1==cfromc ) THEN
!        CFROMC is an inf.  Multiply by a correctly signed zero for
!        finite CTOC, or a NaN if CTOC is infinite.
            mul = ctoc/cfromc
            done = .TRUE.
            cto1 = ctoc
         ELSE
            cto1 = ctoc/bignum
            IF ( cto1==ctoc ) THEN
!           CTOC is either 0 or an inf.  In both cases, CTOC itself
!           serves as the correct multiplication factor.
               mul = ctoc
               done = .TRUE.
               cfromc = ONE
            ELSEIF ( ABS(cfrom1)>ABS(ctoc) .AND. ctoc/=ZERO ) THEN
               mul = smlnum
               done = .FALSE.
               cfromc = cfrom1
            ELSEIF ( ABS(cto1)>ABS(cfromc) ) THEN
               mul = bignum
               done = .FALSE.
               ctoc = cto1
            ELSE
               mul = ctoc/cfromc
               done = .TRUE.
            ENDIF
         ENDIF
!
         IF ( itype==0 ) THEN
!
!        Full matrix
!
            DO j = 1 , N
               DO i = 1 , M
                  A(i,j) = A(i,j)*mul
               ENDDO
            ENDDO
!
         ELSEIF ( itype==1 ) THEN
!
!        Lower triangular matrix
!
            DO j = 1 , N
               DO i = j , M
                  A(i,j) = A(i,j)*mul
               ENDDO
            ENDDO
!
         ELSEIF ( itype==2 ) THEN
!
!        Upper triangular matrix
!
            DO j = 1 , N
               DO i = 1 , MIN(j,M)
                  A(i,j) = A(i,j)*mul
               ENDDO
            ENDDO
!
         ELSEIF ( itype==3 ) THEN
!
!        Upper Hessenberg matrix
!
            DO j = 1 , N
               DO i = 1 , MIN(j+1,M)
                  A(i,j) = A(i,j)*mul
               ENDDO
            ENDDO
!
         ELSEIF ( itype==4 ) THEN
!
!        Lower half of a symmetric band matrix
!
            k3 = Kl + 1
            k4 = N + 1
            DO j = 1 , N
               DO i = 1 , MIN(k3,k4-j)
                  A(i,j) = A(i,j)*mul
               ENDDO
            ENDDO
!
         ELSEIF ( itype==5 ) THEN
!
!        Upper half of a symmetric band matrix
!
            k1 = Ku + 2
            k3 = Ku + 1
            DO j = 1 , N
               DO i = MAX(k1-j,1) , k3
                  A(i,j) = A(i,j)*mul
               ENDDO
            ENDDO
!
         ELSEIF ( itype==6 ) THEN
!
!        Band matrix
!
            k1 = Kl + Ku + 2
            k2 = Kl + 1
            k3 = 2*Kl + Ku + 1
            k4 = Kl + Ku + 1 + M
            DO j = 1 , N
               DO i = MAX(k1-j,k2) , MIN(k3,k4-j)
                  A(i,j) = A(i,j)*mul
               ENDDO
            ENDDO
!
         ENDIF
!
         IF ( done ) EXIT
      ENDDO
!
!
!     End of ZLASCL
!
      END SUBROUTINE ZLASCL


PROGRAM xchstwo
!C     driver for routine chstwo
INTEGER n
PARAMETER(n=10)
INTEGER i
REAL chsq,df,prob
real a1(n),a2(n)
! idum=-17
! do j=1,NBINS
!   bins1(j)=0.0
!   bins2(j)=0.0
! enddo
! do i=1,NPTS
!   x=expdev(idum)
!   ibin=x*NBINS/3.0+1
!   if (ibin.le.NBINS) bins1(ibin)=bins1(ibin)+1.0
!   x=expdev(idum)
!   ibin=x*NBINS/3.0+1
!   if (ibin.le.NBINS) bins2(ibin)=bins2(ibin)+1.0
! enddo
a2(i)=0.
do i=1,n
	a1(i)=i+1
	a2(i+2)=i+1
enddo

call chstwo(a1,a2,n,0,df,chsq,prob)
write(*,'(1x,t10,a,t25,a)') 'Dataset 1','Dataset 2'
do i=1,n
  write(*,'(1x,2f15.2)') a1(i),a2(i)
enddo
write(*,'(/1x,t10,a,e12.4)') 'Chi-squared:',chsq
write(*,'(1x,t10,a,e12.4)') 'Probability:',prob
write(*,*)df
END

include 'gser.f90'
include 'gcf.f90'
include 'gammq.f90'
include 'gammln.f90'
include 'chstwo.f90'
include 'ran1.f90'
include 'expdev.f90'


MODULE TimeSteppingModule_SSPRK

  USE KindModule, ONLY: &
    DP, Zero, One
  USE ProgramHeaderModule, ONLY: &
    iX_B0, iX_B1, iX_E0, iX_E1, &
    nDOFX
  USE ScalarFieldsModule, ONLY: &
    nSF, iSF_u, iSF_v

  IMPLICIT NONE
  PRIVATE

  INTEGER :: nStages_SSPRK
  REAL(DP), DIMENSION(:),   ALLOCATABLE :: c_SSPRK
  REAL(DP), DIMENSION(:),   ALLOCATABLE :: w_SSPRK
  REAL(DP), DIMENSION(:,:), ALLOCATABLE :: a_SSPRK

  REAL(DP), DIMENSION(:,:,:,:,:),   ALLOCATABLE :: U_SSPRK
  REAL(DP), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: D_SSPRK

  LOGICAL :: Verbose

  PUBLIC :: InitializeScalarWave_SSPRK
  PUBLIC :: UpdateScalarWave_SSPRK
  PUBLIC :: FinalizeScalarWave_SSPRK

  INTERFACE
    SUBROUTINE ScalarWaveIncrement &
      ( iX_B0, iX_E0, iX_B1, iX_E1, U, dU )
      USE KindModule, ONLY: DP
      INTEGER,  INTENT(in)           :: &
        iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
      REAL(DP), INTENT(inout)        :: &
        U (:,iX_B1(1):,iX_B1(2):,iX_B1(3):,:)
      REAL(DP), INTENT(out)          :: &
        dU(:,iX_B1(1):,iX_B1(2):,iX_B1(3):,:)
    END SUBROUTINE ScalarWaveIncrement
  END INTERFACE

CONTAINS

  SUBROUTINE InitializeScalarWave_SSPRK( nStages, Verbose_Option )

    INTEGER, INTENT(in)           :: nStages
    LOGICAL, INTENT(in), OPTIONAL :: Verbose_Option

    INTEGER :: i

    IF( PRESENT( Verbose_Option ) )THEN
      Verbose = Verbose_Option
    ELSE
       Verbose = .TRUE.
    END IF

    nStages_SSPRK = nStages

    CALL InitializeSSPRK( nStages )

    IF( Verbose )THEN
      WRITE(*,*)
      WRITE(*,'(A5,A,I1)') '', 'SSP RK Scheme: ', nStages

      WRITE(*,*)
      WRITE(*,'(A5,A)') '', 'Butcher Table:'
      WRITE(*,'(A5,A)') '', '--------------'
      DO i = 1, nStages
        WRITE(*,'(A5,4ES14.4E3)') '', c_SSPRK(i), a_SSPRK(i,1:nStages)
      END DO
      WRITE(*,'(A5,A14,3ES14.4E3)') '', '', w_SSPRK(1:nStages)
      WRITE(*,*)
    END IF

    ALLOCATE( U_SSPRK &
                (1:nDOFX, &
                 iX_B1(1):iX_E1(1), &
                 iX_B1(2):iX_E1(2), &
                 iX_B1(3):iX_E1(3), &
                 1:nSF) )

    ALLOCATE( D_SSPRK &
                (1:nDOFX, &
                 iX_B1(1):iX_E1(1), &
                 iX_B1(2):iX_E1(2), &
                 iX_B1(3):iX_E1(3), &
                 1:nSF,1:nStages) )

  END SUBROUTINE InitializeScalarWave_SSPRK

  SUBROUTINE FinalizeScalarWave_SSPRK

    DEALLOCATE( a_SSPRK, c_SSPRK, w_SSPRK )

    DEALLOCATE( U_SSPRK, D_SSPRK )

  END SUBROUTINE FinalizeScalarWave_SSPRK

  SUBROUTINE InitializeSSPRK( nStages )

    INTEGER, INTENT(in) :: nStages

    INTEGER :: iS

    CALL AllocateButcherTables_SSPRK( nStages )

    SELECT CASE ( nStages )
      CASE ( 1 )

        a_SSPRK(1,1) = 0.0_DP
        w_SSPRK(1)   = 1.0_DP

      CASE ( 2 )

        a_SSPRK(1,1:2) = [ 0.0_DP, 0.0_DP ]
        a_SSPRK(2,1:2) = [ 1.0_DP, 0.0_DP ]
        w_SSPRK(1:2)   = [ 0.5_DP, 0.5_DP ]

      CASE ( 3 )

        a_SSPRK(1,1:3) = [ 0.00_DP, 0.00_DP, 0.00_DP ]
        a_SSPRK(2,1:3) = [ 1.00_DP, 0.00_DP, 0.00_DP ]
        a_SSPRK(3,1:3) = [ 0.25_DP, 0.25_DP, 0.00_DP ]
        w_SSPRK(1:3)   = [ 1.0_DP / 6.0_DP, &
                           1.0_DP / 6.0_DP, &
                           2.0_DP / 3.0_DP ]

    END SELECT

    DO iS = 1, nStages
      c_SSPRK(iS) = SUM( a_SSPRK(iS,1:iS-1) )
    END DO

  END SUBROUTINE InitializeSSPRK

  SUBROUTINE AllocateButcherTables_SSPRK( nStages )

    INTEGER, INTENT(in) :: nStages

    ALLOCATE( a_SSPRK(nStages,nStages) )
    ALLOCATE( c_SSPRK(nStages) )
    ALLOCATE( w_SSPRK(nStages) )

    a_SSPRK = Zero
    c_SSPRK = Zero
    w_SSPRK = Zero

  END SUBROUTINE AllocateButcherTables_SSPRK

  SUBROUTINE UpdateScalarWave_SSPRK &
    ( t, dt, U, ComputeIncrement_ScalarWave )

    REAL(DP), INTENT(in) :: &
      t, dt
    REAL(DP), INTENT(inout) :: &
      U(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    PROCEDURE(ScalarWaveIncrement) :: &
      ComputeIncrement_ScalarWave

    INTEGER :: iS, jS

    U_SSPRK = Zero ! --- State
    D_SSPRK = Zero ! --- Increment

    DO iS = 1, nStages_SSPRK

      U_SSPRK = U

      DO jS = 1, iS - 1

        IF( a_SSPRK(iS,jS) .NE. Zero )THEN

          CALL AddIncrement_ScalarWave &
                 ( One, U_SSPRK, dt * a_SSPRK(iS,jS), D_SSPRK(:,:,:,:,:,jS) )
        END IF

      END DO

      IF( ANY( a_SSPRK(:,iS) .NE. Zero ) &
          .OR. ( w_SSPRK(iS) .NE. Zero ) )THEN

        CALL ComputeIncrement_ScalarWave &
               ( iX_B0, iX_E0, iX_B1, iX_E1, U_SSPRK, D_SSPRK(:,:,:,:,:,iS) )

      END IF

    END DO

    DO iS = 1, nStages_SSPRK

      IF( w_SSPRK(iS) .NE. Zero )THEN

        CALL AddIncrement_ScalarWave &
               ( One, U, dt * w_SSPRK(iS), D_SSPRK(:,:,:,:,:,iS) )

      END IF

    END DO

  END SUBROUTINE UpdateScalarWave_SSPRK

  SUBROUTINE AddIncrement_ScalarWave( alpha, U, beta, D )

    REAL(DP), INTENT(in)    :: &
      alpha, beta
    REAL(DP), INTENT(inout) :: &
      U(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(in)    :: &
      D(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)

    INTEGER :: iSF, iX1, iX2, iX3

    DO iSF = 1, nSF
      DO iX3 = iX_B0(3), iX_E0(3)
        DO iX2 = iX_B0(2), iX_E0(2)
          DO iX1 = iX_B0(1), iX_E0(1)

            U(:,iX1,iX2,iX3,iSF) &
              = alpha * U(:,iX1,iX2,iX3,iSF) &
                  + beta * D(:,iX1,iX2,iX3,iSF)

          END DO
        END DO
      END DO
    END DO

  END SUBROUTINE AddIncrement_ScalarWave

END MODULE TimeSteppingModule_SSPRK


      subroutine onedinit( a, b, f, nx, s, e )
      integer nx, s, e
      double precision a(0:nx+1, s-1:e+1), b(0:nx+1, s-1:e+1), &
                       f(0:nx+1, s-1:e+1)
!
      integer i, j
!
      do j=s-1,e+1
         do i=0,nx+1
            a(i,j) = 0.0d0
            b(i,j) = 0.0d0
            f(i,j) = 0.0d0
         enddo
      enddo
!
!    Handle boundary conditions
!
      do j=s,e
         a(0,j) = 1.0d0
         b(0,j) = 1.0d0
         a(nx+1,j) = 0.0d0
         b(nx+1,j) = 0.0d0
      enddo
      if (s .eq. 1) then
         do i=1,nx
            a(i,0) = 1.0d0
            b(i,0) = 1.0d0
         enddo
      endif
!
      return
      end


module sorting_subroutines
implicit none
contains

subroutine CPU(start1)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)

real(dp), intent(in) :: start1
real(dp) :: finish1, time1

call cpu_time(finish1)
time1 = finish1 - start1
write(3,*) 'CPU TIME:', time1

end subroutine CPU

subroutine bubble_sort(jobs2, energies2, njobs2)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)

integer, allocatable, dimension(:), intent(inout) :: jobs2
real(dp), allocatable, dimension(:), intent(inout) :: energies2
integer, intent(in) :: njobs2
integer :: i, test, x, y, j
real(dp) :: start2, a, b

call cpu_time(start2)

test = 0
j = 1
do while (test .eq. 0)
   test = 1
   do i = njobs2 - 1, 1, -1
      if ( energies2(i) .lt. energies2(i+1) ) then
         a = energies2(i)
         b = energies2(i+1)
         energies2(i + 1) = a
         energies2(i) = b
         x = jobs2(i)
         y = jobs2(i + 1)
         jobs2(i + 1) = x
         jobs2(i) = y
         test = 0
      end if
   end do
   write(3,*)
   write(3,*) 'pass-bubble', j
   write(3,*)
   do i = 1, njobs2
      write(3, *) 'energy', energies2(i), 'job_order', jobs2(i)
   end do
   j = j + 1
end do

open(unit=30, file='bubble.txt', status='replace', action='write')

write(30,*) 'pass-bubble', j
write(30,*)
do i = 1, njobs2
   write(30, *) 'energy', energies2(i), 'job_order', jobs2(i)
end do

close(30)

call CPU(start2)

end subroutine bubble_sort

subroutine first_and_last(jobs3, energies3, njobs3)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
integer, allocatable, dimension(:), intent(inout) :: jobs3
real(dp), allocatable, dimension(:), intent(inout) :: energies3
integer, intent(in) :: njobs3
real(dp), allocatable, dimension(:) :: work
integer, dimension(1) :: k
integer :: dim_work,  x, y, i, j
real(dp) :: start3, a, b

call cpu_time(start3)

i = 0
dim_work = njobs3

do while (dim_work .gt. 1)
   allocate ( work(dim_work) )
   do j = 1, dim_work
      work(j) = energies3(i + j)
   end do

   !---------------------
   !maxima:
   !--------------------

   k = maxloc(work)
   write(3,*) 'k-max', k
   !
   !energies:
   !
   a = energies3(i + k(1))
   b = energies3(i + 1)
   energies3(i + 1) = a
   energies3(i + k(1)) = b
   !
   a = work(k(1))
   b = work(1)
   work(1) = a
   work(k(1)) = b
   !
   !jobs:
   !
   x = jobs3(i + k(1))
   y = jobs3(i + 1)
   jobs3(i + 1) = x
   jobs3(i + k(1)) = y

   !--------------------
   !minima:
   !---------------------

   k = minloc(work)
   write(3,*) 'k-min', k
   !
   !energies:
   !
   a = energies3(i + k(1))
   b = energies3(i + dim_work)
   energies3(i + dim_work) = a
   energies3(i + k(1)) = b
   !
   !jobs:
   !
   x = jobs3(i + k(1))
   y = jobs3(i + dim_work)
   jobs3(i + dim_work) = x
   jobs3(i + k(1)) = y

   deallocate(work)
   write(3,*)
   write(3,*) 'pass-first-and-last', i
   write(3,*)
   do j = 1, njobs3
      write(3, *) 'energy', energies3(j), 'job_order', jobs3(j)
   end do
   dim_work = dim_work - 2
   write(*,*) 'dim_work', dim_work
   i = i + 1
   write(*,*) 'i', i
end do

open(unit=40, file='half-and-half.txt', status='replace', action='write')

write(40,*) 'pass-first-and-last', i
write(40,*)
do j = 1, njobs3
   write(40, *) 'energy', energies3(j), 'job_order', jobs3(j)
end do

close(40)

call CPU(start3)

end subroutine first_and_last

end module sorting_subroutines


module Mod_sup_ComputeTisig
contains
   subroutine sup_ComputeTiSig(e,lambda,visac,vnorm,grvel,staco,chale,auxG,auxPTT,gpsig,tisig)
      use typre
      use Mod_Element
      implicit none
      class(FiniteElement) :: e
      integer(ip), intent(in)    :: auxPTT
      real(rp),    intent(in)    :: staco(4),grvel(e%ndime,e%ndime),auxG
      real(rp),    intent(in)    :: visac,lambda,gpsig((e%ndime-1)*(e%ndime-1)+2)
      real(rp),    intent(in)    :: vnorm,chale(2)
      real(rp),    intent(out)   :: tisig
      real(rp)                   :: freq1,freq2,freq3,freq4,freqT,gradnorm,signorm
      real(rp)                   :: auto1,auto2,raiz,auxlamb,auxchale,traza,expo,h1
      integer(ip)                :: idime,jdime,auxtens

   !Initialization
   auto1=0.0_rp
   auto2=0.0_rp
   freq1=0.0_rp
   freq2=0.0_rp
   freq3=0.0_rp
   freq4=0.0_rp
   traza = 0.0_rp

   auxtens=(e%ndime-1)*(e%ndime-1)+2

   expo=1
   !second invariant of velocity gradient
      gradnorm=0.0_rp
      do idime=1,e%ndime

         traza = traza + gpsig(idime)

         do jdime=1,e%ndime
            gradnorm=gradnorm + grvel(idime,jdime)&
             *(grvel(idime,jdime))

         end do
      end do
      gradnorm=0.5_rp*(gradnorm)**(0.5_rp)

      signorm=0.0_rp

      if(e%ndime==2)then
         signorm = gpsig(1)*gpsig(1) + gpsig(2)*gpsig(2) + 2.0_rp*gpsig(3)*gpsig(3)
      elseif(e%ndime==3)then
         signorm = gpsig(1)*gpsig(1) + gpsig(2)*gpsig(2) + gpsig(3)*gpsig(3) &
               + 2.0_rp*gpsig(4)*gpsig(4) + 2.0_rp*gpsig(5)*gpsig(5) + 2.0_rp*gpsig(6)*gpsig(6)
      endif

      signorm = 0.5_rp*(signorm)**(0.5_rp)

      signorm = signorm*auxPTT + (1_ip - auxPTT)*abs(traza)

!      Using the max-eigenvalue
!
!      raiz=(grvel(1,1)+grvel(2,2))*(grvel(1,1)+grvel(2,2)) - 4.0_rp*((grvel(1,1)+grvel(2,2))-(grvel(2,1)*grvel(1,2)))
!      auxlamb= 0.5_rp*(grvel(1,1)+grvel(2,2))
!      if(raiz>=0.0_rp)then
!       auto1= auxlamb + sqrt(raiz)
!       auto2= auxlamb - sqrt(raiz)
!       auto1=auto1*auto1
!       auto2=auto2*auto2
!      elseif(raiz<0.0_rp)then
!       auto1=auxlamb*auxlamb + raiz*raiz
!       auto2=auxlamb*auxlamb + raiz*raiz
!      endif
!       gradnorm=max(auto1,auto2)
!       gradnorm=sqrt(gradnorm)

      auxchale=max(chale(1),chale(2))
      h1=chale(1)
      !h1=0.1_rp

      ! Characteristic velocity
      freq1 = (1.0_rp/(staco(3)*2.0_rp*visac)) !to control grad_sym
      freq2 = staco(4)*(lambda/(2.0_rp*visac))*(vnorm/((h1/e%npol)**(1.0_rp)))
      freq3 = staco(4)*(lambda/visac)*(gradnorm)
      freq4 = staco(2)*auxG*(lambda/(2.0_rp*visac))*signorm

      freqT = (freq1) + (freq2) + (freq3) + (freq4)
      !initialization
      tisig=0.0_rp

      !Compute the stability parameter
      tisig=freqT**(-expo)

   end subroutine

   subroutine sup_LCR_ComputeTisig(e,lambda,lambda0,auxG,beta,visac,vnorm,grvel,ExpGpPsi_Matrix,staco,chale,auxPTT,gpsig,freq2,freq3,tisig)
      use typre
      use Mod_Element
      implicit none
      class(FiniteElement) :: e
      integer(ip), intent(in)    :: auxPTT
      real(rp),    intent(in)    :: staco(4),grvel(e%ndime,e%ndime),ExpGpPsi_Matrix(e%ndime,e%ndime)
      real(rp),    intent(in)    :: visac,lambda,gpsig((e%ndime-1)*(e%ndime-1)+2),lambda0, auxG
      real(rp),    intent(in)    :: vnorm,chale(2),beta
      real(rp),    intent(out)   :: tisig, freq2, freq3
      real(rp)                   :: freq1,freq2b,freq4,freqT,gradnorm,signorm, Omeganorm, exponorm,exponegnorm
      real(rp)                   :: auto1,auto2,raiz,auxlamb,auxchale,traza,h,vcarac,h1
      real(rp)                   :: ExpMatrix(e%ndime,e%ndime)
      integer(ip)                :: idime,jdime,expo,auxtens,i

      !Initialization
      auto1=0.0_rp
      auto2=0.0_rp
      freq1=0.0_rp
      freq2=0.0_rp
      freq2b=0.0_rp
      freq3=0.0_rp
      freq4=0.0_rp
      expo=1
      auxtens=(e%ndime-1)*(e%ndime-1)+2

      !second invariant of velocity gradient
      exponorm=0.0_rp
      gradnorm=0.0_rp
      expMatrix = 0.0_rp

      do i=1,e%ndime
         ExpMatrix(i,i)=ExpGpPsi_Matrix(i,i)-1.0_rp
      end do

      do idime=1,e%ndime
         do jdime=1,e%ndime

            exponorm  = exponorm  + ExpMatrix(idime,jdime)*ExpMatrix(idime,jdime)
            gradnorm=gradnorm + grvel(idime,jdime)&
             *(grvel(idime,jdime))

         end do
      end do

      exponorm=0.5_rp*(exponorm)**(0.5_rp)
      gradnorm=0.5_rp*(gradnorm)**(0.5_rp)

      h=chale(1)

      ! Characteristic velocity
      freq1 = 1.0_rp/(2.0_rp*staco(3)*visac*(1-beta))
      freq2 = staco(4)*(lambda/(2.0_rp*visac*(1.0_rp-beta)))*(vnorm/((h/e%npol)**(1.0_rp)))
      freq3 = staco(4)*(lambda/(visac*(1.0_rp-beta)))*gradnorm
      freq4 = staco(2)*auxG*(lambda0/(visac*(1.0_rp-beta)))*exponorm   !GIESEKUSLCR

      freqT = freq1 + freq2 + freq3 + freq4

      !initialization
      tisig=0.0_rp

      !Compute the stability parameter
      tisig=freqT**(-expo)

   end subroutine

end module


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine input_Ac
  use global_variables
  implicit none
  integer :: ix
  real(8) :: tt

  E0_1=5.338d-9*sqrt(Iwcm2_1)
  omega_1 = omega_ev_1/(2d0*Ry)
  tpulse_1 = tpulse_fs_1/0.02418d0
  E0_2=5.338d-9*sqrt(Iwcm2_2)
  omega_2 = omega_ev_2/(2d0*Ry)
  tpulse_2 = tpulse_fs_2/0.02418d0
  Tdelay = Tdelay_fs/0.02418d0

  Ez = 0d0; Ez_old = 0d0
  do ix = Nx_L,Nx_R

    tt = - xn(ix)/clight -0.5d0*tpulse_1
    if(abs(tt ) < tpulse_1*0.5d0 )then
      Ez(ix) = E0_1*cos(omega_1*tt)*cos(pi*tt/Tpulse_1)**2 &
        - E0_1/omega_1*sin(omega_1*tt)*pi/tpulse_1*sin(2d0*pi*tt/tpulse_1)
    end if
    tt = - xn(ix)/clight -0.5d0*tpulse_1 - dt
    if(abs(tt ) < tpulse_1*0.5d0 )then
      Ez_old(ix) = E0_1*cos(omega_1*tt)*cos(pi*tt/Tpulse_1)**2 &
        - E0_1/omega_1*sin(omega_1*tt)*pi/tpulse_1*sin(2d0*pi*tt/tpulse_1)
    end if

  end do

end subroutine input_Ac


      module module_cbmz_initmixrats
      use module_peg_util
      integer, parameter :: cbmz_init_wrf_mixrats_flagaa = 1
      contains
      subroutine cbmz_init_wrf_mixrats( &
               config_flags, &
               z_at_w, g, &
               chem, numgas, &
               ids,ide, jds,jde, kds,kde, &
               ims,ime, jms,jme, kms,kme, &
               its,ite, jts,jte, kts,kte )
   USE module_configure, only: grid_config_rec_type, num_chem, &
 p_o3, p_ald, p_hc3, p_hc5, p_hc8, p_ket, p_oli, p_olt, p_ora2, &
    p_hcl, p_par
   USE module_state_description, only: param_first_scalar, &
                        gas_ic_pnnl
   USE module_input_chem_data, only: bdy_chem_value
   IMPLICIT NONE
   INTEGER, INTENT(IN) :: numgas, &
                          ids,ide, jds,jde, kds,kde, &
                          ims,ime, jms,jme, kms,kme, &
                          its,ite, jts,jte, kts,kte
   REAL, INTENT(IN) :: g
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
         INTENT(IN) :: z_at_w
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
         INTENT(INOUT) :: chem
   TYPE(grid_config_rec_type), INTENT(IN) :: config_flags
 integer i, j, k, kp1
    real, dimension( its:ite, kts:kte, jts:jte ) :: z
 if (cbmz_init_wrf_mixrats_flagaa <= 0) return
    do j = jts, min(jte,jde-1)
       do k = kts, kte
          kp1 = min(k+1, kte)
          do i = its, min(ite,ide-1)
             z(i,k,j) = (z_at_w(i,k,j)+z_at_w(i,kp1,j))*0.5
          end do
       end do
    end do
 do j = jts, min(jte,jde-1)
 do k = kts, kte
 do i = its, min(ite,ide-1)
       if( z(i,k,j) <= 1000. ) then
          chem(i,k,j,p_hcl) = 0.4*1e-3
       elseif( z(i,k,j) > 1000. &
            .and. z(i,k,j) <= 2500. ) then
          chem(i,k,j,p_hcl) = (0.4*1e-3) + (z(i,k,j)-1000.)* &
               ((0.1*1e-3)-(0.4*1e-3)) / (2500.-1000.)
       else
          chem(i,k,j,p_hcl) = 0.1*1e-3
       end if
    end do
    end do
    end do
 return
 end subroutine cbmz_init_wrf_mixrats
 end module module_cbmz_initmixrats
 subroutine bdy_chem_value_cbmz ( chem_bv, z, nch, numgas )
 use module_configure, only: grid_config_rec_type, &
     p_o3, p_ald, p_hc3, p_hc5, p_hc8, p_ket, p_oli, &
     p_olt, p_ora2, p_hcl, p_par
 use module_input_chem_data, only: bdy_chem_value
 implicit none
 REAL, INTENT(OUT) :: chem_bv
 REAL, INTENT(IN) :: z
 INTEGER, INTENT(IN) :: nch
    INTEGER, INTENT(IN) :: numgas
 real chem_bv_ald, chem_bv_hc3, chem_bv_hc5, &
      chem_bv_hc8, chem_bv_ket, chem_bv_oli, &
      chem_bv_olt, chem_bv_ora2
 real, parameter :: chem_bv_def = 1.0e-20
    if( nch == p_hcl ) then
       if( z <= 1000. ) then
          chem_bv = 0.4*1e-3
       elseif( z > 1000. &
            .and. z <= 2500. ) then
          chem_bv = (0.4*1e-3) + (z-1000.)* &
               ((0.1*1e-3)-(0.4*1e-3)) / (2500.-1000.)
       else
          chem_bv = 0.1*1e-3
       end if
    else if( nch == p_par ) then
       call bdy_chem_value( chem_bv_ald, z, p_ald, numgas )
       call bdy_chem_value( chem_bv_hc3, z, numgas+1+1, numgas )
       call bdy_chem_value( chem_bv_hc5, z, numgas+1+2, numgas )
       call bdy_chem_value( chem_bv_hc8, z, numgas+1+3, numgas )
       call bdy_chem_value( chem_bv_ket, z, p_ket, numgas )
       call bdy_chem_value( chem_bv_oli, z, p_oli, numgas )
       call bdy_chem_value( chem_bv_olt, z, p_olt, numgas )
       call bdy_chem_value( chem_bv_ora2, z, p_ora2, numgas )
       chem_bv = 0.4*chem_bv_ald + 2.9*chem_bv_hc3 &
            + 4.8*chem_bv_hc5 + 7.9*chem_bv_hc8 &
            + 0.9*chem_bv_ket + 2.8*chem_bv_oli &
            + 1.8*chem_bv_olt + 1.0*chem_bv_ora2
    else
       chem_bv = chem_bv_def
    end if
 return
 end subroutine bdy_chem_value_cbmz


C=======================================================================
C  SATFLO, Subroutine, J.T. Ritchie
C  Calculates saturated flow on days with no rain or irrigation.
!-----------------------------------------------------------------------
C  Notes  : Saturated flow is calculated for days with no irr or rain.
C           Drainage is reduced when the flux exceeds the rate allowed
C           by the saturated soil hydraulic conductivity, assuming unit
C           gradient.  This allows for perched water tables in profile.
C           Prevents flux from exceeding the most limiting layer below
C           it.  If the sat. hyd. cond values are missing (neg) assume
C           no perching of water table.
!-----------------------------------------------------------------------
C  REVISION HISTORY
C  01/01/1989 JR  Written
C  11/01/1987 GH
C  12/05/1993 NBP Made into subroutine
C  07/02/1997 WDB ADDED TILE DRAIN FLOW
!  10/13/1997 CHP Modified for modular format.
!  10/29/2001 CHP Removed read stmts for soil info.  These variables
!                 now come from soil module.
!-----------------------------------------------------------------------
!  Called by: WATBAL
!  Calls:     None
C=======================================================================

      SUBROUTINE SATFLO(
     &    DLAYR, DUL, NLAYR, SAT, SW, SWCN, SWCON,        !Input
     &    DRAIN, DRN, SWDELTS)                            !Output

!     ------------------------------------------------------------------
      USE ModuleDefs     !Definitions of constructed variable types,
                         ! which contain control information, soil
                         ! parameters, hourly weather data.
!     NL defined in ModuleDefs.for

      IMPLICIT NONE

      INTEGER L, NLAYR
      REAL DRAIN, HOLD, SWCON, SWOLD
      REAL DLAYR(NL), DRMX(NL), DRN(NL), DUL(NL), SAT(NL), SW(NL),
     &        SWCN(NL), SWDELTS(NL), SWTEMP(NL)

!-----------------------------------------------------------------------
      DO L = 1, NLAYR
        DRN(L) = 0.0
        SWDELTS(L) = 0.0
        SWTEMP(L) = SW(L)
      ENDDO
!-----------------------------------------------------------------------

      DO L = 1,NLAYR
        DRN(L) = 0.0
        DRMX(L) = 0.0

        IF (SWTEMP(L) .GE. (DUL(L) + 0.003)) THEN
          DRMX(L) = (SWTEMP(L) - DUL(L)) * SWCON * DLAYR(L)
          DRMX(L) = MAX(0.0, DRMX(L))
        ENDIF

        IF (L .EQ. 1) THEN
          DRN(L) = DRMX(L)
        ELSE
          HOLD = 0.0
          IF (SWTEMP(L) .LT. DUL(L))
     &        HOLD = (DUL(L) - SWTEMP(L)) * DLAYR(L)
          DRN(L) = MAX(DRN(L-1) + DRMX(L) - HOLD,0.0)
        ENDIF

!       Failed experiment -- too many problems with zero SWCN and
!         historic soil profiles
!       IF (SWCN(L) .GE. 0.0 .AND. DRN(L) .GT. SWCN(L)*24.0)
        IF (SWCN(L) .GT. 0.0 .AND. DRN(L) .GT. SWCN(L)*24.0)
     &    DRN(L) = SWCN(L) * 24.0

!        IF (DRN(L) .GT. 0.0) IDRSW = 1
      ENDDO

C     Compute volumetric water contents after drainage in a day.
C     Prevent water content in any layer from exceeding saturation
C     as water drains down in the profile.

      DO L = NLAYR, 2, -1
        SWOLD = SWTEMP(L)
        SWTEMP(L) = SWTEMP(L) + (DRN(L-1) - DRN(L)) / DLAYR(L)
        IF (SWTEMP(L) .GT. SAT(L)) THEN
          DRN(L-1) = MAX(0.0,(SAT(L) - SWOLD) * DLAYR(L) + DRN(L))
          SWTEMP(L) = SAT(L)
        ENDIF
      ENDDO

      SWTEMP(1) = SWTEMP(1) - DRN(1) / DLAYR(1)
      DRAIN = DRN(NLAYR) * 10.0
!-----------------------------------------------------------------------
!     Calculate flux in soil water content due to infiltration and
!         saturated flow.
!-----------------------------------------------------------------------
      DO L = 1, NLAYR
        SWDELTS(L) = SWTEMP(L) - SW(L)
      ENDDO

      RETURN
      END SUBROUTINE SATFLO

!-----------------------------------------------------------------------
!     SATFLO VARIABLE DEFINITIONS:  updated 2/19/2004
!-----------------------------------------------------------------------
! DLAYR(L)   Thickness of soil layer L (cm)
! DRAIN      Drainage rate from soil profile (mm/d)
! DRMX(L)    Calculated maximum saturated flow from layer L (cm/d)
! DRN(L)     Drainage rate through soil layer L (cm/d)
! DUL(L)     Volumetric soil water content at Drained Upper Limit in soil
!              layer L (cm3[water]/cm3[soil])
! HOLD       Amount of water a soil layer will hold above it's present
!              level, used to calculate downward flow; also, temporary
!              variable/ intermediate calculation (cm)
! NLAYR      Actual number of soil layers
! SAT(L)     Volumetric soil water content in layer L at saturation
!             (cm3 [water] / cm3 [soil])
! SW(L)      Volumetric soil water content in layer L
!             (cm3 [water] / cm3 [soil])
! SWCN(L)    Saturated hydraulic conductivity in layer L (cm/hr)
! SWCON      Soil water conductivity constant; whole profile drainage rate
!              coefficient (1/d)
! SWDELTS(L) Change in soil water content due to drainage in layer L
!             (cm3 [water] / cm3 [soil])
! SWOLD      Previous soil water content prior to capillary flow from layer
!             (cm3/cm3)
! SWTEMP(L)  Soil water content in layer L (temporary value to be modified
!              based on drainage, root uptake and upward flow through soil
!              layers). (cm3/cm3)
!----------------------------------------------------------------------
!     END SUBROUTINE SATFLO
!=======================================================================


C KROSSPE evalua la opacidad de Rosseland a una T y Pe dadas
c escribe tambien la presion gaseosa, la densidad y el peso molecular medio
c escribe tambien la presion de las particulas neutras (pn)
c y sqrt[(1.+M)/mui]=sqrt(1./mui + 1./mun) donde M=mui/mun con
c mui=peso del ion medio
c mun=peso de la particula neutra media

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

        real*4 t,pe,pp(10),pmusum,kappa,lambda,mui,mun,pn
        real*8 suma,kross,pesomedio,asum,cgases
        real*8 dt0,dt,dpe0,dpe,dpg,dpp(10),dro,dkappa
	character*100 fichabun
        common/fichabun/fichabun
        common/constantes/g,avog	!gravedad,n. avogadro

	g=2.7414e+4	!gravedad cm/s^2 en fotosfera solar
       	avog=6.022045e23
        sigma=5.67e-5  !cte de Stefan Boltzmann erg /(s cm^2 K^4)
        cgases=83144087.d0
        pi=3.1415916

        fichabun='THEVENIN'

	pmusum=0.0
        asum=0.0
	do i=1,92
  	   ii=i
	   call neldatb(ii,0.,wgt,abu,ei1,ei2)
	   pmusum=pmusum+wgt*abu
           asum=asum+abu
	end do
c  pesomedio=pmusum/(asum+ne/nH) !ne/nH=pp(8)

        dpe0=1.e-6
        dt0=2500.d0
        open(2,file='fich_2500_22500.datos')

         do k=1,151    !1,151 indices en pe  desde 10^-6 hasta 10^9 paso .1

           dpe=dpe0*10**((k-1)*.1)
           pe=dpe
           print*,k
          do j=1,201 ! 1,201 T desde 2500 a 22500 con paso 100
c                           do j=1,4
              dt=dt0+(j-1)*100.
c                            dt=5040./(0.5+j*0.3)
              t=dt
              call gase(dt,dpe,dpg,dpp,mui,mun,pn)

              pesomedio=pmusum/(asum+dpp(8))

              dro=(dpg*pesomedio)/(dt*cgases)
              do iii=1,10
                 pp(iii)=dpp(iii)
              end do

  	      pasol=.05
              suma=0.
              kappa=1.e20
             do il=1,1001  !desde 50 A hasta 50000A con paso 50A
                lambda=(.05+(il-1.)*pasol)*1.e-5
                bt=dt_planck(t,lambda)  !derivada de B con respecto a T
                call k_nu(t,pe,pp,pmusum,lambda,kappa)
                dkappa=dble(kappa)
                if(dkappa.lt.1.d-40)dkappa=1.d-40
                if(dkappa.gt.1.d40)dkappa=1.d40
                suma=suma+(bt*pasol*1.d-5)/dkappa
             end do
             kross=(4.*sigma*(dt**3.)/pi)/suma
	     coef=sqrt(1./mui + 1./mun)
             write(2,*) dt,dpe,dpg,dro,pesomedio,kross,pn,coef

cc	      print*,dlog10(dpg),5040./dt,mui,mui/mun,pg,15+0.93*dlog10(dpe/dpg)
c              if(j.eq.1. or. j.eq.131)then
c                 print*,k,j,t,pe,dpg,dro,pesomedio,kross
c              end if
           end do
	end do
        close(1)

        end

c________________________________________________________________

c K_NU evalua la opacidad a una T, ro y lambda(cm)  dadas

	subroutine k_nu(t,pe,pp,pmusum,lambda,kappa)

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

	real*4 pp(10),t,pe,d1(10),lambda,kappa,kac

        common/constantes/g,avog	!gravedad,n. avogadro

        do i=1,10
           d1(i)=0
        end do

	call kappach(lambda,t,pe,pp,d1,d1,kac,d2,d2)
        kappa=kac*avog/pmusum  !cm^2/gr

        return
        end

c________________________________________________________________

c	dt_planck es una funcion que calcula la derivada de la funcion
c	de planck con respecto a la temperatura

	real*4 function dt_planck(t,lambda)
	real*4 t,lambda,c1,c2,d4,b,ex,dplnck

	c1=1.1910627e-5		!1./(2*h*c**2) con lambda en cm
	c2=1.43879
	d4=lambda*lambda*lambda*lambda
	b=dplnck(t,lambda)
	ex=c2/(lambda*t)
        if(ex .lt. 9) then
      	   dt_planck=(c2*b*b*d4*exp(ex))/(c1*t*t)
        else
       	   dt_planck=(c2*b)/(lambda*t*t)
        end if

c        print*,lambda,ex,b,dt_planck

	return
	end