c=======================================================================
c
c     subroutine  RCHO
c
c     Robust Choleski factorization of a symmetric matrix (not necessary
c     definite positive):
c
c     X = L*L', where L is an lower triangular matrix
c
c-----------------------------------------------------------------------
      SUBROUTINE rcho ( n, X, iwork, dwork, L, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : matrix size                                integer
c            X      : symmetric matrix (n*n)                      double
c
c     WORKSPACE
c            iwork  : vector(12*n)                               integer
c            dwork  : vector(n*(4*n + 27))                        double
c
c     OUTPUT
c            L      : lower triangular matrix (n*n)               double
c            info   : = 0 successful exit                        integer
c
c     CALL
c            PROJECTA : projection of a symmetric matrix on matrix cone >= alpha
c            CHOL     : Choleski factorization X = L*L' of a symmetric matrix
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info
      DOUBLE PRECISION X(*), L(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piw, pmat, pdw
      DOUBLE PRECISION alpha
      PARAMETER ( alpha = 1.E-30 )
c
c     external subroutines
      EXTERNAL projecta, chol
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw = 1
c     piw   : pointer for PROJECTA workspace who needs ( 12*n )
c
c     Total size of iwork array : ( 12*n )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pmat = 1
c     pmat  : pointer for work matrix(n*n), so (n*n) more
      pdw = pmat + ( n*n )
c     pdw   : pointer for PROJECTA workspace who needs n*(3*n+27)
c                        and CHOL workspace who needs (n*n),
c             so n*(3*n+27) more
c
c     Total size of dwork array : (n*n) + n*(3*n+27)
c                                 = n*(4*n + 27)
c
c-----------------------------------------------------------------------
c
c     projection on the cone of definite matrices
      CALL projecta ( n, X, alpha, iwork(piw), dwork(pdw),
     &                dwork(pmat), info )
      IF (info .LT. 0) RETURN
c
c     Choleski factorization
      CALL chol ( n, dwork(pmat), dwork(pdw), L, info )
c
      RETURN
      END


      SUBROUTINE CYLCAL(ITYPE,RLAT,RLON,ZC,CPSI,F,FL,REQ,PI,FLAG)
C
C     RETURNS CALCULATED LATITUDE AND LONGITUDE AT
C          DELX SAMPLES,DELZ LINES FROM SAMPLE 1 AT LATITUDE ZERO
C          RLAT=DELX AT ENTRANCE
C             =LATITUDE AT EXIT
C         RLON=DELZ AT ENTRANCE
C           =LONGITUDE AT EXIT
C     CPSI =LONGITUDE OF SAMPLE 1
C     ZC   = LINE OF THE EQUATOR
C     F    = SCAL AT EQUATOR (KM/PIXEL)
C     FL    = POLAR RADIUS (KM)
C     REQ   = EQUATORIAL RADIUS (KM)
C     NOTE THAT DELZ WILL BE NEGATIVE FOR POSITIVE LATITUDE
      REAL*8 RFL,DREQ
      REAL*8 ZDEL ,DRPOLE,RAD,DLAT,DLAT2
      REAL*8 TOL
      DATA   TOL/1.D-7/
C==================================================================
      DRPOLE=DBLE(FL)
      DREQ=DBLE(REQ)
      RFL=DREQ/DRPOLE
      RFL=RFL*RFL
      IF(ITYPE.EQ.2)GO TO 600
100   CONTINUE
      DELX=RLAT-1.
      DELZ=-(RLON-ZC)
C
C     CALCULATE LONGITUDE
      RLON=F*DELX/REQ/PI*180.
      IF(ABS(RLON).GT.360)GO TO 400
      RLON=CPSI-RLON
      RLON=AMOD(360.+RLON,360.)
C
C     CALCULATE LATITUDE
C     WE MUST SOLVE
C     LAT=ARCSIN(X*F/R(LAT))
C     WE WILL ASSUME  THE EQUATORIAL RADIUS
C     AND THEN ITERATE UNTIL CONVERGENCE
C
      ZDEL=DBLE(F*DELZ)
C
C     CHK FOR PT OFF PLANET
      IF(DABS(ZDEL)-DRPOLE)130,120,400
120   CONTINUE
c      LAT=SIGN(90.,DELZ)
      RLAT=SIGN(90.,DELZ)   ! JAM 7-JUL-1985  NO OTHER REFS TO "LAT", MUST BE WRONG
      GO TO 500
130   CONTINUE
      ITER=0
C
C     INITIAL GUESS FOR RADIUS AND LAT
      RAD=DBLE(REQ)
      DLAT=DASIN(ZDEL/RAD)
140   CONTINUE
C
C     CALC LAT AND CHK FOR ITERATION
      RAD=DREQ/(DSQRT(RFL+(1.0D0-RFL)*DCOS(DLAT)**2))
      DLAT2=DLAT
      DLAT=DASIN(ZDEL/RAD)
      IF(DABS(DLAT-DLAT2).LT.TOL)GO TO 160
      ITER=ITER+1
      IF(ITER.LT.100)GO TO 140
      CALL QPRINT(' *** CYLINDRICAL PROJ CONVERGENCE ERROR.',40)
	IZERO=0
      I=1/IZERO
160   CONTINUE
      RLAT=DLAT*180.0D0/ PI
      RETURN
400   RLON=FLAG
      RLAT=FLAG
500   CONTINUE
      RETURN
600   CONTINUE
C
C     GIVEN RLAT/RLON FIND DELX/DELZ
      DELX=REQ*(AMOD(360.-(AMOD(RLON+360.,360.)-CPSI),360.))*PI/180./F
      DELZ=ABS(RLAT)
      IF(DELZ.LT.90.0)GO TO 610
C
C     WE ARE AT THE POLE
      DELZ=SIGN(FL/F,RLAT)
      DELZ=-DELZ
      GO TO 700
610   CONTINUE
C
C     FIND RADIUS AT RLAT
      DLAT=RLAT*PI/180.
      RAD=DREQ/(DSQRT(RFL+(1.0D0-RFL)*DCOS(DLAT)**2))
      DELZ=RAD/F*SIN(RLAT*PI/180.)
      DELZ=-DELZ
700   CONTINUE
      RLAT=DELX+1.
      RLON=DELZ+ZC
      RETURN
      END


c=======================================================================
c
c     subroutine PCA
c
c     PCA (Principal Component Analysis)
c
c-----------------------------------------------------------------------
      SUBROUTINE pca ( ndate, nasset, dasset, indpca,
     &                 nfask, varmin, epsin,
     &                 iwork, dwork, nfatra, varian, covcor,
     &                 specor, eigvec, epskat, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            ndate  : full estimation period                     integer
c            nasset : size of problem                            integer
c            dasset : returns  matrix(ndate*nasset)               double
c            indpca : indicator                                  integer
c                = 1   factor tracking with nfask-factor(s)
c                  11  (epskat constant input)
c                  12  (epskat constant computed)
c                = 2 factor tracking for a level of explicative variance
c                  11  (epskat constant input)
c                  12  (epskat constant computed)
c            nfask  : asked number of tracked factors            integer
c            varmin : minimun variance to reach                   double
c            epsin  : Kato-sensitivity in input                   double
c
c     WORKSPACE
c            iwork  : vector( 13*nasset )                        integer
c            dwork  : vector( nasset *(ndate+3*nasset+27) )     double
c
c     OUTPUT
c            nfatra : number of tracked factors                  integer
c            epskat : computed Kato sensibility                   double
c            varian : variance                                    double
c            covcor : corrected covariance matrix(nasset*nasset)  double
c            specor : corrected spectrum vector(nasset)           double
c            eigvec : eigenvectors matrix(nasset*nasset)          double
c            info   : diagnostic argument                        integer
c
c     CALL
c        COVMVM    : covariance matrix (equally weighted) and mean vector
c        KATVAR  : Kato decomposition of a symmetric matrix
c                  the maximum Kato sensibility and the number factors
c                  for a given variance
c        KATEPS  : computes the Kato decomposition of a symmetric matrix
c                  and the maximum Kato sensibility
c                  to separate choosing eigenvalue of the next
c        OMCDMCT : computing M*D*M'
c                  (M square matrix n*n, D vector n of diagonal matrix,
c                   gives square matrix n*n )
c        ZMCMC   : symmetrises a vectorized full square matrix
c                  and gives a vectorized full square matrix A=(A+A')/2
c        VARFAC  : computes the variance of n first factors
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER ndate, nasset, indpca, nfask, nfatra, ngrkat, info
      DOUBLE PRECISION varmin, epsin, epskat, varian
      DOUBLE PRECISION dasset(ndate,*), covcor(*), specor(*), eigvec(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
      INTEGER iwork(*)
c
c     local parameters
      INTEGER i, ig, iev, nbev, pigk, piw, pdw, pvecw, pmatw
      DOUBLE PRECISION mean, sum
c
c-----------------------------------------------------------------------
c
c     test indpca
      IF ((indpca .NE. 11).AND.(indpca .NE. 12)
     &    .AND.(indpca .NE. 21).AND.(indpca .NE. 22)) THEN
         info = -4001
         RETURN
      ENDIF
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      pigk = 1
c     pigk  : pointer for Kato groups,
      piw = pigk + nasset
c     piw   : pointer for workspaces,
c             KATVAR needs (12*nasset)
c             KATEPS needs (12*nasset)
c             so  (12*nasset) more
c
c     Total size of iwork array = (13*nasset)
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pvecw = 1
c     pvecw : pointer for work vector, so (nasset) more
      pmatw = pvecw + (nasset)
c     pdata : pointer for work matrix, so (nasset*nasset) more
      pdw   = pmatw + (nasset*nasset)
c     pdw   : pointer for workspaces,
c             COVMVM   needs ( ndate*nasset )
c             KATVAR needs ( nasset*(2*nasset+27) )
c             OMCDMCT needs ( nasset*nasset )
c             so  ( nasset*(ndate+2*nasset+27) ) more
c
c     Total size of dwork array = (nasset) + (nasset*nasset)
c                               + ( nasset*(ndate+2*nasset+27)
c              ( nasset *( ndate + 3*nasset + 28 ) )
c
c-----------------------------------------------------------------------
c
c     initial covariance matrix (empiric equally weighted)
      CALL covmvm ( ndate, nasset, dasset, dwork(pdw),
     &            dwork(pvecw), covcor, info)
      IF (info .LT. 0) RETURN
c
c     computing Kato sensibily and number of tracked factors
c     to approach as best the asked variance
      IF ((indpca .EQ. 21) .AND. (indpca .EQ. 22)) THEN
         CALL katvar ( nasset, covcor, varmin, epsin, indpca,
     &                 iwork(piw), dwork(pdw), varian, nfatra,
     &                 epskat, specor, eigvec,
     &                 ngrkat, iwork(pigk), info )
         IF (info .LT. 0) RETURN
      ELSE
         nfatra = nfask
         CALL kateps ( nasset, covcor, nfatra, epsin, indpca,
     &                 iwork(piw), dwork(pdw), epskat,
     &                 specor, eigvec,
     &                 ngrkat, iwork(pigk), info )
         IF (info .LT. 0) RETURN
      ENDIF
c
c     averages eigenvalues in Kato groups
      iev = 0
      DO ig = 1,ngrkat
         nbev = iwork(pigk+ig-1)
         sum  = 0.
c
         DO i = 1,nbev
            sum = sum + specor(iev+i)
         ENDDO
c
         mean = sum / nbev
c
         DO i = 1,nbev
            specor(iev+i) = mean
         ENDDO
c
         iev = iev + nbev
      ENDDO
c
c     covariance matrix = eigvec*specor*eigvec'
      CALL OMCDMCT ( nasset, eigvec, specor, dwork(pdw),
     &               dwork(pmatw) )
c
c     construct a symmetry matrix (for computer precision)
      CALL ZMCMC ( nasset, dwork(pmatw), covcor )
c
c     variance of the factors (alglin/utils/utstat.f)
      CALL VARFAC ( nasset, specor, nfatra, varian, info )
c
      RETURN
      END


module rad_util_module

  use bl_types
  use bl_error_module
  use rad_params_module, only : ngroups
  use bl_constants_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

contains

  subroutine compute_ptot_ctot(lam, q, cg, ptot, ctot, gamc_tot)

    use meth_params_module, only : QPRES, QRHO, comoving, QRAD, QPTOT, NQ
    use fluxlimiter_module, only : Edd_factor

    use amrex_fort_module, only : rt => amrex_real
    real(rt)        , intent(in) :: lam(0:ngroups-1)
    real(rt)        , intent(in) :: q(NQ)
    real(rt)        , intent(in) :: cg
    real(rt)        , intent(out) :: ptot
    real(rt)        , intent(out) :: ctot
    real(rt)        , intent(out) :: gamc_tot

    integer :: g

    real(rt)         :: csrad2, Eddf, gamr, prad

    csrad2 = ZERO
    prad = ZERO

    do g = 0, ngroups-1
       if (comoving) then
          Eddf = Edd_factor(lam(g))
          gamr = (THREE - Eddf)/TWO
       else
          gamr = lam(g) + ONE
       end if

       prad = prad + lam(g)*q(QRAD+g)
       csrad2 = csrad2 + gamr * (lam(g)*q(QRAD+g)) / q(QRHO)
    end do

    ptot = q(QPRES) + prad

    ctot = cg**2 + csrad2
    gamc_tot = ctot * q(QRHO) / ptot

    ctot = sqrt(ctot)

  end subroutine compute_ptot_ctot

  function FLDlambda(r, limiter) result (lambda)

    use amrex_fort_module, only : rt => amrex_real
    real(rt)         :: r
    integer :: limiter

    real(rt)         :: lambda

    if (limiter .eq. 0) then
       ! no limiter
       lambda = 1.e0_rt/3.e0_rt

    else if (limiter < 10) then
       ! approximate LP
       lambda = (2.e0_rt + r) / (6.e0_rt + r * (3.e0_rt + r))

    else if (limiter < 20) then
       ! Bruenn
       lambda = 1.e0_rt / (3.e0_rt + r)

    else if (limiter < 30) then
       ! Larsen's square root
       lambda = 1.e0_rt / sqrt(9.e0_rt + r**2)

    else if (limiter < 40) then
       ! Minerbo
       if (r .lt. 1.5e0_rt) then
          lambda = 2.e0_rt/(3.e0_rt + sqrt(9.e0_rt+12.e0_rt*r**2))
       else
          lambda = 1.e0_rt/(1.e0_rt+r+sqrt(1.e0_rt+2.e0_rt*r))
       end if

    else
       call bl_error("Unknown limiter ", limiter)
    endif
  end function FLDlambda

end module rad_util_module


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief Jacobian calculation

module hecmw_Jacob241
contains

  subroutine hecmw_Jacob_241 ( hecMESH, iElem, DET, W, N, NX, NY )
    use hecmw_util

    implicit none

    type(hecmwST_local_mesh):: hecMESH
    integer(kind=kint)::       iElem
    real(kind=kreal)::         DET
    real(kind=kreal)::         W(4), N(4,4), NX(4,4), NY(4,4)

    integer(kind=kint):: i, j, jj, iLocal
    integer(kind=kint):: LX, LY
    real(kind=kreal)::   DUM
    real(kind=kreal)::   XX(4), YY(4)
    real(kind=kreal)::   XG(2), HR(2,2,4), HS(2,2,4), HT(2,2,4)
    real(kind=kreal)::   H(2,2,4),BX(2,2,4),BY(2,2,4),BZ(2,2,4)
    real(kind=kreal)::   RI, SI, RP, SP, RM, SM
    real(kind=kreal)::   XJ11,XJ12,XJ21,XJ22
    real(kind=kreal)::   XJI11,XJI12,XJI21,XJI22

    data XG/-0.5773502691896D0, 0.5773502691896D0/

    do j = 1, 4
      jj = 4 - j
      iLocal = hecMESH%elem_node_item  ( 4*iElem -jj )
      XX(j)  = hecMESH%node( iLocal*2 -1 )
      YY(j)  = hecMESH%node( iLocal*2    )
      W(j)  = 1.0D0
    end do
    !C
    !C*LOOP OVER ALL INTEGRATION POINTS
    do LX=1,2
      RI=XG(LX)
      do LY=1,2
        SI=XG(LY)
        RP=1.0+RI
        SP=1.0+SI
        RM=1.0-RI
        SM=1.0-SI
        !!
        !! ******** Shape functions ********
        !!
        H(LX,LY,1)=0.25*RM*SM
        H(LX,LY,2)=0.25*RP*SM
        H(LX,LY,3)=0.25*RP*SP
        H(LX,LY,4)=0.25*RM*SP
        !!
        !! ******** Derivative of shape functions ********
        !!
        !! ----------- For R-Coordinate -------------
        HR(LX,LY,1)=-.25*SM
        HR(LX,LY,2)= .25*SM
        HR(LX,LY,3)= .25*SP
        HR(LX,LY,4)=-.25*SP
        !! ----------- For S-Coordinate -------------
        HS(LX,LY,1)=-.25*RM
        HS(LX,LY,2)=-.25*RP
        HS(LX,LY,3)= .25*RP
        HS(LX,LY,4)= .25*RM
        !!
        !! ******** Jacobi matrix calculation********
        !!
        XJ11=0.0
        XJ21=0.0
        XJ12=0.0
        XJ22=0.0
        do I=1,4
          XJ11=XJ11+HR(LX,LY,I)*XX(I)
          XJ21=XJ21+HS(LX,LY,I)*XX(I)
          XJ12=XJ12+HR(LX,LY,I)*YY(I)
          XJ22=XJ22+HS(LX,LY,I)*YY(I)
        end do
        DET=XJ11*XJ22-XJ21*XJ12
        !!
        !! ******** Inverse Jacobi matrix calculation ********
        !!
        DUM=1.0/DET
        XJI11= XJ22*DUM
        XJI12=-XJ12*DUM
        XJI21=-XJ21*DUM
        XJI22= XJ11*DUM
        do J=1, 4
          BX(LX,LY,J)=XJI11*HR(LX,LY,J)+XJI12*HS(LX,LY,J)
          BY(LX,LY,J)=XJI21*HR(LX,LY,J)+XJI22*HS(LX,LY,J)
        end do
        !C
      end do
    end do
    !C

    J = 1
    do LX = 1, 2
      do LY = 1, 2

        N(J,1)  = H(LX,LY,1)
        N(J,2)  = H(LX,LY,2)
        N(J,3)  = H(LX,LY,3)
        N(J,4)  = H(LX,LY,4)

        NX(J,1) = BX(LX,LY,1)
        NX(J,2) = BX(LX,LY,2)
        NX(J,3) = BX(LX,LY,3)
        NX(J,4) = BX(LX,LY,4)

        NY(J,1) = BY(LX,LY,1)
        NY(J,2) = BY(LX,LY,2)
        NY(J,3) = BY(LX,LY,3)
        NY(J,4) = BY(LX,LY,4)

        J = J + 1
      end do
    end do

    !C
    !C
  end subroutine hecmw_Jacob_241

end module hecmw_Jacob241


SUBROUTINE load_function(lf,dtim,al)
!
! This subroutine forms the increment of load at each
! calculation time step.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::lf(:,:),dtim
 REAL(iwp),INTENT(IN OUT)::al(:)
 REAL(iwp)::time,aold,anew
 INTEGER::nlfp,nincs,i,j
 nincs=SIZE(al)
 nlfp=UBOUND(lf,2)
 aold=lf(2,1)
 time=lf(1,1)
 DO i=1,nincs
   time=time+dtim
   DO j=1,nlfp
     IF(time<lf(1,j))THEN
       anew=lf(2,j-1)+                                                    &
         (time-lf(1,j-1))*(lf(2,j)-lf(2,j-1))/(lf(1,j)-lf(1,j-1))
       al(i)=anew-aold
       aold=anew
       EXIT
     END IF
   END DO
 END DO
RETURN
END SUBROUTINE load_function


      SUBROUTINE AVERAGECODIM(coarse,icoarselo0,icoarselo1,icoarsehi0,icoarsehi1,ncoarsecomp,fine,&
     &ifinelo0,ifinelo1,ifinehi0,ifinehi1,nfinecomp,iboxlo0,iboxlo1,iboxhi0,iboxhi1,refRatio,&
     &refFactor,refDim,ibreflo0,ibreflo1,ibrefhi0,ibrefhi1)
      IMPLICIT NONE
      INTEGER(kind=8) :: chiterations
      INTEGER(kind=8) :: chflops, chloads, chstores
      COMMON / chiterations / chiterations
      COMMON / chflops / chflops,chloads,chstores
      external :: CHCOMMON
      INTEGER :: ncoarsecomp
      INTEGER :: icoarselo0, icoarselo1
      INTEGER :: icoarsehi0, icoarsehi1
      REAL(kind=8), DIMENSION(icoarselo0:icoarsehi0,icoarselo1:icoarsehi1,0:(ncoarsecomp - 1)) :: coarse
      INTEGER :: nfinecomp
      INTEGER :: ifinelo0, ifinelo1
      INTEGER :: ifinehi0, ifinehi1
      REAL(kind=8), DIMENSION(ifinelo0:ifinehi0,ifinelo1:ifinehi1,0:(nfinecomp - 1)) :: fine
      INTEGER :: iboxlo0, iboxlo1
      INTEGER :: iboxhi0, iboxhi1
      INTEGER :: refRatio
      INTEGER :: refFactor
      INTEGER :: refDim
      INTEGER :: ibreflo0, ibreflo1
      INTEGER :: ibrefhi0, ibrefhi1
      INTEGER :: var
      INTEGER :: ic0, ic1
      INTEGER :: ip0, ip1
      INTEGER :: ii0, ii1
      REAL(kind=8) :: refScale, coarseSum
      refScale = (1.0d0) / (refFactor ** refDim)
      DO var = 0, ncoarsecomp - 1
      chiterations = (1 + iboxhi1 - iboxlo1) * (1 + iboxhi0 - iboxlo0) * 1
      DO ic1 = iboxlo1, iboxhi1
      DO ic0 = iboxlo0, iboxhi0
      ip0 = ic0 * refRatio
      ip1 = ic1 * refRatio
      coarseSum = (0.0d0)
      chiterations = (1 + ibrefhi1 - ibreflo1) * (1 + ibrefhi0 - ibreflo0) * 1
      DO ii1 = ibreflo1, ibrefhi1
      DO ii0 = ibreflo0, ibrefhi0
      coarseSum = coarseSum + fine(ip0 + ii0,ip1 + ii1,var)
      END DO
      END DO
      coarse(ic0,ic1,var) = coarseSum * refScale
      END DO
      END DO
      END DO
      RETURN
      END SUBROUTINE

      SUBROUTINE AVERAGECODIMHARMONIC(coarse,icoarselo0,icoarselo1,icoarsehi0,icoarsehi1,ncoarsecomp,fine,&
     &ifinelo0,ifinelo1,ifinehi0,ifinehi1,nfinecomp,iboxlo0,iboxlo1,iboxhi0,iboxhi1,refRatio,refFactor,&
     &refDim,ibreflo0,ibreflo1,ibrefhi0,ibrefhi1)
      IMPLICIT NONE
      INTEGER(kind=8) :: chiterations
      INTEGER(kind=8) :: chflops, chloads, chstores
      COMMON / chiterations / chiterations
      COMMON / chflops / chflops,chloads,chstores
      external :: CHCOMMON
      INTEGER :: ncoarsecomp
      INTEGER :: icoarselo0, icoarselo1
      INTEGER :: icoarsehi0, icoarsehi1
      REAL(kind=8), DIMENSION(icoarselo0:icoarsehi0,icoarselo1:icoarsehi1,0:(ncoarsecomp - 1)) :: coarse
      INTEGER :: nfinecomp
      INTEGER :: ifinelo0, ifinelo1
      INTEGER :: ifinehi0, ifinehi1
      REAL(kind=8), DIMENSION(ifinelo0:ifinehi0,ifinelo1:ifinehi1,0:(nfinecomp - 1)) :: fine
      INTEGER :: iboxlo0, iboxlo1
      INTEGER :: iboxhi0, iboxhi1
      INTEGER :: refRatio
      INTEGER :: refFactor
      INTEGER :: refDim
      INTEGER :: ibreflo0, ibreflo1
      INTEGER :: ibrefhi0, ibrefhi1
      INTEGER :: var
      INTEGER :: ic0, ic1
      INTEGER :: ip0, ip1
      INTEGER :: ii0, ii1
      REAL(kind=8) :: refScale, coarseSum
      refScale = (1.0d0) / (refFactor ** refDim)
      DO var = 0, ncoarsecomp - 1
      chiterations = (1 + iboxhi1 - iboxlo1) * (1 + iboxhi0 - iboxlo0) * 1
      DO ic1 = iboxlo1, iboxhi1
      DO ic0 = iboxlo0, iboxhi0
      ip0 = ic0 * refRatio
      ip1 = ic1 * refRatio
      coarseSum = (0.0d0)
      chiterations = (1 + ibrefhi1 - ibreflo1) * (1 + ibrefhi0 - ibreflo0) * 1
      DO ii1 = ibreflo1, ibrefhi1
      DO ii0 = ibreflo0, ibrefhi0
      coarseSum = coarseSum + (1.0d0) / fine(ip0 + ii0,ip1 + ii1,var)
      END DO
      END DO
      coarse(ic0,ic1,var) = (1.0d0) / (coarseSum * refScale)
      END DO
      END DO
      END DO
      RETURN
      END SUBROUTINE


      FUNCTION CHEBEV(A,B,C,M,X)
      DIMENSION C(M)
      IF ((X-A)*(X-B).GT.0.) PAUSE 'X not in range.'
      D=0.
      DD=0.
      Y=(2.*X-A-B)/(B-A)
      Y2=2.*Y
      DO 11 J=M,2,-1
        SV=D
        D=Y2*D-DD+C(J)
        DD=SV
11    CONTINUE
      CHEBEV=Y*D-DD+0.5*C(1)
      RETURN
      END


C NCLFORTSTART
      SUBROUTINE DZREGR1(N,M,M2,Y,YMSG,X,XMSG,C,RESID,CON,CNORM,WK,YY,
     +                   COV,XSD,XMEAN,A,AINV,S)
      IMPLICIT NONE
      INTEGER  N,M,M2
      DOUBLE PRECISION Y(N),X(N,M),C(M),CNORM(M),RESID(N),XMSG,YMSG,CON
      DOUBLE PRECISION WK(M,M2)
      DOUBLE PRECISION YY(N),COV(M,M),XSD(M),XMEAN(M)
      DOUBLE PRECISION A(M,M),AINV(M,M),S(M)
C NCLEND

C NCL:    C = reg_multlin (y[*], x[*][*], opt)

C Nomenclature:
C .   C      - the raw partial correlation coef
C .   CNORM  - the standardized partial correlation coef
C
C The WK array used to be allocated inside the DZREGR2 subroutine,
C but this caused a problem for some compilers. The C wrapper for
C this function is now allocating this array and passing it in.
C Same issue for YY, COV, XSD, and XMEAN.
C
C ADJUSTABLE ARRAYS (LOCAL)  (the adj arrays were moved to the driver routine)
      INTEGER I,J,IERROR,NPTUSED,IER
      DOUBLE PRECISION VAR,YSD,YMEAN
      DATA   IERROR /1/

C IF ANY X HAS A MISSING VALUES THEN SET THE CORRESPONDING Y to YMSG
C .   THIS ELIMINATES ANY X/Y MISSING VALUES FROM THE COMPUTATIONS.

      DO I=1,N
         YY(I) = Y(I)
        DO J=1,M
           IF (X(I,J).EQ.XMSG) THEN
               YY(I) = YMSG
               GO TO 10
           END IF
        END DO
   10    CONTINUE
      END DO

C RESID ARE CALCULATED USING THE RAW PARTIAL REGRESSION COEF

      CALL DZREGR2(IERROR,N,M,M2,YY,YMSG,X,C,RESID,COV,WK,A,AINV,S)

C CALCULATE THE CONSTANT TERM
C .   CON = YMEAN - c(1)*XMEAN_1 - c(2)*XMEAN_2 - ... -c(J)*XMEAN_J

      CALL DSTAT2(YY,N,YMSG,YMEAN,VAR,YSD,NPTUSED,IER)

      CON  = YMEAN
      DO J = 1,M
          CALL DSTAT2(X(1,J),N,XMSG,XMEAN(J),VAR,XSD(J),NPTUSED,IER)
          CON       = CON - C(J)*XMEAN(J)
          CNORM(J)  = C(J)*XSD(J)/YSD
      END DO

      RETURN
      END
C --------------------------------------------------------
      SUBROUTINE DZREGR2(IERROR,N,M,M2,T,TMSG,F,C,RESID,COV,WK,
     +                   A,AINV,S)
      IMPLICIT NONE
      INTEGER  IERROR,N,M,M2
      DOUBLE PRECISION T(N),F(N,M),C(M),RESID(N),COV(M,M),TMSG
      DOUBLE PRECISION WK(M,M2)
      DOUBLE PRECISION A(M,M),AINV(M,M),S(M)

C The modelled regession time series T(I) (I=1,2,...,N) is given by
C (see vector notation on the RIGHT):
C                           M
C                   T(I) = SUM C(J)*F(I,J)        <== T=FC         (1)
C                          J=1
C where C(J)=regression coefficient for J-th input surrogate time
C series F(I,J)
C
C Method: Least squares analysis applied to (1) yields the following
C linear matrix equation:
C                         AC = S                  <==> (F'F)C=F'T  (2)
C
C where C = model coefficient vector to be solved and S = data source
C vector.  It follows that
C                           N
C                   S(J) = SUM T(I)*F(I,J)        <== F'T          (3)
C                          I=1
C and                         N
C                   A(J,K) = SUM F(I,J)*F(I,K)    <== F'F          (4)
C                            I=1
C NOTE(s): The solution is (in vector notation):
C                               -1        -1
C                       C = (F'F)  F'T = A  S                      (5)
C
C The covariance matrix of the C coefficients is:
C                                     2    -1
C                          COV = sigma (F'F)                       (6)
C where
C                            2    1   N             2
C                       sigma  = --- SUM Residual(I)               (7)
C                                N-M I=1
C with Residual(I) being the original time series T(I) MINUS the time
C series T(I) modelled by (1) above.  Under the null hypothesis
C (all cross correlations between the coefficients are zero) that
C Var(T|F)=sigma**2 I, where I is the N X N unit matrix.
C
C Input Data:
C   IERROR = Error flag. If set to 1, standard error analysis is
C            performed for the coefficient vector C. Setting IERROR
C            to any other integer SKIPS this
C   N = Time series length
C   M = Number of surrogate series F applied in (1)
C   T(N) = measured time series being modelled

C   TMSG has replaced TMIN, TMAX for NCL reasons
C   TMIN,TMAX = Values of input series T that are less than TMIN
C          or greater than TMAX will NOT be included in the
C          regression (these are the flagging values)

C   F(N,M) = J-th (J=1,2,..,M) surrogate series, each of length N

C Output Data:
C   C(M) = solved coefficient vector
C   RESID(N) = Residual error time series (Original series T(I)
C              MINUS the modelled T(I) from (1) above)
C   COV(M,M) = Covariance matrix for coefficients C (SKIPPED if
C              IERROR is not equal to 1)
C EXAMPLE:
C      PARAMETER(IERROR=1,TMIN=-1.1,TMAX=1.1)
C      PARAMETER(N=20,M=7)
C      REAL T(N),F(N,M),WK(M,2*M),A(M,M),AINV(M,M),S(M),C(M),
C     & RESID(N),COV(M,M)
C
C      DO I=1,N
C        T(I)=COS(2.*I)
C        F(I,1)=1.0
C        F(I,2)=COS(2.05*I)
C        F(I,3)=SIN(0.4*I)
C        F(I,4)=COS(0.6*I)
C        F(I,5)=SIN(0.8*I)
C        F(I,6)=COS(0.3*I)
C        F(I,7)=SIN(0.9*I)
C      ENDDO
C      CALL ZREGR(IERROR,N,M,T,TMIN,TMAX,F,WK,A,AINV,S,C,RESID,COV)
C      WRITE(*,*)'I,T(I),T_model(I)'
C      DO I=1,N
C        WRITE(*,*) I,T(I),T(I)-RESID(I)
C      ENDDO
C
C      STOP
C      END
C
C Address questions/comments to:
C   Dr. Jerry Ziemke
C   NASA/Goddard Space Flight Center            PH: (301) 614-6034
C   Code 916                                   FAX: (301) 614-5903
C   Greenbelt, MD  20771
C   (Affil: UMBC GEST, Baltimore, MD)
C   e-mail: ziemke@jwocky.gsfc.nasa.gov
C
C Source is from:
C   http://code916.gsfc.nasa.gov/Data_services/cloud_slice/regress.html

C local ... some are adjustable arrays (had to move these to the driver routine)
      INTEGER NGOOD,I,J,K,L,IPRINT,ICHECK
      DOUBLE PRECISION U,SSUM,SIGSQR

      NGOOD = 0
      DO I = 1,N
C C C   IF ((T(I).GT.TMIN).AND.(T(I).LT.TMAX)) NGOOD=NGOOD+1
          IF (T(I).NE.TMSG) NGOOD = NGOOD + 1
      END DO

      DO J = 1,M
          S(J) = 0.D0
          DO I = 1,N
C C C     IF ((T(I).GT.TMIN).AND.(T(I).LT.TMAX)) THEN
              IF (T(I).NE.TMSG) THEN
C                                          ! <== S=F'T
                  S(J) = S(J) + T(I)*F(I,J)
              END IF
          END DO
      END DO

C     !Construct matrix A:
      DO K = 1,M
          DO J = 1,M
              A(J,K) = 0.D0
              DO I = 1,N
C C C       IF ((T(I).GT.TMIN).AND.(T(I).LT.TMAX)) THEN
                  IF (T(I).NE.TMSG) THEN
C                                         ! <== A=F'F
                      A(J,K) = A(J,K) + F(I,J)*F(I,K)
                  END IF
              END DO
          END DO
      END DO

C               ! ==> If 1, print out solution each CALL
      IPRINT = 0
C               ! ==> If 1, print out error analysis each CALL
      ICHECK = 0

C     !Solve for coef vector C:
      DO I = 1,M
          DO J = 1,M
              WK(I,J) = A(I,J)
          END DO
      END DO

      DO I = 1,M
          DO J = M + 1,2*M
              IF (M+I.EQ.J) THEN
                  WK(I,J) = 1.0D0
              ELSE
                  WK(I,J) = 0.0D0
              END IF
          END DO
      END DO

      DO K = 1,M
          DO I = 1,M
              IF (I.NE.K) THEN
                  IF (WK(K,K).EQ.0.0D0) THEN
                      L = 1
   30                 IF (WK(L,K).EQ.0.0D0) THEN
                          L = L + 1
                          GO TO 30
                      END IF
                      DO J = K,2*M
                          WK(K,J) = WK(K,J) + WK(L,J)
                      END DO
                  END IF
                  U = -WK(I,K)/WK(K,K)
                  DO J = K + 1,2*M
                      WK(I,J) = WK(I,J) + U*WK(K,J)
                  END DO
              END IF
          END DO
      END DO

      DO J = 1,M
          DO I = 1,M
              AINV(I,J) = WK(I,J+M)/WK(I,I)
          END DO
      END DO

      IF (IPRINT.EQ.1) THEN
          DO J = 1,M
              WRITE (*,FMT='(1X,A7,I3,A19)') 'Column ',J,
     +          ' of inverse matrix:'
              DO I = 1,M
                  WRITE (*,FMT=*) A(I,J)
              END DO
          END DO
      END IF

      IF (ICHECK.EQ.1) THEN
          WRITE (*,FMT=*)
     +      '-----------------------------------------------'
          WRITE (*,FMT=*) 'Simple error check by multiplying A by AINV:'
          WRITE (*,FMT=*)
     +      '(this should ideally yield the identity matrix)'
          DO J = 1,M
              WRITE (*,FMT='(1X,A7,I3,A27)') 'Column ',J,
     +          ' of product matrix A*AINV:'
              DO I = 1,M
                  SSUM = 0.0D0
                  DO K = 1,M
                      SSUM = SSUM + A(I,K)*AINV(K,J)
                  END DO
                  WRITE (*,FMT=*) SSUM
              END DO
          END DO
      END IF

C     !Coefficient vector solution:
      DO I = 1,M
          C(I) = 0.D0
          DO J = 1,M
              C(I) = C(I) + AINV(I,J)*S(J)
          END DO
      END DO

      IF (IERROR.EQ.1) THEN
          DO I = 1,N
C C C     IF ((T(I).GT.TMIN).AND.(T(I).LT.TMAX)) THEN
              IF (T(I).NE.TMSG) THEN
                  SSUM = 0.D0
                  DO J = 1,M
                      SSUM = SSUM + C(J)*F(I,J)
                  END DO
                  RESID(I) = T(I) - SSUM
              ELSE
                  RESID(I) = TMSG
              END IF
          END DO

          SSUM = 0.D0
          DO I = 1,N
C C C     IF ((T(I).GT.TMIN).AND.(T(I).LT.TMAX)) SSUM=SSUM+RESID(I)**2
              IF (T(I).NE.TMSG) SSUM = SSUM + RESID(I)**2
          END DO

          SIGSQR = SSUM/ (NGOOD-M)

          DO K = 1,M
              DO J = 1,M
                  COV(J,K) = SIGSQR*AINV(J,K)
              END DO
          END DO
      END IF

      RETURN
      END


PROGRAM ComputeLeftState_NuclearEOS

  USE KindModule, ONLY: &
    DP
  USE UnitsModule, ONLY: &
    Centimeter, &
    Kilometer, &
    Gram, &
    Second, &
    Erg, &
    Kelvin
  USE EquationOfStateModule_TABLE, ONLY: &
    InitializeEquationOfState_TABLE, &
    ComputeTemperatureFromPressure_TABLE, &
    ComputeThermodynamicStates_Primitive_TABLE, &
    ComputeAuxiliary_Fluid_TABLE, &
    ComputePressure_TABLE, &
    ComputeSpecificInternalEnergy_TABLE
  USE UtilitiesModule_NuclearEOS, ONLY: &
    ComputeFVEC, &
    ComputeFJAC

  IMPLICIT NONE

  LOGICAL                  :: Converged
  INTEGER                  :: Iter, INFO
  INTEGER,  DIMENSION(4)   :: IPIV
  REAL(DP), PARAMETER      :: Tol = 1.0d-10
  REAL(DP), DIMENSION(1)   :: D_L, V_L, T_L, Y_L
  REAL(DP), DIMENSION(1)   :: P_L, E_L, Ev_L, N_L, S_L, Gm_L, Cs_L
  REAL(DP), DIMENSION(1)   :: D_R, V_R, T_R, Y_R
  REAL(DP), DIMENSION(1)   :: P_R, E_R, Ev_R, N_R, S_R, Gm_R, Cs_R
  REAL(DP), DIMENSION(1)   :: Mach, V_Sh
  REAL(DP), DIMENSION(1)   :: dPdD, dPdT, dPdY
  REAL(DP), DIMENSION(1)   :: dEdD, dEdT, dEdY
  REAL(DP), DIMENSION(4)   :: FVEC, UVEC, dUVEC
  REAL(DP), DIMENSION(4,4) :: FJAC

  CALL InitializeEquationOfState_TABLE( 'EquationOfStateTable.h5' )

  ! --- Right State ---

  D_R = 1.0d12 * Gram / Centimeter**3
  V_R = 0.0d00 * Kilometer / Second
  P_R = 1.0d31 * Erg / Centimeter**3
  Y_R = 0.3_DP

  CALL ComputeTemperatureFromPressure_TABLE &
         ( D_R, P_R, Y_R, T_R )
  CALL ComputeThermodynamicStates_Primitive_TABLE &
         ( D_R, T_R, Y_R, Ev_R, E_R, N_R )
  CALL ComputeAuxiliary_Fluid_TABLE &
         ( D_R, Ev_R, N_R, P_R, T_R, Y_R, S_R, E_R, Gm_R, Cs_R )

  WRITE(*,*)
  WRITE(*,'(A4,A)') '', 'Right State:'
  WRITE(*,*)
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'D_R  =', D_R / ( Gram / Centimeter**3 )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'V_R  =', V_R / ( Kilometer / Second )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'T_R  =', T_R / Kelvin
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'Y_R  =', Y_R
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'E_R  =', E_R / ( Erg / Gram )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'P_R  =', P_R / ( Erg / Centimeter**3 )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'Gm_R =', Gm_R
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'Cs_R =', Cs_R / ( Kilometer / Second )

  Mach = 3.0_DP
  V_Sh = Mach * Cs_R

  WRITE(*,*)
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'Mach =', Mach
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'V_Sh =', V_Sh / ( Kilometer / Second )

  ! --- Initial Guess for Left State ---

  D_L = 4.0_DP * D_R
  V_L = 0.10_DP
  P_L = 10.0_DP * P_R
  Y_L = Y_R

  CALL ComputeTemperatureFromPressure_TABLE &
         ( D_L, P_L, Y_L, T_L )
  CALL ComputeThermodynamicStates_Primitive_TABLE &
         ( D_L, T_L, Y_L, Ev_L, E_L, N_L )
  CALL ComputeAuxiliary_Fluid_TABLE &
         ( D_L, Ev_L, N_L, P_L, T_L, Y_L, S_L, E_L, Gm_L, Cs_L )

  WRITE(*,*)
  WRITE(*,'(A4,A)') '', 'Left State (Initial Guess):'
  WRITE(*,*)
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'D_L  =', D_L / ( Gram / Centimeter**3 )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'V_L  =', V_L / ( Kilometer / Second )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'T_L  =', T_L / Kelvin
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'Y_L  =', Y_L
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'E_L  =', E_L / ( Erg / Gram )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'P_L  =', P_L / ( Erg / Centimeter**3 )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'Gm_L =', Gm_L
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'Cs_L =', Cs_L / ( Kilometer / Second )

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

    Iter = Iter + 1

    CALL ComputePressure_TABLE &
           ( D_L, T_L, Y_L, P_L, dPdD, dPdT, dPdY )

    CALL ComputeSpecificInternalEnergy_TABLE &
           ( D_L, T_L, Y_L, E_L, dEdD, dEdT, dEdY )

    CALL ComputeFVEC &
           ( D_R(1), V_R(1), P_R(1), E_R(1), Y_R(1), &
             D_L(1), V_L(1), P_L(1), E_L(1), Y_L(1), &
             V_Sh(1), FVEC )

    CALL ComputeFJAC &
           ( D_R(1), V_R(1), P_R(1), E_R(1), Y_R(1), &
             D_L(1), V_L(1), P_L(1), E_L(1), Y_L(1), &
             dPdD(1), dPdT(1), dPdY(1), &
             dEdD(1), dEdT(1), dEdY(1), &
             V_Sh(1), FJAC )

    UVEC  = [ D_L(1), V_L(1), T_L(1), Y_L(1) ]
    dUVEC = FVEC

    CALL DGESV( 4, 1, FJAC, 4, IPIV, dUVEC, 4, INFO )

    WRITE(*,*)
    WRITE(*,'(A6,A12,I2.2)') '', 'Iteration: ', Iter
    WRITE(*,'(A6,A12,4ES20.10E3)') '', '|FVEC| = ', &
      ABS( FVEC )
    WRITE(*,'(A6,A12,4ES20.10E3)') '', '|dU/U| = ', &
      ABS(  dUVEC / ( UVEC + TINY(1.0_DP) ) )
    WRITE(*,*)

    D_L(1) = UVEC(1) - dUVEC(1)
    V_L(1) = UVEC(2) - dUVEC(2)
    T_L(1) = UVEC(3) - dUVEC(3)
    Y_L(1) = UVEC(4) - dUVEC(4)

    IF( ALL( ABS(  dUVEC / ( UVEC + TINY(1.0_DP) ) ) < Tol ) ) &
      Converged = .TRUE.

  END DO

  CALL ComputePressure_TABLE &
         ( D_L, T_L, Y_L, P_L )
  CALL ComputeSpecificInternalEnergy_TABLE &
         ( D_L, T_L, Y_L, E_L )
  CALL ComputeThermodynamicStates_Primitive_TABLE &
         ( D_L, T_L, Y_L, Ev_L, E_L, N_L )
  CALL ComputeAuxiliary_Fluid_TABLE &
         ( D_L, Ev_L, N_L, P_L, T_L, Y_L, S_L, E_L, Gm_L, Cs_L )

  WRITE(*,*)
  WRITE(*,'(A4,A)') '', 'Left State:'
  WRITE(*,*)
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'D_L  =', D_L / ( Gram / Centimeter**3 )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'V_L  =', V_L / ( Kilometer / Second )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'T_L  =', T_L / Kelvin
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'Y_L  =', Y_L
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'E_L  =', E_L / ( Erg / Gram )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'P_L  =', P_L / ( Erg / Centimeter**3 )
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'Gm_L =', Gm_L
  WRITE(*,'(A4,A8,ES20.10E3)') '', 'Cs_L =', Cs_L / ( Kilometer / Second )
  WRITE(*,*)

END PROGRAM ComputeLeftState_NuclearEOS


SUBROUTINE DiffXuniform3D(var,varX,order,DiffStencilArray,Nx,Ny,Nz,alpha)
! By Allan P. Engsig-Karup.
!FIXME: this script has not been tested for bugs
USE Precision
USE DataTypes
IMPLICIT NONE
INTEGER :: Nx, Ny, Nz, rank, order, alpha, i,j,k
REAL(KIND=long), DIMENSION(2*alpha+1,2*alpha+1,2) :: DiffStencilArray
REAL(KIND=long), DIMENSION(Nz,Nx,Ny) :: var, varX
REAL(KIND=long), DIMENSION(2*alpha+1) :: Stencil
rank = 2*alpha+1
! one-sided
DO i = 1, alpha
	Stencil = DiffStencilArray(1:rank,i,order)
	DO j = 1, Ny
		DO k = 1, Nz
			varX(k,i,j) = DOT_PRODUCT(Stencil,var(k,1:rank,j))
		END DO
	END DO
END DO
! centered
Stencil = DiffStencilArray(1:rank,alpha+1,order)
DO i = alpha+1, Nx-alpha
	DO j = 1, Ny
		DO k = 1, Nz
			varX(k,i,j) = DOT_PRODUCT(Stencil,var(k,i-alpha:i+alpha,j))
		END DO
	END DO
END DO
! one-sided
DO i = Nx-alpha+1, Nx
	Stencil = DiffStencilArray(1:rank,2*alpha+1-(Nx-i),order)
	DO j = 1, Ny
		DO k = 1, Nz
			varX(k,i,j) = DOT_PRODUCT(Stencil,var(k,Nx+1-rank:Nx,j))
		END DO
	END DO
END DO

END SUBROUTINE DiffXuniform3D


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

! create synthetic observations evenly spaced on a sphere.
! this program creates observations without data - they have
! a location, type, error variance, a time. run the output file
! through create_fixed_network_seq if you want a time series of
! all these obs. run the output through perfect_model_obs to add data.
!
! alter as you wish to change obs types, density, etc.

program create_sphere_obs

use         types_mod, only : r8, missing_r8, pi, rad2deg
use      location_mod, only : VERTISPRESSURE, set_location
use     utilities_mod, only : initialize_utilities, finalize_utilities, &
                              find_namelist_in_file, check_namelist_read,         &
                              do_nml_file, do_nml_term, logfileunit, nmlfileunit
use  time_manager_mod, only : time_type, set_calendar_type, set_date, GREGORIAN, &
                              get_time
use  obs_sequence_mod, only : obs_sequence_type, obs_type, read_obs_seq, &
                              static_init_obs_sequence, init_obs, write_obs_seq, &
                              init_obs_sequence, get_num_obs, set_obs_def, &
                              set_copy_meta_data, set_qc_meta_data
use      obs_kind_mod, only : RADIOSONDE_U_WIND_COMPONENT, RADIOSONDE_V_WIND_COMPONENT, &
                              RADIOSONDE_TEMPERATURE
use      obs_def_mod, only : obs_def_type, set_obs_def_time, set_obs_def_type_of_obs, &
                             set_obs_def_error_variance, set_obs_def_location, &
                             get_obs_def_time, get_obs_def_location,           &
                             get_obs_def_type_of_obs, get_obs_def_error_variance,         &
                             set_obs_def_key
use obs_utilities_mod, only : add_obs_to_seq

! Input is in hectopascals, obs are in pascals
real(r8) :: obs_levels(15) = (/ 1000., 950., 900., 850., 800., 750., 700., 650., &
                                 600., 550., 500., 400., 300., 200., 150. /)

! Date information
integer :: year = 2008
integer :: month = 10
integer :: day = 1
integer :: hour = 0

! Number of roughly evenly distributed points in horizontal
integer :: number_of_locations, iunit, io
real(r8) :: x, y, z, lat, lon, inc, off, r, phi, dlon, dlat
integer :: num_obs, ob, lvl, nlvls

type(time_type) :: time_obs, prev_time

type(obs_sequence_type) :: seq
type(obs_type)          :: obs, prev_obs
type(obs_def_type)      :: obs_def
logical :: first_obs

namelist /create_sphere_obs_nml/ number_of_locations

! start of executable code

call initialize_utilities('create_sphere_obs')

call find_namelist_in_file("input.nml", "create_sphere_obs_nml", iunit)
read(iunit, nml = create_sphere_obs_nml, iostat = io)
call check_namelist_read(iunit, io, "create_sphere_obs_nml")

if (do_nml_file()) write(nmlfileunit, nml=create_sphere_obs_nml)
if (do_nml_term()) write(     *     , nml=create_sphere_obs_nml)

nlvls = size(obs_levels)

! Total number of observations at single time is levels*n*3
num_obs = nlvls * number_of_locations * 3

! create a new (empty) sequence
! we define only the location, type, time, and error here.
! run perfect_model_obs to fill in the obs values if needed
call init_obs_sequence(seq, 0, 0, num_obs)

call init_obs(obs, 0, 0)
call init_obs(prev_obs, 0, 0)

first_obs = .true.

call set_calendar_type(GREGORIAN)
time_obs = set_date(year, month, day, hour, 0, 0)
call set_obs_def_time(obs_def, time_obs)

inc = pi * (3.0_r8 - sqrt(5.0_r8))
off = 2.0_r8 / number_of_locations

do ob = 1, number_of_locations

   y = (ob-1) * off - 1 + (off / 2)
   r = sqrt(1 - y*y)
   phi = (ob-1) * inc

   x = cos(phi) * r
   z = sin(phi) * r

   ! Now convert to latitude and longitude, radians
   ! first, then degrees

   lon = atan2(y, x) + pi
   lat = asin(z)

   dlon = rad2deg * lon
   dlat = rad2deg * lat

   do lvl = 1, nlvls
      call set_obs_def_location(obs_def, set_location(dlon, dlat, obs_levels(lvl), VERTISPRESSURE))

      call set_obs_def_error_variance(obs_def, 1.0_r8)
      call set_obs_def_type_of_obs(obs_def, RADIOSONDE_TEMPERATURE)
      call set_obs_def(obs, obs_def)
      call add_obs_to_seq(seq, obs, time_obs, prev_obs, prev_time, first_obs)

      call set_obs_def_error_variance(obs_def, 4.0_r8)
      call set_obs_def_type_of_obs(obs_def, RADIOSONDE_U_WIND_COMPONENT)
      call set_obs_def(obs, obs_def)
      call add_obs_to_seq(seq, obs, time_obs, prev_obs, prev_time, first_obs)

      call set_obs_def_type_of_obs(obs_def, RADIOSONDE_V_WIND_COMPONENT)
      call set_obs_def(obs, obs_def)
      call add_obs_to_seq(seq, obs, time_obs, prev_obs, prev_time, first_obs)

   enddo

enddo

call write_obs_seq(seq, 'even_sphere.in')

call finalize_utilities('create_sphere_obs')

end program create_sphere_obs

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


*dk,rzv_lg
      subroutine rzv_lg(imsgin,xmsgin,cmsgin,msgtype,nwds,ierr)

C#######################################################################
C
C     PURPOSE -
C       this routine is used to ratio zone the region of space
C       spanned by the specified number of copies of the input vectors
C       (no attempt is made to insure that the 3 vectors are orthogonal)
C
C     INPUT ARGUMENTS -
C        imsgin()  - Integer array of command input tokens
C        xmsgin()  - Real array of command input tokens
C        cmsgin()  - Character array of command input tokens
C        msgtype() - Integer array of command input token types
C        nwds      - Number of command input tokens
C
C     OUTPUT ARGUMENTS -
C        ierr - Error Return Code (==0 ==> OK, <>0 ==> Error)
C
C     LOCAL VARIABLES -
C        * GEOMETRY LABEL
C           cgeom =  xyz ==> x , y , z cartesian geometry
C                 =  rtz ==> r , theta , z ==> cylindrical geometry
C                 =  rtp ==> r , theta , phi  ==> spherical geometry
C           NOTE: angles are in degrees
C        * NUMBER OF VECTOR COPIES IN THE 3 DIRECTIONS
C           nv(iv)=(n1,n2,n3)
C        * 3 DIRECTION VECTORS IN WHICH TO SPREAD POINTS
C           dv(j,iv)=((v11,v12,v13),(v21,v22,v23),(v31,v32,v33))^T
C             note: dv read in as (dv(j,iv),j=1,3),iv=1,3),
C                   so dv is the transpose of v in manual description
C        * STARTING POINT
C           v0(j)=(v01,v02,v03)
C        * RATIO ZONING VALUE FOR THE 3 VECTORS
C           (dv added modifed by this ratio after each addition)
C           rv(j,iv)=((r11,r12,r13),(r21,r22,r23),(r31,r32,r33))^T
C             note: rv read in as (rv(j,iv),j=1,3),iv=1,3),
C                   so rv is the transpose of r in manual description
C           ratio_method=[*component|vector]
C           ratio_flag=(f1,f2,f3)
C           (development note: could make ratio_flag a scalar or matrix...)
C                ratio_method(1:1)='c' (default):
C                    (scale COMPONENTS)
C                    The j-th component of the iv-th vector dv(j,iv)
C                    is reduced by rv(j,iv) at each step
C                    in the iv-th direction away from the initial point.
C                ratio_method(1:1)=['v'|'V'] and ratio_flag(j)=1 (default):
C                    (scale VECTORS)
C                    All components of the j-th vector dv(1:3,j)
C                    are reduced by rv(j,iv) at each step
C                    in the iv-th direction away from the initial point.
C                ratio_method(1:1)=['v'|'V'] and ratio_flag(j)=0:
C                    (scale VECTORS)
C                    All components of the j-th vector dv(1:3,j)
C                    are reduced by [1-(1-rv(j,iv))*2/(i_iv+1)] after the i_iv-th step
C                    in the iv-th direction away from the initial point,
C                    except that for i_iv=0 the vector is not reduced.
C                    Note that after the first step in the iv-th direction
C                    (i_iv=1), the j-th vector is reduced by rv(j,iv).
C                    Note also if rv(j,iv)=0.5, then the amount the j-th vector
C                    is reduced by after the i_iv-th step is [(i_iv)/(i_iv+1)]
C                    (so for a step in the j-th direction at i_iv=1 of 1,
C                          the step in the j-th direction at i_iv=2 is 1/2,
C                          the step in the j-th direction at i_iv=2 is 1/3,
C                          the step in the j-th direction at i_iv=4 is 1/4,
C                     etc, as the reductions after the current step
C                     act on the current step).
C
C     FORMAT -
C       RZV/[ |xyz|XYZ|rtz|RTZ|rtp|RTP]                 &
C                  /n1,n2,n3                            &
C                  /v11,v12,v13/v21,v22,v23/v31,v32,v33 &
C                  /v01,v02,v03                         &
C                  /r11,r12,r13/r21,r22,r23/r31,r32,r33
C                  /[ |*component|vector]
C                  /f1,f2,f3
C
C     DEFAULTS -
C       "rzv" without any arguments will add a point at the origin
C       cgeom is assumed 'xyz' if not present
C         allowed values are [xyz|XYZ|rtz|RTZ|rtp|RTP]
C         (anything else returns error)
C       n1 through v03 are assumed zero if not present
C       r11 through r33 are assumed 1 if not present
C
C     SAMPLES -
C       a) spiral of points
C             rzv/rtz/n1,0,0/.1,10.,1/ , , / , , / , , /1.1,1,.9/
C       b) sc (simple cubic) point distribution
C             rzv/xyz/n1,n2,n3/1,0,0/0,1,0/0,0,1/
C          same as
C             rz/xyz/n1+1,n2+1,n3+1/0,0,0/n1,n2,n3/1,1,1
C       c) bcc (body centered cubic) point distribution
C             rzv/xyz/n1,n2,n3/.5,.5,.5/.5,.5,-.5/.5,-.5,-.5/
C          compare the two command sequence (different bounding box)
C             rz/xyz/n1+1,n2+1,n3+1/0,0,0/n1,n2,n3/1,1,1
C             rz/xyz/n1  ,n2  ,n3  /0,0,0/n1,n2,n3/0,0,0
C       d) fcc (face centered cubic) point distribution
C             rzv/xyz/n1,n2,n3/.5,.5,0/0,.5,.5/.5,0,.5/
C          compare the four command sequence (different bounding box)
C             rz/xyz/n1+1,n2+1,n3+1/0,0,0/n1,n2,n3/1,1,1
C             rz/xyz/n1  ,n2  ,n3+1/0,0,0/n1,n2,n3/0,0,1
C             rz/xyz/n1  ,n2+1,n3  /0,0,0/n1,n2,n3/0,1,0
C             rz/xyz/n1+1,n2  ,n3  /0,0,0/n1,n2,n3/1,0,0
C       e) hexagonal lattice of points in x,y plane, repeated in z direction
C             rzv/xyz/n1,n2,n3/1,0,0/.5,0.866,0/0,0,1/
C       f) (two command sequence)
C          diamond point distribution
C             rzv/xyz/n1,n2,n3/.5,.5,0/0,.5,.5/.5,0,.5/
C             rzv/xyz/n1,n2,n3/.5,.5,0/0,.5,.5/.5,0,.5/.25,.25,.25
C          compare the eight command sequence (different bounding box)
C             rz/xyz/n1+1,n2+1,n3+1/0,0,0/n1,n2,n3/1,1,1
C             rz/xyz/n1  ,n2  ,n3+1/0,0,0/n1,n2,n3/0,0,1
C             rz/xyz/n1  ,n2+1,n3  /0,0,0/n1,n2,n3/0,1,0
C             rz/xyz/n1+1,n2  ,n3  /0,0,0/n1,n2,n3/1,0,0
C             rz/xyz/n1+1,n2+1,n3+1/0.25,0.25,0.25/n1+.25,n2+.25,n3+.25/1,1,1
C             rz/xyz/n1  ,n2  ,n3+1/0.25,0.25,0.25/n1+.25,n2+.25,n3+.25/0,0,1
C             rz/xyz/n1  ,n2+1,n3  /0.25,0.25,0.25/n1+.25,n2+.25,n3+.25/0,1,0
C             rz/xyz/n1+1,n2  ,n3  /0.25,0.25,0.25/n1+.25,n2+.25,n3+.25/1,0,0
C       g) (two command sequence)
C          hcp (hexagonal close pack) point distribution
C            rzv/xyz/n1,n2,n3/1,0,0/.5,0.866,0/0,0,1/
C            rzv/xyz/n1,n2,n3/1,0,0/.5,0.866,0/0,0,1/.5,0.289,.5/
C
C     CAVEATS -
C       * filter should be used afterwards to remove possibly duplicate points
C       * this can create some really bizzare point distributions
C       * mistyped input after "rzv/[cgeom]" always returns successful point addition,
C         but may be very different than desired
C
C     CHANGE HISTORY -
C
C        $Log: rzv_lg.f,v $
C        Revision 2.00  2007/11/09 20:04:02  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.6   22 Aug 2001 12:46:58   jtg
CPVCS    warning rather that error generated if ndimension_geom not 3
CPVCS
CPVCS       Rev 1.5   20 Aug 2001 22:00:12   jtg
CPVCS    fixed Log line
CPVCS    rev 1.4 was to add alternate method of ratio zoning
CPVCS    (see description of ratio_method and ratio_flag)
CPVCS
CPVCS       Rev 1.2   Thu Apr 06 14:19:52 2000   dcg
CPVCS    replace get_info_i and set_info_i calls
CPVCS
CPVCS       Rev 1.1   Fri Jun 25 09:35:08 1999   dcg
CPVCS    set itp, imt, icr for new nodes
CPVCS
CPVCS       Rev 1.0   Wed Jun 23 23:46:54 1999   jtg
CPVCS    Initial revision.
C
C#######################################################################

      implicit none

      include 'chydro.h'
      include 'consts.h'

      integer nwds, imsgin(nwds), msgtype(nwds)
      real*8 xmsgin(nwds)
      character*(*) cmsgin(nwds)
      character*132 logmess

      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      real*8 xic(*), yic(*), zic(*)
      pointer (ipitp1, itp1)
      pointer (ipimt1, imt1)
      pointer (ipicr1, icr1)
      integer itp1(*),imt1(*),icr1(*)

      character*32 cgeom,ratio_method
      character*32 cmo, isubname

      integer ierr,icscode,ipointi,ipointj,ilen,ityp
     &  ,icount,nnodes,nnodes_new,nnodes_save,icntin
     &  ,iv,j,iwd,i1,i2,i3,nv(3),ind,geom_dim,ratio_flag(3)

      real*8 rrr,theta,phi,degtorad,pi
     &  ,dv(3,3),rv(3,3),v0(3),v1(3),v2(3),v3(3)
     &  ,d1(3),d2(3),d3(3)

