C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.01.02/01                           *
C  *    TEST TITLE : Setting and inquiring local           *
C  *                 transformations                       *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

C  Declare program-specific variables

C Composition type
      INTEGER     PCPRE,     PCPOST,     PCREPL
      PARAMETER  (PCPRE = 0, PCPOST = 1, PCREPL = 2)

C Element type
      INTEGER     PELMT3, PELMT
      PARAMETER  (PELMT3 = 57, PELMT = 58)

C array sizes
      INTEGER    INLEN, RELEN, STLEN
      PARAMETER (INLEN = 20, RELEN = 20, STLEN = 20)

      INTEGER    CELTYP, STRID, INTLEN, RLLEN, STRLEN, ROW, COL, IX

      INTEGER    INTG, INTAR(INLEN), RL, STR, STRARL(STLEN)

      REAL       M3(3,3), M4(4,4), RLAR(RELEN)

      CHARACTER  STRAR(STLEN)

C              | 2.2 -33.33e33 9.9e-11 |
C  matrix m3 = | 4.4   5.5     6.6     |
C              | 0.0  -5.2     9.9     |

      DATA M3 /2.2, 4.4, 0.0, -33.33E33, 5.5, -5.2, 9.9E-11, 6.6, 9.9/

C              | 2.2 -33.33e33 9.9e-11   1.34 |
C  matrix m4 = | 4.4   5.5     6.6      12.4  |
C              | 0.0  -5.2     9.9     123.0  |
C              | 3.1   4.1     5.9265   66.66 |

      DATA M4 /2.2, 4.4, 0.0, 3.1, -33.33E33, 5.5, -5.2, 4.1,
     1         9.9E-11, 6.6, 9.9, 5.9265, 1.34, 12.4, 123.0, 66.66/

      CALL INITGL ('06.01.02/01')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)

      STRID = 101
      CALL POPST (STRID)

C  Use <inquire current element type and size> thoughout to determine
C    current element type and size
C
C  Use <inquire current element content> throughout to determine
C    current element content

C  <Set local transformation 3> with m4, PRECONCATENATE
      CALL PSLMT3 (M4, PCPRE)

      CALL SETMSG ('1 2', '<Inquire current element type and size> '  //
     1             'should return set local transformation 3 as the ' //
     2             'type of the created element and the appropriate ' //
     3             'element size, when PRECONCATENATE is specified.')

C  <inquire current element type and size>
      CALL PQCETS (ERRIND, CELTYP, INTLEN, RLLEN, STRLEN)

      CALL IFPF ( ERRIND   .EQ.   0      .AND.
     1            CELTYP   .EQ.   PELMT3 .AND.
     2            INTLEN   .EQ.   1      .AND.
     3            RLLEN    .EQ.  16      .AND.
     4            STRLEN   .EQ.   0)

      CALL SETMSG ('1 3 7', '<Inquire current element content> '      //
     1             'should return the standard representation for '   //
     2             'set local transformation 3, when PRECONCATENATE ' //
     3             'is specified.')

C  garbage up output parameters where expected value is zero
      INTAR(1) = 666
      ERRIND = 666
      STR = 666
C  <inquire current element content>
      CALL PQCECO (INLEN, RELEN, STLEN, ERRIND, INTG, INTAR,
     1             RL, RLAR, STR, STRARL, STRAR)

      IF (ERRIND   .EQ.  0      .AND.
     1    INTG     .EQ.  1      .AND.
     2    INTAR(1) .EQ.  PCPRE  .AND.
     3    RL       .EQ. 16      .AND.
     4    STR      .EQ.  0)  THEN
C OK so far
      ELSE
         CALL FAIL
         CALL INMSG ('Array sizes or composition type are incorrect.')
         GOTO 190
      ENDIF

      IX = 0
      DO 100 COL = 1,4
      DO 110 ROW = 1,4
         IX = IX+1
         IF (M4(ROW, COL) .NE. RLAR(IX)) THEN
            CALL FAIL
            CALL INMSG ('Matrix values are incorrect.')
            GOTO 190
         ENDIF
110   CONTINUE
100   CONTINUE

      CALL PASS

190   CONTINUE

C  <Set local transformation 3> with m4, REPLACE
      CALL PSLMT3 (M4, PCREPL)

      CALL SETMSG ('1 2', '<Inquire current element type and size> '  //
     1             'should return set local transformation 3 as the ' //
     2             'type of the created element and the appropriate ' //
     3             'element size, when REPLACE is specified.')

C  <inquire current element type and size>
      CALL PQCETS (ERRIND, CELTYP, INTLEN, RLLEN, STRLEN)

      CALL IFPF ( ERRIND   .EQ.   0      .AND.
     1            CELTYP   .EQ.   PELMT3 .AND.
     2            INTLEN   .EQ.   1      .AND.
     3            RLLEN    .EQ.  16      .AND.
     4            STRLEN   .EQ.   0)

      CALL SETMSG ('1 3 7', '<Inquire current element content> '    //
     1             'should return the standard representation for ' //
     2             'set local transformation 3, when REPLACE is '   //
     3             'specified.')

C  garbage up output parameters where expected value is zero
      INTAR(1) = 666
      ERRIND = 666
      STR = 666
C  <inquire current element content>
      CALL PQCECO (INLEN, RELEN, STLEN, ERRIND, INTG, INTAR,
     1             RL, RLAR, STR, STRARL, STRAR)

      IF (ERRIND   .EQ.  0      .AND.
     1    INTG     .EQ.  1      .AND.
     2    INTAR(1) .EQ.  PCREPL .AND.
     3    RL       .EQ. 16      .AND.
     4    STR      .EQ.  0)  THEN
C OK so far
      ELSE
         CALL FAIL
         CALL INMSG ('Array sizes or composition type are incorrect.')
         GOTO 290
      ENDIF

      IX = 0
      DO 200 COL = 1,4
      DO 210 ROW = 1,4
         IX = IX+1
         IF (M4(ROW, COL) .NE. RLAR(IX)) THEN
            CALL FAIL
            CALL INMSG ('Matrix values are incorrect.')
            GOTO 290
         ENDIF
210   CONTINUE
200   CONTINUE

      CALL PASS

290   CONTINUE

C  <Set local transformation> with m3, POSTCONCATENATE
      CALL PSLMT (M3, PCPOST)

      CALL SETMSG ('4 5', '<Inquire current element type and size> '  //
     1             'should return set local transformation as the '   //
     2             'type of the created element and the appropriate ' //
     3             'element size, when POSTCONCATENATE is '           //
     4             'specified.')

C  <inquire current element type and size>
      CALL PQCETS (ERRIND, CELTYP, INTLEN, RLLEN, STRLEN)

      CALL IFPF ( ERRIND   .EQ.   0      .AND.
     1            CELTYP   .EQ.   PELMT  .AND.
     2            INTLEN   .EQ.   1      .AND.
     3            RLLEN    .EQ.   9      .AND.
     4            STRLEN   .EQ.   0)

      CALL SETMSG ('4 6 7', '<Inquire current element content> '     //
     1             'should return the standard representation for '  //
     2             'set local transformation, when POSTCONCATENATE ' //
     3             'is specified.')

C  garbage up output parameters where expected value is zero
      INTAR(1) = 666
      ERRIND = 666
      STR = 666
C  <inquire current element content>
      CALL PQCECO (INLEN, RELEN, STLEN, ERRIND, INTG, INTAR,
     1             RL, RLAR, STR, STRARL, STRAR)

      IF (ERRIND   .EQ.  0      .AND.
     1    INTG     .EQ.  1      .AND.
     2    INTAR(1) .EQ.  PCPOST .AND.
     3    RL       .EQ.  9      .AND.
     4    STR      .EQ.  0)  THEN
C OK so far
      ELSE
         CALL FAIL
         CALL INMSG ('Array sizes or composition type are incorrect.')
         GOTO 390
      ENDIF

      IX = 0
      DO 300 COL = 1,3
      DO 310 ROW = 1,3
         IX = IX+1
         IF (M3(ROW, COL) .NE. RLAR(IX)) THEN
            CALL FAIL
            CALL INMSG ('Matrix values are incorrect.')
            GOTO 390
         ENDIF
310   CONTINUE
300   CONTINUE

      CALL PASS

390   CONTINUE

666   CONTINUE
      CALL ENDIT
      END


!----------------------------------------------------------------

      subroutine fnProposeParamUpdates(nparam,curval,
     $     valmin,valmax,step,logflag,
     $     parupdt,iseed,nopt,iopt)

      implicit none
      integer nparam, nopt, iopt(nopt)
      real*8 curval(nparam),valmin(nparam),valmax(nparam)
      real*8 parupdt(nparam),step(nparam)
      real*8 x, rv, rtn
      real*8 ran1
      real*8 SR_to_unit, SR_from_unit
      integer iseed
      integer i,j

      logical logflag(nparam)
      external SR_to_unit, SR_from_unit, ran1

       do j = 1, nopt
          i = iopt(j)
          parupdt(i)=curval(i)

          rv = ran1(iseed)

          rv = (rv - 0.50d0)*step(i)

! convert to a zero - one scale

          x = SR_to_unit(curval(i),valmin(i),valmax(i),
     $         logflag(i))

          x = x + rv

      if (x .lt. 0.0d0) x = 1.0d0 + x
      if (x .gt. 1.0d0) x = x - 1.0d0

! Do not use period boundary conditions here but rather re-smaple
c$$$      if (x .le. 0.0d0 .or. x .ge. 1.0d0) go to 101

! bring value back to original scale

         rtn = SR_from_unit(x,valmin(i),valmax(i),
     $        logflag(i))

         parupdt(i) = rtn

      enddo

      return
      end subroutine fnProposeParamUpdates

c----------------------------------------------------------------

      function SR_to_unit(y,ymin,ymax,logflag)

      implicit none
      real*8 y, ymin,ymax,rtn,SR_to_Unit
      logical logflag

      if (logflag) Then
         rtn = (log10(y) - log10(ymin)) /
     $        (log10(ymax)-log10(ymin))
      else
         rtn = (y - ymin)/(ymax - ymin)
      endif

      SR_to_unit = rtn

      return
      end function SR_to_unit

