      PROGRAM CSSEX03
C
C  Do a comparison of CSSGRID with NATGRIDS for interpolation on
C  a sphere, using an analytic function.  This program produces
C  four plots:
C
C     1.)  Contour plot of the analytic function.
C     2.)  Contour plot of the interpolated function using NATGRIDS
C          with no periodic points.
C     3.)  Contour plot of the interpolated function using NATGRIDS
C          with periodic points added to the longitudes.
C     4.)  Contour plot of the interpolated function using CSSGRID.
C
C  External for Conpack calls.
C
      EXTERNAL DRAWCL
C
C  NUMORG - Number of points in the original dataset.
C  NMAX   - Number of points in the dataset with periodic points added.
C  NUMXOUT - Number of latitudes in the interpolated dataset.
C  NUMYOUT - Number of longitudes in the interpolated dataset.
C
      PARAMETER(NUMORG=750, NMAX = 1111, NUMXOUT = 71, NUMYOUT = 145,
     +          IDIM=2*NUMXOUT*NUMYOUT)
C
C  Conversion factors and constants.
C
      PARAMETER(D2R=0.017453293, R2D=57.29578)
      PARAMETER( PI=3.1415927, PIH= 1.5707963)
C
C  Specify GKS output data.
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1, IWKID=2)
C
C  Sizes of work arrays for plotting.
C
      PARAMETER (IRWRK=5200, IIWRK=11250, IAMASZ=20000)
      DIMENSION RWRK(IRWRK), IWRK(IIWRK), IAMA(IAMASZ)
C
C  Arrays for original data.
C
      REAL X(NMAX), Y(NMAX), FVAL(NMAX)
C
C  Arrays for output data.
C
      REAL RLAT(NMAX), RLON(NMAX)
      REAL XI(NUMXOUT), YI(NUMYOUT), ZDAT(NUMYOUT,NUMXOUT)
      REAL XR(NUMXOUT), YR(NUMYOUT)
      REAL FF(NUMXOUT,NUMYOUT), FFN(NUMXOUT,NUMYOUT)
      REAL FFS(NUMXOUT,NUMYOUT)
C
C  Work arrays for CSSGRID interpolation.
C
      PARAMETER (NIWKC=27*NMAX, NRWKC=13*NMAX)
      INTEGER IWKC(NIWKC)
      DOUBLE PRECISION RWKC(NRWKC)
C
C  Array to store the values of the analytic function.
C
      REAL FF_ANA(NUMXOUT,NUMYOUT)
C
C  Generate a random dataset on the unit sphere.
C
      N = NUMORG
      CALL GENSS(N,RLAT,RLON)
C
C  Generate functional values at the input nodes.
C
      CALL CRGENI(5,10,-200.,500.)
      DO 10 I=1,N
        FVAL(I) = CRGENPNT(RLAT(I),RLON(I))
   10 CONTINUE
C
C  Convert to radians for NATGRIDS calls.
C
      DO 2 K = 1,N
        X(K) = D2R*RLAT(K)
        Y(K) = D2R*RLON(K)
    2 CONTINUE
C
C  Create the output grid.
C
      DO 20 I=1,NUMXOUT
        XI(I) = -87.5+(I-1)*2.5
        XR(I) = D2R*XI(I)
   20 CONTINUE
      DO 30 J=1,NUMYOUT
        YI(J) = -180.+(J-1)*2.5
        YR(J) = D2R*YI(J)
   30 CONTINUE
C
C  Store analytic function values.
C
      DO 600 I=1,NUMXOUT
        DO 610 J=1,NUMYOUT
          FF_ANA(I,J) = CRGENPNT(XI(I),YI(J))
  610   CONTINUE
  600 CONTINUE
C
C  Use Natgrid to interpolate, without using any periodic points
C  in longitude.  There are significant problems along the zero
C  longitude.
C
      CALL NATGRIDS(N,X,Y,FVAL,NUMXOUT,NUMYOUT,XR,YR,FFN,IER)
C
C  Add in periodic points in longitude for the Natgrid call.
C
      IJ = NUMORG
      DO 299 I=1,N
        IF(Y(I).GT.PIH .AND. Y(I).LE.PI) THEN
          IJ = IJ+1
          X(IJ) = X(I)
          Y(IJ) = Y(I)-2.0*PI
          FVAL(IJ) = FVAL(I)
        ELSE IF(Y(I).GE.-PI .AND. Y(I).LT.-PIH) THEN
          IJ = IJ+1
          X(IJ) = X(I)
          Y(IJ) = Y(I)+2.0*PI
          FVAL(IJ) = FVAL(I)
        ENDIF
  299 CONTINUE
C
C  Use Natgrid to interpolate, using the additional periodic points.
C
      N = NMAX
      CALL NATGRIDS(N,X,Y,FVAL,NUMXOUT,NUMYOUT,XR,YR,FF,IER)
C
C  Use Cssgrid to interpolate on the sphere.
C
      N = NUMORG
      CALL CSSGRID(N,RLAT,RLON,FVAL,NUMXOUT,NUMYOUT,XI,YI,FFS,
     +             IWKC,RWKC,IER)
C
C  Plot the results.
C
C
C  Open GKS.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C  Color table.
C
      CALL GSCR(IWKID,0,1.,1.,1.)
      CALL GSCR(IWKID,1,0.,0.,0.)
      CALL GSCR(IWKID,2,1.,0.,0.)
      CALL GSCR(IWKID,3,0.,0.,1.)
C
C  Draw a contour map of the analytic function.
C
      CALL GSPLCI(3)
      CALL GSTXCI(3)
      CALL GSTXFP(-13,2)
C
C  Use a satellite projection and view the globe looking at the
C  north pole.
C
      CALL MAPSTR ('SA - SATELLITE HEIGHT',4.)
      CALL MAPROJ ('SV - SATELLITE-VIEW',90.,0.,0.)
      CALL MAPSET ('MA - MAXIMAL AREA',0.,0.,0.,0.)
      CALL MAPPOS (0.06, 0.94, 0.02, 0.90)
C
      CALL MAPSTI ('PE - PERIMETER',0)
      CALL MAPSTI ('GR - GRID',0)
      CALL MAPSTC ('OU - OUTLINE DATASET','PS')
      CALL MAPSTI ('DO - DOTTING OF OUTLINES',1)
      CALL MAPDRW
C
      CALL CPSETI ('SET - DO SET-CALL FLAG',0)
      CALL CPSETR ('DPS - LINE LABEL SIZE',0.02)
      CALL CPSETR ('T2D - TENSION ON THE 2D SPLINES',1.)
      CALL CPSETI ('CLS - CONTOUR LEVEL SELECTION FLAG',16)
      CALL CPSETC ('HLT - TURN OFF HIGH/LOW LABELS',' ')
      CALL CPSETC ('ILT - TURN OFF INFORMATIONAL LABEL',' ')
C
      CALL CPSETR ('XC1 - X COORDINATE AT I = 1',-180.)
      CALL CPSETR ('XCM - X COORDINATE AT I = M', 180.)
      CALL CPSETR ('YC1 - Y COORDINATE AT J = 1', -90.)
      CALL CPSETR ('YCN - Y COORDINATE AT J = N',  90.)
      CALL CPSETI ('MAP - MAPPING FLAG',1)
      CALL CPSETR ('ORV - OUT-OF-RANGE VALUE',1.E12)
C
C  Reverse the indices, since Conpack wants longitude as
C  the first dimension.
C
      DO 450 I=1,NUMXOUT
        DO 460 J=1,NUMYOUT
          ZDAT(J,I) = FF_ANA(I,J)
  460     CONTINUE
  450 CONTINUE
C
      CALL CPRECT (ZDAT,NUMYOUT,NUMYOUT,NUMXOUT,RWRK,IRWRK,IWRK,IIWRK)
      CALL ARINAM (IAMA,IAMASZ)
      CALL CPLBAM (ZDAT,RWRK,IWRK,IAMA)
      CALL CPCLDM (ZDAT,RWRK,IWRK,IAMA,DRAWCL)
C
C  Plot the picture title.
C
      CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
      CALL PLCHHQ(0.50,0.95,':F26:Analytic function',
     +            0.025,0.,0.)
C
      CALL FRAME
C
C  Plot the results from Natgrid without periodic points.
C
      CALL MAPPOS (0.06, 0.94, 0.02, 0.90)
      CALL MAPDRW
C
C  Reverse the indices, since Conpack wants longitude as
C  the first dimension.
C
      DO 451 I=1,NUMXOUT
        DO 461 J=1,NUMYOUT
          ZDAT(J,I) = FFN(I,J)
  461     CONTINUE
  451 CONTINUE
C
      CALL CPRECT (ZDAT,NUMYOUT,NUMYOUT,NUMXOUT,RWRK,IRWRK,IWRK,IIWRK)
      CALL ARINAM (IAMA,IAMASZ)
      CALL CPLBAM (ZDAT,RWRK,IWRK,IAMA)
      CALL CPCLDM (ZDAT,RWRK,IWRK,IAMA,DRAWCL)
C
C  Plot the picture title.
C
      CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
      CALL PLCHHQ(0.50,0.95,':F26:Natgrid without periodic points',
     +            0.025,0.,0.)
C
      CALL FRAME
C
C  Plot the results from Natgrid with periodic points.
C
      CALL MAPPOS (0.06, 0.94, 0.02, 0.90)
      CALL MAPDRW
C
C  Reverse the indices, since Conpack wants longitude as
C  the first dimension.
C
      DO 452 I=1,NUMXOUT
        DO 462 J=1,NUMYOUT
          ZDAT(J,I) = FF(I,J)
  462     CONTINUE
  452 CONTINUE
C
      CALL CPRECT (ZDAT,NUMYOUT,NUMYOUT,NUMXOUT,RWRK,IRWRK,IWRK,IIWRK)
      CALL ARINAM (IAMA,IAMASZ)
      CALL CPLBAM (ZDAT,RWRK,IWRK,IAMA)
      CALL CPCLDM (ZDAT,RWRK,IWRK,IAMA,DRAWCL)
C
C  Plot the picture title.
C
      CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
      CALL PLCHHQ(0.50,0.95,':F26:Natgrid with periodic points',
     +            0.025,0.,0.)
C
      CALL FRAME
C
C  Plot the results from Cssgrid.
C
      CALL MAPPOS (0.06, 0.94, 0.02, 0.90)
      CALL MAPDRW
C
C  Reverse the indices, since Conpack wants longitude as
C  the first dimension.
C
      DO 453 I=1,NUMXOUT
        DO 463 J=1,NUMYOUT
          ZDAT(J,I) = FFS(I,J)
  463     CONTINUE
  453 CONTINUE
C
      CALL CPRECT (ZDAT,NUMYOUT,NUMYOUT,NUMXOUT,RWRK,IRWRK,IWRK,IIWRK)
      CALL ARINAM (IAMA,IAMASZ)
      CALL CPLBAM (ZDAT,RWRK,IWRK,IAMA)
      CALL CPCLDM (ZDAT,RWRK,IWRK,IAMA,DRAWCL)
C
C  Plot the picture title.
C
      CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
      CALL PLCHHQ(0.50,0.95,':F26:Cssgrid',0.025,0.,0.)
C
      CALL FRAME
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
C
      STOP
C
      END
      SUBROUTINE GENSS(N,RLAT,RLON)
