      SUBROUTINE slPLMO ( ELONGM, PHIM, XP, YP, ELONG, PHI, DAZ )
*+
*     - - - - - -
*      P L M O
*     - - - - - -
*
*  Polar motion:  correct site longitude and latitude for polar
*  motion and calculate azimuth difference between celestial and
*  terrestrial poles.
*
*  Given:
*     ELONGM   d      mean longitude of the observer (radians, east +ve)
*     PHIM     d      mean geodetic latitude of the observer (radians)
*     XP       d      polar motion x-coordinate (radians)
*     YP       d      polar motion y-coordinate (radians)
*
*  Returned:
*     ELONG    d      true longitude of the observer (radians, east +ve)
*     PHI      d      true geodetic latitude of the observer (radians)
*     DAZ      d      azimuth correction (terrestrial-celestial, radians)
*
*  Notes:
*
*   1)  "Mean" longitude and latitude are the (fixed) values for the
*       site's location with respect to the IERS terrestrial reference
*       frame;  the latitude is geodetic.  TAKE CARE WITH THE LONGITUDE
*       SIGN CONVENTION.  The longitudes used by the present routine
*       are east-positive, in accordance with geographical convention
*       (and right-handed).  In particular, note that the longitudes
*       returned by the slOBS routine are west-positive, following
*       astronomical usage, and must be reversed in sign before use in
*       the present routine.
*
*   2)  XP and YP are the (changing) coordinates of the Celestial
*       Ephemeris Pole with respect to the IERS Reference Pole.
*       XP is positive along the meridian at longitude 0 degrees,
*       and YP is positive along the meridian at longitude
*       270 degrees (i.e. 90 degrees west).  Values for XP,YP can
*       be obtained from IERS circulars and equivalent publications;
*       the maximum amplitude observed so far is about 0.3 arcseconds.
*
*   3)  "True" longitude and latitude are the (moving) values for
*       the site's location with respect to the celestial ephemeris
*       pole and the meridian which corresponds to the Greenwich
*       apparent sidereal time.  The true longitude and latitude
*       link the terrestrial coordinates with the standard celestial
*       models (for precession, nutation, sidereal time etc).
*
*   4)  The azimuths produced by slAOP and slAOPQ are with
*       respect to due north as defined by the Celestial Ephemeris
*       Pole, and can therefore be called "celestial azimuths".
*       However, a telescope fixed to the Earth measures azimuth
*       essentially with respect to due north as defined by the
*       IERS Reference Pole, and can therefore be called "terrestrial
*       azimuth".  Uncorrected, this would manifest itself as a
*       changing "azimuth zero-point error".  The value DAZ is the
*       correction to be added to a celestial azimuth to produce
*       a terrestrial azimuth.
*
*   5)  The present routine is rigorous.  For most practical
*       purposes, the following simplified formulae provide an
*       adequate approximation:
*
*       ELONG = ELONGM+XP*COS(ELONGM)-YP*SIN(ELONGM)
*       PHI   = PHIM+(XP*SIN(ELONGM)+YP*COS(ELONGM))*TAN(PHIM)
*       DAZ   = -SQRT(XP*XP+YP*YP)*COS(ELONGM-ATAN2(XP,YP))/COS(PHIM)
*
*       An alternative formulation for DAZ is:
*
*       X = COS(ELONGM)*COS(PHIM)
*       Y = SIN(ELONGM)*COS(PHIM)
*       DAZ = ATAN2(-X*YP-Y*XP,X*X+Y*Y)
*
*   Reference:  Seidelmann, P.K. (ed), 1992.  "Explanatory Supplement
*               to the Astronomical Almanac", ISBN 0-935702-68-7,
*               sections 3.27, 4.25, 4.52.
*
*  P.T.Wallace   Starlink   30 November 2000
*
*  Copyright (C) 2000 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program 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 General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION ELONGM,PHIM,XP,YP,ELONG,PHI,DAZ

      DOUBLE PRECISION SEL,CEL,SPH,CPH,XM,YM,ZM,XNM,YNM,ZNM,
     :                 SXP,CXP,SYP,CYP,ZW,XT,YT,ZT,XNT,YNT

*  Site mean longitude and mean geodetic latitude as a Cartesian vector
      SEL=SIN(ELONGM)
      CEL=COS(ELONGM)
      SPH=SIN(PHIM)
      CPH=COS(PHIM)

      XM=CEL*CPH
      YM=SEL*CPH
      ZM=SPH

*  Rotate site vector by polar motion, Y-component then X-component
      SXP=SIN(XP)
      CXP=COS(XP)
      SYP=SIN(YP)
      CYP=COS(YP)

      ZW=(-YM*SYP+ZM*CYP)

      XT=XM*CXP-ZW*SXP
      YT=YM*CYP+ZM*SYP
      ZT=XM*SXP+ZW*CXP

*  Rotate also the geocentric direction of the terrestrial pole (0,0,1)
      XNM=-SXP*CYP
      YNM=SYP
      ZNM=CXP*CYP

      CPH=SQRT(XT*XT+YT*YT)
      IF (CPH.EQ.0D0) XT=1D0
      SEL=YT/CPH
      CEL=XT/CPH

*  Return true longitude and true geodetic latitude of site
      IF (XT.NE.0D0.OR.YT.NE.0D0) THEN
         ELONG=ATAN2(YT,XT)
      ELSE
         ELONG=0D0
      END IF
      PHI=ATAN2(ZT,CPH)

*  Return current azimuth of terrestrial pole seen from site position
      XNT=(XNM*CEL+YNM*SEL)*ZT-ZNM*CPH
      YNT=-XNM*SEL+YNM*CEL
      IF (XNT.NE.0D0.OR.YNT.NE.0D0) THEN
         DAZ=ATAN2(-YNT,-XNT)
      ELSE
         DAZ=0D0
      END IF

      END