c----------------------------------------------------------------

      function SR_from_unit(x,ymin,ymax,logflag)

      implicit none

      real*8 x,ymin,ymax,rtn,SR_from_unit
      logical logflag

      if (logflag) Then
         rtn = ymin *
     $        10.0**(x*(log10(ymax)-log10(ymin)))

      else
         rtn = ymin + (ymax-ymin)*x
      endif

      SR_from_unit = rtn

      return
      end function SR_from_unit

c----------------------------------------------------------------

      subroutine BuildIMIDforCDC(ndata,nstep,tps,imid)

      implicit none

      integer ndata,nstep
      integer imid((ndata+1))
      real*8 tps(ndata)
      real*8 t0
      integer i

! Build the vector needed for calculating the incidence
! days is needed only to calculate imid
! tps is the 'cumulative' day number
! This works correctly provided tps holds cumulative days numbers
! that start with the first month or week and not some arbitrary start

! this is for the CDC where we begin with EW27 - days start ~182
! If we move to start with first value being 7 days we can move
! to using the cleaner dengue version..

      t0 =  (tps(2) - tps(1) )
      imid(1) = int(t0) * int(nstep * 0.5)

      do i = 1, ndata
         imid((i+1)) = imid(1) + int(tps(i) - tps(1) + t0)* nstep
        ! imid((i+1)) = imid(1) + int(tps(i) * nstep)
      enddo

      return
      end subroutine BuildIMIDforCDC

C----------------------------------------------------------------------

!--------------------------------------------------------------------------------

        subroutine weekly1D(ndata,ndays,nstep,imid,dsdt,pC,e_nonflu,x)

        implicit none
        integer ndata,nstep, ndays
        real*8 dsdt((ndays)*nstep)
        real*8 x(ndata), pC, e_nonflu
        integer i
        integer istart, iend
        integer imid((ndata+1))

        do i=1,ndata
c$$$           x(i) = dsdt(i*nstep*iday_per_week) -
c$$$     $     dsdt(1+(i-1)*nstep*iday_per_week)

           iend   = imid(i+1)
           istart = imid(i)
           x(i) = dsdt(iend) - dsdt(istart)

        enddo

        x= x* pC +e_nonflu

        return
        end subroutine weekly1D

C--------------------------------------------------------------------------------
        function calcFit1D(y,gamay,x,wght,ndata)

        implicit none

        integer ndata, i
        real*8 y(ndata),x(ndata), gamay(ndata)
        real*8 wght(ndata)
        real*8 xi, yi,sum,val,CalcFit1D

c x is the simulated data
c y is the base profile

C calculate the P(yi,xi)

        sum = 0.0
        do i=1,ndata

           yi = y(i)
           xi = x(i)

           val = yi * log(xi) - xi - gamay(i)
           sum = sum + val  * wght(i)

        enddo
        sum = -sum

        CalcFit1D = sum

        return
        end function CalcFit1D

C--------------------------------------------------------------------------------
        function Ratios(nparam,iopt,parnew,parold,ymu,sigma,Temp,
     $     shaveg,imodel)

        implicit none

        integer nparam,iopt(nparam), imodel
        real*8 parnew(nparam),parold(nparam)
        real*8 ymu(nparam),sigma(nparam), Temp, shaveg
        real*8 Ratios
        real*8 dx2New, dx2Old, del
        real*8 tmpOLD, tmpNEW
        integer i, j, i1, i2
        real*8 denom

        Ratios = 1.0d0
        del = 0.0d0

! The first two spots are pC and R0 which are true for all models

! c("NH", "Tg", "R0", "sigma",  "pC", "t0", "seed", "e_bckgrnd", "deltaR", "aparam", "alpha", "delta", "ts", "dur")

        do j = 1, 2
           i = iopt(j)
           dx2New = (parnew(i) - ymu(j))*(parnew(i) - ymu(j))
           dx2Old = (parold(i) - ymu(j))*(parold(i) - ymu(j))
           denom = (sigma(j) * sigma(j) * 2.0d0 * Temp)
           del = del  -(dx2New - dx2Old )/ denom

        enddo

! now we have to become model specific

        if (imodel .eq. 1 ) Then
           i1 = iopt(3)
           i2 = iopt(4)
           j = 3
           tmpNEW = parnew(i1) * exp(-parnew(i2) * shaveg)
           tmpOLD = parold(i1) * exp(-parold(i2) * shaveg)
           dx2New = (tmpNEW - ymu(j))*(tmpNEW - ymu(j))
           dx2Old = (tmpOLD - ymu(j))*(tmpOLD - ymu(j))
           denom = (sigma(j) * sigma(j) * 2.0d0 * Temp)
           del = del -(dx2New - dx2Old )/ denom

        end if

! Simple SV term only

        if (imodel .eq. 2) Then
           i = iopt(3)
           j = 3
           dx2New = (parnew(i) - ymu(j))*(parnew(i) - ymu(j))
           dx2Old = (parold(i) - ymu(j))*(parold(i) - ymu(j))
           denom = (sigma(j) * sigma(j) * 2.0d0 * Temp)
           del = del -(dx2New - dx2Old )/ denom

        endif

! First handle the SH term and then the SV term
        if (imodel .eq. 3) Then

           i1 = iopt(3)
           i2 = iopt(4)
           j = 3
           tmpNEW = parnew(i1) * exp(-parnew(i2) * shaveg)
           tmpOLD = parold(i1) * exp(-parold(i2) * shaveg)
           dx2New = (tmpNEW - ymu(j))*(tmpNEW - ymu(j))
           dx2Old = (tmpOLD - ymu(j))*(tmpOLD - ymu(j))
           denom = (sigma(j) * sigma(j) * 2.0d0 * Temp)
           del = del -(dx2New - dx2Old )/ denom
           i = iopt(5)
           j = 4
           dx2New = (parnew(i) - ymu(j))*(parnew(i) - ymu(j))
           dx2Old = (parold(i) - ymu(j))*(parold(i) - ymu(j))
           denom = (sigma(j) * sigma(j) * 2.0d0 * Temp)
           del = del -(dx2New - dx2Old )/ denom

        endif

        Ratios = exp(del)

        return
        end function Ratios

C--------------------------------------------------------------------------------


!*==zlarcm.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZLARCM copies all or part of a real two-dimensional array to a complex array.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZLARCM + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
!
!       .. Scalar Arguments ..
!       INTEGER            LDA, LDB, LDC, M, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   A( LDA, * ), RWORK( * )
!       COMPLEX*16         B( LDB, * ), C( LDC, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZLARCM performs a very simple matrix-matrix multiplication:
!>          C := A * B,
!> where A is M by M and real; B is M by N and complex;
!> C is M by N and complex.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A and of the matrix C.
!>          M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns and rows of the matrix B and
!>          the number of columns of the matrix C.
!>          N >= 0.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA, M)
!>          On entry, A contains the M by M matrix A.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >=max(1,M).
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is COMPLEX*16 array, dimension (LDB, N)
!>          On entry, B contains the M by N matrix B.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >=max(1,M).
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is COMPLEX*16 array, dimension (LDC, N)
!>          On exit, C contains the M by N matrix C.
!> \endverbatim
!>
!> \param[in] LDC
!> \verbatim
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >=max(1,M).
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is DOUBLE PRECISION array, dimension (2*M*N)
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup complex16OTHERauxiliary
!
!  =====================================================================
      SUBROUTINE ZLARCM(M,N,A,Lda,B,Ldb,C,Ldc,Rwork)
      IMPLICIT NONE