C
C  Generate random positions on a sphere in latitudes and longitudes
C  (latitude values between -90. and 90. and longitude values
C  between -180. and 180.
C
C  First select a random longitude, and then select a random value
C  on the Z axis -R to R (-1 to 1 in the case of the unit sphere).
C  From the random Z value, calculate the latitude.
C
      DIMENSION RLAT(N),RLON(N)
      PARAMETER (R=1., R2D=57.29578)
C
      DO 10 I=1,N
        RLON(I) = -180.+360.*CRRAND()
        RZ = R*(2.*CRRAND()-1.)
        RLAT(I) = R2D*ASIN(RZ)
   10 CONTINUE
C
      RETURN
      END
      REAL FUNCTION CRRAND()
C
C  Portable random number generator.
C
      PARAMETER (MPLIER=16807,MODLUS=2147483647,MOBYMP=127773,
     +           MOMDMP=2836)
C
      INTEGER HVLUE, LVLUE, TESTV, NEXTN
      SAVE    NEXTN
      DATA JSEED,IFRST/9,0/
C
      IF (IFRST .EQ. 0) THEN
        NEXTN = JSEED
        IFRST = 1
      ENDIF
C
      HVLUE = NEXTN / MOBYMP
      LVLUE = MOD(NEXTN, MOBYMP)
      TESTV = MPLIER*LVLUE - MOMDMP*HVLUE
      IF (TESTV .GT. 0) THEN
        NEXTN = TESTV
      ELSE
        NEXTN = TESTV + MODLUS
      ENDIF
      CRRAND = REAL(NEXTN)/REAL(MODLUS)
C
      RETURN
      END
      SUBROUTINE DRAWCL (XCS,YCS,NCS,IAI,IAG,NAI)
      DIMENSION XCS(*),YCS(*),IAI(*),IAG(*)
C
      IDR=1
      DO 101 I=1,NAI
        IF (IAI(I) .LT. 0) IDR = 0
  101 CONTINUE
      IF (IDR .NE. 0) CALL CURVED (XCS,YCS,NCS)
C
      RETURN
      END
      SUBROUTINE CRGENI (MLOW,MHGH,DLOW,DHGH)
C
C  The routines CRGENI and CSGENPT are used to generate test
C  data on the globe.  The data generated will have approximately
C  "MLOW" lows and "MHGH" highs within each of the twenty areas
C  defined by an inscribed icosahedron, a minimum value of
C  approximately "DLOW" and a maximum value of approximately
C  "DHGH".  CRGENI is called to initialize the process and the
C  function CRGENPNT returns a computed functional value at the
C  point (RLAT,RLON).
C
C  The function used is a sum of exponentials.
C
C  This code was originally written by David Kennison at NCAR.
C
      COMMON /CSSBD1/R0,R1,R2
      COMMON /CSSCMN/ CMUL(160),NCNT,NLOW,NHGH,RLOW,RHGH,RMIN,RMAX,
     +                XCOC(160),YCOC(160),ZCOC(160)
C
C Define the vertices and faces of an icosahedron.
C
      DIMENSION XCVI(12),YCVI(12),ZCVI(12),IVOF(3,20)
      DIMENSION R0(220),R1(220),R2(220)
      DATA XCVI / .9510565162952 , -.9510565162951 ,  .4253254041760 ,
     +           -.4253254041760 ,  .4253254041760 , -.4253254041760 ,
     +            .4253254041760 , -.4253254041760 ,  .4253254041760 ,
     +           -.4253254041760 ,  .4253254041760 , -.4253254041760 /
      DATA YCVI / .0000000000000 ,  .0000000000000 ,  .8506508083520 ,
     +           -.8506508083520 ,  .2628655560596 , -.2628655560596 ,
     +           -.6881909602356 ,  .6881909602356 , -.6881909602356 ,
     +            .6881909602356 ,  .2628655560595 , -.2628655560596 /
      DATA ZCVI / .0000000000000 ,  .0000000000000 ,  .0000000000000 ,
     +            .0000000000000 ,  .8090169943749 , -.8090169943749 ,
     +            .5000000000000 , -.5000000000000 , -.5000000000000 ,
     +            .5000000000000 , -.8090169943749 ,  .8090169943749 /
      DATA IVOF / 1, 3, 5  , 1, 5, 7  , 1, 7, 9  ,
     +            1, 9,11  , 1, 3,11  , 3, 8,11  ,
     +            3, 8,10  , 3, 5,10  , 5,10,12  ,
     +            5, 7,12  , 7, 4,12  , 4, 7, 9  ,
     +            4, 6, 9  , 6, 9,11  , 6, 8,11  ,
     +            6, 2, 8  , 2, 4, 6  , 2, 4,12  ,
     +            2,10,12  , 2, 8,10  /
      DATA DTOR / .017453292519943 /
      DATA RTOD / 57.2957795130823 /
C
      NLOW = MAX(0,MIN(4,MLOW))
      NHGH = MAX(0,MIN(4,MHGH))
      IF (NLOW+NHGH.GE.12 .AND. NLOW.GE.6) NLOW = NLOW-1
      IF (NLOW+NHGH.GE.12 .AND. NHGH.GE.6) NHGH = NHGH-1
      NCNT = 20*(NLOW+NHGH)
C
C  Compute the center positions for the exponentials which are
C  summed to create the function.
C
      DO 100 K=1,NCNT
        INDX = MOD(K-1,20)+1
        ILOH = (K+19)/20
        WGT1 = R0(K)
        WGT2 = R1(K)
        WGT3 = R2(K)
        WSUM = WGT1+WGT2+WGT3
        WGT1 = WGT1/WSUM
        WGT2 = WGT2/WSUM
        WGT3 = WGT3/WSUM
        XTMP = WGT1*XCVI(IVOF(1,INDX))+
     +         WGT2*XCVI(IVOF(2,INDX))+
     +         WGT3*XCVI(IVOF(3,INDX))
        YTMP = WGT1*YCVI(IVOF(1,INDX))+
     +         WGT2*YCVI(IVOF(2,INDX))+
     +         WGT3*YCVI(IVOF(3,INDX))
        ZTMP = WGT1*ZCVI(IVOF(1,INDX))+
     +         WGT2*ZCVI(IVOF(2,INDX))+
     +         WGT3*ZCVI(IVOF(3,INDX))
        TEMP = SQRT(XTMP*XTMP+YTMP*YTMP+ZTMP*ZTMP)
        XCOC(K) = XTMP/TEMP
        YCOC(K) = YTMP/TEMP
        ZCOC(K) = ZTMP/TEMP
        IF (.NOT.(ILOH .LE. NLOW)) GO TO 110
        CMUL(K) = -1.
        GO TO 120
  110   CONTINUE
        CMUL(K) = +1.
  120   CONTINUE
  100 CONTINUE
C
      RLOW = DLOW
      RHGH = DHGH
      RMIN = +1.E36
      RMAX = -1.E36
      DO 130 I=-180,175,5
        RLON = DTOR*REAL(I)
        CRLN = COS(RLON)
        SRLN = SIN(RLON)
        DO 140 J=-85,85,5
          RLAT = DTOR*REAL(J)
          CRLT = COS(RLAT)
          SRLT = SIN(RLAT)
          RVAL = 0.5*(RLOW+RHGH)
          DO 150 K=1,NCNT
            DIST = SQRT((CRLT*CRLN-XCOC(K))**2
     +                 +(CRLT*SRLN-YCOC(K))**2
     +                 +(SRLT     -ZCOC(K))**2)
            ANGL = 2.*RTOD*ASIN(DIST/2.)
            DIST = ANGL/18.
            RVAL = RVAL+.5*(RHGH-RLOW)*CMUL(K)*EXP(-DIST*DIST)
     +                              *(2.-SIN(6.283*DIST)/2.)
  150     CONTINUE
          RMIN = MIN(RMIN,RVAL)
          RMAX = MAX(RMAX,RVAL)
  140   CONTINUE
  130 CONTINUE
        RETURN
      END
      FUNCTION CRGENPNT (RLAT,RLON)
      COMMON /CSSCMN/ CMUL(160),NCNT,NLOW,NHGH,RLOW,RHGH,RMIN,RMAX,
     +                XCOC(160),YCOC(160),ZCOC(160)
      DATA DTOR / .017453292519943 /
      DATA RTOD / 57.2957795130823 /
      DATA PI   /  3.1415926/
C
      TLAT = DTOR*RLAT
      TLON = DTOR*RLON
      CRLT=COS(TLAT)
      CRLN=COS(TLON)
      SRLT=SIN(TLAT)
      SRLN=SIN(TLON)
      RVAL=.5*(RLOW+RHGH)
      DO 100 K=1,NCNT
        DIST = SQRT((CRLT*CRLN-XCOC(K))**2
     +             +(CRLT*SRLN-YCOC(K))**2
     +             +(SRLT     -ZCOC(K))**2)
        ANGL = 2.*RTOD*ASIN(DIST/2.)
        DIST = ANGL/18.
        RVAL = RVAL+.5*(RHGH-RLOW)*CMUL(K)*EXP(-DIST*DIST)
     +                          *(2.-SIN(6.283*DIST)/2.)
  100 CONTINUE
      CRGENPNT = RLOW+(RHGH-RLOW)*(RVAL-RMIN)/(RMAX-RMIN)
C
      RETURN
      END
      BLOCKDATA CSSCCBD
C
      COMMON /CSSBD1/R0,R1,R2
      DIMENSION R0(220),R1(220),R2(220)
C
      DATA R0/
     + .968,.067,.478,.910,.352,.933,.654,.021,.512,.202,.940,.204,
     + .379,.793,.288,.267,.357,.128,.703,.737,.803,.915,.511,.762,
     + .456,.471,.300,.613,.073,.498,.220,.041,.565,.698,.951,.917,
     + .630,.605,.938,.143,.807,.878,.347,.186,.671,.635,.453,.028,
     + .763,.157,.765,.566,.072,.276,.328,.528,.747,.627,.141,.821,
     + .126,.360,.862,.690,.058,.813,.607,.689,.419,.545,.831,.226,
     + .422,.178,.412,.093,.813,.866,.121,.576,.023,.886,.142,.095,
     + .162,.470,.623,.910,.097,.764,.730,.223,.124,.593,.913,.183,
     + .406,.520,.871,.825,.065,.703,.051,.488,.881,.463,.581,.694,
     + .329,.702,.270,.352,.587,.412,.446,.750,.882,.069,.659,.979,
     + .833,.390,.202,.957,.982,.115,.140,.389,.635,.011,.213,.701,
     + .714,.264,.188,.594,.727,.769,.288,.056,.471,.558,.408,.058,
     + .970,.854,.808,.851,.923,.467,.830,.756,.857,.032,.713,.839,
     + .147,.852,.228,.783,.863,.441,.483,.577,.705,.671,.171,.432,
     + .441,.459,.489,.911,.017,.897,.969,.987,.751,.777,.838,.674,
     + .244,.669,.430,.101,.701,.143,.940,.848,.995,.168,.631,.858,
     + .608,.114,.435,.313,.785,.606,.746,.226,.065,.234,.137,.082,
     + .131,.106,.069,.882,.883,.907,.556,.127,.576,.986,.228,.276,
     + .128,.168,.124,.123/
C
      DATA R1/
     + .023,.003,.880,.088,.237,.017,.170,.368,.123,.239,.250,.006,
     + .146,.806,.134,.722,.791,.361,.998,.920,.529,.122,.043,.864,
     + .877,.025,.808,.746,.442,.065,.400,.464,.068,.280,.552,.305,
     + .297,.722,.673,.420,.961,.923,.426,.107,.729,.560,.829,.520,
     + .921,.827,.440,.451,.950,.483,.315,.827,.508,.123,.573,.949,
     + .188,.973,.414,.256,.253,.966,.561,.550,.689,.234,.970,.650,
     + .157,.396,.757,.885,.956,.587,.405,.877,.414,.845,.328,.363,
     + .328,.643,.190,.836,.766,.763,.786,.954,.737,.199,.211,.990,
     + .165,.772,.540,.854,.006,.510,.504,.163,.906,.261,.048,.862,
     + .848,.454,.740,.262,.299,.068,.625,.627,.711,.815,.464,.477,
     + .579,.249,.431,.315,.449,.642,.305,.614,.414,.845,.468,.420,
     + .355,.972,.582,.261,.234,.631,.123,.082,.084,.863,.343,.383,
     + .930,.968,.011,.641,.784,.474,.118,.362,.723,.549,.678,.172,
     + .191,.983,.786,.605,.828,.254,.024,.183,.226,.607,.444,.460,
     + .237,.567,.541,.322,.430,.885,.705,.361,.853,.715,.002,.637,
     + .190,.119,.999,.913,.668,.677,.085,.859,.660,.871,.464,.488,
     + .124,.489,.671,.350,.095,.115,.810,.333,.683,.351,.654,.113,
     + .236,.359,.473,.089,.075,.475,.726,.264,.594,.725,.177,.263,
     + .402,.262,.122,.062/
C
      DATA R2/
     + .337,.417,.503,.020,.769,.158,.133,.005,.517,.606,.094,.591,
     + .081,.820,.855,.675,.545,.033,.938,.947,.294,.060,.009,.427,
     + .646,.559,.684,.721,.781,.291,.892,.118,.708,.395,.138,.476,
     + .552,.270,.481,.069,.877,.575,.660,.957,.395,.516,.633,.939,
     + .548,.570,.886,.843,.630,.895,.270,.276,.455,.953,.998,.236,
     + .244,.889,.354,.952,.284,.492,.428,.837,.762,.909,.906,.639,
     + .484,.566,.596,.879,.082,.229,.818,.631,.799,.704,.473,.430,
     + .600,.743,.706,.055,.696,.704,.291,.940,.593,.645,.892,.877,
     + .137,.321,.714,.899,.230,.620,.538,.714,.186,.134,.593,.268,
     + .364,.411,.899,.163,.116,.372,.593,.716,.115,.298,.770,.812,
     + .002,.061,.752,.595,.706,.645,.472,.843,.965,.186,.742,.195,
     + .806,.280,.910,.992,.414,.503,.260,.778,.915,.159,.941,.030,
     + .531,.533,.746,.647,.832,.516,.458,.834,.577,.211,.429,.283,
     + .855,.901,.126,.821,.087,.868,.016,.893,.148,.926,.885,.562,
     + .429,.145,.340,.343,.304,.281,.374,.835,.814,.120,.482,.646,
     + .636,.940,.479,.213,.151,.908,.497,.006,.809,.623,.827,.895,
     + .490,.843,.788,.638,.769,.673,.200,.198,.817,.540,.541,.121,
     + .821,.915,.956,.635,.035,.438,.280,.671,.377,.760,.884,.528,
     + .668,.381,.534,.477/
C
      END


subroutine shafga(xieta,ndime,ltopo,ngaus,shaga)

!-----------------------------------------------------------------------
!
! This routine evaluates shape functions associated to gauss points
! for linear and quadratic isoparametric elements
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)  :: ndime,ltopo,ngaus
  real(rp),    intent(in)  :: xieta(ndime)
  real(rp),    intent(out) :: shaga(ngaus)

  select case(ndime)
  case(1)
     call shaga1(xieta(1),ngaus,shaga)
  case(2)
     call shaga2(xieta(1),xieta(ndime),ltopo,ngaus,shaga)
  case(3)
     call shaga3(xieta(1),xieta(2),xieta(ndime),ltopo,ngaus,shaga)
  end select

end subroutine shafga