************************************************************************
*
*     Subroutine AMLREG            Called by: AMLLOAD2, CALIBR, ESTCAL
*
*     compute nearly-unbiased AMLE parameter estimates
*
*     First-order bias is eliminated for S^2, not S.  Results are
*     equivalent to OLS estimates if there is no censoring (second-
*     order adjustment is made to eliminate first-order bias to
*     guarantee this result).
*
*     Parameter results are for the first NPAR parameters, followed by
*     S**2, the estimated variance of the residuals.  The standard
*     covariances wrt S**2 are given in CV, wrt S in SCV.
*
*     local vars
*     ----------
*     CV_A     Adj. Max. Likelihood Est. of the covariance matrix
*              w.r.t. S**2
*
************************************************************************
      SUBROUTINE AMLREG(NOBSC,NPAR,XLCAL,YLCAL,YD,CENSFLAG,XLIKE,STDDEV,
     &                  PARMLE,PARAML,BIAS,CV,SBIAS,SCV,CV_M,NOBSCI)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      LOGICAL CENSFLAG(*)
      INTEGER*4 NOBSC,NOBSCI,NPAR
      DOUBLE PRECISION XLIKE
      DOUBLE PRECISION BIAS(*),PARAML(*),PARMLE(*),SBIAS(*),STDDEV(*),
     &                 YD(*),YLCAL(*)
      DOUBLE PRECISION CV(MAXPARMS+1,*),CV_M(MAXPARMS+1,*),
     &                 SCV(MAXPARMS+1,*),XLCAL(NOBSCI,*)
*
*     local vars
*
      INTEGER*4 K1,K2,K3,I,K,IK1,IK2,IK3,J,L
      DOUBLE PRECISION S,S2_M,S3_M,S3_A
      DOUBLE PRECISION CV_A(MAXPARMS+1,MAXPARMS+1),
     &                 H2(MAXPARMS+1,MAXPARMS+1),HK2(2,2),
     &                 SH2(MAXPARMS+1,MAXPARMS+1),SHK2(2,2),
     &                 X(NOBSCI,MAXPARMS+1)
      DOUBLE PRECISION H3(MAXPARMS+1,MAXPARMS+1,MAXPARMS+1),
     &                 H3S(MAXPARMS+1,MAXPARMS+1,MAXPARMS+1),
     &                 HK3(2,2,2),HK3S(2,2,2),
     &                 SH3(MAXPARMS+1,MAXPARMS+1,MAXPARMS+1),
     &                 SH3S(MAXPARMS+1,MAXPARMS+1,MAXPARMS+1),
     &                 SHK3(2,2,2),SHK3S(2,2,2)
*
*     function declaration
*
      DOUBLE PRECISION PRED
*
*
*
      DO 20 K1=1,NOBSC
         X(K1,NPAR+1) = 1.D0
         DO 10 K2 =1,NPAR
            X(K1,K2) = XLCAL(K1,K2)
 10      CONTINUE
 20   CONTINUE

      CALL TACIT_R(NOBSC,NPAR,YLCAL,YD,X,PARMLE,XLIKE,CENSFLAG,NOBSCI)

      S = PARMLE(NPAR+1)
      PARMLE(NPAR+1) = S**2

      DO 50 K1=1,NPAR+1
         DO 40 K2=1,NPAR+1
            H2(K1,K2) = 0.D0
            SH2(K1,K2) = 0.D0
            DO 30 K3=1,NPAR+1
               H3(K1,K2,K3) = 0.D0
               SH3(K1,K2,K3) = 0.D0
               H3S(K1,K2,K3) = 0.D0
               SH3S(K1,K2,K3) = 0.D0
 30         CONTINUE
 40      CONTINUE
 50   CONTINUE

      DO 100 I=1,NOBSC
         CALL TACIT_D((YD(I)-PRED(NPAR,NOBSCI,I,X,PARMLE))
     &                / S,SHK2,SHK3,SHK3S,HK2,HK3,HK3S)
*
*        H vars identify CV's corresponding to S**1; S vars identify
*        terms corresponding to S**2
*
         DO 90 K1=1,NPAR+1
            IK1 = 1 + K1/(NPAR+1)
            DO 80 K2=1,NPAR+1
               IK2 = 1 + K2/(NPAR+1)
               H2(K1,K2) = H2(K1,K2) - HK2(IK1,IK2)*X(I,K1)*X(I,K2)
               SH2(K1,K2) = SH2(K1,K2) - SHK2(IK1,IK2)*X(I,K1)*X(I,K2)
               DO 70 K3=1,NPAR+1
                  IK3 = 1 + K3/(NPAR+1)
                  H3(K1,K2,K3) = H3(K1,K2,K3)
     &                    + HK3(IK1,IK2,IK3)*X(I,K1)*X(I,K2)*X(I,K3)
                  H3S(K1,K2,K3) = H3S(K1,K2,K3)
     &                    + HK3S(IK1,IK2,IK3)*X(I,K1)*X(I,K2)*X(I,K3)
                  SH3(K1,K2,K3) = SH3(K1,K2,K3)
     &                    + SHK3(IK1,IK2,IK3)*X(I,K1)*X(I,K2)*X(I,K3)
                  SH3S(K1,K2,K3) = SH3S(K1,K2,K3)
     &                    + SHK3S(IK1,IK2,IK3)*X(I,K1)*X(I,K2)*X(I,K3)
 70            CONTINUE
 80         CONTINUE
 90      CONTINUE
 100  CONTINUE