!*--ZLARCM118
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      INTEGER Lda , Ldb , Ldc , M , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION A(Lda,*) , Rwork(*)
      COMPLEX*16 B(Ldb,*) , C(Ldc,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ONE , ZERO
      PARAMETER (ONE=1.0D0,ZERO=0.0D0)
!     ..
!     .. Local Scalars ..
      INTEGER i , j , l
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC DBLE , DCMPLX , DIMAG
!     ..
!     .. External Subroutines ..
      EXTERNAL DGEMM
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible.
!
      IF ( (M==0) .OR. (N==0) ) RETURN
!
      DO j = 1 , N
         DO i = 1 , M
            Rwork((j-1)*M+i) = DBLE(B(i,j))
         ENDDO
      ENDDO
!
      l = M*N + 1
      CALL DGEMM('N','N',M,N,M,ONE,A,Lda,Rwork,M,ZERO,Rwork(l),M)
      DO j = 1 , N
         DO i = 1 , M
            C(i,j) = Rwork(l+(j-1)*M+i-1)
         ENDDO
      ENDDO
!
      DO j = 1 , N
         DO i = 1 , M
            Rwork((j-1)*M+i) = DIMAG(B(i,j))
         ENDDO
      ENDDO
      CALL DGEMM('N','N',M,N,M,ONE,A,Lda,Rwork,M,ZERO,Rwork(l),M)
      DO j = 1 , N
         DO i = 1 , M
            C(i,j) = DCMPLX(DBLE(C(i,j)),Rwork(l+(j-1)*M+i-1))
         ENDDO
      ENDDO
!
!
!     End of ZLARCM
!
      END SUBROUTINE ZLARCM


c     =====================================================
      subroutine qinit(meqn,mbc,mx,my,xlower,ylower,
     &     dx,dy,q,maux,aux)
c     =====================================================
c
c     # Set initial conditions for q.
c     # Sample scalar equation with data that is piecewise constant with
c     # q = 1.0  if  0.1 < x < 0.6   and   0.1 < y < 0.6
c     #     0.1  otherwise
c
      implicit double precision (a-h,o-z)
      dimension q(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc)
      dimension aux(maux, 1-mbc:mx+mbc, 1-mbc:my+mbc)

c     # set concentration profile
c     ---------------------------

      qin = 1.d0    ! value inside blob
      qout = 0.d0   ! value outside

       do 50 i=1,mx
          xlow = xlower + (i-1)*dx
          do 20 j=1,my
c            # set (xlow,ylow) to lower left corner of grid cell:
             ylow = ylower + (j-1)*dy
             call cellave(xlow,ylow,dx,dy,win)
c            # win is now the fraction of the cell that lies inside the circle
             do 10 m=1,meqn
                q(m,i,j) = win*qin + (1.d0-win)*qout
  10            continue
  20         continue
  50      continue

      return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine z_solve(rho_i, qs, square, u, rhs, nx, nxmax, ny, nz)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     Performs line solves in Z direction by first factoring
c     the block-tridiagonal matrix into an upper triangular matrix,
c     and then performing back substitution to solve for the unknow
c     vectors of each line.
c
c     Make sure we treat elements zero to cell_size in the direction
c     of the sweep.
c---------------------------------------------------------------------
#ifdef READEX_LEVEL_1
#include "readex.inc"
#endif
      include 'header.h'
      include 'work_lhs.h'

      integer nx, nxmax, ny, nz
      double precision rho_i(  0:nxmax-1,0:ny-1,0:nz-1),
     $                 qs    ( 0:nxmax-1,0:ny-1,0:nz-1),
     $                 square( 0:nxmax-1,0:ny-1,0:nz-1),
     $                 u    (5,0:nxmax-1,0:ny-1,0:nz-1),
     $                 rhs  (5,0:nxmax-1,0:ny-1,0:nz-1)

      integer i, j, k, m, n, ksize
#ifdef READEX_LEVEL_1

      READEX_REGION_DEFINE( z_slv )
#endif
c---------------------------------------------------------------------
c---------------------------------------------------------------------

      if (timeron) call timer_start(t_zsolve)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     This function computes the left hand side for the three z-factors
c---------------------------------------------------------------------
#ifdef READEX_LEVEL_1
      READEX_REGION_START( z_slv , "z_solve" , SCOREP_USER_REGION_TYPE_COMMON )
#endif
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(n,m,k,i,j,ksize)
!$OMP&  SHARED(dz5,dz4,dz3,dz2,dz1,tz2,tz1,dt,c1345,c4,c3,con43,c3c4,c1,
!$OMP&         c2,nx,ny,nz)
      ksize = nz-1

c---------------------------------------------------------------------
c     Compute the indices for storing the block-diagonal matrix;
c     determine c (labeled f) and s jacobians
c---------------------------------------------------------------------
!$OMP DO
      do j = 1, ny-2
         do i = 1, nx-2
            do k = 0, ksize

               tmp1 = 1.d0 / u(1,i,j,k)
               tmp2 = tmp1 * tmp1
               tmp3 = tmp1 * tmp2

               fjac(1,1,k) = 0.d0
               fjac(1,2,k) = 0.d0
               fjac(1,3,k) = 0.d0
               fjac(1,4,k) = 1.d0
               fjac(1,5,k) = 0.d0

               fjac(2,1,k) = - ( u(2,i,j,k)*u(4,i,j,k) )
     >              * tmp2
               fjac(2,2,k) = u(4,i,j,k) * tmp1
               fjac(2,3,k) = 0.d0
               fjac(2,4,k) = u(2,i,j,k) * tmp1
               fjac(2,5,k) = 0.d0

               fjac(3,1,k) = - ( u(3,i,j,k)*u(4,i,j,k) )
     >              * tmp2
               fjac(3,2,k) = 0.d0
               fjac(3,3,k) = u(4,i,j,k) * tmp1
               fjac(3,4,k) = u(3,i,j,k) * tmp1
               fjac(3,5,k) = 0.d0

               fjac(4,1,k) = - (u(4,i,j,k)*u(4,i,j,k) * tmp2 )
     >              + c2 * qs(i,j,k)
               fjac(4,2,k) = - c2 *  u(2,i,j,k) * tmp1
               fjac(4,3,k) = - c2 *  u(3,i,j,k) * tmp1
               fjac(4,4,k) = ( 2.d0 - c2 )
     >              *  u(4,i,j,k) * tmp1
               fjac(4,5,k) = c2

               fjac(5,1,k) = ( c2 * 2.0d0 * square(i,j,k)
     >              - c1 * u(5,i,j,k) )
     >              * u(4,i,j,k) * tmp2
               fjac(5,2,k) = - c2 * ( u(2,i,j,k)*u(4,i,j,k) )
     >              * tmp2
               fjac(5,3,k) = - c2 * ( u(3,i,j,k)*u(4,i,j,k) )
     >              * tmp2
               fjac(5,4,k) = c1 * ( u(5,i,j,k) * tmp1 )
     >              - c2
     >              * ( qs(i,j,k)
     >              + u(4,i,j,k)*u(4,i,j,k) * tmp2 )
               fjac(5,5,k) = c1 * u(4,i,j,k) * tmp1

               njac(1,1,k) = 0.d0
               njac(1,2,k) = 0.d0
               njac(1,3,k) = 0.d0
               njac(1,4,k) = 0.d0
               njac(1,5,k) = 0.d0

               njac(2,1,k) = - c3c4 * tmp2 * u(2,i,j,k)
               njac(2,2,k) =   c3c4 * tmp1
               njac(2,3,k) =   0.d0
               njac(2,4,k) =   0.d0
               njac(2,5,k) =   0.d0

               njac(3,1,k) = - c3c4 * tmp2 * u(3,i,j,k)
               njac(3,2,k) =   0.d0
               njac(3,3,k) =   c3c4 * tmp1
               njac(3,4,k) =   0.d0
               njac(3,5,k) =   0.d0

               njac(4,1,k) = - con43 * c3c4 * tmp2 * u(4,i,j,k)
               njac(4,2,k) =   0.d0
               njac(4,3,k) =   0.d0
               njac(4,4,k) =   con43 * c3 * c4 * tmp1
               njac(4,5,k) =   0.d0

               njac(5,1,k) = - (  c3c4
     >              - c1345 ) * tmp3 * (u(2,i,j,k)**2)
     >              - ( c3c4 - c1345 ) * tmp3 * (u(3,i,j,k)**2)
     >              - ( con43 * c3c4
     >              - c1345 ) * tmp3 * (u(4,i,j,k)**2)
     >              - c1345 * tmp2 * u(5,i,j,k)

               njac(5,2,k) = (  c3c4 - c1345 ) * tmp2 * u(2,i,j,k)
               njac(5,3,k) = (  c3c4 - c1345 ) * tmp2 * u(3,i,j,k)
               njac(5,4,k) = ( con43 * c3c4
     >              - c1345 ) * tmp2 * u(4,i,j,k)
               njac(5,5,k) = ( c1345 )* tmp1

            enddo

c---------------------------------------------------------------------
c     now jacobians set, so form left hand side in z direction
c---------------------------------------------------------------------
            call lhsinit(lhs, ksize)
            do k = 1, ksize-1

               tmp1 = dt * tz1
               tmp2 = dt * tz2

               lhs(1,1,aa,k) = - tmp2 * fjac(1,1,k-1)
     >              - tmp1 * njac(1,1,k-1)
     >              - tmp1 * dz1
               lhs(1,2,aa,k) = - tmp2 * fjac(1,2,k-1)
     >              - tmp1 * njac(1,2,k-1)
               lhs(1,3,aa,k) = - tmp2 * fjac(1,3,k-1)
     >              - tmp1 * njac(1,3,k-1)
               lhs(1,4,aa,k) = - tmp2 * fjac(1,4,k-1)
     >              - tmp1 * njac(1,4,k-1)
               lhs(1,5,aa,k) = - tmp2 * fjac(1,5,k-1)
     >              - tmp1 * njac(1,5,k-1)

               lhs(2,1,aa,k) = - tmp2 * fjac(2,1,k-1)
     >              - tmp1 * njac(2,1,k-1)
               lhs(2,2,aa,k) = - tmp2 * fjac(2,2,k-1)
     >              - tmp1 * njac(2,2,k-1)
     >              - tmp1 * dz2
               lhs(2,3,aa,k) = - tmp2 * fjac(2,3,k-1)
     >              - tmp1 * njac(2,3,k-1)
               lhs(2,4,aa,k) = - tmp2 * fjac(2,4,k-1)
     >              - tmp1 * njac(2,4,k-1)
               lhs(2,5,aa,k) = - tmp2 * fjac(2,5,k-1)
     >              - tmp1 * njac(2,5,k-1)

               lhs(3,1,aa,k) = - tmp2 * fjac(3,1,k-1)
     >              - tmp1 * njac(3,1,k-1)
               lhs(3,2,aa,k) = - tmp2 * fjac(3,2,k-1)
     >              - tmp1 * njac(3,2,k-1)
               lhs(3,3,aa,k) = - tmp2 * fjac(3,3,k-1)
     >              - tmp1 * njac(3,3,k-1)
     >              - tmp1 * dz3
               lhs(3,4,aa,k) = - tmp2 * fjac(3,4,k-1)
     >              - tmp1 * njac(3,4,k-1)
               lhs(3,5,aa,k) = - tmp2 * fjac(3,5,k-1)
     >              - tmp1 * njac(3,5,k-1)

               lhs(4,1,aa,k) = - tmp2 * fjac(4,1,k-1)
     >              - tmp1 * njac(4,1,k-1)
               lhs(4,2,aa,k) = - tmp2 * fjac(4,2,k-1)
     >              - tmp1 * njac(4,2,k-1)
               lhs(4,3,aa,k) = - tmp2 * fjac(4,3,k-1)
     >              - tmp1 * njac(4,3,k-1)
               lhs(4,4,aa,k) = - tmp2 * fjac(4,4,k-1)
     >              - tmp1 * njac(4,4,k-1)
     >              - tmp1 * dz4
               lhs(4,5,aa,k) = - tmp2 * fjac(4,5,k-1)
     >              - tmp1 * njac(4,5,k-1)

               lhs(5,1,aa,k) = - tmp2 * fjac(5,1,k-1)
     >              - tmp1 * njac(5,1,k-1)
               lhs(5,2,aa,k) = - tmp2 * fjac(5,2,k-1)
     >              - tmp1 * njac(5,2,k-1)
               lhs(5,3,aa,k) = - tmp2 * fjac(5,3,k-1)
     >              - tmp1 * njac(5,3,k-1)
               lhs(5,4,aa,k) = - tmp2 * fjac(5,4,k-1)
     >              - tmp1 * njac(5,4,k-1)
               lhs(5,5,aa,k) = - tmp2 * fjac(5,5,k-1)
     >              - tmp1 * njac(5,5,k-1)
     >              - tmp1 * dz5

               lhs(1,1,bb,k) = 1.d0
     >              + tmp1 * 2.d0 * njac(1,1,k)
     >              + tmp1 * 2.d0 * dz1
               lhs(1,2,bb,k) = tmp1 * 2.d0 * njac(1,2,k)
               lhs(1,3,bb,k) = tmp1 * 2.d0 * njac(1,3,k)
               lhs(1,4,bb,k) = tmp1 * 2.d0 * njac(1,4,k)
               lhs(1,5,bb,k) = tmp1 * 2.d0 * njac(1,5,k)

               lhs(2,1,bb,k) = tmp1 * 2.d0 * njac(2,1,k)
               lhs(2,2,bb,k) = 1.d0
     >              + tmp1 * 2.d0 * njac(2,2,k)
     >              + tmp1 * 2.d0 * dz2
               lhs(2,3,bb,k) = tmp1 * 2.d0 * njac(2,3,k)
               lhs(2,4,bb,k) = tmp1 * 2.d0 * njac(2,4,k)
               lhs(2,5,bb,k) = tmp1 * 2.d0 * njac(2,5,k)

               lhs(3,1,bb,k) = tmp1 * 2.d0 * njac(3,1,k)
               lhs(3,2,bb,k) = tmp1 * 2.d0 * njac(3,2,k)
               lhs(3,3,bb,k) = 1.d0
     >              + tmp1 * 2.d0 * njac(3,3,k)
     >              + tmp1 * 2.d0 * dz3
               lhs(3,4,bb,k) = tmp1 * 2.d0 * njac(3,4,k)
               lhs(3,5,bb,k) = tmp1 * 2.d0 * njac(3,5,k)

               lhs(4,1,bb,k) = tmp1 * 2.d0 * njac(4,1,k)
               lhs(4,2,bb,k) = tmp1 * 2.d0 * njac(4,2,k)
               lhs(4,3,bb,k) = tmp1 * 2.d0 * njac(4,3,k)
               lhs(4,4,bb,k) = 1.d0
     >              + tmp1 * 2.d0 * njac(4,4,k)
     >              + tmp1 * 2.d0 * dz4
               lhs(4,5,bb,k) = tmp1 * 2.d0 * njac(4,5,k)

               lhs(5,1,bb,k) = tmp1 * 2.d0 * njac(5,1,k)
               lhs(5,2,bb,k) = tmp1 * 2.d0 * njac(5,2,k)
               lhs(5,3,bb,k) = tmp1 * 2.d0 * njac(5,3,k)
               lhs(5,4,bb,k) = tmp1 * 2.d0 * njac(5,4,k)
               lhs(5,5,bb,k) = 1.d0
     >              + tmp1 * 2.d0 * njac(5,5,k)
     >              + tmp1 * 2.d0 * dz5

               lhs(1,1,cc,k) =  tmp2 * fjac(1,1,k+1)
     >              - tmp1 * njac(1,1,k+1)
     >              - tmp1 * dz1
               lhs(1,2,cc,k) =  tmp2 * fjac(1,2,k+1)
     >              - tmp1 * njac(1,2,k+1)
               lhs(1,3,cc,k) =  tmp2 * fjac(1,3,k+1)
     >              - tmp1 * njac(1,3,k+1)
               lhs(1,4,cc,k) =  tmp2 * fjac(1,4,k+1)
     >              - tmp1 * njac(1,4,k+1)
               lhs(1,5,cc,k) =  tmp2 * fjac(1,5,k+1)
     >              - tmp1 * njac(1,5,k+1)

               lhs(2,1,cc,k) =  tmp2 * fjac(2,1,k+1)
     >              - tmp1 * njac(2,1,k+1)
               lhs(2,2,cc,k) =  tmp2 * fjac(2,2,k+1)
     >              - tmp1 * njac(2,2,k+1)
     >              - tmp1 * dz2
               lhs(2,3,cc,k) =  tmp2 * fjac(2,3,k+1)
     >              - tmp1 * njac(2,3,k+1)
               lhs(2,4,cc,k) =  tmp2 * fjac(2,4,k+1)
     >              - tmp1 * njac(2,4,k+1)
               lhs(2,5,cc,k) =  tmp2 * fjac(2,5,k+1)
     >              - tmp1 * njac(2,5,k+1)

               lhs(3,1,cc,k) =  tmp2 * fjac(3,1,k+1)
     >              - tmp1 * njac(3,1,k+1)
               lhs(3,2,cc,k) =  tmp2 * fjac(3,2,k+1)
     >              - tmp1 * njac(3,2,k+1)
               lhs(3,3,cc,k) =  tmp2 * fjac(3,3,k+1)
     >              - tmp1 * njac(3,3,k+1)
     >              - tmp1 * dz3
               lhs(3,4,cc,k) =  tmp2 * fjac(3,4,k+1)
     >              - tmp1 * njac(3,4,k+1)
               lhs(3,5,cc,k) =  tmp2 * fjac(3,5,k+1)
     >              - tmp1 * njac(3,5,k+1)

               lhs(4,1,cc,k) =  tmp2 * fjac(4,1,k+1)
     >              - tmp1 * njac(4,1,k+1)
               lhs(4,2,cc,k) =  tmp2 * fjac(4,2,k+1)
     >              - tmp1 * njac(4,2,k+1)
               lhs(4,3,cc,k) =  tmp2 * fjac(4,3,k+1)
     >              - tmp1 * njac(4,3,k+1)
               lhs(4,4,cc,k) =  tmp2 * fjac(4,4,k+1)
     >              - tmp1 * njac(4,4,k+1)
     >              - tmp1 * dz4
               lhs(4,5,cc,k) =  tmp2 * fjac(4,5,k+1)
     >              - tmp1 * njac(4,5,k+1)

               lhs(5,1,cc,k) =  tmp2 * fjac(5,1,k+1)
     >              - tmp1 * njac(5,1,k+1)
               lhs(5,2,cc,k) =  tmp2 * fjac(5,2,k+1)
     >              - tmp1 * njac(5,2,k+1)
               lhs(5,3,cc,k) =  tmp2 * fjac(5,3,k+1)
     >              - tmp1 * njac(5,3,k+1)
               lhs(5,4,cc,k) =  tmp2 * fjac(5,4,k+1)
     >              - tmp1 * njac(5,4,k+1)
               lhs(5,5,cc,k) =  tmp2 * fjac(5,5,k+1)
     >              - tmp1 * njac(5,5,k+1)
     >              - tmp1 * dz5

            enddo

            do k = 0, ksize
               rtmp(1,k) = rhs(1,i,j,k)
               rtmp(2,k) = rhs(2,i,j,k)
               rtmp(3,k) = rhs(3,i,j,k)
               rtmp(4,k) = rhs(4,i,j,k)
               rtmp(5,k) = rhs(5,i,j,k)
            enddo

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     performs gaussian elimination on this cell.
c
c     assumes that unpacking routines for non-first cells
c     preload C' and rhs' from previous cell.
c
c     assumed send happens outside this routine, but that
c     c'(KMAX) and rhs'(KMAX) will be sent to next cell.
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     outer most do loops - sweeping in i direction
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     multiply c(i,j,0) by b_inverse and copy back to c
c     multiply rhs(0) by b_inverse(0) and copy to rhs
c---------------------------------------------------------------------
            call binvcrhs( lhs(1,1,bb,0),
     >                        lhs(1,1,cc,0),
     >                        rtmp(1,0) )

c---------------------------------------------------------------------
c     begin inner most do loop
c     do all the elements of the cell unless last
c---------------------------------------------------------------------
            do k=1,ksize-1

c---------------------------------------------------------------------
c     subtract A*lhs_vector(k-1) from lhs_vector(k)
c
c     rhs(k) = rhs(k) - A*rhs(k-1)
c---------------------------------------------------------------------
               call matvec_sub(lhs(1,1,aa,k),
     >                         rtmp(1,k-1),rtmp(1,k))

c---------------------------------------------------------------------
c     B(k) = B(k) - C(k-1)*A(k)
c     call matmul_sub(aa,i,j,k,c,cc,i,j,k-1,c,bb,i,j,k)
c---------------------------------------------------------------------
               call matmul_sub(lhs(1,1,aa,k),
     >                         lhs(1,1,cc,k-1),
     >                         lhs(1,1,bb,k))

c---------------------------------------------------------------------
c     multiply c(i,j,k) by b_inverse and copy back to c
c     multiply rhs(i,j,1) by b_inverse(i,j,1) and copy to rhs
c---------------------------------------------------------------------
               call binvcrhs( lhs(1,1,bb,k),
     >                        lhs(1,1,cc,k),
     >                        rtmp(1,k) )

            enddo

c---------------------------------------------------------------------
c     Now finish up special cases for last cell
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     rhs(ksize) = rhs(ksize) - A*rhs(ksize-1)
c---------------------------------------------------------------------
            call matvec_sub(lhs(1,1,aa,ksize),
     >                         rtmp(1,ksize-1),rtmp(1,ksize))

c---------------------------------------------------------------------
c     B(ksize) = B(ksize) - C(ksize-1)*A(ksize)
c     call matmul_sub(aa,i,j,ksize,c,
c     $              cc,i,j,ksize-1,c,bb,i,j,ksize)
c---------------------------------------------------------------------
            call matmul_sub(lhs(1,1,aa,ksize),
     >                         lhs(1,1,cc,ksize-1),
     >                         lhs(1,1,bb,ksize))

c---------------------------------------------------------------------
c     multiply rhs(ksize) by b_inverse(ksize) and copy to rhs
c---------------------------------------------------------------------
            call binvrhs( lhs(1,1,bb,ksize),
     >                       rtmp(1,ksize) )

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     back solve: if last cell, then generate U(ksize)=rhs(ksize)
c     else assume U(ksize) is loaded in un pack backsub_info
c     so just use it
c     after call u(kstart) will be sent to next cell
c---------------------------------------------------------------------

            do k=ksize-1,0,-1
               do m=1,BLOCK_SIZE
                  do n=1,BLOCK_SIZE
                     rtmp(m,k) = rtmp(m,k)
     >                    - lhs(m,n,cc,k)*rtmp(n,k+1)
                  enddo
                  rhs(m,i,j,k) = rtmp(m,k)
               enddo
            enddo

         enddo
      enddo
!$OMP END DO nowait
!$OMP END PARALLEL
#ifdef READEX_LEVEL_1
      READEX_REGION_STOP( z_slv )

#endif
      if (timeron) call timer_stop(t_zsolve)

      return
      end


module initdata_module

  use amrex_mempool_module, only : bl_allocate, bl_deallocate
  use amrex_paralleldescriptor_module, only: parallel_IOProcessor => amrex_pd_ioprocessor
  use amrex_constants_module
  use network, only: nspec
  use amrex_fort_module, only : amrex_spacedim, amrex_random
  use base_state_geometry_module, only: nr_fine, max_radial_level, center
  use meth_params_module, only: nscal, rho_comp, rhoh_comp, temp_comp, spec_comp, pi_comp, &
       prob_lo, prob_hi
  use eos_module
  use eos_type_module
  use fill_3d_data_module, only: put_1d_array_on_cart_sphr
  use probin_module, only: rho_0

  implicit none

  private

contains

  subroutine initdata(lev, time, lo, hi, &
       scal, scal_lo, scal_hi, nc_s, &
       vel, vel_lo, vel_hi, nc_v, &
       s0_init, p0_init, dx) bind(C, name="initdata")

    integer         , intent(in   ) :: lev, lo(3), hi(3)
    integer         , intent(in   ) :: scal_lo(3), scal_hi(3), nc_s
    integer         , intent(in   ) :: vel_lo(3), vel_hi(3), nc_v
    double precision, intent(in   ) :: time
    double precision, intent(inout) :: scal(scal_lo(1):scal_hi(1), &
         scal_lo(2):scal_hi(2), &
         scal_lo(3):scal_hi(3), 1:nc_s)
    double precision, intent(inout) :: vel(vel_lo(1):vel_hi(1), &
         vel_lo(2):vel_hi(2), &
         vel_lo(3):vel_hi(3), 1:nc_v)
    double precision, intent(in   ) :: s0_init(0:max_radial_level,0:nr_fine-1,1:nscal)
    double precision, intent(in   ) :: p0_init(0:max_radial_level,0:nr_fine-1)
    double precision, intent(in   ) :: dx(3)

    integer :: i, j, k, r
    double precision :: x, y, z, fheat, rhopert

    type(eos_t) :: eos_state

    ! set velocity to zero
    vel(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),1:nc_v) = 0.d0

    do k=lo(3),hi(3)
       z = prob_lo(3) + dx(3)*(dble(k) + HALF)
       do j=lo(2),hi(2)
          y = prob_lo(2) + dx(2)*(dble(j) + HALF)

          if (amrex_spacedim .eq. 2) then
            if (y < 1.125d0 * 4.d8) then
                fheat = sin(8.d0 * M_PI * (y/ 4.d8 - ONE))
            else
                fheat = ZERO
            endif
          else
            if (z < 1.125d0 * 4.d8) then
                fheat = sin(8.d0 * M_PI * (z/ 4.d8 - ONE))
            else
                fheat = ZERO
            endif
          endif

          do i=lo(1),hi(1)
             x = prob_lo(1) + dx(1)*(dble(i) + HALF)

             rhopert = 5.d-5 * rho_0 * fheat * (sin(3.d0 * M_PI * x / 4.d8) + &
                                                cos(M_PI * x / 4.d8)) * &
                     (sin(3 * M_PI * y/4.d8) - cos(M_PI * y/4.d8))

             if (amrex_spacedim .eq. 2) then
                r = j
             else if (amrex_spacedim .eq. 3) then
                r = k
             end if

             eos_state % rho = s0_init(lev,r,rho_comp) + rhopert
             eos_state % p = p0_init(lev, r)
             eos_state % xn(:) = s0_init(lev,r,spec_comp:spec_comp+nspec-1)

             call eos(eos_input_rp, eos_state)

             ! set scalars using s0
             scal(i,j,k,rho_comp)  = eos_state % rho
             scal(i,j,k,rhoh_comp) = eos_state % rho * eos_state % h
             scal(i,j,k,temp_comp) = eos_state % t
             scal(i,j,k,spec_comp:spec_comp+nspec-1) = eos_state % xn(:)

             ! initialize pi to zero for now
             scal(i,j,k,pi_comp) = 0.d0

          end do
       end do
    end do

  end subroutine initdata

  subroutine initdata_sphr(time, lo, hi, &
       scal, scal_lo, scal_hi, nc_s, &
       vel, vel_lo, vel_hi, nc_v, &
       s0_init, p0_init, &
       dx, r_cc_loc, r_edge_loc, &
       cc_to_r, ccr_lo, ccr_hi) bind(C, name="initdata_sphr")

    integer         , intent(in   ) :: lo(3), hi(3)
    integer         , intent(in   ) :: scal_lo(3), scal_hi(3), nc_s
    integer         , intent(in   ) :: vel_lo(3), vel_hi(3), nc_v
    integer         , intent(in   ) :: ccr_lo(3), ccr_hi(3)
    double precision, intent(in   ) :: time
    double precision, intent(inout) :: scal(scal_lo(1):scal_hi(1), &
         scal_lo(2):scal_hi(2), &
         scal_lo(3):scal_hi(3), nc_s)
    double precision, intent(inout) :: vel(vel_lo(1):vel_hi(1), &
         vel_lo(2):vel_hi(2), &
         vel_lo(3):vel_hi(3), nc_v)
    double precision, intent(in   ) :: s0_init(0:max_radial_level,0:nr_fine-1,1:nscal)
    double precision, intent(in   ) :: p0_init(0:max_radial_level,0:nr_fine-1)
    double precision, intent(in   ) :: dx(3)
    double precision, intent(in   ) :: r_cc_loc  (0:max_radial_level,0:nr_fine-1)
    double precision, intent(in   ) :: r_edge_loc(0:max_radial_level,0:nr_fine)
    double precision, intent(in   ) :: cc_to_r   (ccr_lo(1):ccr_hi(1), &
         ccr_lo(2):ccr_hi(2),ccr_lo(3):ccr_hi(3))

  end subroutine initdata_sphr

