*DECK DQC25S
      SUBROUTINE DQC25S (F, A, B, BL, BR, ALFA, BETA, RI, RJ, RG, RH,
     +   RESULT, ABSERR, RESASC, INTEGR, NEV)
C***BEGIN PROLOGUE  DQC25S
C***PURPOSE  To compute I = Integral of F*W over (BL,BR), with error
C            estimate, where the weight function W has a singular
C            behaviour of ALGEBRAICO-LOGARITHMIC type at the points
C            A and/or B. (BL,BR) is a part of (A,B).
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A2A2
C***TYPE      DOUBLE PRECISION (QC25S-S, DQC25S-D)
C***KEYWORDS  25-POINT CLENSHAW-CURTIS INTEGRATION, QUADPACK, QUADRATURE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Integration rules for integrands having ALGEBRAICO-LOGARITHMIC
C        end point singularities
C        Standard fortran subroutine
C        Double precision version
C
C        PARAMETERS
C           F      - Double precision
C                    Function subprogram defining the integrand
C                    F(X). The actual name for F needs to be declared
C                    E X T E R N A L  in the driver program.
C
C           A      - Double precision
C                    Left end point of the original interval
C
C           B      - Double precision
C                    Right end point of the original interval, B.GT.A
C
C           BL     - Double precision
C                    Lower limit of integration, BL.GE.A
C
C           BR     - Double precision
C                    Upper limit of integration, BR.LE.B
C
C           ALFA   - Double precision
C                    PARAMETER IN THE WEIGHT FUNCTION
C
C           BETA   - Double precision
C                    Parameter in the weight function
C
C           RI,RJ,RG,RH - Double precision
C                    Modified CHEBYSHEV moments for the application
C                    of the generalized CLENSHAW-CURTIS
C                    method (computed in subroutine DQMOMO)
C
C           RESULT - Double precision
C                    Approximation to the integral
C                    RESULT is computed by using a generalized
C                    CLENSHAW-CURTIS method if B1 = A or BR = B.
C                    in all other cases the 15-POINT KRONROD
C                    RULE is applied, obtained by optimal addition of
C                    Abscissae to the 7-POINT GAUSS RULE.
C
C           ABSERR - Double precision
C                    Estimate of the modulus of the absolute error,
C                    which should equal or exceed ABS(I-RESULT)
C
C           RESASC - Double precision
C                    Approximation to the integral of ABS(F*W-I/(B-A))
C
C           INTEGR - Integer
C                    Which determines the weight function
C                    = 1   W(X) = (X-A)**ALFA*(B-X)**BETA
C                    = 2   W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A)
C                    = 3   W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(B-X)
C                    = 4   W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*
C                                 LOG(B-X)
C
C           NEV    - Integer
C                    Number of integrand evaluations
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DQCHEB, DQK15W, DQWGTS
C***REVISION HISTORY  (YYMMDD)
C   810101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DQC25S
C
      DOUBLE PRECISION A,ABSERR,ALFA,B,BETA,BL,BR,CENTR,CHEB12,CHEB24,
     1  DC,F,FACTOR,FIX,FVAL,HLGTH,RESABS,RESASC,RESULT,RES12,
     2  RES24,RG,RH,RI,RJ,U,DQWGTS,X
      INTEGER I,INTEGR,ISYM,NEV
C
      DIMENSION CHEB12(13),CHEB24(25),FVAL(25),RG(25),RH(25),RI(25),
     1  RJ(25),X(11)
C
      EXTERNAL F, DQWGTS
C
C           THE VECTOR X CONTAINS THE VALUES COS(K*PI/24)
C           K = 1, ..., 11, TO BE USED FOR THE COMPUTATION OF THE
C           CHEBYSHEV SERIES EXPANSION OF F.
C
      SAVE X
       DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10),X(11)/
     1     0.9914448613738104D+00,     0.9659258262890683D+00,
     2     0.9238795325112868D+00,     0.8660254037844386D+00,
     3     0.7933533402912352D+00,     0.7071067811865475D+00,
     4     0.6087614290087206D+00,     0.5000000000000000D+00,
     5     0.3826834323650898D+00,     0.2588190451025208D+00,
     6     0.1305261922200516D+00/
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           FVAL   - VALUE OF THE FUNCTION F AT THE POINTS
C                    (BR-BL)*0.5*COS(K*PI/24)+(BR+BL)*0.5
C                    K = 0, ..., 24
C           CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION
C                    OF DEGREE 12, FOR THE FUNCTION F, IN THE
C                    INTERVAL (BL,BR)
C           CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION
C                    OF DEGREE 24, FOR THE FUNCTION F, IN THE
C                    INTERVAL (BL,BR)
C           RES12  - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB12
C           RES24  - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB24
C           DQWGTS - EXTERNAL FUNCTION SUBPROGRAM DEFINING
C                    THE FOUR POSSIBLE WEIGHT FUNCTIONS
C           HLGTH  - HALF-LENGTH OF THE INTERVAL (BL,BR)
C           CENTR  - MID POINT OF THE INTERVAL (BL,BR)
C
C***FIRST EXECUTABLE STATEMENT  DQC25S
      NEV = 25
      IF(BL.EQ.A.AND.(ALFA.NE.0.0D+00.OR.INTEGR.EQ.2.OR.INTEGR.EQ.4))
     1 GO TO 10
      IF(BR.EQ.B.AND.(BETA.NE.0.0D+00.OR.INTEGR.EQ.3.OR.INTEGR.EQ.4))
     1 GO TO 140
C
C           IF A.GT.BL AND B.LT.BR, APPLY THE 15-POINT GAUSS-KRONROD
C           SCHEME.
C
C
      CALL DQK15W(F,DQWGTS,A,B,ALFA,BETA,INTEGR,BL,BR,
     1    RESULT,ABSERR,RESABS,RESASC)
      NEV = 15
      GO TO 270
C
C           THIS PART OF THE PROGRAM IS EXECUTED ONLY IF A = BL.
C           ----------------------------------------------------
C
C           COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE
C           FOLLOWING FUNCTION
C           F1 = (0.5*(B+B-BR-A)-0.5*(BR-A)*X)**BETA
C                  *F(0.5*(BR-A)*X+0.5*(BR+A))
C
   10 HLGTH = 0.5D+00*(BR-BL)
      CENTR = 0.5D+00*(BR+BL)
      FIX = B-CENTR
      FVAL(1) = 0.5D+00*F(HLGTH+CENTR)*(FIX-HLGTH)**BETA
      FVAL(13) = F(CENTR)*(FIX**BETA)
      FVAL(25) = 0.5D+00*F(CENTR-HLGTH)*(FIX+HLGTH)**BETA
      DO 20 I=2,12
        U = HLGTH*X(I-1)
        ISYM = 26-I
        FVAL(I) = F(U+CENTR)*(FIX-U)**BETA
        FVAL(ISYM) = F(CENTR-U)*(FIX+U)**BETA
   20 CONTINUE
      FACTOR = HLGTH**(ALFA+0.1D+01)
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      RES12 = 0.0D+00
      RES24 = 0.0D+00
      IF(INTEGR.GT.2) GO TO 70
      CALL DQCHEB(X,FVAL,CHEB12,CHEB24)
C
C           INTEGR = 1  (OR 2)
C
      DO 30 I=1,13
        RES12 = RES12+CHEB12(I)*RI(I)
        RES24 = RES24+CHEB24(I)*RI(I)
   30 CONTINUE
      DO 40 I=14,25
        RES24 = RES24+CHEB24(I)*RI(I)
   40 CONTINUE
      IF(INTEGR.EQ.1) GO TO 130
C
C           INTEGR = 2
C
      DC = LOG(BR-BL)
      RESULT = RES24*DC
      ABSERR = ABS((RES24-RES12)*DC)
      RES12 = 0.0D+00
      RES24 = 0.0D+00
      DO 50 I=1,13
        RES12 = RES12+CHEB12(I)*RG(I)
        RES24 = RES12+CHEB24(I)*RG(I)
   50 CONTINUE
      DO 60 I=14,25
        RES24 = RES24+CHEB24(I)*RG(I)
   60 CONTINUE
      GO TO 130
C
C           COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE
C           FOLLOWING FUNCTION
C           F4 = F1*LOG(0.5*(B+B-BR-A)-0.5*(BR-A)*X)
C
   70 FVAL(1) = FVAL(1)*LOG(FIX-HLGTH)
      FVAL(13) = FVAL(13)*LOG(FIX)
      FVAL(25) = FVAL(25)*LOG(FIX+HLGTH)
      DO 80 I=2,12
        U = HLGTH*X(I-1)
        ISYM = 26-I
        FVAL(I) = FVAL(I)*LOG(FIX-U)
        FVAL(ISYM) = FVAL(ISYM)*LOG(FIX+U)
   80 CONTINUE
      CALL DQCHEB(X,FVAL,CHEB12,CHEB24)
C
C           INTEGR = 3  (OR 4)
C
      DO 90 I=1,13
        RES12 = RES12+CHEB12(I)*RI(I)
        RES24 = RES24+CHEB24(I)*RI(I)
   90 CONTINUE
      DO 100 I=14,25
        RES24 = RES24+CHEB24(I)*RI(I)
  100 CONTINUE
      IF(INTEGR.EQ.3) GO TO 130
C
C           INTEGR = 4
C
      DC = LOG(BR-BL)
      RESULT = RES24*DC
      ABSERR = ABS((RES24-RES12)*DC)
      RES12 = 0.0D+00
      RES24 = 0.0D+00
      DO 110 I=1,13
        RES12 = RES12+CHEB12(I)*RG(I)
        RES24 = RES24+CHEB24(I)*RG(I)
  110 CONTINUE
      DO 120 I=14,25
        RES24 = RES24+CHEB24(I)*RG(I)
  120 CONTINUE
  130 RESULT = (RESULT+RES24)*FACTOR
      ABSERR = (ABSERR+ABS(RES24-RES12))*FACTOR
      GO TO 270
C
C           THIS PART OF THE PROGRAM IS EXECUTED ONLY IF B = BR.
C           ----------------------------------------------------
C
C           COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE
C           FOLLOWING FUNCTION
C           F2 = (0.5*(B+BL-A-A)+0.5*(B-BL)*X)**ALFA
C                *F(0.5*(B-BL)*X+0.5*(B+BL))
C
  140 HLGTH = 0.5D+00*(BR-BL)
      CENTR = 0.5D+00*(BR+BL)
      FIX = CENTR-A
      FVAL(1) = 0.5D+00*F(HLGTH+CENTR)*(FIX+HLGTH)**ALFA
      FVAL(13) = F(CENTR)*(FIX**ALFA)
      FVAL(25) = 0.5D+00*F(CENTR-HLGTH)*(FIX-HLGTH)**ALFA
      DO 150 I=2,12
        U = HLGTH*X(I-1)
        ISYM = 26-I
        FVAL(I) = F(U+CENTR)*(FIX+U)**ALFA
        FVAL(ISYM) = F(CENTR-U)*(FIX-U)**ALFA
  150 CONTINUE
      FACTOR = HLGTH**(BETA+0.1D+01)
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      RES12 = 0.0D+00
      RES24 = 0.0D+00
      IF(INTEGR.EQ.2.OR.INTEGR.EQ.4) GO TO 200
C
C           INTEGR = 1  (OR 3)
C
      CALL DQCHEB(X,FVAL,CHEB12,CHEB24)
      DO 160 I=1,13
        RES12 = RES12+CHEB12(I)*RJ(I)
        RES24 = RES24+CHEB24(I)*RJ(I)
  160 CONTINUE
      DO 170 I=14,25
        RES24 = RES24+CHEB24(I)*RJ(I)
  170 CONTINUE
      IF(INTEGR.EQ.1) GO TO 260
C
C           INTEGR = 3
C
      DC = LOG(BR-BL)
      RESULT = RES24*DC
      ABSERR = ABS((RES24-RES12)*DC)
      RES12 = 0.0D+00
      RES24 = 0.0D+00
      DO 180 I=1,13
        RES12 = RES12+CHEB12(I)*RH(I)
        RES24 = RES24+CHEB24(I)*RH(I)
  180 CONTINUE
      DO 190 I=14,25
        RES24 = RES24+CHEB24(I)*RH(I)
  190 CONTINUE
      GO TO 260
C
C           COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE
C           FOLLOWING FUNCTION
C           F3 = F2*LOG(0.5*(B-BL)*X+0.5*(B+BL-A-A))
C
  200 FVAL(1) = FVAL(1)*LOG(FIX+HLGTH)
      FVAL(13) = FVAL(13)*LOG(FIX)
      FVAL(25) = FVAL(25)*LOG(FIX-HLGTH)
      DO 210 I=2,12
        U = HLGTH*X(I-1)
        ISYM = 26-I
        FVAL(I) = FVAL(I)*LOG(U+FIX)
        FVAL(ISYM) = FVAL(ISYM)*LOG(FIX-U)
  210 CONTINUE
      CALL DQCHEB(X,FVAL,CHEB12,CHEB24)
C
C           INTEGR = 2  (OR 4)
C
      DO 220 I=1,13
        RES12 = RES12+CHEB12(I)*RJ(I)
        RES24 = RES24+CHEB24(I)*RJ(I)
  220 CONTINUE
      DO 230 I=14,25
        RES24 = RES24+CHEB24(I)*RJ(I)
  230 CONTINUE
      IF(INTEGR.EQ.2) GO TO 260
      DC = LOG(BR-BL)
      RESULT = RES24*DC
      ABSERR = ABS((RES24-RES12)*DC)
      RES12 = 0.0D+00
      RES24 = 0.0D+00