*
*     invert matrices
*
      CALL MATINV(NPAR+1,H2,CV)
      CALL MATINV(NPAR+1,SH2,SCV)

      DO 140 I=1,NPAR+1
         BIAS(I) = 0.D0
         SBIAS(I) = 0.D0
         DO 130 J=1,NPAR+1
            DO 120 K=1,NPAR+1
               DO 110 L=1,NPAR+1
                  BIAS(I) = BIAS(I) + CV(I,J)*CV(K,L)
     &                               *(H3S(J,K,L)-H3(J,K,L)/2.D0)
                  SBIAS(I) = SBIAS(I) + SCV(I,J)*SCV(K,L)
     &                               *(SH3S(J,K,L)-SH3(J,K,L)/2.D0)
 110           CONTINUE
 120        CONTINUE
 130     CONTINUE
 140  CONTINUE

      DO 150 I=1,NPAR
         PARAML(I) = PARMLE(I) - S*BIAS(I)
 150   CONTINUE

      PARAML(NPAR+1) = S**2/(1.D0+BIAS(NPAR+1))
      S2_M = S**2
      S3_M = S**3
*
*     to get unbiased estimates of the powers of PARAML(NPAR+1), we
*     need to consider the variance of PARAML(NPAR+1)
*
      S3_A = PARAML(NPAR+1)**1.5D0/(1.D0+0.375D0*CV(NPAR+1,NPAR+1))
      CV_M(NPAR+1,NPAR+1) = S2_M*S2_M*CV(NPAR+1,NPAR+1)
      CV_A(NPAR+1,NPAR+1) = (PARAML(NPAR+1)**2
     &                  / (1.D0+CV(NPAR+1,NPAR+1)))
     &                  *CV(NPAR+1,NPAR+1)
      DO 170 I=1,NPAR
         CV_M(I,NPAR+1) = S3_M*CV(I,NPAR+1)
         CV_M(NPAR+1,I) = CV_M(I,NPAR+1)
         CV_A(I,NPAR+1) = S3_A*CV(I,NPAR+1)
         CV_A(NPAR+1,I) = CV_A(I,NPAR+1)
         DO 160 J=1,NPAR
            CV_M(I,J) = S2_M*CV(I,J)
            CV_A(I,J) = PARAML(NPAR+1)*CV(I,J)
 160     CONTINUE
         STDDEV(I) = SQRT(CV_A(I,I))
 170  CONTINUE

      STDDEV(NPAR+1) = SQRT(CV_A(NPAR+1,NPAR+1))
      RETURN
      END


    subroutine compresid
    use setup2d
    implicit none
    include 'mpif.h'

    integer :: is,js,ic,rfp
    double precision :: dFpsi(8),dGeta(8),dFvpsi(9),dGveta(9),Qs(9),&
    advect_u,advect_v

    call compflux

    do ic=1,NCELL

        ! need to find the flux derivatives at each solution pt

        do js=1,N
        do is=1,N

            Qs(1:9) = Q(1:9,is,js,ic)
            advect_u = Qs(2)/Qs(1)
            advect_v = Qs(3)/Qs(1)

            ! compute the dFdpsi derivative
            dFpsi(1:8) = 0.d0
            dFvpsi(1:9) = 0.d0
            do rfp=1,N+1
                dFpsi(1:8) = dFpsi(1:8) + F1(1:8,rfp,js,ic)*Mmat(rfp,is)
                if (vismode==1) then
                dFvpsi(1:9) = dFvpsi(1:9) + Fv1(1:9,rfp,js,ic)*Mmat(rfp,is)
                end if
            end do

            ! compute the dGdeta derivative
            dGeta(1:8) = 0.d0
            dGveta(1:9) = 0.d0
            do rfp=1,N+1
                dGeta(1:8) = dGeta(1:8) + G2(1:8,is,rfp,ic)*Mmat(rfp,js)
                if (vismode==1) then
                dGveta(1:9) = dGveta(1:9) + Gv2(1:9,is,rfp,ic)*Mmat(rfp,js)
                end if
            end do

            resid(1:8,is,js,ic) = -( dFpsi(1:8) + dGeta(1:8) )

            resid(9,is,js,ic) = -advect_u * nablaAs(1,is,js,ic) - &
            advect_v * nablaAs(2,is,js,ic)
            resid(9,is,js,ic) = resid(9,is,js,ic) * Jac(is,js,ic)

            if (vismode==1) then
                resid(1:9,is,js,ic) = resid(1:9,is,js,ic) + &
                (dFvpsi(1:9)+dGveta(1:9))
            end if

        end do
        end do

    end do

    do ic=1,NCELL
        do js=1,N
        do is=1,N
            resid(1:9,is,js,ic)=resid(1:9,is,js,ic)/Jac(is,js,ic)
        end do
        end do
    end do

    end subroutine compresid


subroutine vttab
!---- turbulent velocity broadening ---- !
  use types
  use dfcomm
  implicit none

  include 'common.turbpr'

  logical check
  integer iv, i
  real(kind=dp) v, sum

do iv=1, numvt
  v = ivt(iv)
  sum = 1.0d0
  check = .true.
  i = 0
  do while (check .and. i .lt. 120 )
    i = i + 1
    vtprof(i, iv) = exp(-(i / v *2.99792458e5 / 500000.)**2)
    sum = sum + vtprof(i,iv) * 2.
    if (vtprof(i, iv) < 1.e-5) check = .false.
  end do
  nvt(iv) = i
      do i = 1, nvt(iv)
        vtprof(i, iv) = vtprof(i, iv) / sum
      end do
   vtcenter(iv) = 1. / sum
   write(6, 7)iv, vtcenter(iv), (vtprof(i, iv), i = 1, nvt(iv))
7  format(i3,' km/s',10f10.7/(8x,10f10.7))
end do