C#######################################################################
C get some initial info

      isubname='rzv_lg'

      ierr=0

      call cmo_get_name(cmo,ierr)
      if (ierr.ne.0) then
         ierr=1
         goto 9999
      endif

      call cmo_get_info('ipointi',cmo
     &                ,ipointi,ilen,ityp,ierr)
      if (ierr.ne.0) then
         ierr=2
         goto 9999
      endif
      call cmo_get_info('ipointj',cmo
     &                ,ipointj,ilen,ityp,ierr)
      if (ierr.ne.0) then
         ierr=3
         goto 9999
      endif

      call cmo_get_info('nnodes',cmo,nnodes,ilen,ityp,ierr)
      if (ierr.ne.0) then
         ierr=4
         goto 9999
      endif

      call cmo_get_info('ndimensions_geom',cmo,geom_dim
     &                  ,ilen,ityp,ierr)
      if (ierr.ne.0) then
         ierr=5
         goto 9999
      elseif (geom_dim.ne.3) then
         ! ierr=6
         ! goto 9999
         write(logmess,*) '  RZV WARNING - ndimensions_geom.ne.3'
         call writloga('default',0,logmess,0,icscode)
      endif

C ******************************************************************
C assign the constants

      pi=four*atan(one)
      degtorad=pi/180.0d0

