      subroutine gwhcfa(akmat1,delxi,dxsm11,hhcvec,nord,nordmx,
     $ nrd1mx,whcfac,xhcvec)
c
c     This subroutine computes the w factor (whcfac), which is
c     required for higher-order (stiff) ODE corrections. Logically,
c     w = g dot FCh where g and h are vectors, and (FC) is the matrix
c     required to convert finite differences utilizing the new point
c     of reaction progress to derivatives at the base point. This
c     factor depends only on the recent step size history, including
c     the current step size (delxi).
c
c     This subroutine is called by:
c
c       EQ6/path.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       akmat1 = the (FC) matrix
c       delxi  = the current step size
c       dxsm11 = the array of cumulative step sizes going back from
c                  new point, centered on the new point
c       nord   = the order of the finite difference method
c       nordmx = the maximum order of the finite difference method
c       nrd1mx = nordmx + 1
c       hhcvec = the h vector, here effectively work space
c       xhcvec = the FCh vector, here effectively work space
c
c     Principal output:
c
c       whcfac = the w factor
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nordmx,nrd1mx
c
      integer nord
c
      real*8 akmat1(nrd1mx,nrd1mx),dxsm11(nrd1mx),hhcvec(nordmx),
     $ xhcvec(nordmx)
c
      real*8 delxi,whcfac
c
c----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer i,j
c
      real(8) gx
c
c----------------------------------------------------------------------
c
c     First calculate h (hhcvec).
c
      hhcvec(1) = 1./delxi
      do j = 2,nord
        hhcvec(j) = hhcvec(j - 1)/dxsm11(j)
      enddo
c
c     Now calculate the (FCh) vector (xhcvec).
c
      do i = 1,nord
        xhcvec(i) = 0.
        do j = 1,nord
          xhcvec(i) = xhcvec(i) + akmat1(i,j)*hhcvec(j)
        enddo
      enddo
c
c     Finally, emulate w = g dot (FCh).
c
      whcfac = 0.
      gx = delxi
      do j = 1,nord
        gx = gx*delxi/(j + 1)
        whcfac = whcfac + gx*xhcvec(j)
      enddo
c
      end


C
C       $Id$
C
      SUBROUTINE SH3GRD (PX,PY,PZ,N,X,Y,Z,F,NR,LCELL,LNEXT,
     +                   XYZMIN,XYZDEL,RMAX,RSQ,A, Q,QX,QY,
     +                   QZ,IER)
      INTEGER N, NR, LCELL(NR,NR,NR), LNEXT(N), IER
      REAL    PX, PY, PZ, X(N), Y(N), Z(N), F(N), XYZMIN(3),
     +        XYZDEL(3), RMAX, RSQ(N), A(9,N), Q, QX, QY, QZ
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       UNIV. OF NORTH TEXAS
C                                             (817) 565-2767
C                                                   10/28/87
C
C  This subroutine computes the value and gradient at
C  (PX,PY,PZ) of the interpolatory function Q defined in
C  subroutine SHQSHEP.  Q(X,Y,Z) is a weighted sum of quadratic
C  nodal functions.
C
C  ON INPUT --
C
C    PX,PY,PZ = Cartesian coordinates of the point P at
C               which Q and its partials are to be evaluated.
C
C    N = Number of nodes and data values defining Q.
C        N .GE. 10.
C
C    X,Y,Z,F = Arrays of length N containing the nodes
C              and data values interpolated by Q.
C
C    NR = Number of rows, columns and planes in the cell
C         grid.  Refer to SHSTORE3.  NR .GE. 1.
C
C    LCELL = NR by NR by NR array of nodal indices assoiated
C            with cells.  Refer to SHSTORE3.
C
C    LNEXT = Array of length N containing next-node indices
C            Refer to SHSTORE3.
C
C    XYZMIN,XYZDEL = Arrays of length 3 containing minimum
C                    nodal coordinates and cell dimensions,
C                    respectively.  XYZDEL elements must be
C                    positive.  Refer to SHSTORE3.
C
C    RMAX = Square root of the largest element in RSQ --
C           maximum radius.
C
C    RSQ = Array of length N containing the squared radii
C          which enter into the weights defining Q.
C
C    A = 9 by N array containing the coefficients for the
C        nodal functions defining Q.
C
C  Input parameters are not altered by this subroutine.
C  The parameters other than PX, PY, and PZ should be input
C  unaltered from their values on output from SHQSHEP.  This
C  subroutine should not be called if a nonzero error flag
C  was returned by SHQSHEP.
C
C  ON OUTPUT --
C
C    Q = value of Q at (PX,PY,PZ) unless IER .EQ. 1, in
C        which case no values are returned.
C
C    QX,QY,QZ = first partial derivatives of Q at
C               (PX,PY,PZ) unless IER .EQ. 1.
C
C    IER = error indicator
C          IER = 0 if no errors were encountered.
C          IER = 1 if N, NR, XYZDEL, or RMAX is invalid.
C          IER = 2 if no errors were encountered but
C                  (PX,PY,PZ) is not within the radius
C                  R(K) for any node K (and thus Q = QX =
C                  QY = QZ = 0).
C
C  MODULES REQUIRED BY SH3GRD -- NONE
C
C  INTRINSIC FUNCTIONS CALLED BY SH3GRD -- IFIX, SQRT
C
C***********************************************************
C
      XP = PX
      YP = PY
      ZP = PZ
      XMIN = XYZMIN(1)
      YMIN = XYZMIN(2)
      ZMIN = XYZMIN(3)
      DX = XYZDEL(1)
      DY = XYZDEL(2)
      DZ = XYZDEL(3)
      IF (N .LT. 10) THEN
        GO TO 30
      ELSEIF (NR .LT. 1) THEN
        GO TO 31
      ELSEIF (DX .LE. 0.) THEN
        GO TO 32
      ELSEIF (DY .LE. 0.) THEN
        GO TO 33
      ELSEIF (DZ .LE. 0.) THEN
        GO TO 34
      ELSEIF (RMAX .LT. 0.) THEN
        GO TO 35
      ENDIF
C
C  Set IMIN, IMAX, JMIN, JMAX, KMIN, and KMAX to cell indices
C  defining the range of the search for nodes whose radii
C  include P.  The cells which must be searched are those
C  intersected by (or contained in) a sphere of radius RMAX
C  centered at P.
C
      IMIN = IFIX((XP-XMIN-RMAX)/DX) + 1
      IMAX = IFIX((XP-XMIN+RMAX)/DX) + 1
      IF (IMIN .LT. 1) IMIN = 1
      IF (IMAX .GT. NR) IMAX = NR
      JMIN = IFIX((YP-YMIN-RMAX)/DY) + 1
      JMAX = IFIX((YP-YMIN+RMAX)/DY) + 1
      IF (JMIN .LT. 1) JMIN = 1
      IF (JMAX .GT. NR) JMAX = NR
      KMIN = IFIX((ZP-ZMIN-RMAX)/DZ) + 1
      KMAX = IFIX((ZP-ZMIN+RMAX)/DZ) + 1
      IF (KMIN .LT. 1) KMIN = 1
      IF (KMAX .GT. NR) KMAX = NR
C
C  The following is a test for no cells within the sphere
C  of radius RMAX.
C
      IF (IMIN .GT. IMAX  .OR.  JMIN .GT. JMAX  .OR.
     +    KMIN .GT. KMAX) GO TO 6
C
C  Q = SWQ/SW = SUM(W(L)*Q(L))/SUM(W(L)) where the sum is
C  from L = 1 to N, Q(L) is the quadratic nodal function,
C  and W(L) = ((R-D)+/(R*D))**2 for radius R(L) and distance
C  D(L).  Thus
C
C        QX = (SWQX*SW - SWQ*SWX)/SW**2
C        QY = (SWQY*SW - SWQ*SWY)/SW**2
C        QZ = (SWQZ*SW - SWQ*SWZ)/SW**2
C
C  Where SWQX and SWX are partial derivatives with respect
C  to X of SWQ and SW, respectively.  SWQY, SWY, SWQZ, and
C  SWZ are defined similarly.
C
      SW = 0.
      SWX = 0.
      SWY = 0.
      SWZ = 0.
      SWQ = 0.
      SWQX = 0.
      SWQY = 0.
      SWQZ = 0.
C
C  Outer loop on cells (I,J,K).
C
      DO 3 K = KMIN,KMAX
        DO 3 J = JMIN,JMAX
          DO 3 I = IMIN,IMAX
            L = LCELL(I,J,K)
            IF (L .EQ. 0) GO TO 3
C
C  Inner loop on nodes L.
C
    1       DELX = XP - X(L)
            DELY = YP - Y(L)
            DELZ = ZP - Z(L)
            DXSQ = DELX*DELX
            DYSQ = DELY*DELY
            DZSQ = DELZ*DELZ
            DS = DXSQ + DYSQ + DZSQ
            RS = RSQ(L)
            IF (DS .GE. RS) GO TO 2
            IF (DS .EQ. 0.) GO TO 4
            RDS = RS*DS
            RD = SQRT(RDS)
            W = (RS+DS-RD-RD)/RDS
            T = 2.*(RD-RS)/(DS*RDS)
            WX = DELX*T
            WY = DELY*T
            WZ = DELZ*T
            QLX = 2.*A(1,L)*DELX + A(2,L)*DELY + A(4,L)*DELZ
            QLY = A(2,L)*DELX + 2.*A(3,L)*DELY + A(5,L)*DELZ
            QLZ = A(4,L)*DELX + A(5,L)*DELY + 2.*A(6,L)*DELZ
            QL = (QLX*DELX + QLY*DELY + QLZ*DELZ)/2. +
     +           A(7,L)*DELX + A(8,L)*DELY + A(9,L)*DELZ +
     +           F(L)
            QLX = QLX + A(7,L)
            QLY = QLY + A(8,L)
            QLZ = QLZ + A(9,L)
            SW = SW + W
            SWX = SWX + WX
            SWY = SWY + WY
            SWZ = SWZ + WZ
            SWQ = SWQ + W*QL
            SWQX = SWQX + WX*QL + W*QLX
            SWQY = SWQY + WY*QL + W*QLY
            SWQZ = SWQZ + WZ*QL + W*QLZ
C
C  Bottom of loop on nodes in cell (I,J,K).
C
    2       LP = L
            L = LNEXT(LP)
            IF (L .NE. LP) GO TO 1
    3       CONTINUE
C
C  SW = 0 iff P is not within the radius R(L) for any node L.
C
      IF (SW .EQ. 0.) GO TO 6
      Q = SWQ/SW
      SWS = SW*SW
      QX = (SWQX*SW - SWQ*SWX)/SWS
      QY = (SWQY*SW - SWQ*SWY)/SWS
      QZ = (SWQZ*SW - SWQ*SWZ)/SWS
      IER = 0
      RETURN
C
C  (PX,PY,PZ) = (X(L),Y(L),Z(L))
C
    4 Q = F(L)
      QX = A(7,L)
      QY = A(8,L)
      QZ = A(9,L)
      IER = 0
      RETURN