return
end


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccc   SUBROUTINE TO WRITE CONSTRAINT ROWS TO G-MATRIX  ccc
ccc   2nd ORDER SMOOTHING CONTRAINTS APPEDNING TO G    ccc
ccc                                                    ccc
ccc    INPUT:  smo,nmod,nd                             ccc
ccc    OUTPUT: DV,WD,GB,nk                             ccc
ccc                                                    ccc
ccc    S. Wei, June 2013, edited from                  ccc
ccc      J. A. Conder and S.H.Pozgay's 2D version      ccc
ccc    Edited in Nov. 2015 to allow varying spacing    ccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      SUBROUTINE smoothg(smo,nmod,nd,DV,WD,GB,nk)

      parameter (nxmax = 45, nymax = 45, nzmax = 30)  ! max nodes
      integer nmod              ! model dimensions (as in calling prgm)
      integer nd                ! data dimensions (as in calling prgm)
      integer nk                ! number of new rows added here
      integer nnx, nny, nnz, nnxQ, nnyQ, nnzQ, nnzQ1D      ! model nodes
      real x(nxmax), z(nzmax), y(nymax)
      real xq(nxmax), zq(nzmax), yq(nymax), zq1D(nzmax), attin1D(nzmax)
      real smo,smleng,vu,vd,h   ! smoothing weight
      dimension GR(nmod)        ! row of GB
      dimension DV(nd)          ! data vector needed to be added
      dimension WD(nd)          ! weight vector needed to be added
      dimension GB(nd,nmod)     ! smooth matrix needed to be added
      real c0,cu,cd,cw,ce,cs,cn ! smoothing cefficients

      common /a/ x, y, z, xq, yq, zq
      common /b/ ipolar,nnx,nny,nnz,re,pi,r2d,nnxQ,nnyQ,nnzQ,nnzQ1D

      nk = 0
      c0 = 1.           ! smoothing constraints

cccc  INTERIOR NODES  cccc
      smleng = smo
      do i = 2, nnxQ-1
        do j = 2, nnyQ-1
          do k = 2, nnzQ-1
            do node = 1, nnxQ*nnyQ*nnzQ
              GR(node) = 0.
            enddo
            vu = abs(zq(k)-zq(k-1))
            vd = abs(zq(k)-zq(k+1))
            h  = abs(xq(i)-xq(i-1))
            cu = -c0/(h/vu+h/vd+4)*h/vu
            cd = -c0/(h/vu+h/vd+4)*h/vd
            cw = -c0/(h/vu+h/vd+4)
            ce = -c0/(h/vu+h/vd+4)
            cs = -c0/(h/vu+h/vd+4)
            cn = -c0/(h/vu+h/vd+4)
            GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
            GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
            GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
            GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
            GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
            GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
            GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
            nk = nk + 1
            DV(nk) = 0.
            WD(nk) = smleng
            do node = 1,nnxQ*nnyQ*nnzQ
              GB(nk,node) = GR(node)
            enddo
          enddo
        enddo
      enddo
      write(*,*) "Inter nodes"