C assign the local variables

C assign the geometry type
      if (msgtype(2).eq.1.or.msgtype(2).eq.2) then
         ! probably mistyped
         ierr=7
         goto 9999
      elseif (msgtype(2).ne.3) then
         cgeom='xyz'
      else
         cgeom=cmsgin(2)
         if (cgeom.eq.'RTZ') then
            cgeom='rtz'
         elseif (cgeom.eq.'RTP') then
            cgeom='rtp'
         elseif (cgeom.eq.'XYZ') then
            cgeom='xyz'
         elseif (cgeom.ne.'rtz'.and.cgeom.ne.'rtp'
     &       .and.cgeom.ne.'xyz') then
            ! probably mistyped
            ierr=8
            goto 9999
         endif
      endif

      icount=ipointj

C assign the number of copies for each vector
      do iv=1,3
         iwd=iv+2
         if (iwd.gt.nwds) then
            nv(iv)=0
         elseif (msgtype(iwd) .eq. 1) then
            nv(iv)=imsgin(iwd)
         elseif (msgtype(iwd) .eq. 2) then
            nv(iv)=xmsgin(iwd)
         else
            nv(iv)=0
         endif
      enddo

C assign the vectors
      do iv=1,3
         rrr=zero
         do j=1,3
            iwd=iv*3+j+2
            if (iwd.gt.nwds) then
               dv(j,iv)=zero
            elseif (msgtype(iwd) .eq. 1) then
               dv(j,iv)=imsgin(iwd)
            elseif (msgtype(iwd) .eq. 2) then
               dv(j,iv)=xmsgin(iwd)
            else
               dv(j,iv)=zero
            endif
            rrr=rrr+abs(dv(j,iv))
         enddo
         ! if null vector, don't add multiple copies
         if (rrr.eq.zero) nv(j)=0
         if (nv(iv).lt.0) then
            nv(iv)=-nv(iv)
            do j=1,3
               dv(j,iv)=-dv(j,iv)
            enddo
         endif
      enddo

