   logical :: l1(4)
   logical :: l2(4)
   l1 = (/.TRUE.,.FALSE.,.TRUE.,.FALSE./)
   l2 = (/.FALSE.,.TRUE.,.FALSE.,.TRUE./)
   if (dot_product (l1, l2)) call abort ()
   l2 = .TRUE.
   if (.not.dot_product (l1, l2)) call abort ()
end


module rschroed_other

! Other Schroedinger integrators, not directly used by dftatom, but available
! for reuse. This module contains various rk4 integrators and Adams
! predictor-corrector integrators (both for outward and inward integration).

use types, only: dp
use ode1d_other, only: rk4_integrate_inward2
use utils, only: stop_error
use ode1d, only: adams_extrapolation_outward, adams_interp_outward, &
    rk4_integrate
use ode1d_other, only: adams_extrapolation_inward, adams_interp_inward

implicit none
private
public schroed_inward_adams_pr, schroed_outward_adams_pr, &
    integrate_rschroed_u_inward_rk4, integrate_rschroed_u_rk4

contains

subroutine integrate_rschroed_u_rk4(l, E, R, V, Vmid, P, Q, imax)
! Integrates the Schrodinger equation outward using Runge-Kutta 4th order method
!
! It integrates the Schroedinger equation in the P(r), Q(r) form outwards:
! P' = Q
! Q' = P'' = (2*(V-E) + l*(l+1)/R**2) * P
!
! Returns P(r), Q(r).
integer, intent(in) :: l
real(dp), intent(in) :: E
real(dp), intent(in) :: R(:)
real(dp), intent(in) :: V(:), Vmid(:)
real(dp), intent(out) :: P(:), Q(:)
integer, intent(out) :: imax
real(dp), parameter :: max_val = 1e300_dp

real(dp) :: y(2)
integer :: nr

real(dp), dimension(size(R)) :: C1, C2
real(dp), dimension(size(R)-1) :: C1mid, C2mid
real(dp), dimension(size(R)-1) :: Rmid

! y(:) are values of the components (2) of the equation, in our case:
! y(1) = P, y(2) = Q
! dydx(:) are the derivatives of the components (2) of the equation

nr = size(R)

y(1) = R(1)**(l+1)
y(2) = (l+1)*R(1)**l

C1 = 2*(V-E) + l*(l+1)/R**2
C2 = 0
Rmid = (R(:size(R)-1) + R(2:)) / 2
C1mid = 2*(Vmid-E) + l*(l+1)/Rmid**2
C2mid = 0
call rk4_integrate(R, y, C1, C2, C1mid, C2mid, max_val, P, Q, imax)
end subroutine

subroutine integrate_rschroed_u_inward_rk4(n, l, E, R, V, Vmid, &
        P, Q, imin)
! Integrates the Schrodinger equation inward using Runge-Kutta 4th order method
!
! It integrates the Schroedinger equation in the P(r), Q(r) form inwards:
! P' = Q
! Q' = P'' = (2*(V-E) + l*(l+1)/R**2) * P
!
! Returns P(r), Q(r).
integer, intent(in) :: l, n
real(dp), intent(in) :: E
real(dp), intent(in) :: R(:)
real(dp), intent(in) :: V(:), Vmid(:)
real(dp), intent(out) :: P(:), Q(:)
integer, intent(out) :: imin

real(dp) :: y(2), lambda, zeta, sigma
integer :: nr
integer :: i, i_max
real(dp), parameter :: max_val = 1e300_dp
integer, parameter :: asymptotic = 4
real(dp), dimension(size(R)) :: C1
real(dp), dimension(size(R)-1) :: C1mid
real(dp), dimension(size(R)-1) :: Rmid

! y(:) are values of the components (2) of the equation, in our case:
! y(1) = P, y(2) = Q
! dydx(:) are the derivatives of the components (2) of the equation

nr = size(R)

if (E > 0) then
    print *, "E =", E
    call stop_error("E < 0 required")
end if
if (nr < 4) call stop_error("integrate_rschroed_u_inward: n >= 4 required")
i_max = nr
lambda = sqrt(-2*E)
! One possible condition:
!do while (lambda*R(i_max) > 40)
! Start integrating at the 100x classical turning point
do while (R(i_max) > 100 * R(1))
    if (i_max == 2) then
        print *, "E =", E, "lambda =", lambda
        call stop_error("Can't start the inward integration")
    end if
    i_max = i_max - 1
end do
! The simplest asymptotic seems to be working just fine, but just in case, one
! can try more precise ones by changing the 'asymptotic' parameter above
if (asymptotic == 1) then
    ! Simplest asymptotic (simplified derivative)
    y(1) = R(i_max)**n * exp(-lambda*R(i_max))
    y(2) = - lambda * R(i_max)**n * exp(-lambda*R(i_max))
else if (asymptotic == 2) then
    ! Simple asymptotic (correct derivative)
    y(1) = R(i_max)**n * exp(-lambda*R(i_max))
    y(2) = (n * R(i_max)**(n-1) - lambda * R(i_max)**n) * exp(-lambda*R(i_max))
else if (asymptotic == 3) then
    ! More precise asymptotic:
    zeta = -V(i_max)*R(i_max)
    sigma = zeta/lambda
    y(1) = 0
    y(2) = 0
    ! Use 4 terms (we could use more if needed):
    do i = 0, 4
        y(1) = y(1) + R(i_max)**(sigma-i) * exp(-lambda*R(i_max)) * &
            a_k(i, lambda, sigma, l)
        y(2) = y(2) + R(i_max)**(sigma-i) * exp(-lambda*R(i_max)) * &
            b_k(i, lambda, sigma, l)
    end do
else if (asymptotic == 4) then
    lambda = sqrt(l*(l+1)/R(i_max)**2 + 2 * (V(i_max) - E))
    y(1) = 1
    y(2) = - lambda * R(i_max) * y(1)
else
    call stop_error("Unknown 'asymptotic' parameter")
end if

P(i_max+1:) = 0
Q(i_max+1:) = 0

C1 = 2*(V-E) + l*(l+1)/R**2
Rmid = (R(:size(R)-1) + R(2:)) / 2
C1mid = 2*(Vmid-E) + l*(l+1)/Rmid**2
call rk4_integrate_inward2(R(:i_max), y, C1(:i_max), C1mid(:i_max-1), &
        max_val, P(:i_max), Q(:i_max), imin)
end subroutine

real(dp) recursive function a_k(k, lambda, sigma, l) result(r)
integer, intent(in) :: k, l
real(dp), intent(in) :: lambda, sigma
if (k == 0) then
    r = 1
else
    r = (l*(l+1) - (sigma-k)*(sigma-k+1))/(2*k*lambda)
    r = r * a_k(k-1, lambda, sigma, l)
end if
end function

real(dp) recursive function b_k(k, lambda, sigma, l) result(r)
integer, intent(in) :: k, l
real(dp), intent(in) :: lambda, sigma
if (k == 0) then
    r = -lambda
else
    r = (-l*(l+1) + (sigma+k)*(sigma-k+1))/(2*k)
    r = r * a_k(k-1, lambda, sigma, l)
end if
end function

subroutine schroed_outward_adams_pr(l, E, R, Rp, V, P, Q, imax)
! Integrates the Schrodinger equation outward using Adams 4th order method
!
! It integrates the Schroedinger equation in the P(r), Q(r) form outwards using
! predictor-corrector:
! P' = Q
! Q' = P'' = C * P
! where C = 2*(V-E) + l*(l+1)/R**2
!
! Returns P(r), Q(r).
!
! It tranforms the problem to a uniform mesh 1 <= t <= N + 1, defined by
! R(t) and Rp(t) = dR/dt and Rpp(t) = d^2R/dt^2:
!
! u(t)   = P(R(t))
! up(t)  = du/dt  = dP/dR * dR/dt             = Q * Rp
! upp(t) = dup/dt = dQ/dR * Rp^2 + Q * dRp/dt = C*P*Rp^2 + Q * Rpp
!
! So
!
! up  = u * Rp
! upp = u * C * Rp^2 + up * Rpp / Rp
!
! For example if Rp = al*R, Rpp = al^2 * R, we get:
!
! up  = u * al * R
! upp = u * C * al^2 * R^2 + up * al