C
C  Invalid input parameter.
C
   30 CONTINUE
      CALL SHERR (1,'SH3GRD - number of input data must be > 9',41)
      IER = 1
      RETURN
   31 CONTINUE
      CALL SHERR (7,'SH3GRD - cell grid dimensions must be positive',
     +            46)
      IER = 7
      RETURN
   32 CONTINUE
      CALL SHERR (10,'SH3GRD - at least two points must have different X
     + coordinates',62)
      IER = 10
      RETURN
   33 CONTINUE
      CALL SHERR (11,'SH3GRD - at least two points must have different Y
     + coordinates',62)
      IER = 11
      RETURN
   34 CONTINUE
      CALL SHERR (12,'SH3GRD - at least two points must have different Z
     + coordinates',62)
      IER = 12
      RETURN
   35 CONTINUE
      CALL SHERR (14,
     +'SH3GRD - negative search radius in calculating least squares fit'
     +            ,64)
      IER = 14
      RETURN
C
C  No cells contain a point within RMAX of P, or
C  SW = 0 and thus DS .GE. RSQ(L) for all L.
C
    6 CONTINUE
      CALL SHERR (13,
     +            'SH3GRD - no cells contain a point within the radius o
     +f influence of the input point',83)
      Q = 0.
      QX = 0.
      QY = 0.
      QZ = 0.
      IER = 13
      RETURN
      END


 SUBROUTINE visco20(ms,m2,is,np,curve,ppro,vpar,stra,dtime,g,ier)
 !
 ! compute viscoplastic consistency parameter defined by a power law
 ! using a Newton-Raphson schemme combined with bisection algorithm
 !
 USE ctrl_db, ONLY: vefac !factor for strain rate smoothing
 USE mat_dba, ONLY : inte_cr
 IMPLICIT NONE
 !dummy variables
 REAL (kind=8), INTENT(IN)    :: ms,      & !mises trial stress
                                 m2,      & !2 * mu
                                 ppro(5), & !plastic properties (hardening)
                                 vpar(3), & !viscoplastic model parameters
                                 stra(2), & !efective plastic strain & evp strain rate
                                 dtime       !time increment
 INTEGER (kind=4), INTENT(IN) :: is, &
                                 np
 REAL (kind=8), INTENT(INOUT) :: g    !viscoplas. consistency parameter
 INTEGER(kind=4), INTENT(OUT) :: ier  !if no convergence then is TRUE
 REAL (kind=8), POINTER :: curve(:,:) !(3,np) yield stress curve

 !local variables
 REAL (kind=8) :: gmax,  & !radial return plastic consist. parameter (maximum)
                  yi,    & !yield stress
                  ap,    & !hardenind modulus
                  fbar,  & !mises regularized function
                  fp,    & !1st derivative of mises regularized function
                  dg,    & !increment in viscoplastic consist parameter
                  evp,   & !viscoplastic effective strain
                  rvp      !viscoplastic effective strain rate
 INTEGER (kind=4) :: i

 REAL (kind=8)            :: a=0d0,b=1d0,c=1d0,d=0d0 ! deriv parameters
 REAL (kind=8), PARAMETER :: r23 = 0.816496580927726d0, & ! sqrt(2/3)
                             tol = 1d-6

 ! initalize some variables
 ier  = 0 ! error flag
 gmax = g ! elastic-plastic consistency parameter (maximum) from radial return
 evp  = stra(2)  ! old equivalent strain
 rvp  = stra(1)  ! old equivalent strain rate
 g = 0d0  !

 DO
   !     setup initial yield FUNCTION radius
   IF( is == 5 ) THEN        !for points defined yield value
     i = 1   !begin at first interval
     yi = inte_cr (curve,np,evp,i)    !s_y
     ap = curve(3,i)                  !A'
   ELSE
     CALL isoha14(is,yi,ap,evp,ppro(1),ppro(2),ppro(3),ppro(4))  !compute s_y and A'
   END IF

   ! regularized mises criteria
   fbar = ms - m2*g - r23*yi  - vpar(1)*(evp**vpar(2))*(rvp**vpar(3))

   IF( ABS( fbar / ms ) <= tol )EXIT

   ! first derivative of regularized mises function
   IF( vpar(2) > 0d0 )THEN     ! derivative of hardening term
     a = 2d0*r23*vpar(2)*(evp**(vpar(2)-1d0))
     c = evp**vpar(2)
   END IF
   IF( vpar(3) > 0d0 )THEN     ! derivative of rate sensivity term
     b = rvp**vpar(3)
     d = (r23/dtime)*vpar(3)*(rvp**(vpar(3)-1d0))
   END IF
   ! evaluates first derivative
   fp = - m2 - (2d0/3d0)*ap - vpar(1)*(a*b+c*d) !tangent to curve fbar(vp)
   dg = fbar/fp  !increment in viscoplastic parameter
   g  = g - dg    !corrected viscoplastic parameter

   DO     ! bisection if g is greather gmax
     IF( g < gmax )EXIT
     g = g / 2d0
   END DO

   !update variables
   evp = stra(1) + r23 * g  !new equivalent strain
   rvp = (r23 * g) / dtime  !new equivalent strain rate
   !rvp   = (rvp_i + vefac*rvp) / (1d0 + vefac) !new smoothed eq. strain rate

 END DO

 IF(g > gmax) g = gmax

 !IF (ier /= 0) WRITE(55,999) ncon,gmax,g
 !999 FORMAT('Viscoplastic parameter correction no convergence',/,  &
 !          'iter = ',     i3,/,                                   &
 !          'gmax = ', f16.12,/,                                   &
 !          'g_vp = ', f16.12,/,                                   &
 !          'CALLED FROM VISCO20',/)

 RETURN
 END SUBROUTINE visco20


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%
!%%% DenFit: a program to fit atomic density using Gaussian s-functions. (2019.04.02)
!%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%
!%%% Reference
!%%%
!%%% [1] E. J. Baerends, D. E. Ellis, P. Ros, Chem. Phys. 2, 41 (1973).
!%%%
!%%% [2] B. I. Dunlap, J. W. D. Connolly, J. R. Sabin, J. Chem. Phys. 71, 3396 (1979).
!%%%
!%%% [3] C. Fonseca Guerra, O. Visser, J. G. Snijders, G. te Velde, E. J. Baerends, in Methods and
!%%%     Techniques in Computational Chemistry , (Eds.: E. Clementi, G. Corongiu), STEF, Cagliari,
!%%%     1995, p. 305-395
!%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%
!%%% Parameters are defined in the namelist $control. For example:
!%%%   $control
!%%%       nz=4 nc=2 npt=59000 igtf=3
!%%%   $end
!%%% Then the density data are provided.
!%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%
!%%% Parameters:
!%%% nz      = nuclear charge number of the element. For example, nz=30 for Zn
!%%% nc      = number of core electrons. 1 < nc < nz
!%%% npt     = number of 1D-density points
!%%% igtf    = formula to generate Gaussian exponents (1~4; default: 4)
!%%% dr      = step size (optional; it also defines the format of density data)
!%%% iunit   = (0/1, i.e. in Bohr or Angstrom) unit of dr and the r(:) array (optional; default: 0)
!%%%
!%%%
!%%% Density data (dr <=0 or dr is not set):
!%%% r(1), rho(1)
!%%% r(2), rho(2)
!%%% ...
!%%%
!%%% Density data (dr > 0):
!%%% rho(1), rho(2), ...
!%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
program DenFit
implicit real(kind=8) (a-h,o-z)
parameter(MaxGau = 60,au2ang=0.5291772086d0)
real(kind=8) :: alf(MaxGau)
real(kind=8),allocatable :: r(:), rho(:)
real(kind=8),allocatable :: qn(:), as(:,:), ax(:,:), al(:), an(:), coef(:), scr(:)
real(kind=8),allocatable :: alf0(:), as0(:,:), al0(:), an0(:), qn0(:)
character(8) logo
logical ifnrm

! normalized (.T.) s-functions or not(.F.)
!ifnrm =.false.
ifnrm =.true.

iinp = 5
iedf = 8
write(*,"(//,1x,41('='),/,1x,10('='),'  Results of DenFit  ',10('='),/,1x,41('='))")

! read parameters
call rdpara(iinp,IGTF,NZ,NC,Npt,drval,iunit)
if(iunit == 1) drval=drval/au2ang

logo="E000C000"
write(logo(2:4),"(i3.3)")NZ
write(logo(6:8),"(i3.3)")NC

! Gaussian s-functions alpha for fitting
call GenGau(IGTF,NGau,alf)
if (NGau > MaxGau) then
  write(*,"(//,' NGau > MaxGau!')")
  stop
else
  write(*,"(//,' Starting #S-Fun =',i8)") NGau
end if

! sort alpha in descending order
call ShellSort(NGau,alf,1)

! read density data
allocate(r(Npt), rho(Npt))
call rddata(iinp,Npt,iunit,drval,r,rho,Info)
if (Info == 0) then
  write(*,"(' ### Error when reading density data!')")
  stop
end if

! r0 ~ 1.0d-5
r0=0.d0
rho0=0.d0
drho=1.0d5
do i=1, Npt
  if(drho >= abs(r(i) - 1.0d-5) ) then
    drho=abs(r(i) - 1.0d-5)
    cycle
  else
    j = i -1
    if(r(j) < 0.5d0 * 1.0d-5) j = i
    r0 = r(j)
    rho0=rho(j)
    exit
  end if
end do
rr0 = r0 * r0

! There may be an artificial peak after r = 1.8 a.u.
i18=0
do i=1, Npt
  if(r(i) >= 1.8d0) then
    i18 = i
    exit
  end if
  if(i .eq. Npt) then
    write(*,"(' r(Npt) is too small!')")
    stop
  end if
end do

write(*,"(/,' R0  = ',d12.5,',  Rho0  = ',d20.14)") r0, rho0

allocate(qn(NGau), as(NGau,NGau), ax(NGau,NGau), al(NGau), an(NGau), coef(NGau), scr(NGau))
allocate(alf0(NGau), as0(NGau,NGau), al0(NGau), an0(NGau), qn0(NGau))

! normalization factors of s-ARDF functions
call norms(NGau,ifnrm,alf,qn)

! Calculate the matrices/arrays for fitting
call EqFit(NGau,alf,qn,Npt,r,rho,as,al,an,Acore,scr)
write(*,"(/,' Integrated Ncore: ',f16.10)") Acore
if(abs(Acore-dble(NC)) > 1.d-2) then
  write(*,"(' Accuracy is too low!')")
  stop
end if

! Optimize NGau; get rid of the redundant steepest functions (alpha > 1.0d4)
NGau0 = NGau
call acopy(NGau,alf,alf0)
call acopy(NGau*NGau,as,as0)
call acopy(NGau,al,al0)
call acopy(NGau,an,an0)
call acopy(NGau,qn,qn0)
do I = 1, NGau0
  if (alf0(1) < 1.0d4) exit

  call GauFit(NGau0,as0,ax,al0,an0,qn0,coef,NC,Acore,Info,scr)
  if (Info == 0) then
    write(*,"(' Inverse calculation fails.')")
    stop
  end if

! delta_rho at the first point
  call DltRho(NGau0,I,alf0,coef,rr0,rho0,idxneg,drho)

! delete the first function
  call GauRm(NGau0,1,alf0,as0,al0,an0,qn0)
end do

! the first idxneg-1 functions are redundant and should be deleted
if  (idxneg > 1) then
  write(*,"(' Delete the first ',i3,' redundant functions with min[dRho0] = ',d20.14)") idxneg-1, drho
  call GauRm(NGau,-(idxneg-1),alf,as,al,an,qn)
end if

! Do fitting
do while(.true.)

  call GauFit(NGau,as,ax,al,an,qn,coef,NC,Acore,Info,scr)
  if (Info == 0) then
    write(*,"(' Inverse calculation fails.')")
    exit
  end if

! check
  if(nint(Acore) /= NC) then
    write(*,"(' The fitted Ncore is wrong!')")
    exit
  end if
  if( (NC >= 10 .and. NGau < 10) .or. (NC < 10 .and. NGau < 5) ) then
    write(*,"(' The fitting fails!')")
    exit
  end if
  call ChkPos(NGau,Npt,r,alf,coef,idxneg)
  if(idxneg > 0) then
    write(*,"(' Negative density found!   Delete function-',i3,' with alpha = ',d20.14)") idxneg, alf(idxneg)
    call GauRm(NGau,idxneg,alf,as,al,an,qn)
    cycle
  end if
  call ChkRed(NGau,alf,coef,idxneg)
  if(idxneg > 0) then
    write(*,"(' Redundant function found! Delete function-',i3,' with alpha = ',d20.14)") idxneg, alf(idxneg)
    call GauRm(NGau,idxneg,alf,as,al,an,qn)
    cycle
  end if
  call ChkAPk(NGau,Npt,i18,r,alf,coef,idxneg)
  if(idxneg > 0) then
    write(*,"(' Artificial peak found!    Delete function-',i3,' with alpha = ',d20.14)") idxneg, alf(idxneg)
    call GauRm(NGau,idxneg,alf,as,al,an,qn)
    cycle
  end if
  ! to get a smaller error at dRho(1), ChkHss must be done at the last step
  call ChkHss(NGau,alf,coef,idxneg)
  if(idxneg > 0) then
    write(*,"(' Hessian(r=0) > 0 found!   Delete function-',i3,' with alpha = ',d20.14)") idxneg, alf(idxneg)
    call GauRm(NGau,idxneg,alf,as,al,an,qn)
    cycle
  end if

!================================================= Fitting finished

! delta(rho) at the first point
  call DltRho(NGau,1,alf,coef,rr0,rho0,idxneg,drho)
  write(*,"(/,' Fitting finished successfully with',/,5x,'Ncore(analytic) =',f16.10,' and dRho0  = ',d20.14)") Acore, drho

! print results
  write(*,"(//,' Final results:',//,' Element=',i8,/,' Ncore  =',i8,/,' #S-Fun =',i8, //,19x,'Alpha',13x,'Coefficient',/)") &
    NZ, NC, NGau
  do i = 1, NGau
    write(*,"(2e24.14)") alf(i), coef(i)
  end do

  open(iedf,file="EDF",iostat=Info)
  if (Info > 0) then
    write(*,"(' ### Error when creating EDF file!')")
    exit
  end if
  rewind(iedf)
!  write(iedf,"('**',a8)")logo
!  write(iedf,"(i4)") NGau
!  write(iedf,"(5e22.14)") (alf(i), i=1,NGau)
!  write(iedf,"(5e22.14)") (coef(i), i=1,NGau)

  write(iedf,"(//,2x,'EDF in FORTRAN90',/,2x,'NZA   = ',i4,/,2x,'NCore = ',i4)") NZ, NC
  write(iedf,"(/,4x,'nfun =',i3)") NGau
  Nline=(NGau+3)/4
  Nlast=mod(NGau,4)
!  alf
  write(iedf,"(4x,'alf(1:nfun)=(/',4(d22.14,','),'&')") (alf(j),j=1,4)
  do i = 2, Nline-1
    write(iedf,"(18x,4(d22.14,','),'&')")(alf(j),j=4*i-3,4*i)
  end do
  if(Nlast .eq. 0) then
    write(iedf,"(18x,3(d22.14,','),d22.14,'/)')") (alf(j),j=NGau-3,NGau)
  else if(Nlast .eq. 3) then
    write(iedf,"(18x,2(d22.14,','),d22.14,'/)')") (alf(j),j=NGau-2,NGau)
  else if(Nlast .eq. 2) then
    write(iedf,"(18x,d22.14,',',d22.14,'/)')") (alf(j),j=NGau-1,NGau)
  else
    write(iedf,"(18x,d22.14,'/)')") alf(NGau)
  end if
!  coe
  write(iedf,"(4x,'coe(1:nfun)=(/',4(d22.14,','),'&')") (coef(j),j=1,4)
  do i = 2, Nline-1
    write(iedf,"(18x,4(d22.14,','),'&')")(coef(j),j=4*i-3,4*i)
  end do
  if(Nlast .eq. 0) then
    write(iedf,"(18x,3(d22.14,','),d22.14,'/)')") (coef(j),j=NGau-3,NGau)
  else if(Nlast .eq. 3) then
    write(iedf,"(18x,2(d22.14,','),d22.14,'/)')") (coef(j),j=NGau-2,NGau)
  else if(Nlast .eq. 2) then
    write(iedf,"(18x,d22.14,',',d22.14,'/)')") (coef(j),j=NGau-1,NGau)
  else
    write(iedf,"(18x,d22.14,'/)')") coef(NGau)
  end if

  exit

end do

deallocate(r, rho)
deallocate(qn, as, ax, al, an, coef, scr)
deallocate(alf0, as0, al0, an0, qn0)

end

!%%%
!%%% read parameters from input
!%%%
subroutine rdpara(iinp,IGTF,NZ,NC,Npt,dr,iunit)
implicit real(kind=8) (a-h,o-z)
namelist/control/NZ,NC,Npt,IGTF,dr,iunit

NZ=0
NC=0
Npt=0
IGTF=4
dr=-1.d0

rewind(iinp)
read(iinp,control,err=100,end=200)

! default: 4
if (IGTF < 1 .or. IGTF > 4) IGTF = 4

if (NZ < 2 .or. NZ > 120) then
  write(*,"(' NZ is out of range!')")
  stop
end if
if (NC < 0 .or. NC >= NZ) then
  write(*,"(' NC is out of range!')")
  stop
end if
if (Npt < 50) then
  write(*,"(' Npt is too small!')")
  stop
end if
if (dr > 0.02d0) then
  write(*,"(' dR is too big!')")
  stop
end if
if(iunit /= 1) iunit = 0

Return

100  write(*,"(//,' Unknown parameters found!')")
  stop
200  write(*,"(//,' No parameters defined!')")
  stop
End

!%%%
!%%% read density data
!%%%
subroutine rddata(iinp,Npt,iunit,drval,r,rho,l)
implicit real(kind=8) (a-h,o-z)
parameter(au2ang=0.5291772086d0)
real(kind=8) :: r(Npt), rho(Npt)

l=1
if(drval > 0) then
  read(iinp,*,err=100) (rho(i), i=1,Npt)
  r(1) = 0.d0
  do i=2,Npt
    r(i) = r(i-1) + drval
  end do
else
  do i=1,Npt
    read(iinp,*,err=100) r(i), rho(i)
  end do
  if(iunit == 1) r = r/au2ang
end if
Return

100  l=0
Return
End

!%%%
!%%% delete redundant functions
!%%%
subroutine ChkRed(NGau,alf,coef,idxneg)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: alf(NGau), coef(NGau)

idxneg = 0

Nhalf=NGau/2

! for steep functions with alpha > 1.0d5
do i=1,Nhalf
  if(alf(i) > 1.0d5) then
    if(abs(coef(i)) < 5.0d0) then
      idxneg = i
      goto 1000
    end if
  else
    exit
  end if
end do

! for flat functions with alpha < 3
do i=NGau, Nhalf+1, -1
  if(alf(i) < 3.0d0) then
    if(abs(coef(i)) < 1.0d-5) then
      idxneg = i
      goto 1000
    end if
  else
    exit
  end if
end do

1000 return
end

!%%%
!%%% check artificial peak in ARDF for r>1.8
!%%%
subroutine ChkAPk(NGau,Npt,i18,r,alf,coef,idxneg)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: r(Npt), alf(NGau), coef(NGau)

idxneg = 0
! alf(idxneg) should be < 1
if(alf(NGau) > 1.d0) return

ardfold = 0.d0
do i= i18, Npt, 10
  ! ardf/(4pi)
  rr = r(i)*r(i)
  ardf = 0.d0
  do j=1,NGau
    ardf = ardf + coef(j)*rr*exp(-alf(j)*rr)
  end do
  if(i == i18 .or. ardf <= ardfold) then
    ardfold = ardf
    cycle
  else
  	idxneg = NGau
  	exit
  end if
end do

return
end

!%%%
!%%% Check Hessian at r=0, which should be negative, i.e. there is a maximum at r=0.
!%%%
!%%% Hessian(0) = -2 * hess, where hess = sum[coe(i)*alf(i)]
!%%%
subroutine ChkHss(NGau,alf,coef,idxneg)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: alf(NGau), coef(NGau)

idxneg = 0
hess = 0.0d0
do i= 1, NGau
  hess = hess + coef(i)*alf(i)
end do
if(hess <= 0.0d0) idxneg = 1

return
end

!%%%
!%%% check positive definiteness of rho
!%%%
subroutine ChkPos(NGau,Npt,r,alf,coef,idxneg)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: r(Npt), alf(NGau), coef(NGau)

rhomin = 1.d-10
idxneg = 0
do i=1,Npt
  rho=0.d0
  do j=1,NGau
    rho = rho + coef(j) * exp(-alf(j) * r(i) * r(i))
  end do
  if(i == 1 .and. rho < 0.0d0) then
    rhomin = rho
    idxneg = 1
    exit
  end if
!  if(i < 5) write(*,"(d24.12)") rho
  if(rhomin > rho) then
    rhomin = rho
    idxneg = i
  end if
end do

if(rhomin < 0.d0)then
  r0 = r(idxneg)
  rhomin = 1.d-10
  idxneg = 0
  do i=1,NGau
    rho = coef(i) * exp(-alf(i) * r0 * r0)
    if(rhomin > rho) then
      rhomin = rho
      idxneg = i
    end if
  end do
else
  idxneg = 0
end if

return
end

!%%%
!%%% Irm > 0: Remove the Irm-th row/column in an array/matrix
!%%% Irm < 0: Remove the first |Irm| rows/columns in an array/matrix
!%%%
Subroutine GauRm(NGau,Irm,alf,as,al,an,qn)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: alf(NGau), as(NGau,NGau), al(NGau), an(NGau), qn(NGau)
logical Lmod

Iab = abs(Irm)

if (Iab == 0) return

J = 0
Do I = 1, NGau
  if (Irm > 0) then
    Lmod = (I == Iab)
  else
    Lmod = (I <= Iab)
  end if
  if (Lmod) cycle
  J = J + 1
  alf(J) = alf(I)
  al(J) = al(I)
  an(J) = an(I)
  qn(J) = qn(I)
end do

call DelRC(NGau,Irm,as,as)

if (Irm > 0) then
  NGau = NGau - 1
else
  NGau = NGau - Iab
end if

Return
End

!%%%
!%%% Irm > 0: Remove the Irm-th row & column in a matrix
!%%% Irm < 0: Remove the first |Irm| rows & columns in a matrix
!%%%
Subroutine DelRC(N,Irm,a,b)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: a(N,N), b(*)
logical Imod, Jmod

Iab = abs(Irm)

if (Iab == 0) return

K = 0
Do I = 1, N
  if (Irm > 0) then
    Imod = (I == Iab)
  else
    Imod = (I <= Iab)
  end if
  if (Imod) cycle
  Do J = 1, N
    if (Irm > 0) then
      Jmod = (J == Iab)
    else
      Jmod = (J <= Iab)
    end if
    if (Jmod) cycle
    K = K + 1
    b(K) = a(J,I)
  end do
end do

Return
End

!%%%
!%%% Calculate the matrices/arrays for fitting
!%%%
subroutine EqFit(NGau,alf,qn,Npt,r,rho,as,al,an,Acore,scr)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: alf(NGau), qn(NGau), r(Npt), rho(Npt), as(NGau,NGau), al(NGau), an(NGau), scr(NGau)

! For normalized s-ARDF functions, the overlap matrix element
! as(j,i)
! = N(i) * N(j) * Int{(4*pi*r*r)^3 * [exp(-a_i*r*r)] * [exp(-a_j*r*r)]} dr
! = N(i) * N(j) * 60 * (pi/(a_i+a_j))^3.5
!
! an(i)
! = Int{[4*pi*r*r*exp(-a_i*r*r)]} dr
! = (pi/a_i)^1.5
pi=acos(-1.d0)
cons1 = power(sqrt(pi),3)
cons2 = pi * 4.d0
cons3 = cons2*cons2*cons2
do i=1,NGau
  do j=1,i
    as(j,i) = pi / (alf(i) + alf(j))
    as(j,i) = qn(i) * qn(j) * 60.d0 * as(j,i)**3.5d0
    if(j < i) as(i,j) = as(j,i)
  end do
  an(i) = sqrt(alf(i))
  an(i) = cons1 / power(an(i),3)
end do

! calculate Ncore and al numerically
Acore=0.d0
al=0.d0
do i=1,Npt-1
  dr=r(i+1)-r(i)
  rr=r(i)*r(i)
  dc=rr*rho(i)
  d6=rr*rr*dc
  do j=1,NGau
    scr(j) = d6 * exp(-alf(j) * rr)
  end do
  Acore = Acore + dc * dr
  call AccAB(NGau,dr,scr,al,al)
end do
Acore=Acore*cons2
al=al*cons3

return
end

!%%%
!%%% Do fitting
!%%%
subroutine GauFit(NGau,as,ax,al,an,qn,coef,NC,Acore,Info,scr)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: as(NGau,NGau), ax(NGau,NGau), al(NGau), an(NGau), qn(NGau), coef(NGau), scr(NGau)

! as^-1 --> ax
call acopy(NGau*NGau,as,ax)
call bssgj(NGau,Info,ax,scr)
if (Info == 0) return

! mat(qn) * ax * mat(qn) --> ax
call dmd(NGau,qn,ax)

! lambda = (Ncore-an'*ax*al)/(an'*ax*an)
call MatxL(NGau,ax,an,scr)
alam = (dble(NC) - dotx(NGau,scr,al)) / dotx(NGau,scr,an)

! coefficients: ax * (al + lambda*an)
call AccAB(NGau,alam,an,al,scr)
call MatxL(NGau,ax,scr,coef)

! recalculate Ncore analytically
Acore=0.d0
do i=1,NGau
  Acore=Acore+an(i)*coef(i)
end do

return
end

!%%%
!%%% Inverse of a symmetric positive definite matrix a
!%%% Taken from Shiliang Xu's Fortran77 book, SS2.5
!%%%
subroutine bssgj(n,l,a,b)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: a(n,n), b(n)

l=1
do k=1,n
  m=n-k+1
  w=a(1,1)
  if (w+1.d0 == 1.d0) then
    l=0
    return
  end if
  do i=2,n
    g=a(i,1)
    b(i)=g/w
    if (i <= m) b(i)=-b(i)
    do j=2,i
      a(i-1,j-1)=a(i,j)+g*b(j)
    end do
  end do
  a(n,n)=1.d0/w
  do i=2,n
    a(n,i-1)=b(i)
  end do
end do

do i=1,n-1
  do j=i+1,n
    a(i,j)=a(j,i)
  end do
end do

return
end

!%%%
!%%% delta_rho at the first point
!%%%
!%%% rr0 = r0*r0
!%%%
subroutine DltRho(N,Iter,a,c,rr0,rho0,imin,dmin)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: a(*), c(*)

x = 0.d0
do i = 1, N
  x = x + c(i) * exp(-a(i) * rr0)
end do

! delta_rho
x = abs(x - rho0)

if(Iter == 1) then
  imin = 1
  dmin = x
else
  if(dmin > x) then
    imin = Iter
    dmin = x
  end if
end if

return
end

!%%%
!%%% D(N,N) * A(N,N) * D(N,N) --> A(N,N)
!%%% where D is a diagonal matrix with elements in d(N)
!%%%
subroutine dmd(N,d,a)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: d(N), a(N,N)

do i = 1, N
  do j = 1, i
    a(j,i) = a(j,i) * d(i) * d(j)
    if(j < i) a(i,j) = a(j,i)
  end do
end do

return
end

!%%%
!%%% B(*) = A(*)
!%%%
subroutine acopy(n,a,b)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: a(*), b(*)

do i = 1, n
  b(i) = a(i)
end do

return
end

!%%%
!%%% a**N
!%%%
function power(a,N)
implicit real(kind=8) (a-h,o-z)

if (N == 0) then
  power = 1.d0
  return
end if

power = a
Do I = 2, abs(N)
  power = power * a
end do
if (N < 0) power = 1.d0 / power

Return
End

!%%%
!%%% normalization factors of s-ARDF functions: q_i = (2*a_i/pi)^(7/4) / sqrt(60)
!%%%
Subroutine norms(N,ifnrm,a,q)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: a(N), q(N)
logical ifnrm

q = 1.d0
if(ifnrm) then
  pi=acos(-1.d0)
  Do I = 1, N
    q(I) = ((a(I)+a(I))/pi)**1.75d0
  end do
end if

q=q/sqrt(60.d0)

Return
End

!%%%
!%%% A(N,N) * B(N) = C(N)
!%%%
Subroutine MatxL(N,A,B,C)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: A(N,N), B(N), C(*)

Do I = 1,N
  C(I) = dotx(N,A(1,I),B)
end do

Return
End

!%%%
!%%% vector A dot_product vector B
!%%%
function dotx(N,A,B)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: A(N), B(N)

dotx = 0.d0

Do I = 1,N
  dotx = dotx + A(I)*B(I)
end do

Return
End

!%%%
!%%% C(*) = c0 * A(*) + B(*)
!%%%
Subroutine AccAB(N,c0,A,B,C)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: A(N), B(N), C(N)

Do I = 1, N
  C(I) = B(I) + c0*A(I)
end do

Return
End

!%%%
!%%%  sort a in ascending (Mode = 0) or descending (Mode /= 0) order using D. L. Shell's method
!%%%
subroutine ShellSort(N,a,Mode)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: a(N)
logical :: AD

K = N /2

do while (K > 0)
  do I = K + 1, N
    J = I - K
    do while (J > 0)
      if (Mode == 0) then
        AD = a(J) > a(J+K)
      else
        AD = a(J) < a(J+K)
      end if
      if (AD) then
        t = a(J)
        a(J) = a(J + K)
        a(J + K) = t
        J = J - K
      else
        exit
      end if
    end do
  end do
  K = K / 2
end do

Return
End

!%%%
!%%% Gaussian s-functions
!%%%
subroutine GenGau(icase,NGau,alf)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: alf(*)

write(*,"(//,' Type of functions: ',i6)") icase

select case(icase)

  case(1)
!   Alpha_i = exp[a + b * (i - 1)], a=-3.21885281944033, b=0.672
!   Parameters used by G09
    NGau = 40
    a =-3.21885281944033d0
    b = 0.672d0
    do i = 1, NGau
      j = i - 1
      alf(i) = exp(a + b * j)
    end do
    write(*,"(&
    '  Alpha_i = exp[a + b * (i - 1)], a=-3.21885281944033, b=0.672',/,&
    ' Reference:',/,&
    '  E. V. R. de Castro and F. E. Jorge, J. Chem. Phys. 108 5225 (1998).',/,&
    '  and modified in',/,&
    '  T. A. Keith and M. J. Frisch, J. Phys. Chem. A 115, 12879 (2011).')")

  case(2)
!   Alpha_i = exp[a + b * (i - 1)], a=-4.584, b=0.672
!   Ref.
!   E. V. R. de Castro and F. E. Jorge, J. Chem. Phys. 108 5225 (1998).
    NGau = 40
    a =-4.584d0
    b = 0.672d0
    do i = 1, NGau
      j = i - 1
      alf(i) = exp(a + b * j)
    end do
    write(*,"(&
    '  Alpha_i = exp[a + b * (i - 1)], a=-4.584, b=0.672',/,&
    ' Reference:',/,&
    '  E. V. R. de Castro and F. E. Jorge, J. Chem. Phys. 108 5225 (1998).')")

  case(3)
!   Alpha_i = exp[a + b * (i - 1)], a=-3.84, b=0.72
!   Ref.
!   G. L. Malli, A. B. F. DaSilva, and Y. Ishikawa, Phys. Rev. A 47, 143 (1993).
!   A. Wolf, M. Reiher, and B. A. Hess, J. Chem. Phys. 117, 9215 (2002).
    NGau = 38
    a =-3.84d0
    b = 0.72d0
    do i = 1, NGau
      j = i - 1
      alf(i) = exp(a + b * j)
    end do
    write(*,"(&
    '  Alpha_i = exp[a + b * (i - 1)], a=-3.84, b=0.72',/,&
    ' Reference:',/,&
    '  G. L. Malli, A. B. F. DaSilva, and Y. Ishikawa, Phys. Rev. A 47, 143 (1993).',/,&
    '  A. Wolf, M. Reiher, and B. A. Hess, J. Chem. Phys. 117, 9215 (2002).')")

!  case(4)
  case default
!   Even-tempered universal Gaussian exponents
!   Alpha_i = 0.001 * 1.65^(i-1)
!           ~ exp[a + b * (i - 1)], a=-6.907755, b=0.500775
!   Ref.
!   M. Reiher and A. Wolf, J. Chem. Phys. 121, 10945 (2004).
    NGau = 60
    a = 1.0d-3
    b = 1.65d0
    alf(1) = a;
    do i=2,NGau
      alf(i) = alf(i-1) * b
    end do
    write(*,"(&
    '  Even-tempered universal Gaussian exponents',/,&
    '  Alpha_i = 0.001 * 1.65^(i-1)',/,&
    '          ~ exp[a + b * (i - 1)], a=-6.907755, b=0.500775',/,&
    ' Reference:',/,&
    '  M. Reiher and A. Wolf, J. Chem. Phys. 121, 10945 (2004).')")

end select

return
end


C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      FUNCTION SPLDE (NDIM,X,NDERIV,COEF,XMIN,XMAX,NODES,IERROR)
      DIMENSION       X(NDIM)    ,NDERIV(NDIM)           ,COEF(*)    ,
     1                XMIN(NDIM) ,XMAX(NDIM) ,NODES(NDIM)
      COMMON /SPLCOM/ MDIM       ,DX(4)      ,DXIN(4)    ,IB(4)      ,
     1                IBMN(4)    ,IBMX(4)
      SAVE
C
C The restriction for NDIM to be .LE. 4 can be eliminated by increasing
C the above dimensions.
C
      IERROR = 0
      MDIM = NDIM
      IF (MDIM.LT.1 .OR. MDIM.GT.4) GO TO 105
      IIBMX = 1
      DO 101 IDIM=1,MDIM
         NOD = NODES(IDIM)
         IF (NOD .LT. 4) GO TO 106
         XRNG = XMAX(IDIM)-XMIN(IDIM)
         IF (XRNG .EQ. 0.) GO TO 107
         IF (NDERIV(IDIM).LT.0 .OR. NDERIV(IDIM).GT.2) GO TO 108
C
C  DX(IDIM) is the node spacing along the IDIM coordinate.
C
         DX(IDIM) = XRNG/FLOAT(NOD-1)
         DXIN(IDIM) = 1./DX(IDIM)
C
C  Compute indices of basis functions which are nonzero at X.
C
         IT = DXIN(IDIM)*(X(IDIM)-XMIN(IDIM))
C
C  IBMN must be in the range 0 to NODES-2.
C
         IBMN(IDIM) = MIN0(MAX0(IT-1,0),NOD-2)
C
C  IBMX must be in the range 1 to NODES-1.
C
         IBMX(IDIM) = MAX0(MIN0(IT+2,NOD-1),1)
         IIBMX = IIBMX*(IBMX(IDIM)-IBMN(IDIM)+1)
         IB(IDIM) = IBMN(IDIM)
  101 CONTINUE
C
      SUM = 0.
      IIB = 0
C
C  Begining of basis index loop - traverse all indices corresponding
C  to basis functions which are nonzero at X.
C
  102 IIB = IIB+1
C
C  The indices are in IB and are passed through common to BASCMP.
C
      CALL BASCMP (X,NDERIV,XMIN,NODES,ICOF,BASM)
C
C  BASCMP computes ICOF and BASM where BASM is the value at X of the
C  N-dimensional basis function corresponding to COEF(ICOF).
C
      SUM = SUM+COEF(ICOF)*BASM
      IF (IIB .GE. IIBMX) GO TO 104
C
C  Increment the basis indices.
C
      DO 103 IDIM=1,MDIM
         IB(IDIM) = IB(IDIM)+1
         IF (IB(IDIM) .LE. IBMX(IDIM)) GO TO 102
         IB(IDIM) = IBMN(IDIM)
  103 CONTINUE
C
C  End of basis index loop.
C
  104 SPLDE = SUM
      RETURN
C
C  Errors.
C
  105 CONTINUE
      IERROR = 101
      CALL CFAERR (IERROR,' SPLFE or SPLDE - NDIM is less than 1 or grea
     +ter than 4     ',60)
      GO TO 109
  106 CONTINUE
      IERROR = 102
      CALL CFAERR (IERROR,' SPLFE or SPLDE - NODES(IDIM) is less than  4
     +for some IDIM  ',60)
      GO TO 109
  107 CONTINUE
      IERROR = 103
      CALL CFAERR (IERROR,' SPLFE or SPLDE - XMIN(IDIM) = XMAX(IDIM) for
     + some IDIM     ',60)
      GO TO 109
  108 CONTINUE
      IERROR = 104
      CALL CFAERR (IERROR,' SPLDE - NDERIV(IDIM) IS less than 0 or great
     +er than 2 for some IDIM  ',70)
C
  109 STOP
      END


      subroutine corey(sl,rp1,rp2,rl,drls,rv,drvs)
!***********************************************************************
! Copyright 2009 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Corey relative permeability model.
!D1
!***********************************************************************

      implicit none
      real*8 sl,rp1,rp2,rl,drls,rv,drvs,star,denom,ds
c     this is the formulation in Gaz's original rlperm.f (geothermal)
c     and in the models and methods document
c     and in Preuss(2002)
c     rp1 and rp2 are both residual saturations

      rl = 0.0
      rv = 0.0
      drls = 0.0
      drvs = 0.0
      denom = 1.0-rp1-rp2
      star=(sl-rp1)/denom
      ds = 1.0/denom
      if(star.lt.0.d0) then
         rv = 1.0
      else if(star.gt.1.d0) then
         rl = 1.0
      else
         rl = star**4
         drls = 4.0*star**3*ds
         rv=(1.0d0-star)**2*(1.0d0-star**2)
         drvs=(2.0*(1.0-star)*(1.0-star**2)+
     $        (1.0-star)**2*(-2.0*star))*(-ds)
      endif

      end subroutine corey


!======================================================================
!
! !IROUTINE: VIRTUAL -- Calculate virtual temperature (K)
!
! !DESCRIPTION:
!
!   This function returns a single value of virtual temperature in
!   K, given temperature in K and mixing ratio in kg/kg.  For an
!   array of virtual temperatures, use subroutine VIRTUAL_TEMP.
!
! !INPUT:
!    RATMIX - water vapor mixing ratio (kg/kg)
!    TEMP   - temperature (K)
!
! !OUTPUT:
!    TV     - Virtual temperature (K)
!

! NCLFORTSTART
REAL(KIND=8) FUNCTION TVIRTUAL(temp, ratmix)
    USE wrf_constants, ONLY : EPS

    !f2py threadsafe

    IMPLICIT NONE
    REAL(KIND=8), INTENT(IN) :: temp, ratmix

! NCLEND

    TVIRTUAL = temp*(EPS + ratmix)/(EPS*(1.D0 + ratmix))

    RETURN

END FUNCTION TVIRTUAL

! NCLFORTSTART
REAL(KIND=8) FUNCTION TONPSADIABAT(thte, prs, psadithte, psadiprs, psaditmk, gamma,&
                                   errstat, errmsg)
    USE wrf_constants, ONLY : ALGERR
!!$OMP DECLARE SIMD (TONPSADIABAT)
!!uniform(thte,prs,psadithte,psadiprs,psaditmk)
    !f2py threadsafe

    IMPLICIT NONE
    REAL(KIND=8), INTENT(IN) :: thte
    REAL(KIND=8), INTENT(IN) :: prs
    REAL(KIND=8), DIMENSION(150), INTENT(IN) :: psadithte
    REAL(KIND=8), DIMENSION(150), INTENT(IN) :: psadiprs
    REAL(KIND=8), DIMENSION(150,150), INTENT(IN) :: psaditmk
    REAL(KIND=8), INTENT(IN) :: gamma
    INTEGER, INTENT(INOUT) :: errstat
    CHARACTER(LEN=*), INTENT(INOUT) :: errmsg

! NCLEND

    REAL(KIND=8) :: fracjt
    REAL(KIND=8) :: fracjt2
    REAL(KIND=8) :: fracip
    REAL(KIND=8) :: fracip2

    INTEGER :: l1, h1, mid1, rang1, l2, h2, mid2, rang2
    INTEGER :: ip, jt

    !   This function gives the temperature (in K) on a moist adiabat
    !   (specified by thte in K) given pressure in hPa.  It uses a
    !   lookup table, with data that was generated by the Bolton (1980)
    !   formula for theta_e.

    !     First check if pressure is less than min pressure in lookup table.
    !     If it is, assume parcel is so dry that the given theta-e value can
    !     be interpretted as theta, and get temperature from the simple dry
    !     theta formula.

    IF (prs .LE. psadiprs(150)) THEN
        TONPSADIABAT = thte * (prs/1000.D0)**gamma
        RETURN
    END IF

    !   Otherwise, look for the given thte/prs point in the lookup table.

    jt = -1
    l1 = 1
    h1 = 149
    rang1 = h1 - l1
    mid1 = (h1 + l1) / 2
    DO WHILE(rang1 .GT. 1)
        IF (thte .GE. psadithte(mid1)) THEN
           l1 = mid1
        ELSE
           h1 = mid1
        END IF
        rang1 = h1 - l1
        mid1 = (h1 + l1) / 2
    END DO
    jt = l1

   ! DO jtch = 1, 150-1
   !     IF (thte .GE. psadithte(jtch) .AND. thte .LT. psadithte(jtch+1)) THEN
   !         jt = jtch
   !         EXIT
  !          !GO TO 213
  !      END IF
  !  END DO

    ip = -1
    l2 = 1
    h2 = 149
    rang2 = h2 - l2
    mid2 = (h2 + l2) / 2
    DO WHILE(rang2 .GT. 1)
        IF (prs .LE. psadiprs(mid2)) THEN
           l2 = mid2
        ELSE
           h2 = mid2
        END IF
        rang2 = h2 - l2
        mid2 = (h2 + l2) / 2
    END DO
    ip = l2

   ! ip = -1
   ! DO ipch = 1, 150-1
   !     IF (prs .LE. psadiprs(ipch) .AND. prs .GT. psadiprs(ipch+1)) THEN
   !         ip = ipch
   !         EXIT
   !         !GO TO 215
   !     END IF
   ! END DO

    IF (jt .EQ. -1 .OR. ip .EQ. -1) THEN
        ! Set the error and return
        TONPSADIABAT = -1
        errstat = ALGERR
        WRITE(errmsg, *) "capecalc3d: Outside of lookup table bounds. prs,thte=", prs, thte
        RETURN
    END IF

    fracjt = (thte-psadithte(jt)) / (psadithte(jt+1)-psadithte(jt))
    fracjt2 = 1.D0 - fracjt
    fracip = (psadiprs(ip)-prs) / (psadiprs(ip)-psadiprs(ip+1))
    fracip2 = 1.D0 - fracip

    IF (psaditmk(ip,jt) .GT. 1D9 .OR. psaditmk(ip+1,jt) .GT. 1D9 .OR. &
        psaditmk(ip,jt+1) .GT. 1D9 .OR. psaditmk(ip+1,jt+1) .GT. 1D9) THEN
        ! Set the error and return
        TONPSADIABAT = -1
        errstat = ALGERR
        WRITE(errmsg, *) "capecalc3d: Tried to access missing temperature in lookup table. ", &
                 "Prs and Thte probably unreasonable. prs,thte=", prs, thte
        RETURN
    END IF

    TONPSADIABAT = fracip2*fracjt2*psaditmk(ip,jt) + fracip*fracjt2*psaditmk(ip+1,jt) + &
            fracip2*fracjt*psaditmk(ip,jt+1) + fracip*fracjt*psaditmk(ip+1,jt+1)

    RETURN

END FUNCTION TONPSADIABAT

!NCLFORTSTART
SUBROUTINE DLOOKUP_TABLE(psadithte, psadiprs, psaditmk, fname, errstat, errmsg)
    USE wrf_constants, ONLY : ALGERR

    !f2py threadsafe

    REAL(KIND=8), DIMENSION(150), INTENT(INOUT) :: psadithte, psadiprs
    REAL(KIND=8), DIMENSION(150,150), INTENT(INOUT) :: psaditmk
    CHARACTER(LEN=*), INTENT(IN) :: fname
    INTEGER, INTENT(INOUT) :: errstat
    CHARACTER(LEN=*), INTENT(INOUT) :: errmsg

!NCLEND

    ! Locals
    INTEGER :: iustnlist, i, nthte, nprs, ip, jt

    !      FNAME = 'psadilookup.dat'
    iustnlist = 33
    OPEN (UNIT=iustnlist, FILE=fname, FORM='formatted', STATUS='old')

    DO i = 1,14
        READ (iustnlist, FMT=*)
    END DO

    READ (iustnlist, FMT=*) nthte, nprs

    IF (nthte .NE. 150 .OR. nprs .NE. 150) THEN
        errstat = ALGERR
        errmsg = "Number of pressure or theta_e levels in lookup table file not 150"
        RETURN
    END IF

    READ (iustnlist, FMT="(5D15.7)") (psadithte(jt),jt=1,nthte)
    READ (iustnlist, FMT="(5D15.7)") (psadiprs(ip),ip=1,nprs)
    READ (iustnlist, FMT="(5D15.7)") ((psaditmk(ip,jt),ip=1,nprs),jt=1,nthte)

    CLOSE (iustnlist)

    RETURN

END SUBROUTINE DLOOKUP_TABLE

!     Historically, this routine calculated the pressure at full sigma
!     levels when RIP was specifically designed for MM4/MM5 output.
!     With the new generalized RIP (Feb '02), this routine is still
!     intended to calculate a set of pressure levels that bound the
!     layers represented by the vertical grid points, although no such
!     layer boundaries are assumed to be defined.  The routine simply
!     uses the midpoint between the pressures of the vertical grid
!     points as the bounding levels.  The array only contains mkzh
!     levels, so the pressure of the top of the uppermost layer is
!     actually excluded.  The kth value of pf is the lower bounding
!     pressure for the layer represented by kth data level.  At the
!     lower bounding level of the lowest model layer, it uses the
!     surface pressure, unless the data set is pressure-level data, in
!     which case it assumes the lower bounding pressure level is as far
!     below the lowest vertical level as the upper bounding pressure
!     level is above.
SUBROUTINE DPFCALC(prs, sfp, pf, mix, mjy, mkzh, ter_follow)

    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(IN) :: prs
    REAL(KIND=8), DIMENSION(mix,mjy), INTENT(IN) :: sfp
    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(OUT) :: pf
    INTEGER, INTENT(IN) :: ter_follow,mix,mjy,mkzh

    INTEGER :: i,j,k

    !$OMP PARALLEL DO COLLAPSE(3) SCHEDULE(runtime)
    DO j = 1,mjy
        DO i = 1,mix
            DO k = 1,mkzh
                IF (k .EQ. mkzh) THEN
                    ! terrain-following data
                    IF (ter_follow .EQ. 1) THEN
                        pf(k,i,j) = sfp(i,j)
                    ! pressure-level data
                    ELSE
                        pf(k,i,j) = .5D0 * (3.D0*prs(k,i,j) - prs(k-1,i,j))
                    END IF
                ELSE
                    pf(k,i,j) = .5D0 * (prs(k+1,i,j) + prs(k,i,j))
                END IF
            END DO
        END DO
    END DO

    !$OMP END PARALLEL DO

    RETURN

END SUBROUTINE DPFCALC

!======================================================================
!
! !IROUTINE: capecalc3d -- Calculate CAPE and CIN
!
! !DESCRIPTION:
!
!   This routine calculates CAPE and CIN (in m**2/s**2,
!   or J/kg) for every grid point in the entire 3D domain (treating
!   each grid point as a parcel).
!

! Important!  The z-indexes must be arranged so that mkzh (max z-index) is the
! surface pressure.  So, pressure must be ordered in ascending order before
! calling this routine.  Other variables must be ordered the same (p,tk,q,z).

! Also, be advised that missing data values are not checked during the computation.
! Also also, Pressure must be hPa

! NCLFORTSTART
SUBROUTINE DCAPECALC3D(prs,tmk,qvp,ght,ter,sfp,cape,cin,&
            prsf, prs_new, tmk_new, qvp_new, ght_new,&
            cmsg,mix,mjy,mkzh,ter_follow,&
            psafile, errstat, errmsg)
    USE wrf_constants, ONLY : CELKEL, G, EZERO, ESLCON1, ESLCON2, &
                          EPS, RD, CP, GAMMA, CPMD, RGASMD, GAMMAMD, TLCLC1, &
                          TLCLC2, TLCLC3, TLCLC4, THTECON1, THTECON2, THTECON3

    !USE omp_lib
    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: cape, cin

    INTEGER, INTENT(IN) :: mix, mjy, mkzh, ter_follow
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(IN) :: prs
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(IN) :: tmk
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(IN) :: qvp
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(IN) :: ght
    REAL(KIND=8), DIMENSION(mix,mjy), INTENT(IN) :: ter
    REAL(KIND=8), DIMENSION(mix,mjy), INTENT(IN) ::sfp
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(OUT) :: cape
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(OUT) :: cin

    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(INOUT) :: prsf
    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(INOUT)  :: prs_new
    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(INOUT)  :: tmk_new
    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(INOUT)  :: qvp_new
    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(INOUT)  :: ght_new

    REAL(KIND=8), INTENT(IN) :: cmsg
    CHARACTER(LEN=*), INTENT(IN) :: psafile
    INTEGER, INTENT(INOUT) :: errstat
    CHARACTER(LEN=*), INTENT(INOUT) :: errmsg

! NCLFORTEND

    ! local variables
    INTEGER :: i, j, k, ilcl, kel, kk, klcl, klev, klfc, kmax, kpar
    REAL(KIND=8) :: tlcl, zlcl
    REAL(KIND=8) :: ethpari, qvppari, tmkpari
    REAL(KIND=8) :: facden, qvplift, tmklift, tvenv, tvlift, ghtlift
    REAL(KIND=8) :: eslift, tmkenv, qvpenv, tonpsadiabat
    REAL(KIND=8) :: benamin, dz
    ! Set a safety factor of 2*mkzh + 1 instead of previously chosen
    ! 150 levels
    REAL(KIND=8), DIMENSION(2*mkzh + 1) :: buoy, zrel, benaccum
    REAL(KIND=8), DIMENSION(150) :: psadithte, psadiprs
    REAL(KIND=8), DIMENSION(150,150) :: psaditmk
    LOGICAL :: elfound

    ! To remove compiler warnings
    tmkpari = 0
    qvppari = 0
    klev = 0
    klcl = 0
    kel = 0
    IF (.FALSE.) PRINT *,ter

    ! the comments were taken from a mark stoelinga email, 23 apr 2007,
    ! in response to a user getting the "outside of lookup table bounds"
    ! error message.

    ! tmkpari  - initial temperature of parcel, k
    !    values of 300 okay. (not sure how much from this you can stray.)

    ! prspari - initial pressure of parcel, hpa
    !    values of 980 okay. (not sure how much from this you can stray.)

    ! thtecon1, thtecon2, thtecon3
    !     these are all constants, the first in k and the other two have
    !     no units.  values of 3376, 2.54, and 0.81 were stated as being
    !     okay.

    ! tlcl - the temperature at the parcel's lifted condensation level, k
    !        should be a reasonable atmospheric temperature around 250-300 k
    !        (398 is "way too high")

    ! qvppari - the initial water vapor mixing ratio of the parcel,
    !           kg/kg (should range from 0.000 to 0.025)
    !

    !  calculated the pressure at full sigma levels (a set of pressure
    !  levels that bound the layers represented by the vertical grid points)

    !$OMP PARALLEL DO COLLAPSE(3) SCHEDULE(runtime)
    DO j = 1,mjy
        DO i = 1,mix
            DO k = 1,mkzh
                prs_new(k,i,j) = prs(i,j,k)
                tmk_new(k,i,j) = tmk(i,j,k)
                qvp_new(k,i,j) = qvp(i,j,k)
                ght_new(k,i,j) = ght(i,j,k)
            END DO
        END DO
    END DO
    !$OMP END PARALLEL DO

    CALL DPFCALC(prs_new, sfp, prsf, mix, mjy, mkzh, ter_follow)

    !  before looping, set lookup table for getting temperature on
    !  a pseudoadiabat.

    CALL DLOOKUP_TABLE(psadithte, psadiprs, psaditmk, psafile, errstat, errmsg)

    IF (errstat .NE. 0) THEN
        RETURN
    END IF

    !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(tlcl, ethpari, &
    !$OMP zlcl, kk, ilcl, klcl, tmklift, tvenv, tvlift, ghtlift, &
    !$OMP facden, tmkenv, qvpenv, eslift, qvplift, buoy, benamin, &
    !$OMP benaccum, zrel, kmax, dz, elfound, &
    !$OMP kel, klfc, &
    !$OMP i, j, k, kpar) SCHEDULE(runtime)
    DO j = 1,mjy
        DO i = 1,mix
            cape(i,j,1) = 0.D0
            cin(i,j,1) = 0.D0

            !!$OMP SIMD
            DO kpar = 2, mkzh

                ! Calculate temperature and moisture properties of parcel
                ! (note, qvppari and tmkpari already calculated above for 2d case.)

                tlcl = TLCLC1/(LOG(tmk_new(kpar,i,j)**TLCLC2/(MAX(1.D-20,qvp_new(kpar,i,j)*prs_new(kpar,i,j)/ &
                       (EPS + qvp_new(kpar,i,j))))) - TLCLC3) + TLCLC4

                ethpari = tmk_new(kpar,i,j)*(1000.D0/prs_new(kpar,i,j))**(GAMMA*(1.D0 + GAMMAMD*qvp_new(kpar,i,j)))* &
                          EXP((THTECON1/tlcl - THTECON2)*qvp_new(kpar,i,j)*(1.D0 + THTECON3*qvp_new(kpar,i,j)))

                zlcl = ght_new(kpar,i,j) + (tmk_new(kpar,i,j) - tlcl)/(G/CP * (1.D0 + CPMD*qvp_new(kpar,i,j)))

                ! Calculate buoyancy and relative height of lifted parcel at
                ! all levels, and store in bottom up arrays.  add a level at the lcl,
                ! and at all points where buoyancy is zero.
                !
                ! For arrays that go bottom to top
                kk = 0
                ilcl = 0

                IF (ght_new(kpar,i,j) .GE. zlcl) THEN
                    ! Initial parcel already saturated or supersaturated.
                    ilcl = 2
                    klcl = 1
                END IF

                !!$OMP SIMD lastprivate(qvplift,tmklift,ghtlift,tvlift,tmkenv,qvpenv,tvenv,eslift,facden)
                DO k = kpar,1,-1
                    ! For arrays that go bottom to top
                    kk = kk + 1

                    ! Model level is below lcl
                    IF (ght_new(k,i,j) .LT. zlcl) THEN
                        tmklift = tmk_new(kpar,i,j) - G/(CP * (1.D0 + CPMD*qvp_new(kpar,i,j)))*&
                                  (ght_new(k,i,j) - ght_new(kpar,i,j))
                        tvenv = tmk_new(k,i,j)*(EPS + qvp_new(k,i,j))/(EPS*(1.D0 + qvp_new(k,i,j)))
                        tvlift = tmklift*(EPS + qvp_new(kpar,i,j))/(EPS*(1.D0 + qvp_new(kpar,i,j)))
                        ghtlift = ght_new(k,i,j)
                    ELSE IF (ght(i,j,k) .GE. zlcl .AND. ilcl .EQ. 0) THEN
                        ! This model level and previous model level straddle the lcl,
                        ! so first create a new level in the bottom-up array, at the lcl.
                        facden = 1.0/(ght_new(k,i,j) - ght_new(k+1,i,j))
                        tmkenv = tmk_new(k+1,i,j)*((ght_new(k,i,j)-zlcl)*facden) + tmk_new(k,i,j)*&
                                 ((zlcl-ght_new(k+1,i,j))*facden)
                        qvpenv = qvp_new(k+1,i,j)*((ght_new(k,i,j)-zlcl)*facden) + qvp_new(k,i,j)*&
                                 ((zlcl-ght_new(k+1,i,j))*facden)
                        tvenv = tmkenv* (EPS + qvpenv) / (EPS * (1.D0 + qvpenv))
                        tvlift = tlcl* (EPS + qvp_new(kpar,i,j)) / (EPS *(1.D0 + qvp_new(kpar,i,j)))
                        ghtlift = zlcl
                        ilcl = 1
                    ELSE
                        tmklift = TONPSADIABAT(ethpari, prs_new(k,i,j), psadithte, psadiprs,&
                                             psaditmk, GAMMA, errstat, errmsg)
                        eslift = EZERO*EXP(ESLCON1*(tmklift - CELKEL)/(tmklift - ESLCON2))
                        qvplift = EPS*eslift/(prs_new(k,i,j) - eslift)
                        tvenv = tmk_new(k,i,j) * (EPS + qvp_new(k,i,j)) / (EPS * (1.D0 + qvp_new(k,i,j)))
                        tvlift = tmklift*(EPS + qvplift) / (EPS * (1.D0 + qvplift))
                        ghtlift = ght_new(k,i,j)
                    END IF
                    ! Buoyancy
                    buoy(kk) = G*(tvlift - tvenv)/tvenv
                    zrel(kk) = ghtlift - ght_new(kpar,i,j)
                    IF ((kk .GT. 1) .AND. (buoy(kk)*buoy(kk-1) .LT. 0.0D0)) THEN
                        ! Parcel ascent curve crosses sounding curve, so create a new level
                        ! in the bottom-up array at the crossing.
                        kk = kk + 1
                        buoy(kk) = buoy(kk-1)
                        zrel(kk) = zrel(kk-1)
                        buoy(kk-1) = 0.D0
                        zrel(kk-1) = zrel(kk-2) + buoy(kk-2)/&
                                     (buoy(kk-2) - buoy(kk))*(zrel(kk) - zrel(kk-2))
                    END IF
                    IF (ilcl .EQ. 1) THEN
                        klcl = kk
                        ilcl = 2
                        CYCLE
                    END IF

                END DO

                kmax = kk
                ! IF (kmax .GT. 150) THEN
                !      print *,'kmax got too big'
                !     errstat = ALGERR
                !     WRITE(errmsg, *) 'capecalc3d: kmax got too big. kmax=',kmax
                !     RETURN
                ! END IF

                ! If no lcl was found, set klcl to kmax.  it is probably not really
                ! at kmax, but this will make the rest of the routine behave
                ! properly.
                IF (ilcl .EQ. 0) klcl=kmax

                ! Get the accumulated buoyant energy from the parcel's starting
                ! point, at all levels up to the top level.
                benaccum(1) = 0.0D0
                benamin = 9d9
                DO k = 2,kmax
                    dz = zrel(k) - zrel(k-1)
                    benaccum(k) = benaccum(k-1) + .5D0*dz*(buoy(k-1) + buoy(k))
                    IF (benaccum(k) .LT. benamin) THEN
                        benamin = benaccum(k)
                    END IF
                END DO
                ! Determine equilibrium level (el), which we define as the highest
                ! level of non-negative buoyancy above the lcl. note, this may be
                ! the top level if the parcel is still buoyant there.

                elfound = .FALSE.
                DO k = kmax,klcl,-1
                    IF (buoy(k) .GE. 0.D0) THEN
                        ! k of equilibrium level
                        kel = k
                        elfound = .TRUE.
                        EXIT
                    END IF
                END DO

                ! If we got through that loop, then there is no non-negative
                ! buoyancy above the lcl in the sounding.  in these situations,
                ! both cape and cin will be set to -0.1 j/kg. (see below about
                ! missing values in v6.1.0). also, where cape is
                ! non-zero, cape and cin will be set to a minimum of +0.1 j/kg, so
                ! that the zero contour in either the cin or cape fields will
                ! circumscribe regions of non-zero cape.

                ! In v6.1.0 of ncl, we added a _fillvalue attribute to the return
                ! value of this function. at that time we decided to change -0.1
                ! to a more appropriate missing value, which is passed into this
                ! routine as cmsg.

                IF (.NOT. elfound) THEN
                    !print *,'el not found'
                    cape(i,j,kpar) = cmsg
                    cin(i,j,kpar)  = cmsg
                    klfc = kmax
                    CYCLE
                END IF

                ! If there is an equilibrium level, then cape is positive.  we'll
                ! define the level of free convection (lfc) as the point below the
                ! el, but at or above the lcl, where accumulated buoyant energy is a
                ! minimum.  the net positive area (accumulated buoyant energy) from
                ! the lfc up to the el will be defined as the cape, and the net
                ! negative area (negative of accumulated buoyant energy) from the
                ! parcel starting point to the lfc will be defined as the convective
                !  inhibition (cin).

                ! First get the lfc according to the above definition.
                benamin = 9D9
                klfc = kmax
                DO k = klcl,kel
                    IF (benaccum(k) .LT. benamin) THEN
                        benamin = benaccum(k)
                        klfc = k
                    END IF
                END DO

                ! Now we can assign values to cape and cin

                cape(i,j,kpar) = MAX(benaccum(kel)-benamin, 0.1D0)
                cin(i,j,kpar) = MAX(-benamin, 0.1D0)

                ! cin is uninteresting when cape is small (< 100 j/kg), so set
                ! cin to -0.1 (see note about missing values in v6.1.0) in
                ! that case.

                ! In v6.1.0 of ncl, we added a _fillvalue attribute to the return
                ! value of this function. at that time we decided to change -0.1
                ! to a more appropriate missing value, which is passed into this
                ! routine as cmsg.

                IF (cape(i,j,kpar) .LT. 100.D0) cin(i,j,kpar) = cmsg

            END DO
        END DO
    END DO
    !$OMP END PARALLEL DO

    RETURN
END SUBROUTINE DCAPECALC3D

!======================================================================
!
! !IROUTINE: capecalc2d -- Calculate CAPE and CIN
!
! !DESCRIPTION:
!
!   Calculates CAPE and CIN only for the parcel with max theta-e in
!   the column, (i.e. something akin to Colman's MCAPE).  By "parcel",
!   we mean a 500-m deep parcel, with actual temperature and moisture
!   averaged over that depth.
!
!   CAPE and CIN are 2D fields that are placed in the k=mkzh slabs of
!   the cape and cin arrays.  Also, LCL and LFC heights
!   are put in the k=mkzh-1 and k=mkzh-2 slabs of the cin array.
!
! Important!  The z-indexes must be arranged so that mkzh (max z-index) is the
! surface pressure.  So, pressure must be ordered in ascending order before
! calling this routine.  Other variables must be ordered the same (p,tk,q,z).

! Also, be advised that missing data values are not checked during the
! computation.
! Also also, Pressure must be hPa

! NCLFORTSTART
SUBROUTINE DCAPECALC2D(prs,tmk,qvp,ght,ter,sfp,cape,cin,&
            prsf, prs_new, tmk_new, qvp_new, ght_new,&
            cmsg,mix,mjy,mkzh,ter_follow,&
            psafile, errstat, errmsg)
    USE wrf_constants, ONLY : CELKEL, G, EZERO, ESLCON1, ESLCON2, &
                          EPS, RD, CP, GAMMA, CPMD, RGASMD, GAMMAMD, TLCLC1, &
                          TLCLC2, TLCLC3, TLCLC4, THTECON1, THTECON2, THTECON3

    !USE omp_lib
    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: cape, cin

    INTEGER, INTENT(IN) :: mix, mjy, mkzh, ter_follow
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(IN) :: prs
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(IN) :: tmk
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(IN) :: qvp
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(IN) :: ght
    REAL(KIND=8), DIMENSION(mix,mjy), INTENT(IN) :: ter
    REAL(KIND=8), DIMENSION(mix,mjy), INTENT(IN) ::sfp
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(OUT) :: cape
    REAL(KIND=8), DIMENSION(mix,mjy,mkzh), INTENT(OUT) :: cin

    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(INOUT) :: prsf
    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(INOUT) :: prs_new
    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(INOUT) :: tmk_new
    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(INOUT) :: qvp_new
    REAL(KIND=8), DIMENSION(mkzh,mix,mjy), INTENT(INOUT) :: ght_new

    REAL(KIND=8), INTENT(IN) :: cmsg
    CHARACTER(LEN=*), INTENT(IN) :: psafile
    INTEGER, INTENT(INOUT) :: errstat
    CHARACTER(LEN=*), INTENT(INOUT) :: errmsg

! NCLFORTEND

    ! local variables
    INTEGER :: i, j, k, ilcl, kel, kk, klcl, klev, klfc, kmax, kpar, kpar1, kpar2
    REAL(KIND=8) :: ethmax, p, e, tlcl, zlcl
    REAL(KIND=8) :: pavg, tvirtual, p1, p2, pp1, pp2, th, totthe, totqvp, totprs
    REAL(KIND=8) :: cpm, deltap, ethpari, gammam, qvppari, tmkpari
    REAL(KIND=8) :: facden, qvplift, tmklift, tvenv, tvlift, ghtlift
    REAL(KIND=8) :: eslift, tmkenv, qvpenv, tonpsadiabat
    REAL(KIND=8) :: benamin, dz, pup, pdn
    ! Set a safety factor of 2*mkzh + 1 instead of previously chosen
    ! 150 levels
    REAL(KIND=8), DIMENSION(2*mkzh + 1) :: buoy, zrel, benaccum
    REAL(KIND=8), DIMENSION(150) :: psadithte, psadiprs
    REAL(KIND=8), DIMENSION(150,150) :: psaditmk
    LOGICAL :: elfound
    REAL(KIND=8), DIMENSION(mkzh) :: eth_temp

    ! To remove compiler warnings
    errstat = 0
    tmkpari = 0
    qvppari = 0
    klev = 0
    klcl = 0
    kel = 0
    deltap = 0

    ! the comments were taken from a mark stoelinga email, 23 apr 2007,
    ! in response to a user getting the "outside of lookup table bounds"
    ! error message.

    ! tmkpari  - initial temperature of parcel, k
    !    values of 300 okay. (not sure how much from this you can stray.)

    ! prspari - initial pressure of parcel, hpa
    !    values of 980 okay. (not sure how much from this you can stray.)

    ! thtecon1, thtecon2, thtecon3
    !     these are all constants, the first in k and the other two have
    !     no units.  values of 3376, 2.54, and 0.81 were stated as being
    !     okay.

    ! tlcl - the temperature at the parcel's lifted condensation level, k
    !        should be a reasonable atmospheric temperature around 250-300 k
    !        (398 is "way too high")

    ! qvppari - the initial water vapor mixing ratio of the parcel,
    !           kg/kg (should range from 0.000 to 0.025)
    !

    !$OMP PARALLEL DO COLLAPSE(3) SCHEDULE(runtime)
    DO j = 1,mjy
        DO i = 1,mix
            DO k = 1,mkzh
                prs_new(k,i,j) = prs(i,j,k)
                tmk_new(k,i,j) = tmk(i,j,k)
                qvp_new(k,i,j) = qvp(i,j,k)
                ght_new(k,i,j) = ght(i,j,k)
            END DO
        END DO
    END DO
    !$OMP END PARALLEL DO

    !  calculated the pressure at full sigma levels (a set of pressure
    !  levels that bound the layers represented by the vertical grid points)
    CALL DPFCALC(prs_new, sfp, prsf, mix, mjy, mkzh, ter_follow)

    !  before looping, set lookup table for getting temperature on
    !  a pseudoadiabat.

    CALL DLOOKUP_TABLE(psadithte, psadiprs, psaditmk, psafile, errstat, errmsg)

    IF (errstat .NE. 0) THEN
        RETURN
    END IF

    !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(tlcl, ethpari, &
    !$OMP zlcl, kk, ilcl, klcl, tmklift, tvenv, tvlift, ghtlift, &
    !$OMP facden, tmkenv, qvpenv, eslift, qvplift, buoy, benamin, &
    !$OMP benaccum, zrel, kmax, dz, elfound, gammam, cpm, e, &
    !$OMP kel, klfc, pavg, p2, p1, totthe, totqvp, totprs, &
    !$OMP i, j, k, kpar, kpar1, kpar2, qvppari, tmkpari, p, pup, pdn, th, &
    !$OMP pp1, pp2, ethmax, eth_temp, klev) SCHEDULE(runtime)
    DO j = 1,mjy
        DO i = 1,mix
            cape(i,j,1) = 0.D0
            cin(i,j,1) = 0.D0
            ! find parcel with max theta-e in lowest 3 km agl.
            ethmax = -1.D0
            eth_temp = -1.D0
            DO k = 1, mkzh
                IF (ght_new(k,i,j)-ter(i,j) .LT. 3000.D0) THEN
                    tlcl = TLCLC1 / (LOG(tmk_new(k,i,j)**TLCLC2/&
                           (MAX(qvp_new(k,i,j), 1.d-15)*prs_new(k,i,j)/(EPS+MAX(qvp_new(k,i,j), 1.d-15))))-TLCLC3)+&
                           TLCLC4
                    eth_temp(k) = tmk_new(k,i,j) * (1000.D0/prs_new(k,i,j))**&
                                  (GAMMA*(1.D0 + GAMMAMD*(MAX(qvp_new(k,i,j), 1.d-15))))*&
                                  EXP((THTECON1/tlcl - THTECON2)*(MAX(qvp_new(k,i,j), 1.d-15))*&
                                  (1.D0 + THTECON3*(MAX(qvp_new(k,i,j), 1.d-15))))
                END IF
            END DO
            klev = mkzh
            DO k = 1,mkzh
                IF (eth_temp(k) .GT. ethmax) THEN
                    klev = k
                    ethmax = eth_temp(k)
                END IF
            END DO

            kpar1 = klev
            kpar2 = klev

            ! Establish average properties of that parcel
            ! (over depth of approximately davg meters)

            !davg = 500.D0
            pavg = 500.D0 * prs_new(kpar1,i,j)*&
                   G/(RD*tvirtual(tmk_new(kpar1,i,j), qvp_new(kpar1,i,j)))
            p2 = MIN(prs_new(kpar1,i,j)+.5d0*pavg, prsf(mkzh,i,j))
            p1 = p2 - pavg
            totthe = 0.D0
            totqvp = 0.D0
            totprs = 0.D0
            DO k = mkzh,2,-1
                IF (prsf(k,i,j) .LE. p1) EXIT !GOTO 35
                IF (prsf(k-1,i,j) .GE. p2) CYCLE !GOTO 34
                p = prs_new(k,i,j)
                pup = prsf(k,i,j)
                pdn = prsf(k-1,i,j)
                !q = MAX(qvp_new(k,i,j),1.D-15)
                th = tmk_new(k,i,j)*(1000.D0/prs_new(k,i,j))**(GAMMA*(1.D0 + GAMMAMD*MAX(qvp_new(k,i,j),1.D-15)))
                pp1 = MAX(p1,pdn)
                pp2 = MIN(p2,pup)
                IF (pp2 .GT. pp1) THEN
                    ! deltap = pp2 - pp1
                    totqvp = totqvp + MAX(qvp_new(k,i,j),1.D-15)*(pp2 - pp1)
                    totthe = totthe + th*(pp2 - pp1)
                    totprs = totprs + (pp2 - pp1)
                END IF
            END DO
            qvppari = totqvp/totprs
            tmkpari = (totthe/totprs)*&
                      (prs_new(kpar1,i,j)/1000.D0)**(GAMMA*(1.D0+GAMMAMD*qvp_new(kpar1,i,j)))

            DO kpar = kpar1, kpar2

                ! Calculate temperature and moisture properties of parcel
                ! (note, qvppari and tmkpari already calculated above for 2d
                ! case.)

                !prspari = prs_new(kpar,i,j)
                !ghtpari = ght_new(kpar,i,j)
                gammam = GAMMA * (1.D0 + GAMMAMD*qvppari)
                cpm = CP * (1.D0 + CPMD*qvppari)

                e = MAX(1.D-20,qvppari*prs_new(kpar,i,j)/(EPS + qvppari))
                tlcl = TLCLC1/(LOG(tmkpari**TLCLC2/e) - TLCLC3) + TLCLC4
                ethpari = tmkpari*(1000.D0/prs_new(kpar,i,j))**(GAMMA*(1.D0 + GAMMAMD*qvppari))*&
                          EXP((THTECON1/tlcl - THTECON2)*qvppari*(1.D0 + THTECON3*qvppari))
                zlcl = ght_new(kpar,i,j) + (tmkpari - tlcl)/(G/cpm)

                ! Calculate buoyancy and relative height of lifted parcel at
                ! all levels, and store in bottom up arrays.  add a level at the
                ! lcl,
                ! and at all points where buoyancy is zero.
                !
                !
                ! For arrays that go bottom to top
                kk = 0
                ilcl = 0

                IF (ght_new(kpar,i,j) .GE. zlcl) THEN
                    ! Initial parcel already saturated or supersaturated.
                    ilcl = 2
                    klcl = 1
                END IF

                k = kpar
                DO k = kpar,1,-1
                    ! For arrays that go bottom to top
                    kk = kk + 1

                    ! Model level is below lcl
                    IF (ght_new(k,i,j) .LT. zlcl) THEN
                        tmklift = tmk_new(kpar,i,j) - G/(CP * (1.D0 + CPMD*qvp_new(kpar,i,j)))*&
                                  (ght_new(k,i,j) - ght_new(kpar,i,j))
                        tvenv = tmk_new(k,i,j)*(EPS + qvp_new(k,i,j))/(EPS*(1.D0 + qvp_new(k,i,j)))
                        tvlift = tmklift*(EPS + qvp_new(kpar,i,j))/(EPS*(1.D0 + qvp_new(kpar,i,j)))
                        ghtlift = ght_new(k,i,j)
                    ELSE IF (ght(i,j,k) .GE. zlcl .AND. ilcl .EQ. 0) THEN
                        ! This model level and previous model level straddle the lcl,
                        ! so first create a new level in the bottom-up array, at the lcl.
                        facden = 1/(ght_new(k,i,j) - ght_new(k+1,i,j))
                        tmkenv = tmk_new(k+1,i,j)*((ght_new(k,i,j)-zlcl)*facden) + tmk_new(k,i,j)*&
                                 ((zlcl-ght_new(k+1,i,j))*facden)
                        qvpenv = qvp_new(k+1,i,j)*((ght_new(k,i,j)-zlcl)*facden) + qvp_new(k,i,j)*&
                                 ((zlcl-ght_new(k+1,i,j))*facden)
                        tvenv = tmkenv* (EPS + qvpenv) / (EPS * (1.D0 + qvpenv))
                        tvlift = tlcl* (EPS + qvp_new(kpar,i,j)) / (EPS *(1.D0 + qvp_new(kpar,i,j)))
                        ghtlift = zlcl
                        ilcl = 1
                    ELSE
                        tmklift = TONPSADIABAT(ethpari, prs_new(k,i,j), psadithte, psadiprs,&
                                               psaditmk, GAMMA, errstat, errmsg)
                        eslift = EZERO*EXP(ESLCON1*(tmklift - CELKEL)/(tmklift - ESLCON2))
                        qvplift = EPS*eslift/(prs_new(k,i,j) - eslift)
                        tvenv = tmk_new(k,i,j) * (EPS + qvp_new(k,i,j)) / (EPS * (1.D0 + qvp_new(k,i,j)))
                        tvlift = tmklift*(EPS + qvplift) / (EPS * (1.D0 + qvplift))
                        ghtlift = ght_new(k,i,j)
                    END IF
                    ! Buoyancy
                    buoy(kk) = G*(tvlift - tvenv)/tvenv
                    zrel(kk) = ghtlift - ght_new(kpar,i,j)
                    IF ((kk .GT. 1) .AND. (buoy(kk)*buoy(kk-1) .LT. 0.0D0)) THEN
                        ! Parcel ascent curve crosses sounding curve, so create a new level
                        ! in the bottom-up array at the crossing.
                        kk = kk + 1
                        buoy(kk) = buoy(kk-1)
                        zrel(kk) = zrel(kk-1)
                        buoy(kk-1) = 0.D0
                        zrel(kk-1) = zrel(kk-2) + buoy(kk-2)/&
                                     (buoy(kk-2) - buoy(kk))*(zrel(kk) - zrel(kk-2))
                    END IF
                    IF (ilcl .EQ. 1) THEN
                        klcl = kk
                        ilcl = 2
                        CYCLE
                    END IF
                END DO

                kmax = kk
                ! IF (kmax .GT. 150) THEN
                !     errstat = ALGERR
                !     WRITE(errmsg, *) 'capecalc3d: kmax got too big. kmax=',kmax
                !     RETURN
                ! END IF

                ! If no lcl was found, set klcl to kmax.  it is probably not
                ! really
                ! at kmax, but this will make the rest of the routine behave
                ! properly.
                IF (ilcl .EQ. 0) klcl=kmax

                ! Get the accumulated buoyant energy from the parcel's starting
                ! point, at all levels up to the top level.
                benaccum(1) = 0.0D0
                benamin = 9d9
                DO k = 2,kmax
                    dz = zrel(k) - zrel(k-1)
                    benaccum(k) = benaccum(k-1) + .5D0*dz*(buoy(k-1) + buoy(k))
                    IF (benaccum(k) .LT. benamin) THEN
                        benamin = benaccum(k)
                    END IF
                END DO
                ! Determine equilibrium level (el), which we define as the highest
                ! level of non-negative buoyancy above the lcl. note, this may be
                ! the top level if the parcel is still buoyant there.

                elfound = .FALSE.
                DO k = kmax,klcl,-1
                    IF (buoy(k) .GE. 0.D0) THEN
                        ! k of equilibrium level
                        kel = k
                        elfound = .TRUE.
                        EXIT
                    END IF
                END DO

                ! If we got through that loop, then there is no non-negative
                ! buoyancy above the lcl in the sounding.  in these situations,
                ! both cape and cin will be set to -0.1 j/kg. (see below about
                ! missing values in v6.1.0). also, where cape is
                ! non-zero, cape and cin will be set to a minimum of +0.1 j/kg, so
                ! that the zero contour in either the cin or cape fields will
                ! circumscribe regions of non-zero cape.
                ! In v6.1.0 of ncl, we added a _fillvalue attribute to the return
                ! value of this function. at that time we decided to change -0.1
                ! to a more appropriate missing value, which is passed into this
                ! routine as cmsg.

                IF (.NOT. elfound) THEN
                    cape(i,j,kpar) = cmsg
                    cin(i,j,kpar)  = cmsg
                    klfc = kmax
                    CYCLE
                END IF

                ! If there is an equilibrium level, then cape is positive.
                ! we'll
                ! define the level of free convection (lfc) as the point below
                ! the
                ! el, but at or above the lcl, where accumulated buoyant energy
                ! is a
                ! minimum.  the net positive area (accumulated buoyant energy)
                ! from
                ! the lfc up to the el will be defined as the cape, and the net
                ! negative area (negative of accumulated buoyant energy) from
                ! the
                ! parcel starting point to the lfc will be defined as the
                ! convective
                ! inhibition (cin).

                ! First get the lfc according to the above definition.
                benamin = 9D9
                klfc = kmax
                DO k = klcl,kel
                    IF (benaccum(k) .LT. benamin) THEN
                        benamin = benaccum(k)
                        klfc = k
                    END IF
                END DO

                ! Now we can assign values to cape and cin

                cape(i,j,kpar) = MAX(benaccum(kel)-benamin, 0.1D0)
                cin(i,j,kpar) = MAX(-benamin, 0.1D0)

                ! cin is uninteresting when cape is small (< 100 j/kg), so set
                ! cin to -0.1 (see note about missing values in v6.1.0) in
                ! that case.

                ! In v6.1.0 of ncl, we added a _fillvalue attribute to the return
                ! value of this function. at that time we decided to change -0.1
                ! to a more appropriate missing value, which is passed into this
                ! routine as cmsg.

                IF (cape(i,j,kpar) .LT. 100.D0) cin(i,j,kpar) = cmsg

            END DO

            cape(i,j,mkzh) = cape(i,j,kpar1)
            cin(i,j,mkzh) = cin(i,j,kpar1)
            ! meters agl
            cin(i,j,mkzh-1) = zrel(klcl) + ght_new(kpar1,i,j) - ter(i,j)
            ! meters agl
            cin(i,j,mkzh-2) = zrel(klfc) + ght_new(kpar1,i,j) - ter(i,j)

        END DO
    END DO
    !$OMP END PARALLEL DO

    RETURN
END SUBROUTINE DCAPECALC2D


      subroutine testfun(idim, jdim, r, fun)
      implicit none
      integer idim, jdim
      real    r(idim,jdim,2), fun

      integer i, j

      do i=1,idim
         do j=1,jdim
c           fun = fun + r(i,j,1)**2 + r(i,j,2)**2
            fun = fun + r(i,j,1) * r(i,j,2)
         enddo
      enddo

      return
      end

      subroutine testgrad(idim, jdim, r, rb, fun)
      implicit none
      integer idim, jdim
      real    r(idim,jdim,2), fun
      real    rb(idim,jdim,2)

      integer i, j

      do i=1,idim
         do j=1,jdim
c           rb(i,j,1) = 2.0*r(i,j,1)
c           rb(i,j,2) = 2.0*r(i,j,2)
            rb(i,j,1) = r(i,j,2)
            rb(i,j,2) = r(i,j,1)
         enddo
      enddo

      return
      end


subroutine ComputeDMap(Dij, dh_mask, n_dh, sampling, lmax)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will compute the matrix D(lm,l'm') for the spatiospectral concentration
!	problem using the input grid DH_MASK to define the concentration region. The
!	input grid must be sampled according to the Driscoll and Healy sampling theorem
!	and must possess values of 1 inside the concentration region, and 0 elsewhere. The grid
!	possess N_DH samples in latitude, and either N_DH samples in longitude for SAMPLING=1
!	or 2*N_DH samples in longitude for SAMPLING=2. Elements of the matrix D
!	(which are ordered accoring to YilmIndex) are computed up to a maximum degree LMAX.
!
!	It should be noted that the elements of D are computed approximately. These are explicitly
!	calculated using
!
!		Dlm,l'm' = 1/(4 pi) Int_Omega F Yl'm' dOmega
!
!	where
!
!		F = Ylm * DH_MASK.
!
!	This integral would be computed exactly if F had a bandwith of
!	L = N_DH/2 - 1. However, since DH_MASK has an infinite bandwidth, this will not be true. However,
!	if L is larger than LMAX, then we might expect that the spherical harmonic expansions will
!	be good approximations. This needs to be verified by chosing different values of N_DH and
!	comparing the results. A simple comparison is to see how good the D(1,1) element approximates
!	the area of the concentration region.
!
!	Calling Parameters
!		IN
!			dh_mask		Integer grid sampled according to the Driscoll and Healy sampling
!					theorem. A value of 1 indicates the the grid node is in the concentration
!					domain, and a value of 0 indicates that it is outside. Dimensioned as
!					(n_dh, n_dh) for SAMPLING = 1 or (n_dh, 2*n_dh) for SAMPLING = 2.
!			n_dh		The number of latitude samples in the Driscoll and Healy sampled grid.
!			SAMPLING	1 corresponds to equal sampling (n_dh, n_dh), whereas 2 corresponds
!					to equal spaced grids (n_dh, 2*n_dh).
!			lmax		Maximum spherical harmonic degree of elements in the matrix D.
!		OUT
!			Dij		Elements of the matrix D, which is symmetric, and whose elements
!					are packed into a 1D array according to YilmINDEX. Dimesions of
!					Dij are ((lmax+1)**2, (lmax+1)**2).
!
!	Written by Mark Wieczorek (August 2009)
!
!	Copyright (c) 2009, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only : SHExpandDH, PlmIndex, PlmBar, SHCilmToVector, YilmIndex

	implicit none

	real*8, intent(out) ::	Dij(:,:)
	integer, intent(in) ::	dh_mask(:,:), n_dh, sampling, lmax
	integer ::		nlat, nlong, lmax_dh, astat, i, j, k, l, m, max_mask, min_mask
	real*8, allocatable ::	f(:,:), plm(:), clm(:,:,:), vec(:)
	real*8 ::		colat, lat_int, temp(2*n_dh), lon, lon_int

	if (size(Dij(:,1)) < (lmax+1)**2 .or. size(Dij(1,:)) < (lmax+1)**2) then
		print*, "Error --- ComputeDMap"
		print*, "Dij must be dimesioned as ((LMAX+1)**2, (LMAX+1)**2)."
		print*, "Dij is dimensioned as ", size(Dij(:,1)), size(Dij(1,:))
		stop
	endif

	if (mod(n_dh,2) /= 0) then
		print*, "Error --- ComputeDMap"
		print*, "Number of samples in latitude must be even for the Driscoll and Healy sampling theorem."
		print*, "N_DH = ", n_dh
		stop
	endif

	nlat = n_dh
	lat_int = acos(-1.0d0) / dble(nlat)
	if (sampling == 1) then
		nlong = nlat
		lon_int = 2.0d0*lat_int
	elseif (sampling == 2) then
		nlong = 2*nlat
		lon_int = lat_int
	else
		print*, "Error --- ComputeDMap"
		print*, "SAMPLING must be either 1 (equally sampled) or 2 (equally spaced)."
		print*, "SAMPLING = ", sampling
		stop
	endif

	if (size(dh_mask(:,1)) < nlat .or. size(dh_mask(1,:)) < nlong) then
		print*, "Error --- ComputeDMap"
		print*, "DH_MASK must be dimensioned as ", nlat, nlong
		print*, "Dimensions of DH_MASK are ", size(dh_mask(:,1)), size(dh_mask(1,:))
		stop
	endif

	lmax_dh = n_dh/2 - 1

	if (lmax_dh < lmax) then
		print*, "Error --- ComputeDMap"
		print*, "The effective bandwith of the input grid DH_MASK must be greater or equal than LMAX."
		print*, "LMAX = ", lmax
		print*, "Effective bandwidth of DH_MASK = ", lmax_dh
		stop
	endif

	allocate(f(nlat,nlong), stat = astat)
	if (astat /= 0) then
		print*, "Error --- ComputeDMap"
		print*, "Problem allocating memory for grid F(NLAT, NLONG)."
		print*, "NLAT = ", nlat
		print*, "NLONG = ", nlong
		stop
	endif

	allocate(plm((lmax+1)*(lmax+2)/2), stat = astat)
	if (astat /= 0) then
		print*, "Error --- ComputeDMap"
		print*, "Problem allocating memory for grid PLM((LMAX+1)*(LMAX+2)/2)."
		print*, "LMAX = ", lmax
		stop
	endif

	allocate(clm(2, lmax+1, lmax+1), stat = astat)
	if (astat /= 0) then
		print*, "Error --- ComputeDMap"
		print*, "Problem allocating memory for CLM(2, LMAX+1, LMAX+1)."
		stop
	endif

	allocate(vec((lmax+1)**2), stat = astat)
	if (astat /= 0) then
		print*, "Error --- ComputeDMap"
		print*, "Problem allocating memory for VEC((LMAX+1)**2)."
		print*, "LMAX = ", lmax
		stop
	endif

	min_mask = minval(dh_mask(1:nlat, 1:nlong))
	max_mask = maxval(dh_mask(1:nlat, 1:nlong))
	if (min_mask < 0 .or. max_mask > 1) then
		print*, "Error --- ComputeDMap"
		print*, "DH_MASK must consist of 0s exterior to the concentration region"
		print*, "and 1s inside of the concentration region."
		print*, "Minimum value of DH_MASK = ", min_mask
		print*, "Maximum value of DH_MASK = ", max_mask
		stop
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Compute elements of Dij. Start at high degrees, and work towards
	!	low degrees. Dij is symmetric.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	dij = 0.0d0

	do l=lmax, 0, -1
		print*, "ComputeDMap --- Working on degree", l
		do m=0, l
			do j=1, 2

				if (m==0 .and. j==2) cycle

				!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
				!
				!	Make Map of Yilm * mask
				!
				!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

				do k=1, nlong
					lon = dble(k-1)*lon_int
					if (j==1) then
						temp(k) = cos(dble(m)*lon)
					else
						temp(k) = sin(dble(m)*lon)
					endif
				enddo

				do k=1, nlat
					colat = dble(k-1)*lat_int
					call plmbar(plm, l, cos(colat))
					f(k, 1:nlong) = plm(plmindex(l,m)) * temp(1:nlong) &
							* dble(dh_mask(k, 1:nlong))
				enddo

				i = YilmIndex(j, l, m)

				call SHExpandDH(f, n_dh, clm, lmax_dh, sampling = sampling, lmax_calc = l)

				call SHCilmToVector(clm, vec, l)

				dij(i, 1:(l+1)**2) = vec(1:(l+1)**2)

				if (l /= 0) dij(1:(l+1)**2 - 1, i) = vec(1:(l+1)**2 - 1)

			enddo
		enddo
	enddo

	call plmbar(plm, -1, cos(colat))

	deallocate(f)
	deallocate(plm)
	deallocate(clm)
	deallocate(vec)

end subroutine ComputeDMap


PROGRAM GFPE2_HF
 USE PE2D_TYPE
 USE PE2D_VAR
 USE PE2D_AUX
 USE PE2D_GROUND
 IMPLICIT NONE
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) "========== Parabolic Equation Package =========="
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "University of Bristol"
 WRITE(*,*) "Mech. Eng. Department"
 WRITE(*,*) "Aerodynamics and Aeroacoustics Research Group"
 WRITE(*,*) ""
 WRITE(*,*) "Codor Khodr, July 2016"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "GFPE2_HT"
 WRITE(*,*) "Dimension 	: 	2D"
 WRITE(*,*) "Atmosphere	:	Homogeneous"
 WRITE(*,*) "Boundary 	:	Flat"
 WRITE(*,*) "Impedance	:	Rigid"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Enter inputs L, H, f, zs, As"
 WRITE(*,*) ""
 READ *, L, F, ZS, AS
 !----------------------------------------------------------
 !-----------------------------------------------------------
 C0     = 343.0_DP
 LMBDA0 = C0/F
 K0     = 2*PI*F/C0
 DZ     = LMBDA0/10
 DR     = LMBDA0/10
 DKZ    = 2*PI/(N*DZ)
 H      = 100*LMBDA0
 HA     = 30*LMBDA0
 N      = FLOOR(H/DZ)
 M      = FLOOR(L/DR)
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Size of the system : ", N
 WRITE(*,*) "Number of steps : ", M
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 NS     = MAX(1,FLOOR(ZS/DZ))
 NA     = FLOOR(HA/DZ)
 A      = IM/(2.0_DP*K0*DZ**2)
 BETA   = 0.0_DP
 WIDE   = 0
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Memory allocation
 ALLOCATE(K(N), KZ(N), REF(N), PHASE(N), DK2(N), Z(N), DELTA(N), R(M), &
 BUFR(N), PHI(N,M+1), FPHI(N,M), FPHII(N,M), FPHIR(N,M), FPHIS(M), &
 WA(2,N), CH(2*N), PHI1(N,M), PHI2(N,M), P(N,M), LP(N,M), LPRMS(N,M), &
 P0(N,M), LPG(M), LPRMSG(M))
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Atmosphere density and wave velocity
 DO NZ = 1,N
  C(NZ)     = C0
  K(NZ)     = K0
  DK2(NZ)   = K(NZ)**2-K0**2
  ALT(NZ)   = NZ*DZ
  PHASE(NZ) = EXP(IM*DR*(SQRT(K0**2-KZ(NZ)**2)-K0**2))
  DELTA(NZ) = EXP(IM*DR*DK2(NZ)/(2*K0))
 END DO
 !Absorbing layer (PML)
 DO NZ = N-NA,N
  K(NZ)     = K0+AS*IM*(NZ-N+NA)**2/NA**2
 END
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Terrain Boundary condition
 LIN(-1) = 0
 THETA   = ANGLE*PI/180.0_DP
 X0      = L/2.0_DP
 S       = L/5.0_DP
 H0      = SQRT(EXP(1.0_DP)/2.0_DP)*S*ATAN(THETA)
 DO MX = 0,M
  GHX      = GHILL(H0,X0,S,MX*DR)
  TERR(MX)  = GHX(1)
  TERR1(MX) = GHX(2)
  TERR2(MX) = GHX(3)
  R(MX)     = MX*DR
  LIN(MX)   = LIN(MX-1)+(1+TERR1(MX))*DR
  SLOPE(MX) = ATAN(TERR1(MX))
 END DO
 !TERR1 = DIFF1(X,TERR)
 !TERR2 = DIFF2(X,TERR)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Starting field
 A0 = 1.3717_DP
 A2 = -0.3701_DP
 B  = 3.0_DP
 DO NZ = 1,N
  PHI(NZ,1) = SQRT(IM*K0)* &
              ((A0+A2*K0**2*(NZ*DZ-ZS)**2)*EXP(-K0**2*(NZ*DZ-ZS)**2/B) + &
              (A0+A2*K0**2*(NZ*DZ+ZS)**2)*EXP(-K0**2*(NZ*DZ+ZS)**2/B))
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Forward-marching procedure
 CALL CPU_TIME(TI)
 CALL CFFTI1(N,WA,IFAC)      !IFAC AND WA DEPEND ONLY ON N -> USED IN CFFTF1 AND CFFTB1
 DO MX = 2,M+1
  WRITE(*, *) "STEP :", MX-1, "OUT OF", M
  !-------------------------------
  !-------------------------------
  !Surface term
  DO NZ = 1,N
   FPHIS(MX-1)  = FPHIS(MX-1)+PHI(NZ,MX-1)*DZ*EXP(-J*BETA*NZ*DZ)
  END DO
  !-------------------------------
  !-------------------------------
  !Forward Fourier transform
  TEMP          = PHI(:,MX-1)
  CALL CFFTF1(N,TEMP,CH,WA,IFAC)
  FPHII(:,MX-1) = TEMP                                          !Incident wave
  CALL FLIP(TEMP,FPHIR(:,MX-1))                                 !Reflected wave
  FPHI(:,MX-1)  = (FPHII(:,MX-1)+FPHIR(:,MX-1))*PHASE           !Total wave
  !Inverse Fourier Transform
  TEMP          = FPHI(:,MX-1)
  CALL CFFTB1(N,TEMP,CH,WA,IFAC)
  PHI1(:,MX-1)  = TEMP/N                                        !Normalize Fourier Transform
  PHI2(:,MX-1)  = 2*IM*BETA*FPHIS(MX-1)*EXP(-IM*BETA*Z)*EXP(IM*DR*(SQRT(K0**2-BETA**2)-K0**2))
  PHI(:,MX)     = DELTA*(PHI1(:,MX-1)+PHI2(:,MX-1))*EXP(IM*K0*Z*TERR2(MX-1))
  !-------------------------------
  !-------------------------------
  !Real pressure
  P(:,MX-1)     = EXP(IM*K0*(MX-1)*DR)*PHI(:,MX)*(1/SQRT((MX-1)*DR))
 END DO
 CALL CPU_TIME(TF)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Transmission loss conversion
 P0 = ABS(P(NS,1))
 DO MX = 1,M
  DO NZ = 1,N
   LP(NZ,MX) = 20.*LOG10(ABS(P(NZ,MX))/P0)
   IF (LP(NZ,MX).LE.-120) THEN
    LP(NZ,MX) = -120
   END IF
  END DO
 END DO
 LPG = LP(1,1:M)
 LP2 = LP/SQRT(2.0_DP)
 LPG2 = LP2(1,1:M)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Output
 IF (OUTPUT.EQ."Y") THEN
  OPEN(UNIT=10,FILE="GFPE_LPg.dat")
  OPEN(UNIT=20,FILE="GFPE_LP.dat")
  OPEN(UNIT=30,FILE="GFPE_P.dat")
  OPEN(UNIT=50,FILE="Topo.dat")
  DO MX = 1,M
   WRITE(10,100) MX*DR, LPG(MX), LPG2(MX)
   WRITE(50,100) MX*DR, TERR(MX), TERR1(MX), TERR2(MX)
   DO NZ = 1,N
    WRITE(20,100) MX*DR, NZ*DZ+TERR(MX), LP(NZ,MX)
    WRITE(30,101) MX*DR, NZ*DZ+TERR(MX), ABS(P(NZ,MX))
   END DO
   WRITE(20,*)
   WRITE(30,*)
  END DO
  100 FORMAT(3(3X,F12.3))
  101 FORMAT(2(3X,F12.3),3X,F12.3,SP,F12.3,SS,"i")
  !Plotting of results
  CALL SYSTEM('gnuplot -p plot.plt')
  CALL SYSTEM('gnuplot -p plot2.plt')
 END IF
 PRINT *, "Main CPU time (s) :", TF-TI
 PRINT *, "Source pressure P0 (dB) :", 20*LOG10(ABS(P0))
 !-----------------------------------------------------------
 !----------------------------------------------------------
END PROGRAM GFPE2_HF


C GAMMA FUNCTION:

      DOUBLE PRECISION FUNCTION DGAM(X)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION G(26)
      PI = 3.141592653589793D0
      IF (X.EQ.INT(X)) THEN
         IF (X.GT.0.0D0) THEN
            DGAM = 1.0D0
            M1 = X-1
            DO K = 2, M1
               DGAM = DGAM*K
            END DO
          ELSE
            DGAM = 1.0D+300
          END IF
      ELSE
          IF (DABS(X).GT.1.0D0) THEN
             Z = DABS(X)
             M = INT(Z)
             R = 1.0D0
             DO K = 1, M
                R = R*(Z-K)
             END DO
             Z = Z-M
          ELSE
             Z = X
          END IF
          DATA G/1.0D0,0.5772156649015329D0,
     +          -0.6558780715202538D0, -0.420026350340952D-1,
     +          0.1665386113822915D0,-.421977345555443D-1,
     +          -.96219715278770D-2, .72189432466630D-2,
     +          -.11651675918591D-2, -.2152416741149D-3,
     +          .1280502823882D-3, -.201348547807D-4,
     +          -.12504934821D-5, .11330272320D-5,
     +          -.2056338417D-6, .61160950D-8,
     +          .50020075D-8, -.11812746D-8,
     +          .1043427D-9, .77823D-11,
     +          -.36968D-11, .51D-12,
     +          -.206D-13, -.54D-14, .14D-14, .1D-15/
          GR = G(26)
          DO K = 25, 1, -1
             GR = GR*Z+G(K)
          END DO
          DGAM = 1.0D0/(GR*Z)
          IF (DABS(X).GT.1.0D0) THEN
             DGAM = DGAM*R
             IF (X.LT.0.0D0) DGAM = -PI/(X*GA*DSIN(PI*X))
          END IF
      END IF
      RETURN
      END

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


program motodens
	use cubeClass
	implicit none
	character(len=200)::input,occupationString,output
	real(kind=8)::occupation,dx,dy,dz,sumOverCompleteSpace
	type(cube)::cube1
	integer::io,lastSlash

	call getarg(1,input)
	call getarg(2,occupationString)
	call getarg(3,output)

	cube1 = readCube(input)

	dx=cube1%axis_x(1)
	dy=cube1%axis_y(2)
	dz=cube1%axis_z(3)

	if (trim(occupationString) == "")then
		write(*,*) 'The occupation of the MO hast to be given as second parameter!'
		stop
	end if
	read ( occupationString, '(F50.0)', iostat=io ) occupation
	if ( io /= 0 ) THEN
		write(*,*) 'The second parameter "',trim(occupationString) , '"could not be converted to a number!'
		stop
	end if

	if (trim(output) == "")then
		lastSlash = scan(trim(input),"/", BACK= .true.)
		output = trim(input(1:lastSlash))//"dens"//trim(occupationString)//"-"//trim(input(lastSlash+1:))
	end if

	!cube1%values = cube1%values * cube1%values * occupation

	cube1%values = cube1%values * cube1%values
	sumOverCompleteSpace= sum(cube1%values) * dx * dy *dz

	cube1%values = cube1%values / sumOverCompleteSpace * occupation

	call writeCube(cube1,output)

end program motodens