C
C           INTEGR = 4
C
      DO 240 I=1,13
        RES12 = RES12+CHEB12(I)*RH(I)
        RES24 = RES24+CHEB24(I)*RH(I)
  240 CONTINUE
      DO 250 I=14,25
        RES24 = RES24+CHEB24(I)*RH(I)
  250 CONTINUE
  260 RESULT = (RESULT+RES24)*FACTOR
      ABSERR = (ABSERR+ABS(RES24-RES12))*FACTOR
  270 RETURN
      END


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
! Reference Joachim Kopp, Int. J. Mod. Phys. C 19 (2008) 523-548
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine diag3x3(zA,zB,lambda)
  implicit none
  real(8),parameter :: pi=4d0*atan(1d0)
  complex(8), intent(in) :: zA(3,3)
  complex(8), intent(out) :: zB(3,3)
  real(8), intent(out) :: lambda(3)

  real(8) :: c0,c1,c2
  real(8) :: p,q,t,ss,phi,xx(3),xx_t(3)
  complex(8) :: zC(3,3),zx,zy
  integer :: ivec,imin

  c2 = -real(zA(1,1)+zA(2,2)+zA(3,3))
  c1 = real( zA(1,1)*zA(2,2) + zA(2,2)*zA(3,3) + zA(3,3)*zA(1,1) &
       -abs(zA(1,2))**2 -abs(zA(1,3))**2 -abs(zA(2,3))**2 )
  c0 = real( zA(1,1)*abs(zA(2,3))**2 + zA(2,2)*abs(zA(1,3))**2 &
       + zA(3,3)*abs(zA(1,2))**2 - zA(1,1)*zA(2,2)*zA(3,3) &
       - 2d0*conjg(zA(1,3))*zA(1,2)*zA(2,3) )

  p = c2**2 - 3d0*c1
  q = -27d0*c0/2d0 -c2**3 + 9d0*c2*c1/2d0
  ss = c1**2*(p-c1)/4d0+c0*(q+27d0*c0/4d0)
  ss = sqrt(27d0*ss)/q
  phi = atan(ss)/3d0
  if(phi < 0)phi = phi + pi

  xx(1) = 2d0*cos(phi)
  xx(2) = 2d0*cos(phi+2d0*pi/3d0)
  xx(3) = 2d0*cos(phi-2d0*pi/3d0)

  lambda(:) = (sqrt(p)*xx(:)-c2)/3d0

  do ivec = 1,3

    zC = zA
    zC(1,1) = zC(1,1) -lambda(ivec)
    zC(2,2) = zC(2,2) -lambda(ivec)
    zC(3,3) = zC(3,3) -lambda(ivec)

    xx(1) = abs(zC(1,1))
    xx(2) = abs(zC(2,2))
    xx(3) = abs(zC(3,3))
    if(xx(1)<xx(2))then
      if(xx(1)<xx(3))then
        imin = 1
      else
        imin = 3
      end if
    else
      if(xx(2)<xx(3))then
        imin=2
      else
        imin=3
      end if
    end if

    select case(imin)
    case(1)
! First vector
      zx = (conjg(zC(1,3))*zC(2,3) - zC(3,3)*conjg(zC(1,2))) &
        /(zC(2,2)*zC(3,3)-abs(zC(2,3))**2)
      zy = -(conjg(zC(1,3)) + conjg(zC(2,3))*zx)/zC(3,3)

      ss = 1d0 + abs(zx)**2 + abs(zy)**2; ss = 1d0/sqrt(ss)
      zB(1,ivec) = ss; zB(2,ivec) = zx*ss; zB(3,ivec) = zy*ss
    case(2)
! Second vector
      zx = (conjg(zC(1,3))*zC(1,2) - zC(1,1)*conjg(zC(2,3))) &
        /(zC(1,1)*zC(3,3)-abs(zC(1,3))**2)
      zy = -(zC(1,2) + zC(1,3)*zx)/zC(1,1)
      ss = 1d0 + abs(zx)**2 + abs(zy)**2; ss = 1d0/sqrt(ss)
      zB(1,ivec) = zy*ss; zB(2,ivec) = ss; zB(3,ivec) = zx*ss
    case(3)
! Third vector
      zx = (zC(1,2)*zC(2,3) - zC(2,2)*zC(1,3)) &
        /(zC(1,1)*zC(2,2)-abs(zC(1,2))**2)
      zy = -(zC(2,3) + conjg(zC(1,2))*zx)/zC(2,2)
      ss = 1d0 + abs(zx)**2 + abs(zy)**2; ss = 1d0/sqrt(ss)
      zB(1,ivec) = zx*ss; zB(2,ivec) = zy*ss; zB(3,ivec) = ss
    case default
      stop "Failed in diag3x3"
    end select
  end do
end subroutine diag3x3


SUBROUTINE cmp_all_Gaunt(cgcoef, maxj)
  IMPLICIT NONE
  INTEGER, intent(in) :: maxj
  REAL*8, intent(out), dimension( (maxj+1)*(maxj+2)*(maxj+3)*(16*maxj*maxj+29*maxj+10)/60 ) :: cgcoef
  ! External function
  REAL*8 :: Gaunt
  ! Temporaries
  REAL*8, parameter :: pi = 3.14159265358979d0
  INTEGER :: m1, m2, m3, l1, l2, l3, i
  REAL*8  :: c
  !ntot=(maxj+1)*(maxj+2)*(maxj+3)*(16*maxj*maxj+29*maxj+10)/60
  i=0
  do l1=0,maxj
     do l2=0,l1
        do l3=l1-l2,l1+l2
           do m1=-l1,l1
              do m2=0,l2
                 m3=m1+m2
                 i=i+1
                 if(mod(l1+l2+l3,2).eq.0)then
                    if(iabs(m3).le.l3)then
                       cgcoef(i) = Gaunt(l3,m3,l2,m2,l1,m1)
                    else
                       cgcoef(i)=0.0d0
                    endif
                 else
                    cgcoef(i)=0.0d0
                 endif
              enddo
           enddo
        enddo
     enddo
  enddo
END SUBROUTINE cmp_all_Gaunt