integer, intent(in) :: l
real(dp), intent(in) :: E
real(dp), intent(in) :: R(:), Rp(:)
real(dp), intent(in) :: V(:)
real(dp), intent(out) :: P(:), Q(:)
real(dp), parameter :: max_val = 1e6_dp
integer, intent(out) :: imax ! The integration was carried to R(imax)

real(dp), dimension(size(R)) :: C, u1, u2, u1p, u2p
integer :: i, it

C = (l*(l+1)/R**2 + 2 * (V-E))
u1(1:4) = R(1:4) ** (l+1)
u2(1:4) = (l+1) * R(1:4) ** l
u1p(1:4) = Rp(1:4)          * u2(1:4)
u2p(1:4) = Rp(1:4) * C(1:4) * u1(1:4)

do i = 4, size(R)-1
    u1(i+1)  = u1(i)  + adams_extrapolation_outward(u1p, i)
    u2(i+1)  = u2(i)  + adams_extrapolation_outward(u2p, i)
    do it = 1, 2
        u1p(i+1) = Rp(i+1)          * u2(i+1)
        u2p(i+1) = Rp(i+1) * C(i+1) * u1(i+1)
        u1(i+1)  = u1(i) + adams_interp_outward(u1p, i)
        u2(i+1)  = u2(i) + adams_interp_outward(u2p, i)
    end do
    if (abs(u1(i+1)) >= max_val .or. abs(u2(i+1)) >= max_val) then
        P = u1
        Q = u2
        imax = i
        return
    end if
end do
P = u1
Q = u2
imax = size(R)
end subroutine

subroutine schroed_inward_adams_pr(l, E, R, Rp, V, P, Q, imin)
! Integrates the Schrodinger equation inward using Adams 4th order method
!
! It integrates the Schroedinger equation in the P(r), Q(r) form inwards using
! predictor-corrector:
! P' = Q
! Q' = P'' = (2*(V-E) + l*(l+1)/R**2) * P
!
! Returns P(r), Q(r).
!
integer, intent(in) :: l
real(dp), intent(in) :: E
real(dp), intent(in) :: R(:), Rp(:)
real(dp), intent(in) :: V(:)
real(dp), intent(out) :: P(:), Q(:)
real(dp), parameter :: max_val = 1e300_dp
integer, intent(out) :: imin

real(dp), dimension(size(R)) :: C, u1, u2, u1p, u2p
real(dp) :: xkap
integer :: i, it, i_max

C = (l*(l+1)/R**2 + 2 * (V-E))

i_max = size(R)-4
do while (R(i_max) > 100 * R(1))
    if (i_max == 2) then
        call stop_error("Can't start the inward integration")
    end if
    i_max = i_max - 1
end do

xkap = sqrt(l*(l+1) / r(i_max)**2 + 2 * (V(i_max) - E))
u1(i_max:i_max+4) = exp(-xkap * (R(i_max:i_max+4) - R(i_max)))
u2(i_max:i_max+4) = - xkap * u1(i_max:i_max+4)
u1p(i_max:i_max+4) = Rp(i_max:i_max+4)                * u2(i_max:i_max+4)
u2p(i_max:i_max+4) = Rp(i_max:i_max+4) * C(i_max:i_max+4) * u1(i_max:i_max+4)

do i = i_max, 2, -1
    u1(i-1)  = u1(i)  + adams_extrapolation_inward(u1p, i)
    u2(i-1)  = u2(i)  + adams_extrapolation_inward(u2p, i)
    do it = 1, 2
        u1p(i-1) = Rp(i-1)          * u2(i-1)
        u2p(i-1) = Rp(i-1) * C(i-1) * u1(i-1)
        u1(i-1)  = u1(i) + adams_interp_inward(u1p, i)
        u2(i-1)  = u2(i) + adams_interp_inward(u2p, i)
    end do
    if (abs(u1(i-1)) >= max_val .or. abs(u2(i-1)) >= max_val) then
        P = u1
        Q = u2
        P(i_max+1:) = 0
        Q(i_max+1:) = 0
        imin = i
        return
    end if
end do
P = u1
Q = u2
P(i_max+1:) = 0
Q(i_max+1:) = 0
imin = 1
end subroutine

end module


      SUBROUTINE BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,CM,IDIMY,Y,
     1                   IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     SUBROUTINE BLKTRI SOLVES A SYSTEM OF LINEAR EQUATIONS OF THE FORM