end module initdata_module


!###############################################################
!     PURPOSE  : Contains all the modules used to solve DMFT with IPT
!     AUTHORS  : Adriano Amaricci
!###############################################################
module DMFT_IPT
  USE IPT_GF
  USE IPT_VARS_GLOBAL
  USE IPT_MATSUBARA
  USE IPT_REAL
  USE IPT_KELDYSH
  ! !IPT+AF:
  ! USE IPT_AF_MATS
  implicit none
end module DMFT_IPT


      SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z)
      INTEGER LDA,N,IPVT(1)
      DOUBLE PRECISION A(LDA,1),Z(1)
      DOUBLE PRECISION RCOND
C
C     DGECO FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION
C     AND ESTIMATES THE CONDITION OF THE MATRIX.
C
C     IF  RCOND  IS NOT NEEDED, DGEFA IS SLIGHTLY FASTER.
C     TO SOLVE  A*X = B , FOLLOW DGECO BY DGESL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW DGECO BY DGESL.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW DGECO BY DGEDI.
C     TO COMPUTE  INVERSE(A) , FOLLOW DGECO BY DGEDI.
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        RCOND   DOUBLE PRECISION
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C
C        Z       DOUBLE PRECISION(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     LINPACK DGEFA
C     BLAS DAXPY,DDOT,DSCAL,DASUM
C     FORTRAN DABS,DMAX1,DSIGN
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION DDOT,EK,T,WK,WKM
      DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM
      INTEGER INFO,J,K,KB,KP1,L
C
C
C     COMPUTE 1-NORM OF A
C
      ANORM = 0.0D0
      DO 10 J = 1, N
         ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1))
   10 CONTINUE