cccc  SIDE NODES  cccc
      smleng = smo*7/6
      k = 1       ! top side
      do i = 2, nnxQ-1
        do j = 2, nnyQ-1
          do node = 1, nnxQ*nnyQ*nnzQ
            GR(node) = 0.
          enddo
          vd = abs(zq(k)-zq(k+1))
          h  = abs(xq(i)-xq(i-1))
          cd = -c0/(h/vd+4)*h/vd
          cw = -c0/(h/vd+4)
          ce = -c0/(h/vd+4)
          cs = -c0/(h/vd+4)
          cn = -c0/(h/vd+4)
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
          GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
          GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
          GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
          GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
          nk = nk + 1
          DV(nk) = 0.
          WD(nk) = smleng
          do node = 1,nnxQ*nnyQ*nnzQ
            GB(nk,node) = GR(node)
          enddo
        enddo
      enddo

      k = nnzQ    ! bottom side
      do i = 2, nnxQ-1
        do j = 2, nnyQ-1
          do node = 1, nnxQ*nnyQ*nnzQ
            GR(node) = 0.
          enddo
          vu = abs(zq(k)-zq(k-1))
          h  = abs(xq(i)-xq(i-1))
          cu = -c0/(h/vu+4)*h/vu
          cw = -c0/(h/vu+4)
          ce = -c0/(h/vu+4)
          cs = -c0/(h/vu+4)
          cn = -c0/(h/vu+4)
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
          GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
          GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
          GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
          GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
          nk = nk + 1
          DV(nk) = 0.
          WD(nk) = smleng
          do node = 1,nnxQ*nnyQ*nnzQ
            GB(nk,node) = GR(node)
          enddo
        enddo
      enddo

      i = 1       ! west side
      do j = 2, nnyQ-1
        do k = 2, nnzQ-1
          do node = 1, nnxQ*nnyQ*nnzQ
            GR(node) = 0.
          enddo
          vu = abs(zq(k)-zq(k-1))
          vd = abs(zq(k)-zq(k+1))
          h  = abs(xq(i)-xq(i+1))
          cu = -c0/(h/vu+h/vd+3)*h/vu
          cd = -c0/(h/vu+h/vd+3)*h/vd
          ce = -c0/(h/vu+h/vd+3)
          cs = -c0/(h/vu+h/vd+3)
          cn = -c0/(h/vu+h/vd+3)
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
          GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
          GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
          GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
          nk = nk + 1
          DV(nk) = 0.
          WD(nk) = smleng
          do node = 1,nnxQ*nnyQ*nnzQ
            GB(nk,node) = GR(node)
          enddo
        enddo
      enddo

      i = nnxQ     ! east side
      do j = 2, nnyQ-1
        do k = 2, nnzQ-1
          do node = 1, nnxQ*nnyQ*nnzQ
            GR(node) = 0.
          enddo
          vu = abs(zq(k)-zq(k-1))
          vd = abs(zq(k)-zq(k+1))
          h  = abs(xq(i)-xq(i-1))
          cu = -c0/(h/vu+h/vd+3)*h/vu
          cd = -c0/(h/vu+h/vd+3)*h/vd
          cw = -c0/(h/vu+h/vd+3)
          cs = -c0/(h/vu+h/vd+3)
          cn = -c0/(h/vu+h/vd+3)
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
          GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
          GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
          GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
          nk = nk + 1
          DV(nk) = 0.
          WD(nk) = smleng
          do node = 1,nnxQ*nnyQ*nnzQ
            GB(nk,node) = GR(node)
          enddo
        enddo
      enddo

      j = 1       ! south side
      do i = 2, nnxQ-1
        do k = 2, nnzQ-1
          do node = 1, nnxQ*nnyQ*nnzQ
            GR(node) = 0.
          enddo
          vu = abs(zq(k)-zq(k-1))
          vd = abs(zq(k)-zq(k+1))
          h  = abs(xq(i)-xq(i-1))
          cu = -c0/(h/vu+h/vd+3)*h/vu
          cd = -c0/(h/vu+h/vd+3)*h/vd
          cw = -c0/(h/vu+h/vd+3)
          ce = -c0/(h/vu+h/vd+3)
          cn = -c0/(h/vu+h/vd+3)
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
          GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
          GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
          GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
          nk = nk + 1
          DV(nk) = 0.
          WD(nk) = smleng
          do node = 1,nnxQ*nnyQ*nnzQ
            GB(nk,node) = GR(node)
          enddo
        enddo
      enddo

      j = nnyQ     ! north side
      do i = 2, nnxQ-1
        do k = 2, nnzQ-1
          do node = 1, nnxQ*nnyQ*nnzQ
            GR(node) = 0.
          enddo
          vu = abs(zq(k)-zq(k-1))
          vd = abs(zq(k)-zq(k+1))
          h  = abs(xq(i)-xq(i-1))
          cu = -c0/(h/vu+h/vd+3)*h/vu
          cd = -c0/(h/vu+h/vd+3)*h/vd
          cw = -c0/(h/vu+h/vd+3)
          ce = -c0/(h/vu+h/vd+3)
          cs = -c0/(h/vu+h/vd+3)
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
          GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
          GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
          GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
          GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
          nk = nk + 1
          DV(nk) = 0.
          WD(nk) = smleng
          do node = 1,nnxQ*nnyQ*nnzQ
            GB(nk,node) = GR(node)
          enddo
        enddo
      enddo
      write(*,*) "side nodes"