C
C          AN(J)*X(I,J-1) + AM(I)*X(I-1,J) + (BN(J)+BM(I))*X(I,J)
C
C          + CN(J)*X(I,J+1) + CM(I)*X(I+1,J) = Y(I,J)
C
C               FOR I = 1,2,...,M  AND  J = 1,2,...,N.
C
C     I+1 AND I-1 ARE EVALUATED MODULO M AND J+1 AND J-1 MODULO N, I.E.,
C
C          X(I,0) = X(I,N),  X(I,N+1) = X(I,1),
C          X(0,J) = X(M,J),  X(M+1,J) = X(1,J).
C
C     THESE EQUATIONS USUALLY RESULT FROM THE DISCRETIZATION OF
C     SEPARABLE ELLIPTIC EQUATIONS.  BOUNDARY CONDITIONS MAY BE
C     DIRICHLET, NEUMANN, OR PERIODIC.
C
C
C     * * * * * * * * * *     ON INPUT     * * * * * * * * * *
C
C     IFLG
C       = 0  INITIALIZATION ONLY.  CERTAIN QUANTITIES THAT DEPEND ON NP,
C            N, AN, BN, AND CN ARE COMPUTED AND STORED IN THE WORK
C            ARRAY  W.
C       = 1  THE QUANTITIES THAT WERE COMPUTED IN THE INITIALIZATION ARE
C            USED TO OBTAIN THE SOLUTION X(I,J).
C
C       NOTE   A CALL WITH IFLG=0 TAKES APPROXIMATELY ONE HALF THE TIME
C              TIME AS A CALL WITH IFLG = 1  .  HOWEVER, THE
C              INITIALIZATION DOES NOT HAVE TO BE REPEATED UNLESS NP, N,
C              AN, BN, OR CN CHANGE.
C
C     NP
C       = 0  IF AN(1) AND CN(N) ARE NOT ZERO, WHICH CORRESPONDS TO
C            PERIODIC BOUNARY CONDITIONS.
C       = 1  IF AN(1) AND CN(N) ARE ZERO.
C
C     N
C       THE NUMBER OF UNKNOWNS IN THE J-DIRECTION. N MUST BE GREATER
C       THAN 4. THE OPERATION COUNT IS PROPORTIONAL TO MNLOG2(N), HENCE
C       N SHOULD BE SELECTED LESS THAN OR EQUAL TO M.
C
C     AN,BN,CN
C       ONE-DIMENSIONAL ARRAYS OF LENGTH N THAT SPECIFY THE COEFFICIENTS
C       IN THE LINEAR EQUATIONS GIVEN ABOVE.
C
C     MP
C       = 0  IF AM(1) AND CM(M) ARE NOT ZERO, WHICH CORRESPONDS TO
C            PERIODIC BOUNDARY CONDITIONS.
C       = 1  IF AM(1) = CM(M) = 0  .
C
C     M
C       THE NUMBER OF UNKNOWNS IN THE I-DIRECTION. M MUST BE GREATER
C       THAN 4.
C
C     AM,BM,CM
C       ONE-DIMENSIONAL ARRAYS OF LENGTH M THAT SPECIFY THE COEFFICIENTS
C       IN THE LINEAR EQUATIONS GIVEN ABOVE.
C
C     IDIMY
C       THE ROW (OR FIRST) DIMENSION OF THE TWO-DIMENSIONAL ARRAY Y AS
C       IT APPEARS IN THE PROGRAM CALLING BLKTRI.  THIS PARAMETER IS
C       USED TO SPECIFY THE VARIABLE DIMENSION OF Y.  IDIMY MUST BE AT
C       LEAST M.
C
C     Y
C       A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE RIGHT
C       SIDE OF THE LINEAR SYSTEM OF EQUATIONS GIVEN ABOVE.  Y MUST BE
C       DIMENSIONED AT LEAST M*N.
C
C     W
C       A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C       WORK SPACE.
C             IF NP=1 DEFINE K=INT(LOG2(N))+1 AND SET L=2**(K+1) THEN
C                     W MUST HAVE DIMENSION (K-2)*L+K+5+MAX(2N,6M)
C
C             IF NP=0 DEFINE K=INT(LOG2(N-1))+1 AND SET L=2**(K+1) THEN
C                     W MUST HAVE DIMENSION (K-2)*L+K+5+2N+MAX(2N,6M)
C
C       **IMPORTANT** FOR PURPOSES OF CHECKING, THE REQUIRED DIMENSION
C                     OF W IS COMPUTED BY BLKTRI AND STORED IN W(1)
C                     IN FLOATING POINT FORMAT.
C
C     * * * * * * * * * *     ON OUTPUT     * * * * * * * * * *
C
C     Y
C       CONTAINS THE SOLUTION X.
C
C     IERROR
C       AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.  EXCEPT
C       FOR NUMBER ZERO, A SOLUTION IS NOT ATTEMPTED.
C
C       = 0  NO ERROR.
C       = 1  M IS LESS THAN 5
C       = 2  N IS LESS THAN 5
C       = 3  IDIMY IS LESS THAN M.
C       = 4  BLKTRI FAILED WHILE COMPUTING RESULTS THAT DEPEND ON THE
C            COEFFICIENT ARRAYS AN, BN, CN.  CHECK THESE ARRAYS.
C       = 5  AN(J)*CN(J-1) IS LESS THAN 0 FOR SOME J. POSSIBLE REASONS
C            FOR THIS CONDITION ARE
C            1. THE ARRAYS AN AND CN ARE NOT CORRECT
C            2. TOO LARGE A GRID SPACING WAS USED IN THE DISCRETIZATION
C               OF THE ELLIPTIC EQUATION
C            3. THE LINEAR EQUATIONS RESULTED FROM A PARTIAL
C               DIFFERENTIAL EQUATION WHICH WAS NOT ELLIPTIC
C
C     W
C       CONTAINS INTERMEDIATE VALUES THAT MUST NOT BE DESTROYED IF
C       BLKTRI WILL BE CALLED AGAIN WITH IFLG=1. W(1) CONTAINS THE
C       NUMBER OF LOCATIONS REQUIRED BY W IN FLOATING POINT FORMAT.
C
C     * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C     DIMENSION OF   AN(N),BN(N),CN(N),AM(M),BM(M),CM(M),Y(IDIMY,N)
C     ARGUMENTS      W(SEE ARGUMENT LIST)
C
C     LATEST         JUNE 1979
C     REVISION
C
C     REQUIRED       BLKTRI,BLKTRI,PROD,PRODP,CPROD,CPRODP,COMPB,INDXA,
C     SUBPROGRAMS    INDXB,INDXC,PPADD,PSGF,PPSGF,PPSPF,BSRH,TEVLS,
C                    EPMACH,STORE
C
C     SPECIAL        THE ALGORITHM MAY FAIL IF ABS(BM(I)+BN(J)) IS LESS
C     CONDITIONS     THAN ABS(AM(I))+ABS(AN(J))+ABS(CM(I))+ABS(CN(J))
C                    FOR SOME I AND J. THE ALGORITHM WILL ALSO FAIL IF
C                    AN(J)*CN(J-1) IS LESS THAN ZERO FOR SOME J
C                    SEE THE DISCRIPTION OF THE OUTPUT PARAMETER IERROR.
C
C     COMMON         CBLKT,VALUE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C     SPECIALIST     PAUL SWARZTRAUBER
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        VERSION 1 SEPTEMBER 1973
C                    VERSION 2 APRIL     1976
C                    VERSION 3 JUNE      1979
C
C     ALGORITHM      GENERALIZED CYCLIC REDUCTION (SEE REFERENCE BELOW)
C
C     SPACE
C     REQUIRED       CONTROL DATA 7600
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                    THE APPROXIMATE MACHINE ACCURACY IS COMPUTED IN
C                    FUNCTION EPMACH
C
C     REQUIRED       NONE
C     RESIDENT
C     ROUTINES
C
C     REFERENCES     SWARZTRAUBER,P. AND R. SWEET, 'EFFICIENT FORTRAN
C                    SUBPROGRAMS FOR THE SOLUTION OF ELLIPTIC EQUATIONS'
C                    NCAR TN/IA-109, JULY, 1975, 138 PP.
C
C                    SWARZTRAUBER P. N.,A DIRECT METHOD FOR THE DISCRETE
C                    SOLUTION OF SEPARABLE ELLIPTIC EQUATIONS, S.I.A.M.
C                    J. NUMER. ANAL.,11(1974) PP. 1136-1150.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
      DIMENSION       AN(1)      ,BN(1)      ,CN(1)      ,AM(1)      ,
     1                BM(1)      ,CM(1)      ,Y(IDIMY,1) ,W(1)
      EXTERNAL        PROD       ,PRODP      ,CPROD      ,CPRODP
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
C TEST M AND N FOR THE PROPER FORM
C
      NM = N
      IERROR = 0
      IF (M-5) 101,102,102
  101 IERROR = 1
      GO TO 119
  102 IF (NM-3) 103,104,104
  103 IERROR = 2
      GO TO 119
  104 IF (IDIMY-M) 105,106,106
  105 IERROR = 3
      GO TO 119
  106 NH = N
      NPP = NP
      IF (NPP) 107,108,107
  107 NH = NH+1
  108 IK = 2
      K = 1
  109 IK = IK+IK
      K = K+1
      IF (NH-IK) 110,110,109
  110 NL = IK
      IK = IK+IK
      NL = NL-1
      IWAH = (K-2)*IK+K+6
      IF (NPP) 111,112,111
C
C     DIVIDE W INTO WORKING SUB ARRAYS
C
  111 IW1 = IWAH
      IWBH = IW1+NM
      W(1) = FLOAT(IW1-1+MAX0(2*NM,6*M))
      GO TO 113
  112 IWBH = IWAH+NM+NM
      IW1 = IWBH
      W(1) = FLOAT(IW1-1+MAX0(2*NM,6*M))
      NM = NM-1
C
C SUBROUTINE COMP B COMPUTES THE ROOTS OF THE B POLYNOMIALS
C
  113 IF (IERROR) 119,114,119
  114 IW2 = IW1+M
      IW3 = IW2+M
      IWD = IW3+M
      IWW = IWD+M
      IWU = IWW+M
      IF (IFLG) 116,115,116
  115 CALL COMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH))
      GO TO 119
  116 IF (MP) 117,118,117
C
C SUBROUTINE BLKTR1 SOLVES THE LINEAR SYSTEM
C
  117 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
     1             W(IW3),W(IWD),W(IWW),W(IWU),PROD,CPROD)
      GO TO 119
  118 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
     1             W(IW3),W(IWD),W(IWW),W(IWU),PRODP,CPRODP)
  119 CONTINUE
      RETURN
      END


C$Procedure      RECGEO ( Rectangular to geodetic )

      SUBROUTINE RECGEO ( RECTAN, RE, F,  LONG, LAT, ALT )