REAL*8 function getcgcoef(l1,l2,l3,m1,m2,cgcoef)
!This subroutine gets the gaunt coefficient $G^{l3,m1+m2}_{l1,l2,m1,m2}$
!from the vector \verb"cgcoef" by:
!\begin{equation}
!G^{l3,m1+m2}_{l1,l2,m1,m2}=\alpha \verb"cgcoef"(i)
!\end{equation}
!calculating i by:
!\begin{equation}
!\begin{aligned}
!i=&\tfrac{1}{60}(16l^2-3l-3)(l+2)(l+1)l+\tfrac{1}{3}ll'(l'+1)(4l'-1)+%
!\tfrac{1}{6}l'(l'-1)(4l'+7)+\\
!&+(2l+1)(l'+1)(L-l+l')+(l'+1)(m+l)+m'+l'+1
!\end{aligned}
!\end{equation}
!where
!
!\begin{subequations}
!\begin{align}
!l&=l1 & l'&=l2 & m&=m1 & m'&=m2 & \alpha&=1 &\text{ if $l1 \ge l2$} \\
!l&=l2 & l'&=l1 & m&=m2 & m'&=m1 & \alpha&=1 &\text{ if $l1 < l2$} \\
! &    &   &    & m&=m1 & m'&=m2 & \alpha&=1 &\text{ if $m2 \ge 0$} \\
! &    &   &    & m&=-m1 & m'&=-m2 & \alpha&=(-1)^{l+l'-L} &\text{ if $m2 < 0$}
!\end{align}
!\end{subequations}
!
  implicit none
  REAL*8, intent(in) :: cgcoef(*)
  integer(4), intent(in) :: l1, l2, l3, m1, m2
  ! !LOCAL VARIABLES:
  integer(4) :: j1,j2,mj1,mj2
  integer(4) :: par,ing
  integer(4) :: ind1,ind2,ind3,ind4
  real(8) :: fact
  logical :: trcond
  intrinsic mod
  intrinsic abs
  par=mod(abs(l1+l2-l3),2)
  fact=1.0d0
  trcond=(abs(m1+m2).le.l3).and.(abs(l1-l2).le.l3).and.(l1+l2.ge.l3)
  if(trcond)then
     if(l1.lt.l2)then
        j1=l2
        mj1=m2
        j2=l1
        mj2=m1
     else
        j1=l1
        mj1=m1
        j2=l2
        mj2=m2
     endif
     if(mj2.lt.0)then
        mj2=-mj2
        mj1=-mj1
        fact=(-2.0d0*par+1.0d0)
     endif
     ind1=(16*j1*j1-3*j1-3)*(j1+2)*(j1+1)*j1/60
     ind2=j1*j2*(j2+1)*(4*j2-1)/3
     ind3=j2*(j2-1)*(4*j2+7)/6
     ind4=(2*j1+1)*(j2+1)*(l3-j1+j2)
     ing=ind1+ind2+ind3+ind4+(j2+1)*(mj1+j1)+mj2+j2+1
     getcgcoef=fact*cgcoef(ing)
  else
     getcgcoef=0.0d0
  endif
end function getcgcoef

REAL*8 function Gaunt(l1, m1, l2, m2, l3, m3)
  IMPLICIT NONE
  INTEGER, intent(in) :: l1, m1, l2, m2, l3, m3
  REAL*8, PARAMETER   :: pi = 3.14159265358979d0
  REAL*8 :: l1_, l2_, l3_, mm1_, m2_, m3_, zero
  ! function calls
  REAL*8             :: f3j
  REAL*8             :: mone
  l1_ = l1;   l2_ = l2;   l3_ = l3
  mm1_ = -m1; m2_ = m2; m3_ = m3
  zero = 0
  ! Calculates <Y_{l1m1}|Y_{l2m2}|Y_{l3m3}>
  if (l1.LT.0 .OR. l2.LT.0 .OR. l3.LT.0) print *, "Quantum number l must be non-negative!"
  Gaunt = mone(m1)*sqrt((2*l1+1)*(2*l2+1)*(2*l3+1)/(4*pi))*f3j(l1_,zero,l2_,zero,l3_,zero)*f3j(l1_,mm1_,l2_,m2_,l3_,m3_)
  return
END function Gaunt

REAL*8 function iFactorial(j)
  IMPLICIT NONE
  INTEGER, intent(in) :: j
  INTEGER :: i
  REAL*8 :: x
  if (j<0) print *, "iFactorial defined only for non-negative numbers!"
  x=1
  iFactorial = x
  if (j.eq.1) return
  DO i=2,j
     x = x*i
  END DO
  iFactorial = x
  return
end function iFactorial

REAL*8 function dFactorial(x)
  IMPLICIT NONE
  REAL*8, intent(in) :: x
  REAL*8, PARAMETER :: spi2 = 0.8862269254527579
  REAL*8 :: y, r
  r=1
  y=x
  DO WHILE(y.gt.1.0)
     r = r * y
     y = y -1.
  ENDDO
  IF (abs(y-0.5).LT.1e-10) r = r*spi2
  dFactorial = r
  return
END function dFactorial

REAL*8 function mone(i)
  INTEGER, intent(in) :: i
  mone = 1 - 2*MOD(abs(i),2)
  return
end function mone

REAL*8 function Delta(j1, j2, j)
  IMPLICIT NONE
  REAL*8, intent(in) :: j1, j2, j
  ! function calls
  REAL*8 :: dFactorial
  Delta = sqrt(dFactorial(j1+j2-j)*dFactorial(j1-j2+j)*dFactorial(-j1+j2+j)/dFactorial(j1+j2+j+1))
  return
END function Delta

REAL*8 function f3j(j1, m1, j2, m2, j3, m3)
  IMPLICIT NONE
  REAL*8, intent(in) :: j1, j2, j3, m1, m2, m3
  INTEGER            :: tmin, tmax, t
  REAL*8             :: sum, v1, v2, dn
  ! function calls
  REAL*8             :: dFactorial
  REAL*8             :: iFactorial
  REAL*8             :: Delta
  REAL*8             :: mone
  f3j=0
  IF (abs(m1+m2+m3) .GT. 1e-10) return
  IF (abs(j1-j2)-1e-14 .GT. j3 .OR. j3 .GT. j1+j2+1e-14) return
  if (abs(m1) .GT. j1 .OR. abs(m2) .GT. j2 .OR. abs(m3) .GT. j3) return
  tmin = INT(max(max(0.0,j2-j3-m1),j1-j3+m2)+1e-14)
  tmax = INT(min(min(j1+j2-j3,j1-m1),j2+m2)+1e-14)
  sum=0
  DO t=tmin, tmax
     v1 = dFactorial(j3-j2+m1+t)*dFactorial(j3-j1-m2+t)
     v2 = dFactorial(j1+j2-j3-t)*dFactorial(j1-m1-t)*dFactorial(j2+m2-t)
     sum = sum + mone(t)/(iFactorial(t)*v1*v2)
  END DO
  dn = dFactorial(j1+m1)*dFactorial(j1-m1)*dFactorial(j2+m2)*dFactorial(j2-m2)*dFactorial(j3+m3)*dFactorial(j3-m3)
  f3j = mone(INT(j1-j2-m3))*Delta(j1,j2,j3)*sqrt(dn)*sum
  return
END function f3j

REAL*8 function ClebschG(j,m,j1,m1,j2,m2)
  IMPLICIT NONE
  REAL*8, intent(in) :: j,m,j1,m1,j2,m2
  INTEGER            :: tmin, tmax, t
  REAL*8             :: sum, v1, v2
  ! function calls
  REAL*8             :: iFactorial
  REAL*8             :: dFactorial
  REAL*8             :: mone
  REAL*8             :: Delta

  ClebschG = 0
  IF (m1+m2 .NE. m) return
  tmin = INT(max(max(0.0,j2-j-m1),j1-j+m2)+1e-14)
  tmax = INT(min(min(j1+j2-j,j1-m1),j2+m2)+1e-14)
  sum=0;
  DO t=tmin, tmax
     v1 = sqrt((2*j+1)*dFactorial(j1+m1)*dFactorial(j1-m1)*dFactorial(j2+m2)*dFactorial(j2-m2)*dFactorial(j+m)*dFactorial(j-m))
     v2 = iFactorial(t)*dFactorial(j1+j2-j-t)*dFactorial(j1-m1-t)*dFactorial(j2+m2-t)*dFactorial(j-j2+m1+t)*dFactorial(j-j1-m2+t)
     sum = sum + mone(t)*v1/v2
  END DO
  ClebschG = sum*Delta(j1,j2,j)
  return
END function ClebschG


! { dg-do compile }
! { dg-options "-Warray-temporaries -O -fdump-tree-original" }
!
! PR fortran/43829
! Scalarization of reductions.
! Test that sum is properly inlined.

! This is the compile time test only; for the runtime test see inline_sum_2.f90
! We can't test for temporaries on the run time test directly, as it tries
! several optimization options among which -Os, and sum inlining is disabled
! at -Os.

  implicit none

  integer :: i, j, k

  integer, parameter :: q = 2
  integer, parameter :: nx=3, ny=2*q, nz=5
  integer, parameter, dimension(nx,ny,nz) :: p  = &
        & reshape ((/ (i**2, i=1,size(p)) /), shape(p))

  integer, parameter, dimension(   ny,nz) :: px = &
        & reshape ((/ (( &
        &        nx*(  nx*j+nx*ny*k+1)*(  nx*j+nx*ny*k+1+      (nx-1)) &
        &       +      nx*(nx-1)*(2*nx-1)/6, &
        &       j=0,ny-1), k=0,nz-1) /), shape(px))

  integer, parameter, dimension(nx,   nz) :: py = &
        & reshape ((/ (( &
        &        ny*(i     +nx*ny*k+1)*(i     +nx*ny*k+1+nx   *(ny-1)) &
        &       +(nx   )**2*ny*(ny-1)*(2*ny-1)/6, &
        &       i=0,nx-1), k=0,nz-1) /), shape(py))

  integer, parameter, dimension(nx,ny   ) :: pz = &
        & reshape ((/ (( &
        &        nz*(i+nx*j        +1)*(i+nx*j        +1+nx*ny*(nz-1)) &
        &       +(nx*ny)**2*nz*(nz-1)*(2*nz-1)/6, &
        &       i=0,nx-1), j=0,ny-1) /), shape(pz))

  integer, dimension(nx,ny,nz) :: a
  integer, dimension(   ny,nz) :: ax
  integer, dimension(nx,   nz) :: ay
  integer, dimension(nx,ny   ) :: az

  logical, dimension(nx,ny,nz) :: m, true

  integer, dimension(nx,ny) :: b

  integer, dimension(nx,nx) :: onesx
  integer, dimension(ny,ny) :: onesy
  integer, dimension(nz,nz) :: onesz

  a    = p
  m    = reshape((/ ((/ .true., .false. /), i=1,size(m)/2) /), shape(m))
  true = reshape((/ (.true., i=1,size(true)) /), shape(true))

  onesx = reshape((/ ((1, j=1,i),(0,j=1,nx-i),i=1,size(onesx,2)) /), shape(onesx))
  onesy = reshape((/ ((1, j=1,i),(0,j=1,ny-i),i=1,size(onesy,2)) /), shape(onesy))
  onesz = reshape((/ ((1, j=1,i),(0,j=1,nz-i),i=1,size(onesz,2)) /), shape(onesz))

  ! Correct results in simple cases
  ax = sum(a,1)
  if (any(ax /= px)) STOP 1

  ay = sum(a,2)
  if (any(ay /= py)) STOP 2

  az = sum(a,3)
  if (any(az /= pz)) STOP 3

  ! Masks work
  if (any(sum(a,1,.false.) /= 0))                    STOP 4
  if (any(sum(a,2,.true.)  /= py))                   STOP 5
  if (any(sum(a,3,m)       /= merge(pz,0,m(:,:,1)))) STOP 6
  if (any(sum(a,2,m)       /= merge(sum(a(:, ::2,:),2),&
                                    sum(a(:,2::2,:),2),&
                                    m(:,1,:))))      STOP 7

  ! It works too with array constructors ...
  if (any(sum(                                      &
        reshape((/ (i*i,i=1,size(a)) /), shape(a)), &
        1,                                          &
        true) /= ax)) STOP 8

  ! ... and with vector subscripts
  if (any(sum(               &
        a((/ (i,i=1,nx) /),  &
          (/ (i,i=1,ny) /),  &
          (/ (i,i=1,nz) /)), &
        1) /= ax)) STOP 9

  if (any(sum(                &
        a(sum(onesx(:,:),1),  & ! unnecessary { dg-warning "Creating array temporary" }
          sum(onesy(:,:),1),  & ! unnecessary { dg-warning "Creating array temporary" }
          sum(onesz(:,:),1)), & ! unnecessary { dg-warning "Creating array temporary" }
        1) /= ax)) STOP 10

  ! Nested sums work
  if (sum(sum(sum(a,1),1),1) /= sum(a)) STOP 11
  if (sum(sum(sum(a,1),2),1) /= sum(a)) STOP 12
  if (sum(sum(sum(a,3),1),1) /= sum(a)) STOP 13
  if (sum(sum(sum(a,3),2),1) /= sum(a)) STOP 14

  if (any(sum(sum(a,1),1) /= sum(sum(a,2),1))) STOP 15
  if (any(sum(sum(a,1),2) /= sum(sum(a,3),1))) STOP 16
  if (any(sum(sum(a,2),2) /= sum(sum(a,3),2))) STOP 17

  ! Temps are unavoidable here (function call's argument or result)
  ax = sum(neid3(a),1)          ! { dg-warning "Creating array temporary" }
  ! Sums as part of a bigger expr work
  if (any(1+sum(eid(a),1)+ax+sum( &
        neid3(a), &            ! { dg-warning "Creating array temporary" }
        1)+1  /= 3*ax+2))        STOP 18
  if (any(1+eid(sum(a,2))+ay+ &
        neid2( &               ! { dg-warning "Creating array temporary" }
        sum(a,2) &             ! { dg-warning "Creating array temporary" }
        )+1  /= 3*ay+2))        STOP 19
  if (any(sum(eid(sum(a,3))+az+2* &
        neid2(az) &            ! { dg-warning "Creating array temporary" }
        ,1)+1 /= 4*sum(az,1)+1)) STOP 20

  if (any(sum(transpose(sum(a,1)),1)+sum(az,1) /= sum(ax,2)+sum(sum(a,3),1))) STOP 21

  ! Creates a temp when needed.
  a(1,:,:) = sum(a,1)                   ! unnecessary { dg-warning "Creating array temporary" }
  if (any(a(1,:,:) /= ax)) STOP 22

  b = p(:,:,1)
  call set(b(2:,1), sum(b(:nx-1,:),2))  ! { dg-warning "Creating array temporary" }
  if (any(b(2:,1) /= ay(1:nx-1,1))) STOP 23

  b = p(:,:,1)
  call set(b(:,1), sum(b,2))            ! unnecessary { dg-warning "Creating array temporary" }
  if (any(b(:,1) /= ay(:,1))) STOP 24

  b = p(:,:,1)
  call tes(sum(eid(b(:nx-1,:)),2), b(2:,1))  ! { dg-warning "Creating array temporary" }
  if (any(b(2:,1) /= ay(1:nx-1,1))) STOP 25

  b = p(:,:,1)
  call tes(eid(sum(b,2)), b(:,1))            ! unnecessary { dg-warning "Creating array temporary" }
  if (any(b(:,1) /= ay(:,1))) STOP 26

contains

  elemental function eid (x)
    integer, intent(in) :: x
    integer             :: eid

    eid = x
  end function eid

  function neid2 (x)
    integer, intent(in) :: x(:,:)
    integer             :: neid2(size(x,1),size(x,2))

    neid2 = x
  end function neid2

  function neid3 (x)
    integer, intent(in) :: x(:,:,:)
    integer             :: neid3(size(x,1),size(x,2),size(x,3))

    neid3 = x
  end function neid3

  elemental subroutine set (o, i)
    integer, intent(in)  :: i
    integer, intent(out) :: o

    o = i
  end subroutine set

  elemental subroutine tes (i, o)
    integer, intent(in)  :: i
    integer, intent(out) :: o

    o = i
  end subroutine tes
end
! { dg-final { scan-tree-dump-times "struct array.._integer\\(kind=4\\) atmp" 13 "original" } }
! { dg-final { scan-tree-dump-times "struct array\[^\\n\]*atmp" 13 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_sum_" 0 "original" } }


program array_op_3
implicit none

integer :: a(2, 2, 1), b(2, 2, 1)
logical :: c(2, 2, 1)
integer :: i, j, k

do i = 1, 2
    do j = 1, 2
        do k = 1, 1
            a(i, j, k) = i/j
            b(i, j, k) = j/i
        end do
    end do
end do

c = a .eq. b
call check(c, a, b, 0)

c = a .ne. b
call check(c, a, b, 1)

c = a .lt. b
call check(c, a, b, 2)

c = b <= a
call check(c, a, b, 3)

c = b .gt. a
call check(c, a, b, 4)

c = b >= a
call check(c, a, b, 5)

contains

    subroutine check(c, a, b, op_code)
    implicit none

    integer, intent(in) :: a(:, :, :), b(:, :, :)
    logical, intent(in) :: c(:, :, :)
    integer, intent(in) :: op_code

    integer :: i, j, k

    do i = lbound(a, 1), ubound(a, 1)
        do j = lbound(a, 2), ubound(a, 2)
            do k = lbound(a, 3), ubound(a, 3)
                select case(op_code)
                case (0)
                    if(c(i, j, k) .neqv. (a(i, j, k) .eq. b(i, j, k))) error stop
                case (1)
                    if(c(i, j, k) .neqv. (a(i, j, k) .ne. b(i, j, k))) error stop
                case (2)
                    if(c(i, j, k) .neqv. (a(i, j, k) .lt. b(i, j, k))) error stop
                case (3)
                    if(c(i, j, k) .neqv. (b(i, j, k) <= a(i, j, k))) error stop
                case (4)
                    if(c(i, j, k) .neqv. (b(i, j, k) .gt. a(i, j, k))) error stop
                case (5)
                    if(c(i, j, k) .neqv. (b(i, j, k) >= a(i, j, k))) error stop
                end select
            end do
        end do
    end do

    end subroutine check

end program


! Fortran arrays can have any lower bound. The default is 1
! lbound and ubound are intrinsics that return the lower and upper bounds
! of an array
program bounds
implicit none
integer :: v(-1:1) = [1,-2,3]
integer :: mat(-1:1,3)
print*,lbound(v),ubound(v),size(v) ! -1 1 3
print*,sum(v) ! 2
print*,sum(v,mask=v>0) ! 4 -- sum excludes -2
print*,lbound(mat),ubound(mat),size(mat) ! -1 1 1 3 9
end program bounds


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testExtendedMath
#include "UnitTest.h"
USE UnitTest
USE IntrType
USE Constants_Conversion
USE ExtendedMath

IMPLICIT NONE

CREATE_TEST('EXTENDED MATH')

REGISTER_SUBTEST('Gamma Function',testGammaF)
REGISTER_SUBTEST('Rational Fraction',testRatFrac)
REGISTER_SUBTEST('GCD',testGCD)
REGISTER_SUBTEST('GCD',testLCM)
REGISTER_SUBTEST('ATAN2PI',testATAN2PI)

FINALIZE_TEST()
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE testGammaF()

  ASSERT_SOFTEQ(GAMMAF(0.25_SRK),3.6256099082219083119_SRK,1.0E-12_SRK, 'GammaF 0.25')
  ASSERT_SOFTEQ(GAMMAF(0.5_SRK), 1.7724538509055160273_SRK,1.0E-12_SRK, 'GammaF 0.5')
  ASSERT_SOFTEQ(GAMMAF(0.75_SRK),1.2254167024651776451_SRK,1.0E-12_SRK, 'GammaF 0.75')
  ASSERT_SOFTEQ(GAMMAF(3.5_SRK), 3.3233509704478425512_SRK,1.0E-12_SRK, 'GammaF 3.5')
  ASSERT_SOFTEQ(GAMMAF(5.00_SRK),24.00000000000000000_SRK ,1.0E-12_SRK, 'GammaF 5.0')
  ASSERT_SOFTEQ(GAMMAF(7.00_SRK),720.00000000000000000_SRK,1.0E-10_SRK, 'GammaF 7.0')
ENDSUBROUTINE testGammaF
!
!-------------------------------------------------------------------------------
SUBROUTINE testRatFrac()
  INTEGER(SIK) :: i,N,D
  REAL(SRK) :: dif,tol

  CALL Rational_Fraction(1.5_SRK,1.0E-12_SRK,N,D)
  ASSERT_EQ(N , 3, 'RatFrac 1.5 num')
  ASSERT_EQ(D , 2, 'RatFrac 1.5 denom')

  CALL Rational_Fraction(12.8125_SRK,1.0E-12_SRK,N,D)
  ASSERT_EQ(N , 205, 'RatFrac 12.8125 num')
  ASSERT_EQ(D , 16, 'RatFrac 12.8125 denom')

  ! Values of coefficients checked against wikipedia:
  ! http://en.wikipedia.org/wiki/Continued_fraction
  !  pi: [3;7,15,1,292,1,1,1,2,1,3,1,…].
  ! by truncating at 1e-12, the series should be [3;7,15,1,292,1,1,1,2,1]
  ! which is 1146408 / 364913 from hand calc
  CALL Rational_Fraction(3.141592653589793_SRK,1.0E-12_SRK,N,D)
  ASSERT_EQ(N , 1146408, 'RatFrac PI num')
  ASSERT_EQ(D , 364913, 'RatFrac PI denom')

  ! Values of coefficients checked againt wikipedia:
  !  sqrt(19): [4;2,1,3,1,2,8,2,1,3,1,2,8,…]  series repeats every 6
  ! by truncating to 1e-8 the series should be [4;2,1,3,1,2,8,2,1,3]
  ! which is  16311 / 3742 from hand calc
  CALL Rational_Fraction(SQRT(19.0_SRK),1.0E-8_SRK,N,D)
  ASSERT_EQ(N , 16311, 'RatFrac SQRT(19) num')
  ASSERT_EQ(D , 3742, 'RatFrac SQRT(19) denom')

  ! Checking a range of tolerances to ensure it is working correctly
  !  sqrt(2): [1;2,2,2,...] according to wikipedia.  2 the repeats forever
  !  This is also the slowest converging rational fraction
  DO i=1,12
    tol=10.0_SRK**(-REAL(i,SRK))
    CALL Rational_Fraction(SQRT(2.0_SRK),tol,N,D)
    dif=ABS(REAL(N,SRK)/REAL(D,SRK)/SQRT(2.0_SRK) - 1.0_SRK)
    ASSERT_LE(dif,tol, 'tolerance check')
  ENDDO

ENDSUBROUTINE testRatFrac
!
!-------------------------------------------------------------------------------
SUBROUTINE testGCD()
  ! test error conditions (passing negative or 0 values)
  ASSERT_EQ(GreatestCommonDivisor(-1,5),0, 'GCD errors')
  ASSERT_EQ(GreatestCommonDivisor(5,-5),0, 'GCD errors')
  ASSERT_EQ(GreatestCommonDivisor(-1,-5),0, 'GCD errors')
  ASSERT_EQ(GreatestCommonDivisor(0,5),0, 'GCD errors')
  ASSERT_EQ(GreatestCommonDivisor(5,0),0, 'GCD errors')

  ASSERT_EQ(GreatestCommonDivisor(2,3),1, 'GCD 2,3')
  ASSERT_EQ(GreatestCommonDivisor(3,2),1, 'GCD 3,2')  ! ensure both directions give same answer
  ASSERT_EQ(GreatestCommonDivisor(201,3),3, 'GCD 201,3')
  ASSERT_EQ(GreatestCommonDivisor(33,198),33, 'GCD 33,198')
  ASSERT_EQ(GreatestCommonDivisor(6248,3784),88, 'GCD 6248,3784')
ENDSUBROUTINE testGCD
!
!-------------------------------------------------------------------------------
SUBROUTINE testLCM()
  ASSERT_EQ(LeastCommonMultiple(-1,5),5, 'LCM')
  ASSERT_EQ(LeastCommonMultiple(5,-5),5, 'LCM')
  ASSERT_EQ(LeastCommonMultiple(-1,-5),5, 'LCM')
  ASSERT_EQ(LeastCommonMultiple(0,5),0, 'LCM')
  ASSERT_EQ(LeastCommonMultiple(5,0),0, 'LCM')

  ASSERT_EQ(LeastCommonMultiple(2,3),6, 'LCM')
  ASSERT_EQ(LeastCommonMultiple(3,2),6, 'LCM')
  ASSERT_EQ(LeastCommonMultiple(201,3),201, 'LCM')
  ASSERT_EQ(LeastCommonMultiple(33,198),198, 'LCM')
  ASSERT_EQ(LeastCommonMultiple(8,12),24, 'LCM')
  ASSERT_EQ(LeastCommonMultiple(36,8),72, 'LCM')

  ASSERT_EQ(LeastCommonMultiple((/8,12,36/)),72,"LCM array")
  ASSERT_EQ(LeastCommonMultiple((/3,25,28/)),2100,"LCM array")
  ASSERT_EQ(LeastCommonMultiple((/12,15,75,10/)),300,"LCM array")
  ASSERT_EQ(LeastCommonMultiple((/100,1000,50,200,25/)),1000,"LCM array")
  ASSERT_EQ(LeastCommonMultiple((/100,1000,50,200,24/)),3000,"LCM array")
  ASSERT_EQ(LeastCommonMultiple((/198,150,24,205,87,200,154/)),164795400,"LCM array")
ENDSUBROUTINE testLCM
!
!-------------------------------------------------------------------------------
SUBROUTINE testATAN2PI()
  ASSERT_APPROXEQ(ATAN2PI(0.0_SRK,0.0_SRK) , 0.0_SRK,'(0,0)')

  ASSERT_APPROXEQ(ATAN2PI(1.0_SRK,0.0_SRK) , 0.0_SRK,'(1,0)')
  ASSERT_APPROXEQ(ATAN2PI(0.0_SRK,1.0_SRK) , PI*0.5_SRK,'(0,1)')
  ASSERT_APPROXEQ(ATAN2PI(-1.0_SRK,0.0_SRK) , PI,'(-1,0)')
  ASSERT_APPROXEQ(ATAN2PI(0.0_SRK,-1.0_SRK) , PI*1.5_SRK,'(0,-1)')
  ASSERT_APPROXEQ(ATAN2PI(1.0_SRK,1.0_SRK) , PI*0.25_SRK,'(1,1)')
  ASSERT_APPROXEQ(ATAN2PI(-1.0_SRK,1.0_SRK) , PI*0.75_SRK,'(-1,1)')
  ASSERT_APPROXEQ(ATAN2PI(-1.0_SRK,-1.0_SRK) , PI*1.25_SRK,'(-1,-1)')
  ASSERT_APPROXEQ(ATAN2PI(1.0_SRK,-1.0_SRK) , PI*1.75_SRK,'(1,-1)')

  ASSERT_APPROXEQ(ATAN2PI(1.0_SRK,-EPSREAL) , 0.0_SRK,'(1.0,-EPS)')
  ASSERT_APPROXEQ(ATAN2PI(1.0_SRK,EPSREAL) , 0.0_SRK,'(1.0,+EPS)')
  ASSERT_APPROXEQ(ATAN2PI(-EPSREAL,1.0_SRK) , PI*0.5_SRK,'(-EPS,1.0)')
  ASSERT_APPROXEQ(ATAN2PI(EPSREAL,1.0_SRK) , PI*0.5_SRK,'(+EPS,1.0)')
  ASSERT_APPROXEQ(ATAN2PI(EPSREAL,EPSREAL) , 0.0_SRK,'(+EPS,+EPS)')
  ASSERT_APPROXEQ(ATAN2PI(-EPSREAL,EPSREAL) , 0.0_SRK,'(-EPS,+EPS)')
  ASSERT_APPROXEQ(ATAN2PI(EPSREAL,-EPSREAL) , 0.0_SRK,'(+EPS,-EPS)')
  ASSERT_APPROXEQ(ATAN2PI(-EPSREAL,-EPSREAL) , 0.0_SRK,'(-EPS,-EPS)')
ENDSUBROUTINE testATAN2PI
!
!-------------------------------------------------------------------------------
FUNCTION oldATAN2PI(x,y) RESULT(theta)
  REAL(SRK),INTENT(IN) :: x,y
  REAL(SRK) :: theta
  theta=atan2(y,x)
  IF(theta < 0) theta=2.0_SRK*PI+theta
ENDFUNCTION oldATAN2PI
!
ENDPROGRAM testExtendedMath


! Evalute C_p (thermal conductivity as function of temperature based on correlation
! C_p units - cal/(mol*K) , 1 cal = 4.184 J

! Correlation is of the form C_p(T) = a + b*T where a, b are constants
! Currently using FliNaK correlation from Rogers (1982)
! Valid between 748 - 863 K
! Input:
!       T - temperature to evaluate density at in Kelvin
! Output:
!       C_p - evaluated conductivity at T
!
subroutine cond_corr(T, C_p)

    USE global_parameters_M

    implicit none

!---Dummy
    real(dp), intent(in)  :: T
    real(dp), intent(out) :: C_p

!---Local
    real(dp) :: a
    real(dp) :: b

    a = 9.636_dp
    b = 10.487_dp
    C_p = a + b*T

end


	REAL FUNCTION TCUM(T,RDF)
C
C-Description-----------------------------------------------------------
	IMPLICIT NONE
C
C  Function:
C	Calculate the probability that a t statistic with RDF degrees
C	of freedom is <= T.
C  Arguments:
C	T	(Real)
C		T STATISTIC
C	RDF	(Real)
C		DEGREES OF FREEDOM
C  Notes:
C    .	Reference:
C	"Student's t-Distribution", _Collected Algorithms
C	from CACM_, vol II, Algorithm 344, 1980.
C
C-Declarations----------------------------------------------------------
C
C
C  Arguments
C
      REAL T,RDF
C
C  Locals
C
	INTEGER DF1,DF2,DF
	REAL TCUM1,TCUM2,TCUMFCN
C
C-Code------------------------------------------------------------------
C
C    If degrees of freedom is less than 10 then do the calculation in
C    two steps.
C
	IF (RDF.LT.10) THEN
	    DF1=INT(RDF)
	    DF2=DF1+1
	    TCUM1=TCUMFCN(T,DF1)
	    TCUM2=TCUMFCN(T,DF2)
	    TCUM=TCUM1*(DF2-RDF) + TCUM2*(RDF-DF1)
	ELSE
C
C    If degrees of freedom >=10 then do the calculation directly.
C
	    DF=NINT(RDF)
	    TCUM=TCUMFCN(T,DF)
	END IF

	RETURN
	END


      SUBROUTINE FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK,
     $                   CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve the least-squares filtering problem recursively in time.
C     Each subroutine call implements one time update of the solution.
C     The algorithm uses a fast QR-decomposition based approach.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JP      CHARACTER*1
C             Indicates whether the user wishes to apply both prediction
C             and filtering parts, as follows:
C             = 'B':  Both prediction and filtering parts are to be
C                     applied;
C             = 'P':  Only the prediction section is to be applied.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The length of the impulse response of the equivalent
C             transversal filter model.  L >= 1.
C
C     LAMBDA  (input) DOUBLE PRECISION
C             Square root of the forgetting factor.
C             For tracking capabilities and exponentially stable error
C             propagation, LAMBDA < 1.0 (strict inequality) should
C             be used.  0.0 < LAMBDA <= 1.0.
C
C     XIN     (input) DOUBLE PRECISION
C             The input sample at instant n.
C             (The situation just before and just after the call of
C             the routine are denoted by instant (n-1) and instant n,
C             respectively.)
C
C     YIN     (input) DOUBLE PRECISION
C             If JP = 'B', then YIN must contain the reference sample
C             at instant n.
C             Otherwise, YIN is not referenced.
C
C     EFOR    (input/output) DOUBLE PRECISION
C             On entry, this parameter must contain the square root of
C             exponentially weighted forward prediction error energy
C             at instant (n-1).  EFOR >= 0.0.
C             On exit, this parameter contains the square root of the
C             exponentially weighted forward prediction error energy
C             at instant n.
C
C     XF      (input/output) DOUBLE PRECISION array, dimension (L)
C             On entry, this array must contain the transformed forward
C             prediction variables at instant (n-1).
C             On exit, this array contains the transformed forward
C             prediction variables at instant n.
C
C     EPSBCK  (input/output) DOUBLE PRECISION array, dimension (L+1)
C             On entry, the leading L elements of this array must
C             contain the normalized a posteriori backward prediction
C             error residuals of orders zero through L-1, respectively,
C             at instant (n-1), and EPSBCK(L+1) must contain the
C             square-root of the so-called "conversion factor" at
C             instant (n-1).
C             On exit, this array contains the normalized a posteriori
C             backward prediction error residuals, plus the square root
C             of the conversion factor at instant n.
C
C     CTETA   (input/output) DOUBLE PRECISION array, dimension (L)
C             On entry, this array must contain the cosines of the
C             rotation angles used in time updates, at instant (n-1).
C             On exit, this array contains the cosines of the rotation
C             angles at instant n.
C
C     STETA   (input/output) DOUBLE PRECISION array, dimension (L)
C             On entry, this array must contain the sines of the
C             rotation angles used in time updates, at instant (n-1).
C             On exit, this array contains the sines of the rotation
C             angles at instant n.
C
C     YQ      (input/output) DOUBLE PRECISION array, dimension (L)
C             On entry, if JP = 'B', then this array must contain the
C             orthogonally transformed reference vector at instant
C             (n-1). These elements are also the tap multipliers of an
C             equivalent normalized lattice least-squares filter.
C             Otherwise, YQ is not referenced and can be supplied as
C             a dummy array (i.e., declare this array to be YQ(1) in
C             the calling program).
C             On exit, if JP = 'B', then this array contains the
C             orthogonally transformed reference vector at instant n.
C
C     EPOS    (output) DOUBLE PRECISION
C             The a posteriori forward prediction error residual.
C
C     EOUT    (output) DOUBLE PRECISION
C             If JP = 'B', then EOUT contains the a posteriori output
C             error residual from the least-squares filter at instant n.
C
C     SALPH   (output) DOUBLE PRECISION array, dimension (L)
C             The element SALPH(i), i=1,...,L, contains the opposite of
C             the i-(th) reflection coefficient for the least-squares
C             normalized lattice predictor (whose value is -SALPH(i)).
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  an element to be annihilated by a rotation is less
C                   than the machine precision (see LAPACK Library
C                   routine DLAMCH).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The output error EOUT at instant n, denoted by EOUT(n), is the
C     reference sample minus a linear combination of L successive input
C     samples:
C
C                           L-1
C        EOUT(n) = YIN(n) - SUM h_i * XIN(n-i),
C                           i=0
C
C     where YIN(n) and XIN(n) are the scalar samples at instant n.
C     A least-squares filter uses those h_0,...,h_{L-1} which minimize
C     an exponentially weighted sum of successive output errors squared:
C
C         n
C        SUM [LAMBDA**(2(n-k)) * EOUT(k)**2].
C        k=1
C
C     Each subroutine call performs a time update of the least-squares
C     filter using a fast least-squares algorithm derived from a
C     QR decomposition, as described in references [1] and [2] (the
C     notation from [2] is followed in the naming of the arrays).
C     The algorithm does not compute the parameters h_0,...,h_{L-1} from
C     the above formula, but instead furnishes the parameters of an
C     equivalent normalized least-squares lattice filter, which are
C     available from the arrays SALPH (reflection coefficients) and YQ
C     (tap multipliers), as well as the exponentially weighted input
C     signal energy
C
C         n                                              L
C        SUM [LAMBDA**(2(n-k)) * XIN(k)**2] = EFOR**2 + SUM XF(i)**2.
C        k=1                                            i=1
C
C     For more details on reflection coefficients and tap multipliers,
C     references [2] and [4] are recommended.
C
C     REFERENCES
C
C     [1]  Proudler, I. K., McWhirter, J. G., and Shepherd, T. J.
C          Fast QRD based algorithms for least-squares linear
C          prediction.
C          Proceedings IMA Conf. Mathematics in Signal Processing
C          Warwick, UK, December 1988.
C
C     [2]  Regalia, P. A., and Bellanger, M. G.
C          On the duality between QR methods and lattice methods in
C          least-squares adaptive filtering.
C          IEEE Trans. Signal Processing, SP-39, pp. 879-891,
C          April 1991.
C
C     [3]  Regalia, P. A.
C          Numerical stability properties of a QR-based fast
C          least-squares algorithm.
C          IEEE Trans. Signal Processing, SP-41, June 1993.
C
C     [4]  Lev-Ari, H., Kailath, T., and Cioffi, J.
C          Least-squares adaptive lattice and transversal filters:
C          A unified geometric theory.
C          IEEE Trans. Information Theory, IT-30, pp. 222-236,
C          March 1984.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O(L) operations for each subroutine call.
C     It is backward consistent for all input sequences XIN, and
C     backward stable for persistently exciting input sequences,
C     assuming LAMBDA < 1.0 (see [3]).
C     If the condition of the signal is very poor (IWARN = 1), then the
C     results are not guaranteed to be reliable.
C
C     FURTHER COMMENTS
C
C     1.  For tracking capabilities and exponentially stable error
C         propagation, LAMBDA < 1.0 should be used.  LAMBDA is typically
C         chosen slightly less than 1.0 so that "past" data are
C         exponentially forgotten.
C     2.  Prior to the first subroutine call, the variables must be
C         initialized. The following initial values are recommended:
C
C         XF(i) = 0.0,        i=1,...,L
C         EPSBCK(i) = 0.0     i=1,...,L
C         EPSBCK(L+1) = 1.0
C         CTETA(i) = 1.0      i=1,...,L
C         STETA(i) = 0.0      i=1,...,L
C         YQ(i) = 0.0         i=1,...,L
C
C         EFOR = 0.0          (exact start)
C         EFOR = "small positive constant" (soft start).
C
C         Soft starts are numerically more reliable, but result in a
C         biased least-squares solution during the first few iterations.
C         This bias decays exponentially fast provided LAMBDA < 1.0.
C         If sigma is the standard deviation of the input sequence
C         XIN, then initializing EFOR = sigma*1.0E-02 usually works
C         well.
C
C     CONTRIBUTOR
C
C     P. A. Regalia (October 1994).
C     Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Kalman filtering, least-squares estimator, optimal filtering,
C     orthogonal transformation, recursive estimation, QR decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JP
      INTEGER           INFO, IWARN, L
      DOUBLE PRECISION  EFOR, EOUT, EPOS, LAMBDA, XIN, YIN
C     .. Array Arguments ..
      DOUBLE PRECISION  CTETA(*), EPSBCK(*), SALPH(*), STETA(*), XF(*),
     $                  YQ(*)
C     .. Local Scalars ..
      LOGICAL           BOTH
      INTEGER           I
      DOUBLE PRECISION  CTEMP, EPS, FNODE, NORM, TEMP, XFI, YQI
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLAPY2, DNRM2
      EXTERNAL          DLAMCH, DLAPY2, DNRM2, LSAME
C     .. External Subroutines ..
      EXTERNAL          DLARTG, XERBLA
C     .. Intrinsic Functions
      INTRINSIC         ABS, SQRT
C     .. Executable statements ..
C
C     Test the input scalar arguments.
C
      BOTH  = LSAME( JP, 'B' )
      IWARN = 0
      INFO  = 0
C
      IF( .NOT.BOTH .AND. .NOT.LSAME( JP, 'P' ) ) THEN
         INFO = -1
      ELSE IF( L.LT.1 ) THEN
         INFO = -2
      ELSE IF( ( LAMBDA.LE.ZERO ) .OR. ( LAMBDA.GT.ONE  ) ) THEN
         INFO = -3
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'FD01AD', -INFO )
         RETURN
      END IF
C
C     Computation of the machine precision EPS.
C
      EPS = DLAMCH( 'Epsilon' )
C
C     Forward prediction rotations.
C
      FNODE = XIN
C
      DO 10  I = 1, L
         XFI   = XF(I) * LAMBDA
         XF(I) = STETA(I) * FNODE + CTETA(I) * XFI
         FNODE = CTETA(I) * FNODE - STETA(I) * XFI
   10 CONTINUE
C
      EPOS = FNODE * EPSBCK(L+1)
C
C     Update the square root of the prediction energy.
C
      EFOR = EFOR * LAMBDA
      TEMP = DLAPY2( FNODE, EFOR )
      IF ( TEMP.LT.EPS ) THEN
         FNODE = ZERO
         IWARN = 1
      ELSE
         FNODE = FNODE * EPSBCK(L+1)/TEMP
      END IF
      EFOR = TEMP
C
C     Calculate the reflection coefficients and the backward prediction
C     errors.
C
      DO 20 I = L, 1, -1
         IF ( ABS( XF(I) ).LT.EPS )
     $      IWARN = 1
         CALL DLARTG( TEMP, XF(I), CTEMP, SALPH(I), NORM )
         EPSBCK(I+1) = CTEMP * EPSBCK(I) - SALPH(I) * FNODE
         FNODE = CTEMP * FNODE + SALPH(I) * EPSBCK(I)
         TEMP  = NORM
   20 CONTINUE
C
      EPSBCK(1) = FNODE
C
C     Update to new rotation angles.
C
      NORM = DNRM2( L, EPSBCK, 1 )
      TEMP = SQRT( ( ONE + NORM )*( ONE - NORM ) )
      EPSBCK(L+1) = TEMP
C
      DO 30 I = L, 1, -1
         IF ( ABS( EPSBCK(I) ).LT.EPS )
     $      IWARN = 1
         CALL DLARTG( TEMP, EPSBCK(I), CTETA(I), STETA(I), NORM )
         TEMP = NORM
   30 CONTINUE
C
C     Joint process section.
C
      IF ( BOTH) THEN
         FNODE = YIN
C
         DO 40  I = 1, L
            YQI   = YQ(I) * LAMBDA
            YQ(I) = STETA(I) * FNODE + CTETA(I) * YQI
            FNODE = CTETA(I) * FNODE - STETA(I) * YQI
   40    CONTINUE
C
         EOUT = FNODE * EPSBCK(L+1)
      END IF
C
      RETURN
C *** Last line of FD01AD ***
      END


      PROGRAM xcholsl
C     driver for routine cholsl
      INTEGER N
      PARAMETER (N=3)
      INTEGER i,j,k
      REAL sum,a(N,N),aorig(N,N),atest(N,N),chol(N,N),p(N),b(N),x(N)
      DATA a/100.,15.,.01,15.,2.3,.01,.01,.01,1./
      DATA b/.4,.02,99./
      do 12 i=1,N
        do 11 j=1,N
          aorig(i,j)=a(i,j)
11      continue
12    continue
      call choldc(a,N,N,p)
      do 14 i=1,N
        do 13 j=1,N
          if (i.gt.j) then
            chol(i,j)=a(i,j)
          else if (i.eq.j) then
            chol(i,j)=p(i)
          else
            chol(i,j)=0.
          endif
13      continue
14    continue
      do 17 i=1,N
        do 16 j=1,N
          sum=0.
          do 15 k=1,N
            sum=sum+chol(i,k)*chol(j,k)
15        continue
          atest(i,j)=sum
16      continue
17    continue
      write(*,*) 'Original matrix:'
      write(*,100) ((aorig(i,j),j=1,N),i=1,N)
      write(*,*)
      write(*,*) 'Product of Cholesky factors:'
      write(*,100) ((atest(i,j),j=1,N),i=1,N)
100   format(1p3e16.6)
      write(*,*)
      call cholsl(a,N,N,p,b,x)
      do 19 i=1,N
        sum=0.
        do 18 j=1,N
          sum=sum+aorig(i,j)*x(j)
18      continue
        p(i)=sum
19    continue
      write(*,*) 'Check solution vector:'
      write(*,101) (p(i),b(i),i=1,N)
101   format(1p2e16.6)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xcholsl.for


!
! Copyright (C) 2001-2010 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-----------------------------------------------------------------------
SUBROUTINE rgen ( dtau, rmax, mxr, at, bg, r, r2, nrm)
  !-----------------------------------------------------------------------
  !
  !   generates neighbours shells (cartesian, in units of lattice parameter)
  !   with length < rmax,and returns them in order of increasing length:
  !      r(:) = i*a1(:) + j*a2(:) + k*a3(:) - dtau(:),   r2 = r^2
  !   where a1, a2, a3 are primitive lattice vectors. Other input variables:
  !     mxr = maximum number of vectors
  !     at  = lattice vectors ( a1=at(:,1), a2=at(:,2), a3=at(:,3) )
  !     bg  = reciprocal lattice vectors ( b1=bg(:,1), b2=bg(:,2), b3=bg(:,3) )
  !   Other output variables:
  !     nrm = the number of vectors with r^2 < rmax^2
  !
  USE kinds, ONLY : DP
  !
  IMPLICIT NONE
  INTEGER, INTENT(in) :: mxr
  INTEGER, INTENT(out):: nrm
  REAL(DP), INTENT(in) :: at(3,3), bg(3,3), dtau(3), rmax
  REAL(DP), INTENT(out):: r(3,mxr), r2(mxr)
  !
  !    and here the local variables
  !
  INTEGER, ALLOCATABLE :: irr (:)
  INTEGER ::  nm1, nm2, nm3, i, j, k, ipol, ir, indsw, iswap
  real(DP) :: ds(3), dtau0(3)
  real(DP) :: t (3), tt, swap
  real(DP), EXTERNAL :: dnrm2
  !
  !
  nrm = 0
  IF (rmax==0.d0) RETURN

  ! bring dtau into the unit cell centered on the origin - prevents trouble
  ! if atomic positions are not centered around the origin but displaced
  ! far away (remember that translational invariance allows this!)
  !
  ds(:) = matmul( dtau(:), bg(:,:) )
  ds(:) = ds(:) - anint(ds(:))
  dtau0(:) = matmul( at(:,:), ds(:) )
  !
  ALLOCATE (irr( mxr))
  !
  ! these are estimates of the maximum values of needed integer indices
  !
  nm1 = int (dnrm2 (3, bg (1, 1), 1) * rmax) + 2
  nm2 = int (dnrm2 (3, bg (1, 2), 1) * rmax) + 2
  nm3 = int (dnrm2 (3, bg (1, 3), 1) * rmax) + 2
  !
  DO i = -nm1, nm1
     DO j = -nm2, nm2
        DO k = -nm3, nm3
           tt = 0.d0
           DO ipol = 1, 3
              t (ipol) = i*at (ipol, 1) + j*at (ipol, 2) + k*at (ipol, 3) &
                       - dtau0(ipol)
              tt = tt + t (ipol) * t (ipol)
           ENDDO
           IF (tt<=rmax**2.and.abs (tt) >1.d-10) THEN
              nrm = nrm + 1
              IF (nrm>mxr) CALL errore ('rgen', 'too many r-vectors', nrm)
              DO ipol = 1, 3
                 r (ipol, nrm) = t (ipol)
              ENDDO
              r2 (nrm) = tt
           ENDIF
        ENDDO
     ENDDO
  ENDDO
  !
  !   reorder the vectors in order of increasing magnitude
  !
  !   initialize the index inside sorting routine
  !
  irr (1) = 0
  IF (nrm>1) CALL hpsort (nrm, r2, irr)
  DO ir = 1, nrm - 1
20   indsw = irr (ir)
     IF (indsw/=ir) THEN
        DO ipol = 1, 3
           swap = r (ipol, indsw)
           r (ipol, indsw) = r (ipol, irr (indsw) )
           r (ipol, irr (indsw) ) = swap
        ENDDO
        iswap = irr (ir)
        irr (ir) = irr (indsw)
        irr (indsw) = iswap
        GOTO 20
     ENDIF

  ENDDO
  DEALLOCATE(irr)
  !
  RETURN
END SUBROUTINE rgen


      implicit double precision (a-h,o-z)
      complex*8 ylm
      character*1 aal,aam
      common /alegp/ alp(0:100,-100:100)
      common /factl/ fact(0:100)
      dimension ylm(0:100,0:100)
      pi=4.0d0*datan(1.0d0)
      read(*,*)lmax
      call factorial(2*lmax)
      ifno=0
      do l=0,lmax
        write(aal,'(i1)')l
        do m=0,l
          write(aam,'(i1)')m
          ifno=ifno+1
          open(ifno,file='y'//aal//aam//'r.out',status='unknown')
          ifno=ifno+1
          open(ifno,file='y'//aal//aam//'i.out',status='unknown')
        end do
      end do
      theta=0.d0
      ainc=pi/10.d0
      do while (theta.le.pi)
        x=dcos(theta)
        call alegendrep(lmax,x)
        phi=0.d0
        do while (phi.le.2.0*pi)
          xx=dsin(theta)*dcos(phi)
          yy=dsin(theta)*dsin(phi)
          ifno=0
          do l=0,lmax
            do m=0,l
              fac=dsqrt((2*l+1)*fact(l-m)/(4.0d0*pi*fact(l+m)))
              ylm(l,m)=fac*alp(l,m)*dcmplx(dcos(m*phi),dsin(m*phi))
              ifno=ifno+1
              rr=dreal(ylm(l,m))
              write(ifno,'(1x,3f12.6)') rr*xx,rr*yy,rr*dcos(theta)
              ifno=ifno+1
              rr=imag(ylm(l,m))
              write(ifno,'(1x,3f12.6)') rr*xx,rr*yy,rr*dcos(theta)
            end do
          end do
          phi=phi+ainc
        end do
        theta=theta+ainc
      end do

      end

c Calculates assosicated Legendre polynomials upto lmax for a given x
c -1 < x < 1; Condon-Shortley phase is included
c i/p lmax, x
c o/p alp(0:lmax,-lmax:lmax)
      subroutine alegendrep(lmax,x)
      implicit real*8 (a-h,o-z)
      common /alegp/ alp(0:100,-100:100)
      common /factl/ fact(0:100)
      alp(0,0)=1.0d0
      do l=1,lmax
        alp(l,l-1)=x*(2.0d0*(l-1.0d0)+1.0d0)*alp(l-1,l-1)
        alp(l,-l+1)=(-1)**(l-1)*alp(l,l-1)/fact(l+l-1)  !m=l-1
        alp(l,l)=-(2.0d0*(l-1.0d0)+1.0d0)*dsqrt(1.d0-x*x)*alp(l-1,l-1)
        alp(l,-l)=(-1)**l*alp(l,l)/fact(l+l)
        do m=l-2,1,-1
          alp(l,m)=(x*(2*l-1)*alp(l-1,m)-(l+m-1)*alp(l-2,m))/dfloat(l-m)
          alp(l,-m)=(-1)**m*fact(l-m)*alp(l,m)/fact(l+m)
        end do
        alp(l,0)=(x*(2*l-1)*alp(l-1,0)-(l-1)*alp(l-2,0))/dfloat(l)
      end do
      end

c Calculates and stores 0!,1!,2!,...,n!
c i/p n
c o/p fact(0:n)
      subroutine factorial(n)
      implicit double precision (a-h,o-z)
      common /factl/ fact(0:100)
      fact(0)=1
      do i=1,n
        fact(i)=fact(i-1)*i
      end do
      end


***********************************************************************
*	                    COORD_VH2VJ.F
***********************************************************************
*     PURPOSE: Converts from Heliocentric to Jacobi coords. VELOCITIES ONLY.
*     ARGUMENTS:  Input is
*                    nbod ==> number of  objects (must be less than NBMAX)
*                             (integer)
*	             mass(*) ==> planetary masses (real array)
*		     vxh(*),vyh(*),vzh(*) ==>barycentric particle velocities
*                                             (real array)
*                 Returned are
*                    vxj(*),vyj(*),vzj(*) ==> jacobi. particle velocities
*                                              (real array)
*
*     ALGORITHM: See my notes Nov 21/92
*     REMARKS:
*
*     AUTHOR:  M. Duncan.
*     DATE WRITTEN:  Jan 29, 1993.
*     REVISIONS:  2/17/93 HFL

	subroutine coord_vh2vj(nbod,mass,vxh,vyh,vzh,vxj,vyj,vzj)

      include '../swift.inc'

c...  Inputs:
	integer nbod
	real*8 mass(NPLMAX)
	real*8 vxh(NPLMAX),vyh(NPLMAX),vzh(NPLMAX)

c...  Outputs:
	real*8 vxj(NPLMAX),vyj(NPLMAX),vzj(NPLMAX)

c...  Internals:
	real*8 eta(NPLMAX)
	real*8 sumvx,sumvy,sumvz
	real*8 capvx,capvy,capvz
	integer n

c----
c...  Executable code

c First calc. the array eta(*) then convert to jacobi velocities

	eta(1) = mass(1)
	do n = 2,nbod
	  eta(n) = eta(n-1) + mass(n)
	enddo

	vxj(1) =0.d0
	vyj(1) =0.d0
	vzj(1) =0.d0

	vxj(2) = vxh(2)
	vyj(2) = vyh(2)
	vzj(2) = vzh(2)

	sumvx = mass(2)*vxh(2)
	sumvy = mass(2)*vyh(2)
	sumvz = mass(2)*vzh(2)

	capvx = sumvx/eta(2)
	capvy = sumvy/eta(2)
	capvz = sumvz/eta(2)

	do n=3,nbod
	  vxj(n) = vxh(n) - capvx
	  vyj(n) = vyh(n) - capvy
	  vzj(n) = vzh(n) - capvz

	  if(n.lt.nbod) then
             sumvx = sumvx + mass(n)*vxh(n)
             sumvy = sumvy + mass(n)*vyh(n)
             sumvz = sumvz + mass(n)*vzh(n)

             capvx =sumvx/eta(n)
             capvy =sumvy/eta(n)
             capvz =sumvz/eta(n)
          endif

	enddo

123	return
	end    ! coord_vh2vj
c--------------------------------------------------------------------------


      INTEGER N,m
      PARAMETER(N=4,m=100000) ! N = Number od differential equation, m = Number of divisions between x1 and x2
      INTEGER:: i
!	  complex::al,be

	  REAL h,x,y(N),dydx(N),yout(N)
      EXTERNAL derivs
      open(10,file='e:\1\JC_Model_Psi.txt')  ! Output program results
      ! -------------- initial conditons --------------
      x1=0.0                      ! x1 = t1
	  x2=30                       ! x2 = t2
      y(1)=1/sqrt(2.)             ! real part of c1(t):= y(1) + iy(2)
      y(2)=0                      ! complex part of c1(t):= y(1) + iy(2)
      y(3)=1/sqrt(2.)             ! real part of c2(t):= y(3) + iy(4)
      y(4)=0                      ! complex part of c2(t):= y(3) + iy(4)

	   x=x1
	   h=(x2-x1)/m                        ! Number of divisions
       do i=0,m-1
	      x=x1+i*h
          call derivs(x,y,dydx)
          call rk4(y,dydx,N,x,h,yout,derivs)
              x=x1+i*h
              A=y(1)*y(1)+y(2)*y(2)       ! |c1(t)|^2
              B=y(3)*y(3)+y(4)*y(4)       ! |c2(t)|^2
              rho_a_2_11 = A * A
              rho_a_2_22 = B * B
              tr_r_2  = rho_a_2_11 + rho_a_2_22 ! trace (rho_a) ^ 2
              U = A * A
              O = B * B
              S= -((B*LOG(B)/LOG(2.))+(A*LOG(A)/LOG(2.)))   ! Von Neumann entropy
              G= 2*(1-U-O)                ! G = L (Linear entropy)
              C = SQRT(G) !Concurence
          if (mod(i,10)==0) then
              write(10,'(22(f10.4,2x))')x,y(1),y(2),y(3),y(4),tr_r_2,S,G   ! Computational values to create in the file a.txt
          end if
	      do j=1,n
	        y(j)=yout(j) !/sqrt((r11+r22))
	     end do
      end do

      END

      SUBROUTINE derivs(x,y,dydx)

      REAL x,y(N),dydx(N)

      ! ------------------- State --------------------

      ! psi(t) = c1(t)|e,n> + c2(t)|g,n+1>

      ! --------------- initial values ---------------

	  wa=1      ! atomic frequency
	  wp=0.6      ! field frequency
	  g=0.6    ! coupling strength
      n = 1     ! number of photons

      ! ----------------- Equations ------------------

      A = n*wp+(wa/2)
      B = (1+n)*wp-(wa/2)
      X = n+1
      C = SQRT(X)
      ! print*, A

      ! ----------- Differential equations -----------

      dydx(1)=  A*y(2)+g*C*y(4)
      dydx(2)= -A*y(1)-g*C*y(3)
      dydx(3)=  B*y(4)+g*C*y(2)
      dydx(4)= -B*y(3)-g*C*y(1)

      return

      end

      ! ------------ Runge-Kutta Function ------------

      SUBROUTINE rk4(y,dydx,n,x,h,yout,derivs)
      INTEGER n,NMAX
      REAL h,x,dydx(n),y(n),yout(n)
      EXTERNAL derivs
      PARAMETER (NMAX=50)
      INTEGER i
      REAL h6,hh,xh,dym(NMAX),dyt(NMAX),yt(NMAX)
      hh=h*0.5
      h6=h/6.
	  x=0
      xh=x+hh
      do 11 i=1,n
        yt(i)=y(i)+hh*dydx(i)
11    continue
      call derivs(xh,yt,dyt)
      do 12 i=1,n
        yt(i)=y(i)+hh*dyt(i)
12    continue
      call derivs(xh,yt,dym)
      do 13 i=1,n
        yt(i)=y(i)+h*dym(i)
        dym(i)=dyt(i)+dym(i)
13    continue
      call derivs(x+h,yt,dyt)
      do 14 i=1,n
        yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i))

14    continue
      return
      END


Program PoissonMultigrid
Use MultiGrid, only : AddFourierMode
Use IO,        only : Textual_Output
Use MultiGrid, only : Restrict_1D, Prolongate_1D

Implicit None

Real, parameter :: w = (2.0/3.0)

Integer, parameter :: N      =  64
Integer, parameter :: fd     =  12

Integer :: t, i, device
Integer :: nsteps = 5

Real, allocatable, dimension(:), codimension[*] :: V1h, V2h, V4h, V8h, V16h, Buf

device = get_subimage(0)

Allocate(V1h(-1:N+1)[*])
Allocate(Buf(-1:N+1)[*])
Allocate(V2h(-1:N/2+1)[*])
Allocate(V4h(-1:N/4+1)[*])
Allocate(V8h(-1:N/8+1)[*])
Allocate(V16h(-1:N/16+1)[*])

if (device /= THIS_IMAGE()) then
  Allocate(V1h(-1:N+1)[*])    [[device]]
  Allocate(Buf(-1:N+1)[*])    [[device]]
  Allocate(V2h(-1:N/2+1)[*])  [[device]]
  Allocate(V4h(-1:N/4+1)[*])  [[device]]
  Allocate(V8h(-1:N/8+1)[*])  [[device]]
  Allocate(V16h(-1:N/16+1)[*])[[device]]
end if

open(unit=fd, file="error_time.dat")

!! Initialize
!
V1h = 0.0
Call AddFourierMode(N, V1h,  1)
Call AddFourierMode(N, V1h,  6)
Call AddFourierMode(N, V1h, 16)
V1h = (1./3.)*V1h

V1h[device] = V1h

!... Relax solution on 1h mesh
!    -------------------------
call Textual_Output(N, V1h, "1h_0")
do t = 1, nsteps
   call Relax_1D(N, V1h[device], Buf[device])  [[device]]
   call Exchange_Halo_1D(device, N, V1h)
end do
V1h = V1h[device]
write(fd, *) t, maxval(V1h)
call Textual_Output(N, V1h, "1h_mid")

!... Relax solution on 2h mesh
!    -------------------------
call Restrict_1D(N, V1h[device], V2h[device])    [[device]]
call Textual_Output(N/2, V2h, "2h_0")
do t = 1, nsteps
   call Relax_1D(N/2, V2h[device], Buf[device])  [[device]]
   call Exchange_Halo_1D(device, N/2, V2h)
end do
V2h = V2h[device]
write(fd, *) t, maxval(V2h)
call Textual_Output(N/2, V2h, "2h_mid")

!... Relax solution on 4h mesh
!    -------------------------
call Restrict_1D(N/2, V2h[device], V4h[device])  [[device]]
call Textual_Output(N/4, V4h, "4h_0")
do t = 1, nsteps
   call Relax_1D(N/4, V4h[device], Buf[device])  [[device]]
   call Exchange_Halo_1D(device, N/4, V4h)
end do
V4h = V4h[device]
write(fd, *) t, maxval(V4h)
call Textual_Output(N/4, V4h, "4h_mid")

!... Relax solution on 8h mesh
!    -------------------------
call Restrict_1D(N/4, V4h[device], V8h[device])  [[device]]
call Textual_Output(N/8, V8h, "8h_0")
do t = 1, nsteps
   call Relax_1D(N/8, V8h[device], Buf[device])  [[device]]
   call Exchange_Halo_1D(device, N/8, V8h)
end do
V8h = V8h[device]
write(fd, *) t, maxval(V8h)
call Textual_Output(N/8, V8h, "8h_mid")

!! IMPORTANT: this last step should be an exact solution on a smaller grid probably
!
! exact solution is 0, so just set to 0.
V16h = 0

V16h[device] = V16h
call Prolongate_1D(N/8, V8h[device], V16h[device])  [[device]]
do t = 1, nsteps
   call Relax_1D(N/8, V8h[device], Buf[device])    [[device]]
   call Exchange_Halo_1D(device, N/8, V8h)
end do
V8h = V8h[device]
write(fd, *) t, maxval(V8h)
call Textual_Output(N/8, V8h, "8h_end")

call Prolongate_1D(N/4, V4h[device], V8h[device])  [[device]]
do t = 1, nsteps
   call Relax_1D(N/4, V4h[device], Buf[device])    [[device]]
   call Exchange_Halo_1D(device, N/4, V4h)
end do
V4h = V4h[device]
write(fd, *) t, maxval(V4h)
call Textual_Output(N/4, V4h, "4h_end")

call Prolongate_1D(N/2, V2h[device], V4h[device])  [[device]]
do t = 1, nsteps
   call Relax_1D(N/2, V2h[device], Buf[device])    [[device]]
   call Exchange_Halo_1D(device, N/2, V2h)
end do
V2h = V2h[device]
write(fd, *) t, maxval(V2h)
call Textual_Output(N/2, V2h, "2h_end")

call Prolongate_1D(N, V1h[device], V2h[device])  [[device]]
do t = 1, nsteps
   call Relax_1D(N, V1h[device], Buf[device])    [[device]]
   call Exchange_Halo_1D(device, N, V1h)
end do
V1h = V1h[device]
write(fd, *) t, maxval(V1h)
call Textual_Output(N, V1h, "1h_end")

close(fd)

End Program PoissonMultigrid


program problem61
  implicit none
  integer, dimension(6) :: numbers,polygonal
  logical               :: success

  success=.false.
  call search(1)
  print *, numbers, polygonal
  print *, sum(numbers)

contains

  recursive subroutine search(depth)
    use euler
    implicit none
    integer, intent(in) :: depth
    integer             :: i,start,fin

    if (depth>6 .and. (mod(numbers(6),100) == numbers(1)/100)) success=.true.

    if (depth==1) then
       start=1010
       fin=9999
    else
       start=mod(numbers(depth-1),100)*100+10
       fin=mod(numbers(depth-1),100)*100+99
    end if

    do i=start,fin
       if (success) return
       numbers(depth)=i
       if (is_triangular(i) .and. (.not. any(polygonal(1:depth)==3))) then
          polygonal(depth)=3
          call search(depth+1)
       else if (is_square(i) .and. (.not. any(polygonal(1:depth)==4))) then
          polygonal(depth)=4
          call search(depth+1)
       else if (is_pentagonal(i) .and. (.not. any(polygonal(1:depth)==5))) then
          polygonal(depth)=5
          call search(depth+1)
       else if (is_hexagonal(i) .and. (.not. any(polygonal(1:depth)==6))) then
          polygonal(depth)=6
          call search(depth+1)
       else if (is_heptagonal(i) .and. (.not. any(polygonal(1:depth)==7))) then
          polygonal(depth)=7
          call search(depth+1)
       else if (is_octagonal(i) .and. (.not. any(polygonal(1:depth)==8))) then
          polygonal(depth)=8
          call search(depth+1)
       end if
    end do

  end subroutine search

end program problem61


MODULE my_random
IMPLICIT NONE
SAVE
  INTEGER, PARAMETER :: A = 8121, B = 28411, C = 134456
  INTEGER :: rand_int
  REAL :: rand_real

END MODULE my_random

PROGRAM random_test
USE my_random
IMPLICIT NONE
  INTEGER :: i
  rand_int = 1
  DO i = 1, 10
    CALL rando
    WRITE(*, 100) rand_real
    100 FORMAT (F10.4)
  END DO
END PROGRAM random_test

SUBROUTINE rando
USE my_random
IMPLICIT NONE
  rand_int = MOD(A * rand_int + B, C)
  rand_real = REAL(rand_int) / REAL(C)

END SUBROUTINE rando


      real function getz(pval,nt,vr,cdf,zmin,zmax,ltail,ltpar,
     +                   utail,utpar)
c-----------------------------------------------------------------------
c
c           Back Transform Univariate Data from Normal Scores
c           *************************************************
c
c This subroutine backtransforms a standard normal deviate from a
c specified back transform table and option for the tails of the
c distribution.  Call once with "first" set to true then set to false
c unless one of the options for the tail changes.
c
c
c
c INPUT VARIABLES:
c
c   pval             probability value to use
c   nt               number of values in the back transform tbale
c   vr(nt)           original data values that were transformed
c   cdf(nt)          the corresponding transformed values
c   zmin,zmax        limits possibly used for linear or power model
c   ltail            option to handle values less than cdf(1)
c   ltpar            parameter required for option ltail
c   utail            option to handle values greater than cdf(nt)
c   utpar            parameter required for option utail
c
c
c
c-----------------------------------------------------------------------

      implicit integer (i-n)
      implicit double precision (a-h,o-z)

      parameter(EPSLON=1.0e-20)
      dimension vr(nt),cdf(nt)
      real*8      ltpar,utpar,lambda
      integer   ltail,utail
c
c Value in the lower tail?    1=linear, 2=power, (3 and 4 are invalid):
c
      if(pval.le.cdf(1)) then
                  getz = vr(1)
            if(ltail.eq.1) then
                  getz = powint(0.d0,cdf(1),zmin,vr(1),pval,1.0)
            else if(ltail.eq.2) then
                  cpow = 1.0 / ltpar
                  getz = powint(0.d0,cdf(1),zmin,vr(1),pval,cpow)
            endif
c
c Value in the upper tail?     1=linear, 2=power, 4=hyperbolic:
c
      else if(pval.ge.cdf(nt)) then
                  cdfhi  = cdf(nt)
                  getz   = vr(nt)
            if(utail.eq.1) then
                  getz   = powint(cdfhi,1.0,vr(nt),zmax,pval,1.0)
            else if(utail.eq.2) then
                  cpow   = 1.0 / utpar
                  getz   = powint(cdfhi,1.0,vr(nt),zmax,pval,cpow)
            else if(utail.eq.4) then
                  lambda = (vr(nt)**utpar)*(1.0-cdf(nt))
                  getz   = (lambda/(1.0-pval))**(1.0/utpar)
            endif
      else
c
c Value within the transformation table:
c
            call locate(cdf,nt,1,nt,pval,j)
            j    = max(min((nt-1),j),1)
            getz = powint(cdf(j),cdf(j+1),vr(j),vr(j+1),pval,1.0)
      endif
      if(getz.lt.zmin) getz = zmin
      if(getz.gt.zmax) getz = zmax
      return
      end


!-------------------------------------------------------------
! Gives the upper limit as determined by a sphere in a fixed
! position: R^2=x^2+y^2+(z-H)^2.
!-------------------------------------------------------------
  FUNCTION SphereBottom( Model, n, t ) RESULT(f)
    USE DefUtils
    IMPLICIT NONE

    TYPE(Model_t) :: Model
    INTEGER :: n
    REAL(KIND=dp) :: t,f
!-------------------------------------------------------------
    REAL(KIND=dp) :: x,y,z,R,Disc,H

    x = Model % Nodes % x(n)
    y = Model % Nodes % y(n)
    z = Model % Nodes % z(n)
    R = 3.0_dp

    R = ListGetCReal( Model % Simulation,'Sphere Radius')
    H = ListGetCReal( Model % Simulation,'Sphere Z')

    Disc = R**2 - x**2 - y**2
    IF( Disc < 0 ) THEN
      f = HUGE(f)
    ELSE
      f = H - SQRT(Disc)
!      PRINT *,'Contact:',x,y,z,H,f
    END IF

  END FUNCTION SphereBottom
!-------------------------------------------------------------


SUBROUTINE fill_missing_levs(nx,ny,nz,plevs,data,missval,method)

! Subroutine to fill in missing values in a 3D data array on
! pressure levels.  This routine assumes you have valid data
! on the top most and bottom most levels.

  IMPLICIT NONE
  INTEGER, INTENT(IN)                 :: nx
  INTEGER, INTENT(IN)                 :: ny
  INTEGER, INTENT(IN)                 :: nz
  REAL, INTENT(IN)                    :: plevs(75)  ! Press in Pa
  REAL, INTENT(INOUT)                 :: data(nx,ny,nz)
  REAL, INTENT(IN)                    :: missval
  INTEGER, INTENT(IN)                 :: method

  INTEGER, PARAMETER                  :: METHOD_LIN = 1
  INTEGER, PARAMETER                  :: METHOD_LOG = 2

  INTEGER                             :: k,kbot,ktop
  REAL                                :: weight_top, weight_bot
  LOGICAL                             :: goodlev(nz)

  goodlev(:) = .false.
  checklevs: DO k = 1,nz
    IF (MAXVAL(data(:,:,k)) .NE. missval) THEN
       goodlev(k) = .true.
    ENDIF
  ENDDO checklevs

  fixlevs: DO k = 1, nz
    IF (goodlev(k)) CYCLE fixlevs

    ! Else:

    ! Find first level below that is "good"
    find_kbot: DO kbot = k-1,1,-1
      IF (goodlev(kbot)) EXIT find_kbot
    ENDDO find_kbot

    ! Find first level above that is good
    find_ktop: DO ktop = k+1,nz
      IF (goodlev(ktop)) EXIT find_ktop
    ENDDO find_ktop

    ! Compute interp weights using plevs and method
    IF (method .EQ. METHOD_LIN) THEN
      ! Linear interp in Pressure
      weight_bot = (plevs(k)-plevs(ktop)) / &
                   (plevs(kbot)-plevs(ktop))
      weight_top = 1. - weight_bot
    ELSE IF (method .EQ. METHOD_LOG) THEN
      ! Linear in ln(P)
      weight_bot = ( ALOG(plevs(k)/plevs(ktop)) ) / &
                   ( ALOG(plevs(kbot)/plevs(ktop)) )
      weight_top = 1. - weight_bot
    ENDIF
    data(:,:,k) = weight_bot*data(:,:,kbot) + weight_top*data(:,:,ktop)
  ENDDO fixlevs
  RETURN
END SUBROUTINE fill_missing_levs


! File flaplace95_forall.f90
! Author: Ramon Crehuet
subroutine timestep(u,n,m,dx,dy,error)
implicit none
real (kind=8), dimension(0:n-1,0:m-1), intent(inout):: u

real (kind=8), intent(in) :: dx,dy
real (kind=8), intent(out) :: error
integer, intent(in) :: n,m
real (kind=8), dimension(0:n-1,0:m-1) :: diff
real (kind=8) :: dx2,dy2,dnr_inv
integer :: i,j

!f2py intent(in) :: dx,dy
!f2py intent(in,out) :: u
!f2py intent(out) :: error
!f2py intent(hide) :: n,m

dx2 = dx*dx
dy2 = dy*dy
dnr_inv = 0.5d0 / (dx2+dy2)

diff=u

forall (i=1:n-2,j=1:m-2)
    u(i,j) = ((u(i-1,j) + u(i+1,j))*dy2+(u(i,j-1) + u(i,j+1))*dx2)*dnr_inv
end forall

error=sqrt(sum((u-diff)**2))

end subroutine


!================================================================================
! CONSTRUCCION DE UNA CONFIGURACION INICIAL REGULAR EN CELDA BIDIMENSIONAL
! SIN TRASLAPES
! Autor: Martin Paredes Sosa
!================================================================================

Subroutine ConfigIni(N3)
  Use cte
  Implicit None
  Real :: xRan, yRan, xij, yij,  dist
  Real :: dBoxl
  Integer :: i, j, k ,l                             !CONTADOR
  Integer :: N2, N3
  Real, Dimension(:),Allocatable :: nX, nY, nZ         !GEN

  !CALCULANDO DIMENSIONES DE LA CAJA
  N2 =anint( N**(Dim) )
  BoxL = (1.0*N/Dens )**(Dim)
  N3 = N2**(1.0/Dim)
  Write(*,*) "LONGITUD DE LA CELDA:", BoxL
  Write(*,*) "TOTAL DE PARTICULAS EN LA CELDA COLOCADAS:", N3
  dBoxl = BoxL/N2

  Allocate( nX(N2), nY(N2), nZ(N2) , X(N3), Y(N3), z(N3) )

  !GENERANDO COORDENADAS PARA POSICIONES DE LAS PARTICULAS
  GEN: Do i=1, N2

     nx(i) = (-BoxL)/2.0 + dBoxL/2.0 + dBoxL*(i-1)
     ny(i) = (-BoxL)/2.0 + dBoxL/2.0 + dBoxL*(i-1)
     nz(i) = (-BoxL)/2.0 + dBoxL/2.0 + dBoxL*(i-1)
  End Do GEN

  !ESCRIBIENDO EN ARCHIVO
  Open (1, File = "ConIni.dat" )
  l = 0
  EscribirX: Do i = 1, N2

     EscribirY: Do j = 1, N2

        EscribirZ: Do k = 1, N2

           l = l + 1
           X(l) = nX(i)
           Y(l) = nY(j)
           Z(l) = nZ(k)

        End Do EscribirZ

     End Do EscribirY

  End Do EscribirX

  !Write(*,*) l !DEBUG

  Do i=1, N3
     Write(1,*) X(i), Y(i), Z(i)
  End Do

  Deallocate(nX, nY, nZ)

  Close(1)

End Subroutine ConfigIni


use std
use FEMDomainClass
implicit none

type(IO_) :: f
type(FEMDomain_) :: domain
type(Math_) :: math
character(:),allocatable :: line
real(real64) :: x, y, r ,theta,x_sum,y_sum,center(2),max_r,coord(2), ret
real(real64),allocatable :: r_data(:),theta_data(:),leafSurface(:,:),tx(:),tfx(:)
integer(int32) :: num_ptr, i,id,ids(5),id_n
character(:),allocatable :: filename

!filename = "oak.txt"
!filename = "LeafSurface.txt"
filename = "grape_leaf.txt"
call f%open(filename,"r")
! get brief info
num_ptr = 0

x_sum = 0.0d0
y_sum = 0.0d0

do
    line = f%readline()
    if(f%EOF) exit
    num_ptr = num_ptr+1
    ! read x-y
    read(line,*) x, y
    x_sum = x_sum + x
    y_sum = y_sum + y
enddo
call f%close()

center(1) = x_sum/dble(num_ptr)
center(2) = y_sum/dble(num_ptr)

r_data = zeros(num_ptr)
theta_data = zeros(num_ptr)
leafSurface = zeros(num_ptr,2)

! get detail
call f%open(filename,"r")
num_ptr=0
do
    line = f%readline()
    if(f%EOF) exit
    ! read x-y
    read(line,*) x, y

    coord(1) = x - center(1)
    coord(2) = y - center(2)
    r = sqrt( dot_product(coord,coord) )
    theta = angles( coord )

    num_ptr = num_ptr + 1
    leafSurface(num_ptr,1) = x
    leafSurface(num_ptr,2) = y

    r_data(num_ptr) = r
    theta_data(num_ptr) = theta
enddo
max_r = maxval(r_data)
r_data = r_data/max_r
call f%close()

call domain%create("Cylinder3D",x_num=10,y_num=10)
call domain%resize(x=2.0d0)
call domain%resize(y=2.0d0)
call domain%resize(z=0.010d0)

! ####################################
! test interpolate

!tx = [0.0d0, 1.0d0, 2.0d0, 3.0d0]
!tfx = [0.0d0, 2.0d0, 4.0d0, 8.0d0]
!ret = interpolate(x =tx,Fx=tfx,x_value = -0.50d0)
!print *, ret
!stop
! ####################################

! adjust shape
do i=1,domain%nn()
    x = domain%mesh%nodcoord(i,1)
    y = domain%mesh%nodcoord(i,2)
    r = sqrt(x**2 + y**2)
    coord(1:2) = domain%mesh%nodcoord(i,1:2)
    r = norm(coord)
    theta = angles(coord)
    ! find nearest theta
    r = r * interpolate(x=theta_data,Fx=r_data,x_value=theta)
    x = r*x
    y = r*y
    domain%mesh%nodcoord(i,1) = x
    domain%mesh%nodcoord(i,2) = y
enddo

! export data
call f%open("theta_r_relation.txt","w")
do i=1,size(r_data)
    call f%write(theta_data(i),r_data(i) )
enddo
call f%close()
call f%plot("theta_r_relation.txt","w l")
call f%plot(filename,"w l")

call domain%vtk("leaf")

end


subroutine Interv ( xt, lxt, x, left, mflag )

!*****************************************************************************80
!
!! INTERV brackets a real value in an ascending vector of values.
!
!  Discussion:
!
!    The XT array is a set of increasing values.  The goal of the routine
!    is to determine the largest index I so that
!
!      XT(I) < XT(LXT)  and  XT(I) <= X.
!
!    The routine is designed to be efficient in the common situation
!    that it is called repeatedly, with X taken from an increasing
!    or decreasing sequence.
!
!    This will happen when a piecewise polynomial is to be graphed.
!    The first guess for LEFT is therefore taken to be the value
!    returned at the previous call and stored in the local variable ILO.
!
!    A first check ascertains that ILO < LXT.  This is necessary
!    since the present call may have nothing to do with the previous
!    call.  Then, if
!      XT(ILO) <= X < XT(ILO+1),
!    we set LEFT = ILO and are done after just three comparisons.
!
!    Otherwise, we repeatedly double the difference ISTEP = IHI - ILO
!    while also moving ILO and IHI in the direction of X, until
!      XT(ILO) <= X < XT(IHI)
!    after which we use bisection to get, in addition, ILO + 1 = IHI.
!    The value LEFT = ILO is then returned.
!
!    Thanks to Daniel Gloger for pointing out an important modification
!    to the routine, so that the piecewise polynomial in B-form is
!    left-continuous at the right endpoint of the basic interval,
!    17 April 2014.
!
!  Modified:
!
!    17 April 2014
!
!  Author:
!
!    Carl de Boor
!
!  Reference:
!
!    Carl de Boor,
!    A Practical Guide to Splines,
!    Springer, 2001,
!    ISBN: 0387953663,
!    LC: QA1.A647.v27.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) XT(LXT), a nondecreasing sequence of values.
!
!    Input, integer ( kind = 4 ) LXT, the dimension of XT.
!
!    Input, real ( kind = 8 ) X, the point whose location with
!    respect to the sequence XT is to be determined.
!
!    Output, integer ( kind = 4 ) LEFT, the index of the bracketing value:
!      1     if             X  <  XT(1)
!      I     if   XT(I)  <= X  < XT(I+1)
!      I     if   XT(I)  <  X == XT(I+1) == XT(LXT)
!
!    Output, integer ( kind = 4 ) MFLAG, indicates whether X lies within the
!    range of the data.
!    -1:            X  <  XT(1)
!     0: XT(I)   <= X  < XT(I+1)
!    +1: XT(LXT) <  X
!
  implicit none

  integer ( kind = 4 ) lxt

  integer ( kind = 4 ) left
  integer ( kind = 4 ) mflag
  integer ( kind = 4 ) ihi
  integer ( kind = 4 ), save :: ilo = 1
  integer ( kind = 4 ) istep
  integer ( kind = 4 ) middle
  real ( kind = 8 ) x
  real ( kind = 8 ) xt(lxt)

  ihi = ilo + 1

  if ( lxt <= ihi ) then

    if ( xt(lxt) <= x ) then
      go to 110
    end if

    if ( lxt <= 1 ) then
      mflag = -1
      left = 1
      return
    end if

    ilo = lxt - 1
    ihi = lxt

  end if

  if ( xt(ihi) <= x ) then
    go to 20
  end if

  if ( xt(ilo) <= x ) then
    mflag = 0
    left = ilo
    return
  end if
!
!  Now X < XT(ILO).  Decrease ILO to capture X.
!
  istep = 1

10 continue

  ihi = ilo
  ilo = ihi - istep

  if ( 1 < ilo ) then
    if ( xt(ilo) <= x ) then
      go to 50
    end if
    istep = istep * 2
    go to 10
  end if

  ilo = 1

  if ( x < xt(1) ) then
    mflag = -1
    left = 1
    return
  end if

  go to 50
!
!  Now XT(IHI) <= X.  Increase IHI to capture X.
!
20 continue

  istep = 1

30 continue

  ilo = ihi
  ihi = ilo + istep

  if ( ihi < lxt ) then

    if ( x < xt(ihi) ) then
      go to 50
    end if

    istep = istep * 2
    go to 30

  end if

  if ( xt(lxt) <= x ) then
    go to 110
  end if
!
!  Now XT(ILO) < = X < XT(IHI).  Narrow the interval.
!
  ihi = lxt

50 continue

  do

    middle = ( ilo + ihi ) / 2

    if ( middle == ilo ) then
      mflag = 0
      left = ilo
      return
    end if
!
!  It is assumed that MIDDLE = ILO in case IHI = ILO+1.
!
    if ( xt(middle) <= x ) then
      ilo = middle
    else
      ihi = middle
    end if

  end do
!
!  Set output and return.
!
110 continue

  mflag = 1

  if ( x == xt(lxt) ) then
    mflag = 0
  end if

  do left = lxt - 1, 1, -1
    if ( xt(left) < xt(lxt) ) then
      return
    end if
  end do

  return
end


    Program dgetrf_example

!     DGETRF Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgetrf
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, lda, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :)
      Integer, Allocatable :: ipiv(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: min
!     .. Executable Statements ..
      Write (nout, *) 'DGETRF Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      Allocate (a(lda,n), ipiv(n))

!     Read A from data file

      Read (nin, *)(a(i,1:n), i=1, m)

!     Factorize A

      Call dgetrf(m, n, a, lda, ipiv, info)

!     Print details of factorization

      Write (nout, *)
      Flush (nout)

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', m, n, a, lda, &
        'Details of factorization', ifail)

!     Print pivot indices

      Write (nout, *)
      Write (nout, *) 'IPIV'
      Write (nout, 100) ipiv(1:min(m,n))

      If (info/=0) Then
        Write (nout, *) 'The factor U is singular'
      End If

100   Format ((3X,7I11))
    End Program


! { dg-do run }
! { dg-require-effective-target fortran_large_real }
program foo
   implicit none
   integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1)

   real(kind=k), dimension(10) :: r_k
   real(kind=k), dimension (2, 3) :: ar_k
   real(kind=k), dimension (2, 2, 3) :: br_k
   complex(kind=k), dimension(10) :: c_k
   complex(kind=k), dimension (2, 3) :: ac_k
   complex(kind=k), dimension (2, 2, 3) :: bc_k
   character (len=200) line1, line2, line3

   ar_k = reshape ((/1._k, 2._k, 3._k, 4._k, 5._k, 6._k/), (/2, 3/))
   br_k = spread (ar_k, 1, 2)
   if (any (br_k .ne. reshape ((/1._k, 1._k, 2._k, 2._k, 3._k, 3._k, &
   & 4._k, 4._k, 5._k, 5._k, 6._k, 6._k/), (/2, 2, 3/)))) call abort
   line1 = ' '
   write(line1, 9010) br_k
   line2 = ' '
   write(line2, 9010) spread (ar_k, 1, 2)
   if (line1 /= line2) call abort
   line3 = ' '
   write(line3, 9010) spread (ar_k, 1, 2) + 0._k
   if (line1 /= line3) call abort
   r_k = spread(1._k,1,10)
   if (any(r_k /= 1._k)) call abort

   ac_k = reshape ((/(1._k,-1._k), (2._k,-2._k), (3._k, -3._k), (4._k, -4._k), &
                   & (5._k,-5._k), (6._k,-6._k)/), (/2, 3/))
   bc_k = spread (ac_k, 1, 2)
   if (any (real(bc_k) .ne. reshape ((/1._k, 1._k, 2._k, 2._k, 3._k, 3._k, &
   & 4._k, 4._k, 5._k, 5._k, 6._k, 6._k/), (/2, 2, 3/)))) call abort
   if (any (-aimag(bc_k) .ne. reshape ((/1._k, 1._k, 2._k, 2._k, 3._k, 3._k, &
   & 4._k, 4._k, 5._k, 5._k, 6._k, 6._k/), (/2, 2, 3/)))) call abort
   line1 = ' '
   write(line1, 9020) bc_k
   line2 = ' '
   write(line2, 9020) spread (ac_k, 1, 2)
   if (line1 /= line2) call abort
   line3 = ' '
   write(line3, 9020) spread (ac_k, 1, 2) + 0._k
   if (line1 /= line3) call abort
   c_k = spread((1._k,-1._k),1,10)
   if (any(c_k /= (1._k,-1._k))) call abort

9010 format(12F7.3)
9020 format(25F7.3)

end program


SUBROUTINE throw(dice_arr, sides, ndice)
IMPLICIT NONE
INTEGER, DIMENSION(2), INTENT(OUT) :: dice_arr
INTEGER, INTENT(IN) :: sides, ndice
INTEGER :: i

DO i = 1, ndice
  dice_arr(i) = die()
END DO

CONTAINS
  INTEGER FUNCTION die()
  die = CEILING(RAND() * sides)
  END FUNCTION die
END SUBROUTINE throw

PROGRAM dice_thrower
IMPLICIT NONE
INTEGER, DIMENSION(3) :: dice
INTEGER :: i
DO i = 1, 10
  CALL throw(dice, 12, 3)
  WRITE(*, '(3I3)') dice(1), dice(2), dice(3)
END DO
END PROGRAM dice_thrower


module m_mt
  implicit none

  integer,parameter :: r_single = 4
  integer,parameter :: r_kind   = kind(0.d0)
  integer,parameter :: i_kind   = 4

  public :: EIGEN
  public :: EYE
  public :: QR
  public :: INV
  public :: RENORM
  public :: SVD
  public :: RANDN    ! Guassian noise N(0,1) generateor

  interface RENORM
    module procedure RENORM1d
    module procedure RENORM2d
  endinterface

  interface RANDN
    module procedure RANDN1d
    module procedure RANDN2d
  endinterface

contains

subroutine EIGEN( n, A, eigvect, eigval)
!
! check "dsyev" in the LAPACK
!
implicit none
! passed args
  integer,   intent(in   ) :: n
  real(8),intent(in   ) :: A(n,n)
  real(8),intent(  out) :: eigvect(n,n)
  real(8),intent(  out) :: eigval(n)

! local vars
  real(8)         :: r8A(n,n)
  real(8)         :: r8eigvect(n,n)
  real(8)         :: r8eigval(n)
  integer           :: lwk
  integer,parameter :: lwkmax = 3000
  real(8)         :: wk(lwkmax)
  integer           :: i, ierr

  ierr = 0
  r8A      = REAL(A, kind(0.0d0))
  r8eigvect = 0.0d0
  r8eigval = 0.0d0
  wk       = 0.0d0

  if ( 3*n-1 > lwkmax ) stop "ERROR in EIGEN: increase lwkmax"
! get the optimal work space
  lwk = -1
  call dsyev( 'V', 'U', n, r8A, n, r8eigval, wk, lwk, ierr )
  if (ierr/=0) stop "ERROR in EIGEN: dsyev"
  lwk = MIN( lwkmax, INT(wk(1)) )
! solve eigenproblem
  call dsyev( 'V', 'U', n, r8A, n, r8eigval, wk, lwk, ierr )
  if ( ierr /= 0 ) stop "ERROR in EIGEN: dsyev"
! put the largest eigenvalue as the 1st column, which brings the largest variance
  do i = 1, n
     eigval(i)    = r8eigval(n+1-i)
     eigvect(:,i) = r8A(:,n+1-i)
  enddo

endsubroutine

!
! generate random 1d-array
!
subroutine RANDN1d(n, A)
  implicit none

  integer,intent(in) :: n
  real(r_kind),intent(out) :: A(n)

  integer :: i
  real(r_kind) :: am

  do i = 1, n
     A(i) = real(rnorm(),r_kind)
  enddo
  am = sum(A(:))/n
  A(:) = A(:)-am

endsubroutine

!
! random 2D-array
!
subroutine RANDN2d(n,m,A)
  implicit none

  integer,intent(in) :: n, m
  real(r_kind),intent(out) :: A(n,m)

  real(r_kind) :: Am
  integer :: i, j

  do i = 1, n
     do j = 1, m
        A(i,j) = real(rnorm(),r_kind)
     enddo
  enddo
  Am = sum(A(:,:))/(n*m)
  A = A - Am

endsubroutine

!
! SVD: A= U * S * V^t
!
subroutine SVD(n,m,A,U,S,VT)
  implicit none

  integer,intent(in) :: n, m
  real(r_kind),intent(in)  :: A(m,n)
  real(r_kind),intent(out) :: U(m,m), VT(n,n)
  real(r_kind),intent(inout) :: S(:)

  character :: jobu, jobvt
  integer :: lda, ldu, ldvt
  integer :: info
  integer :: lwork
  real(r_kind) :: bufA(m,n)
  real(r_kind),allocatable :: work(:)

  bufA=A
  lda=m; ldu=m; ldvt=n
  lwork=3*min(m,n) + max ( max(m,n), 2*min(m,n) )
  allocate( work(lwork) )
  jobu='A'; jobvt='A'
  call dgesvd( jobu, jobvt, m, n, bufA, lda, S, U, ldu, VT, ldvt, work, lwork, info)
  if (info/=0) stop 'svd: error in dgesvd'
  deallocate( work )

endsubroutine

!
! identity matrix
!
subroutine EYE(n,A)
  implicit none

  integer,intent(in) :: n
  real(r_kind),intent(out) :: A(n,n)

  integer :: i

  A=0.d0
  do i = 1, n
     A(i,i) = 1.d0
  enddo

endsubroutine

!
! A random upper triangle square matrix
!
subroutine RANDUTRI(n,A)
  implicit none
  integer,intent(in) :: n
  real(r_kind),intent(out) :: A(n,n)

  integer :: i, j

  A=0.d0
  do i = 1, n
     do j = i,n
        A(i,j) = REAL(rnorm(),8)
     enddo
  enddo

  call RENORM(n,n,A)

endsubroutine

subroutine RENORM1d(n,A)
  implicit none

  integer,intent(in) :: n
  real(r_kind),intent(inout) :: A(n)

  real(r_kind) :: rn2

  rn2 = sqrt(sum(A(:)*A(:)))
  A(:) = A(:)/rn2

endsubroutine

!
! renormalize each column of the general matrix
!
subroutine RENORM2d(n,m,A)
  implicit none

  integer,intent(in) :: n, m
  real(r_kind),intent(inout) :: A(n,m)

  integer :: i
  real(r_kind) :: rn2

  do i = 1, m
     rn2 = sqrt(sum(A(:,i)*A(:,i)))
     A(:,i) = A(:,i)/rn2
  enddo

endsubroutine

!
! inverse of a general square matrix
!
subroutine INV(n,A,invA)
  implicit none

  integer,intent(in) :: n
  real(r_kind),intent(in) :: A(n,n)
  real(r_kind),intent(out) :: invA(n,n)

  integer :: info, ipiv(n)
  integer :: lwork, lda
  real(r_kind) :: work(n)

  invA = A
  lda  = n; lwork = n
  call dgetrf(n,n,invA,lda,ipiv,info)
  if (info/=0) stop "ERROR in INV: dgetrf"
  call dgetri(n,invA,lda,ipiv,work,lwork,info)
  if (info/=0) stop "ERROR in INV: dgetri"
endsubroutine

!
! QR decomposition of a square matrix
!
subroutine QR(n,A,Q,R)
  implicit none

  integer,intent(in) :: n
  real(r_kind),intent(in) :: A(n,n)
  real(r_kind),intent(out) :: Q(n,n), R(n,n)

  integer :: ierr
  real(r_kind) :: work(n), bufA(n,n), tau(n)
  integer :: lda
  integer :: i

  ierr=0
  lda = n
  bufA = A
  call dgeqrf(n,n,bufA,lda,tau,work,n,ierr)
  if (ierr/=0) stop "ERROR in QR: dgetqrf"
  R=0.d0
  do i = 1, n
     R(i,i:n) = bufA(i,i:n)
  enddo
  Q=bufA
  call dorgqr(n,n,n,Q,lda,tau,work,n,ierr)
  if (ierr/=0) stop "ERROR in QR: qorgqr"

endsubroutine

!
! random number generator
!
subroutine rnorm1d( nn, r1d )
  implicit none

  integer,intent(in) :: nn
  real(r_single),intent(inout) :: r1d(nn)

  integer :: i

  do i =1 , nn
     r1d(i) = rnorm()
  enddo

endsubroutine

real(r_single) function rnorm() result( fn_val )

!   Generate a random normal deviate using the polar method.
!   Reference: Marsaglia,G. & Bray,T.A. 'A convenient method for generating
!              normal variables', Siam Rev., vol.6, 260-264, 1964.

implicit none

! Local variables

real(r_single)            :: u, sum
real(r_single), save      :: v, sln
logicaL, save           :: second = .false.
real(r_single), parameter :: one = 1.0_r_single, vsmall = TINY( one )

if (second) then
! If second, use the second random number generated on last call

  second = .false.
  fn_val = v*sln

else
! First call; generate a pair of random normals

  second = .true.
  do
    call random_number( u )
    call random_number( v )
    u = scale( u, 1 ) - one
    v = scale( v, 1 ) - one
    sum = u*u + v*v + vsmall         ! vsmall added to prevent LOG(zero) / zero
    IF(sum < one) exit
  end do
  sln = sqrt(- scale( log(sum), 1 ) / sum)
  fn_val = u*sln
end if

return
end function rnorm

subroutine iran(l,n,ran_int)
! generate an array of N random integers between 0 and L-1.
 real(r_single) :: rnd
 integer(i_kind) :: L,i,N
 integer(i_kind) :: ran_int(N)
 do i = 1,n
    call random_number(rnd)
    ran_int(i) = nint(float(l-1)*rnd)
 end do
end subroutine iran

subroutine set_random_seed ( iseed , myrank)
!
!*******************************************************************************
!
!! SET_RANDOM_SEED initializes the FORTRAN 90 random number generator.
!
!
!  Discussion:
!
!    If ISEED is nonzero, then that value is used to construct a seed.
!
!    If ISEED is zero, then the seed is determined by calling the date
!    and time routine.  Thus, if the code is run at different times,
!    different seed values will be set.
!
!  Parameters:
!
!    Input, integer ISEED, is nonzero for a user seed, or 0 if the
!    seed should be determined by this routine.
!
  implicit none
!
  integer(i_kind), intent(in), optional :: myrank
  integer(i_kind) date_time(8)
  logical, parameter :: debug = .false.
  integer(i_kind) i,j,k
  integer(i_kind) iseed
  integer(i_kind), allocatable :: seed(:)

!
!  Initialize the random seed routine.
!
  call random_seed
!
!  Request the size of a typical seed.
!  (On the DEC ALPHA, K is returned as 2.)
!
  call random_seed ( size = k )

  if ( debug ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SET_RANDOM_SEED:'
    write ( *, '(a,i6)' ) '  Random seed size is K = ', k
  end if
!
!  Set up space for a seed vector.
!
  allocate ( seed(k) )

  if ( iseed /= 0 ) then

    seed(1:k) = iseed

  else
!
!  Make up a "random" value based on date and time information.
!
    call date_and_time ( values = date_time )

    do i = 1, k

      seed(i) = 0

      do j = 1, 8
        if (present(myrank)) then
        seed(i) = seed(i) + ( j + i ) * date_time(j) + myrank * 100
        else
        seed(i) = seed(i) + ( j + i ) * date_time(j)
        endif
        seed(i) = ishftc ( seed(i), 4 * ( j - 1 ) )
      end do

    end do

  end if

  if  ( debug ) then

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SET_RANDOM_SEED:'
    write ( *, '(a)' ) '  The random seed vector:'
    write ( *, '(a)' ) ' '

    do i = 1, k
      write ( *, '(i12)' ) seed(i)
    end do

  end if
!
!  Send this random value back to the RANDOM_SEED routine, to be
!  used as the seed of the random number generator.
!
  call random_seed ( put = seed(1:k) )

  deallocate ( seed )

  end subroutine set_random_seed

endmodule

!
! test SVD
!
!program main
!  use m_mt
!  implicit none
!
!  integer :: n, m
!  real(8),allocatable :: A(:,:), U(:,:),S(:),VT(:,:)
!
!  integer :: i, j
!
!  m=3; n=4
!  allocate(A(m,n),U(m,m),S(max(m,n)),VT(n,n))
!  A(1,:)=(/1.d0, 2.d0, 3.d0, 4.d0/)
!  A(2,:)=(/3.d0, 4.d0, 5.d0, 6.d0/)
!  A(3,:)=(/6.d0, 5.d0, 4.d0, 1.d0/)
!  call SVD(n,m,A,U,S,VT)
!  print*, "A="
!  do i = 1, m
!     write(*,*) (A(i,j),j=1,n)
!  enddo
!
!  print*, "U="
!  do i = 1, m
!     write(*,*) (U(i,j),j=1,m)
!  enddo
!
!  print*, "U=", (S(i),i=1,max(m,n))
!
!  print*, "VT="
!  do i = 1, n
!     write(*,*) (VT(i,j),j=1,n)
!  enddo
!endprogram

!
! test randn
!
!program main
!  use m_mt, only :randn
!  implicit none
!
!  real(8) :: a(100)
!  integer :: i , k
!
!  do i = 1, 3
!    call randn(100,a)
!    do k = 1 , 5
!       write(*,*) a(k)
!    enddo
!    pause "i"
!  enddo
!
!endprogram


! An example of converting the indices of a 9-element rank 1 array
! into the indices of a 3-by-3 rank 2 array. Column major ordering!
program convert_array_indices

  implicit none

  integer, dimension(9) :: a, j, i
  integer :: n, k, ny = 3

  n = size(a)

  do k = 1, n
     a(k) = k
  end do
  write(*, "(a, 9(i3))") "a =", a

  do k = 1, n
     j(k) = mod((k-1), ny) + 1
     i(k) = (k-1)/ny + 1
  end do
  write(*, "(a, 9(i3))") "j =", j
  write(*, "(a, 9(i3))") "i =", i

end program convert_array_indices