*=======================================================================
*
* WCSLIB 4.24 - an implementation of the FITS WCS standard.
* Copyright (C) 1995-2014, Mark Calabretta
*
* This file is part of WCSLIB.
*
* WCSLIB is free software: you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* WCSLIB is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with WCSLIB.  If not, see http://www.gnu.org/licenses.
*
* Direct correspondence concerning WCSLIB to mark@calabretta.id.au
*
* Author: Mark Calabretta, Australia Telescope National Facility, CSIRO.
* http://www.atnf.csiro.au/people/Mark.Calabretta
* $Id: tprj1.f,v 4.24 2014/09/18 15:25:02 mcalabre Exp $
*=======================================================================

      PROGRAM TPRJ1
*-----------------------------------------------------------------------
*
* TPRJ1 tests forward and reverse spherical projections for closure.
*
*-----------------------------------------------------------------------
      INCLUDE 'prj.inc'

      INTEGER   J, K, NFAIL, PROJEX, STATUS
      DOUBLE PRECISION PV(0:29)

      DOUBLE PRECISION PI
      PARAMETER (PI = 3.141592653589793238462643D0)

      DOUBLE PRECISION TOL
      PARAMETER (TOL = 1D-9)
*-----------------------------------------------------------------------
      WRITE (*, 10)
 10   FORMAT ('Testing closure of WCSLIB spherical projection ',
     :        'routines (tprj1.f)',/,
     :        '-----------------------------------------------',
     :        '------------------')

      WRITE (*, '(/,A)') 'List of prj status return values:'
      DO 40 STATUS = 1, 4
        DO 30 K = 80, 1, -1
          IF (PRJ_ERRMSG(STATUS)(K:K).NE.' ') THEN
            WRITE(*, 20) STATUS, PRJ_ERRMSG(STATUS)(:K)
 20         FORMAT(I4,': ',A,'.')
            GO TO 40
          END IF
 30     CONTINUE
 40   CONTINUE
      WRITE(*, '()')

      DO 50 J = 0, 29
        PV(J) = 0D0
 50   CONTINUE

      NFAIL = 0

*     AZP: zenithal/azimuthal perspective.
      PV(1) = 0.5D0
      PV(2) =  30D0
      NFAIL = NFAIL + PROJEX ('AZP', PV, 90,   5, TOL)

*     SZP: slant zenithal perspective.
      PV(1) = 0.5D0
      PV(2) = 210D0
      PV(3) =  60D0
      NFAIL = NFAIL + PROJEX ('SZP', PV, 90, -90, TOL)

*     TAN: gnomonic.
      NFAIL = NFAIL + PROJEX ('TAN', PV, 90,   5, TOL)

*     STG: stereographic.
      NFAIL = NFAIL + PROJEX ('STG', PV, 90, -85, TOL)

*     SIN: orthographic/synthesis.
      PV(1) = -0.3D0
      PV(2) =  0.5D0
      NFAIL = NFAIL + PROJEX ('SIN', PV, 90,  45, TOL)

*     ARC: zenithal/azimuthal equidistant.
      NFAIL = NFAIL + PROJEX ('ARC', PV, 90, -90, TOL)

*     ZPN: zenithal/azimuthal polynomial.
      PV(0) =  0.00000D0
      PV(1) =  0.95000D0
      PV(2) = -0.02500D0
      PV(3) = -0.15833D0
      PV(4) =  0.00208D0
      PV(5) =  0.00792D0
      PV(6) = -0.00007D0
      PV(7) = -0.00019D0
      PV(8) =  0.00000D0
      PV(9) =  0.00000D0
      NFAIL = NFAIL + PROJEX ('ZPN', PV, 90,  10, TOL)

*     ZEA: zenithal/azimuthal equal area.
      NFAIL = NFAIL + PROJEX ('ZEA', PV, 90, -85, TOL)

*     AIR: Airy's zenithal projection.
      PV(1) = 45D0
      NFAIL = NFAIL + PROJEX ('AIR', PV, 90, -85, TOL)

*     CYP: cylindrical perspective.
      PV(1) = 3.0D0
      PV(2) = 0.8D0
      NFAIL = NFAIL + PROJEX ('CYP', PV, 90, -90, TOL)

*     CEA: cylindrical equal area.
      PV(1) = 0.75D0
      NFAIL = NFAIL + PROJEX ('CEA', PV, 90, -90, TOL)

*     CAR: plate carree.
      NFAIL = NFAIL + PROJEX ('CAR', PV, 90, -90, TOL)

*     MER: Mercator's.
      NFAIL = NFAIL + PROJEX ('MER', PV, 85, -85, TOL)

*     SFL: Sanson-Flamsteed.
      NFAIL = NFAIL + PROJEX ('SFL', PV, 90, -90, TOL)

*     PAR: parabolic.
      NFAIL = NFAIL + PROJEX ('PAR', PV, 90, -90, TOL)

*     MOL: Mollweide's projection.
      NFAIL = NFAIL + PROJEX ('MOL', PV, 90, -90, TOL)

*     AIT: Hammer-Aitoff.
      NFAIL = NFAIL + PROJEX ('AIT', PV, 90, -90, TOL)

*     COP: conic perspective.
      PV(1) =  60D0
      PV(2) =  15D0
      NFAIL = NFAIL + PROJEX ('COP', PV, 90, -25, TOL)

*     COE: conic equal area.
      PV(1) =  60D0
      PV(2) = -15D0
      NFAIL = NFAIL + PROJEX ('COE', PV, 90, -90, TOL)

*     COD: conic equidistant.
      PV(1) = -60D0
      PV(2) =  15D0
      NFAIL = NFAIL + PROJEX ('COD', PV, 90, -90, TOL)

*     COO: conic orthomorphic.
      PV(1) = -60D0
      PV(2) = -15D0
      NFAIL = NFAIL + PROJEX ('COO', PV, 85, -90, TOL)

*     BON: Bonne's projection.
      PV(1) = 30D0
      NFAIL = NFAIL + PROJEX ('BON', PV, 90, -90, TOL)

*     PCO: polyconic.
      NFAIL = NFAIL + PROJEX ('PCO', PV, 90, -90, TOL)

*     TSC: tangential spherical cube.
      NFAIL = NFAIL + PROJEX ('TSC', PV, 90, -90, TOL)

*     CSC: COBE quadrilateralized spherical cube.
      NFAIL = NFAIL + PROJEX ('CSC', PV, 90, -90, 4D-2)

*     QSC: quadrilateralized spherical cube.
      NFAIL = NFAIL + PROJEX ('QSC', PV, 90, -90, TOL)

*     HPX: HEALPix projection.
      PV(1) = 4D0
      PV(2) = 3D0
      NFAIL = NFAIL + PROJEX ('HPX', PV, 90, -90, TOL)

*     XPH: HEALPix polar, aka "butterfly" projection.
      NFAIL = NFAIL + PROJEX ('XPH', PV, 90, -90, TOL)

      IF (NFAIL.NE.0) THEN
        WRITE (*, 60) NFAIL
 60     FORMAT (/,'FAIL:',I5,' closure residuals exceed reporting ',
     :    'tolerance.')
      ELSE
        WRITE (*, 70)
 70     FORMAT (/,'PASS: All closure residuals are within reporting ',
     :    'tolerance.')
      END IF

      END

*-----------------------------------------------------------------------
      INTEGER FUNCTION PROJEX (PCODE, PV, NORTH, SOUTH, TOL)
*-----------------------------------------------------------------------
*   PROJEX exercises the spherical projection routines.
*
*   Given:
*      PCODE    C*3      Projection code.
*      PV       D(0:29)  Projection parameters.
*      NORTH    I        Northern cutoff latitude, degrees.
*      SOUTH    I        Southern cutoff latitude, degrees.
*      TOL      D        Reporting tolerance, degrees.
*-----------------------------------------------------------------------
      INTEGER   I, J, LAT, LNG, NFAIL, NORTH, SOUTH, STAT1(361),
     :          STAT2(361), STATR(25,25), STATUS
      DOUBLE PRECISION DLAT, DLATMX, DLNG, DLNGMX, DR, DRMAX, DX, DY,
     :          LAT1, LAT2(361), LATR(25,25), LNG1(361), LNG2(361),
     :          LNGR(25,25), PV(0:29), R, TOL, X(361), X1(25),
     :          X2(25,25), Y(361), Y1(25), Y2(25,25)
      CHARACTER PCODE*3

*     On some systems, such as Sun Sparc, the struct MUST be aligned
*     on a double precision boundary, done here using an equivalence.
*     Failure to do this may result in mysterious "bus errors".
      INCLUDE 'prj.inc'
      INTEGER   PRJ(PRJLEN)
      DOUBLE PRECISION DUMMY
      EQUIVALENCE (PRJ,DUMMY)

      DOUBLE PRECISION D2R, PI
      PARAMETER (PI = 3.141592653589793238462643D0)
      PARAMETER (D2R = PI/180D0)
*-----------------------------------------------------------------------
      STATUS = PRJINI(PRJ)

      DO 10 J = 0, 29
        STATUS = PRJPUT (PRJ, PRJ_PV, PV(J), J)
 10   CONTINUE

      STATUS = PRJPUT (PRJ, PRJ_CODE, PCODE, 0)

*     Uncomment the next line to test alternative initializations of
*     projection parameters.
*     STATUS = PRJPUT (PRJ, PRJ_R0, 180D0/PI, 0)

      WRITE (*, 20) PCODE, NORTH, SOUTH, TOL
 20   FORMAT ('Testing ',A3,'; latitudes',I3,' to',I4,
     :        ', reporting tolerance',1PG8.1,' deg.')

      NFAIL  = 0
      DLNGMX = 0D0
      DLATMX = 0D0

      DO 90 LAT = NORTH, SOUTH, -1
        LAT1 = DBLE(LAT)

        J = 1
        DO 30 LNG = -180, 180
          LNG1(J) = DBLE(LNG)
          J = J + 1
 30     CONTINUE

        STATUS = PRJS2X (PRJ, 361, 1, 1, 1, LNG1, LAT1, X, Y, STAT1)
        IF (STATUS.EQ.1) THEN
          WRITE (*, 40) PCODE, STATUS
 40       FORMAT (3X,A3,'(S2X) ERROR',I2)
          GO TO 90
        END IF

        STATUS = PRJX2S (PRJ, 361, 0, 1, 1, X, Y, LNG2, LAT2, STAT2)
        IF (STATUS.EQ.1) THEN
          WRITE (*, 50) PCODE, STATUS
 50       FORMAT (3X,A3,'(X2S) ERROR',I2)
          GO TO 90
        END IF

        LNG = -180
        DO 80 J = 1, 361
          IF (STAT1(J).NE.0) GO TO 80

          IF (STAT2(J).NE.0) THEN
            NFAIL = NFAIL + 1
            WRITE (*, 60) PCODE, LNG1(J), LAT1, X(J), Y(J), LNG2(J),
     :                    LAT2(J), STAT2(J)
 60         FORMAT (3X,A3,'(X2S): lng1 =',F20.15,'  lat1 =',F20.15,/,
     :              '                x =',F20.15,'     y =',F20.15,/,
     :              '             lng2 =',F20.15,'  lat2 =',F20.15,
     :              '  ERROR',I3)
            GO TO 80
          END IF

          DLNG = ABS(LNG2(J) - LNG1(J))
          IF (DLNG.GT.180D0) DLNG = ABS(DLNG-360D0)
          IF (ABS(LAT).NE.90 .AND. DLNG.GT.DLNGMX) DLNGMX = DLNG
          DLAT = ABS(LAT2(J) - LAT1)
          IF (DLAT.GT.DLATMX) DLATMX = DLAT

          IF (DLAT.GT.TOL) THEN
            NFAIL = NFAIL + 1
            WRITE (*, 70) PCODE, LNG1(J), LAT1, X(J), Y(J), LNG2(J),
     :                    LAT2(J)
 70         FORMAT (8X,A3,': lng1 =',F20.15,'  lat1 =',F20.15,/,
     :              8X,'        x =',F20.15,'     y =',F20.15,/,
     :              8X,'     lng2 =',F20.15,'  lat2 =',F20.15)
          ELSE IF (ABS(LAT).NE.90) THEN
            IF (DLNG.GT.TOL) THEN
              NFAIL = NFAIL + 1
              WRITE (*, 70) PCODE, LNG1(J), LAT1, X(J), Y(J),
     :                      LNG2(J), LAT2(J)
             END IF
          END IF
 80     CONTINUE
 90   CONTINUE

      WRITE (*, 100) DLNGMX, DLATMX
 100  FORMAT (13X,'Maximum residual (sky): lng',1P,E8.1,'   lat',E8.1)

*     Test closure at points close to the reference point.
      R = 1D0
      X1(13) = 0D0
      Y1(13) = 0D0
      DO 110 I = 1, 12
        X1(I) = -R
        Y1(I) = -R
        X1(26-I) = R
        Y1(26-I) = R

        R = R / 10D0
 110  CONTINUE

      STATUS = PRJX2S (PRJ, 25, 25, 1, 1, X1, Y1, LNGR, LATR, STATR)
      IF (STATUS.NE.0) THEN
        WRITE (*, 120) PCODE, STATUS
 120    FORMAT (8X,A3,'(X2S): ERROR',I3)
        GO TO 999
      END IF

      STATUS = PRJS2X (PRJ, 625, 0, 1, 1, LNGR, LATR, X2, Y2, STATR)
      IF (STATUS.NE.0) THEN
        WRITE (*, 130) PCODE, STATUS
 130    FORMAT (3X,A3,' ERROR',I3)
        GO TO 999
      END IF

      DRMAX = 0D0

      DO 160 J = 1, 25
        DO 150 I = 1, 25
          DX = X2(I,J) - X1(I)
          DY = Y2(I,J) - Y1(J)
          DR = SQRT(DX*DX + DY*DY)

          IF (DR.GT.DRMAX) DRMAX = DR
          IF (DR.GT.TOL) THEN
            NFAIL = NFAIL + 1
            WRITE (*, 140) PCODE, X1(I), Y1(J), LNGR(I,J), LATR(I,J),
     :                     X2(I,J), Y2(I,J)
 140        FORMAT (8X,A3,':   x1 =',F20.15,'    y1 =',F20.15,/,
     :              8X,'      lng =',F20.15,'   lat =',F20.15,/,
     :              8X,'       x2 =',F20.15,'    y2 =',F20.15)
          END IF
 150    CONTINUE
 160  CONTINUE

      WRITE (*, 170) DRMAX
 170  FORMAT (13X,'Maximum residual (ref):  dR',1PE8.1)

 999  PROJEX = NFAIL

      END


      MODULE global
      IMPLICIT NONE
      SAVE