C$ Abstract
C
C     Convert from rectangular coordinates to geodetic coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      CONVERSION,  COORDINATES
C
C$ Declarations

      DOUBLE PRECISION   RECTAN ( 3 )
      DOUBLE PRECISION   RE
      DOUBLE PRECISION   F
      DOUBLE PRECISION   LONG
      DOUBLE PRECISION   LAT
      DOUBLE PRECISION   ALT

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     RECTAN     I   Rectangular coordinates of a point.
C     RE         I   Equatorial radius of the reference spheroid.
C     F          I   Flattening coefficient.
C     LONG       O   Geodetic longitude of the point (radians).
C     LAT        O   Geodetic latitude  of the point (radians).
C     ALT        O   Altitude of the point above reference spheroid.
C
C$ Detailed_Input
C
C     RECTAN     The rectangular coordinates of a point. RECTAN must
C                be in the same units as RE.
C
C     RE         Equatorial radius of a reference spheroid.  This
C                spheroid is a volume of revolution:  its horizontal
C                cross sections are circular.  The shape of the
C                spheroid is defined by an equatorial radius RE and a
C                polar radius RP. RE must be in the same units as
C                RECTAN.
C
C     F          Flattening coefficient = (RE-RP) / RE,  where RP is
C                the polar radius of the spheroid.
C
C$ Detailed_Output
C
C     LONG       Geodetic longitude of the input point.  This is the
C                angle between the prime meridian and the meridian
C                containing RECTAN.  The direction of increasing
C                longitude is from the +X axis towards the +Y axis.
C
C                LONG is output in radians.  The range of LONG is
C                [-pi, pi].
C
C     LAT        Geodetic latitude of the input point.  For a point P
C                on the reference spheroid, this is the angle between
C                the XY plane and the outward normal vector at P.
C                For a point P not on the reference spheroid, the
C                geodetic latitude is that of the closest point to P on
C                the spheroid.
C
C                LAT is output in radians.  The range of LAT is
C                [-pi/2, pi/2].
C
C
C     ALT        Altitude of point above the reference spheroid.
C
C                The units associated with ALT are those associated
C                with the inputs RECTAN and RE.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the equatorial radius is non-positive, the error
C        SPICE(VALUEOUTOFRANGE) is signaled.
C
C     2) If the flattening coefficient is greater than or equal to
C        one, the error SPICE(VALUEOUTOFRANGE) is signaled.
C
C     3) For points inside the reference ellipsoid, the nearest
C        point on the ellipsoid to RECTAN may not be unique, so
C        latitude may not be well-defined.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Given the body-fixed rectangular coordinates of a point, and the
C     constants describing the reference spheroid,  this routine
C     returns the geodetic coordinates of the point.  The body-fixed
C     rectangular frame is that having the x-axis pass through the
C     0 degree latitude 0 degree longitude point.  The y-axis passes
C     through the 0 degree latitude 90 degree longitude.  The z-axis
C     passes through the 90 degree latitude point.  For some bodies
C     this coordinate system may not be a right-handed coordinate
C     system.
C
C$ Examples
C
C     This routine can be used to convert body fixed rectangular
C     coordinates (such as the Satellite Tracking and Data Network
C     of 1973) to geodetic coordinates such as those used by the
C     United States Geological Survey topographic maps.
C
C     The code would look something like this
C
C     C
C     C     Shift the STDN-73 coordinates to line up with the center
C     C     of the Clark66 reference system.
C     C
C           CALL VSUB ( STDNX, OFFSET, X )
C
C     C
C     C     Using the equatorial radius of the Clark66 spheroid
C     C     (CLARKR = 6378.2064 km) and the Clark 66 flattening
C     C     factor (CLARKF = 1.0D0 / 294.9787D0 ) convert to
C     C     geodetic coordinates of the North American Datum of 1927.
C     C
C           CALL RECGEO ( X, CLARKR, CLARKF, LONG, LAT, ALT )
C
C
C
C     Below are two tables.
C
C     Listed in the first table (under X(1), X(2) and X(3)) are a
C     number of points whose rectangular coordinates are
C     taken from the set {-1, 0, 1}.
C
C     The results of the code fragment
C
C          CALL RECGEO ( X, CLARKR, CLARKF, LONG, LAT, ALT )
C
C          Use the SPICELIB routine CONVRT to convert the angular
C          quantities to degrees
C
C          CALL CONVRT ( LAT,  'RADIANS', 'DEGREES', LAT  )
C          CALL CONVRT ( LONG, 'RADIANS', 'DEGREES', LONG )
C
C     are listed to 4 decimal places in the second parallel table under
C     LONG (longitude), LAT (latitude), and ALT (altitude).
C
C
C       X(1)       X(2)     X(3)         LONG      LAT        ALT
C       --------------------------       ----------------------------
C       0.0000     0.0000   0.0000       0.0000    90.0000   -6356.5838
C       1.0000     0.0000   0.0000       0.0000     0.0000   -6377.2063
C       0.0000     1.0000   0.0000      90.0000     0.0000   -6377.2063
C       0.0000     0.0000   1.0000       0.0000    90.0000   -6355.5838
C      -1.0000     0.0000   0.0000     180.0000     0.0000   -6377.2063
C       0.0000    -1.0000   0.0000     -90.0000     0.0000   -6377.2063
C       0.0000     0.0000  -1.0000       0.0000   -90.0000   -6355.5838
C       1.0000     1.0000   0.0000      45.0000     0.0000   -6376.7921
C       1.0000     0.0000   1.0000       0.0000    88.7070   -6355.5725
C       0.0000     1.0000   1.0000      90.0000    88.7070   -6355.5725
C       1.0000     1.0000   1.0000      45.0000    88.1713   -6355.5612
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     See FUNDAMENTALS OF ASTRODYNAMICS, Bate, Mueller, White
C     published by Dover for a description of geodetic coordinates.
C
C$ Author_and_Institution
C
C     C.H. Acton      (JPL)
C     N.J. Bachman    (JPL)
C     H.A. Neilan     (JPL)
C     B.V. Semenov    (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 03-AUG-2016 (BVS) (NJB)
C
C        Re-implemented derivation of longitude to improve
C        accuray.
C
C        Minor header edits.
C
C-    SPICELIB Version 1.0.3, 02-JUL-2007 (NJB)
C
C        In Examples section of header, description of right-hand
C        table was updated to use correct names of columns. Term
C        "bodyfixed" is now hyphenated.
C
C-    SPICELIB Version 1.0.2, 30-JUL-2003 (NJB) (CHA)
C
C        Various header changes were made to improve clarity.  Some
C        minor header corrections were made.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     rectangular to geodetic
C
C-&

C$ Revisions
C
C-    Beta Version 3.0.1, 9-JUN-1989 (HAN)
C
C        Error handling was added to detect and equatorial radius
C        whose value is less than or equal to zero.
C
C-    Beta Version 2.0.0, 21-DEC-1988 (HAN)
C
C        Error handling to detect invalid flattening coefficients
C        was added. Because the flattening coefficient is used to
C        compute the length of an axis, it must be checked so that
C        the length is greater than zero.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION C
      DOUBLE PRECISION BASE   (3)
      DOUBLE PRECISION NORMAL (3)
      DOUBLE PRECISION RADIUS

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'RECGEO' )
      END IF

C
C     The equatorial radius must be positive. If not, signal an error
C     and check out.
C
      IF ( RE. LE. 0.0D0 ) THEN
          CALL SETMSG ( 'Equatorial radius was *.' )
          CALL ERRDP  ( '*', RE                    )
          CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'   )
          CALL CHKOUT ( 'RECGEO'                   )
          RETURN
      END IF

C
C     If the flattening coefficient is greater than one, the length
C     of the 'C' axis computed below is negative. If it's equal to one,
C     the length of the axis is zero. Either case is a problem, so
C     signal an error and check out.
C
      IF ( F .GE. 1 ) THEN
          CALL SETMSG ( 'Flattening coefficient was *.'  )
          CALL ERRDP  ( '*', F                           )
          CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'         )
          CALL CHKOUT ( 'RECGEO'                         )
          RETURN
      END IF

C
C     Determine the lengths of the axes of the reference ellipsoid.
C
      A = RE
      B = RE
      C = RE - F*RE

C
C     Find the point on the reference spheroid closest to the input
C     point. From this closest point determine the surface normal.
C
      CALL NEARPT ( RECTAN, A, B, C, BASE, ALT    )
      CALL SURFNM (         A, B, C, BASE, NORMAL )
C
C     Using the surface normal, determine the latitude and longitude
C     of the input point.
C
      CALL RECLAT ( NORMAL, RADIUS, LONG, LAT )