C assign the starting point
      do j=1,3
         iwd=j+14
         if (iwd.gt.nwds) then
            v0(j)=zero
         elseif (msgtype(iwd) .eq. 1) then
            v0(j)=imsgin(iwd)
         elseif (msgtype(iwd) .eq. 2) then
            v0(j)=xmsgin(iwd)
         else
            v0(j)=zero
         endif
      enddo

C assign the step ratios
      do iv=1,3
         rrr=zero
         do j=1,3
            iwd=iv*3+j+14
            if (iwd.gt.nwds) then
               rv(j,iv)=one
            elseif (msgtype(iwd) .eq. 1) then
               rv(j,iv)=imsgin(iwd)
            elseif (msgtype(iwd) .eq. 2) then
               rv(j,iv)=xmsgin(iwd)
            else
               rv(j,iv)=one
            endif
            rrr=rrr+abs(rv(j,iv)*dv(j,iv))
         enddo
         ! if ratio*step is zero, don't add multiple copies
         if (rrr.eq.zero.and.nv(iv).gt.1) nv(iv)=1
      enddo

C assign the ratio method and set ratio_flag

      iwd=iwd+1
      if ( nwds.ge.iwd .and. msgtype(iwd).eq.3 ) then
         ratio_method=cmsgin(iwd)
         if (ratio_method(1:1).eq.'V') ratio_method='v'
      else
         ratio_method='c'
      endif

      do iv=1,3
         iwd=iwd+1
         if (iwd.gt.nwds) then
            ratio_flag(iv)=1
         elseif (msgtype(iwd) .eq. 1) then
            ratio_flag(iv)=imsgin(iwd)
         elseif (msgtype(iwd) .eq. 2) then
            ratio_flag(iv)=xmsgin(iwd)
         else
            ratio_flag(iv)=1
         endif
      enddo