! ------------------------ REAL PARAMETERS -----------------------------
      REAL*8 :: DX, DT, LX
      REAL*8 :: NI0, NE0, VXI0, VXE0
      REAL*8 :: TI, TE,  MI, ME, ZI, ZE, GYM
      REAL*8  :: DN, L0
! ----------------------- INTEGER PARAMETERS ---------------------------
      INTEGER :: NX, NXP1, NXP2, NXP3, NXP4
      INTEGER :: NTIME, TIDATA
      INTEGER :: J
! ---------------------------- MATRIX ----------------------------------
      REAL*8,ALLOCATABLE :: NI(:,:), NE(:,:)
      REAL*8,ALLOCATABLE :: PI(:,:), PE(:,:)
      REAL*8,ALLOCATABLE :: VXI(:,:), VXE(:,:)
      REAL*8,ALLOCATABLE :: PH(:,:), EX(:,:)
      REAL*8,ALLOCATABLE :: FD0(:,:), FD1(:,:), FD2(:,:)
      END MODULE global


module nbrsTest_nd_module

  use amrex_fort_module, only : amrex_real, dim=>bl_spacedim
  use amrex_ebcellflag_module, only : get_neighbor_cells
  use pelec_eb_stencil_types_module, only : eb_bndry_geom, eb_bndry_sten, face_sten
  use bl_constants_module, only: ONE, HALF, TWO, FOUR3RD

  implicit none