C
C     Compute longitude directly rather than from the normal vector.
C
      IF (       ( RECTAN(1) .EQ.0.D0 )
     .     .AND. ( RECTAN(2) .EQ.0.D0 ) ) THEN

         LONG = 0.D0
      ELSE
         LONG = DATAN2 ( RECTAN(2), RECTAN(1) )
      END IF

      CALL CHKOUT ( 'RECGEO' )
      RETURN
      END


      function getdiskpsi(r)

      include 'commonblocks'
      common /diskestimate/ ddens(0:nmax),dpot(0:nmax),dfr(0:nmax)

      ihi=int(r/dr)+1
      if (ihi.lt.1) ihi=1
      if (ihi.gt.nr) ihi=nr
      r1=dr*(ihi-1)
      r2=dr*ihi
      t=(r-r1)/(r2-r1)
      tm1 = 1.0 - t
      if (r.eq.0.) then
         lmaxx=0
         costheta=0
      else
         costheta=z/r
         lmaxx=lmax
      endif
      getdiskpsi = (t*dpot(ihi)+ tm1*dpot(ihi-1))

      return
      end

      function gettotalpsi(rad)

      include 'commonblocks'

      gettotalpsi = 0.
      if(idiskflag.eq.1) then
         gettotalpsi = gettotalpsi + getdiskpsi(rad)
      endif
      if(ibulgeflag.eq.1) then
         gettotalpsi = gettotalpsi + sersicpot(rad)
      endif
      if(ihaloflag.eq.1) then
         gettotalpsi = gettotalpsi + gethalopsi(rad)
      endif
      return
      end

      function gethalopsi(r)

      include 'commonblocks'
      common /haloestimate/ hdens(0:nmax),hpot(0:nmax),hfr(0:nmax)

      ihi=int(r/dr)+1
      if (ihi.lt.1) ihi=1
      if (ihi.gt.nr) ihi=nr
      r1=dr*(ihi-1)
      r2=dr*ihi
      t=(r-r1)/(r2-r1)
      tm1 = 1.0 - t
      if (r.eq.0.) then
         lmaxx=0
         costheta=0
      else
         costheta=z/r
         lmaxx=lmax
      endif
      gethalopsi = (t*hpot(ihi)+ tm1*hpot(ihi-1))

      return
      end


MODULE omp_variables

!$ use omp_lib

  implicit none

  PRIVATE
  PUBLIC :: init_omp, Igrid_omp,Ngrid_omp
  PUBLIC :: partition_job_omp

  integer,allocatable :: Igrid_omp(:,:,:)
  integer,allocatable :: Ngrid_omp(:,:)
  integer :: nthreads

CONTAINS

  SUBROUTINE init_omp(a1b,b1b,a2b,b2b,a3b,b3b,n1,n2,systype,disp_switch)

    implicit none

    integer,intent(IN) :: a1b,b1b,a2b,b2b,a3b,b3b,n1,n2,systype
    logical,intent(IN) :: disp_switch
    integer :: i1,i2,i3,m,n,k,j,i,ab1,ab2,ab3,nn(3),np(3)
    integer,allocatable :: ntmp(:,:)

    call write_border( 80, " init_omp(start)" )

    ab1 = b1b-a1b+1
    ab2 = b2b-a2b+1
    ab3 = b3b-a3b+1

    m=1
    n=1

!$OMP parallel private(m,n,k,j,i)

!$  n=omp_get_num_threads()

!$OMP single

    nthreads = n
    allocate( Ngrid_omp(0:3,0:n-1)   ) ; Ngrid_omp=0
    allocate( Igrid_omp(2,0:3,0:n-1) ) ; Igrid_omp=0

    m = n

    k     = gcd(ab3,m)
    m     = m/k
    nn(3) = ab3/k
    np(3) = k

    if ( m == 1 ) then

       nn(2) = ab2
       nn(1) = ab1
       np(2) = 1
       np(1) = 1

    else

       k     = gcd(ab2,m)
       m     = m/k
       nn(2) = ab2/k
       np(2) = k

       if ( m == 1 ) then

          nn(1) = ab1
          np(1) = 1

       else

          k     = gcd(ab1,m)
          m     = m/k
          nn(1) = ab1/k
          np(1) = k

!          if ( m == 1 ) then
!          else
!             nn(1) = ab1
!          end if

       end if

    end if

    if ( disp_switch ) then
       write(*,*) "nn(ini)=",ab1,ab2,ab3
       write(*,*) "nn(1:3)=",nn(1:3)
       write(*,*) "np(1:3)=",np(1:3)
       write(*,*) "m      =",m
    end if

    if ( m == 1 ) then

       n=maxval(np)
       allocate( ntmp(3,n) ) ; ntmp=0

       do i=1,ab1
          n=mod(i-1,np(1))+1
          ntmp(1,n)=ntmp(1,n)+1
       end do
       do i=1,ab2
          n=mod(i-1,np(2))+1
          ntmp(2,n)=ntmp(2,n)+1
       end do
       do i=1,ab3
          n=mod(i-1,np(3))+1
          ntmp(3,n)=ntmp(3,n)+1
       end do

       n=-1
       do k=1,np(3)
       do j=1,np(2)
       do i=1,np(1)
          n=n+1
          Ngrid_omp(1,n)=ntmp(1,i)
          Ngrid_omp(2,n)=ntmp(2,j)
          Ngrid_omp(3,n)=ntmp(3,k)
          if ( disp_switch ) write(*,'(1x,"Ngrid_omp",3i5)') Ngrid_omp(1:3,n)
       end do
       end do
       end do

    else

       np( maxloc(nn,1) ) = np( maxloc(nn,1) )*m

       if ( disp_switch ) write(*,*) "np_=",np

       n=maxval(np)
       allocate( ntmp(3,n) ) ; ntmp=0

       do i=1,ab1
          n=mod(i-1,np(1))+1
          ntmp(1,n)=ntmp(1,n)+1
       end do
       do i=1,ab2
          n=mod(i-1,np(2))+1
          ntmp(2,n)=ntmp(2,n)+1
       end do
       do i=1,ab3
          n=mod(i-1,np(3))+1
          ntmp(3,n)=ntmp(3,n)+1
       end do

       n=-1
       do k=1,np(3)
       do j=1,np(2)
       do i=1,np(1)
          n=n+1
          Ngrid_omp(1,n)=ntmp(1,i)
          Ngrid_omp(2,n)=ntmp(2,j)
          Ngrid_omp(3,n)=ntmp(3,k)
          if ( disp_switch ) write(*,'(1x,"Ngrid_omp_",3i5)') Ngrid_omp(1:3,n)
       end do
       end do
       end do

    end if

    if ( systype == 1 ) then

       do j=1,n2-n1+1
          i=mod( j-1, nthreads )
          Ngrid_omp(0,i) = Ngrid_omp(0,i) + 1
       end do

    else

       do i=0,nthreads-1
          Ngrid_omp(0,i) = Ngrid_omp(1,i)*Ngrid_omp(2,i)*Ngrid_omp(3,i)
       end do

    end if

    i=-1
    do i3=1,np(3)
    do i2=1,np(2)
    do i1=1,np(1)
       i=i+1
       Igrid_omp(1,0,i) = sum( Ngrid_omp(0,0:i) ) - Ngrid_omp(0,i) + n1
       Igrid_omp(2,0,i) = Igrid_omp(1,0,i) + Ngrid_omp(0,i) - 1
       Igrid_omp(1,1,i) = sum(ntmp(1,1:i1))-ntmp(1,i1) + a1b
       Igrid_omp(2,1,i) = Igrid_omp(1,1,i) + ntmp(1,i1) - 1
       Igrid_omp(1,2,i) = sum(ntmp(2,1:i2))-ntmp(2,i2) + a2b
       Igrid_omp(2,2,i) = Igrid_omp(1,2,i) + ntmp(2,i2) - 1
       Igrid_omp(1,3,i) = sum(ntmp(3,1:i3))-ntmp(3,i3) + a3b
       Igrid_omp(2,3,i) = Igrid_omp(1,3,i) + ntmp(3,i3) - 1
       if ( disp_switch ) then
          write(*,'(1x,"IGIG",1x,9i8)') Igrid_omp(:,:,i),Ngrid_omp(0,i)
       end if
    end do
    end do
    end do

    if ( disp_switch ) write(*,*) "omp_get_num_threads=",nthreads

    deallocate( ntmp )

!$OMP end single

!$OMP end parallel

    call write_border( 80, " init_omp(end)" )

  END SUBROUTINE init_omp

  FUNCTION gcd(m0,n0)
    implicit none
    integer :: gcd,m0,n0
    integer :: m,n,mtmp,loop

    if ( m0 >= n0 ) then
       m=m0
       n=n0
    else
       m=n0
       n=m0
    end if

    do loop=1,10000
       if ( n == 0 ) exit
       mtmp = n
       n = mod(m,n)
       m = mtmp
    end do

    gcd = m

  END FUNCTION gcd

  SUBROUTINE partition_job_omp( a1b,b1b,a2b,b2b,a3b,b3b,ib1,ib2 )

    implicit none
    integer,intent(INOUT) :: a1b,b1b,a2b,b2b,a3b,b3b,ib1,ib2
    integer :: i1,i2,i3,i4,m,n,k,j,i,ab1,ab2,ab3,nib,nn(4),np(4),myrank_omp
    integer,allocatable :: ntmp(:,:)

    ab1 = b1b-a1b+1
    ab2 = b2b-a2b+1
    ab3 = b3b-a3b+1
    nib = ib2-ib1+1

    m=1
    n=1