C ******************************************************************
C increment storage

      icntin=icount
      nnodes_new=(1+nv(1))*(1+nv(2))*(1+nv(3))
      nnodes_save=ipointj
      nnodes=nnodes+nnodes_new
      call cmo_set_info('nnodes',cmo,nnodes,1,1,ierr)
      if (ierr.ne.0) then
        ierr=1
        goto 9998
      endif
      call cmo_newlen(cmo,ierr)
      if (ierr.ne.0) then
        ierr=2
        goto 9998
      endif
      call cmo_get_info('xic',cmo,ipxic,ilen,ityp,ierr)
      if (ierr.ne.0) then
        ierr=3
        goto 9998
      endif
      call cmo_get_info('yic',cmo,ipyic,ilen,ityp,ierr)
      if (ierr.ne.0) then
        ierr=4
        goto 9998
      endif
      call cmo_get_info('zic',cmo,ipzic,ilen,ityp,ierr)
      if (ierr.ne.0) then
        ierr=5
        goto 9998
      endif
      call cmo_get_info('itp1',cmo,ipitp1,ilen,ityp,ierr)
      if (ierr.ne.0) then
        ierr=5
        goto 9998
      endif
      call cmo_get_info('imt1',cmo,ipimt1,ilen,ityp,ierr)
      if (ierr.ne.0) then
        ierr=5
        goto 9998
      endif
      call cmo_get_info('icr',cmo,ipicr1,ilen,ityp,ierr)
      if (ierr.ne.0) then
        ierr=5
        goto 9998
      endif

C ******************************************************************
C TRANSFORM POINTS AND VELOCITIES TO LOCAL COORD. SYSTEM
C (copied from RZ)

      if (normflgc .gt. 0) call chglocl(1,icount,1)