contains

  pure logical function is_inside (i,j,k,lo,hi)
    integer, intent(in) :: i,j,k,lo(3),hi(3)
    is_inside = i.ge.lo(1) .and. i.le.hi(1) &
         .and.  j.ge.lo(2) .and. j.le.hi(2) &
         .and.  k.ge.lo(3) .and. k.le.hi(3)
  end function is_inside

  pure subroutine mysort(c, n)
    real(amrex_real), intent(in) :: n(dim)
    integer, intent(out) :: c(dim)
    logical          :: mask(dim)
    integer :: m,imax(1)
    mask = .true.
    do m=1,dim
       imax = MAXLOC(ABS(n),mask)
       c(m) = imax(1)
       mask(imax(1)) = .false.
    enddo
  end subroutine mysort

  subroutine pc_fill_bndry_grad_stencil(lo, hi, ebg, Nebg, grad_stencil, Nsten, dx) &
       bind(C,name="pc_fill_bndry_grad_stencil")

    integer,            intent(in   ) :: lo(0:2),hi(0:2)
    integer,            intent(in   ) :: Nebg, Nsten
    type(eb_bndry_geom),intent(in   ) :: ebg(0:Nebg-1)
    type(eb_bndry_sten),intent(inout) :: grad_stencil(0:Nsten-1)
    real(amrex_real),   intent(in   ) :: dx
    integer :: i, j, k, m, c(dim), s(dim), iv(dim), ivs(dim), sh(dim), L, baseiv(dim)
    real(amrex_real) :: n(dim), b(dim), x(2), y(2), z(2), d(2), fac, sten(-1:1,-1:1,-1:1), AREA
    real(amrex_real) :: cy(-1:1),cz(-1:1), bcs, tsten(-1:1,-1:1,-1:1)

    integer :: ii,jj,kk

    AREA = dx**(dim-1)
    fac = AREA / dx

    do L = 0, Nsten-1
       i = ebg(L) % iv(0)
       j = ebg(L) % iv(1)
       k = ebg(L) % iv(2)
       if (i.ge.lo(0) .and. i.le.hi(0) &
            .and. j.ge.lo(1) .and. j.le.hi(1) &
            .and. k.ge.lo(2) .and. k.le.hi(2) ) then

          n = ebg(L)%eb_normal
          call mysort(c,n)
          ivs = ebg(L)%iv
          s = SIGN(1.d0,n(c))
          b = ebg(L)%eb_centroid(c) * s

          baseiv = ivs + SIGN(1.d0,n) - 1 ! From ivs, move to center of stencil, then move to lower-left of that

          x(1) = 1
          x(2) = 2
          y = b(2) + (x - b(1))*ABS(n(c(2))/n(c(1)))
          z = b(3) + (x - b(1))*ABS(n(c(3))/n(c(1)))

          sh(:) = 0
          if (y(1)<0 .or. y(2)<0) then
             sh(c(2)) = -s(2) ! Slide stencil down to avoid extrapolating, push up eb, shift down base later
             b(2) = b(2) + 1
             y(:) = b(2) + (x(:) - b(1))*ABS(n(c(2))/n(c(1)))
          endif
          if (z(1)<0 .or. z(2)<0) then
             sh(c(3)) = -s(3) ! Slide stencil down to avoid extrapolating, push up eb, shift down base later
             b(3) = b(3) + 1
             z(:) = b(3) + (x(:) - b(1))*ABS(n(c(3))/n(c(1)))
          endif

          d = SQRT( (x-b(1))**2 + (y-b(2))**2 + (z-b(3))**2)

          sten = 0

          ! The two intersections, that are d(1) and d(2) away from the eb centroid, are both in
          !  y-z planes, bounded in (0:2)x(0:2) in normalized coordinates
          ! For point m, we interpolate z=0,1,2 lines, to (y(m),0), (y(m),1) and (y(m),2), and
          !  then interpolate along y=y(m) to (y(m),z(m))
          do m=1,2
             cy(-1) = HALF*(y(m)-ONE)*(y(m)-TWO)
             cy( 0) =      -y(m)     *(y(m)-TWO)
             cy( 1) = HALF* y(m)     *(y(m)-ONE)

             cz(-1) = HALF*(z(m)-ONE)*(z(m)-TWO)
             cz( 0) =      -z(m)     *(z(m)-TWO)
             cz( 1) = HALF* z(m)     *(z(m)-ONE)

             do kk=-1,1
                do jj=-1,1
                   sten(m-1,jj,kk) = cy(jj)*cz(kk)
                enddo
             enddo
          enddo

          sten(0,-1:1,-1:1) = sten(0,-1:1,-1:1) * d(2)/(d(1)*(d(2)-d(1)))
          sten(1,-1:1,-1:1) = sten(1,-1:1,-1:1) * d(1)/(d(2)*(d(1)-d(2)))
          bcs = - (d(1)+d(2))/(d(1)*d(2))

          ! Transform stencil into regular stencil structure
          do kk=-1,1
             do jj=-1,1
                do ii=-1,1
                   iv(c(1)) = (ii+1) * s(1) + ivs(c(1)) - baseiv(c(1)) - 1
                   iv(c(2)) = (jj+1) * s(2) + ivs(c(2)) - baseiv(c(2)) - 1
                   iv(c(3)) = (kk+1) * s(3) + ivs(c(3)) - baseiv(c(3)) - 1
                   tsten(iv(1),iv(2),iv(3)) = sten(ii,jj,kk)
                enddo
             enddo
          enddo

          grad_stencil(L)%iv = ebg(L)%iv
          grad_stencil(L)%iv_base = baseiv + sh ! Shift base down, if required
          grad_stencil(L)%bcval = fac * ebg(L)%eb_area * bcs
          grad_stencil(L)%val   = fac * ebg(L)%eb_area * tsten

       endif
    enddo

  end subroutine pc_fill_bndry_grad_stencil

  subroutine pc_apply_eb_boundry_flux_stencil(lo, hi, sten, Nsten, s, slo, shi, D, Dlo, Dhi, &
       bcval, Nvals, bcflux, Nflux, nc) &
       bind(C,name="pc_apply_eb_boundry_flux_stencil")

    integer,          intent(in   ) ::  lo(0:2),  hi(0:2)
    integer,          intent(in   ) :: Nsten, Nvals, Nflux, nc
    type(eb_bndry_sten), intent(in) :: sten(0:Nsten-1)
    real(amrex_real), intent(in   ) :: bcval(0:Nvals-1,1:nc)
    real(amrex_real), intent(inout) :: bcflux(0:Nflux-1,1:nc)
    integer,          intent(in)  :: slo(0:2), shi(0:2)
    integer,          intent(in)  :: Dlo(0:2), Dhi(0:2)
    real(amrex_real), intent(in)  :: s(slo(0):shi(0),slo(1):shi(1),slo(2):shi(2),1:nc)
    real(amrex_real), intent(in)  :: D(Dlo(0):Dhi(0),Dlo(1):Dhi(1),Dlo(2):Dhi(2),1:nc)
    integer :: i,j,k,L,n,ii,jj,kk

    do L = 0, Nsten-1
       i = sten(L) % iv(0)
       j = sten(L) % iv(1)
       k = sten(L) % iv(2)
       if (i.ge.lo(0) .and. i.le.hi(0) &
            .and. j.ge.lo(1) .and. j.le.hi(1) &
            .and. k.ge.lo(2) .and. k.le.hi(2) ) then

          ii = sten(L)%iv_base(0)
          jj = sten(L)%iv_base(1)
          kk = sten(L)%iv_base(2)

          do n=1,nc
             bcflux(L,1:nc) = D(i,j,k,n) * (bcval(L,n) * sten(L)%bcval + &
                  sum(sten(L)%val(-1:1,-1:1,-1:1) * s(ii:ii+2,jj:jj+2,kk:kk+2,n)) )
          enddo

       endif
    enddo

  end subroutine pc_apply_eb_boundry_flux_stencil

  subroutine pc_apply_eb_boundry_visc_flux_stencil( &
       lo, hi,         &
       sten, Nsten,    &
       ebg,  Nebg,     &
       s,  slo,  shi,  &
       mu, mulo, muhi, &
       xi, xilo, xihi, &
       bcval, Nvals, bcflux, Nflux, nc) &
       bind(C,name="pc_apply_eb_boundry_visc_flux_stencil")

    integer,          intent(in   ) ::  lo(0:2),  hi(0:2)
    integer,          intent(in   ) :: Nsten, Nebg, Nvals, Nflux, nc
    type(eb_bndry_sten), intent(in) :: sten(0:Nsten-1)
    type(eb_bndry_geom),intent(in   ) :: ebg(0:Nebg-1)
    real(amrex_real), intent(in   ) :: bcval(0:Nvals-1,1:nc)
    real(amrex_real), intent(inout) :: bcflux(0:Nflux-1,1:nc)
    integer,          intent(in)  ::  slo(0:2),  shi(0:2)
    integer,          intent(in)  :: mulo(0:2), muhi(0:2)
    integer,          intent(in)  :: xilo(0:2), xihi(0:2)
    real(amrex_real), intent(in)  ::  s( slo(0):shi(0),  slo(1):shi(1),  slo(2):shi(2) ,1:nc)
    real(amrex_real), intent(in)  :: mu(mulo(0):muhi(0),mulo(1):muhi(1),mulo(2):muhi(2))
    real(amrex_real), intent(in)  :: xi(xilo(0):xihi(0),xilo(1):xihi(1),xilo(2):xihi(2))
    integer :: i,j,k,L,M,ii,jj,kk,iii,jjj,kkk
    real(amrex_real) :: Nmag, n(dim), t1(dim), t2(dim), denom, ndota
    real(amrex_real) :: Uo(-1:1,-1:1,-1:1,dim), Ut(-1:1,-1:1,-1:1,dim), alpha(dim)
    real(amrex_real) :: Qt(dim,dim), dUtdn(dim), tauDotN(dim), bco(dim), bct(dim)

    do L = 0, Nsten-1
       i = sten(L) % iv(0)
       j = sten(L) % iv(1)
       k = sten(L) % iv(2)
       if (i.ge.lo(0) .and. i.le.hi(0) &
            .and. j.ge.lo(1) .and. j.le.hi(1) &
            .and. k.ge.lo(2) .and. k.le.hi(2) ) then

          ii = sten(L)%iv_base(0)
          jj = sten(L)%iv_base(1)
          kk = sten(L)%iv_base(2)

          Nmag = SQRT(ebg(L)%eb_normal(1)**2 + ebg(L)%eb_normal(2)**2 + ebg(L)%eb_normal(3)**2)
          n(1) = ebg(L)%eb_normal(1) / Nmag
          n(2) = ebg(L)%eb_normal(2) / Nmag
          n(3) = ebg(L)%eb_normal(3) / Nmag

          alpha = 0.d0
          alpha(MINLOC(ABS(n))) = 1.d0

          ndota = n(1)*alpha(1) + n(2)*alpha(2) + n(3)*alpha(3)
          t1(1) = alpha(1) - ndota*n(1)
          t1(2) = alpha(2) - ndota*n(2)
          t1(3) = alpha(3) - ndota*n(3)
          denom = 1.d0 / SQRT(t1(1)**2 + t1(2)**2 + t1(3)**2)
          t1(1) = t1(1) * denom
          t1(2) = t1(2) * denom
          t1(3) = t1(3) * denom

          t2(1) = n(2)*t1(3) - n(3)*t1(2)
          t2(2) = n(3)*t1(1) - n(1)*t1(3)
          t2(3) = n(1)*t1(2) - n(2)*t1(1)

          Qt(1,1) = n(1)
          Qt(1,2) = n(2)
          Qt(1,3) = n(3)
          Qt(2,1) = t1(1)
          Qt(2,2) = t1(2)
          Qt(2,3) = t1(3)
          Qt(3,1) = t2(1)
          Qt(3,2) = t2(2)
          Qt(3,3) = t2(3)

          ! Transform velocities at all stencil points to coordinates aligned with EB
          Uo(-1:1,-1:1,-1:1,1:dim) = s(ii:ii+2,jj:jj+2,kk:kk+2,1:dim)
          do kkk=-1,1
             do jjj=-1,1
                do iii=-1,1
                   do M=1,dim
                      Ut(iii,jjj,kkk,M) = Qt(M,1) * Uo(iii,jjj,kkk,1) &
                           +              Qt(M,2) * Uo(iii,jjj,kkk,2) &
                           +              Qt(M,3) * Uo(iii,jjj,kkk,3)
                   enddo
                enddo
             enddo
          enddo

          ! Transform eb boundary velocities to coordinates aligned with EB
          bco(1:dim) = bcval(L,1:dim)
          bct(1) = Qt(1,1) * bco(1) + Qt(1,2)*bco(2) + Qt(1,3)*bco(3)
          bct(2) = Qt(2,1) * bco(1) + Qt(2,2)*bco(2) + Qt(2,3)*bco(3)
          bct(3) = Qt(3,1) * bco(1) + Qt(3,2)*bco(2) + Qt(3,3)*bco(3)

          ! Compute normal derivative (times eb area) using precomputed stencil
          dUtdn(1) = sum(sten(L)%val(-1:1,-1:1,-1:1) * Ut(-1:1,-1:1,-1:1,1)) + bct(1) * sten(L)%bcval
          dUtdn(2) = sum(sten(L)%val(-1:1,-1:1,-1:1) * Ut(-1:1,-1:1,-1:1,2)) + bct(2) * sten(L)%bcval
          dUtdn(3) = sum(sten(L)%val(-1:1,-1:1,-1:1) * Ut(-1:1,-1:1,-1:1,3)) + bct(3) * sten(L)%bcval

          tauDotN(1) = (FOUR3RD*mu(i,j,k) + xi(i,j,k)) * dUtdn(1)
          tauDotN(2) =          mu(i,j,k)              * dUtdn(2)
          tauDotN(3) =          mu(i,j,k)              * dUtdn(3)

          bcflux(L,1) = Qt(1,1) * tauDotN(1) + Qt(2,1) * tauDotN(2) + Qt(3,1) * tauDotN(3)
          bcflux(L,2) = Qt(1,2) * tauDotN(1) + Qt(2,2) * tauDotN(2) + Qt(3,2) * tauDotN(3)
          bcflux(L,3) = Qt(1,3) * tauDotN(1) + Qt(2,3) * tauDotN(2) + Qt(3,3) * tauDotN(3)
       endif
    enddo

  end subroutine pc_apply_eb_boundry_visc_flux_stencil

  subroutine pc_fill_flux_interp_stencil(lo, hi, slo, shi, sten, Nsten, idir, &
       fc, fclo, fchi, fa, falo, fahi) bind(C,name="pc_fill_flux_interp_stencil")

    integer,          intent(in)  ::  lo(0:2),  hi(0:2)
    integer,          intent(in)  :: slo(0:2), shi(0:2)
    integer,          intent(in)  :: Nsten, idir
    type(face_sten),intent(inout) :: sten(0:Nsten-1)
    integer,          intent(in)  :: fclo(0:2), fchi(0:2)
    integer,          intent(in)  :: falo(0:2), fahi(0:2)
    real(amrex_real), intent(in)  :: fc( fclo(0):fchi(0),fclo(1):fchi(1),fclo(2):fchi(2),2)
    real(amrex_real), intent(in)  :: fa( falo(0):fahi(0),falo(1):fahi(1),falo(2):fahi(2))
    integer :: i,j,k,n,in,jn,kn
    real(amrex_real) :: cx,cy,cz,acx,acy,acz

    if (idir .eq. 0) then
       do n = 0, Nsten-1
          i = sten(n) % iv(0)
          j = sten(n) % iv(1)
          k = sten(n) % iv(2)
          if (i.ge.lo(0) .and. i.le.hi(0) &
               .and. j.ge.lo(1) .and. j.le.hi(1) &
               .and. k.ge.lo(2) .and. k.le.hi(2) ) then
             sten(n)%val = 0.d0
             cy = fc(i,j,k,1)
             cz = fc(i,j,k,2)
             jn = SIGN(1.d0, cy)
             kn = SIGN(1.d0, cz)
             acy = ABS(cy)
             acz = ABS(cz)
             sten(n)%val(0, 0 ) = fa(i,j,k) * (1.d0 - acy) * (1.d0 - acz)
             sten(n)%val(jn,0 ) = fa(i,j,k) *      acy     * (1.d0 - acz)
             sten(n)%val(0, kn) = fa(i,j,k) * (1.d0 - acy) *      acz
             sten(n)%val(jn,kn) = fa(i,j,k) *      acy     *      acz
          endif
       enddo
    else if (idir.eq.1) then
       do n = 0, Nsten-1
          i = sten(n) % iv(0)
          j = sten(n) % iv(1)
          k = sten(n) % iv(2)
          if (i.ge.lo(0) .and. i.le.hi(0) &
               .and. j.ge.lo(1) .and. j.le.hi(1) &
               .and. k.ge.lo(2) .and. k.le.hi(2) ) then
             sten(n)%val = 0.d0
             cx = fc(i,j,k,1)
             cz = fc(i,j,k,2)
             in = SIGN(1.d0, cx)
             kn = SIGN(1.d0, cz)
             acx = ABS(cx)
             acz = ABS(cz)
             sten(n)%val(0, 0 ) = fa(i,j,k) * (1.d0 - acx) * (1.d0 - acz)
             sten(n)%val(in,0 ) = fa(i,j,k) *      acx     * (1.d0 - acz)
             sten(n)%val(0, kn) = fa(i,j,k) * (1.d0 - acx) *      acz
             sten(n)%val(in,kn) = fa(i,j,k) *      acx     *      acz
          endif
       enddo
    else
       do n = 0, Nsten-1
          i = sten(n) % iv(0)
          j = sten(n) % iv(1)
          k = sten(n) % iv(2)
          if (i.ge.lo(0) .and. i.le.hi(0) &
               .and. j.ge.lo(1) .and. j.le.hi(1) &
               .and. k.ge.lo(2) .and. k.le.hi(2) ) then
             sten(n)%val = 0.d0
             cx = fc(i,j,k,1)
             cy = fc(i,j,k,2)
             in = SIGN(1.d0, cx)
             jn = SIGN(1.d0, cy)
             acx = ABS(cx)
             acy = ABS(cy)
             sten(n)%val(0, 0 ) = fa(i,j,k) * (1.d0 - acx) * (1.d0 - acy)
             sten(n)%val(in,0 ) = fa(i,j,k) *      acx     * (1.d0 - acy)
             sten(n)%val(0, jn) = fa(i,j,k) * (1.d0 - acx) *      acy
             sten(n)%val(in,jn) = fa(i,j,k) *      acx     *      acy
          endif
       enddo
    endif
  end subroutine pc_fill_flux_interp_stencil

  subroutine pc_apply_face_stencil(lo, hi, slo, shi, sten, Nsten, idir, vin, vin_lo, vin_hi, &
    vout, vout_lo, vout_hi, nc, in_place) bind(C,name="pc_apply_face_stencil")

    integer,          intent(in   ) ::  lo(0:2),  hi(0:2)
    integer,          intent(in   ) :: slo(0:2), shi(0:2)
    integer,          intent(in   ) :: Nsten, idir, nc, in_place
    type(face_sten),  intent(in   ) :: sten(0:Nsten-1)
    integer,          intent(in   ) ::  vin_lo(0:2),  vin_hi(0:2)
    integer,          intent(in   ) :: vout_lo(0:2), vout_hi(0:2)
    real(amrex_real), intent(in   ) ::  vin( vin_lo(0):vin_hi(0),  vin_lo(1):vin_hi(1),  vin_lo(2):vin_hi(2),  1:nc)
    real(amrex_real), intent(inout) :: vout(vout_lo(0):vout_hi(0),vout_lo(1):vout_hi(1),vout_lo(2):vout_hi(2), 1:nc)
    integer :: i,j,k,L,n
    real(amrex_real), allocatable :: newval(:)

    if (in_place .eq. 1) then

       allocate(newval(0:Nsten-1))

       if (idir.eq.0) then
          do n = 1,nc
             do L = 0, Nsten-1
                i = sten(L) % iv(0)
                j = sten(L) % iv(1)
                k = sten(L) % iv(2)
                if (i.ge.lo(0) .and. i.le.hi(0) &
                     .and. j.ge.lo(1) .and. j.le.hi(1) &
                     .and. k.ge.lo(2) .and. k.le.hi(2) ) then
                   newval(L) = sum(sten(L)%val(-1:1,-1:1) * vin(i,j-1:j+1,k-1:k+1,n))
                endif
             enddo

             do L = 0, Nsten-1
                i = sten(L) % iv(0)
                j = sten(L) % iv(1)
                k = sten(L) % iv(2)
                if (i.ge.lo(0) .and. i.le.hi(0) &
                     .and. j.ge.lo(1) .and. j.le.hi(1) &
                     .and. k.ge.lo(2) .and. k.le.hi(2) ) then
                   vout(i,j,k,n) = newval(L)
                endif
             enddo

          enddo
       else if (idir.eq.1) then
          do n = 1,nc
             do L = 0, Nsten-1
                i = sten(L) % iv(0)
                j = sten(L) % iv(1)
                k = sten(L) % iv(2)
                if (i.ge.lo(0) .and. i.le.hi(0) &
                     .and. j.ge.lo(1) .and. j.le.hi(1) &
                     .and. k.ge.lo(2) .and. k.le.hi(2) ) then
                   newval(L) = sum(sten(L)%val(-1:1,-1:1) * vin(i-1:i+1,j,k-1:k+1,n))
                endif
             enddo

             do L = 0, Nsten-1
                i = sten(L) % iv(0)
                j = sten(L) % iv(1)
                k = sten(L) % iv(2)
                if (i.ge.lo(0) .and. i.le.hi(0) &
                     .and. j.ge.lo(1) .and. j.le.hi(1) &
                     .and. k.ge.lo(2) .and. k.le.hi(2) ) then
                   vout(i,j,k,n) = newval(L)
                endif
             enddo

          enddo
       else
          do n = 1,nc
             do L = 0, Nsten-1
                i = sten(L) % iv(0)
                j = sten(L) % iv(1)
                k = sten(L) % iv(2)
                if (i.ge.lo(0) .and. i.le.hi(0) &
                     .and. j.ge.lo(1) .and. j.le.hi(1) &
                     .and. k.ge.lo(2) .and. k.le.hi(2) ) then
                   newval(L) = sum(sten(L)%val(-1:1,-1:1) * vin(i-1:i+1,j-1:j+1,k,n))
                endif
             enddo

             do L = 0, Nsten-1
                i = sten(L) % iv(0)
                j = sten(L) % iv(1)
                k = sten(L) % iv(2)
                if (i.ge.lo(0) .and. i.le.hi(0) &
                     .and. j.ge.lo(1) .and. j.le.hi(1) &
                     .and. k.ge.lo(2) .and. k.le.hi(2) ) then
                   vout(i,j,k,n) = newval(L)
                endif
             enddo

          enddo
       endif

       deallocate(newval)

    else

       if (idir.eq.0) then
          do n = 1,nc
             do L = 0, Nsten-1
                i = sten(L) % iv(0)
                j = sten(L) % iv(1)
                k = sten(L) % iv(2)
                if (i.ge.lo(0) .and. i.le.hi(0) &
                     .and. j.ge.lo(1) .and. j.le.hi(1) &
                     .and. k.ge.lo(2) .and. k.le.hi(2) ) then
                   vout(i,j,k,n) = sum(sten(L)%val(-1:1,-1:1) * vin(i,j-1:j+1,k-1:k+1,n))
                endif
             enddo
          enddo
       else if (idir.eq.1) then
          do n = 1,nc
             do L = 0, Nsten-1
                i = sten(L) % iv(0)
                j = sten(L) % iv(1)
                k = sten(L) % iv(2)
                if (i.ge.lo(0) .and. i.le.hi(0) &
                     .and. j.ge.lo(1) .and. j.le.hi(1) &
                     .and. k.ge.lo(2) .and. k.le.hi(2) ) then
                   vout(i,j,k,n) = sum(sten(L)%val(-1:1,-1:1) * vin(i-1:i+1,j,k-1:k+1,n))
                endif
             enddo
          enddo
       else
          do n = 1,nc
             do L = 0, Nsten-1
                i = sten(L) % iv(0)
                j = sten(L) % iv(1)
                k = sten(L) % iv(2)
                if (i.ge.lo(0) .and. i.le.hi(0) &
                     .and. j.ge.lo(1) .and. j.le.hi(1) &
                     .and. k.ge.lo(2) .and. k.le.hi(2) ) then
                   vout(i,j,k,n) = sum(sten(L)%val(-1:1,-1:1) * vin(i-1:i+1,j-1:j+1,k,n))
                endif
             enddo
          enddo
       endif

    endif

  end subroutine pc_apply_face_stencil

  subroutine pc_fix_div_and_redistribute( &
       lo, hi,             &
       sv_ebg, Ncut,       &
       flag, fglo, fghi,   &
       f0,   f0lo,   f0hi, &
       f1,   f1lo,   f1hi, &
       f2,   f2lo,   f2hi, &
       ebflux, nebflux,    &
       DC,   DClo,   DChi, &
       W,    Wlo,    Whi,  &
       vf,   vflo,   vfhi, VOL, nc, &
       as_crse, rr_drho_crse, rdclo, rdchi, rr_flag_crse, rfclo, rfchi, &
       as_fine, dm_as_fine, dflo, dfhi, &
       levmsk, lmlo, lmhi,dt) bind(C,name="pc_fix_div_and_redistribute")

    use amrex_eb_flux_reg_nd_module, only : crse_cell, crse_fine_boundary_cell, &
         covered_by_fine=>fine_cell, reredistribution_threshold

    use meth_params_module, only: levmsk_notcovered

    integer,          intent(in   ) ::  lo(0:2),  hi(0:2)
    integer,          intent(in   ) :: nc, Ncut, nebflux
    type(eb_bndry_geom), intent(in   ) :: sv_ebg(0:Ncut-1)
    integer,          intent(in   ) :: fglo(0:2),fghi(0:2)
    integer,          intent(in   ) :: f0lo(0:2),f0hi(0:2)
    integer,          intent(in   ) :: f1lo(0:2),f1hi(0:2)
    integer,          intent(in   ) :: f2lo(0:2),f2hi(0:2)
    integer,          intent(in   ) :: DClo(0:2),DChi(0:2)
    integer,          intent(in   ) :: vflo(0:2),vfhi(0:2)
    integer,          intent(in   ) ::  Wlo(0:2), Whi(0:2)
    integer,          intent(in   ) :: flag(fglo(0):fghi(0),fglo(1):fghi(1),fglo(2):fghi(2))
    real(amrex_real), intent(in   ) ::   f0(f0lo(0):f0hi(0),f0lo(1):f0hi(1),f0lo(2):f0hi(2),1:nc)
    real(amrex_real), intent(in   ) ::   f1(f1lo(0):f1hi(0),f1lo(1):f1hi(1),f1lo(2):f1hi(2),1:nc)
    real(amrex_real), intent(in   ) ::   f2(f2lo(0):f2hi(0),f2lo(1):f2hi(1),f2lo(2):f2hi(2),1:nc)
    real(amrex_real), intent(inout) ::   ebflux(0:nebflux-1,1:nc)
    real(amrex_real), intent(inout) ::   DC(DClo(0):DChi(0),DClo(1):DChi(1),DClo(2):DChi(2),1:nc)
    real(amrex_real), intent(in   ) ::   vf(vflo(0):vfhi(0),vflo(1):vfhi(1),vflo(2):vfhi(2))
    real(amrex_real), intent(in   ) ::    W( Wlo(0):Whi(0) , Wlo(1):Whi(1) , Wlo(2):Whi(2))
    real(amrex_real), intent(in   ) :: VOL,dt
    real(amrex_real) :: VOLINV, sum_kappa, sum_div, kappa_inv, DNC
    integer :: i,j,k,L,n
    integer :: nbr(-1:1,-1:1,-1:1)
    real(amrex_real) :: dM(0:Ncut-1), HD(0:Ncut-1), sum_kappa_inv

    integer, intent(in) :: as_crse, as_fine
    integer, intent(in), dimension(3) :: rdclo,rdchi,rfclo,rfchi,dflo,dfhi,lmlo,lmhi
    real(amrex_real), intent(inout) :: rr_drho_crse(rdclo(1):rdchi(1),rdclo(2):rdchi(2),rdclo(3):rdchi(3),nc)
    real(amrex_real), intent(out) :: dm_as_fine(dflo(1):dfhi(1),dflo(2):dfhi(2),dflo(3):dfhi(3),nc)
    integer,  intent(in) ::  levmsk (lmlo(1):lmhi(1),lmlo(2):lmhi(2),lmlo(3):lmhi(3))
    integer,  intent(in) ::  rr_flag_crse(rfclo(1):rfchi(1),rfclo(2):rfchi(2),rfclo(3):rfchi(3))
    real(amrex_real) :: drho

    integer :: ii,jj,kk,iii,jjj,kkk
    logical :: valid_dst_cell
    logical :: as_crse_crse_cell, as_crse_covered_cell, as_fine_valid_cell, as_fine_ghost_cell

    dm_as_fine=0.d0
    VOLINV = 1.d0 / VOL

    do n=1,nc

       ! Recompute conservative divergence, DC, on cut cells...need DC in 2 grow cells for final result
       do L = 0, Ncut-1
          i = sv_ebg(L) % iv(0)
          j = sv_ebg(L) % iv(1)
          k = sv_ebg(L) % iv(2)
          if (       i.ge.lo(0)-2 .and. i.le.hi(0)+2 &
               .and. j.ge.lo(1)-2 .and. j.le.hi(1)+2 &
               .and. k.ge.lo(2)-2 .and. k.le.hi(2)+2 ) then
             kappa_inv = 1.d0 / MAX(vf(i,j,k),1.d-12)
             DC(i,j,k,n) = - ( f0(i+1,j,k,n) - f0(i,j,k,n) &
                  +            f1(i,j+1,k,n) - f1(i,j,k,n) &
                  +            f2(i,j,k+1,n) - f2(i,j,k,n) + ebflux(L,n)) * VOLINV * kappa_inv
          endif
       enddo

       ! Compute non-conservative and hybrid divergence, DNC and HD, and redistribution mass dM in cut cells
       ! Will need in 1 grow cells (see below), so it depends on having a conservative div in 2 grow cells
       do L = 0, Ncut-1
          i = sv_ebg(L) % iv(0)
          j = sv_ebg(L) % iv(1)
          k = sv_ebg(L) % iv(2)
          if (       i.ge.lo(0)-1 .and. i.le.hi(0)+1 &
               .and. j.ge.lo(1)-1 .and. j.le.hi(1)+1 &
               .and. k.ge.lo(2)-1 .and. k.le.hi(2)+1 ) then
             call get_neighbor_cells(flag(i,j,k),nbr)
             sum_kappa = sum(nbr(-1:1,-1:1,-1:1) * vf(i-1:i+1,j-1:j+1,k-1:k+1))
             sum_div =   sum(nbr(-1:1,-1:1,-1:1) * vf(i-1:i+1,j-1:j+1,k-1:k+1) * DC(i-1:i+1,j-1:j+1,k-1:k+1,n))
             DNC = sum_div / sum_kappa
             dM(L) = vf(i,j,k)*(1.d0 - vf(i,j,k))*(DC(i,j,k,n) - DNC)
             HD(L) = vf(i,j,k)*DC(i,j,k,n) + (1.d0 - vf(i,j,k))*DNC
          endif
       enddo

       ! Now that we finished computing HD and dM everywhere, it is safe to increment DC to hold HD
       do L = 0, Ncut-1
          i = sv_ebg(L) % iv(0)
          j = sv_ebg(L) % iv(1)
          k = sv_ebg(L) % iv(2)
          if (       i.ge.lo(0)-1 .and. i.le.hi(0)+1 &
               .and. j.ge.lo(1)-1 .and. j.le.hi(1)+1 &
               .and. k.ge.lo(2)-1 .and. k.le.hi(2)+1 ) then
             DC(i,j,k,n) = HD(L)
          endif
       enddo

       ! Redistribute dM - THIS REQUIRES THAT DC BE GOOD IN 1 GROW CELL
       do L = 0, Ncut-1
          i = sv_ebg(L) % iv(0)
          j = sv_ebg(L) % iv(1)
          k = sv_ebg(L) % iv(2)
          if (       i.ge.lo(0)-1 .and. i.le.hi(0)+1 &
               .and. j.ge.lo(1)-1 .and. j.le.hi(1)+1 &
               .and. k.ge.lo(2)-1 .and. k.le.hi(2)+1 ) then

             call get_neighbor_cells(flag(i,j,k),nbr)
             nbr(0,0,0) = 0.d0 ! redistribute to all neighbors but me
             sum_kappa = sum(nbr(-1:1,-1:1,-1:1) * vf(i-1:i+1,j-1:j+1,k-1:k+1) * W(i-1:i+1,j-1:j+1,k-1:k+1))
             sum_kappa_inv = 1.d0 / sum_kappa
             DC(i-1:i+1,j-1:j+1,k-1:k+1,n) = DC(i-1:i+1,j-1:j+1,k-1:k+1,n) &
                  + dM(L) * nbr(-1:1,-1:1,-1:1) * W(i-1:i+1,j-1:j+1,k-1:k+1) * sum_kappa_inv

          !re redistribution book keeping
          as_crse_crse_cell = .false.
          as_crse_covered_cell = .false.
          if (as_crse .eq. 1) then
                as_crse_crse_cell = is_inside(i,j,k,lo,hi) .and. &
                           rr_flag_crse(i,j,k) .eq. crse_fine_boundary_cell
                as_crse_covered_cell = rr_flag_crse(i,j,k) .eq. covered_by_fine
          end if

          as_fine_valid_cell = .false.  ! valid cells near box boundary
          as_fine_ghost_cell = .false.  ! ghost cells just outside valid region
          if (as_fine .eq. 1) then
            as_fine_valid_cell = is_inside(i,j,k,lo,hi)
            as_fine_ghost_cell = levmsk(i,j,k) .eq. levmsk_notcovered ! not covered by other grids
          end if

         do kk = -1,1
            do jj = -1,1
               do ii = -1,1
                  if((ii.ne. 0 .or. jj.ne.0 .or. kk.ne. 0) .and. nbr(ii,jj,kk).eq.1) then

                      iii = i + ii
                      jjj = j + jj
                      kkk = k + kk

                      drho = dM(L)*sum_kappa_inv*W(iii,jjj,kkk)

                      valid_dst_cell = is_inside(iii,jjj,kkk,lo,hi)

                      if (as_crse_crse_cell) then
                            if (rr_flag_crse(iii,jjj,kkk).eq.covered_by_fine &
                                       .and. vf(i,j,k).gt.reredistribution_threshold) then
                                rr_drho_crse(i,j,k,n) = rr_drho_crse(i,j,k,n) &
                                          + dt*drho*(vf(iii,jjj,kkk)/vf(i,j,k))
                            end if
                      end if

                      if (as_crse_covered_cell) then
                            if (valid_dst_cell) then
                               if (rr_flag_crse(iii,jjj,kkk).eq.crse_fine_boundary_cell &
                                          .and. vf(iii,jjj,kkk).gt.reredistribution_threshold) then
                                        ! the recipient is a crse/fine boundary cell
                                    rr_drho_crse(iii,jjj,kkk,n) = rr_drho_crse(iii,jjj,kkk,n) &
                                             - dt*drho
                                end if
                            end if
                     end if

                    if (as_fine_valid_cell) then
                            if (.not.valid_dst_cell) then
                                dm_as_fine(iii,jjj,kkk,n) = dm_as_fine(iii,jjj,kkk,n) &
                                          + dt*drho*vf(iii,jjj,kkk)
                            end if
                    end if

                    if (as_fine_ghost_cell) then
                            if (valid_dst_cell) then
                                     dm_as_fine(i,j,k,n) = dm_as_fine(i,j,k,n) &
                                         - dt*drho*vf(iii,jjj,kkk)
                            end if
                    end if

                    endif
                enddo
             enddo
           enddo !end neighbor loop (re redistribution)

        endif
       enddo !redistribution loop

    enddo !component loop

  end subroutine pc_fix_div_and_redistribute

  subroutine pc_set_body_state(lo, hi, S, Slo, Shi, mask, mlo, mhi, b, nc, bval) &
       bind(C,name="pc_set_body_state")

    integer,          intent(in   ) :: nc, bval
    integer,          intent(in   ) :: lo(1:3),hi(1:3)
    integer,          intent(in   ) :: Slo(1:3),Shi(1:3)
    integer,          intent(in   ) :: mlo(1:3),mhi(1:3)
    integer,          intent(in   ) :: mask(mlo(1):mhi(1),mlo(2):mhi(2),mlo(3):mhi(3))
    real(amrex_real), intent(inout) :: S(Slo(1):Shi(1),Slo(2):Shi(2),Slo(3):Shi(3),1:nc)
    real(amrex_real), intent(in   ) :: b(1:nc)
    integer :: i,j,k,n

    do n=1,nc
       do k=lo(3),hi(3)
          do j=lo(2),hi(2)
             do i=lo(1),hi(1)
                if (mask(i,j,k).eq.bval) S(i,j,k,n)=b(n)
             enddo
          enddo
       enddo
    enddo

  end subroutine pc_set_body_state

  subroutine pc_fill_sv_ebg(lo, hi, ebg, Nebg, vfrac, vflo, vfhi, bcent, blo, bhi, &
       apx, axlo, axhi, apy, aylo, ayhi, apz, azlo, azhi) &
       bind(C,name="pc_fill_sv_ebg")

    integer,          intent(in   ) ::  lo(0:2),  hi(0:2)
    integer, dimension(3), intent(in) :: vflo, vfhi, blo, bhi, axlo, axhi, aylo, ayhi, azlo, azhi
    integer,          intent(in   ) :: Nebg
    type(eb_bndry_geom), intent(inout) :: ebg(0:Nebg-1)
    integer :: i,j,k,L,n,ii,jj,kk

    real(amrex_real), intent(in) :: vfrac(vflo(1):vfhi(1),vflo(2):vfhi(2),vflo(3):vfhi(3))
    real(amrex_real), intent(in) :: bcent(blo(1):bhi(1),blo(2):bhi(2),blo(3):bhi(3),3)
    real(amrex_real), intent(in) :: apx(axlo(1):axhi(1),axlo(2):axhi(2),axlo(3):axhi(3))
    real(amrex_real), intent(in) :: apy(aylo(1):ayhi(1),aylo(2):ayhi(2),aylo(3):ayhi(3))
    real(amrex_real), intent(in) :: apz(azlo(1):azhi(1),azlo(2):azhi(2),azlo(3):azhi(3))

    real(amrex_real) :: axm, axp, aym, ayp, azm, azp, apnorm, apnorminv
    do L = 0, Nebg-1
       i = ebg(L) % iv(0)
       j = ebg(L) % iv(1)
       k = ebg(L) % iv(2)
       if (i.ge.lo(0) .and. i.le.hi(0) &
            .and. j.ge.lo(1) .and. j.le.hi(1) &
            .and. k.ge.lo(2) .and. k.le.hi(2) ) then

          axm = apx(i,j,k)
          axp = apx(i+1,j,k)
          aym = apy(i,j,k)
          ayp = apy(i,j+1,k)
          azm = apz(i,j,k)
          azp = apz(i,j,k+1)

          apnorm = sqrt((axm-axp)**2 + (aym-ayp)**2 + (azm-azp)**2)
          apnorminv = -1.d0 / apnorm
          ebg(L) % eb_normal(1) = (axm-axp) * apnorminv  ! pointing to the wall
          ebg(L) % eb_normal(2) = (aym-ayp) * apnorminv
          ebg(L) % eb_normal(3) = (azm-azp) * apnorminv

          ebg(L) % eb_area = apnorm

          ebg(L) % eb_centroid(1) = bcent(i,j,k,1)
          ebg(L) % eb_centroid(2) = bcent(i,j,k,2)
          ebg(L) % eb_centroid(3) = bcent(i,j,k,3)
       endif
    enddo

  end subroutine pc_fill_sv_ebg