!$  n = omp_get_num_threads()
!$  myrank_omp = omp_get_thread_num()

    m = n

    k     = gcd(nib,m)
    m     = m/k
    nn(4) = nib/k
    np(4) = k

    if ( m == 1 ) then

       nn(3) = ab3
       nn(2) = ab2
       nn(1) = ab1
       np(3) = 1
       np(2) = 1
       np(1) = 1

    else

       k     = gcd(ab3,m)
       m     = m/k
       nn(3) = ab3/k
       np(3) = k

       if ( m == 1 ) then

          nn(2) = ab2
          nn(1) = ab1
          np(2) = 1
          np(1) = 1

       else

          k     = gcd(ab2,m)
          m     = m/k
          nn(2) = ab2/k
          np(2) = k

          if ( m == 1 ) then

             nn(1) = ab1
             np(1) = 1

          else

             k     = gcd(ab1,m)
             m     = m/k
             nn(1) = ab1/k
             np(1) = k

          end if

       end if

    end if

!    write(*,*) "nn(ini)=",ab1,ab2,ab3,nib
!    write(*,*) "nn(1:4)=",nn(1:4)
!    write(*,*) "np(1:4)=",np(1:4)
!    write(*,*) "m      =",m

    if ( m == 1 ) then

       i=-1
       loop_a : do i4=0,np(4)-1
       do i3=0,np(3)-1
       do i2=0,np(2)-1
       do i1=0,np(1)-1
          i=i+1
          if ( i == myrank_omp ) then
             a1b = a1b + nn(1)*i1
             b1b = a1b + nn(1) - 1
             a2b = a2b + nn(2)*i2
             b2b = a2b + nn(2) - 1
             a3b = a3b + nn(3)*i3
             b3b = a3b + nn(3) - 1
             ib1 = ib1 + nn(4)*i4
             ib2 = ib1 + nn(4) - 1
             exit loop_a
          end if
       end do
       end do
       end do
       end do loop_a

    else

       np( maxloc(nn,1) ) = np( maxloc(nn,1) )*m

       n=maxval(np)
       allocate( ntmp(4,0:n-1) ) ; ntmp=0

       do i=1,ab1
          n=mod(i-1,np(1))
          ntmp(1,n)=ntmp(1,n)+1
       end do
       do i=1,ab2
          n=mod(i-1,np(2))
          ntmp(2,n)=ntmp(2,n)+1
       end do
       do i=1,ab3
          n=mod(i-1,np(3))
          ntmp(3,n)=ntmp(3,n)+1
       end do
       do i=1,nib
          n=mod(i-1,np(4))
          ntmp(4,n)=ntmp(4,n)+1
       end do

       i=-1
       loop_b : do i4=0,np(4)-1
       do i3=0,np(3)-1
       do i2=0,np(2)-1
       do i1=0,np(1)-1
          i=i+1
          if ( i == myrank_omp ) then
             a1b = a1b + sum( ntmp(1,1:i1) ) - ntmp(1,i1)
             b1b = a1b + ntmp(1,i1) - 1
             a2b = a2b + sum( ntmp(2,1:i2) ) - ntmp(1,i2)
             b2b = a2b + ntmp(1,i2) - 1
             a3b = a3b + sum( ntmp(3,1:i3) ) - ntmp(1,i3)
             b3b = a3b + ntmp(1,i3) - 1
             ib1 = ib1 + sum( ntmp(4,1:i4) ) - ntmp(1,i4)
             ib2 = ib1 + ntmp(1,i4) - 1
             exit loop_b
          end if
       end do
       end do
       end do
       end do loop_b

       deallocate( ntmp )

    end if

  END SUBROUTINE partition_job_omp

END MODULE omp_variables


module mod_fftw_param
  use iso_c_binding
  !
  type, bind(C) :: fftw_iodim
     integer(C_INT) n, is, os
  end type fftw_iodim
  !
  interface
     type(C_PTR) function fftw_plan_guru_r2r(rank,dims, &
       howmany_rank,howmany_dims,in,out,kind,flags)  &
#ifdef SINGLE_PRECISION
       bind(C, name='fftwf_plan_guru_r2r')
#else
       bind(C, name='fftw_plan_guru_r2r')
#endif
       import
       integer(C_INT), value :: rank
       type(fftw_iodim), dimension(*), intent(in) :: dims
       integer(C_INT), value :: howmany_rank
       type(fftw_iodim), dimension(*), intent(in) :: howmany_dims
#ifdef SINGLE_PRECISION
       real(C_FLOAT ), dimension(*), intent(out) :: in,out
#else
       real(C_DOUBLE), dimension(*), intent(out) :: in,out
#endif
       integer(C_INT) :: kind
       integer(C_INT), value :: flags
     end function fftw_plan_guru_r2r
  end interface
  !
  integer :: FFTW_PATIENT,FFTW_ESTIMATE
  parameter (FFTW_PATIENT=32)
  parameter (FFTW_ESTIMATE=64)
  integer FFTW_R2HC
  parameter (FFTW_R2HC=0)
  integer FFTW_HC2R
  parameter (FFTW_HC2R=1)
  !
  integer REDFT00
  parameter (FFTW_REDFT00=3)
  integer FFTW_REDFT01
  parameter (FFTW_REDFT01=4)
  integer FFTW_REDFT10
  parameter (FFTW_REDFT10=5)
  integer FFTW_REDFT11
  parameter (FFTW_REDFT11=6)
  integer FFTW_RODFT00
  parameter (FFTW_RODFT00=7)
  integer FFTW_RODFT01
  parameter (FFTW_RODFT01=8)
  integer FFTW_RODFT10
  parameter (FFTW_RODFT10=9)
  integer FFTW_RODFT11
  parameter (FFTW_RODFT11=10)
  !
  type(C_PTR) :: fwd_guruplan_y,bwd_guruplan_y
  type(C_PTR) :: fwd_guruplan_z,bwd_guruplan_z
  logical :: planned=.false.
end module mod_fftw_param


      SUBROUTINE legendre_to_power(n, a_inv, b_inv, tc, ac)
      USE stel_kinds
      IMPLICIT NONE
      INTEGER, INTENT(IN):: n
      REAL(rprec), DIMENSION(0:n), INTENT(IN):: tc
      REAL(rprec), DIMENSION(0:n), INTENT(OUT):: ac
      REAL(rprec), DIMENSION(0:n,0:n), INTENT(IN):: a_inv, b_inv
      INTEGER:: i, j, k