cccc  EDGE NODES  cccc
      smleng = smo*7/5

      j = 1       ! top-south edge
      k = 1
      do i = 2, nnxQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vd = abs(zq(k)-zq(k+1))
        h  = abs(xq(i)-xq(i-1))
        cd = -c0/(h/vd+3)*h/vd
        cw = -c0/(h/vd+3)
        ce = -c0/(h/vd+3)
        cn = -c0/(h/vd+3)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
        GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
        GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
        GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo

      j = nnyQ     ! top-north edge
      k = 1
      do i = 2, nnxQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vd = abs(zq(k)-zq(k+1))
        h  = abs(xq(i)-xq(i-1))
        cd = -c0/(h/vd+3)*h/vd
        cw = -c0/(h/vd+3)
        ce = -c0/(h/vd+3)
        cs = -c0/(h/vd+3)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
        GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
        GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
        GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo

      i = 1       ! top-west edge
      k = 1
      do j = 2, nnyQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vd = abs(zq(k)-zq(k+1))
        h  = abs(xq(i)-xq(i+1))
        cd = -c0/(h/vd+3)*h/vd
        ce = -c0/(h/vd+3)
        cs = -c0/(h/vd+3)
        cn = -c0/(h/vd+3)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
        GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
        GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
        GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo

      i = nnxQ     ! top-east edge
      k = 1
      do j = 2, nnyQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vd = abs(zq(k)-zq(k+1))
        h  = abs(xq(i)-xq(i-1))
        cd = -c0/(h/vd+3)*h/vd
        cw = -c0/(h/vd+3)
        cn = -c0/(h/vd+3)
        cs = -c0/(h/vd+3)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
        GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
        GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
        GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo

      j = 1       ! bottom-south edge
      k = nnzQ
      do i = 2, nnxQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vu = abs(zq(k)-zq(k-1))
        h  = abs(xq(i)-xq(i-1))
        cu = -c0/(h/vu+3)*h/vu
        cw = -c0/(h/vu+3)
        ce = -c0/(h/vu+3)
        cn = -c0/(h/vu+3)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
        GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
        GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
        GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo

      j = nnyQ     ! bottom-north edge
      k = nnzQ
      do i = 2, nnxQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vu = abs(zq(k)-zq(k-1))
        h  = abs(xq(i)-xq(i-1))
        cu = -c0/(h/vu+3)*h/vu
        cw = -c0/(h/vu+3)
        ce = -c0/(h/vu+3)
        cs = -c0/(h/vu+3)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
        GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
        GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
        GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo

      i = 1       ! bottom-west edge
      k = nnzQ
      do j = 2, nnyQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vu = abs(zq(k)-zq(k-1))
        h  = abs(xq(i)-xq(i+1))
        cu = -c0/(h/vu+3)*h/vu
        cs = -c0/(h/vu+3)
        ce = -c0/(h/vu+3)
        cn = -c0/(h/vu+3)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
        GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
        GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
        GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo

      i = nnxQ     ! bottom-east edge
      k = nnzQ
      do j = 2, nnyQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vu = abs(zq(k)-zq(k-1))
        h  = abs(xq(i)-xq(i-1))
        cu = -c0/(h/vu+3)*h/vu
        cw = -c0/(h/vu+3)
        cs = -c0/(h/vu+3)
        cn = -c0/(h/vu+3)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
        GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
        GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
        GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo

      i = 1       ! south-west edge
      j = 1
      do k = 2, nnzQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vu = abs(zq(k)-zq(k-1))
        vd = abs(zq(k)-zq(k+1))
        h  = abs(xq(i)-xq(i+1))
        cu = -c0/(h/vu+h/vd+2)*h/vu
        cd = -c0/(h/vu+h/vd+2)*h/vd
        ce = -c0/(h/vu+h/vd+2)
        cn = -c0/(h/vu+h/vd+2)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
        GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
        GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo

      i = nnxQ     ! south-east edge
      j = 1
      do k = 2, nnzQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vu = abs(zq(k)-zq(k-1))
        vd = abs(zq(k)-zq(k+1))
        h  = abs(xq(i)-xq(i-1))
        cu = -c0/(h/vu+h/vd+2)*h/vu
        cd = -c0/(h/vu+h/vd+2)*h/vd
        cn = -c0/(h/vu+h/vd+2)
        cw = -c0/(h/vu+h/vd+2)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
        GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
        GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo

      i = 1       ! north-west edge
      j = nnyQ
      do k = 2, nnzQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vu = abs(zq(k)-zq(k-1))
        vd = abs(zq(k)-zq(k+1))
        h  = abs(xq(i)-xq(i+1))
        cu = -c0/(h/vu+h/vd+2)*h/vu
        cd = -c0/(h/vu+h/vd+2)*h/vd
        ce = -c0/(h/vu+h/vd+2)
        cs = -c0/(h/vu+h/vd+2)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
        GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
        GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo

      i = nnxQ     ! north-east edge
      j = nnyQ
      do k = 2, nnzQ-1
        do node = 1, nnxQ*nnyQ*nnzQ
          GR(node) = 0.
        enddo
        vu = abs(zq(k)-zq(k-1))
        vd = abs(zq(k)-zq(k+1))
        h  = abs(xq(i)-xq(i-1))
        cu = -c0/(h/vu+h/vd+2)*h/vu
        cd = -c0/(h/vu+h/vd+2)*h/vd
        cw = -c0/(h/vu+h/vd+2)
        cs = -c0/(h/vu+h/vd+2)
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
        GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
        GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
        GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
        nk = nk + 1
        DV(nk) = 0.
        WD(nk) = smleng
        do node = 1,nnxQ*nnyQ*nnzQ
          GB(nk,node) = GR(node)
        enddo
      enddo
      write(*,*)"edge nodes"

