program test
    use SuperSorting

    integer :: a(34),a1(17),a2(17)
    integer :: i

    a = [1,3,11,6,2,15,54,12,23,66,30,7,8,65,17,12,14,4,6,67,38,8,27,28,18,43,15,2,9,8,23,45,15,23]

    ! Remove comment for testing
    !call insertionsort(a)
    !write(*,*) a

    ! Remove comment for testing
    !a = mergesort([1,3,6],[2,7,8])
    !write(*,*) a

    call timsort(a)

    do i = 1,size(a,1)
        write(*,*) i,a(i)
    end do
end program


C File: arrays-basic-03.f
C This program has a simple 1-D array with the default lower bound of 1
C that is accessed in a non-sequential order using a second array.

      program main
      implicit none

C     array and idx are 1-D arrays of integers with an implicit
C     lower-bound = 1 upper bound = 10
      integer, dimension(10) :: array, idx
      integer :: i

      do i = 1, 10
          array(i) = i*i    ! array() holds the values
      end do

      do i = 1, 5
          idx(i) = 2*i      ! idx() is used to index into array()
          idx(i+5) = 2*i-1
      end do

      do i = 1, 10
          write (*,10) array(idx(i))
      end do

 10   format(I5)

      stop
      end program main


#SET<sort><quick_sort_recursive>#
!> @ingroup #<sort><name>##ord#
!>
!> @brief
!> Run #<sort><docRef># on a vector of #<data><full># values.
!>
!> @details
!> Run #<ord><docRef># on a vector of #<data><full># values to sort them in the specified order.#IF<map><true>THEN<The vector of intergers map is permuted in the same way that the vector #<data><var># is permuted to be sorted. It is important that #<map><var># be at least as long as #<data><var>#.>ENDIF#
!>
!> @param #<data><var>#
!> The vector #<data><full># values to be sorted.
!>
#IF<map><true>#!> @param #<map><var>#
#IF<map><true>#!> Vector of intergers which is permuted in the same way that #<data><var># is permuted. If #<map><var># is a vector of values 1 to N, where N is the length of #<data><var>#, than, #<map><var># is the map from #<data><var>#'s original value to #<data><var>#'s final value after the sort.
#IF<map><true>#!>
#IF<ord><gen>#!> @param #<ord><var>#
#IF<ord><gen>#!> A logical function which describes the ordering used. The function must take two #<data><full># arguments and return true if and only if the first argument must proceed the second argument in the order.
#IF<ord><gen>#!>
#IF<ord><gen>#!> @warning
#IF<ord><gen>#!> The argument types and counts of #<ord><var># are not checked within this subroutine.
#IF<ord><gen>#!>
#IF<map><true>#!> @warning
#IF<map><true>#!> The length of #<map><var># is not checked within this subroutine. If the length of #<data><var># is larger than the length of #<map><var>#, than this subroutine may attempt to access elements outside of #<map><var>#.
#IF<map><true>#!>
!> @author Arin R. Bratt
!> @date 11/07/2014
#IF<ord><gen>THEN<>ELSE<pure >ENDIF#subroutine #<sort><name>##ord##map##data#(#<data><var>##<map><arg>##<ord><arg>#)
  ! Arguments
  #<data><full>#, intent(inout) :: #<data><var>#(:)
  #IF<map><true>#integer, intent(inout) :: #<map><var>#(:)
  #IF<ord><gen>#procedure(logical) :: #<ord><var>#

  ! Variables
  integer :: low
  integer :: high
  integer :: low_eq
  integer :: high_eq
  #<data><full># :: pivot
  #<data><full># :: temp

  ! Go to interchange sort if list is small
  if (size(#<data><var>#,1) <= max_interchange_sort_size) then
     call interchange_sort#ord##map##data#(#<data><var>##<map><arg>##<ord><arg>#)
  else
     ! Initilize values
     low = 1
     high = size(#<data><var>#,1)
     low_eq = 1
     high_eq = size(#<data><var>#,1)

     ! Build pivot
     pivot = (#<data><var>#(low) + #<data><var>#(high)) / 2
     if (#ORD< #<data><var>#(low)><#<data><var>#(high)>#) then
        call swap(#<data><var>#(low),#<data><var>#(high))
        #IF<map><true>#call swap(#<map><var>#(low),#<map><var>#(high))
     end if

     ! Main loop with three way partition
     do
        ! Find pivot points
        do
           low = low + 1
           if (.not. #ORD<pivot><#<data><var>#(low)>#) exit
        end do
        do
           high = high - 1
           if (.not. #ORD<#<data><var>#(high)><pivot># .or. high == 1) exit
        end do

        ! Exit if they are on the wrong side of the pivot
        if (low >= high) exit

        ! Run main quick sort swap
        call swap(#<data><var>#(low),#<data><var>#(high))
        #IF<map><true>#call swap(#<map><var>#(low),#<map><var>#(high))

        ! Check for if values are equal to pivot, if so swap
        if (.not. #ORD<#<data><var>#(high)><pivot>#) then
           call swap(#<data><var>#(high),#<data><var>#(high_eq))
           #IF<map><true>#call swap(#<map><var>#(high),#<map><var>#(high_eq))
           high_eq = high_eq - 1
        end if

        if (.not. #ORD<pivot><#<data><var>#(low)>#) then
           call swap(#<data><var>#(low),#<data><var>#(low_eq))
           #IF<map><true>#call swap(#<map><var>#(low),#<map><var>#(low_eq))
           low_eq = low_eq + 1
        end if
     end do
     high = low - 1

     ! Move equals to the middle
     do while(1 < low_eq)
        low_eq = low_eq - 1
        call swap(#<data><var>#(low_eq),#<data><var>#(high))
        #IF<map><true>#call swap(#<map><var>#(low_eq),#<map><var>#(high))
        high = high - 1
     end do

     do while(high_eq < size(#<data><var>#,1))
        high_eq = high_eq + 1
        call swap(#<data><var>#(high_eq),#<data><var>#(low))
        #IF<map><true>#call swap(#<map><var>#(high_eq),#<map><var>#(low))
        low = low + 1
     end do

     ! Recursive calls
     if (size(#<data><var>#,1) - low > high - 1) then
        if (high > 1) call #<sort><name>##ord##map##data#(#<data><var>#(:high)#IF<map><true>THEN<,#<map><var>#(:high)>ENDIF##<ord><arg>#)
        if (low < size(#<data><var>#,1)) call #<sort><name>##ord##map##data#(#<data><var>#(low:)#IF<map><true>THEN<,#<map><var>#(low:)>ENDIF##<ord><arg>#)
     else
        if (low < size(#<data><var>#,1)) call #<sort><name>##ord##map##data#(#<data><var>#(low:)#IF<map><true>THEN<,#<map><var>#(low:)>ENDIF##<ord><arg>#)
        if (high > 1) call #<sort><name>##ord##map##data#(#<data><var>#(:high)#IF<map><true>THEN<,#<map><var>#(:high)>ENDIF##<ord><arg>#)
     end if
  end if
end subroutine #<sort><name>##ord##map##data#


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PROGRAM PROJ4
C     PROJECT 4: Partial-wave solution of quantum scattering
C  COMPUTATIONAL PHYSICS (FORTRAN VERSION)
C  by Steven E. Koonin and Dawn C. Meredith
C  Copyright 1989, Addison-Wesley Publishing Company Inc.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL INIT          !display header screen, setup parameters
5     CONTINUE           !main loop/ execute once for each set of param
        CALL PARAM       !get input from screen
        CALL ARCHON      !calculate total and differential cross section
      GOTO 5
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE ARCHON
C calculates differential and total cross section using
C partial-wave expansion; scattering is from a central potential
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.P4'
      INCLUDE 'IO.ALL'
C Local variables:
      INTEGER  L                  !which partial wave
      REAL DELTA(0:MAXL)          !phase shift
      REAL DELDEG(0:MAXL)         !phase shift in degrees
      REAL SIGMA(0:MAXL),SIGTOT   !total cross section
      REAL DSIGMA(0:MAXANG)       !differential cross section
      COMPLEX F(0:MAXANG)         !scattering amplitude
      REAL CD,SD                  !sins and cosines
      INTEGER ITHETA              !index the angle
      INTEGER NLINES              !number of lines written to terminal
      INTEGER DEVICE              !current graphics device
      INTEGER SCREEN              !send to terminal
      INTEGER PAPER               !make a hardcopy
      INTEGER FILE                !send to a file
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     output summary of parameters
      IF ((TTERM) .AND. (.NOT. GTERM)) CALL PRMOUT(OUNIT,NLINES)
      IF (TFILE) CALL PRMOUT(TUNIT,NLINES)
      IF (GFILE) CALL PRMOUT(GUNIT,NLINES)
C
C     find the phase shifts by integrating the time-indp Schrodinger eq.
      SIGTOT=0.
      DO 100 L=LSTART,LSTOP
        CALL NUMERV(L,DELTA)
        DELDEG(L)=180.0*DELTA(L)/PI
        SIGMA(L)=4*PI/K2*(2*L+1)*SIN(DELTA(L))**2
        SIGTOT=SIGTOT+SIGMA(L)
C
        IF (GTERM) THEN             !output results for this L value
            CALL GRFOUT(SCREEN,L,DELDEG(L),SIGMA(L))
        ELSE IF (TTERM) THEN
            CALL TXTOUT(OUNIT,NLINES,L,DELDEG(L),SIGMA(L))
        END IF
        IF (TFILE) CALL TXTOUT(TUNIT,NLINES,L,DELDEG(L),SIGMA(L))
100   CONTINUE
C
C     output data for all L
      IF ((TTERM) .AND. (GTERM)) CALL DELOUT(DELDEG,SIGMA)
C
C     calculate differential cross section by summing over partial waves
      DO 300 ITHETA=0,NANG
         F(ITHETA)=(0.,0.)
         DO 200 L=LSTART,LSTOP
            SD=SIN(DELTA(L))
            CD=COS(DELTA(L))
            F(ITHETA)=F(ITHETA)+(2*L+1)*SD*PL(L,ITHETA)*CMPLX(CD,SD)
200      CONTINUE
         F(ITHETA)=F(ITHETA)/K
         DSIGMA(ITHETA)=(ABS(F(ITHETA)))**2
300   CONTINUE
C
      IF (TTERM) CALL PAUSE('to see total cross sections...',1)
      IF (TTERM) CALL CLEAR
C
      IF (TTERM) CALL SIGOUT(OUNIT,F,DSIGMA,SIGTOT)
      IF (TFILE) CALL SIGOUT(TUNIT,F,DSIGMA,SIGTOT)
C
      IF (TTERM) CALL PAUSE('to continue...',1)
      IF (TTERM) CALL CLEAR
C
C     graphics output
      IF (GTERM) CALL GRFSIG(SCREEN,DSIGMA,SIGTOT)
      IF (GFILE) CALL GRFSIG(FILE,DSIGMA,SIGTOT)
      IF (GHRDCP) CALL GRFSIG(PAPER,DSIGMA,SIGTOT)
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      Subroutine NUMERV(L,DELTA)
C find the phase shifts DELTA for fixed L by integrating
C the radial wave equation (for both the scattered and free wave)
C using the Numerov algorithm
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.P4'
C Input/Output Variables:
      INTEGER  L               !which partial wave (input)
      REAL DELTA(0:MAXL)       !phase shift (output)
C Local Variables:
      REAL PSI(MAXN+MAXE),PSIF(MAXN+MAXE)   !wave functions
      REAL PSIMAX,PSFMAX       !maxima of wave functions
      REAL VEFF(MAXN+MAXE)     !effective pot for fixed L
      REAL CONST               !factor in Numerov algorithm
      REAL VFREE(MAXN+MAXE)    !centrifugal potential
      REAL KI,KIM1,KIP1        !Numerov coefficients for scatt wave
      REAL KIF,KIM1F,KIP1F     !Numerov coefficients for free wave
      REAL G,NUMER,DENOM       !factors to calculate phase shift
      REAL LL                  !useful constant for centrifugal pot
      INTEGER IR,MR            !index for radius
      COMMON/RESULT/PSI,PSIF,PSIMAX,PSFMAX,VEFF  !pass results to GRFOUT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CONST=DR*DR/HBARM/6         !useful constant
C
C     calculate the centrifugal barrier and effective potential
      LL=L*(L+1)*HBARM/2.0
      DO 200 IR=1,NPTS+NXTRA
         VFREE(IR)=LL/(R(IR)*R(IR))
         VEFF(IR)=V(IR)+VFREE(IR)
200   CONTINUE
C
C     beginning values for Numerov algorithm
C       we are finding both scattered and free wave functions
      PSI(1)=1E-25                   !scattered wave initial conditions
      KIM1=CONST*(E-VEFF(1))         !k of Numerov algorithm
      PSI(2)=(2.-12.*KIM1)*PSI(1)    !use information from the second
      KI=CONST*(E-VEFF(2))           ! derivative to get started
C
      PSIF(1)=1E-25                  !free wave initial conditions
      KIM1F=CONST*(E-VFREE(1))
      PSIF(2)=(2.-12.*KIM1F)*PSIF(1)
      KIF=CONST*(E-VFREE(2))
C
      DO 300 IR=2,NPTS+NXTRA-1
C
        KIP1=CONST*(E-VEFF(IR+1))        !scattered wave K
        PSI(IR+1)=((2-10*KI)*PSI(IR)-(1+KIM1)*PSI(IR-1))/(1+KIP1)
        IF (PSI(IR+1).GT.1E+15) THEN     !prevent overflows
            DO 400 MR=1,IR+1
400         PSI(MR)=PSI(MR)*0.00001
        ENDIF
        KIM1=KI                          !roll values
        KI=KIP1
C
        KIP1F=CONST*(E-VFREE(IR+1))      !free wave  K
        PSIF(IR+1)=((2-10*KIF)*PSIF(IR)-(1+KIM1F)*PSIF(IR-1))/(1+KIP1F)
        IF (PSIF(IR+1).GT.1E+15) THEN    !prevent overflows
           DO 500 MR=1,IR+1
500        PSIF(MR)=PSIF(MR)*0.00001
        ENDIF
        KIM1F=KIF                        !roll values
        KIF=KIP1F
C
300   CONTINUE
C
C     calculate delta (see Eq. IV.8)
      G=RMAX*PSI(NPTS+NXTRA)/((RMAX+RXTRA)*PSI(NPTS))
      NUMER=G*JL(1,L)-JL(2,L)
      DENOM=G*NL(1,L)-NL(2,L)
      DELTA(L)=ATAN(NUMER/DENOM)
      CALL FIXDEL(DELTA(L),PSI,PSIF,PSIMAX,PSFMAX) !fix delta absolutely
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE FIXDEL(DELTA,PSI,PSIF,PSIMAX,PSFMAX)
C resolves the ambiguity in DELTA using info from the wave functions
C PSI and PSIF; finds maxima in wave functions PSIMAX, PSIFMAX
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.P4'
C Passed Variables:
      REAL DELTA                          !phase shift (I/O)
      REAL PSI(MAXN+MAXE),PSIF(MAXN+MAXE) !wave functions (input)
      REAL PSIMAX,PSFMAX                  !max of wave functions(output)
C Local Variables:
      INTEGER BUMP,NODES,BUMPF,NODESF  !number of nodes and antinodes
      INTEGER I                        !radial index
      LOGICAL DPOS                     !is the phase shift positive?
      INTEGER N                        !how many factors of pi to add
C Function:
      REAL SGN                         !returns sign of argument
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     find number of maxima, nodes, and psimax for the scattered wave
      BUMP=0
      NODES=0
      PSIMAX=0.0
      DO 100 I=2,NPTS+NXTRA-1
         IF (SGN(PSI(I)) .NE. SGN(PSI(I-1))) NODES=NODES+1
         IF (ABS(PSI(I)).GT. PSIMAX) PSIMAX=ABS(PSI(I))
         IF ( SGN(PSI(I+1)-PSI(I)) .NE. SGN(PSI(I)-PSI(I-1)) )
     +        BUMP=BUMP+1
100   CONTINUE
C
C     find number of maxima, nodes, and psimax for the free wave
      BUMPF=0
      NODESF=0
      PSFMAX=0.0
      DO 200 I=2,NPTS+NXTRA-1
         IF (SGN(PSIF(I)) .NE. SGN(PSIF(I-1))) NODESF=NODESF+1
         IF (ABS(PSIF(I)).GT.PSFMAX) PSFMAX=ABS(PSIF(I))
         IF ( SGN(PSIF(I+1)-PSIF(I)) .NE. SGN(PSIF(I)-PSIF(I-1)) )
     +              BUMPF=BUMPF+1
200   CONTINUE
C
      DPOS=DELTA .GT. 0.0            !is the phase shift positive?
C
C     make sign of phase shift agree with convention
C     viz., an attractive potential has positive delta
      N=(NODES+BUMP-NODESF-BUMPF)
      IF (ATTRCT .AND. .NOT. DPOS) THEN
         N=(N+1)/2
      ELSE IF (.NOT. ATTRCT .AND. DPOS) THEN
         N=(N-1)/2
      ELSE
         N=N/2
      END IF
      DELTA=DELTA+N*PI
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      REAL FUNCTION SGN(X)
C returns the sign of x
      REAL X
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF (X.EQ.0) THEN
         SGN=0.0
      ELSE IF (X.LT.0) THEN
         SGN=-1.0
      ELSE IF (X.GT.0) THEN
         SGN=1.0
      ENDIF
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE POTNTL
C fill the array V for choice of potential
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.P4'
C Local variables:
      INTEGER IR                    !index for radius
      REAL U                        !temp value for Lenz-Jensen
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     save values of the radius
      DO 100 IR=1,NPTS+NXTRA
         R(IR)=IR*DR
100   CONTINUE
C
      IF (POT .EQ. LENZ) THEN       !Lenz-Jensen
        DO 200 IR=1,NPTS
          U=4.5397*Z6*SQRT(R(IR))
          V(IR)=-((Z*E2)/R(IR))*EXP(-U)*
     +        (1+U+U*U*(0.3344+U*(0.0485+0.002647*U)))
200     CONTINUE
        ATTRCT=.TRUE.
C
      ELSE IF (POT .EQ. SQUARE) THEN      !square well
         DO 300 IR=1,NPTS*3/4
           V(IR)=-VZERO
300      CONTINUE
         DO 400 IR=NPTS*3/4,NPTS
           V(IR)=0.0
400      CONTINUE
         IF (VZERO .LE. 0) ATTRCT=.FALSE.
         IF (VZERO .GT. 0) ATTRCT=.TRUE.
C
      ELSE IF (POT .EQ. GAUSS) THEN       !Gaussian well
         DO 500 IR=1,NPTS
            V(IR)=-VZERO*EXP(-R(IR)*R(IR))
500      CONTINUE
         IF (VZERO .LE. 0) ATTRCT=.FALSE.
         IF (VZERO .GT. 0) ATTRCT=.TRUE.
C
      ENDIF
C
C     for all potentials, V is zero outside RMAX
      DO 600 IR=NPTS+1,NPTS+NXTRA
         V(IR)=0.
600   CONTINUE
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE LPINIT
C calculates the Legendre Polynomials P0 and P1
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global Variables:
      INCLUDE 'PARAM.P4'
C Local Variables:
      INTEGER    ITHETA                 !indexes the angle
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      DO 100 ITHETA=0,NANG
         THETA(ITHETA)=ITHETA*PI/NANG
         DEGREE(ITHETA)=ITHETA*180/NANG
         CTHETA(ITHETA)=COS(THETA(ITHETA))
         PL(0,ITHETA)=1
         PL(1,ITHETA)=CTHETA(ITHETA)
100   CONTINUE
      LTABLE=1
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE LEGPOL
C calculates the Legendre Polynomials from LTABLE to LSTOP
C  using recursion relation
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE    'PARAM.P4'
C Local Variables:
      INTEGER   ITHETA,L               !index angle and L
      REAL X                           !cos(theta)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      DO 100 ITHETA=0,NANG
       X=CTHETA(ITHETA)
       DO 200 L=LTABLE,LSTOP-1
         PL(L+1,ITHETA)=((2*L+1)*X*PL(L,ITHETA)-L*PL(L-1,ITHETA))/(L+1)
200    CONTINUE
100   CONTINUE
      LTABLE=LSTOP
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE SBSSEL
C calculates the Spherical Bessel functions at RMAX and RXTRA+RMAX
C  for L values from 0 to LSTOP
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE    'PARAM.P4'
C Local Variables:
      REAL       J,JM1,JP1            !temp values for JL backwd recursn
      REAL       NORM                 !normalizing factor for JL's
      INTEGER    L,LUPPER             !index of JL and NL
      INTEGER    IR                   !indexes RMAX or RMAX+RXTRA
      REAL       X                    !function argument
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      DO 1000 IR=1,2                  !needed at RMAX and RMAX+RXTRA
C       X values for which we are calculating spherical Bessel functions
        IF (IR .EQ. 1) X=K*RMAX
        IF (IR .EQ. 2) X=K*(RMAX+RXTRA)
C
C       obtain NL's by stable forward recursion
        NL(IR,0)=-COS(X)/X
        NL(IR,1)=-COS(X)/(X*X)-SIN(X)/X
        DO 100 L=1,LSTOP-1
           NL(IR,L+1)=(2*L+1)*NL(IR,L)/X-NL(IR,L-1)
100     CONTINUE
C
C       obtain JL's by stable backward recursion
        LUPPER=X+10.             !start at L such that JL is neglgbl
        JP1=0
        J=9.9999999E-21          !arbitrary beginning value
        DO 200 L=LUPPER,1,-1
           JM1=(2*L+1)*J/X-JP1
           IF ((L-1).LE. LSTOP) JL(IR,L-1)=JM1   !save needed L values
           JP1=J                                 !roll values
           J=JM1
200     CONTINUE
        NORM=SIN(X)/X/JL(IR,0)   !normalize using analytic form of JO
        DO 300 L=0,LSTOP
          JL(IR,L)=NORM*JL(IR,L)
300     CONTINUE
1000  CONTINUE
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE INIT
C initializes constants, displays header screen,
C initializes arrays for input parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'MENU.ALL'
      INCLUDE 'PARAM.P4'
C Local parameters:
      CHARACTER*80 DESCRP          !program description
      DIMENSION DESCRP(20)
      INTEGER NHEAD,NTEXT,NGRAPH   !number of lines for each description
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL SETUP                !get environment parameters
C
C     display header screen
      DESCRP(1)= 'PROJECT 4'
      DESCRP(2)= 'Partial-wave solution to quantum scattering'
      NHEAD=2
C
C     text output description
      DESCRP(3)= 'phase shift and total cross section for each L;'
      DESCRP(4)= 'differential cross section at several angles'
      NTEXT=2
C
C     graphics output description
      DESCRP(5)='Veffective, scattered wave, and free wave vs. radius;'
      DESCRP(6)='differential cross section vs. angle'
      NGRAPH=2
C
      CALL HEADER(DESCRP,NHEAD,NTEXT,NGRAPH)
C
C     set constant values
      PI=4.0*ATAN(1.)
      E2=14.409
      RMAX=2.0
      HBARM=7.6359
C
      CALL MENU                      !setup constant part of menu
C
      MTYPE(13)=MTITLE
      MPRMPT(13)='Potential Function Options:'
      MLOLIM(13)=2
      MHILIM(13)=1
C
      MTYPE(14)=MTITLE
      MPRMPT(14)='1) Lenz-Jensen Potential: electron & neutral atom'
      MLOLIM(14)=0
      MHILIM(14)=0
C
      MTYPE(15)=MTITLE
      MPRMPT(15)='2) Square Well'
      MLOLIM(15)=0
      MHILIM(15)=0
C
      MTYPE(16)=MTITLE
      MPRMPT(16)='3) Gaussian Well'
      MLOLIM(16)=0
      MHILIM(16)=1
C
      MTYPE(17)=MCHOIC
      MPRMPT(17)='Enter Choice'
      MTAG(17)='18 20 20'
      MLOLIM(17)=1
      MHILIM(17)=3
      MINTS(17)=1
      MREALS(17)=1.
C
      MTYPE(18)=NUM
      MPRMPT(18)='Enter charge of the atomic nucleus'
      MTAG(18)='Z'
      MLOLIM(18)=1
      MHILIM(18)=108
      MINTS(18)=4
C
      MTYPE(19)=SKIP
      MREALS(19)=21
C
      MTYPE(20)=FLOAT
      MPRMPT(20)='Enter depth of potential well (eV)'
      MTAG(20)='Vzero (eV)'
      MLOLIM(20)=-5000.
      MHILIM(20)=5000.
      MREALS(20)= 50.0
C
      MTYPE(21)=FLOAT
      MPRMPT(21)='Enter Energy (eV)'
      MTAG(21)='Energy (eV)'
      MLOLIM(21)=0.0001
      MHILIM(21)=1000.
      MREALS(21)=20.0
C
      MTYPE(22)=SKIP
      MREALS(22)=35
C
      MTYPE(38)=NUM
      MPRMPT(38)='Number of integration points to r1'
      MTAG(38)='number of integration points to r1'
      MLOLIM(38)=100
      MHILIM(38)=MAXN
      MINTS(38)=400
C
      MTYPE(39)=NUM
      MPRMPT(39)='Number of integration points between r1 and r2'
      MTAG(39)='number of extra integration points'
      MLOLIM(39)=20
      MHILIM(39)=MAXE
      MINTS(39)=60
C
      MTYPE(40)=NUM
      MPRMPT(40)='Number of angles'
      MTAG(40)='number of angles'
      MLOLIM(40)=1
      MHILIM(40)=MAXANG
      MINTS(40)=36
C
      MTYPE(41)=SKIP
      MREALS(41)=60
C
      MSTRNG(MINTS(75))= 'proj4.txt'
C
      MTYPE(76)=SKIP
      MREALS(76)=80.
C
      MSTRNG(MINTS(86))= 'proj4.grf'
C
      MTYPE(87)=SKIP
      MREALS(87)=90.
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE PARAM
C gets parameters from screen
C ends program on request
C closes old files
C maps menu variables to program variables
C opens new files
C calculates all derivative parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global Variables:
      INCLUDE 'MENU.ALL'
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P4'
C Local Variables:
      INTEGER GETINT             !get integer input from terminal
      INTEGER LDEF               !default value for L stop
C map between menu items and parameters
      INTEGER IPOT,IZ,IVZERO,IE,INPTS,INXTRA,INANG
      PARAMETER (IPOT   = 17 )
      PARAMETER (IZ     = 18 )
      PARAMETER (IVZERO = 20 )
      PARAMETER (IE     = 21 )
      PARAMETER (INPTS  = 38 )
      PARAMETER (INXTRA = 39 )
      PARAMETER (INANG  = 40 )
C Function:
      LOGICAL LOGCVT             !converts 1 and 0 to true and false
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     get input from terminal
      CALL CLEAR
      CALL ASK(1,ISTOP)
C
C     stop program if requested
      IF (MREALS(IMAIN) .EQ. STOP) CALL FINISH
C
C     close files if necessary
      IF (TNAME .NE. MSTRNG(MINTS(ITNAME)))
     +     CALL FLCLOS(TNAME,TUNIT)
      IF (GNAME .NE. MSTRNG(MINTS(IGNAME)))
     +     CALL FLCLOS(GNAME,GUNIT)
C
C     set new parameter values
C     physical and numerical
      POT=MINTS(IPOT)
      Z=MINTS(IZ)
      VZERO=MREALS(IVZERO)
      E=MREALS(IE)
      NPTS=MINTS(INPTS)
      NXTRA=MINTS(INXTRA)
C
C     calculate derivative parameters:
      Z6=Z**0.166667
      K2=2*E/HBARM
      K=SQRT(K2)
      LMAX=K*RMAX/2+4
      DR=RMAX/NPTS
      RXTRA=DR*NXTRA
C
      CALL POTNTL           !fill the potential array
C
C     prompt for range of partial waves after displaying LMAX
      WRITE (OUNIT,10) LMAX
10    FORMAT (' The value for LMAX at this energy is = ',I3)
      WRITE (OUNIT,*) ' '
      LSTART=GETINT(0,0,MAXL,' Enter a value for L start')
      LDEF=MAX(LSTART,LMAX)
      LSTOP=GETINT(LDEF,LSTART,MAXL,' Enter a value for L stop')
      CALL CLEAR
C
C     calculate Legendre Polynomials if not already done
      IF (NANG .NE. MINTS(INANG)) THEN       !angles have changed
         NANG=MINTS(INANG)
         CALL LPINIT
      END IF
C     need to have Legendre polynomials all the way to LSTOP
      IF (LTABLE .LT. LSTOP) CALL LEGPOL
C
C     calculate spherical bessel functions
      CALL SBSSEL
C
C     text output
      TTERM=LOGCVT(MINTS(ITTERM))
      TFILE=LOGCVT(MINTS(ITFILE))
      TNAME=MSTRNG(MINTS(ITNAME))
C
C     graphics output
      GTERM=LOGCVT(MINTS(IGTERM))
      GHRDCP=LOGCVT(MINTS(IGHRD))
      GFILE=LOGCVT(MINTS(IGFILE))
      GNAME=MSTRNG(MINTS(IGNAME))
C
C     open files
      IF (TFILE) CALL FLOPEN(TNAME,TUNIT)
      IF (GFILE) CALL FLOPEN(GNAME,GUNIT)
      !files may have been renamed
      MSTRNG(MINTS(ITNAME))=TNAME
      MSTRNG(MINTS(IGNAME))=GNAME
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE PRMOUT(MUNIT,NLINES)
C outputs parameters to MUNIT, keeping track of number of lines printed
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
       INCLUDE 'IO.ALL'
       INCLUDE 'PARAM.P4'
C Passed variables:
       INTEGER MUNIT            !unit number for output (input)
       INTEGER NLINES           !number of lines written so far (I/O)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       IF (MUNIT .EQ. OUNIT) CALL CLEAR
C
       WRITE (MUNIT,2)
       WRITE (MUNIT,4)
       WRITE (MUNIT,6) E
       WRITE (MUNIT,8) LSTART,LSTOP
       WRITE (MUNIT,20) NPTS
       WRITE (MUNIT,22) NXTRA
       WRITE (MUNIT,24) NANG
C
       IF (POT .EQ. LENZ) THEN
           WRITE (MUNIT,10) Z
       ELSE IF (POT .EQ. SQUARE) THEN
           WRITE (MUNIT,12) VZERO
       ELSE IF (POT .EQ. GAUSS) THEN
           WRITE (MUNIT,14) VZERO
       END IF
C
C      different header for text and graphics files
       IF (MUNIT .EQ. GUNIT) THEN
         WRITE (MUNIT,2)
       ELSE
         WRITE (MUNIT,2)
         WRITE (MUNIT,16)
         WRITE (MUNIT,17)
         WRITE (MUNIT,18)
       END IF
C
       NLINES=11
C
2      FORMAT (' ')
4      FORMAT (' Output from project 4: Partial-wave solution'
     +         ' to quantum scattering')
6      FORMAT (' Energy (eV) =', 1PE10.3)
8      FORMAT (' L start = ' , I3, 10X,' L stop = ', I3)
10     FORMAT (' Lenz Jensen potential with Z = ', I3)
12     FORMAT (' Square well potential with Vzero = ' 1PE10.3)
14     FORMAT (' Gaussian potential with Vzero = ' 1PE10.3)
20     FORMAT (' Number of integration points = ', I4)
22     FORMAT (' Number of points between r1 and r2 = ', I4)
24     FORMAT (' Number of angles = ', I3)
16     FORMAT (15X,'L',15X,'Delta(L)',17X,'Sigma(L)')
17     FORMAT (15X,' ',15X,'degrees ',15X,'Angstroms**2')
18     FORMAT (15X,'-',15X,'--------',15X,'------------')
C
       RETURN
       END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE TXTOUT(MUNIT,NLINES,L,DELDEG,SIGMA)
C writes out phase shift and total cross section for each partial wave
C to MUNIT, keeping track of number of lines printed
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P4'
C Passed variables:
      INTEGER MUNIT              !output unit specifier (input)
      INTEGER NLINES             !number of lines printed to screen(I/O)
      INTEGER L                  !partial wave number(input)
      REAL DELDEG,SIGMA          !phase shift and cross section(input)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     if screen is full, clear and type headings again
      IF ((MOD(NLINES,TRMLIN-4) .EQ. 0)
     +                          .AND. (MUNIT .EQ. OUNIT)) THEN
         CALL PAUSE('to continue...',1)
         CALL CLEAR
         WRITE (MUNIT,16)
         WRITE (MUNIT,17)
         WRITE (MUNIT,18)
         WRITE (MUNIT,2)
         NLINES=NLINES+4
      END IF
C
      WRITE (MUNIT,20) L,DELDEG,SIGMA
C     keep track of printed lines only for terminal output
      IF (MUNIT .EQ. OUNIT) NLINES=NLINES+1
C
20    FORMAT(13X,I3,13X,1PE10.3,13X,1PE15.8)
2     FORMAT (' ')
16    FORMAT (15X,'L',15X,'Delta(L)',17X,'Sigma(L)')
17    FORMAT (15X,' ',15X,'degrees ',15X,'Angstroms**2')
18    FORMAT (15X,'-',15X,'--------',15X,'------------')
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE DELOUT(DELDEG,SIGMA)
C outputs delta and partial wave cross sections to screen
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P4'
C Passed variables:
      REAL DELDEG(0:MAXL)         !phase shift in degrees (input)
      REAL SIGMA(0:MAXL),SIGTOT   !total cross section (input)
      INTEGER L                   !partial wave index (input)
C Local variables:
      INTEGER NLINES              !number of lines written so far (I/O)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       CALL PRMOUT(OUNIT,NLINES)
       DO 100 L=LSTART,LSTOP
          CALL TXTOUT(OUNIT,NLINES,L,DELDEG(L),SIGMA(L))
100    CONTINUE
       RETURN
       END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE SIGOUT(MUNIT,F,DSIGMA,SIGTOT)
C writes out scattering angle, scattering amplitude,
C differential cross section and total cross section to MUNIT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P4'
C Input variables:
      INTEGER MUNIT                 !output unit specifier
      REAL DSIGMA(0:MAXANG)         !differential cross section
      COMPLEX F(0:MAXANG)           !scattering amplitude
      INTEGER ITHETA                !index of theta
      REAL SIGTOT                   !total cross section
C Local variables:
      INTEGER NLINES                !keep track of lines printed out
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      WRITE (MUNIT,2)
      WRITE (MUNIT,2)
      WRITE (MUNIT,4) SIGTOT
      WRITE (MUNIT,2)
      WRITE (MUNIT,2)
      WRITE (MUNIT,10)
      WRITE (MUNIT,11)
      WRITE (MUNIT,12)
C
      NLINES=8
C
C     write out data, allowing time for user to examine full pages
      DO 100 ITHETA=0,NANG
        WRITE (MUNIT,14) DEGREE(ITHETA),F(ITHETA),DSIGMA(ITHETA)
        NLINES=NLINES+1
        IF ((MOD(NLINES,TRMLIN-4) .EQ. 0) .AND.
     +               (MUNIT .EQ. OUNIT)) THEN
           CALL PAUSE('to continue...',1)
           CALL CLEAR
        END IF
100   CONTINUE
C
2      FORMAT (' ')
4      FORMAT (15X,'TOTAL CROSS SECTION = ',1PE15.8,' Angstroms**2')
10     FORMAT (10X,'Theta' ,14X,'Amplitude (Re,Im)',15X,'dSigma/dTheta')
11     FORMAT (9X,'degrees',13X,'  Angstroms**2   ',15X,' Angstroms**2')
12     FORMAT (9X,'-------',13X,'-----------------',15X,'-------------')
14     FORMAT (7X,F8.2,6X,'(',1PE15.8,','1PE15.8,')',6X,1PE15.8)
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE GRFOUT(DEVICE,L,DELDEG,SIGMA)
C outputs potential and both free and scattered wave functions for one L:
C does not allow for hardcopy or file output
C in order to avoid the creation of voluminous files
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P4'
      INCLUDE 'GRFDAT.ALL'
C Input variables:
      INTEGER DEVICE               !which device is being used?
      INTEGER L                    !partial wave
      REAL DELDEG,SIGMA            !phase shift and cross section
      REAL PSI(MAXN+MAXE),PSIF(MAXN+MAXE)   !wave functions
      REAL PSIMAX,PSFMAX           !maxima of wave functions
      REAL VEFF(MAXN+MAXE)         !effective pot for fixed L
      COMMON/RESULT/PSI,PSIF,PSIMAX,PSFMAX,VEFF!pass results from Numerv
C Local variables
      INTEGER IR                   !index of lattice
      REAL VGRF(MAXE+MAXN)         !V scaled for graphing
      REAL PSIG(MAXE+MAXN),PSIFG(MAXE+MAXN)  !rescaled wave functions
      REAL ENERGY(2),RADIUS(2)     !array for plotting energy
      CHARACTER*9 CL,CDEL,CSIG,CE  !character version of data
      INTEGER LEN,LCDEL,LCSIG      !length of strings
      INTEGER SCREEN               !send to terminal
      INTEGER PAPER                !make a hardcopy
      INTEGER FILE                 !send to a file
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     messages for the impatient
      IF (DEVICE .NE. SCREEN) WRITE (OUNIT,100)
C
C     setup graphing paramters
      IF (DEVICE .NE. FILE) THEN
          NPLOT=1                        !how many plots?
          IPLOT=1
C
          XMIN=0.0                       !axis parameters
          XMAX=RMAX+RXTRA
          Y0VAL=XMIN
          YMIN=-2*E                      !energy axis varies between
          YMAX=+4*E                      !-2E and 4E
          X0VAL=0.
C
          NPOINT=NPTS+NXTRA
C
          LABEL(1)= 'radius (Angstroms)' !titles and labels
          LABEL(2)= 'Veff(eV), scattered wave (solid),'
     +              //' and free (ooo) wave'
          CALL CONVRT(E,CE,LEN)
          IF (POT .EQ. LENZ) THEN
            TITLE = ' Lenz-Jensen Potential, Energy (eV)='//CE
          ELSE IF (POT .EQ. SQUARE) THEN
            TITLE = 'Square Well Potential, Energy (eV)='//CE
          ELSE IF (POT .EQ. GAUSS) THEN
            TITLE = 'Gaussian Potential, Energy (eV)='//CE
          END IF
C
C         arrays for plotting energy
          RADIUS(1)=0.
          RADIUS(2)=XMAX
          ENERGY(1)=E
          ENERGY(2)=E
C
C         plot Veffective between -2E and 4E
          DO 30 IR=1,NPTS+NXTRA         !normalize VEFF
             VGRF(IR)=VEFF(IR)
             IF (VGRF(IR) .GT. YMAX) VGRF(IR)=YMAX
             IF (VGRF(IR) .LT. YMIN) VGRF(IR)=YMIN
30        CONTINUE
C
C         rescale wave functions so that it fits on the energy scale
          DO 10 IR=1,NPTS+NXTRA
            PSIG(IR)=PSI(IR)*3*E/PSIMAX+E
            PSIFG(IR)=PSIF(IR)*3*E/PSFMAX+E
10        CONTINUE
C
          ILINE=1                      !line and symbol styles
          ISYM=1
          IFREQ=0
          NXTICK=5
          NYTICK=5
C
          CALL GTDEV(DEVICE)                   !device nomination
          IF (DEVICE .EQ. SCREEN) CALL GMODE   !change to graphics mode
C
C         create the legend
          CALL ICNVRT(L,CL,LEN)
          CALL CONVRT(DELDEG,CDEL,LCDEL)
          CALL CONVRT(SIGMA,CSIG,LCSIG)
          INFO='Delta(L=' //CL(1:LEN) //')=' //CDEL(1:LCDEL)//
     +        ' deg'//
     +        '  Sig(L=' //CL(1:LEN) //')='//CSIG(1:LCSIG)//' A**2'
C
          CALL LNLNAX
C
          CALL XYPLOT (R,VGRF)                   !plot potential
          NPOINT=2
          CALL XYPLOT (RADIUS,ENERGY)            !plot energy
C
          NPOINT=NPTS+NXTRA
          CALL XYPLOT (R,PSIG)                   !plot wave function
          IFREQ=4
          CALL XYPLOT (R,PSIFG)                  !plot free wave function
C
      END IF
C
C     end graphing session
      IF (DEVICE .NE. FILE) CALL GPAGE(DEVICE)  !end graphics package
      IF (DEVICE .EQ. SCREEN) CALL TMODE        !switch to text mode
C
100   FORMAT (/,' Patience, please; output going to a file.')
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE GRFSIG(DEVICE,DSIGMA,SIGTOT)
C graphs differential cross section vs. angle for all partial waves
C on a semi-log scale
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P4'
      INCLUDE 'GRFDAT.ALL'
C Input variables:
      INTEGER DEVICE         !which device is being used?
      REAL SIGTOT            !total cross section
      REAL DSIGMA(0:MAXANG)  !differential cross section
C Local variables
      INTEGER ITHETA         !indexes angle
      INTEGER EXPMAX,EXPMIN  !min and max exp for diff cross section
      CHARACTER*9 CE,CSIG    !energy,sigma as a character string
      INTEGER LEN            !string length
      INTEGER SCREEN         !send to terminal
      INTEGER PAPER          !make a hardcopy
      INTEGER FILE           !send to a file
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     messages for the impatient
      IF (DEVICE .NE. SCREEN) WRITE (OUNIT,100)
C
C     calculate parameters for graphing
      IF (DEVICE .NE. FILE) THEN
C
          NPLOT=1                        !how many plots?
          IPLOT=1
C
          YMAX=0.                        !find limits on data points
          YMIN=DSIGMA(1)
          DO 20 ITHETA=0,NANG
             IF (DSIGMA(ITHETA) .GT. YMAX) YMAX=DSIGMA(ITHETA)
             IF (DSIGMA(ITHETA) .LT. YMIN) YMIN=DSIGMA(ITHETA)
20        CONTINUE
          !find integer limits on exponent
          EXPMAX=INT(LOG10(YMAX))
          IF (YMAX .GT. 1.) EXPMAX =EXPMAX+1
          EXPMIN=INT(LOG10(YMIN))
          IF (YMIN .LT. 1.) EXPMIN=EXPMIN-1
          YMAX=10.**EXPMAX
          YMIN=10.**EXPMIN
C
          XMIN=DEGREE(0)
          XMAX=DEGREE(NANG)
          Y0VAL=XMIN
          X0VAL=YMIN
C
          NPOINT=NANG
C
          ILINE=1                      !line and symbol styles
          ISYM=4
          IFREQ=1
          NXTICK=4
          NYTICK=EXPMAX-EXPMIN
          IF (NYTICK .GT. 8) THEN      !keep number of ticks small
             IF (MOD(NYTICK,2) .EQ. 0) THEN
                NYTICK=NYTICK/2
             ELSE
                NYTICK=8
             END IF
          END IF
C
          CALL CONVRT(E,CE,LEN)             !titles and labels
          IF (POT .EQ. LENZ) THEN
            TITLE = ' Lenz-Jensen Potential, Energy (eV)='//CE
          ELSE IF (POT .EQ. SQUARE) THEN
            TITLE = 'Square Well Potential, Energy (eV)='//CE
          ELSE IF (POT .EQ. GAUSS) THEN
            TITLE = 'Gaussian Potential, Energy (eV)='//CE
          END IF
          CALL CONVRT(SIGTOT,CSIG,LEN)
          INFO='Total cross section in A**2 = '//CSIG
          LABEL(1)= 'Angle (degrees)'
          LABEL(2)= 'Differential Cross Section (Angstroms**2)'
C
          CALL GTDEV(DEVICE)                   !device nomination
          IF (DEVICE .EQ. SCREEN) CALL GMODE   !change to graphics mode
          CALL LGLNAX                          !draw axes
      END IF
C
C     output results
      IF (DEVICE .EQ. FILE) THEN
         WRITE (GUNIT,10)
         WRITE (GUNIT,11)
         WRITE (GUNIT,12)
         WRITE (GUNIT,14) (DEGREE(ITHETA),DSIGMA(ITHETA),ITHETA=0,NANG)
      ELSE
         CALL XYPLOT (DEGREE,DSIGMA)
      END IF
C
C     end graphing session
      IF (DEVICE .NE. FILE) CALL GPAGE(DEVICE) !end graphics package
      IF (DEVICE .EQ. SCREEN) CALL TMODE       !switch to text mode
C
10    FORMAT (21X,'Theta',  21X,'dSigma/dTheta')
11    FORMAT (20X,'degrees',20X,' Angstroms**2')
12    FORMAT (20X,'-------',20X,'-------------')
14    FORMAT (18X,1PE10.3,18X,1PE15.8)
100   FORMAT (/,' Patience, please; output going to a file.')
C
      RETURN
      END


      subroutine ldp (g,mdg,m,n,h,x,xnorm,w,index,mode)
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1974 mar 1
c     to appear in 'solving least squares problems', prentice-hall, 1974
c
c	     **********  least distance programming  **********
c
      integer index(m)
      dimension g(mdg,n), h(m), x(n), w(1)
      zero=0.
      one=1.
      if (n.le.0) go to 120
	  do 10 j=1,n
   10	  x(j)=zero
      xnorm=zero
      if (m.le.0) go to 110
c
c     the declared dimension of w() must be at least (n+1)*(m+2)+2*m.
c
c      first (n+1)*m locs of w()   =  matrix e for problem nnls.
c	next	 n+1 locs of w()   =  vector f for problem nnls.
c	next	 n+1 locs of w()   =  vector z for problem nnls.
c	next	   m locs of w()   =  vector y for problem nnls.
c	next	   m locs of w()   =  vector wdual for problem nnls.
c     copy g**t into first n rows and m columns of e.
c     copy h**t into row n+1 of e.
c
      iw=0
	  do 30 j=1,m
	      do 20 i=1,n
	      iw=iw+1
   20	      w(iw)=g(j,i)
	  iw=iw+1
   30	  w(iw)=h(j)
      if=iw+1
c				 store n zeros followed by a one into f.
	  do 40 i=1,n
	  iw=iw+1
   40	  w(iw)=zero
      w(iw+1)=one
c
      np1=n+1
      iz=iw+2
      iy=iz+np1
      iwdual=iy+m
c
      call nnls (w,np1,np1,m,w(if),w(iy),rnorm,w(iwdual),w(iz),index,
     *		 mode)
c		       use the following return if unsuccessful in nnls.
      if (mode.ne.1) return
      if (rnorm) 130,130,50
   50 fac=one
      iw=iy-1
	  do 60 i=1,m
	  iw=iw+1
c				here we are using the solution vector y.
   60	  fac=fac-h(i)*w(iw)
c
      if (diff(one+fac,one)) 130,130,70
   70 fac=one/fac
	  do 90 j=1,n
	  iw=iy-1
	      do 80 i=1,m
	      iw=iw+1
c				here we are using the solution vector y.
   80	      x(j)=x(j)+g(i,j)*w(iw)
   90	  x(j)=x(j)*fac
	  do 100 j=1,n
  100	  xnorm=xnorm+x(j)**2
      xnorm=sqrt(xnorm)
c			      successful return.
  110 mode=1
      return
c			      error return.	  n .le. 0.
  120 mode=2
      return
c			      returning with constraints not compatible.
  130 mode=4
      return
      end


!	Maximum likelihood for log-linear MIRT models with possible indirect observation.
!	Summary of variables.
!	comment is used to comment on the iteration progress report.
!	catobsrange is the range of underlying categories per for each observed category.
!	constdim1 is the number of linear constraints not treated via least squares.
!	dat is the data matrix.
!	maxit is the maximum number of iterations.
!	maxita is the maximum number of iterations used to find alp.
!	maxitb is the maximum number of iterations used to find the step size.
!	numcat is the number of underlying categories per item.
!	numcatobs is the number of observed categories per item.
!	rbetamap is the reduced beta map.
!	unitno is the unit number for reporting iteration progress.
!	normal is for a multivariate normal distribution of the latent vector.  The alternative is multinomial.
!	nr is for Newton-Raphson.  The alternative uses an approximation to Newton-Raphson based on the Louis
!		approximation.
!	printprog indicates that iteration progress is to be printed to unitno.
!	printprogstd indicates that iteration progress is to go to standard output.
!	proport is .true. if the constraint sum of squares is proportional to the sum of the observation weights.
!	changemin is the criterion for minimum change.
!	constmat is the constraint matrix.
!	constvec is the constraint vector.
!	design is the design matrix.
!	indvar is the matrix of independent variables.
!	kappa is the maximum permitted step size.
!	lintran is the linear transformation from basic quadrature points to values of the latent vector.
!	maxdalpha is the maximum change in thee alpha maximum norm permitted per iteration.
!	obsweight is the vector of observation weights.
!	offset is the offset vector.
!	quadpoint is the quadrature points.
!	quadweight is the quadrature weights.
!	rdesign is the reduced design matrix.
!	tau is a step multiplier.
!	tol is the convergence criterion for ent change.
!	tola is the convergence criterion for alpha change.
!   tolc is the criterion for appropriate maximum ratio of diagonal terms in modified Cholesky decomposition.
!	tolsing is a criterion for singularity.
!	alpha is the matrix of approximate maxima of the individual log likelihood.
!	beta is the parameter vector.
!	beta=design(gamma).
!	cholnhess is the modified Cholesky decomposition of the negative hessian at the corresponding alpha.
!	grad is the gradient vector relative to beta=design(gamma).
!	graddes is the gradient vector relative to gamma.
!	grads is a matrix of individual gradient vectors.
!	loglik is the log likelihood.
!	nhess is the negative hessian matrix relative to beta.
!	nhessdes is the negative hessian matrix relative to gamma.
!	nhessdeschol is the modified Cholesky decomposition of nhessdesplus.
!	nhessdesplus is nhessdes plus the component constquad for constraints.
!	postdensity is the array of posterior densities at adaptive quadrature points.
!	prob contains item probabilities.
!	theta is the array of adaptive quadrature points.
subroutine ndmmaxlik(comment,catobsrange,constdim1,dat,maxit,maxita,maxitb,numcat,numcatobs,rbetamap,unitno,&
	normal,nr,printprog,printprogstd,proport,&
	changemin,constmat,constvec,design,indvar,kappa,lintran,&
	maxdalpha,obsweight,offset,quadpoint,quadweight,rdesign,&
	tau,tol,tola,tolc,tolsing,&
	alpha,beta,cholnhess,gamma,constquad,grad,graddes,grads,&
	loglik,nhess,nhessdes,nhessdeschol,nhessdesplus,postdensity,prob,theta)
implicit none
interface
!
	function chol(sym,tolsing)
!	chol is used to compute a modified Cholesky decomposition of the n by n matrix sym.
!	The singularity tolerance is tolsing.
		implicit none
		real(kind=8),intent(in)::sym(:,:),tolsing
	 	real(kind=8)::chol(size(sym,1),size(sym,1))
	end function chol
!	condprobvec is used to compute observed item conditional probabilities of underlying item categories given
!	observed item categories.
!	catobsrange provides ranges of underlying item categories that correspond to observed item categories.
!	numcatobs provides the number of observed categories per item.
!	resp is the item response.
!	mask indicates which items were presented.
!	probcat is the vector of underlying category probabilities.
!	probcatobs is the vector of observed category probabilities.
	function condprobvec(catobsrange,numcatobs,resp,mask,probcat,probcatobs)
		implicit none
		integer,intent(in)::catobsrange(:,:),numcatobs(:),resp(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::probcat(:),probcatobs(:)
		real(kind=8)::condprobvec(size(probcat))
	end function condprobvec

!	Covariances of products of elements of latent vector and of elements of latent vector with normal
!	distribution with mean mean and  covariance cov.
	function cubicnormal(cov,mean)
		implicit none
		real(kind=8),intent(in)::cov(:,:),mean(:)
		real(kind=8)::cubicnormal(size(mean),size(mean),size(mean))
	end function cubicnormal
!	Get normal density for scaled latent vector.  Place in density.
!	Input involves linear component linth, quadrature points quadpoint, quadratic components quadth, quadrature weights quadweight, and scale
!	factor scaletheta.
	function density(linth,quadpoint,quadth,quadweight,scaletheta)
		implicit none
		real(kind=8),intent(in)::linth(:),quadpoint(:,:),quadth(:,:),quadweight(:),scaletheta
		real(kind=8)::density(size(quadweight))
	end function density

!	Get multinomial probabilities for latent vector.  Place in density.
!	Input involves linear component linth, quadrature points quadpoint, quadratic components quadth, and quadrature weights quadweight.
	function densitym(linth,quadpoint,quadth,quadweight)
		real(kind=8),intent(in)::linth(:),quadpoint(:,:),quadth(:,:),quadweight(:)
		real(kind=8)::densitym(size(quadweight))
	end function densitym

!	convert an n by n symmetric matrix from compact to regular form.
	function expandmat(n,compmat)
		implicit none
		integer,intent(in)::n
		real(kind=8),intent(in)::compmat(:)
		real(kind=8)::expandmat(n,n)
	end function expandmat
!	Extract the linear component lintheta and the quadratic component quadtheta from the parameter vector beta.
	subroutine getlinquad(beta,lintheta,quadtheta)
		implicit none
		real(kind=8),intent(in)::beta(:)
		real(kind=8),intent(out)::lintheta(:,:),quadtheta(:,:,:)
	end subroutine getlinquad

!	Extract the linear component linth and the quadratic component quadth from lintheta and quadtheta for a given predictor thpr.
	subroutine getlinquadth(lintheta,quadtheta,thpr,linth,quadth)
		implicit none
		real(kind=8),intent(in)::lintheta(:,:),quadtheta(:,:,:),thpr(:)
		real(kind=8),intent(out)::linth(:),quadth(:,:)
	end subroutine getlinquadth

!	gradient of log conditional probability of an observation.
!	rbetamap is the reduced beta map.
!	mask is the response mask.
!	condprobcat contains conditional item probabilities.
!	meanth is the mean of theta.
!	mean2th is the mean of products of elements of theta.
!	newtheta is the transformed latent vector.
!	probcat contains item probabilities.
!	theta is the latent vector.
!	thpr is the independent vector.
	function gradvec(rbetamap,mask,condprobcat,meanth,mean2th,newtheta,probcat,theta,thpr)
		implicit none
		integer,intent(in)::rbetamap(:,:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::condprobcat(:),meanth(:),mean2th(:,:),newtheta(:),probcat(:),theta(:),thpr(:)
		real(kind=8)::gradvec(size(rbetamap,2))
	end function gradvec

!	Estimate the information matrix with the Louis approach.
!	adjust is .true. if the average of grads is to be subtracted.
!	grads is the array of observation gradients.
!	obsweight contains observation weights.
	function information(adjust,grads,obsweight)
		implicit none
		logical,intent(in)::adjust
		real(kind=8),intent(in)::grads(:,:),obsweight(:)
		real(kind=8)::information(size(grads,1),size(grads,1))
	end function information
!

!	Compute inverse for n by n matrix with modified Cholesky
!	decomposition tri.
	function invert(tri)
		implicit none
		real(kind=8),intent(in)::tri(:,:)
		real(kind=8)::invert(size(tri,1),size(tri,1))
	end function invert

!	Report on iteration progress.
!	comment is used to comment on the iteration progress report.
!	it is the iteration number.
!	unitno is the unit number for the report.
!	printprog indicates that iteration progress is to be printed to unitno.
!	printprogstd indicates that iteration progress is to go to standard output.
!	loglik is the log likelihood.
!	step is the step size.
	subroutine iterationreport(comment,it,unitno,printprog,printprogstd,loglik,step)
		implicit none
		character(len=*),intent(in)::comment
		integer,intent(in)::it,unitno
		logical,intent(in)::printprog,printprogstd
		real(kind=8),intent(in)::loglik,step
	end subroutine iterationreport

	subroutine makesym(matrix)
!	Symmetrize n by n matrix based on lower triangle.
		implicit none
		real(kind=8),intent(inout)::matrix(:,:)
	end subroutine makesym

!	Find location of maximum posterior density of the latent vector.
!	catobsrange is used to relate observed and underlying categories.
!	maxita is used to determine the number of iterations to use to find the maximum posterior density.
!	maxitb is used for subiterations.
!	numcat provides ranges for underlying observations,
!	numcatobs provides ranges of observations, mask indicates items to use for computations.
!	obsmask is an observation mask that can be used to restrict attention to a portion of the response.
!	beta is the parameter vector.
!	changemin is used for minimum change.
!	linth is the linear component of the log density.
!	lintran is the linear transformation of the latent vector.
!	maxdtheta is the maximum permitted change in the approximation of the maximum in one step.
!	quadth is the quadratic component of the log density.
!	resp is the response.
!	tau is used for minimum step sizes.
!	thpr is the predictor.
!	tol is used to determine the desired accuracy of the maximization.
!	tolsing is used to determine the tolerance for the Cholesky decomposition.
!	nhchol is the modified Cholesky decomposition of the negative hessian.
!	theta is the maximum.
	subroutine maxpost(catobsrange,maxita,maxitb,npred,numcat,numcatobs,resp,obsmask,beta,changemin,&
		linth,lintran,maxdtheta,quadth,tau,tol,tolsing,&
		nhchol,theta)
		implicit none
		integer,intent(in)::catobsrange(:,:),maxita,maxitb,npred,numcat(:),numcatobs(:),resp(:)
		logical,intent(in)::obsmask(:)
		real(kind=8),intent(in)::beta(:),changemin,lintran(:,:),linth(:),maxdtheta,quadth(:,:),tau,tol,tolsing
		real(kind=8),intent(inout)::theta(:)
		real(kind=8),intent(out)::nhchol(:,:)
	end subroutine maxpost

!	Multinomial covariance matrix.
!	density is vector of probabilities.
!	meanth is vector of means.
!	quadpoint is array of weights.
	function mcovth(density,meanth,quadpoint)
		implicit none
		real(kind=8),intent(in)::density(:),meanth(:),quadpoint(:,:)
		real(kind=8)::mcovth(size(meanth),size(meanth))
	end function mcovth

!	Multinomial third moments.  Covariance of product and single term.
!	density contains weights.
!	meanth contains means.
!	mean2th contains means of products.
!	quadpoint contains points.

	function mcubth(density,meanth,mean2th,quadpoint)
		implicit none
		real(kind=8),intent(in)::density(:),meanth(:),mean2th(:,:),quadpoint(:,:)
		real(kind=8)::mcubth(size(meanth),size(meanth),size(meanth))
	end function mcubth

!	Multinomial mean.
!	density is vector of probabilities
!	quadpoint is array of weights.
	function mmeanth(density,quadpoint)
		implicit none
		real(kind=8),intent(in)::density(:),quadpoint(:,:)
		real(kind=8)::mmeanth(size(quadpoint,1))
	end function mmeanth

!	Means of products.  meanth contains means.
!	covth contains covariances.
!	quadpoint contains points.  density contains weights.
	function mprodth(covth,meanth)
		implicit none
		real(kind=8),intent(in)::covth(:,:),meanth(:)
		real(kind=8)::mprodth(size(meanth),size(meanth))
	end function mprodth

!	Multinomial fourth moments.  Covariances of cross-products.
!	density provides weights.
!	points are in quadpoint.
!	Product means are in mean2th.
	function mquarth(density,mean2th,quadpoint)
		implicit none
		real(kind=8),intent(in)::density(:),mean2th(:,:),quadpoint(:,:)
		real(kind=8)::mquarth(size(mean2th,1),size(mean2th,1),size(mean2th,1),size(mean2th,1))
	end function mquarth

!	negative hessian of log conditional probability of an observation.
!	rbetamap is the reduced beta map
!	mask indicates the items presented.
!	condprobcat contains conditional item probabilities.
!	covth is the covariance matrix of the latent vector.
!	cubth provides covariances of products of latent vector elements and of latent vector elements.
!	probcat contains item probabilities.
!	quarth provides covariances of products of latent vector elements.
!	theta is the latent vector.
!	thpr is the independent vector.

	function nhessvec(rbetamap,mask,condprobcat,covth,cubth,newtheta,probcat,quarth,theta,thpr)
		implicit none
		integer,intent(in)::rbetamap(:,:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::condprobcat(:),covth(:,:),cubth(:,:,:),newtheta(:),probcat(:),quarth(:,:,:,:),theta(:),thpr(:)
		real(kind=8)::nhessvec(size(rbetamap,2),size(rbetamap,2))
	end function nhessvec

!	probvec is used to compute underlying item probabilities.
!   	numcat indicates the number of underlying categories per item.
!	mask indicates which items were presented.
!	locations provides location parameters and scales provides scale factors.
!	theta is the value of the latent vector.
	function probvec(numcat,mask,locations,scales,theta)
		implicit none
		integer,intent(in)::numcat(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::locations(:),scales(:,:),theta(:)
		real(kind=8)::probvec(size(locations))
	end function probvec

!	probvecobs is used to compute observed item probabilities given the latent vector.
!	catobsrange is the table of ranges of underlying categories per observed category.
!	numcatobs provides the number of observed categories per item.
!	resp is the response vector.
!	mask indicates which items were presented.
!	probcat is the vector of underlying item probabilities.
	function probvecobs(catobsrange,numcatobs,resp,mask,probcat)
		implicit none
		integer,intent(in)::catobsrange(:,:),numcatobs(:),resp(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::probcat(:)
		real(kind=8)::probvecobs(size(mask))
	end function probvecobs

!	Covariances of products of a normal random vector with covariance matric cov and mean mean.
	function quarticnormal(cov,mean)
		implicit none
		real(kind=8),intent(in)::cov(:,:),mean(:)
		real(kind=8)::quarticnormal(size(mean),size(mean),size(mean),size(mean))
	end function quarticnormal

!	Convert from adaptive quadrature scale to normalized latent vector.
!	Use nhchol for modified Cholesky decomposition of negative hessian.
!	Use oldalpha for location.
!	Use scalez for scaling.
!	Quadrature point is z.
	function scaleadapt(nhchol,oldalpha,scalez,z)
		implicit none

		real(kind=8),intent(in)::nhchol(:,:),oldalpha(:),scalez(:),z(:)
		real(kind=8)::scaleadapt(size(z))
	end function scaleadapt
!

!		This program uses the modified Cholesky decomposition
!		in lu to solve the equation lusolve = b.
	function solve(lu,b)
		implicit none

		real(kind=8),intent(in)::lu(:,:)
		real(kind=8),intent(in)::b(:)
		real(kind=8)::solve(size(b))
	end function solve

end interface
character(len=*),intent(in)::comment
integer,intent(in)::catobsrange(:,:),constdim1,dat(:,:),maxit,maxita,maxitb,numcat(:),numcatobs(:),rbetamap(:,:),unitno
logical,intent(in)::normal,nr,printprog,printprogstd,proport
real(kind=8),intent(in)::changemin,constmat(:,:),constvec(:),design(:,:),indvar(:,:),kappa,lintran(:,:),maxdalpha,&
	obsweight(:),offset(:),quadpoint(:,:),quadweight(:),&
	rdesign(:,:),tau,tol,tola,tolc,tolsing
real(kind=8),intent(inout)::alpha(:,:),beta(:),cholnhess(:,:,:),gamma(:)
real(kind=8),intent(out)::constquad(:,:),grad(:),graddes(:),grads(:,:),loglik,&
	nhess(:,:),nhessdes(:,:),nhessdeschol(:,:),nhessdesplus(:,:),postdensity(:,:),prob(:),theta(:,:,:)
!	al is allocation error flag.
!	col is the column number.
!	constdim is the total number of constraints.
!	dimlatin is the dimension of the latent vector.
!	dimlatout is the dimension of the transformed latent vector.

!	it is the iteration number.
!	ita is the iteration number for determination of the adaptive quadrature.
!	item is the item number.
!	ncat is the total number of underlying categories.
!	ncatobs is the total number of observed categories.
!	nitems is the number of items.
!	nobs is the total number of observations.
!	npred is the number of independent variables.

!	nquad is the number of quadrature points.

!	nreduce is the dimension of the reduced version of beta.
!	nscale is the pointer for scale parameters.
!	nscale1 points to the last scale parameter.
!	obs is the  observation number.
!	pred is the predictor number.

!	quad is the quadrature point index.
!	resp is the response vector for the observation under study.
!	row is the row number.
!	rowpt is the row pointer.

integer::al,col,constdim,dimlatin,dimlatout,it,ita,item,ncat,&
	nobs,nitems,npred,nquad,nreduce,nscale,nscale1,&
	obs,pred,quad,resp(size(dat,1)),row,rowpt

!	error is used to indicate a problem with a covariance matrix.
!	finish indicates whether iterations end.
!	linflag indicates if linear terms vary.
!	mask is .true. if the  item is  present and .false. otherwise.
!	nrskip is used to skip Newton-Raphson.
!	quadflag indicates if  quadratic terms vary.
logical::error,finish,linflag,mask(size(dat,1)),nrskip,quadflag

!	loc is the location vector for the latent vector.
!	lowtri is the lower triangular matrix in the Cholesky decomposition of the
!	covariance matrix of the latent vector.
!	probcat is a vector of conditional underlying item category probabilities.
!	probcatobs is a vector of conditional observed item category probabilities.
!	condprobcat is a vector of conditional probabilities of underlying item
!	categories given observed category probabilities.
!	nhchol is a matrix used in Cholesky decompositions for transformation of latent vectors.
!	gradth is a gradient with respect to the standardized latent vector value, and nhessth
!	is a negative hessian with respect
!	to the standardized latent vector value.
!	alphastep is a proposed change in alpha.
!	betastep is the change in beta proposed.
!	change is the change in weighted log likelihood.
!	condprob is a probability component.
!	consterr is the constraint error.
!	constweight is the multiplier of the sum of squares of constraint errors.
!	covth is the covariance matrix of the latent vector.
!	cubth is the matrix of third central moments of the latent vector.
!	der is the directional derivative of the weighted log likelihood.
!	gammastep is the proposed change in gamma.
!	gradlog is an array of gradients of logs of posterior densities at the latent vector.
!	gradobs is the gradient with respect to beta for a single observation.
!	lintheta is a matrix used for the log density of theta.  It provides a linear contribution.  It is
!	used in conjunction wih the vector linth.
!	locations is the vector of location parameters.
!	logcondprob is a logarithm of a probability component.
!	loglikn is the old log likelihood within the iteration.
!	loglikold is the previous log likelihood from the last iteration.
!	maxalphastep is the maximum norm of alphastep.
!	maxbeta is the maximum norm of betastep.
!	mean2th is the mean of products of elements of the latent vector.
!	meanth is the mean of the latent vector.
!   maxchol is the maximum diagonal in a Cholesky decomposition.
!   minchol is the minimum diagonal in a Cholesky decomposition.
!	newtheta is lintran(theta)
!	nhessobs is the negative hessian with respect to beta for a single observation.
!	nhessquad is a negative hessian of the log of a posterior density at the latent vector.
!	oldalpha is the previous alpha.
!	oldbeta is the previous beta.
!	oldconsterr is  the last constraint error.
!	oldlogcondprob is the previous value of logcondprob.
!	priordensity is the prior density of the latent vector at quadrature points.
!	quadtheta is ann array of matrices used for the log density of theta.  It is used  in conjunction
!	with quadth.
!	quarth is the matrix of fourth central moments of the latent vector minus products of covariances.
!	rowdiv is a divisor for a variable.
!	scale is the vector of scale factors for the latent vector.
!	scales is the matrix of scale factors.
!	scaletheta is the square root of the inverse of the determinant of covth.
!	scalez is used to scale latent vector values for adaptive quadrature.
!	scalezp is the product of the elements of scalez.
!	step is the step size.
!	stepmin is the minimum step size.
!	thpr is the vector of theta predictors for a particular observation.
!	v is a matrix used for constraints not based on least squares.
!	vv is a second matrix used for constraints not based on least squares.
!	xitemcount is a counter for the number of items presented for an observation.
!	z is a latent vector value in standard units.
real(kind=8)::alphastep(size(quadpoint,1)),&
	betastep(size(beta)),&
	change,condprob,condprobcat(sum(numcat)),consterr(size(constvec)),constweight,&
	covth(size(quadpoint,1),size(quadpoint,1)),scaletheta,&
	cubth(size(quadpoint,1),size(quadpoint,1),size(quadpoint,1)),&
	der,&
	gammastep(size(gamma)),gradlog(size(rbetamap,2)),gradobs(size(rdesign,1)),&
	gradth(size(quadpoint,1)),&
	linth(size(quadpoint,1)),lintheta(size(quadpoint,1),size(indvar,1)),&
	locations(sum(numcat)),loglikn,loglikold,logcondprob,&
	maxalphastep,maxbeta,maxchol,&
    mean2th(size(quadpoint,1),size(quadpoint,1)),meanth(size(quadpoint,1)),&
	minchol,newtheta(size(lintran,1)),nhchol(size(quadpoint,1),size(quadpoint,1)),&
	nhessobs(size(rdesign,1),size(rdesign,1)),&
	nhessquad(size(rbetamap,2),size(rbetamap,2)),nhessth(size(quadpoint,1),size(quadpoint,1)),&
	oldalpha(size(quadpoint,1)),oldbeta(size(beta)),oldconsterr(size(constvec)),&
	oldlogcondprob,&
	priordensity(size(quadweight)),probcat(sum(numcat)),&
	probcatobs(size(dat,1)),&
	quadth(size(quadpoint,1),size(quadpoint,1)),&
	quadtheta(size(quadpoint,1),size(quadpoint,1),size(indvar,1)),&
	quarth(size(quadpoint,1),size(quadpoint,1),size(quadpoint,1),size(quadpoint,1)),&
	scales(size(lintran,1),sum(numcat)),step,stepmin,&
	scalez(size(quadpoint,1)),scalezp(size(obsweight)),&
	thpr(size(indvar,1)),&
	xitemcount,&

	z(size(quadpoint,1))
real(kind=8),allocatable::v(:,:),vv(:,:)
!	Some sizes.
constdim=size(constvec)
dimlatin=size(quadpoint,1)
dimlatout=size(lintran,1)
ncat=sum(numcat)
nitems=size(dat,1)
nobs=size(obsweight)

nquad=size(quadweight)

nreduce=size(rdesign,1)
npred=size(indvar,1)
if(constdim1>0)then
	allocate(v(size(gamma),constdim1),vv(constdim1,constdim1),stat=al)
	if(al/=0)stop 'Allocation of constraint arrays failed.'
end if
!	Set up pointers for beta elements.
!	Item scale parameters.
nscale=ncat+1

nscale1=ncat*(1+dimlatout)
!	Parameters for quadratic component of log density.

!	Check for linear and quadratic terms
linflag=.false.
quadflag=.false.
if(any(rbetamap(3,:)>0.and.rbetamap(5,:)==0))linflag=.true.
if(any(rbetamap(3,:)>0.and.rbetamap(4,:)>0))quadflag=.true.
if(constdim1<constdim) then
	constquad=2.0_8*matmul(constmat(:,constdim1+1:constdim),transpose(constmat(:,constdim1+1:constdim)))
	constweight=1.0_8
	if(proport)then
		constweight=sum(obsweight)
		constquad=constweight*constquad

	end if

end if

!	Up to maxit iterations.
finish=.false.

do it=0,maxit

	if(it>=maxit)finish=.true.
!	Initialize gradient and hessian.
	grad=0.0_8
	nhess=0.0_8
	prob=0.0_8

!	Initialize information measure.

	loglik=0.0_8
	if(constdim>0)then
		consterr=constvec-matmul(transpose(constmat),gamma)
		if(constdim1<constdim)loglik=-constweight*sum(consterr(constdim1+1:constdim)*consterr(constdim1+1:constdim))

	end if

!	Set up parameter arrays for simplified processing.

	locations=beta(1:ncat)

	scales=reshape(beta(nscale:nscale1),(/dimlatout,ncat/))

	call getlinquad(beta,lintheta,quadtheta)

	do obs=1,nobs

		if(obsweight(obs)<=0.0_8) cycle

! Observation obs.
		resp=dat(:,obs)

		mask=.false.
		do item=1,nitems
			if(resp(item)>=0.and.resp(item)<numcatobs(item))mask(item)=.true.
		end do

!	Density specification for observation.
		thpr=indvar(:,obs)

		call getlinquadth(lintheta,quadtheta,thpr,linth,quadth)
!	The normal versus multinomial cases differ here.
		if(normal)then
!	Mean and covariance matrix of latent vector.

			nhchol=chol(-2.0_8*quadth,tolsing)
!	Check that covariance matrix is positive definite.
			if(minval((/(nhchol(row,row),row=1,dimlatin)/))<=0.0_8)stop "Unacceptable covariance matrix"
			scaletheta=sqrt(product((/(nhchol(row,row),row=1,dimlatin)/)))

			meanth=solve(nhchol,linth)
			scaletheta=scaletheta*exp(-0.5_8*dot_product(linth,meanth))
			covth=invert(nhchol)
			mean2th=mprodth(covth,meanth)
			if(linflag.and.quadflag)cubth=cubicnormal(covth,meanth)
			if(quadflag)quarth=quarticnormal(covth,meanth)

! 	Location maximum of likelihood contribution for examinee k.

!	See if adaptive approach to be used.
			if(maxita>0) then

				call maxpost(catobsrange,maxita,maxita,npred,numcat,numcatobs,resp,mask,beta,changemin,&
					linth,lintran,maxdalpha,quadth,tau,tol,tolsing,&
					nhchol,alpha(:,obs))
				cholnhess(:,:,obs)=nhchol

			end if
		end if
!	Initialize gradient and negative hessian.  Initialize probability.

		gradobs=0.0_8

		nhessobs=0.0_8

!	Scale factors and priordensities.
		if(normal)then
			nhchol=cholnhess(:,:,obs)
			oldalpha=alpha(:,obs)

			do row=1,dimlatin
				scalez(row)=1.0_8/sqrt(nhchol(row,row))
			end do
			scalezp(obs)=product(scalez)
			scaletheta=scaletheta*scalezp(obs)
			do quad=1,nquad
				theta(:,quad,obs)=scaleadapt(nhchol,oldalpha,scalez,quadpoint(:,quad))
			end do
			priordensity=density(linth,theta(:,:,obs),quadth,quadweight,scaletheta)

		else
			theta(:,:,obs)=quadpoint
			priordensity=densitym(linth,quadpoint,quadth,quadweight)
			if(linflag.or.quadflag)then
				meanth=mmeanth(priordensity,quadpoint)
				covth=mcovth(priordensity,meanth,quadpoint)
				if(quadflag)then
					mean2th=mprodth(covth,meanth)
					cubth=mcubth(priordensity,meanth,mean2th,quadpoint)
					quarth=mquarth(priordensity,mean2th,quadpoint)
				end if
			end if

		end if
!	Cycle through quadrature points.

		do quad=1,nquad

!	Probability computation.

			newtheta=matmul(lintran,theta(:,quad,obs))
			probcat=probvec(numcat,mask,locations,scales,newtheta)

			probcatobs=probvecobs(catobsrange,numcatobs,resp,mask,probcat)

			postdensity(quad,obs)=product(probcatobs,mask)*priordensity(quad)

			prob(obs)=prob(obs)+postdensity(quad,obs)

			condprobcat=condprobvec(catobsrange,numcatobs,resp,mask,probcat,probcatobs)

!	Gradient and negative hessian computations.
			gradlog= gradvec(rbetamap,mask,condprobcat,meanth,mean2th,newtheta,probcat,theta(:,quad,obs),thpr)
			do row=1,nreduce
				if(gradlog(row)/=0.0_8)gradobs(row)=gradobs(row)+postdensity(quad,obs)*gradlog(row)
			end do
			if(nr)then
				nhessquad=nhessvec(rbetamap,mask,condprobcat,covth,cubth,newtheta,&
					probcat,quarth,theta(:,quad,obs),thpr)
				do row=1,nreduce
					do col=1,row
						if((gradlog(row)/=0.0.and.gradlog(col)/=0.0_8).or.nhessquad(row,col)/=0.0_8)&
							nhessobs(row,col)=nhessobs(row,col)+postdensity(quad,obs)*(nhessquad(row,col)&
							-gradlog(row)*gradlog(col))
					end do
				end do
			end if
		end do
		do row=1,nreduce
			if(gradobs(row)/=0.0_8)	gradobs(row)=gradobs(row)/prob(obs)
		end do
		postdensity(:,obs)=postdensity(:,obs)/prob(obs)
		if(nr)then
			do row=1,nreduce
				do col=1,nreduce
					if(nhessobs(row,col)/=0.0_8.or.(gradobs(row)/=0.0_8.and.gradobs(col)/=0.0_8))&
						nhessobs(row,col)=nhessobs(row,col)/prob(obs)+gradobs(row)*gradobs(col)
				end do
			end do
		end if
		do row=1,nreduce
			if(gradobs(row)/=0.0_8)grad(row)=grad(row)+obsweight(obs)*gradobs(row)
		end do
		grads(:,obs)=gradobs
		if(nr)then
			do row=1,nreduce
				do col=1,row
					if(nhessobs(row,col)/=0.0_8)&
						nhess(row,col)=nhess(row,col)+obsweight(obs)*nhessobs(row,col)
				end do
			end do
		end if

		loglik=loglik+obsweight(obs)*log(prob(obs))

	end do
!	Check for adequate progress.
	if(nr)call makesym(nhess)
	oldbeta=beta
	if(constdim>0)oldconsterr=consterr
	step=1.0_8
!	Save log likelihood.
	loglikn=loglik
!	Gradients and hessians.
	graddes=matmul(transpose(rdesign),grad)

	if(constdim1<constdim) graddes=graddes+2.0_8*constweight*matmul(constmat(:,constdim1+1:constdim),consterr)
	nrskip=.false.
	if(nr)then
		nhessdes=matmul(transpose(rdesign),matmul(nhess,rdesign))
		nhessdesplus=nhessdes
		if(constdim1<constdim)nhessdesplus=nhessdesplus+constquad
		nhessdeschol=chol(nhessdesplus,tolsing)
!	If not nonnegative definite, then use Louis approach.
!		if(minval((/(nhessdeschol(row,row),row=1,size(gamma))/))<0.0_8)nrskip=.true.
        do ita=1,maxitb
            minchol=minval((/(nhessdeschol(row,row),row=1,size(gamma))/))
            maxchol=maxval((/(nhessdeschol(row,row),row=1,size(gamma))/))
            if(minchol<tolc*maxchol)then
                do row=1,size(gamma)
                    nhessdesplus(row,row)=nhessdesplus(row,row)+ita*maxchol
                end do
                nhessdeschol=chol(nhessdesplus,tolsing)
            else
                exit
            end if
        end do
    end if
	if(.not.nr)then
		nhess=information(.false.,grads,obsweight)
		nhessdes=matmul(transpose(rdesign),matmul(nhess,rdesign))
		nhessdesplus=nhessdes
		if(constdim1<constdim)nhessdesplus=nhessdesplus+constquad
		nhessdeschol=chol(nhessdesplus,tolsing)
        do ita=1,maxitb
            minchol=minval((/(nhessdeschol(row,row),row=1,size(gamma))/))
            maxchol=maxval((/(nhessdeschol(row,row),row=1,size(gamma))/))
            if(minchol<tolc*maxchol)then
                do row=1,size(gamma)
                    nhessdesplus(row,row)=nhessdesplus(row,row)+ita*maxchol
                end do
                nhessdeschol=chol(nhessdesplus,tolsing)
            else
                exit
            end if
        end do
    end if

	if(finish)return
!	Tentative steps.

	gammastep=solve(nhessdeschol,graddes)
	if(constdim1>0)then
		do col=1,constdim1
			v(:,col)=solve(nhessdeschol,constmat(:,col))
		end do
		vv=matmul(transpose(v),matmul(nhessdesplus,v))
		vv=chol(vv,tolsing)
		gammastep=gammastep&
            +matmul(v,solve(vv,consterr(1:constdim1)&
            -matmul(transpose(constmat(:,1:constdim1)),gammastep)))

	end if
	betastep=matmul(design,gammastep)
	maxbeta=maxval(abs(betastep))
!	See if step is too large.
	if (maxbeta>kappa) step=kappa/maxbeta
!	Predict improvement.
	der=dot_product(graddes,gammastep)

	do ita=1,maxitb
!	Take step and check progress.
		beta=oldbeta+step*betastep
		locations=beta(1:ncat)
		scales=reshape(beta(nscale:nscale1),(/dimlatout,ncat/))

		call getlinquad(beta,lintheta,quadtheta)

!	Error flag
		error=.false.

		loglik=0.0_8

		if(constdim>0) consterr=oldconsterr-step*matmul(transpose(constmat),gammastep)
		if(constdim1<constdim) loglik=-constweight*sum(consterr(constdim1+1:constdim)*consterr(constdim1+1:constdim))

		prob=0.0_8
!	New log likelihood.
		do obs=1,nobs

			if(obsweight(obs)<=0.0_8) cycle

! Observation obs.
			resp=dat(:,obs)

			mask=.false.
			do item=1,nitems
				if(resp(item)>=0.and.resp(item)<numcatobs(item))mask(item)=.true.
			end do

!	Density specification for observation.
			thpr=indvar(:,obs)
			call getlinquadth(lintheta,quadtheta,thpr,linth,quadth)

			if(normal)then
!	Mean and covariance matrix of latent vector.
				nhchol=chol(-2.0_8*quadth,tolsing)
!	Check that covariance matrix is positive definite.
				if(minval((/(nhchol(row,row),row=1,dimlatin)/))<=0.0_8)then
					error=.TRUE.
					exit
				end if
				meanth=solve(nhchol,linth)

				scaletheta=sqrt(product((/(nhchol(row,row),row=1,dimlatin)/)))
				scaletheta=scaletheta*exp(-0.5_8*dot_product(linth,meanth))

! 	Location maximum of likelihood contribution for examinee k.

!	See if adaptive approach to be used.
				if(maxita>0) then

					call maxpost(catobsrange,maxita,maxita,npred,numcat,numcatobs,resp,mask,beta,changemin,&
						linth,lintran,maxdalpha,quadth,tau,tola,tolsing,&
						nhchol,alpha(:,obs))
					cholnhess(:,:,obs)=nhchol

				end if

				oldalpha=alpha(:,obs)

				do row=1,dimlatin
					scalez(row)=1.0_8/sqrt(nhchol(row,row))
				end do
				scalezp(obs)=product(scalez)
				scaletheta=scaletheta*scalezp(obs)
				do quad=1,nquad
					theta(:,quad,obs)=scaleadapt(nhchol,oldalpha,scalez,quadpoint(:,quad))
				end do
				priordensity=density(linth,theta(:,:,obs),quadth,quadweight,scaletheta)

!	 Scale factor

			else
				priordensity=densitym(linth,quadpoint,quadth,quadweight)

			end if
!	Cycle through quadrature points.
			do quad=1,nquad

! Probability computation.
				newtheta=matmul(lintran,theta(:,quad,obs))
				probcat=probvec(numcat,mask,locations,scales,newtheta)
				probcatobs=probvecobs(catobsrange,numcatobs,resp,mask,probcat)
				postdensity(quad,obs)=product(probcatobs,mask)*priordensity(quad)

				prob(obs)=prob(obs)+postdensity(quad,obs)

			end do

			postdensity(:,obs)=postdensity(:,obs)/prob(obs)
			loglik=loglik+obsweight(obs)*log(prob(obs))
		end do
!	Error in covariance matrix requires step reduction.

		if(error)then
			loglik=loglikn
			step=step/2.0_8
		else

!	See if change in log likelihood acceptable.

			change=loglik-loglikn

			if(change>step*der*changemin) exit
			stepmin = step*tau
			step = step*der/(2.0_8*(der-change/step))
			if(step<stepmin) step = stepmin
		end if
	end do
	if(printprog.or.printprogstd)call  iterationreport(comment,it,unitno,printprog,printprogstd,loglik,step)
	gamma=gamma+step*gammastep
!	Finish up.
	if(change<(-tol*loglikn))finish=.true.
!	The following check arises due to quadrature errors.
	if(it>0)then
		if(loglik<loglikold)finish=.true.
	end if
	loglikold=loglik

end do
return
end subroutine  ndmmaxlik


subroutine AspirationUpdate(nodeUpdate, payoffUpdate, randNumUpdate)
    use global
    implicit none
    integer,intent(in)::nodeUpdate
    real(8),intent(in)::payoffUpdate
    real(8), intent(in)::randNumUpdate

    real(8)::switchProb
    real(8)::AspirationMinusPayoff
    !!

    AspirationMinusPayoff = aspirationValueNode(nodeUpdate) - payoffUpdate
    switchProb = real(1.0,8) / (real(1.0,8) + exp(-selectionIntensity * AspirationMinusPayoff))
    !!!
    if(randNumUpdate < switchProb)then
        strategyPGG(nodeUpdate) = 1 - strategyPGG(nodeUpdate)
    end if

    return
end subroutine AspirationUpdate


\ -----------------------------------------------------------------------------
\  Lichens
\  Cellular Automata
\  Michel Jean 2019
\ -----------------------------------------------------------------------------

S" Rand.f" INCLUDED
S" pixel.f" INCLUDED

320 constant largeur-monde \
200 constant hauteur-monde
largeur-monde hauteur-monde * constant dim-monde

variable pos-X
variable pos-Y

0 pos-X !
0 pos-Y !

\ ============================================

create  monde dim-monde allot
create  monde-buf dim-monde allot

variable *monde
variable *monde-buf
variable tampon

variable total \ nbr voisins
variable etat \ etat de la cellule

' monde *monde !
' monde-buf *monde-buf !

: centre ( n -- )
*monde @ + c@
;
\ 9 voisins possibles
: est ( n -- )
	1 + dim-monde mod *monde @ + c@ ;

: ouest ( n -- )
	1 - dim-monde mod *monde @ + c@ ;

: nord ( n -- )
	largeur-monde - dim-monde mod *monde @ + c@ ;

: sud ( n -- )
	largeur-monde + dim-monde mod *monde @ + c@ ;

: nord-est ( n -- )
	largeur-monde - 1 + dim-monde mod *monde @ + c@ ;

: nord-ouest ( n -- )
	largeur-monde - 1 - dim-monde mod *monde @ + c@ ;

: sud-est ( n -- )
	largeur-monde + 1 + dim-monde mod *monde @ + c@ ;

: sud-ouest ( n -- )
	largeur-monde + 1 - dim-monde mod *monde @ + c@ ;

\ voisinage de moore

: moore ( n -- ) \ returne le nombre de voisins

	dup nord-ouest
	swap dup nord
	swap dup nord-est
	swap dup est
	swap dup sud-est
	swap dup sud
	swap dup sud-ouest
	swap ouest
;

: somme-moore
	moore
	+ + + + + + +
;

\ regles lichens
: lichens
	dup
	centre etat c!
	somme-moore total c!

	total @ 3 = if 1 etat c! ELSE
	total @ 4 = if 0 etat c! ELSE
	total @ 7 = if 1 etat c! ELSE
	total @ 8 = if 1 etat c!
	then then then then
	etat c@
;

\ =========================================

: initialisation ( -- ) \ monde aléatoire
	*monde @ dim-monde 0 fill
	dim-monde 0 do 100 random
	1 = if 1 *monde @ i + c! then loop
;

: regenere-monde
	dim-monde 0 do i lichens *monde-buf @ i + c! loop
	*monde tampon 1 cells move
	*monde-buf *monde 1 cells move
	tampon *monde-buf 1 cells move
;

: dessine-monde ( -- )
	largeur-monde 0 do
	hauteur-monde 0 do
		largeur-monde i * j + *monde @ + c@ 1 = if
			j i green pixel else
				j i black pixel

	then
	loop loop

;

: run
	initialisation
	set-screen
	dessine-monde
	do
		dessine-monde
		regenere-monde
		view
		10 pause
	loop
;

run


MODULE mod_numerical_fluxes

    USE mod_euler_flux_jacobian
    USE mod_constants
    USE mod_exact_riemann

    IMPLICIT NONE

CONTAINS

    SUBROUTINE godunov_flux_x(w, F)
        IMPLICIT NONE

        REAL(dp_kind), DIMENSION(:,:,:), INTENT(IN) :: w
        REAL(dp_kind), DIMENSION(:,:,:), INTENT(INOUT) :: F

        REAL(dp_kind), DIMENSION(4) :: wl, wr, wCl, wCr, w_vert, lambda_l, lambda_r, lambda

        REAL(dp_kind) :: vl, ul,  vr, ur,  vCl, vCr, uC,  ss ! shock speed

        INTEGER :: i, j

        LOGICAL, PARAMETER :: dir = .TRUE.

        REAL(dp_kind), PARAMETER :: rel_tol = 1.0d-8

        DO j = 1, SIZE(w, 2) ! ciclo esterno su y
            DO i = 1, SIZE(w,1)-1 ! ciclo interno su x

                ! recuperiamo lo stato sinistro wl e lo stato destro wl
                wl = w(i,j,i_cons)
                wr = w(i+1,j,i_cons)

                ! controlliamo che ci sia salto
                IF (SQRT(SUM((wr - wl)**2))  <  SQRT(SUM((wl + wr)**2)) * rel_tol) THEN

                    w_vert = wl     ! idem wr

                ELSE

                    vl = 1/wl(1);   ul = wl(2)/wl(1)
                    vr = 1/wr(1);   ur = wr(2)/wr(1)

                    CALL exact_riemann (wl, wr,  wCl, wCr, dir )

                    WRITE(*,*) 'F: i,j = ', i,j

                    uC = wCl(2)/wCl(1) ! ;  PC = Pi(wCl)

                    IF (uC > 0) THEN  ! The contact discontinuity propagates to
                                       ! the right: the third wave is not relevant

                        vCl = 1/wCl(1)

                        IF (vCl < vl) THEN ! LEFT SHOCK

                            ! Compute the shock speed
                            ss = (vl*uC - vCl*ul)/(vl - vCl)

                            IF (ss > 0) THEN ! right propagating shock
                                w_vert = wl
                            ELSE             ! left propagating shock
                                w_vert = wCl
                            ENDIF

                        ELSE ! LEFT RAREFACTION

                            lambda_l = eigenvalues(wl, dir )
                            lambda   = eigenvalues(wCl, dir )

                            IF (lambda_l(1) >= 0) THEN ! right propagating fan
                                w_vert = wl
                            ELSEIF (lambda(1) <= 0) THEN ! left propagating fan
                                w_vert = wCl
                            ELSE ! transonic rarefaction for the first wave
                                w_vert = ws_sonic_state(1, wl, dir )
                            ENDIF

                        ENDIF ! alternative shock  vs  fan for the first wave

                    ELSE ! (uC < 0) The contact discontinuity propagates to
                          !          the left: the first wave is not relevant

                        vCr = 1/wCr(1)

                        IF (vCr < vr) THEN ! RIGHT SHOCK

                            ! Compute the shock speed
                            ss = (vr*uC - vCr*ur)/(vr - vCr)

                            IF (ss > 0) THEN ! right propagating shock
                                w_vert = wCr
                            ELSE             ! left propagating shock
                                w_vert = wr
                            ENDIF

                        ELSE ! RIGHT RAREFACTION

                            lambda   = eigenvalues(wCr, dir )
                            lambda_r = eigenvalues(wr, dir )

                            IF (lambda(4) >= 0) THEN ! right propagating fan
                                w_vert = wCr
                            ELSEIF (lambda_r(4) <= 0) THEN ! left propagating fan
                                w_vert = wr
                            ELSE ! transonic rarefaction for the third wave
                                w_vert = ws_sonic_state(4, wr, dir )
                            ENDIF

                        ENDIF ! alternative shock  vs  fan for the fourth wave

                    ENDIF ! alternative uC >  or  uC <= 0

                ENDIF ! il salto è rilevante

                F(i,j,:) = flux_x(w_vert)

            END DO

        END DO

    END SUBROUTINE godunov_flux_x

    SUBROUTINE godunov_flux_y(w, G)
        IMPLICIT NONE

        REAL(dp_kind), DIMENSION(:,:,:), INTENT(IN) :: w
        REAL(dp_kind), DIMENSION(:,:,:), INTENT(INOUT) :: G

        REAL(dp_kind), DIMENSION(4) :: wl, wr, wCl, wCr, w_vert, lambda_l, lambda_r, lambda

        REAL(dp_kind) :: vl, ul,  vr, ur,  vCl, vCr, uC,  ss ! shock speed

        INTEGER :: i, j

        LOGICAL, PARAMETER :: dir = .FALSE.

        REAL(dp_kind), PARAMETER :: rel_tol = 1.0d-8

        DO i = 1, SIZE(w, 2) ! ciclo esterno su y
            DO j = 1, SIZE(w,1)-1 ! ciclo interno su x

                ! recuperiamo lo stato sinistro wl e lo stato destro wr
                wl = w(i,j,i_cons)
                wr = w(i,j+1,i_cons)

                ! controlliamo che ci sia salto
                IF (SQRT(SUM((wr - wl)**2))  <  SQRT(SUM((wl + wr)**2)) * rel_tol) THEN

                    w_vert = wl     ! idem wr

                ELSE

                    vl = 1/wl(1);   ul = wl(3)/wl(1)
                    vr = 1/wr(1);   ur = wr(3)/wr(1)

                    CALL exact_riemann (wl, wr,  wCl, wCr, dir )

                    WRITE(*,*) 'G: i,j = ', i,j

                    uC = wCl(3)/wCl(1) ! ;  PC = Pi(wCl)

                    IF (uC > 0) THEN  ! The contact discontinuity propagates to
                                       ! the right: the third wave is not relevant

                        vCl = 1/wCl(1)

                        IF (vCl < vl) THEN ! LEFT SHOCK

                            ! Compute the shock speed
                            ss = (vl*uC - vCl*ul)/(vl - vCl)

                            IF (ss > 0) THEN ! right propagating shock
                                w_vert = wl
                            ELSE             ! left propagating shock
                                w_vert = wCl
                            ENDIF

                        ELSE ! LEFT RAREFACTION

                            lambda_l = eigenvalues(wl, dir )
                            lambda   = eigenvalues(wCl, dir )

                            IF (lambda_l(1) >= 0) THEN ! right propagating fan
                                w_vert = wl
                            ELSEIF (lambda(1) <= 0) THEN ! left propagating fan
                                w_vert = wCl
                            ELSE ! transonic rarefaction for the first wave
                                w_vert = ws_sonic_state(1, wl, dir )
                            ENDIF

                        ENDIF ! alternative shock  vs  fan for the first wave

                    ELSE ! (uC < 0) The contact discontinuity propagates to
                          !          the left: the first wave is not relevant

                        vCr = 1/wCr(1)

                        IF (vCr < vr) THEN ! RIGHT SHOCK

                            ! Compute the shock speed
                            ss = (vr*uC - vCr*ur)/(vr - vCr)

                            IF (ss > 0) THEN ! right propagating shock
                                w_vert = wCr
                            ELSE             ! left propagating shock
                                w_vert = wr
                            ENDIF

                        ELSE ! RIGHT RAREFACTION

                            lambda   = eigenvalues(wCr, dir )
                            lambda_r = eigenvalues(wr, dir )

                            IF (lambda(4) >= 0) THEN ! right propagating fan
                                w_vert = wCr
                            ELSEIF (lambda_r(4) <= 0) THEN ! left propagating fan
                                w_vert = wr
                            ELSE ! transonic rarefaction for the third wave
                                w_vert = ws_sonic_state(4, wr, dir )
                            ENDIF

                        ENDIF ! alternative shock  vs  fan for the fourth wave

                    ENDIF ! alternative uC >  or  uC <= 0

                ENDIF ! il salto è rilevante

                G(i,j,:) = flux_y(w_vert)

            END DO

        END DO

    END SUBROUTINE godunov_flux_y

    SUBROUTINE HLLC_flux_x(w,F)
        ! HLLC numerical flux according to Toro 10.6 pagg. 331-332

        IMPLICIT NONE

        REAL(dp_kind), DIMENSION(:,:,:), INTENT(IN) :: w
        REAL(dp_kind), DIMENSION(:,:,:), INTENT(INOUT) :: F

        REAL(dp_kind), DIMENSION(SIZE(w,1)-1,SIZE(w,2)) :: p_star, p_pvrs, rho_bar, c_bar, q_l, q_r, S_l, S_r, S_star

        REAL(dp_kind), DIMENSION(4) :: w_star_k, tmp_wl, tmp_wr

        INTEGER :: r_min, r_max, l_min, l_max

        INTEGER :: i, j

        REAL(dp_kind), PARAMETER :: rel_tol = 1.0d-8

        r_min = 2
        r_max = num_cells

        l_min = 1
        l_max = num_cells - 1

        rho_bar = HALF*( w(l_min:l_max,:,i_rho) + w(r_min:r_max,:,i_rho) )

        c_bar =  HALF*( w(l_min:l_max,:,i_c) + w(r_min:r_max,:,i_c) )

        p_pvrs = HALF*( w(l_min:l_max,:,i_P) + w(r_min:r_max,:,i_P) ) - &
                 HALF*( w(r_min:r_max,:,i_u) - w(l_min:l_max,:,i_u) ) * rho_bar * c_bar

        WHERE (p_pvrs > 0)
            p_star = p_pvrs
        ELSEWHERE
            p_star = 0.0d0
        END WHERE

        q_l = ONE;    q_r = ONE

        WHERE (p_star > w(l_min:l_max,:,i_P))
            q_l = SQRT(ONE + (gamma + ONE)/(2.0*gamma)*( p_star/w(l_min:l_max,:,i_P) - ONE)  )
        END WHERE

        WHERE (p_star > w(r_min:r_max,:,i_P))
            q_r = SQRT(ONE + (gamma + ONE)/(2.0*gamma)*( p_star/w(r_min:r_max,:,i_P) - ONE)  )
        END WHERE

        S_l = w(l_min:l_max,:,i_u) - w(l_min:l_max,:,i_c)*q_l
        S_r = w(r_min:r_max,:,i_u) + w(r_min:r_max,:,i_c)*q_r

        ! S* = (pR - pL + rhoL uL (SL - uL )  - rhoR uR (SR - uR) ) / ( rhoL(SL -uL ) - rhoR (SR - uR ) )

        S_star = ( w(r_min:r_max,:,i_P) - w(l_min:l_max,:,i_P) + &
                   w(l_min:l_max,:,i_rho) * w(l_min:l_max,:,i_u) * (S_l - w(l_min:l_max,:,i_u) ) - &
                   w(r_min:r_max,:,i_rho) * w(r_min:r_max,:,i_u) * (S_r - w(r_min:r_max,:,i_u) ) &
                 ) / ( w(l_min:l_max,:,i_rho) * (S_l - w(l_min:l_max,:,i_u) ) - &
                       w(r_min:r_max,:,i_rho) * (S_r - w(r_min:r_max,:,i_u) ) )

        ! flux for left and right boundary
        DO j = 1, SIZE(w,2)
            F(1,j,:) = flux_x(w(1,j,i_cons))
            F(num_cells+1,j,:) = flux_x(w(num_cells,j,i_cons))
        END DO

        DO j = 1, SIZE(w,2)
            DO i = 1, SIZE(w,1) - 1

                ! if states are equal we skip computation
                ! recuperiamo lo stato sinistro wl e lo stato destro wr
                tmp_wl = w(i,j,i_cons)
                tmp_wr = w(i+1,j,i_cons)

                ! controlliamo che ci sia salto
                IF (SQRT(SUM((tmp_wr - tmp_wl)**2))  <  SQRT(SUM((tmp_wl + tmp_wr)**2)) * rel_tol) THEN
                    F(i+1,j,:) = flux_x(w(i,j,i_cons))
                    CYCLE
                ENDIF

                ! compute HLLC flux according to wave speed values
                IF (S_l(i,j) >= 0.0 ) THEN
                    F(i+1,j,:) = flux_x(w(i,j,i_cons)) ! FL
                ELSEIF ( S_star(i,j) >= 0.0 .AND. S_l(i,j) < 0.0 ) THEN
                    ! inizializzo le var note di w_star_k (U_star_k nel testo)
                    w_star_k(1) = ONE
                    w_star_k(2) = S_star(i,j)
                    w_star_k(3) = w(i,j,i_v)
                    w_star_k(4) = w(i,j,i_eT)/w(i,j,i_rho) + &                ! Ek/rho_k +
                                  (S_star(i,j) - w(i,j,i_u) ) *  &            ! (S_star - u_k) *
                                  (S_star(i,j) + w(i,j,i_P)/( w(i,j,i_rho)* ( S_l(i,j) - w(i,j,i_u)  ) )  )! ( S_star + p_K/(rho_k*(S_k - u_k)))

                    w_star_k = w_star_k*w(i,j,i_rho)*( (S_l(i,j) - w(i,j,i_u) ) / ( S_l(i,j) - S_star(i,j)  )   )

                    F(i+1,j,:) = flux_x(w(i,j,i_cons)) + S_l(i,j)*(w_star_k - w(i,j,i_cons))  ! F_star_L
                ELSEIF ( S_r(i,j ) < 0.0 ) THEN
                    F(i+1,j,:) = flux_x(w(i+1,j,i_cons)) ! FR
                ELSEIF ( S_r(i,j) >= 0.0 .AND. S_star(i,j) < 0.0 ) THEN
                    ! inizializzo le var note di w_star_k (U_star_k nel testo)
                    w_star_k(1) = ONE
                    w_star_k(2) = S_star(i,j)
                    w_star_k(3) = w(i+1,j,i_v)
                    w_star_k(4) = w(i+1,j,i_eT)/w(i+1,j,i_rho) +   &            ! Ek/rho_k +
                                  (S_star(i,j) - w(i+1,j,i_u) ) *    &           ! (S_star - u_k ) *
                                  (S_star(i,j) + w(i+1,j,i_P)/( w(i+1,j,i_rho)*( S_r(i,j) - w(i+1,j,i_u) ) ) ) ! ( S_star + p_K/(rho_k*(S_k - u_k)))

                    w_star_k = w_star_k*w(i+1,j,i_rho)*( (S_r(i,j) - w(i+1,j,i_u) ) / ( S_r(i,j) - S_star(i,j)  )   )

                    F(i+1,j,:) = flux_x(w(i+1,j,i_cons)) + S_r(i,j)*(w_star_k - w(i+1,j,i_cons))  ! F_star_L
                ELSE
                    WRITE(*,*) 'No suitable condition found for HLLC x at ', i,j
                    WRITE(*,*) 'S_L:', S_l(i,j), 'S*:', S_star(i,j), 'S_R:', S_r(i,j)
                    WRITE(*,*) 'q_l:', q_l(i,j), 'q_r:',q_r(i,j)
                    WRITE(*,*) 'u_l:', w(i,j,i_u), 'u_r:',w(i+1,j,i_u)
                    WRITE(*,*) 'c_l:', w(i,j,i_c), 'c_r:',w(i+1,j,i_c)
                    WRITE(*,*) 'e_l:', w(i,j,i_e), 'e_r:',w(i+1,j,i_e)
                    WRITE(*,*) 'eT_l:', w(i,j,i_eT), 'eT_r:',w(i+1,j,i_eT)
                    WRITE(*,*) 'v_l:', w(i,j,i_v), 'v_r:',w(i+1,j,i_v)
                    WRITE(*,*) 'rho_l:', w(i,j,i_rho), 'rho_r:',w(i+1,j,i_rho)
                    STOP
                END IF
            END DO
        END DO

    END SUBROUTINE HLLC_flux_x

    SUBROUTINE HLLC_flux_y(w,G)
        ! HLLC numerical flux according to Toro 10.6 pagg. 331-332

        IMPLICIT NONE

        REAL(dp_kind), DIMENSION(:,:,:), INTENT(IN) :: w
        REAL(dp_kind), DIMENSION(:,:,:), INTENT(INOUT) :: G

        REAL(dp_kind), DIMENSION(SIZE(w,1),SIZE(w,2)-1) :: p_star, p_pvrs, rho_bar, c_bar, q_l, q_r, S_l, S_r, S_star

        REAL(dp_kind), DIMENSION(4) :: w_star_k, tmp_wl, tmp_wr

        INTEGER :: r_min, r_max, l_min, l_max

        INTEGER :: i, j

        REAL(dp_kind), PARAMETER :: rel_tol = 1.0d-8

        r_min = 2
        r_max = num_cells

        l_min = 1
        l_max = num_cells - 1

        rho_bar = HALF*( w(:,l_min:l_max,i_rho) + w(:,r_min:r_max,i_rho) )

        c_bar =  HALF*( w(:,l_min:l_max,i_c) + w(:,r_min:r_max,i_c) )

        p_pvrs = HALF*( w(:,l_min:l_max,i_P) + w(:,r_min:r_max,i_P) ) - &
                 HALF*( w(:,r_min:r_max,i_v) - w(:,l_min:l_max,i_v) ) * rho_bar * c_bar

        WHERE (p_pvrs > 0)
            p_star = p_pvrs
        ELSEWHERE
            p_star = 0.0d0
        END WHERE

        q_l = ONE;    q_r = ONE

        WHERE (p_star > w(:,l_min:l_max,i_P))
            q_l = SQRT(ONE + (gamma + ONE)/(2.0*gamma)*( p_star/w(:,l_min:l_max,i_P) - ONE)  )
        END WHERE

        WHERE (p_star > w(:,r_min:r_max,i_P))
            q_r = SQRT(ONE + (gamma + ONE)/(2.0*gamma)*( p_star/w(:,r_min:r_max,i_P) - ONE)  )
        END WHERE

        S_l = w(:,l_min:l_max,i_v) - w(:,l_min:l_max,i_c)*q_l
        S_r = w(:,r_min:r_max,i_v) + w(:,r_min:r_max,i_c)*q_r

        ! S* = (pR - pL + rhoL uL (SL - uL )  - rhoR uR (SR - uR) ) / ( rhoL(SL -uL ) - rhoR (SR - uR ) )

        S_star = ( w(:,r_min:r_max,i_P) - w(:,l_min:l_max,i_P) + &
                   w(:,l_min:l_max,i_rho) * w(:,l_min:l_max,i_v) * (S_l - w(:,l_min:l_max,i_v) ) - &
                   w(:,r_min:r_max,i_rho) * w(:,r_min:r_max,i_v) * (S_r - w(:,r_min:r_max,i_v) ) &
                 ) / ( w(:,l_min:l_max,i_rho) * (S_l - w(:,l_min:l_max,i_v) ) - &
                       w(:,r_min:r_max,i_rho) * (S_r - w(:,r_min:r_max,i_v) ) )

        ! flux for lower and upper boundary
        DO i = 1, SIZE(w,1)
            G(i,1,:) = flux_y(w(i,1,i_cons))
            G(i,num_cells+1,:) = flux_y(w(i,num_cells,i_cons))
        END DO

        DO j = 1, SIZE(w,2) - 1
            DO i = 1, SIZE(w,1)

                ! if states are equal we skip computation
                ! recuperiamo lo stato sinistro wl e lo stato destro wr
                tmp_wl = w(i,j,i_cons)
                tmp_wr = w(i,j+1,i_cons)

                ! controlliamo che ci sia salto
                IF (SQRT(SUM((tmp_wr - tmp_wl)**2))  <  SQRT(SUM((tmp_wl + tmp_wr)**2)) * rel_tol) THEN
                    G(i,j+1,:) = flux_y(w(i,j,i_cons)) ! FL
                    CYCLE
                ENDIF

                ! compute HLLC flux according to wave speed values
                IF (S_l(i,j) >= 0.0 ) THEN
                    G(i,j+1,:) = flux_y(w(i,j,i_cons)) ! FL
                ELSEIF ( S_star(i,j) >= 0.0 .AND. S_l(i,j) < 0.0 ) THEN
                    ! inizializzo le var note di w_star_k (U_star_k nel testo)
                    w_star_k(1) = ONE
                    w_star_k(2) = w(i,j,i_u)
                    w_star_k(3) = S_star(i,j)
                    w_star_k(4) = w(i,j,i_eT)/w(i,j,i_rho) + &                ! Ek/rho_k +
                                  (S_star(i,j) - w(i,j,i_v) ) *  &            ! (S_star - u_k) *
                                  (S_star(i,j) + w(i,j,i_P)/( w(i,j,i_rho)* ( S_l(i,j) - w(i,j,i_v)  ) )  )! ( S_star + p_K/(rho_k*(S_k - u_k)))

                    w_star_k = w_star_k*w(i,j,i_rho)*( (S_l(i,j) - w(i,j,i_v) ) / ( S_l(i,j) - S_star(i,j)  )   )

                    G(i,j+1,:) = flux_y(w(i,j,i_cons)) + S_l(i,j)*(w_star_k - w(i,j,i_cons))  ! F_star_L
                ELSEIF ( S_r(i,j ) <= 0.0 ) THEN
                    G(i,j+1,:) = flux_y(w(i,j+1,i_cons)) ! FR
                ELSEIF ( S_r(i,j) >= 0.0 .AND. S_star(i,j) < 0.0 ) THEN
                    ! inizializzo le var note di w_star_k (U_star_k nel testo)
                    w_star_k(1) = ONE
                    w_star_k(2) = w(i,j+1,i_u)
                    w_star_k(3) = S_star(i,j)
                    w_star_k(4) = w(i,j+1,i_eT)/w(i,j+1,i_rho) +   &            ! Ek/rho_k +
                                  (S_star(i,j) - w(i,j+1,i_v) ) *    &           ! (S_star - u_k ) *
                                  (S_star(i,j) + w(i,j+1,i_P)/( w(i,j+1,i_rho)*( S_r(i,j) - w(i,j+1,i_v) ) ) ) ! ( S_star + p_K/(rho_k*(S_k - u_k)))

                    w_star_k = w_star_k*w(i,j+1,i_rho)*( (S_r(i,j) - w(i,j+1,i_v) ) / ( S_r(i,j) - S_star(i,j)  )   )

                    G(i,j+1,:) = flux_y(w(i,j+1,i_cons)) + S_r(i,j)*(w_star_k - w(i,j+1,i_cons))  ! F_star_L
                ELSE
                    WRITE(*,*) 'No suitable condition found for HLLC y at ', i,j
                    STOP
                END IF
            END DO
        END DO

    END SUBROUTINE HLLC_flux_y

END MODULE mod_numerical_fluxes