end module nbrsTest_nd_module


! this library implements the limiting functions used in the
! reconstruction.  We use F90 for both speed and clarity, since
! the numpy array notations can sometimes be confusing.

!-----------------------------------------------------------------------------
! multi-dimensional limiting from BDS
!-----------------------------------------------------------------------------
subroutine multid_limit(a, ldax, lday, qx, qy, ng)

  ! a multidimensional limiter based on the ideas from
  ! Bell, Dawson, and Schubin

  implicit none

  integer, intent(in) :: qx, qy, ng

  ! 0-based indexing to match python
  double precision, intent(inout) :: a(0:qx-1, 0:qy-1)
  double precision, intent(  out) :: ldax(0:qx-1, 0:qy-1), lday(0:qx-1, 0:qy-1)

!f2py depend(qx, qy) :: a, ldax, lday
!f2py intent(in) :: a
!f2py intent(out) :: ldax, lday

! call this as: ldax, lday = reconstruction_f.multid_limit(a,qx,qy,ng)

  integer :: ilo, ihi, jlo, jhi
  integer :: nx, ny
  integer :: i, j, m, n

  integer, parameter :: ill = 1, ilh = 2, irl = 3, irh = 4
  double precision :: ss(4), ss_temp(4), min_ss(4), max_ss(4), diff(4)
  double precision :: A_x, A_y, A_xy
  double precision :: sumdiff, sgndiff, redfac, redmax, div
  double precision, parameter :: eps = 1.d-10
  integer :: kdp
  integer, parameter :: niter = 3

  double precision, allocatable :: a_nd(:,:)

  nx = qx - 2*ng; ny = qy - 2*ng
  ilo = ng; ihi = ng+nx-1; jlo = ng; jhi = ng+ny-1

  ldax(:,:) = 0.0d0
  lday(:,:) = 0.0d0

  ! here we do a multidimensional reconstruction of the data, forming
  ! a bilinear polynomial:
  !     q(x,y) = A_xy (x-x_i)(y-y_i) + A_x (x-x_i) + A_y (y-y_i) + A_avg
  !
  ! First find the values at the nodes.  Here a_nd(i,j) will refer to
  ! a_{i-1/2,j-1/2}

  allocate(a_nd(0:qx-1, 0:qy-1))

  do j = jlo-2, jhi+3
     do i = ilo-2, ihi+3

        a_nd(i,j) = &
             (        a(i-2,j-2) -  7.0d0*(a(i-1,j-2) + a(i,j-2)) +       a(i+1,j-2) + &
             (-7.0d0)*a(i-2,j-1) + 49.0d0*(a(i-1,j-1) + a(i,j-1)) - 7.0d0*a(i+1,j-1) + &
             (-7.0d0)*a(i-2,j  ) + 49.0d0*(a(i-1,j  ) + a(i,j  )) - 7.0d0*a(i+1,j  ) + &
                      a(i-2,j+1) -  7.0d0*(a(i-1,j+1) + a(i,j+1)) +       a(i+1,j+1))/ &
             144.0d0

     enddo
  enddo

  ! now get the coefficients of the bilinear polynomial.  Here we loop
  ! ! over zone centers.
  do j = jlo-1, jhi+1
     do i = ilo-1, ihi+1

        ss(ill) = a_nd(i,j)     ! a_{i-1/2,j-1/2}
        ss(ilh) = a_nd(i,j+1)   ! a_{i-1/2,j+1/2}
        ss(irl) = a_nd(i+1,j)   ! a_{i+1/2,j-1/2}
        ss(irh) = a_nd(i+1,j+1) ! a_{i+1/2,j+1/2}

        ! note, we omit the dx and dy here
        A_x  = ((ss(irh) + ss(irl)) - (ss(ilh) + ss(ill)))/2.0d0
        A_y  = ((ss(ilh) + ss(irh)) - (ss(ill) + ss(irl)))/2.0d0
        A_xy = ((ss(irh) - ss(irl)) - (ss(ilh) - ss(ill)))

        ! check if we are within the cc-values
        ss_temp(ill) = a(i,j) - 0.5d0*A_x - 0.5d0*A_y + 0.25d0*A_xy
        ss_temp(ilh) = a(i,j) - 0.5d0*A_x + 0.5d0*A_y - 0.25d0*A_xy
        ss_temp(irl) = a(i,j) + 0.5d0*A_x - 0.5d0*A_y - 0.25d0*A_xy
        ss_temp(irh) = a(i,j) + 0.5d0*A_x + 0.5d0*A_y + 0.25d0*A_xy

        min_ss(ill) = min(a(i-1,j-1), a(i,j-1), a(i-1,j), a(i,j))
        max_ss(ill) = max(a(i-1,j-1), a(i,j-1), a(i-1,j), a(i,j))

        min_ss(ilh) = min(a(i-1,j+1), a(i,j+1), a(i-1,j), a(i,j))
        max_ss(ilh) = max(a(i-1,j+1), a(i,j+1), a(i-1,j), a(i,j))

        min_ss(irl) = min(a(i+1,j-1), a(i,j-1), a(i+1,j), a(i,j))
        max_ss(irl) = max(a(i+1,j-1), a(i,j-1), a(i+1,j), a(i,j))

        min_ss(irh) = min(a(i+1,j+1), a(i,j+1), a(i+1,j), a(i,j))
        max_ss(irh) = max(a(i+1,j+1), a(i,j+1), a(i+1,j), a(i,j))

        ! limit
        do m = 1, 4
           ss_temp(m) = max(min(ss_temp(m), max_ss(m)), min_ss(m))
        enddo

        do n = 1, niter
           sumdiff = (ss_temp(ill) + ss_temp(ilh) + &
                      ss_temp(irl) + ss_temp(irh)) - 4.0d0*a(i,j)
           sgndiff = sign(1.d0, sumdiff)

           do m = 1, 4
              diff(m) = (ss_temp(m) - a(i,j))*sgndiff
           enddo

           kdp = 0

           do m = 1, 4
              if (diff(m) > eps) kdp = kdp + 1
           enddo

           do m = 1, 4
              if (kdp < 1) then
                 div = 1.d0
              else
                 div = dble(kdp)
              endif

              if (diff(m) > eps) then
                 redfac = sumdiff*sgndiff/div
                 kdp = kdp-1
              else
                 redfac = 0.0d0
              endif

              if (sgndiff > 0.0d0) then
                 redmax = ss_temp(m) - min_ss(m)
              else
                 redmax = max_ss(m) - ss_temp(m)
              endif

              redfac = min(redfac, redmax)
              sumdiff = sumdiff - redfac*sgndiff
              ss_temp(m) = ss_temp(m) - redfac*sgndiff
           enddo
        enddo

        ! construct the final slopes
        A_x  = ((ss_temp(irh) + ss_temp(irl)) - &
                (ss_temp(ilh) + ss_temp(ill)))/2.0d0

        A_y  = ((ss_temp(ilh) + ss_temp(irh)) - &
                (ss_temp(ill) + ss_temp(irl)))/2.0d0

        !A_xy = ((ss_temp(irh) - ss_temp(irl)) - &
        !        (ss_temp(ilh) - ss_temp(ill)))/(dx*dy)

        ! now construct the limited differences in x and y
        ldax(i,j) = A_x
        lday(i,j) = A_y

     enddo
  enddo

  deallocate(a_nd)