C ******************************************************************
C assign the new node positions

      if (ratio_method(1:1).ne.'v') then
         ! (COMPONENTS scaled)
         ! jth component of iv-th vec reduced by rv(j,iv)
         ! at each step in iv-th direction

         do j=1,3
            v3(j)=zero
            d3(j)=dv(j,3)
         enddo
         do i3=0,nv(3)
            do j=1,3
               v2(j)=zero
               d2(j)=dv(j,2)
            enddo
            do i2=0,nv(2)
               do j=1,3
                  v1(j)=zero
                  d1(j)=dv(j,1)
               enddo
               do i1=0,nv(1)
                  icount=icount+1
                  xic(icount)=v0(1)+v1(1)+v2(1)+v3(1)
                  yic(icount)=v0(2)+v1(2)+v2(2)+v3(2)
                  zic(icount)=v0(3)+v1(3)+v2(3)+v3(3)
                  do j=1,3
                     v1(j)=v1(j)+d1(j)
                     d1(j)=d1(j)*rv(j,1)
                  enddo
               enddo
               do j=1,3
                  v2(j)=v2(j)+d2(j)
                  d2(j)=d2(j)*rv(j,2)
               enddo
            enddo
            do j=1,3
               v3(j)=v3(j)+d3(j)
               d3(j)=d3(j)*rv(j,3)
            enddo
         enddo

      else
         ! (VECTORS scaled)
         ! all components of jth vec reduced by rv(j,iv)
         ! at each step in iv-th direction

         do j=1,3
            d3(j)=one
            v3(j)=zero
         enddo
         do i3=0,nv(3)
            do j=1,3
               d2(j)=one
               v2(j)=zero
            enddo
            do i2=0,nv(2)
               do j=1,3
                  d1(j)=one
                  v1(j)=zero
               enddo
               do i1=0,nv(1)
                  icount=icount+1
                  xic(icount)=v0(1)+v1(1)*d1(1)*d2(1)*d3(1)
     &                             +v2(1)*d1(2)*d2(2)*d3(2)
     &                             +v3(1)*d1(3)*d2(3)*d3(3)
                  yic(icount)=v0(2)+v1(2)*d1(1)*d2(1)*d3(1)
     &                             +v2(2)*d1(2)*d2(2)*d3(2)
     &                             +v3(2)*d1(3)*d2(3)*d3(3)
                  zic(icount)=v0(3)+v1(3)*d1(1)*d2(1)*d3(1)
     &                             +v2(3)*d1(2)*d2(2)*d3(2)
     &                             +v3(3)*d1(3)*d2(3)*d3(3)
                  do j=1,3
                     if (i1.ne.0) then
                        if (ratio_flag(j).eq.0) then
                           d1(j)=d1(j)
     &                          *(1.d0-(1.d0-rv(j,1))*2.d0/dble(i1+1))
                        else
                           d1(j)=d1(j)*rv(j,1)
                        endif
                     endif
                     v1(j)=v1(j)+dv(j,1)
                  enddo
               enddo
               do j=1,3
                  if (i2.ne.0) then
                     if (ratio_flag(j).eq.0) then
                        d2(j)=d2(j)
     &                       *(1.d0-(1.d0-rv(j,2))*2.d0/dble(i2+1))
                     else
                        d2(j)=d2(j)*rv(j,2)
                     endif
                  endif
                  v2(j)=v2(j)+dv(j,2)
               enddo
            enddo
            do j=1,3
               if (i3.ne.0) then
                  if (ratio_flag(j).eq.0) then
                     d3(j)=d3(j)
     &                    *(1.d0-(1.d0-rv(j,3))*2.d0/dble(i3+1))
                  else
                     d3(j)=d3(j)*rv(j,3)
                  endif
               endif
               v3(j)=v3(j)+dv(j,3)
            enddo
         enddo

      endif

C ******************************************************************
C convert new coordinates to xyz if not already

      if (cgeom.eq.'rtz') then
         ! convert cylindrical to xyz
         do ind=icntin+1,icntin+nnodes_new
            rrr=xic(ind)
            theta=yic(ind)*degtorad
            xic(ind)=rrr*cos(theta)
            yic(ind)=rrr*sin(theta)
         enddo
      elseif (cgeom.eq.'rtp') then
         ! convert spherical to xyz
         do ind=icntin+1,icntin+nnodes_new
            rrr=xic(ind)
            theta=yic(ind)*degtorad
            phi=zic(ind)*degtorad
            xic(ind)=rrr*sin(theta)*cos(phi)
            yic(ind)=rrr*sin(theta)*sin(phi)
            zic(ind)=rrr*cos(theta)
         enddo
      endif

C ******************************************************************
C TRANSFORM POINTS AND VELOCITIES TO NORMAL COORD. SYSTEM
C (copied from RZ)

      if (normflgc .gt. 0) call chgnorm(1,icount,1)

C ******************************************************************
C PRINT OUT THE POINT NUMBERS GENERATED
C also come here if error after start (error resets to no nodes added)

 9998 write(logmess,6000) icntin+1,icount
 6000 format('  RZV GENERATED POINTS ',i6,' TO ',i6)
      call writloga('default',0,logmess,0,icscode)
c
c     Initialize ipt1, imt1 and icr1 to zero for new nodes.
C
      do ind=icntin+1,icount
         itp1(ind)=0
         imt1(ind)=0
         icr1(ind)=0
      enddo
      ipointi=nnodes_save+1
      ipointj=icount

      nnodes=ipointj
      call cmo_set_info('nnodes',cmo,nnodes,1,1,icscode)
      if (icscode.ne.0) ierr=ierr+10

      call cmo_set_info('ipointi',cmo
     &                ,ipointi,1,1,icscode)
      if (icscode.ne.0) ierr=ierr+10
      call cmo_set_info('ipointj',cmo
     &                ,ipointj,1,1,icscode)
      if (icscode.ne.0) ierr=ierr+10

C ******************************************************************
C NORMAL RETURN
c (and error return if error after start adding)

      if (icntin+1.gt.icount.and.ierr.eq.0) ierr=-1
      return

C ******************************************************************
C ERROR RETURN (at least for errors before anything done)

 9999 continue
      write(logmess,*) '  RZV ERROR - no points added'
      call writloga('default',0,logmess,0,icscode)

      return

C#######################################################################
      end

C#######################################################################


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Integer DO-loop tests - special cases:
*      (1) real addition used for step expression,
*      (2) do index variable used in init, upper, and step exprs,
*      (3) change values of init, upper, and step exprs
*          within the loop.

      program p

      integer rslts(11), expect(11)
c                         tests 1 - 4:
      data expect /   2, 7, 6, -4,
c                         tests 5 - 8:
     +                10, -6, -10, -8,
c                         tests 9 - 11:
     +                9, 1013, 11      /

C     tests 1, 3, 5, 2:   Real addition for step expression:

      data x, y / 5.3, -3.1 /
      do 10 i = 1, 6, x+y
          rslts(i) = 2 * i
10    continue
      rslts(2) = i

C     tests 4, 6, 8, 7:  DO index var used in DO expressions:

      data i6 /6/
      i = i6
      do 20 i = i-10, i-14, 2*i-14
          rslts(-i) = i
20    continue
      rslts(7) = i

C     tests 9, 11, 10:  Changing value of DO exprs within loop:

      j = 9
      k = 11
      m = 2
      do 30 i = j, k, m
          j = 100
          k = 1000
          m = 3
          rslts(i) = i
30    continue
      rslts(10) = i + k

C     check results:

      call check(rslts, expect, 11)
      end


c  programa poolmedia.for. Basado en submultiplos.for
c  Minimizar el costo considerando un intervalo de incerteza
c  en la probabilidad.
c  Actualizado en 30 enero 2021.
c
      implicit none

      integer numero, lin, col, i, j, k, ii, ini, kk, jopt, u,
     *  m1min, m1max, kkk, jj, diez
      integer mafil, macol, subdim, imenor, jmenor
      parameter (macol=20, subdim=100)

      parameter (mafil=10000)

c       parameter (mafil=8500000)

c  pc-computer supports up to mafil = 8500000

      integer solucion(macol), solopt(macol)
      integer matriz(mafil, macol), submu(subdim), numesub, filas
      integer columnas, noceros, numefail
      integer prede(mafil, macol)
      double precision costos(mafil, macol), cosopt, acum, porce
      double precision  p, q, cosmenor, cota, seed, probinf, parpul
      integer memfail, step, time, mejores, npobla, nparpul
      integer meritos(100, 20), pobla, ncang, cangf, infef
      double precision cosmeri(100), cant1, cant2, infe1, probanf
      double precision prind, cangru, totinfec, intes, sumtes, nbomax
      integer necepul, nparpu, nsteps, ntime, overf, nsumt,kmax1,nbon
      integer pseudo, filused, impre, nbonop
      integer longmer(100), ka

      character*200 file

      double precision pmin, pmax, eme(100), costal

      diez = 10
      filused = 0

      write(*, *)' Name of the output file:'
      read(*, *) file
      open (20,file=file)

      write(*, *)
     * ' Minimal and maximal prevalence:'

c prevalence: probability of individual infection:'

      read(*, *)pmin, pmax
      if(pmin.gt.pmax) then
         write(*, *)' Sorry: Minimal cannot be bigger than maximum. '
         write(20, 9000) 'Minimal cannot be bigger than maximum.'
         goto 7000
      endif
      if(pmin.eq.pmax) then
      diez = 0
      p = pmin
      q = 1.d0-p
      endif

      if(pmax.gt.0.3066387) then
         write(*, *)' It seems that you believe that the probability '
         write(*, *)' of infection may be bigger than 0.3066387.'
         write(*, *)' In that case, the  optimal solution is to test '
         write(*, *)' all the individuals immediately.'
         write(*, *)' The average cost is equal to 1 and we stop here.'

         write(20,9000)
     + ' It seems that you believe that the probability
     +  of infection may be bigger than 0.3066387.
     +  In that case, the  optimal solution is to test
     +  all the individuals immediately.
     +  The average cost is equal to 1 and we stop here.'

         goto 7000
      endif

      write(*, *)' How many best strategies do you want to report ?'
      write(*, *)' (No more than 100 please)'
      read(*, *) mejores
      if(mejores.gt.100) then
         write(*, *)' Sorry, we dont admit more than 100. We stop here.'
         write(20, 9000) 'Sorry, we dont admit more than 100.'
         goto 7000
      endif

c  Inicializar matriz de méritos
      do j = 1, 20
      do i = 1, mejores
      meritos(i, j) = 0
      end do
      end do
      do i = 1, mejores
      cosmeri(i) = 10.d0
      longmer(i) = 20
      end do

5      write(*, *)

c      cota = (dlog(3.d0)/3.d0)/dabs(dlog(q))

c      write(*, *)' Cota para m2 = ', cota

      nbomax =   1.464d0/dabs(dlog(1.d0-pmin)) + 1.d0

      nbon = nbomax

      if(nbon.gt.0) then
      write(*, *)' Bound for optimal m(1) = ', nbon
      nbonop = nbon
      else
      write(*, *)' Bound for optimal m(1) = ', nbomax
      nbonop = nbomax
      endif

c      nbomax =    0.366/dabs(dlog(1.d0-pmin)) + 1.d0
c      nbon = nbomax
c      if(nbon.gt.0) then
c      write(*, *)' Bound for optimal m(2) = ', nbon
c      else
c      write(*, *)' Bound for optimal m(2) = ', nbomax
c      endif

      cosopt = 1.d30
      memfail = 0

      m1min = 2

      write(*, *)

      write(*, *)' TYPE "Maximal allowed value for m(1) "'
      write(*, *)' "(first pool size)":'
      write(*, *)
      write(*, *)' You can set m1 greater than ', nbonop
      write(*, *)' if you are interested in suboptimal strategies.)'

      read(*, *) m1max

      write(*, *)' Maximum number of stages k+1:'
      read(*, *) kmax1

      write(*, *)' Type 1 if you want detailed printing'
      write(*, *)' Otherwise, type 0'
      read(*, *) impre

      do 4 numero = m1min, m1max

c888888888888888888888888888888888888888888888888888888888888888888888888888888888
c     Impresiones (*, *) a partir de aqui y hasta el lugar indicado tienen importancia
c     interna y son irrelevantes para el usuario
c888888888888888888888888888888888888888888888888888888888888888888888888888888888

      if(impre.eq.1) then
      write(*, *)
      write(*, *)
     *  ' m1 = ', numero, ' m1 minimo:', m1min,' m1 maximo:', m1max
      endif

      do j = 1, macol
      do i = 1, mafil
      matriz(i, j) = 0
      prede(i, j) = 0
      end do
      end do

      filas = 0
      columnas = 0

      matriz(1, 1) = numero

      acum = 0.d0
      if(pmin.eq.pmax) then
      acum = 1.d0/float(numero) + 1. - q**numero
      else

      do jj = 1, diez+1
      p = pmin + dfloat(jj-1)/dfloat(diez) *(pmax-pmin)
      q = 1.d0 -  p
      acum = acum + 1.d0/float(numero) + 1. - q**numero
      end do
      endif
      costos(1, 1) = acum/dfloat(diez+1)

      do 1 j = 2, macol

c   Verificar si la columna j-1 tenia no-ceros
      noceros=0
      do i = 1, mafil
      noceros = noceros + matriz(i, j-1)
      end do
      if(noceros.eq.0) go to 3

      ini = 0
      do 2 k = 1, mafil
      if(matriz(k, j-1).eq.0) go to 1
      if(matriz(k, j-1).eq.1) go to 2
c      write(*, *)' matriz(k, j-1)=', matriz(k, j-1)
      call submultiplos(matriz(k, j-1), submu, numesub)