C
C     FACTOR
C
      CALL DGEFA(A,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C     OVERFLOW.
C
C     SOLVE TRANS(U)*W = E
C
      EK = 1.0D0
      DO 20 J = 1, N
         Z(J) = 0.0D0
   20 CONTINUE
      DO 100 K = 1, N
         IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K))
         IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30
            S = DABS(A(K,K))/DABS(EK-Z(K))
            CALL DSCAL(N,S,Z,1)
            EK = S*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = DABS(WK)
         SM = DABS(WKM)
         IF (A(K,K) .EQ. 0.0D0) GO TO 40
            WK = WK/A(K,K)
            WKM = WKM/A(K,K)
         GO TO 50
   40    CONTINUE
            WK = 1.0D0
            WKM = 1.0D0
   50    CONTINUE
         KP1 = K + 1
         IF (KP1 .GT. N) GO TO 90
            DO 60 J = KP1, N
               SM = SM + DABS(Z(J)+WKM*A(K,J))
               Z(J) = Z(J) + WK*A(K,J)
               S = S + DABS(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               T = WKM - WK
               WK = WKM
               DO 70 J = KP1, N
                  Z(J) = Z(J) + T*A(K,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
C     SOLVE TRANS(L)*Y = W
C
      DO 120 KB = 1, N
         K = N + 1 - KB
         IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1)
         IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110
            S = 1.0D0/DABS(Z(K))
            CALL DSCAL(N,S,Z,1)
  110    CONTINUE
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
      YNORM = 1.0D0
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
         IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130
            S = 1.0D0/DABS(Z(K))
            CALL DSCAL(N,S,Z,1)
            YNORM = S*YNORM
  130    CONTINUE
  140 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150
            S = DABS(A(K,K))/DABS(Z(K))
            CALL DSCAL(N,S,Z,1)
            YNORM = S*YNORM
  150    CONTINUE
         IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K)
         IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0
         T = -Z(K)
         CALL DAXPY(K-1,T,A(1,K),1,Z(1),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END


( --== Tilemap collisions ==-- )

( what sides the object collided )
0 value lwall?
0 value rwall?
0 value floor?
0 value ceiling?

#1
    bit BIT_CEL
    bit BIT_FLR
    bit BIT_WLT
    bit BIT_WRT
drop

define collisioning
    0 value map
    0 value tileprops

    defer on-collide-tilemap  ( -- )
        ' noop is on-collide-tilemap

    : tileprops@   ( tilespec -- flags )
        1i $ffff and tileprops + c@ ;

    : map@  ( col row - tile )  map tile @ ;

    : cel? BIT_CEL and ; \ ' ceiling '
    : flr? BIT_FLR and ; \ ' floor '
    : wlt? BIT_WLT and ; \ ' wall left '
    : wrt? BIT_WRT and ; \ ' wall right '

    : vector   create 0 , here 0 , constant ;
    vector nx ny

    16 constant gap

    : px x @ ;
    : py y @ ;

    variable t
    : xy>cr  ( x y tilesize - ) dup  2/  2pfloor ;
    : pt  gap xy>cr  map@ dup t !  tileprops@ ;          \ point

    ( increment coordinates )
    : ve+  swap gap +  sbw @ #1 - px +  min  swap ;
    : he+  gap +  sbh @ #1 - ny @ +  min ;

    : +ny ny +! 0 vy ! ;
    : +nx nx +! 0 vx ! ;

    ( push up/down )
    : pu ( xy ) nip gap mod negate +ny  true to floor?  on-collide-tilemap  ;
    : pd ( xy ) nip gap mod negate gap + +ny  true to ceiling?  on-collide-tilemap ;

    ( check up/down )
    : cu sbw @ gap / 2 + for 2dup pt cel? if pd unloop exit then ve+ loop 2drop ;
    : cd sbw @ gap / 2 + for 2dup pt flr? if pu unloop exit then ve+ loop 2drop ;

    ( push left/right )
    : pl ( xy ) drop gap mod negate +nx  true to rwall?  on-collide-tilemap ;
    : pr ( xy ) drop gap mod negate gap + +nx  true to lwall?  on-collide-tilemap ;

    ( check left/right )
    : cl sbh @ gap /  2 + for 2dup pt wrt? if pr unloop exit then he+ loop 2drop ;
    : crt sbh @ gap / 2 + for 2dup pt wlt? if pl unloop exit then he+ loop 2drop ;

    : ud vy @ -exit vy @ 0 < if px ny @ cu exit then px ny @ sbh @ + cd ;
    : lr vx @ -exit vx @ 0 < if nx 2@ cl exit then   nx @ sbw @ + ny @ crt ;

    : init   px py  vx 2@  2+  nx 2!  0 to lwall? 0 to rwall? 0 to floor? 0 to ceiling? ;

common also collisioning

: collide-tilemap> ( tilemap tileprops -- <code> )  ( -- )
    to tileprops to map  r> code> is on-collide-tilemap  init ud lr
    nx 2@ x 2! ;

: collide-tilemap  ( tilemap tileprops -- )
    collide-tilemap> noop ;

0 value (code)
: each-tile>  ( tilemap -- <code> ) ( ... -- ... )  \ address is in A; you're in charge of incrementing
    r> (code) >r to (code)
    y @ ibh @ + 1 - gap / pfloor 1 +  y @ gap / pfloor do
        x @ gap / pfloor  i  third tile a!
        x @ ibw @ + 1 - gap / pfloor 1 +   x @ gap / pfloor do
            (code) call
        loop
    loop
    drop  r> to (code)
;

common


program noise
  use iso_fortran_env, only : real32, real64
  implicit none

  integer, parameter :: n = 100000
  real(real32), allocatable :: a(:),b(:)
  real(real32) :: redux
  integer :: i

  allocate(a(n),b(n))

  do i = 1, n
     a(i) = i + 314.1415
     b(i) = 1/(1+10000*i)
  end do

  redux = 0.0
!dir$ novector
  do i = 1, n
     redux = redux + a(i) + b(i)
  end do

  write( *, "(F24.8)") redux

end program noise


!-----------------2018-4-30-------------------------------!
! Individualized Aspiration Dynamics
! For Figure 1 & 2
!---------------------------------------------------------!
module global
    use MT_PNRG
    implicit none
    !
    integer,parameter::Ntotal = 100
    !
    integer,save::numPlayerInGame
    !!!
    !!! ---- On Ring Graphs ----
    !!! payoffCollectType: 1---Average Payoff, 0---Singel game payoff
    integer,save:: payoffCollectType = 1
    !!! ----------------------------------
    real, save:: initialFrequencyA = 0.05
    !
    real,save::selectionIntensity
    !!!
    !!!
    !!! strategyPGG: A Player -- 1; B Player -- 0
    integer,save::strategyPGG(Ntotal)
    !!!
    real,save::aspirationValueNode(Ntotal)
    !!!!
    integer,save::degreeMain = 2
    !!!
    type structuredPopulations
        integer,allocatable::neighborNode(:)
    end type
    !
end module

INCLUDE 'link_fnl_static.h'
!DEC$ OBJCOMMENT LIB:'libiomp5md.lib'
program main
    use global
    implicit none
    integer::generationNum
    integer::timesRepeated
    !Number of nodes
    character(32)::inputFileName
    !Number of nodes
    character(15)::inputFileNameValueY
    logical::alive
    !!!
    real,allocatable::APlayerPayoff(:), BPlayerPayoff(:)
    namelist /keyParameters/ payoffCollectType, timesRepeated, generationNum, initialFrequencyA

    !!! ------ One parameter File ------ !!!
    inputFileNameValueY = 'yParameters.inp'
    inquire(file = inputFileNameValueY, exist = alive)
    if(.not. alive)then
        write(*,*) "ERROR: File "//inputFileNameValueY//" is NOT found!"
        stop
    end if
    open(unit = 166, file = inputFileNameValueY,status = 'old')
    read(166, nml = keyParameters)
    close(166)

    aspirationValueNode = -1.0
    !!! ----- Main Parameter File, Read By Line ----- !!!
    inputFileName = 'AspirationDynamicsParameters.txt'
    !
    inquire(file = inputFileName, exist = alive)
    if(.not. alive)then
        write(*,*) "ERROR: File "//inputFileName//" is NOT found!"
        stop
    end if
    open(unit = 188, file = inputFileName,status = 'old')
    !!!
    read(188,*)
    read(188,*)
    read(188,*)
    read(188,*)
    !!!
    read(188,*)
    read(188,*) numPlayerInGame
    !!!
    allocate(APlayerPayoff(numPlayerInGame))
    allocate(BPlayerPayoff(numPlayerInGame))
    !!!
    read(188,*)
    read(188,*)
    read(188,*) APlayerPayoff
    read(188,*) BPlayerPayoff
    !!!
    read(188,*)
    read(188,*) aspirationValueNode
    !!!!
    read(188,*)
    read(188,*) selectionIntensity
    !!!
    write(*,*)
    write(*,"(' Population Size = ', I3)") Ntotal
    write(*,*) "----------------"
    write(*,"(' # of Player in a game = ', I3)") numPlayerInGame
    write(*,*) "----------------"
    write(*,"('  Payoff Parameters')")
    write(*,*) "A:",APlayerPayoff
    write(*,*) "B:",BPlayerPayoff
    write(*,*) "----------------"
    write(*,*) "value:"
    write(*,*) aspirationValueNode
    write(*,*) "----------------"
    write(*,"(' Selection Intensity = ', F8.5)") selectionIntensity
    write(*,*) "----------------"
    write(*,"(2X,'RepeatedTimes = ', I5)") timesRepeated
    write(*,*) "----------------"
    write(*,"(2X,'Payoff Collection = ', I1, ' (On graphs)')") payoffCollectType
    write(*,*) "----------------"
    write(*,"(2X,'GenerationNum_OneLoop = ', I8)") GenerationNum
    write(*,*) "----------------"

    if(any(aspirationValueNode == -1.0))then
        write(*,*) "The number of Aspiration Values MUST equal to the population size!"
        stop
    elseif(selectionIntensity < 0)then
        write(*,*) "The Selection Intensity MUST be Non-nagetive!"
        stop
    end if

    !!!! RNOPT(8) --- A 32-bit Mersenne Twister generator is used.
    !!! RNOPT(9) --- A 64-bit Mersenne Twister generator is used.
    call RNOPT(8)

    call frequencyCalculation2(timesRepeated, generationNum, &
    APlayerPayoff, BPlayerPayoff)
    !stop
end


program create_wisdom
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This program will demonstrate how to create an fftw file for a specific sized
!	transform using the unix command fftw-wisdom. For a given spherical harmonic
!	degree l, there will be 2l+1 data points used in the longitudinal FFTs employed
!	in the Gauss-Legendre integrations, and 2l+2 for the Driscoll and Healy intergrations.
!	When using an equally SPACED DH grid there are 4l+4 points in longitude.
!
!	In order to compute a wisdom file, use the following unix command
!
!		fftw-wisdom -v -x -o wisdom_file [SIZES]
!
!	The -x command performs an exhaustive search.
!
!	SHTOOLS will try to read the wisdom file in the default location
!		/etc/fftw/wisdom
!	Otherwise, one can specify its location using the optional argument wisdom_file
!	with the routine PreCompute_FFTW.
!
!	Notes:
!		1.	Only real data FFTs are used in SHTOOLS
!		2.	The FFTs are "out-of-place" in that the length of the
!			input and output arrays are different.
!		3.	Both forward and backward FFTs are used.
!		4.	I have found that my code runs at exactly the same speed
!			when using the above created wisdom file on a Mac G4 laptop. Results may
!			be different on differnt machine architectures.
!
!	Written by Mark Wieczorek June 2004
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer ::	lmax, n, i
	character*8 ::	str(6)

	print*, "Spherical harmonic degree to compute transforms > "
	read(*,*) lmax

	if (lmax >= 2800) then
		print*, "Warning --- SHTOOLS is not accurate beyond ~2800."
	endif

	do i=1, 3

		if (i==1) then
			n = 2*lmax +1
		elseif (i==2) then
			n = 2*(lmax+1)
		elseif (i==3) then
			n = 4*(lmax+1)
		endif

		if (n<10) then
			write(str(i) ,fmt="('rof', i1)") n
			write(str(3+i), fmt="('rob', i1)") n
		elseif (n<100) then
			write(str(i),fmt="('rof', i2)") n
			write(str(3+i),fmt="('rob', i2)") n
		elseif(n<1000 .and. n>=100) then
			write(str(i),fmt="('rof', i3)") n
			write(str(3+i),fmt="('rob', i3)") n
		elseif(n<10000 .and. n>=1000) then
			write(str(i),fmt="('rof', i4)") n
			write(str(3+i),fmt="('rob', i4)") n
		elseif(n<100000 .and. n>=10000) then
			write(str(i),fmt="('rof', i5)") n
			write(str(3+i),fmt="('rob', i5)") n
		endif

	enddo

	print*, "Create wisdom file by using the following command:"
	write(*,*)
	write(*,*) "fftw-wisdom -v -x -o wisdom ", str(1), str(2), str(3), str(4), str(5), str(6)
	write(*,*)
	print*, "If a system wisdom file does not already exist, or if you do not want "
	print*, "to read the system wisdom file, add the option -n."
	print*, "To read a specific wisdom file, add the option -w wisdom_file_name."q
	print*, "The default location for the system wisdom file is"
	print*, "/etc/fftw/wisdom (copying to this directory will require root privileges)."

end program create_wisdom


module mc_walk

implicit none
integer :: nwalks

contains

subroutine random_walk(i0, j0, max_steps, ub, iabort)

    use problem_description, only: nx,ny,ax,ay,dx,dy,uboundary

    implicit none
    integer, intent(in) :: i0,j0,max_steps
    real(kind=8), intent(out) :: ub
    integer, intent(out) :: iabort

    real(kind=4), allocatable :: r(:)
    integer i,j,istep
    real(kind=4) :: rr
    real(kind=8) :: xb,yb

    allocate(r(max_steps))

    i = i0
    j = j0
    call random_number(r)

    do istep=1,max_steps
        rr = r(istep)
        if (rr < 0.25d0) then
            i = i-1
          else if (rr < 0.5d0) then
            i = i+1
          else if (rr < 0.75d0) then
            j = j-1
          else
            j = j+1
          endif

        if (i*j*(nx+1-i)*(ny+1-j) == 0) then
            xb = ax + i*dx
            yb = ay + j*dy
            ub = uboundary(xb, yb)
            exit  ! end the walk
            endif
        enddo

    if (istep == max_steps+1) then
        iabort = 1
        ub = 0.d0  ! this value won't be used
    else
        iabort = 0
    endif

    nwalks = nwalks + 1

end subroutine random_walk

subroutine many_walks(i0, j0, max_steps, n_mc, u_mc, n_success)

    use mpi

    implicit none
    integer, intent(in) :: i0,j0,max_steps,n_mc
    integer, intent(out) :: n_success
    real(kind=8), intent(out) :: u_mc

    integer :: k, iabort, nb_sum
    real(kind=8) :: ub,ub_sum

    integer, dimension(MPI_STATUS_SIZE) :: status
    integer :: num_procs, proc_num, ierr, j, numsent, sender

    call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, proc_num, ierr)

    ! -----------------------------------------
    ! code for Master (Processor 0):
    ! -----------------------------------------

    if (proc_num == 0) then
      ub_sum = 0.d0
      nb_sum = 0

      numsent = 0
      ! send the first batch to get all workers working:
      do j=1,min(num_procs-1, n_mc)
          call MPI_SEND(MPI_BOTTOM, 0, MPI_INTEGER, j, 1, &
                      MPI_COMM_WORLD, ierr)
          numsent = numsent + 1
          enddo

      ! as results come back, send out more work...
      ! the variable sender tells who sent back a result and ready for more
      do k=1,n_mc
        call MPI_RECV(ub, 1, MPI_DOUBLE_PRECISION, &
                        MPI_ANY_SOURCE, MPI_ANY_TAG, &
                        MPI_COMM_WORLD, status, ierr)
        sender = status(MPI_SOURCE)
        iabort = status(MPI_TAG)
        if (iabort == 0) then
            ub_sum = ub_sum + ub
            nb_sum = nb_sum + 1
            endif
        if (numsent < n_mc) then
            ! still more work to do
            call MPI_SEND(MPI_BOTTOM, 0, MPI_INTEGER, sender, 1, &
                      MPI_COMM_WORLD, ierr)
            numsent = numsent + 1
          else
            ! send an empty message with tag=0 to indicate this worker
            ! is done:
            call MPI_SEND(MPI_BOTTOM, 0, MPI_INTEGER, &
                            sender, 0, MPI_COMM_WORLD, ierr)
          endif
         enddo

        u_mc = ub_sum / nb_sum
        n_success = nb_sum
        endif

    ! -----------------------------------------
    ! code for Workers (Processors 1, 2, ...):
    ! -----------------------------------------
    if (proc_num /= 0) then

        if (proc_num > n_mc) go to 99   ! no work expected

        do while (.true.)
            ! repeat until message with tag==0 received...

            call MPI_RECV(MPI_BOTTOM, 0, MPI_INTEGER, &
                          0, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)

            j = status(MPI_TAG)   ! this tells worker whether to stop

            if (j==0) go to 99    ! received "done" message

            call random_walk(i0, j0, max_steps, ub, iabort)
            call MPI_SEND(ub, 1, MPI_DOUBLE_PRECISION, &
                        0, iabort, MPI_COMM_WORLD, ierr)

            enddo
        endif