cccc  CORNER NODES  cccc
      smleng = smo*7/4

      i = 1       ! top-south-west corner
      j = 1
      k = 1
      do node = 1, nnxQ*nnyQ*nnzQ
        GR(node) = 0.
      enddo
      vd = abs(zq(k)-zq(k+1))
      h  = abs(xq(i)-xq(i+1))
      cd = -c0/(h/vd+2)*h/vd
      ce = -c0/(h/vd+2)
      cn = -c0/(h/vd+2)
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
      GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
      GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
      nk = nk + 1
      DV(nk) = 0.
      WD(nk) = smleng
      do node = 1,nnxQ*nnyQ*nnzQ
        GB(nk,node) = GR(node)
      enddo

      i = 1       ! bottom-south-west corner
      j = 1
      k = nnzQ
      do node = 1, nnxQ*nnyQ*nnzQ
        GR(node) = 0.
      enddo
      vu = abs(zq(k)-zq(k-1))
      h  = abs(xq(i)-xq(i+1))
      cu = -c0/(h/vu+2)*h/vu
      ce = -c0/(h/vu+2)
      cn = -c0/(h/vu+2)
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
      GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
      GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
      nk = nk + 1
      DV(nk) = 0.
      WD(nk) = smleng
      do node = 1,nnxQ*nnyQ*nnzQ
        GB(nk,node) = GR(node)
      enddo

      i = 1       ! top-north-west corner
      j = nnyQ
      k = 1
      do node = 1, nnxQ*nnyQ*nnzQ
        GR(node) = 0.
      enddo
      vd = abs(zq(k)-zq(k+1))
      h  = abs(xq(i)-xq(i+1))
      cd = -c0/(h/vd+2)*h/vd
      ce = -c0/(h/vd+2)
      cs = -c0/(h/vd+2)
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
      GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
      GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
      nk = nk + 1
      DV(nk) = 0.
      WD(nk) = smleng
      do node = 1,nnxQ*nnyQ*nnzQ
        GB(nk,node) = GR(node)
      enddo

      i = 1       ! bottow-north-west corner
      j = nnyQ
      k = nnzQ
      do node = 1, nnxQ*nnyQ*nnzQ
        GR(node) = 0.
      enddo
      vu = abs(zq(k)-zq(k-1))
      h  = abs(xq(i)-xq(i+1))
      cu = -c0/(h/vu+2)*h/vu
      ce = -c0/(h/vu+2)
      cs = -c0/(h/vu+2)
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
      GR((i-1)*nnzQ*nnyQ+j*nnzQ+k) = ce          ! east node
      GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
      nk = nk + 1
      DV(nk) = 0.
      WD(nk) = smleng
      do node = 1,nnxQ*nnyQ*nnzQ
        GB(nk,node) = GR(node)
      enddo

      i = nnxQ     ! top-south-east corner
      j = 1
      k = 1
      do node = 1, nnxQ*nnyQ*nnzQ
        GR(node) = 0.
      enddo
      vd = abs(zq(k)-zq(k+1))
      h  = abs(xq(i)-xq(i-1))
      cd = -c0/(h/vd+2)*h/vd
      cw = -c0/(h/vd+2)
      cn = -c0/(h/vd+2)
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
      GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
      GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
      nk = nk + 1
      DV(nk) = 0.
      WD(nk) = smleng
      do node = 1,nnxQ*nnyQ*nnzQ
        GB(nk,node) = GR(node)
      enddo

      i = nnxQ     ! bottom-south-east corner
      j = 1
      k = nnzQ
      do node = 1, nnxQ*nnyQ*nnzQ
        GR(node) = 0.
      enddo
      vu = abs(zq(k)-zq(k-1))
      h  = abs(xq(i)-xq(i-1))
      cu = -c0/(h/vu+2)*h/vu
      cw = -c0/(h/vu+2)
      cn = -c0/(h/vu+2)
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
      GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
      GR(i*nnzQ*nnyQ+(j-1)*nnzQ+k) = cn          ! north node
      nk = nk + 1
      DV(nk) = 0.
      WD(nk) = smleng
      do node = 1,nnxQ*nnyQ*nnzQ
        GB(nk,node) = GR(node)
      enddo

      i = nnxQ     ! top-north-east corner
      j = nnyQ
      k = 1
      do node = 1, nnxQ*nnyQ*nnzQ
        GR(node) = 0.
      enddo
      vd = abs(zq(k)-zq(k+1))
      h  = abs(xq(i)-xq(i-1))
      cd = -c0/(h/vd+2)*h/vd
      cw = -c0/(h/vd+2)
      cs = -c0/(h/vd+2)
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k+1) = cd    ! lower node
      GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
      GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
      nk = nk + 1
      DV(nk) = 0.
      WD(nk) = smleng
      do node = 1,nnxQ*nnyQ*nnzQ
        GB(nk,node) = GR(node)
      enddo

      i = nnxQ     ! bottow-north-east corner
      j = nnyQ
      k = nnzQ
      do node = 1, nnxQ*nnyQ*nnzQ
        GR(node) = 0.
      enddo
      vu = abs(zq(k)-zq(k-1))
      h  = abs(xq(i)-xq(i-1))
      cu = -c0/(h/vu+2)*h/vu
      cw = -c0/(h/vu+2)
      cs = -c0/(h/vu+2)
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k) = c0      ! target node
      GR((i-1)*nnzQ*nnyQ+(j-1)*nnzQ+k-1) = cu    ! upper node
      GR((i-1)*nnzQ*nnyQ+(j-2)*nnzQ+k) = cw      ! west node
      GR((i-2)*nnzQ*nnyQ+(j-1)*nnzQ+k) = cs      ! south node
      nk = nk + 1
      DV(nk) = 0.
      WD(nk) = smleng
      do node = 1,nnxQ*nnyQ*nnzQ
        GB(nk,node) = GR(node)
      enddo

      END


      subroutine runY_0(i,j,f,Xtwiddle,Gtwiddle,Gtt,Shat1,Czero0,N0)
      implicit none