end subroutine multid_limit

!-----------------------------------------------------------------------------
! flatten
!-----------------------------------------------------------------------------
subroutine flatten(idir, p, u, xi, qx, qy, ng, smallp, delta, z0, z1)

  ! 1-d flattening near shocks
  !
  ! flattening kicks in behind strong shocks and reduces the
  ! reconstruction to using piecewise constant slopes, making things
  ! first-order.  See Saltzman (1994) page 159 for this
  ! implementation.
  implicit none

  integer, intent(in) :: idir
  integer, intent(in) :: qx, qy, ng

  ! 0-based indexing to match python
  double precision, intent(inout) :: p(0:qx-1, 0:qy-1), u(0:qx-1, 0:qy-1)
  double precision, intent(  out) :: xi(0:qx-1, 0:qy-1)
  double precision, intent(in   ) :: smallp, delta, z0, z1

!f2py intent(in) :: idir
!f2py depend(qx, qy) :: p, u, xi
!f2py intent(in) :: p, u
!f2py intent(out) :: xi

! call this as: xi = reconstruction_f.flatten(1,p,u,qx,qy,ng,smallp,delta,z0,z1)

  integer :: ilo, ihi, jlo, jhi
  integer :: nx, ny
  integer :: i, j

  double precision :: test1, test2
  double precision :: dp, dp2, z

  nx = qx - 2*ng; ny = qy - 2*ng
  ilo = ng; ihi = ng+nx-1; jlo = ng; jhi = ng+ny-1

  xi(:,:) = 1.0d0

  select case (idir)

  case (1)

     do j = jlo-2, jhi+2
        do i = ilo-2, ihi+2

           dp  = abs(p(i+1,j) - p(i-1,j))
           dp2 = abs(p(i+2,j) - p(i-2,j))
           z = dp/max(dp2,smallp)

           test1 = u(i-1,j) - u(i+1,j)
           test2 = dp/min(p(i+1,j),p(i-1,j))

           if (test1 > 0.0d0 .and. test2 > delta) then
              xi(i,j) = min(1.0d0, max(0.0d0, 1.0d0 - (z - z0)/(z1 - z0)))
           else
              xi(i,j) = 1.0
           endif

        enddo
     enddo

  case (2)

     do j = jlo-2, jhi+2
        do i = ilo-2, ihi+2

           dp  = abs(p(i,j+1) - p(i,j-1))
           dp2 = abs(p(i,j+2) - p(i,j-2))
           z = dp/max(dp2,smallp)

           test1 = u(i,j-1) - u(i,j+1)
           test2 = dp/min(p(i,j+1),p(i,j-1))

           if (test1 > 0.0d0 .and. test2 > delta) then
              xi(i,j) = min(1.0d0, max(0.0d0, 1.0d0 - (z - z0)/(z1 - z0)))
           else
              xi(i,j) = 1.0
           endif

        enddo
     enddo

  end select

end subroutine flatten

!-----------------------------------------------------------------------------
! flatten_multid
!-----------------------------------------------------------------------------
subroutine flatten_multid(xi_x, xi_y, p, xi, qx, qy, ng)

  ! multi-dimensional flattening
  implicit none

  integer, intent(in) :: qx, qy, ng

  ! 0-based indexing to match python
  double precision, intent(inout) :: xi_x(0:qx-1, 0:qy-1)
  double precision, intent(inout) :: xi_y(0:qx-1, 0:qy-1)
  double precision, intent(inout) :: p(0:qx-1, 0:qy-1)
  double precision, intent(  out) :: xi(0:qx-1, 0:qy-1)

!f2py depend(qx, qy) :: xi_x, xi_y, p, xi
!f2py intent(in) :: xi_x, xi_y, p
!f2py intent(out) :: xi