99  continue   ! jump here when done

    call MPI_BARRIER(MPI_COMM_WORLD,ierr) ! wait for all processes to finish

end subroutine many_walks

end module mc_walk


! examples/Fortran/ssmfe/hermitian.f90 - Example code for SPRAL_SSMFE package
! Hermitian operator example
program ssmfe_hermitian_example
  use spral_ssmfe
  implicit none

  integer, parameter :: wp = kind(0d0) ! working precision

  integer, parameter :: n   = 80     ! problem size
  integer, parameter :: nep = 5      ! eigenpairs wanted

  real(wp) :: lambda(nep)            ! eigenvalues
  complex(wp) :: X(n, nep)           ! eigenvectors
  type(ssmfe_rciz   ) :: rci         ! reverse communication data
  type(ssmfe_options) :: options     ! options
  type(ssmfe_keepz  ) :: keep        ! private data
  type(ssmfe_inform ) :: inform      ! information
  integer :: i                       ! loop index

  rci%job = 0
  do ! reverse communication loop
    call ssmfe_standard( rci, nep, nep, lambda, n, X, n, keep, options, inform )
    select case ( rci%job )
    case ( 1 )
      call apply_idx( n, rci%nx, rci%x, rci%y )
    case ( :-1 )
      exit
    end select
  end do
  print '(i3, 1x, a, i3, 1x, a)', inform%left, 'eigenpairs converged in', &
     inform%iteration, 'iterations'
  print '(1x, a, i2, a, es14.7)', &
    ('lambda(', i, ') = ', lambda(i), i = 1, inform%left)
  call ssmfe_free( keep, inform )