C---  Expression for Eq. 5.55
C---  Calculates D0, requires D00
C---  Small terms of order Xtwiddle(0,j)*Di
C---  Denominator Xtwiddle(i,j)
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,i,j,n,m,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np),f(np),
     . Gtt(np,np,np,np)
      double complex Shat1(np,-2:0),Czero0(-2:0),
     . bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gtt(i,n,j,m)*f(n)*Shat1(m,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=-4*Dv(dd00+N0,ep-1)
      Dv(dd0+N0,ep)=
     .  (Gtwiddle(i,j)*(2d0*Dv(dd00+N0,ep)+pole-Czero0(ep))
     . +bit+Xtwiddle(0,j)*Dv(di(i)+N0,ep))/Xtwiddle(i,j)
      enddo

c      write(6,*) 'Dv(dd0)',Dv(dd0+N0,-2),Dv(dd0+N0,-1),Dv(dd0+N0,0)
c      write(6,*) 'bit',Dv(dd0+N0,-2),Dv(dd0+N0,-1),Dv(dd0+N0,0)

      return
      end


        implicit real *8 (a-h,o-z)
        complex *16 z,j0,ima,ztest(1000 000),jtest(1000 000),
     1    jtest2(1000 000),jntest(10 000),nu
        real *8 jtestr(1000 0000),rerrors(10),
     1      jtesti(1000 0000),xtest(1000 0000),ytest(1000 0000)
        data ima/(0.0d0,1.0d0)/

        call prini(6,13)

        n=100

        ntest=100 000
        OPEN(UNIT=66,FILE="../mathematica/xntest.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) xtest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/yntest.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) ytest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/jntestr.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtestr(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/jntesti.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtesti(i)
        enddo
        close(66)

        do i=1,ntest
           ztest(i)=xtest(i)+ima*ytest(i)
        enddo

        do i=1,ntest
           jtest(i)=jtestr(i)+ima*jtesti(i)
           nu=3*(ztest(i)/2)**(2.0d0/3)
           jtest(i)=jtest(i)*exp(-nu)
        enddo

        ifexpon=1
        t1=second()
        do i=1,ntest
c           call abramns(ztest(i),jntest,n,ifexpon)
c           jtest2(i)=jntest(n+1)
           call abramn(ztest(i),jtest2(i),n,ifexpon)
        enddo
        t2=second()
        call prin2('evaluation time of J_n=*',t2-t1,1)

cccc        t1=second()
cccc        do i=1,ntest
cccc           j0=exp(ztest(i))
cccc        enddo
cccc        t2=second()
cccc        call prin2('evaluation time of complex exponentials=*',t2-t1,1)

        dmax=0
        imax=0
        do i=1,ntest
           dd=abs((jtest(i)-jtest2(i))/jtest(i))
           if (dd .gt. 1d-14) then
              print *, dd, ztest(i)
           endif
           az=abs(ztest(i))
           if (az .lt. 1) then
              if (rerrors(1) .lt. dd) then
                 rerrors(1) = dd
              endif
           elseif (az .ge. 1 .and. az .lt. 3) then
              if (rerrors(2) .lt. dd) then
                 rerrors(2) = dd
              endif
           elseif (az .ge. 3 .and. az .lt. 15) then
              if (rerrors(3) .lt. dd) then
                 rerrors(3) = dd
              endif
           elseif (az .ge. 15 .and. az .lt. 120) then
              if (rerrors(4) .lt. dd) then
                 rerrors(4) = dd
              endif
           elseif (az .gt. 120) then
              if (rerrors(5) .lt. dd) then
                 rerrors(5) = dd
              endif
           endif

           if (dmax .lt. dd) then
              dmax=dd
              imax=i
           endif
        enddo

        print *, 'maximum relative error = ', dmax
        print *, 'occured at ', ztest(imax), imax
        print *, 'true value = ', jtest(imax)
        print *, 'computed value = ', jtest2(imax)

        print *, 'done with testing J_n'

        write(31,*) '{S} &  ${Q_1}$ &  ${Q_2}$ &  ${Q_3}$ & {A}\\'
 1600   format(4(2x,ES8.2,'&'), 2x, ES8.2, '\\')
        write(31,1600) (rerrors(j), j=1,5)

        stop
        end


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE EPSCALC ( ISUB )

! Calculates, and prints, EPSILON, an indicator of numerical accuracy in the soln for UA:

!   EPSILON = UL(t)*[ PL - KLL*UL ]/[ UL(t)*PL ],  UL: displ's, PL: loads, KLL: stiff matrix for the L-set

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, NDOFL, NTERM_KLl, WARN_ERR
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  EPSCALC_BEGEND
      USE CONSTANTS_1, ONLY           :  ONE
      USE PARAMS, ONLY                :  EPSIL, SUPINFO, SUPWARN
      USE MACHINE_PARAMS, ONLY        :  MACH_SFMIN
      USE LAPACK_DPB_MATRICES, ONLY   :  RES
      USE SPARSE_MATRICES, ONLY       :  I_KLL, J_KLL, KLL
      USE SPARSE_MATRICES, ONLY       :  SYM_KLL
      USE COL_VECS, ONLY              :  UL_COL, PL_COL
      USE LAPACK_BLAS_AUX

      USE EPSCALC_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'EPSCALC'

      INTEGER(LONG), INTENT(IN)       :: ISUB              ! Internal subcase no. (1 to NSUB)
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = EPSCALC_BEGEND

      REAL(DOUBLE) , PARAMETER        :: ALPHA     =  ONE  ! Scalar multiplier for KLL in calc'ing residual vector, RES
      REAL(DOUBLE) , PARAMETER        :: BETA      = -ONE  ! Scalar multiplier for PL in calc'ing residual vector, RES
      REAL(DOUBLE)                    :: DEN               ! Denominator in EPSILON calculation
      REAL(DOUBLE)                    :: EPSILON           ! The indicator of numerical accuracy of the displ soln, UL
      REAL(DOUBLE)                    :: KU(NDOFL)         ! Result of multiplying KLL and UL_COL
      REAL(DOUBLE)                    :: NUM               ! Numerator in EPSILON calculation

      INTRINSIC                       :: DABS

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Calculate residual vector. First, multiply KLL x UL_COL and then add -PL_COL:

      CALL MATMULT_SFF ( 'KLL', NDOFL, NDOFL, NTERM_KLL, SYM_KLL, I_KLL, J_KLL, KLL, 'UL_COL', NDOFL, 1, UL_COL, 'Y',             &
                         'KLL*UL_COL',  ONE, KU )
      CALL MATADD_FFF  ( KU, PL_COL, NDOFL, 1, ALPHA, BETA, 0, RES )

! Calculate dot product of UL displ vector and RES residual vector

      NUM = DDOT (NDOFL, UL_COL, 1, RES, 1)

! Calculate dot product of UL displ vector and PL load vector

      DEN = DDOT (NDOFL, UL_COL, 1, PL_COL, 1)

! Calculate EPSILON and print

      IF (DABS(DEN) > MACH_SFMIN) THEN
         EPSILON = NUM/DEN
         WRITE(F06,3701) ISUB,EPSILON
      ELSE
         WARN_ERR = WARN_ERR + 1
         WRITE(F06,3702) ISUB, DEN, MACH_SFMIN
      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
 3701 FORMAT(' *INFORMATION: FOR INTERNAL SUBCASE NUMBER ',I8,' EPSILON ERROR ESTIMATE            = ',1ES13.6,                     &
                           ' Based on U''*(K*U - P)/(U''*P)',/)

 3702 FORMAT(' *WARNING    : CANNOT CALCULATE EPSILON ERROR ESTIMATE FOR INTERNAL SUBCASE NUMBER ',I8                              &
                    ,/,14X,' THE DOT PRODUCT OF DISPL AND LOAD VECTORS                     = ',1ES15.6,' CANNOT BE INVERTED.'      &
                    ,/,14X,' IT IS TOO SMALL COMPARED TO MACHINE SAFE MINIMUM (MACH_SFMIN) = ',1ES15.6,/)

! **********************************************************************************************************************************

      END SUBROUTINE EPSCALC