! call this as: xi = reconstruction_f.flatten_multid(xi_x,xi_y,,p,qx,qy,ng)

  integer :: ilo, ihi, jlo, jhi
  integer :: nx, ny
  integer :: i, j

  integer :: sx, sy

  nx = qx - 2*ng; ny = qy - 2*ng
  ilo = ng; ihi = ng+nx-1; jlo = ng; jhi = ng+ny-1

  xi(:,:) = 1.0d0

  do j = jlo-2, jhi+2
     do i = ilo-2, ihi+2

        sx = int(sign(1.0d0, p(i+1,j) - p(i-1,j)))
        sy = int(sign(1.0d0, p(i,j+1) - p(i,j-1)))

        xi(i,j) = min(min(xi_x(i,j), xi_x(i-sx,j)), &
                      min(xi_y(i,j), xi_y(i,j-sy)))

     enddo
  enddo

end subroutine flatten_multid


Real Function sigma(srt, id, ioi, iof)
  Parameter (amu=0.9383, amp=0.1384, pi=3.1415926, hc=0.19733)
  Save
  If (id==1) Then
     amass0 = 1.22
     t0 = 0.12
  Else
     amass0 = 1.43
     t0 = 0.2
  End If
  If ((ioi==1) .And. (iof==1)) Then
     alfa = 3.772
     beta = 1.262
     am0 = 1.188
     t = 0.09902
  End If
  If ((ioi==1) .And. (iof==0)) Then
     alfa = 15.28
     beta = 0.
     am0 = 1.245
     t = 0.1374
  End If
  If ((ioi==0) .And. (iof==1)) Then
     alfa = 146.3
     beta = 0.
     am0 = 1.472
     t = 0.02649
  End If
  zplus = (srt-amu-amass0)*2./t0
  zminus = (amu+amp-amass0)*2./t0
  deln = atan(zplus) - atan(zminus)
  If (deln==0) deln = 1.E-06
  amass = amass0 + (t0/4.)*alog((1.+zplus**2)/(1.+zminus**2))/deln
  s = srt**2
  p2 = s/4. - amu**2
  s0 = (amu+am0)**2
  p02 = s0/4. - amu**2
  p0 = sqrt(p02)
  pr2 = (s-(amu-amass)**2)*(s-(amu+amass)**2)/(4.*s)
  If (pr2>1.E-06) Then
     pr = sqrt(pr2)
  Else
     pr = 0.
     sigma = 1.E-06
     Return
  End If
  ss = amass**2
  q2 = (ss-(amu-amp)**2)*(ss-(amu+amp)**2)/(4.*ss)
  If (q2>1.E-06) Then
     q = sqrt(q2)
  Else
     q = 0.
     sigma = 1.E-06
     Return
  End If
  ss0 = am0**2
  q02 = (ss0-(amu-amp)**2)*(ss0-(amu+amp)**2)/(4.*ss0)
  scheck = q02
  If (scheck<0) Then
     Write (99, *) 'scheck20: ', scheck
     scheck = 0.
  End If
  q0 = sqrt(scheck)
  sigma = pi*(hc)**2/(2.*p2)*alfa*(pr/p0)**beta*am0**2*t**2*(q/q0)**3/((ss-am0**2)**2+am0**2*t**2)
  sigma = sigma*10.
  If (sigma==0) sigma = 1.E-06
  Return
End Function sigma


module razdol
  implicit none
  private
  public razd
  public raz2

contains
  pure function deriv(n, w, c, phi, u, alpha, b, h, f, e, t) result(mu)
    integer, intent(in) :: n
    real, dimension(n), intent(in) :: w, c, phi, u, alpha, b
    real, intent(in) :: h(n+1), f
    real, dimension(n+1), intent(in) :: e, t
    integer :: i, j
    real, dimension(n+1) :: de, dt
    real :: cosa2, mu, tana, tanp

    de = 0
    dt = 0
    do i = 2, n + 1
      j = i - 1
      cosa2 = cos(alpha(j))**2
      tana = tan(alpha(j))
      tanp = tan(phi(j))
      de(i) = cosa2 * (6. * f * dt(j) * (f * tana - tanp)&
            + (2. * b(j) * w(j) * h(j) + b(j) * w(j) * h(i)&
            + 6. * t(j) - 6. * e(j) * tana) * tanp + 3. * b(j) / cosa2&
            * (c(j) - u(j) * tanp) + 3. * f * de(j)&
            * (f - f * tana**2 + 2. * tana * tanp))
      de(i) = de(i) / (3. * f**2)
      dt(i) = (de(i) + de(j)) * tana - dt(j)
    end do
    i = maxloc(e, 1)
    mu = (de(i) * e(n+1) - de(n+1) * e(i)) / e(i)**2
  end function

  pure subroutine razd(f, wa, fval, fderiv)
    integer, parameter :: nwa = 7
    real, intent(in) :: f, wa(:)
    real, intent(out) :: fval, fderiv
    real, dimension(size(wa)/nwa+1) :: e, t
    real :: mu
    integer :: n

    n = size(wa) / nwa
    associate(w => wa(:n),&
      c => wa(n+1:2*n),&
      phi => wa(2*n+1:3*n),&
      u => wa(3*n+1:4*n),&
      alpha => wa(4*n+1:5*n),&
      b => wa(5*n+1:6*n),&
      h => wa(6*n+1:))

      call raz2(n, w, c, phi, u, alpha, b, h, f, e, t, mu)
      fval = mu - 1.
      fderiv = deriv(n, w, c, phi, u, alpha, b, h, f, e, t)
    end associate
  end subroutine

  pure subroutine raz2(n, w, c, phi, u, alpha, b, h, f, e, t, mu, p0)
    integer, intent(in) :: n
    real, dimension(n), intent(in) :: w, c, phi, u, alpha, b
    real, intent(in) :: h(n+1), f
    real, dimension(n+1), intent(out) :: e, t
    real, intent(out) :: mu
    real, optional, intent(in) :: p0
    integer :: i, j
    real :: phim, tana, tana2

    e = 0
    t = 0
    if(present(p0)) then
      e(1) = p0
      t(1) = p0
    end if

    do i = 2, n + 1
      j = i - 1
      tana = tan(alpha(j))
      tana2 = tana**2
      phim = tan(phi(j)) / f
      e(i) = 2. * t(j) * (tana - phim) + e(j) * (1. + 2. * tana * phim - tana2)&
           + w(j) * b(j) / 3. * (h(i) + 2. * h(j)) * (tana - phim)&
           - b(j) * (1. + tana2) * (c(j) / f - u(j) * phim)
      e(i) = e(i) / (1. + tana2)
      t(i) = (e(i) + e(j)) * tana - t(j) + w(j) * b(j) / 6. * (h(i) - h(j))
    end do
    mu = 1. - e(n+1) / maxval(e)
  end subroutine
end module


      SUBROUTINE CLUAGG(METHOD,X,NX,N,NATT,MERGE,DISP,IWORK,WORK,NW)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C*  VERSION 3.02  MARCH 1997                                           *
C*  * Implement single-link and complete-link clustering               *
C*                                                                     *
C***********************************************************************
C
C  CLUSTER ANALYSIS BY ANY OF SEVERAL AGGLOMERATIVE HIERARCHICAL METHODS
C
C  PARAMETERS OF ROUTINE:
C  METHOD * INPUT* CLUSTERING METHOD. SHOULD BE SET TO:
C                   1 FOR SINGLE-LINK CLUSTERING
C                   2 FOR COMPLETE-LINK CLUSTERING
C                   3 FOR WARD'S PROCEDURE
C  X      * INPUT* ARRAY OF DIMENSION (NX,NATT).  X(I,J) SHOULD CONTAIN
C                  THE J'TH ATTRIBUTE FOR THE I'TH DATA POINT.
C  NX     * INPUT* THE FIRST DIMENSION OF ARRAY X, AS DECLARED IN THE
C                  CALLING PROGRAM.
C  N      * INPUT* NUMBER OF DATA POINTS
C  NATT   * INPUT* NUMBER OF ATTRIBUTES FOR EACH DATA POINT
C  MERGE  *OUTPUT* ARRAY OF DIMENSION (2,N). MERGE(1,I) AND MERGE(2,I)
C                  ARE THE LABELS OF THE CLUSTERS MERGED AT THE I'TH
C                  STAGE.  MERGE(1,N) AND MERGE(2,N) ARE NOT USED.
C  DISP   *OUTPUT* ARRAY OF LENGTH N.  DISP(I) IS A MEASURE OF THE
C                  WITHIN-CLUSTER DISPERSION AFTER THE I'TH MERGE.
C                  DISPERSION IS DEFINED DIFFERENTLY FOR EACH METHOD:
C                  SEE BELOW.  DISP(N) IS NOT USED.
C  IWORK  * LOCAL* WORK ARRAY OF LENGTH N
C  WORK   * LOCAL* WORK ARRAY OF LENGTH NW
C  NW     * INPUT* LENGTH OF ARRAY WORK. MUST BE AT LEAST N*(N-1)/2.
C
C  Agglomerative hierarchical clustering: general description.
C  Initially there are N clusters, each containing one data point,
C  labeled 1 through N in the same order as the data points.  At each
C  stage of clustering, two clusters are merged.  Their labels are saved
C  in the MERGE array.  The smaller of the two labels is used as the
C  label of the merged cluster.  After the Mth stage of clustering
C  there are N-M clusters.  To find which data points belong to which
C  clusters, use routine CLUINF.
C
C  Single-link clustering: the distance between two clusters A and B is
C  defined to be the minimum of the Euclidean distances between pairs of
C  points with one point in A and one in B.  At each stage, the two
C  clusters separated by the smallest distance are merged.  The square
C  of this distance is saved in the corresponding element of array DISP.
C
C  Complete-link clustering: the distance between two clusters A and B
C  is defined to be the maximum of the Euclidean distances between pairs
C  of points with one point in A and one in B.  At each stage, the two
C  clusters separated by the smallest distance are merged.  The square
C  of this distance is saved in the corresponding element of array DISP.
C  DISP(I) is therefore the largest squared Euclidean distance between
C  two points that are in the same cluster after the Ith merge.
C
C  Ward's procedure: at each stage, the clusters that are merged are
C  chosen to minimize the within-cluster sum of squared deviations of
C  each attribute about the cluster mean.  This sum of squares is saved
C  in the corresponding element of array DISP.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION X(NX,NATT),DISP(N),WORK(NW)
      INTEGER MERGE(2,N),IWORK(N)
      DATA ZERO/0D0/,HALF/0.5D0/
C
C         BIG IS A LARGE NUMBER, USED TO INITIALIZE THE SEARCH CRITERION
C
      DATA BIG/1D72/
C
      NWREQ=N*(N-1)/2
      IF(NW.LT.NWREQ)GOTO 1000
C
C         INITIALLY THERE ARE N CLUSTERS, EACH CONTAINING ONE DATA
C         POINT.  COMPUTE THE COST (INCREASE IN DISPERSION) OF MERGING
C         EACH PAIR OF CLUSTERS.
C
      IW=0
      DO 20 J=2,N
      DO 20 I=1,J-1
      SUM=ZERO
      DO 10 IATT=1,NATT
   10 SUM=SUM+(X(I,IATT)-X(J,IATT))**2
      IW=IW+1
      WORK(IW)=SUM
   20 CONTINUE
      DO 30 I=1,N
   30 IWORK(I)=1
      CCOST=ZERO
C
C         START OF MAIN LOOP
C
      DO 100 IMERGE=1,N-1
C
C         FIND THE PAIR OF CLUSTERS WITH THE LOWEST COST OF MERGING
C
      COST=BIG
      DO 50 J=2,N
      IF(IWORK(J).EQ.0)GOTO 50
      IORIG=(J-1)*(J-2)/2
      DO 40 I=1,J-1
      IF(IWORK(I).EQ.0)GOTO 40
      LIJ=IORIG+I
      IF(WORK(LIJ).GE.COST)GOTO 40
      COST=WORK(LIJ)
      II=I
      JJ=J
   40 CONTINUE
   50 CONTINUE
C
C         MERGE THEM
C
      MERGE(1,IMERGE)=II
      MERGE(2,IMERGE)=JJ
      IF(METHOD.EQ.1.OR.METHOD.EQ.2)DISP(IMERGE)=COST
      IF(METHOD.EQ.3)CCOST=CCOST+COST
      IF(METHOD.EQ.3)DISP(IMERGE)=HALF*CCOST
C
C         COMPUTE THE COST OF MERGING THE NEW CLUSTER WITH EACH OF THE
C         OTHERS
C
      NI=IWORK(II)
      NJ=IWORK(JJ)
      NIJ=NI+NJ
      DO 60 KK=1,N
      NK=IWORK(KK)
      IF(NK.EQ.0)GOTO 60
      IF(KK.EQ.II.OR.KK.EQ.JJ)GOTO 60
      MM=MAX0(II,KK)
      M =MIN0(II,KK)
      IK=(MM-1)*(MM-2)/2+M
      MM=MAX0(JJ,KK)
      M =MIN0(JJ,KK)
      JK=(MM-1)*(MM-2)/2+M
      IF(METHOD.EQ.1)WORK(IK)=DMIN1(WORK(IK),WORK(JK))
      IF(METHOD.EQ.2)WORK(IK)=DMAX1(WORK(IK),WORK(JK))
      IF(METHOD.EQ.3)
     *  WORK(IK)=((NI+NK)*WORK(IK)+(NJ+NK)*WORK(JK)-NK*COST)/(NIJ+NK)
   60 CONTINUE
      IWORK(II)=NIJ
      IWORK(JJ)=0
C
C         END OF MAIN LOOP
C
  100 CONTINUE
C
      RETURN
C
 1000 WRITE(6,7000)NWREQ
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE CLUAGG : INSUFFICIENT WORKSPACE.',
     *  ' LENGTH OF WORK ARRAY SHOULD BE AT LEAST ',I8)
C
      END