c      write(*, *)' Submultiplos de ', matriz(k, j-1),' hay ', numesub
      do kk = 1, numesub
      filused = max0(filused, ini+kk)
      if(ini+kk.gt.mafil) then
      if(impre.eq.1) then
      write(*, *)' Aumentar numero de filas mafil para mas de ', ini+kk
      write(*, *)' Falto memoria cuando m1 = ', numero
      endif
      memfail = memfail + 1
      numefail = numero
      go to 4
      endif
      filas = max0(filas, ini+kk)
      matriz(ini + kk, j) = submu(kk)
      prede(ini+kk, j) = k

      acum = 0.d0
      if(pmin.eq.pmax) then
      acum =  q**matriz(k, j-1)-
     *  q**matriz(ini+kk,j) + (1.-q**matriz(k, j-1))/matriz(ini+kk, j)
      else

      do jj = 1, diez+1
      p = pmin + dfloat(jj-1)/dfloat(diez) *(pmax-pmin)
      q = 1.d0 -  p
      acum = acum +  q**matriz(k, j-1)-
     *  q**matriz(ini+kk,j) + (1.-q**matriz(k, j-1))/matriz(ini+kk, j)
      end do
      endif

      costos(ini+kk, j) = costos(k, j-1) + acum/dfloat(diez+1)

      end do
      ini = ini + numesub
2     continue

1     continue

3      columnas = j-1

       if(impre.eq.1) then
      write(*, *)' Numero de filas necesarias para la matriz:', filas
      write(*, *)' Numero columnas necesarias para la matriz:', columnas
      endif

c      write(*, *)' Matriz de divisores:'
c      write(*, *)'         Fila'
c      do i = 1, filas
c      write(*, *)i, (matriz(i, j),j=1,columnas)
c      end do

c     write(*, *)' Matriz de predecesores:'
c      write(*, *)'         Fila'
c      do i = 1, filas
c      write(*, *)i, (prede(i, j),j=1,columnas)
c      end do

c      write(*, *)' Matriz de costos:'
c      write(*, *)'         Fila'
c      do i = 1, filas
c      write(*, *)i, (costos(i, j),j=1,columnas)
c      end do

c      write(*, *)' Numero de filas necesarias para la matriz:', filas
c      write(*, *)' Numero columnas necesarias para la matriz:', columnas

c  Encontrar el menor costo
      cosmenor = costos(1, 1)
      imenor = 1
      jmenor = 1
      do j = 1, columnas
      if(j.le.kmax1-1) then
      do i = 1, filas
      if(matriz(i, j).ne.0.and.costos(i, j).lt.cosmenor) then
      cosmenor = costos(i, j)
      imenor = i
      jmenor = j

      endif
      end do
      endif
      end do

      if(impre.eq.1) then
      write(*, *)' Resultado para  m1 =', numero

      write(*, *)' Costo para este  m1:', cosmenor
      endif

      i = imenor
      do j = jmenor, 1, -1
      solucion(j) = matriz(i, j)
      i = prede(i, j)
      end do

      if(impre.eq.1) then
      write(*, *)' Solucion para  m1 =', numero

      do i = 1, jmenor
      write(*, *) solucion(i)
      end do
      do i = 1, jmenor-1
      write(*, *)' Cociente entre m(j) y m(j+1) = ',
     *  solucion(i)/solucion(i+1)
      end do
      write(*, *)
      endif

c  Poner la ultima solucion obtenida en su orden de mérito

      do i = 1, mejores
        if(cosmenor.lt.cosmeri(i)) then
          do ii = mejores, i+1, -1
            cosmeri(ii) = cosmeri(ii-1)
            longmer(ii) = longmer(ii-1)
            do j = 1, longmer(ii)
            meritos(ii, j) = meritos(ii-1, j)
            end do
          end do
            cosmeri(i) = cosmenor
            longmer(i) = jmenor
            do j = 1, jmenor
            meritos(i, j) = solucion(j)
            end do
         go to 6
        endif
      end do

6      if(cosmenor.lt.cosopt) then
      cosopt = cosmenor
      jopt = jmenor
      do i = 1, jopt
      solopt(i) = solucion(i)
      end do
      endif

      if(impre.eq.1) then
      write(*, *)' Costo minimo hasta ahora obtenido en m1 =', solopt(1)
      write(*, *)' con un costo igual a ', cosopt
      endif

4     continue
c   Este "4 continue" corresponde a "do 4 m1 = m1min, m1max"
c   O sea, aqui termina el proceso de optimizacion, arrojando la solucion solopt.

      if(impre.eq.1) then

      write(*, *)
      write(*, *)' Solucion final: '

      write(*, *)' Longitud de la estrategia:', jopt

      do i = 1, jopt
      write(*, *) solopt(i)
      end do

      endif

c8888888888888888888888888888888888888888888888888888888888888888888888888888888888
c    A partir de aqui las impresiones vuelven a tener importancia para el usuario
c8888888888888888888888888888888888888888888888888888888888888888888888888888888888

      write(*, *)
      write(*, *)' Number of rows used:', filused,' over a maximum of '
     *,  mafil

      porce  = dfloat(filused)/dfloat(mafil)
      porce = porce*100.
      write(*, 101) porce
101   format(1x, ' Percentage Used / Reserved Memory:', f8.2)

      if(memfail.gt.0) then

      write(*, *)
      write(*, *) ' *************************************************'
      write(*, *) ' *************************************************'
      write(*, *)

      write(*, *)' MEMORY WAS NOT SUFFICIENT IN ', memfail,' CASES'
      write(*, *)' PARAMETER MAFIL, WHICH WAS  ', mafil,' IN THIS RUN'
      write(*, *)' SHOULD BE INCREASED.'
      write(*, *)' YOU MAY CONTACT THE DEVELOPMENT TEAM.'

      write(*, *)
      write(*, *) ' *************************************************'
      write(*, *) ' *************************************************'
      write(*, *)

      endif

      write(*, *)

      write(*, *)' Optimal cost :', cosopt
      write(*, *)' Failures by lack of memory:', memfail
      write(*, *)' Solution:'
      write(*, *)(solopt(i),i=1,jopt)
      write(*, *)' Optimal cost:', cosopt
      write(*, *)' End of Optimization'

      p = (pmin+pmax)/2.d0

      ka = longmer(1)
      do j = 1, ka
      eme(j) = dfloat(meritos(1, j))
      end do
      eme(ka+1) = 1.d0

      write(*, *)
      call poolindeptes(ka, eme, p, costal)
      write(*, *)' Reshuffled-pool cost:', costal
      write(*, *)
      write(*, *)' (The reshuffled-pool cost is the cost obtained if '
      write(*, *)' the samples belonging to pools tested positive at '
      write(*, *)' any given stage are shuffled before being '
      write(*, *)' distributed in the pools of the next stage.)'

      write(*, *)

      write(*, *)'*************************************************'
C     To file
      write(20, 9001) cosopt,memfail,porce

      do i = 1, mejores
      write(*, *)'*************************************************'
      write(*, *)
      if(meritos(i, 1).eq.0) then
      write(*, *)' The number of feasible strategies is smaller than ',
     *   mejores
      exit
      endif

      if(i.eq.1) write(*, *) '          1 -st best strategy'
      if(i.eq.2) write(*, *) '          2 -nd best strategy'
      if(i.eq.3) write(*, *) '          3 -rd best strategy'

      if(i.gt.3)  write(*, *) i, '-th   best strategy '
      write(*, *)' Number of stages (k+1):', longmer(i)+1
      write(*, *)' Sequence  m1, m2, ..., mk, m_{k+1} :'
      write(*, *) (meritos(i,j),j=1,longmer(i)), '        1 '
      write(*, *)' Cost of this sequence = ', cosmeri(i)
      write(*, *)
C     To file
      write(20, 9002) longmer(i) + 1, cosmeri(i)
      write(20, 9003) (meritos(i, j), j=1,longmer(i))
      if ((i + 1 .gt. mejores) .or. (meritos(i + 1, 1) .eq. 0)) then
         write(20, 9005)
      else
         write(20, 9004)
      end if
      end do

      write(*, *)'*************************************************'

      write(*, *)' If you want pseudo-simulations considering '
      write(*, *)' availability of parallel pools, type 1'
      write(*, *)' otherwise, type 0'
      read(*, *) pseudo

      write(*, *)'*************************************************'

      if(pseudo.eq.0) then
C     To file
         write(20,9013)
         goto 7000
      endif

C     To file
      write(20,9014)

      write(*, *)' Total population:'
      read(*, *) pobla

      write(*, *)' Parallel pools available:'
      read(*, *) parpul

      write(*, *)
      p = (pmin+pmax)/2.d0

      write(*, *)' Population :', pobla,' p = ', p
      nparpul = parpul
      write(*, *)' Parallel pools available:',nparpul

      write(*, *)' Maximum pool-size allowed (m1):', m1max
      write(*, *)'*************************************************'
      write(*, *) ' Best ', mejores,' strategies :'

      write(*, *)' (For simulating stages we use p =', p,' .)'
      write(*, *)'  Pseudosimulations are not real simulations'
      write(*, *)'  of the testing process. Take then as a rough'
      write(*, *)'  indication of real possibilities.'

C     Write to file
      write(20, 9006)

      do i = 1, mejores
      write(*, *)'        ***************************************'
      write(*, *)
      if(meritos(i, 1).eq.0) then
      write(*, *)' The number of feasible strategies is smaller than ',
     *   mejores
      exit
      endif

      write(*, *)' Pseudo-simulation of '

      if(i.eq.1) write(*, *) '          1 -st best strategy'
      if(i.eq.2) write(*, *) '          2 -nd best strategy'
      if(i.eq.3) write(*, *) '          3 -rd best strategy'

      if(i.gt.3)  write(*, *) i, '-th   best strategy '
      write(*, *)' Number of stages (k+1):', longmer(i)+1
      write(*, *)' Sequence  m1, m2, ..., mk, m_{k+1} :'
      write(*, *) (meritos(i,j),j=1,longmer(i)), '        1 '
      write(*, *)' Cost of this sequence = ', cosmeri(i)
      write(*, *)

c**************************************************************************
c  totinfec es el numero total de infectados en la poblacion

c  prind es la probabilidad de que un individuo envuelto en los tests
c  de determinado nivel j esté infectado
c  En el nivel 1 es igual a p

      totinfec = p * pobla

c      write(*, *)' Total de infectados en la poblacion:', totinfec

      prind = p
      cangru = dfloat(pobla)/dfloat(meritos(i, 1))

c  cangru es el numero de grupos en el nivel 1

      sumtes = 0.d0
      ntime = 0

      do j = 1, longmer(i)

      write(*, *)
      write(*, *)' Stage ', j,' Size of each pool:', meritos(i,j)

      ncang = cangru
      if(cangru.gt.dfloat(ncang)) then
      necepul = cangru + 1.
      else
      necepul = cangru
      endif

      write(*, *)' Number of Pools that are necessary for this stage:',
     *   necepul
      nparpu = parpul
      overf = mod(necepul, nparpu)
      if(overf.eq.0) then
      nsteps = (necepul-overf)/parpul
      else
      nsteps = (necepul - overf)/parpul + 1
      endif
      write(*, *)' Time units necessary to process this stage:', nsteps
      if(nsteps.gt.1) then
      if(overf.ne.0) then
      if(overf.eq.1) then
      write(*, *)' including 1 time unit for an overflow equal to ',
     *  overf,' pool '
      else
      write(*, *)' including 1 time unit for an overflow equal to ',
     *  overf,' pools '
      endif
      endif
      endif
      ntime = ntime + nsteps
      write(*, *)' Accumulated time up to this stage:',
     *  ntime,' time units'

C     To file
      if (j .eq. 1) write(20,9007)
      write(20,9008) meritos(i, j),necepul,nsteps,overf,ntime
      write(20,9009)

      sumtes = sumtes + cangru

c  Calcular la probabilidad de que un grupo en el nivel j
c  (cuyo numero de miembros es meritos(i, j))
c  tenga algun individuo infectado
      probinf = 1.d0 - (1.d0-prind)**meritos(i, j)

c      write(*, *)' Probabilidad de que um grupo en  nivel ', j
c      write(*, *)' (con ', meritos(i, j),' individuos', ' )'
c      write(*, *)' esté infectado:', probinf

c  Calcular la cantidad de grupos infectados en el nivel j
      infe1 = probinf * cangru

      infef = floor(infe1)
      if(infe1-dfloat(infef).gt.0.5d0) infef = infef+1

      cangf = floor(cangru)
      if(cangru - dfloat(cangf).gt.0.5d0) cangf = cangf+1

c      write(*, *)'  Infected pools at stage ', j,' = ', infef

       write(*, *)'  Non-infected pools at stage ', j,' = ', cangf-infef

c  Calcular la cantidad de grupos en el nivel j+1
      cangru = infe1*meritos(i, j)

      if(j.lt.longmer(i)) then
      cangru = cangru/meritos(i, j+1)

c      write(*, *)' Cantidad de grupos en el nivel ', j+1,' = ', cangru
c  Calcular la cantidad de individuos envueltos en tests en el nivel j+1
      intes = cangru * meritos(i, j+1)

c      write(*, *)' Total individuos envueltos en tests en nivel',
c     *   j+1,' = ',intes
c  Calcular la probabilidad de que un individuo envuelto em tests en el
c  nivel j+1 este' infectado

      prind = totinfec/intes

c      prind = p
c      write(*, *)' Probabilidad de que un individuo envuelto en tests'
c      write(*, *)' en el nivel ', j+1,' esté infectado:', prind
      endif
      end do

      sumtes = sumtes + cangru
      write(*, *)
      write(*, *)' Stage ', longmer(i)+1 ,' Size of each pool: 1'

      ncang = cangru
      if(cangru.gt.dfloat(ncang)) then
      necepul = cangru + 1.
      else
      necepul = cangru
      endif

      write(*, *)' Pools that are necessary for this stage:', necepul
      nparpu = parpul
      overf = mod(necepul, nparpu)
      if(overf.eq.0) then
      nsteps = (necepul-overf)/parpul
      write(*, *)' Time units necessary to process this stage:', nsteps
      else
      nsteps = (necepul - overf)/parpul + 1
      write(*, *)' Time units necessary to process this stage:', nsteps
      if(nsteps.gt.1) then
      if(overf.eq.1) then
      write(*, *)' including 1 time unit for an overflow equal to = ',
     *   overf, ' pool'
      else
      write(*, *)' including 1 time unit for an overflow equal to = ',
     *   overf, ' pools'
      endif
      endif
      endif
      ntime = ntime + nsteps