!---------------------------------------------------------------------
!     Given the following notation:
!
!           AC == (ac(1), ...ac(n))==>  vector of coefficients for
!                 power series in [0,1]
!           TC == (tc(1), ...tc(n))==>  vector of coefficients for
!                 Legendre series in [-1,1]
!     THEN:
!                        AC = TC* A_INV * B_INV
!----------------------------------------------------------------------
      DO i = 0, n
         ac(i) = 0
         DO j= 0, n
           DO k = 0, n
             ac(i) = ac(i) + tc(j) * a_inv(j,k) * b_inv(k,i)
           ENDDO
         ENDDO
      ENDDO

      END SUBROUTINE legendre_to_power


      DOUBLE PRECISION FUNCTION DREXP (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2001-07-16 DREXP Krogh  Change -1.0 to -1.D0.
C>> 1998-10-29 DREXP Krogh  Moved external statement up for mangle.
C>> 1994-10-20 DREXP Krogh  Changes to use M77CON
C>> 1994-05-20 DREXP WVS JPL Make SP and DP alike using CHGTYP
C>> 1993-05-06 DREXP WVS JPL Convert from NSWC to Math 77
c--D replaces "?": ?REXP
C ----------------------------------------------------------------------
C            EVALUATION OF THE FUNCTION EXP(X) - 1
c ----------------------------------------------------------------------
      DOUBLE PRECISION X, EXMIN, ROUND, Z
      DOUBLE PRECISION A0, A1, A2, A3, A4, B1, B2, B3, B4
      DOUBLE PRECISION C1, C2, C3, C4, C5
      DOUBLE PRECISION P1, P2, Q1, Q2, Q3, Q4
      EXTERNAL D1MACH
      DOUBLE PRECISION D1MACH
C     EXMIN is the smallest number such that EXP(EXMIN) - 1 > -1.
C     ROUND is the smallest number such that ROUND + 1 > 1.
      SAVE EXMIN, ROUND
c --------------------------
C     CI = 1/FACTORIAL(I + 2)
c --------------------------
      PARAMETER (C1 = 1.0D0/6.0D0)
      PARAMETER (C2 = 1.0D0/24.0D0)
      PARAMETER (C3 = 1.0D0/120.0D0)
      PARAMETER (C4 = 1.0D0/720.0D0)
      PARAMETER (C5 = 1.0D0/5040.0D0)
c --------------------------
      DATA EXMIN /1.0D0/
      DATA A0/ .248015873015873015873016D-04/,
     *     A1/-.344452080605731005808147D-05/,
     *     A2/ .206664230430046597475413D-06/,
     *     A3/-.447300111094328162971036D-08/,
     *     A4/ .114734027080634968083920D-11/
      DATA B1/-.249994190011341852652396D+00/,
     *     B2/ .249987228833107957725728D-01/,
     *     B3/-.119037506846942249362528D-02/,
     *     B4/ .228908693387350391768682D-04/
c --------------------------
      DATA P1/ .914041914819518D-09/, P2/ .238082361044469D-01/,
     *     Q1/-.499999999085958D+00/, Q2/ .107141568980644D+00/,
     *     Q3/-.119041179760821D-01/, Q4/ .595130811860248D-03/
c ----------------------
      IF (EXMIN .GT. 0.0D0) THEN
         ROUND = D1MACH(4)
         EXMIN = LOG(ROUND)
      END IF
      IF (ABS(X) .LE. 0.15D0) THEN
         IF (ROUND .LT. 1.0D-14) THEN
C
C           Z IS A MINIMAX APPROXIMATION OF THE SERIES
C
C                C6 + C7*X + C8*X**2 + ....
C
C           THIS APPROXIMATION IS ACCURATE TO WITHIN
C           1 UNIT OF THE 23-RD SIGNIFICANT DIGIT.
C           THE RESULTING VALUE FOR DREXP IS ACCURATE TO
C           WITHIN 1 UNIT OF THE 33-RD SIGNIFICANT
C           DIGIT.
C
            Z = ((((A4*X + A3)*X + A2)*X + A1)*X + A0) /
     *          ((((B4*X + B3)*X + B2)*X + B1)*X + 1.D0)
            DREXP = X * (((((((Z*X + C5)*X + C4)*X + C3)*X + C2)*X +
     *                  C1)*X + 0.5D0)*X + 1.D0)
            RETURN
         END IF
         DREXP = X*(((P2*X + P1)*X + 1.0D0)/((((Q4*X + Q3)*X + Q2)*X +
     *           Q1)*X + 1.0D0))
         RETURN
      END IF
C
      IF (X .GE. 0.D0) THEN
         Z = EXP(X)
         DREXP = Z*(0.5D0 + (0.5D0 - 1.D0/Z))
         RETURN
      END IF
      IF (X .GE. EXMIN) THEN
         DREXP = (EXP(X) - 0.5D0) - 0.5D0
         RETURN
      END IF
      DREXP = -1.D0
      RETURN
      END


      SUBROUTINE MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the solution to a real system of linear equations
C        X * op(A) = B,
C     where op(A) is either A or its transpose, A is an N-by-N matrix,
C     and X and B are M-by-N matrices.
C     The LU decomposition with partial pivoting and row interchanges,
C     A = P * L * U, is used, where P is a permutation matrix, L is unit
C     lower triangular, and U is upper triangular.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANS   CHARACTER*1
C             Specifies the form of op(A) to be used as follows:
C             = 'N':  op(A) = A;
C             = 'T':  op(A) = A';
C             = 'C':  op(A) = A'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix B.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix B, and the order of
C             the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the coefficient matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the factors L and U from the factorization A = P*L*U;
C             the unit diagonal elements of L are not stored.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     IPIV    (output) INTEGER array, dimension (N)
C             The pivot indices that define the permutation matrix P;
C             row i of the matrix was interchanged with row IPIV(i).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading M-by-N part of this array must
C             contain the right hand side matrix B.
C             On exit, if INFO = 0, the leading M-by-N part of this
C             array contains the solution matrix X.
C
C     LDB     (input) INTEGER
C             The leading dimension of the array B.  LDB >= max(1,M).
C
C     INFO    (output) INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, U(i,i) is exactly zero.  The
C                   factorization has been completed, but the factor U
C                   is exactly singular, so the solution could not be
C                   computed.
C
C     METHOD
C
C     The LU decomposition with partial pivoting and row interchanges is
C     used to factor A as
C        A = P * L * U,
C     where P is a permutation matrix, L is unit lower triangular, and
C     U is upper triangular.  The factored form of A is then used to
C     solve the system of equations X * A = B or X * A' = B.
C
C     FURTHER COMMENTS
C
C     This routine enables to solve the system X * A = B or X * A' = B
C     as easily and efficiently as possible; it is similar to the LAPACK
C     Library routine DGESV, which solves A * X = B.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, linear algebra.
C
C    ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, M, N
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            TRAN
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGETRF, DTRSM, MA02GD, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the scalar input parameters.
C
      INFO = 0
      TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -8
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02VD', -INFO )
         RETURN
      END IF
C
C     Compute the LU factorization of A.
C
      CALL DGETRF( N, N, A, LDA, IPIV, INFO )
C
      IF( INFO.EQ.0 ) THEN
         IF( TRAN ) THEN
C
C           Compute X = B * A**(-T).
C
            CALL MA02GD( M, B, LDB, 1, N, IPIV, 1 )
            CALL DTRSM(  'Right', 'Lower', 'Transpose', 'Unit', M, N,
     $                   ONE, A, LDA, B, LDB )
            CALL DTRSM(  'Right', 'Upper', 'Transpose', 'NonUnit', M,
     $                   N, ONE, A, LDA, B, LDB )
         ELSE
C
C           Compute X = B * A**(-1).
C
            CALL DTRSM(  'Right', 'Upper', 'NoTranspose', 'NonUnit', M,
     $                   N, ONE, A, LDA, B, LDB )
            CALL DTRSM(  'Right', 'Lower', 'NoTranspose', 'Unit', M, N,
     $                   ONE, A, LDA, B, LDB )
            CALL MA02GD( M, B, LDB, 1, N, IPIV, -1 )
         END IF
      END IF
      RETURN
C
C *** Last line of MB02VD ***
      END


      SUBROUTINE jacobian
      USE vmec_main, ONLY: ohs, nrzt, irst
      USE vmec_params, ONLY: meven, modd
      USE realspace
      USE vmec_dim, ONLY: ns
      USE vforces, r12 => armn_o, ru12 => azmn_e, zu12 => armn_e,
     1             rs => bzmn_e, zs => brmn_e, tau => azmn_o  !,z12 => blmn_e,
      IMPLICIT NONE
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: zero = 0, p5 = 0.5_dp, p25 = p5*p5
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: l
      REAL(rprec) :: taumax, taumin, dphids, temp(nrzt/ns)
C-----------------------------------------------
!
!     (RS, ZS)=(R, Z) SUB S, (RU12, ZU12)=(R, Z) SUB THETA(=U)
!     AND TAU=SQRT(G)/R ARE DIFFERENCED ON HALF MESH
!     NOTE: LOOPS WERE SPLIT TO ALLOW EFFICIENT MEMORY BUS USAGE
!
!     SQRT(G) = R*TAU IS COMPUTED IN BCOVAR
!
!     FOR OPTIMIZATION ON CRAY, MUST USE COMPILER DIRECTIVES TO
!     GET VECTORIZATION OF LOOPS INVOLVING MORE THAN ONE POINTER!
!
!
!     HERE, TAU = (Ru * Zs - Rs * Zu). THE DERIVATIVES OF SHALF = SQRT(s)
!     WERE COMPUTED EXPLICITLY AS: d(shalf)/ds = .5/shalf
!
!     NOTE: z12 IS USED IN RECONSTRUCTION PART OF CODE ONLY; COULD BE ELIMINATED...
!
!
      dphids = p25
      irst = 1

CDIR$ IVDEP
      DO l = 2,nrzt
        ru12(l) = p5*(ru(l,meven) + ru(l-1,meven) +
     1       shalf(l)*(ru(l,modd)  + ru(l-1,modd)))
        zs(l)   = ohs*(z1(l,meven) - z1(l-1,meven) +
     1       shalf(l)*(z1(l,modd)  - z1(l-1,modd)))
!        z12(l)  = p5*(z1(l,meven) + z1(l-1,meven) +
!     1       shalf(l)*(z1(l,modd)  + z1(l-1,modd)))
        tau(l) = ru12(l)*zs(l) + dphids*
     1  (ru(l,modd) *z1(l,modd) + ru(l-1,modd) *z1(l-1,modd) +
     2  (ru(l,meven)*z1(l,modd) + ru(l-1,meven)*z1(l-1,modd))/shalf(l))
      ENDDO

CDIR$ IVDEP
      DO l = 2,nrzt
        zu12(l) = p5*(zu(l,meven) + zu(l-1,meven) +
     1       shalf(l)*(zu(l,modd)  + zu(l-1,modd)))
        rs(l)   = ohs*(r1(l,meven) - r1(l-1,meven) +
     1       shalf(l)*(r1(l,modd)  - r1(l-1,modd)))
        r12(l)  = p5*(r1(l,meven) + r1(l-1,meven) +
     1       shalf(l)*(r1(l,modd)  + r1(l-1,modd)))
        tau(l) = (tau(l) - rs(l)*zu12(l) - dphids*
     1    (zu(l,modd) *r1(l,modd)+zu(l-1,modd) *r1(l-1,modd)
     2  + (zu(l,meven)*r1(l,modd)+zu(l-1,meven)*r1(l-1,modd))/shalf(l)))
      END DO

!
!     TEST FOR SIGN CHANGE IN JACOBIAN
!
      temp(:) = tau(2:nrzt:ns)
      tau(1:nrzt:ns) = temp(:)
      taumax = MAXVAL(tau(2:nrzt))
      taumin = MINVAL(tau(2:nrzt))
      IF (taumax*taumin .lt. zero) irst = 2

      END SUBROUTINE jacobian


c*********************************************************
c This program generate piramidal shape around central
c point iin. After that program construct approcsimation
c cone with radius sig1 and amplitude amp1, only for
c neigbouring points. The next step is constraction new
c more wider approximation cone for all points iside the
c sircle radiuus of sig1. The new cone radius is sig2 and
c n_f is the numder of points inside the new cone base
c*********************************************************
      SUBROUTINE RES_TRIA(lidd,nlidd,iin,nmm,ff,amp1,sig1,sig2,n_f,n2,
     *tresh,ierr)
      IMPLICIT NONE
      include "tomo.h"
      include "line.h"
      integer*4 nmm
      real*4    ff(nmm),amp1,sig1,sig2,tresh
      integer*4 lidd(nmm),nlidd,n_f,ierr
      real*8    s,s1,x1(3),x2(3),del,factor,s2,s3,atresh,wc,dc
      integer*4 i,i1,i2,i3,iin,i_glob,ilo_glob,ilo,iou,nd1,nve,
     *nsum_c,j,k,kk,mp,n2,nve2
      nlidd=0
      ierr=0
      factor=0.1d0
c
c  Get the central point coordinates, x1
c
      iou=ioutr(iin)
      i1=icrpnt(iou)/1000000
      i3=icrpnt(iou)-i1*1000000
      i2=i3/1000
      i3=i3-i2*1000
      s1=dr(i1)*dr(i1)+dr(i2)*dr(i2)+dr(i3)*dr(i3)
      s=DSQRT(s1)
      x1(1)=dr(i1)/s
      x1(2)=dr(i2)/s
      x1(3)=dr(i3)/s
c
c Define main plane
c
      mp=0
      if(i1.ge.2.and.i1.le.nd.and.i2.ge.2.and.i2.le.nd) mp=3
      if(i1.ge.2.and.i1.le.nd.and.i3.ge.2.and.i3.le.nd) mp=2
      if(i3.ge.2.and.i3.le.nd.and.i2.ge.2.and.i2.le.nd) mp=1
c
c  Get neighbour points coordinate, six points maximum
c
      nd1=nd+1
      s=0.0d0
      nve=0
      do i=i1-1,i1+1
      do j=i2-1,i2+1
      do k=i3-1,i3+1
        if(min0(i,j,k).eq.1.or.max0(i,j,k).eq.nd1) then
        if(min0(i,j,k).ge.1.and.max0(i,j,k).le.nd1) then
        if((mp.ne.1.or.IABS(i-i1).eq.0).and.
     +     (mp.ne.2.or.IABS(j-i2).eq.0).and.
     +     (mp.ne.3.or.IABS(k-i3).eq.0)) then
        if(max0(IABS(i-i1),IABS(j-i2),IABS(k-i3)).lt.2) then
          nsum_c=IABS(i-i1)+IABS(j-i2)+IABS(k-i3)
          if(nsum_c.eq.2.or.nsum_c.eq.1) then
            s1=dr(i)*dr(i)+dr(j)*dr(j)+dr(k)*dr(k)
            s1=DSQRT(s1)
            x2(1)=dr(i)/s1
            x2(2)=dr(j)/s1
            x2(3)=dr(k)/s1
            s1=x1(1)*x2(1)+x1(2)*x2(2)+x1(3)*x2(3)
            if(DABS(s1).gt.1.0d0) s1=DSIGN(1.0d0,s1)
            i_glob=i*1000000+j*1000+k
            ilo_glob=0
            do kk=1,nall
              if(icrpnt(kk).eq.i_glob) then
                 ilo_glob=kk
                 goto 10
              endif
            enddo
            STOP 'Wrong table icrpnt'
   10       ilo=ilocr(ilo_glob)
            if(ilo.ne.0) then
              nlidd=nlidd+1
              lidd(nlidd)=ilo
              del=DACOS(s1)/drad
              if(del.gt.0.1d0) then
                s=s+DBLE(ff(iin)-ff(ilo))/del
                nve=nve+1
              endif
            endif
          endif
        endif
        endif
        endif
        endif
      enddo
      enddo
      enddo
c
c  Evaluate sig1, (degree)
c
      s=s/nve
      amp1=ff(iin)
      sig2=-1.0
      if(s.le.1.0d-10) then
        sig1=-1.0
      else
        sig1=ff(iin)/s
      endif
c
c more wider area. Incudes all surrounding points
c in the vicinity sig1. The new wider vicinity is
c sig2, (degree)
c
      s=0.0d0
      s2=0.0d0
      nve=0
      nve2=0
      wc=DABS(DBLE(ff(iin)))
      atresh=wc*factor
      wc=wc/2.0d0
      do i=1,nall
        if(i.ne.iou) then
          s1=0.d0
            do j=1,3
              s1=s1+dpx(j,i)*dpx(j,iou)
            enddo
          if(DABS(s1).gt.1.0d0) s1=DSIGN(1.0d0,s1)
          s1=DACOS(s1)*DBLE(R)
          del=s1/DBLE(R)/drad
c
c Cone approximation
c
          if(del.le.DBLE(sig1)) then
            ilo=ilocr(i)
            if(ilo.ne.0) then
              s=s+DBLE(ff(iin)-ff(ilo))/del
              nve=nve+1
            endif
          endif
c
c Gaussian approximation
c
c         if(del.le.DBLE(tresh)) then
          if(del.le.DBLE(sig1*1.2)) then
            ilo=ilocr(i)
            s3=DABS(DBLE(ff(ilo)))
c           if(ilo.ne.0.and.s3.gt.atresh) then
            if(ilo.ne.0) then
              dc=2.0d0*dpi*del/dlcell
              s2=s2+s3*del*del/dc
              wc=wc+ABS(ff(ilo))/dc
              nve2=nve2+1
            endif
          endif
c
        endif
      enddo
      n_f=nve+1
      n2=nve2+1
      if(s.le.1.0d-10) then
        sig1=-1.0
        ierr=1
      else
        s=s/nve
        sig1=ff(iin)/s
      endif
      if(s2.le.1.0d-10) then
        sig2=-1.0
        ierr=2
      else
        sig2=SNGL(DSQRT(s2/wc))
      endif
      return
      end