contains

  subroutine apply_idx( n, m, x, y ) ! central differences for i d/dx
    implicit none
    complex(wp), parameter :: IM_ONE = (0.0D0, 1.0D0)
    integer, intent(in) :: n, m
    complex(wp), intent(in) :: x(n, m)
    complex(wp), intent(out) :: y(n, m)
    integer :: i, j, il, ir
    do j = 1, m
      do i = 1, n
        if ( i == 1 ) then
          il = n
        else
          il = i - 1
        end if
        if ( i == n ) then
          ir = 1
        else
          ir = i + 1
        end if
        y(i, j) = IM_ONE*(x(ir, j) - x(il, j))
      end do
    end do
  end subroutine apply_idx

end program ssmfe_hermitian_example


subroutine fclaw3dx_clawpatch46_fort_timeinterp(mx,my,mz, mbc,meqn, &
        psize, qcurr,qlast,qinterp,alpha,ierror)
    implicit none

    integer :: mx,my,mz,mbc,meqn,psize, ierror
    double precision :: alpha
    double precision ::   qcurr(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,meqn)
    double precision ::   qlast(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,meqn)
    double precision :: qinterp(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,meqn)

    integer :: i,j,k,m,mint,count,count_final

    !! # Number of interior layers to compute.  Since we only
    !! # interpolate from time-interpolated levels, we only
    !! # need two layers.  If we were averaging, we'd need four.
    mint = mbc
    ierror = 0
    count = 1

    !! # Time interpolate only to the interior cells.

    do m = 1,meqn
        do k = 1,mz
            !! # Face 0
            do j = 1,my-mint
                do i = 1,mint
                    qinterp(i,j,k, m) = qlast(i,j,k,m) + &
                        alpha*(qcurr(i,j,k,m)-qlast(i,j,k,m))
                    count = count + 1
                end do
            end do

            !! # Face 2
            do j = 1,mint
                do i = mint+1,mx
                    qinterp(i,j,k,m) = qlast(i,j,k,m) + &
                        alpha*(qcurr(i,j,k,m)-qlast(i,j,k,m))
                    count = count + 1
                end do
            end do

            !! # Face 1
            do j = mint+1,my
                do i = mx-mint+1,mx
                    qinterp(i,j,k, m) = qlast(i,j,k,m) + &
                         alpha*(qcurr(i,j,k,m)-qlast(i,j,k,m))
                    count = count + 1
                end do
            end do

            !! # Face 3
            do j = my-mint+1,my
                do i = 1,mx-mint
                    qinterp(i,j,k,m) = qlast(i,j,k,m) + &
                         alpha*(qcurr(i,j,k,m)-qlast(i,j,k,m))
                    count = count + 1
                end do
            end do
        end do
    end do

    count_final = count-1
    if (count_final .ne. psize) then
       ierror = 2
    endif

end


      program brune

!     Choose tau = 0.1 for sac examples/convolve
!     Could modify program to input N and delta too.

      real*4 pulse(100)
      character*40 file_out,input
      nmarg = iargc()
      if (nmarg .eq. 0) then
         write(*,*)'Usage: brune tau file_out'
         write(*,*) 'N=64, delta=0.02'
         stop
      end if
      call getarg(1,input)
      read(input,'(f10.0)') tau
      call getarg(2,file_out)
      write(*,*) tau,file_out
      N = 64
      delta = 0.02
      do j=1,N
         t = float(j-1)*delta/tau
         pulse(j) = t*exp(-t)
      enddo
      call wsac1(file_out,pulse,64,0.0,delta,nerr)
      stop
      end


!! DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS HEADER.
!!
!! Copyright 2009 Sun Microsystems, Inc. All rights reserved.
!!
!! The contents of this file are subject to the terms of the BSD License("BSD")(the "License").
!! You can obtain a copy of the License at: http://www.opensparc.net/pubs/t1/licenses/BSD+_License.txt
!!
!! The BSD License
!!
!! Redistribution and use in source and binary forms, with or without
!! modification, are permitted provided that the following conditions are met:
!!
!!     * Redistribution of source code must retain the above copyright
!!       notice, this list of conditions and the following disclaimer.
!!     * Redistribution in binary form must reproduce the above copyright
!!       notice, this list of conditions and the following disclaimer in
!!       the documentation and/or other materials provided with the
!!       distribution.
!!     * Neither the name of Sun Microsystems, Inc. or the names of
!!       contributors may be used to endorse or promote products derived
!!       from this software without specific prior written permission.
!!
!! This software is provided "AS IS," without a warranty of any kind. ALL
!! EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, INCLUDING ANY
!! IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE OR
!! NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN MICROSYSTEMS, INC. ("SUN") AND
!! ITS LICENSORS SHALL NOT BE LIABLE FOR ANY DAMAGES SUFFERED BY LICENSEE AS A
!! RESULT OF USING, MODIFYING OR DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES.
!! IN NO EVENT WILL SUN OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT
!! OR DATA, OR FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR
!! PUNITIVE DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
!! ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF SUN HAS
!! BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
!!
!! You acknowledge that this software is not designed, licensed or intended for
!! use in the design, construction, operation or maintenance of any nuclear facility.

      program array_reduction

!$    use OMP_LIB

      implicit none

      integer:: i, j, n, memstat
      integer, allocatable:: a(:), b(:,:), c(:), indx(:), ref(:)

      n = 9

!$    call OMP_SET_DYNAMIC(.false.)
!$    if (OMP_GET_DYNAMIC()) print *,'Warning: dynamic adjustment of threads has been set'
!$    call OMP_SET_NUM_THREADS(4)

      allocate(a(1:n), STAT=memstat)
      if (memstat /= 0) stop 'Fatal error in memory allocation for A'

      allocate(b(1:n,1:n), STAT=memstat)
      if (memstat /= 0) stop 'Fatal error in memory allocation for B'

      allocate(c(1:n), STAT=memstat)
      if (memstat /= 0) stop 'Fatal error in memory allocation for C'

      allocate(indx(1:n), STAT=memstat)
      if (memstat /= 0) stop 'Fatal error in memory allocation for INDX'

      allocate(ref(1:n), STAT=memstat)
      if (memstat /= 0) stop 'Fatal error in memory allocation for REF'

      do i = 1, n
         indx(i) = i
      end do

      do j = 1, n
         b(1:n,j) = indx(1:n)
      end do
      c(1:n) = indx(1:n) + 1

      ref(1:n) = 0
      do j = 1, n
         ref(1:n) = ref(1:n) + b(1:n,j)*c(j)
      end do

      call mxv(n, a, b, c)

      print *,'After MXV:'
      print *,'Result array a is   :',a(1:n)
      print *,'Reference solution  :',ref(1:n)
      print *,'Difference a - ref  :',a(1:n)-ref(1:n)

      if (allocated(a)) deallocate(a)
      if (allocated(b)) deallocate(b)
      if (allocated(c)) deallocate(c)
      if (allocated(c)) deallocate(indx)

      end program array_reduction

      subroutine mxv(n, a, b, c)
      implicit none
      integer:: n, a(1:n), b(1:n,1:n), c(1:n)

      integer:: j

!$OMP PARALLEL WORKSHARE
      a(1:n) = 0.0
!$OMP END PARALLEL WORKSHARE

!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(j) SHARED(n,b,c) &
!$OMP          REDUCTION(+:a)
      do j = 1, n
         a(1:n) = a(1:n) + b(1:n,j)*c(j)
      end do
!$OMP END PARALLEL DO

      return
      end


!*******************************************************************************
! * Copyright 2019 UChicago Argonne, LLC.
! * (c.f. AUTHORS, LICENSE)
! *
! * This file is part of the nrm-extra project.
! * For more info, see https://github.com/anlsys/nrm-extra
! *
! * SPDX-License-Identifier: BSD-3-Clause
!*******************************************************************************

module test_collectives
use mpi
implicit none

contains
subroutine check_collectives(size, rank)
implicit none
integer, intent(in) :: size, rank
integer :: i, ierror
double precision, dimension(size) :: local, recv
double precision :: err

do i = 1, size
        local(i) = rank
end do

call MPI_BARRIER(MPI_COMM_WORLD, ierror)
call MPI_ALLREDUCE(local, recv, size, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD, ierror)

do i = 1, size
        err = recv(i) - ((size*(size-1))/2)
        if(err > 1e-14) then
                call exit(1)
        endif
end do
end subroutine
end module test_collectives

program mpi_collectives
use test_collectives
implicit none
integer :: rank, size, ierror

call MPI_INIT(ierror)
call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierror)
call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierror)

call check_collectives(size, rank)
call MPI_FINALIZE(ierror)

end


! $ gfortran -g -O0 -std=f2008 -Wall f.f08 -o f.exe
! $ ./f
!  compiles             syntax error
! :
! :                     ][
! :                     ]][[
! :[[[]]]
! :                     ][[][]][
! :                     ][[]]][[[]
! :                     ]]]][]][[[[[
! :                     ]]]][][]][[[[[
! :                     ][[[]]]]][]][[[[
! :                     [[][]]][]]][[[][[]
! :                     ]]][[][[[[[[[[]]]]]]
! :[[][[[][]]][]]
! :[[[][]][][[[]][]][]]

program balanced_brackets
  implicit none
  integer :: N
  character(len=20) :: brackets, fmt
  write(6,*)'compiles             syntax error'
  call random_seed
  do N=0, 10
     call generate(N, brackets)
     if (balanced(brackets)) then
        fmt = '(a,a20)'
     else
        fmt = '(a,21x,a20)'
     end if
     write(6,fmt)':',brackets
  end do

  brackets = '[[][[[][]]][]]'
  if (balanced(brackets)) then
     fmt = '(a,a20)'
  else
     fmt = '(a,21x,a20)'
  end if
  write(6,fmt)':',brackets

  N = 10
  call generate(N, brackets)
  do while (.not. balanced(brackets)) ! show a balanced set
     call generate(N, brackets)
  end do
  fmt = '(a,a20)'
  write(6,fmt)':',brackets

contains

  logical function balanced(s)
    implicit none
    character(len=*), intent(in) :: s
    integer :: i, a, n
    n = len_trim(s)
    a = 0
    balanced = .true.
    do i=1, n
       if (s(i:i) == '[') then
          a = a+1
       else
          a = a-1
       end if
       balanced = balanced .and. (0 <= a)
    end do
  end function balanced

  subroutine generate(N, s)
    implicit none
    integer, intent(in) :: N
    character(len=*), intent(out) :: s
    integer :: L, R, i
    real, dimension(2*N) :: harvest
    character :: c
    i = 1
    L = 0
    R = 0
    s = ' '
    call random_number(harvest)
    do while ((L < N) .and. (R < N))
       if (harvest(i) < 0.5) then
          L = L+1
          s(i:i) = '['
       else
          R = R+1
          s(i:i) = ']'
       end if
       i = i+1
    end do
    c = merge('[', ']', L < N)
    do while (i <= 2*N)
       s(i:i) = c
       i = i+1
    end do
  end subroutine generate
end program balanced_brackets


program pretreatmentmodeling

	use polynomial_module
	use inputs_module
	use exprparser_module
	use element_module
	use outputs_module
	use timestepper_module

	implicit none

	integer :: i
	real*8 :: delr,endp(2)
	real*8,allocatable :: pointsoln(:,:)
	real*8,allocatable :: interpsoln(:,:)

	call readinpfile(inpobj,'pretreat_defs.inp')

	allocate(elementarray(inpobj%nelements))

	delr=(inpobj%maxr-inpobj%minr)/(inpobj%nelements)

	do i=1,inpobj%nelements

		endp(1)=inpobj%minr+(i-1)*delr
		endp(2)=inpobj%minr+i*delr

		if(i .eq. 1) then
			call setelementattribs(elementarray(i),endp,inpobj,1)
		else if(i .eq. inpobj%nelements) then
			call setelementattribs(elementarray(i),endp,inpobj,2)
		else
			call setelementattribs(elementarray(i),endp,inpobj)
		endif
	enddo

	if(inpobj%timeorder .eq. 0) then
		call timestepping_Implicit(inpobj,elementarray,pointsoln,interpsoln)
	else
		call timestepping_explicit(inpobj,elementarray,pointsoln,interpsoln)
	endif

	write(*,'(A)',advance='yes')
	print *,"======================================="

end program pretreatmentmodeling


!
! SEUIF97 Library:
!
!  1 Windows: C:/Windows/system/libseuif97.dll
!  2 Linux:  /usr/lib/libseuif97.so
!  3 The Module: ./seuif97.f08

! Build：
! Windows with MinGW-W64
!  >gfortran -fno-underscoring -c seuif97.f08 -LC:/Windows/system/ -lseuif97
!  >gfortran -fno-underscoring -o demo demo_fortran_module.f08 -LC:/Windows/system/ -lseuif97
!
! Linux：
!  $gfortran  -fno-underscoring -c seuif97.f08 -L/usr/lib/ -lseuif97 -lm
!  $gfortran  -fno-underscoring -o demo demo_fortran_module.f08 seuif97.f08 -L/usr/lib/ -lseuif97 -lm
!
! Run:
! ./demo
!
! Author: Cheng Maohua
! Email:  cmh@seu.edu.cn
!
! Last modified: 2019.01.05
!

program demo
  use iso_c_binding
  use seuif97
  implicit none
  real(c_double) :: p,t,h,s,v
  p = 16.13;
  t = 535.0;

  h = seupt(p, t, 4);
  s = seupt(p, t, 5);
  v = seupt(p, t, 3);
  write (*,'(A,F10.2,F10.2,F10.2,F10.4,F10.4)') "(p,t),h,s,v",p,t,h,s,v

  t = seuph(p, h, 1);
  s = seuph(p, h, 5);
  v = seuph(p, h, 3);
  write (*,'(A,F10.2,F10.2,F10.2,F10.4,F10.4)') "(p,h),t,s,v",p,h,t,s,v

  t = seups(p, s, 1);
  h = seups(p, s, 4);
  v = seups(p, s, 3);
  write (*,'(A,F10.2,F10.2,F10.2,F10.4,F10.4)') "(p,s),t,h,v",p,s,t,h,v

  p = seuth(t, h, 0);
  s = seuth(t, h, 5);
  v = seuth(t, h, 3);
  write (*,'(A,F10.2,F10.2,F10.2,F10.4,F10.4)') "(t,h),p,s,v",t,h,p,s,v

end program demo