c      write(*, *)' Number of (individual) tests at stage ',
c     *    longmer(i)+1,' :', cangru
c      sumtes = sumtes + cangru
c      step = cangru/parpul + 1.d0
c      time = time + step
c      write(*, *)' Time steps at stage ', j,' considering parallelism:'
c     *,   step, ' Accumulated:', time

      nsumt = sumtes+1.d0
      write(*, *)' Total number of tests:', nsumt
      write(*, *)' Total number of tests / population:', sumtes/pobla

      write(*, *)' Accumulated time of the whole strategy:',
     *   ntime,' time units'

      write(*, *)

C     To file
      write(20,9008) 1,necepul,nsteps,overf,ntime
      write(20,9010) nsumt,sumtes/pobla
      if (i .lt. mejores .and. meritos(i + 1, 1) .ne. 0) write(20,9011)

c*******************************************************************************
      end do

C     To file
      write(20,9012)
      write(20,9013)

 7000 close(20)
      stop

C     JSON error format
 9000 FORMAT('{',/,
     +     2X,'"foundSolution": false,',/,
     +     2X,'"message": "',A,'"',/,
     +     '}')
 9001 FORMAT('{',/,
     +     2X,'"foundSolution": true,',/,
     +     2X,'"optimalCost":',F17.10,',',/,
     +     2X,'"memFailures":',I5,',',/,
     +     2X,'"percMemUsed":',F8.2,',',/,
     +     2X,'"solutions": [')
 9002 FORMAT(4X,'{',/,
     +     6X,'"nStages":',I5,',',/,
     +     6X,'"cost":',F17.10,',',/,
     +     6X,'"sequence": [')
 9003 FORMAT(10(I5,','))
 9004 FORMAT('1]',/,4X,'},')
 9005 FORMAT('1]',/,
     +     4X,'}',/,
     +     2X,']')
 9014 FORMAT(2X,',')
 9006 FORMAT(2X,'"simulations": [')
 9007 FORMAT(4X,'{',/,6X,'"s": [')
 9008 FORMAT(8X,'[',4(I10,','),I10,']')
 9009 FORMAT(8X,',')
 9010 FORMAT(6X,'],',/,
     +     6X,'"totalNumTests":',I10,',',/,
     +     6X,'"testsPerInhab":',F17.10,/,
     +     4X,'}')
 9011 FORMAT(4X,',')
 9012 FORMAT(2X,']')
 9013 FORMAT('}')

      end

      subroutine submultiplos(numero, submu, numesub)
      implicit none
      integer numero
      integer submu(numero), numesub
      integer i, j, k

c      write(*, *)' Entrada a subrout submultiplos, numero:', numero

      if(numero.eq.1) then
      numesub = 0
      return
      endif

      i = dfloat(numero)/2.d0+0.8
      k = 0
      do j = i, 1, -1
      if(mod(numero, j).eq.0) then
      k = k+1
      submu(k) = j
      endif
      end do
      numesub = k
      return
      end

      subroutine rando(seed, x)

C     This is the random number generator of Schrage:
C
C     L. Schrage, A more portable Fortran random number generator, ACM
C     Transactions on Mathematical Software 5 (1979), 132-138.

      double precision seed, x

      double precision a,p,b15,b16,xhi,xalo,leftlo,fhi,k
      data a/16807.d0/,b15/32768.d0/,b16/65536.d0/,p/2147483647.d0/

      xhi= seed/b16
      xhi= xhi - dmod(xhi,1.d0)
      xalo= (seed-xhi*b16)*a
      leftlo= xalo/b16
      leftlo= leftlo - dmod(leftlo,1.d0)
      fhi= xhi*a + leftlo
      k= fhi/b15
      k= k - dmod(k,1.d0)
      seed= (((xalo-leftlo*b16)-p)+(fhi-k*b15)*b16)+k
      if (seed.lt.0) seed = seed + p
      x = seed*4.656612875d-10

      return

      end

      subroutine poolindeptes(k, m, prob, total)

      implicit none
      double precision m(100)
      double precision pob(0:100)
      double precision pools(100)
      double precision p(0:100)
      double precision q(0:100)
      double precision total, prob

      integer k, j

      p(0) = prob

      total = 0.d0
      pob(0) = 1.d0

      q(0) = 1.d0-p(0)

      j = 0

1     pools(j+1) = pob(j)/m(j+1)
      total = total + pools(j+1)
      if(j+1.eq.k+1) return

      pob(j+1)= pob(j)*(1.d0 - q(j)**m(j+1))
      p(j+1) = p(j)/(1.d0-q(j)**m(j+1))
      q(j+1) = 1.d0 - p(j+1)

      j = j+1
      go to 1

      end


      DOUBLE PRECISION FUNCTION APPROX_DELTA( APPROX, X, SIGMA )
*
      IMPLICIT NONE
      INCLUDE 'solver.f'
*
*     .. Scalar Arguments ..
      INTEGER            APPROX
      DOUBLE PRECISION   X, SIGMA
*     ..
*
*  Purpose
*  =======
*
*  APPROX_DELTA() computes an approximate value of the delta function.
*   returns the value of the Gaussian function
*
*  Arguments
*  =========
*
*  APPROX  (input) INTEGER
*          Indicate how the delta function is approximated.
*          See solver.f for details.
*
*  X       (input) DOUBLE PRECISION
*          Value of the variable x.
*
*  SIGMA   (input) DOUBLE PRECISION
*          Broadening factor in the approximation.
*          SIGMA > 0.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, NEG_HALF, INV_SQRT_TWOPI, INV_PI
      PARAMETER          ( ZERO = 0.0D+0, NEG_HALF = -0.5D+0,
     $                     INV_SQRT_TWOPI = 0.39894228040143268D+0,
     $                     INV_PI = 0.31830988618379067D+0 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          EXP, IAND
*     ..
*     .. Executable Statements ..
*
      IF ( IAND( APPROX, BSE_DELTA ) .EQ. BSE_GAUSSIAN ) THEN
*
*        Gaussian:
*           exp( -x**2/( 2*sigma**2 ) )/( sqrt( 2*pi )*sigma )
*
         APPROX_DELTA =
     $        INV_SQRT_TWOPI/SIGMA*EXP( NEG_HALF*( X/SIGMA )**2 )
      ELSE IF ( IAND( APPROX, BSE_DELTA ) .EQ. BSE_LORENTZIAN ) THEN
*
*        Lorentzian:
*           1/pi * sigma / ( x**2 + sigma**2 )
*
         APPROX_DELTA =
     $        INV_PI*SIGMA/( X**2 + SIGMA**2 )
      ELSE
*
*        Return zero for unspecified approximation.
*
         APPROX_DELTA = ZERO
      END IF
*
      RETURN
*
*     End of APPROX_DELTA().
*
      END


      function chg_par (val_cur, ielem, chg_typ, chg_val, absmin, absmax, num_db)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this function computes new paramter value based on
!!    user defined change

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    val_cur     |variable      |current parameter value
!!                               |the standard temperature (20 degrees C)
!!    chg_typ     |variable      |type of change (absval, abschg, pctchg)
!!    chg_val     |variable      |amount of change
!!    parm_num    |              |calibration parameter number
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    chg_par     |variable      |new parameter value
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      implicit none

      real, intent (in) :: val_cur                    !variable      |current parameter value
                                                      !              |the standard temperature (20 degrees C)
      real, intent (in) :: chg_val                    !variable      |amount of change
      character(len=16), intent (in) :: chg_typ       !variable      |type of change (absval, abschg, pctchg)
      integer, intent (in) :: num_db                  !crosswalk number of parameter, structure or land use to get database array number
      real :: chg_par                                 !variable      |new parameter value
      real :: absmin                                  !minimum range for variable
      real :: absmax                                  !maximum change for variable
      real :: amin1                                   !units         |description
      integer :: ielem                                !none          |counter

      select case (chg_typ)

      case ("absval")
        chg_par = chg_val

      case ("abschg")
        chg_par = val_cur + chg_val

      case ("pctchg")
        chg_par = (1. + chg_val / 100.) * val_cur

      case ("relchg")
        chg_par = (1. + chg_val) * val_cur

      end select

      chg_par = Max(chg_par, absmin)
      chg_par = amin1(chg_par, absmax)

      return
      end function chg_par


      subroutine gnrfft(ar,nlen,direct,norm)
c
c-------------------------------------------------------------------------------
c This is the routine that is called by SIOSEIS to perform the fft of a real time
c series. This is a glue routine that defines a common call interface between
c SIOSEIS and FFT routine that have been optimized for different machines.
c
c This version is the general version and uses the simple fft pair & scram
c to perform transform of a real time series.
c
c     integer nlen      The length of the input real time series. A power of two
      real    ar(nlen)
c                       The array containing the time series/DFT trace. In
c                       frequency domain the (real) Nyquist frequency component
c                       is expect to be packed at ar(2) after the zero frequency
c                       component at ar(1). All other frequency components are
c                       as expected i.e. real at ar(2i), imag at ar(2i+1)
      logical direct
c                       Direction of FFT.
c                       = TRUE  forward  FFT time -> frequency.
c                       = FALSE inverse FFT frequency -> time.
c                         sign convention is exp(+iwt) for forward transform
c                                            exp(-iwt) for inverse transform
      logical    norm
c                      = TRUE  normalize the output FFT by 1/nlen
c                      = FALSE no normalization.
c-------------------------------------------------------------------------------
c
c
      integer pow2
c
      np = pow2(nlen) - 1
      if(direct) then                                                   ! forward FFT
        call fftfwd(ar,np)                                              ! A +ve exponent
c        call fftinv(ar,np)
        call scram(ar,nlen/2,+1,.FALSE.)
      else
        call scram(ar,nlen/2,-1,.TRUE.)
        call fftinv(ar,np)
c        call fftfwd(ar,np)
      endif
      if (norm) then
        rlen = float(nlen/2)
        do 10 i = 1, nlen
  10    ar(i) = ar(i)/rlen
      endif
      return
      end
C
C
      subroutine scram(a,n,isgn,inv)
c---------------------------------------------------------------------------
c    This routine enables the DFT of a real time series of length 2n to
c be recoverd from the DFT of the sames series when it is treated as a complex
c time series of length n.
c
c    On the forward transform the elements real series of 2n are packed
c sequentially into the real & imaginary parts of the complex array. i.e.
c the even elements (starting at 0) are packed into the real parts & the
c odd elements into the imaginary parts. The FFT of this complex series
c is not the same as the FFT of the real series; the output must be
c processed further to recover the correct positive frequency values. This
c is the job of scram.
c
c   On inverse transform the positive frequency components must be repacked
c prior to being passed to a complex inverse FFT if the resulting output is
c be a real time series.
c
c   For the forward transform, this routine returns the Nyquist frequency
c component packed into the imaginary part of the zero frequency component.
c It expects the Nyquist frequency component packed here for the inverse
c transform.
c
      complex a(0:n-1)
c                  The array to be transformed
c     Integer n    The length of the complex arrray
      integer isgn
c                   The sign of the current transform
      logical inv
c                 = TRUE  this is an inverse transform. The frequency
c                         components are being packed prior to DFT
c                 = FALSE this is a forward transform. The positive
c                         frequency components are being upacked after
c                         a DFT.
c Modifications:
c     10/20/88 ( Added conjg to atem a(n-i)= )
c
c Last Modified
c     14/3/89 Changed to single precision for CRAY compatibility
c--------------------------------------------------------------------------
c
      parameter (pi = 3.1415926535)
      integer jsgn
      real    rexp, iexp
      real    rphas, iphas, rtem
      real    rtems, items
      complex atem, btem
      complex yi
c
      nby2 = n/2
      jsgn = sign(1,isgn)
      rtem = pi / float(n)
      rexp =  cos(rtem)
      iexp =  sin(jsgn*rtem)
      rphas = 1.0
      iphas = 0.0
      if (inv) then
        yi = cmplx(0.,-0.5)
      else
c      yi   = jsgn * cmplx(0., 0.5)
        yi   = cmplx(0., 0.5)
      endif
c
      do 10 i = 1, nby2
      rtem   = rexp * rphas - iexp * iphas
      iphas  = rexp * iphas + iexp * rphas
      atem   = 0.5 * (a(i) + conjg(a(n-i)))
      btem   = yi * cmplx(rtem, iphas) * ( a(i) - conjg( a(n-i) ) )
      a(i)   = atem - btem
      a(n-i) = atem + conjg(btem)
      a(n-i) = conjg(atem) + conjg(btem)
      rphas  = rtem
   10 continue
c
c.. Assume that the Nyquist frequency is packed/wanted in the imaginary
c    part of the zero frequency component
      rtems = real(a(0))
      items = aimag(a(0))
      a(0)  = cmplx(rtems + items, rtems - items)
      if (inv) a(0) = 0.5 * a(0)
      return
      end


      subroutine ahat(v1,v2,ah)
      dimension v1(3),v2(3),ah(6)
c
c     routine to compute the operator matrix defined
c     below eq. 3.6 on p.355 of hext(1963)
c
      ah(1)=v1(1)*v2(1)
      ah(2)=v1(2)*v2(2)
      ah(3)=v1(3)*v2(3)
      ah(4)=v1(2)*v2(3)+v1(3)*v2(2)
      ah(5)=v1(1)*v2(3)+v1(3)*v2(1)
      ah(6)=v1(1)*v2(2)+v1(2)*v2(1)
      return
      end