module md_module
contains
    subroutine matrix_diagonal(a, diag, n)
        implicit none
        real, dimension(:,:), intent(in) :: a
        real, dimension(:), intent(out) :: diag
        integer, intent(in) :: n
        real, dimension(1:size(a)) :: tmp

        tmp = pack(a,.true.)
        diag = tmp(1:n*n:n+1)
    end subroutine
end module

program ch2603
    ! A Subroutine to Extract the Diagonal
    ! Elements of a Matrix
    use md_module
    implicit none
    integer :: i, n
    real, allocatable, dimension(:,:) :: a
    real, allocatable, dimension(:) :: diag
    character(20) :: filename

    print *, 'input name of data file'
    read '(a)', filename
    open(1,file=filename)
    read(1,*) n
    allocate(a(1:n,1:n), diag(1:n))
    do i = 1, n
        read(1,*) a(i,1:n)
    end do
    call matrix_diagonal(a,diag,n)
    print *, ' diagonal elements of a are:'
    print *, diag
end program


SUBROUTINE chol (a, n, nn, u, nullty, ifault)

!    Algorithm AS6, Applied Statistics, vol.17, (1968)

!    Given a symmetric matrix order n as lower triangle in a( ),
!    calculates an upper triangle, u( ), such that uprime * u = a.
!    a must be positive semi-definite.  eta is set to multiplying
!    factor determining effective zero for pivot.

!    arguments:-
!    a()     = input, a +ve definite matrix stored in lower-triangular form.
!    n       = input, the order of a
!    nn      = input, the size of the a and u arrays >= n*(n+1)/2
!    u()     = output, a lower triangular matrix such that u*u' = a.
!              a & u may occupy the same locations.
!    nullty  = output, the rank deficiency of a.
!    ifault  = output, error indicator
!                    = 1 if n < 1
!                    = 2 if a is not +ve semi-definite
!                    = 3 if nn < n*(n+1)/2
!                    = 0 otherwise

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

IMPLICIT NONE
INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 60)
REAL (dp), INTENT(IN)  :: a(:)
INTEGER, INTENT(IN)    :: n, nn
REAL (dp), INTENT(OUT) :: u(:)
INTEGER, INTENT(OUT)   :: nullty, ifault

! Local variables
REAL (dp)              :: eta2, x, w
INTEGER                :: i, icol, ii, irow, j, k, kk, l, m

!       The value of eta will depend on the word-length of the
!       computer being used.  See introductory text.

REAL (dp), PARAMETER   :: eta = 1.E-09_dp, zero = 0.0_dp

ifault = 1
IF (n <=  0) RETURN
ifault = 3
IF (nn < n*(n+1)/2) RETURN
ifault = 2
nullty = 0
j = 1
k = 0
eta2 = eta*eta
ii = 0

!       Factorize column by column, icol = column no.

DO icol = 1, n
  ii = ii + icol
  x = eta2*a(ii)
  l = 0
  kk = 0

!       IROW = row number within column ICOL

  DO irow = 1, icol
    kk = kk + irow
    k = k + 1
    w = a(k)
    m = j
    DO i = 1, irow
      l = l + 1
      IF (i == irow) EXIT
      w = w - u(l)*u(m)
      m = m + 1
    END DO

    IF (irow == icol) EXIT
    IF (u(l) /= zero) THEN
      u(k) = w / u(l)
    ELSE
      IF (w*w > ABS(x*a(kk))) RETURN
      u(k) = zero
    END IF
  END DO

  IF (ABS(w) > ABS(eta*a(k))) THEN
    IF (w < zero) RETURN
    u(k) = SQRT(w)
  ELSE
    u(k) = zero
    nullty = nullty + 1
  END IF
  j = j + icol
END DO

ifault = 0
RETURN
END SUBROUTINE chol

SUBROUTINE subchl (a, b, n, u, nullty, ifault, det)

!   REMARK ASR 44  APPL. STATIST. (1982) VOL. 31, NO. 3

!   A revised and enhanced version of
!   ALGORITHM AS 6  APPL. STATIST. (1968) VOL. 17, NO. 2

! N.B. Argument NDIM has been removed, and DET is an OPTIONAL argument

!   Given a symmetric matrix of order N as lower triangle in A(),
!   calculates an upper triangle, U(), such that U'U = the sub-matrix
!   of A whose rows and columns are specified in the integer array B().
!   U() may coincide with A().   A() must be +ve semi-definite.
!   ETA is set to multiplying factor determining effective zero for a pivot.
!   NULLTY is returned as number of effective zero pivots.
!   IFAULT is returned as 1 if N <= 0, 2 if A() is not +ve semi-
!   definite, otherwise 0 is returned.

IMPLICIT NONE
INTEGER, PARAMETER               :: dp = SELECTED_REAL_KIND(15, 60)
REAL (dp), INTENT(IN)            :: a(:)
REAL (dp), INTENT(OUT)           :: u(:)
REAL (dp), INTENT(OUT), OPTIONAL :: det
INTEGER, INTENT(IN)              :: b(:), n
INTEGER, INTENT(OUT)             :: nullty, ifault

!     Local variables

REAL (dp) :: w, eta2, x
INTEGER   :: i, icol, ii, ij, irow, j, jj, k, kk, l, m

!     The value of ETA below will depend upon the word length of the
!     computer being used.

REAL (dp), PARAMETER :: eta = 1.E-14_dp, zero = 0.0_dp, one = 1.0_dp

ifault = 1
IF (n <= 0) GO TO 90
ifault = 2
nullty = 0
IF (PRESENT(det)) det = one
j = 1
k = 0
eta2 = eta*eta
DO icol = 1, n
  ij = b(icol)*(b(icol) - 1)/2
  ii = ij + b(icol)
  x = eta2*a(ii)
  l = 0
  DO irow = 1, icol
    kk = b(irow)*(b(irow) + 1)/2
    k = k + 1
    jj = ij + b(irow)
    w = a(jj)
    m = j
    DO i = 1, irow
      l = l + 1
      IF (i == irow) GO TO 20
      w = w - u(l)*u(m)
      m = m + 1
    END DO
    20 IF (irow == icol) GO TO 50
    IF (u(l) == zero) GO TO 30
    u(k) = w/u(l)
    CYCLE
    30 IF (w*w > ABS(x*a(kk))) GO TO 90
    u(k) = zero
  END DO

  50 IF (ABS(w) <= ABS(eta*a(kk))) GO TO 60
  IF (w < zero) GO TO 90
  u(k) = SQRT(w)
  GO TO 70
  60 u(k) = zero
  nullty = nullty + 1
  70 j = j + icol
  IF (PRESENT(det)) det = det*u(k)*u(k)
END DO

ifault = 0
90 RETURN
END SUBROUTINE subchl


!*******************************************************
!
!   TO TEST xor4096_apps
!
!*******************************************************
program xor4096_apps

  use mo_kind,         only: i4, i8, dp
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_xor4096,      only: xor4096,xor4096g, n_save_state
  use mo_xor4096_apps, only: xor4096_array, xor4096_range, xor4096g_mvn

  implicit none

  integer(i8)                            :: seed1
  real(dp),    dimension(20)             :: rn1
  integer(i8), dimension(n_save_state)   :: save_state1

  integer(i8), dimension(3)              :: seed2
  real(dp),    dimension(20,3)           :: rn2
  integer(i8), dimension(3,n_save_state) :: save_state2

  integer(i8), dimension(2)              :: seed3
  real(dp),    dimension(20,2)           :: rn_mvn
  integer(i8), dimension(2,n_save_state) :: save_state3
  real(dp), dimension(2,2)               :: cov  ! covariance matrix
  real(dp), dimension(2,2)               :: lcho ! lower cholesky factor

  integer(i4) :: i
  logical     :: isgood
  integer     :: info

  external DPOTRF   ! Lapack routine for calculating the cholesky factor

  isgood = .true.

  ! *********************************************************************
  ! TEST XOR4096_ARRAY
  ! *********************************************************************

  write(*,*) ''
  write(*,*) 'Testing xor4096_array: one stream'

  ! initialize a stream and save its state
  seed1 = 123456_i8
  call xor4096(seed1, rn1(1), save_state=save_state1)
  seed1 = 0_i8
  ! now ready for usage

  call xor4096_array(rn1, save_state=save_state1)
  do i=1,20
     write(*,*) i, rn1(i)
  end do

  if ( nint(rn1(20)*10000.0_dp, i4) /= 8767_i4 ) isgood = .false.

  write(*,*) ''
  write(*,*) 'Testing xor4096_array: multiple streams'

  ! initialize multiple streams and save their states
  seed2 = (/ 123456_i8, 567362_i8, 4572417_i8 /)
  call xor4096(seed2, rn2(1,:), save_state=save_state2)
  seed2 = 0_i8
  ! now ready for usage

  call xor4096_array(rn2, save_state=save_state2)
  do i=1,20
     write(*,*) i, rn2(i,:)
  end do

  if ( nint(rn2(20,3)*10000.0_dp, i4) /= 8125_i4 ) isgood = .false.

  ! *********************************************************************
  ! TEST XOR4096_MVN
  ! *********************************************************************

  write(*,*) ''
  write(*,*) 'Testing xor4096_mvn: time series'

  ! initialize a stream and save its state
  seed3 = (/ 123456_i8, 154725_i8 /)

  call xor4096g(seed3, rn_mvn(1,:), save_state=save_state3)
  seed3 = 0_i8
  ! now ready for usage

  ! calculating lcho: Lower Cholesky factor of covariance matrix cov
  cov(1,:) = (/ 1.0_dp, 0.25_dp /)
  cov(2,:) = (/ 0.25_dp, 1.0_dp /)
  lcho = cov
  call DPOTRF('L', size(lcho,2), lcho, size(lcho,1), info) ! changes lower triangular (incl. main diagonal) of Lcho
  ! DONT forget to set upper triangular matrix to zero
  lcho(1,2) = 0._dp

  call xor4096g_mvn(lcho, rn_mvn, save_state=save_state3)
  do i=1,20
     write(*,*) i, rn_mvn(i,:)
  end do

  if ( nint(rn_mvn(20,2)*10000.0_dp, i4) /= 771_i4 ) isgood = .false.

  ! *********************************************************************
  ! TEST XOR4096_RANGE
  ! *********************************************************************

  write(*,*) ''
  write(*,*) 'Testing xor4096_range: one stream'

  ! initialize a stream and save its state
  seed1 = 123456_i8
  call xor4096(seed1, rn1(1), save_state=save_state1)
  seed1 = 0_i8
  ! now ready for usage

  call xor4096_range((/ 1.0_dp, 5.0_dp /), rn1, save_state=save_state1)
  do i=1,20
     write(*,*) i, rn1(i)
  end do

  if ( nint(rn1(20)*10000.0_dp, i4) /= 45068_i4 ) isgood = .false.

  write(*,*) ''
  write(*,*) 'Testing xor4096_range: multiple streams'

  ! initialize multiple streams and save their states
  seed2 = (/ 123456_i8, 567362_i8, 4572417_i8 /)
  call xor4096(seed2, rn2(1,:), save_state=save_state2)
  seed2 = 0_i8
  ! now ready for usage

  call xor4096_range((/ 1.0_dp, 5.0_dp /), rn2, save_state=save_state2)
  do i=1,20
     write(*,*) i, rn2(i,:)
  end do

  if ( nint(rn2(20,3)*10000.0_dp, i4) /= 42501_i4 ) isgood = .false.

  write(*,*) ''
  if (isgood) then
     write(*,*) 'mo_xor4096_apps ', color('o.k.', c_green)
  else
     write(*,*) 'mo_xor4096_apps ', color('failed', c_red)
  end if

end program xor4096_apps


! { dg-do run }
!
! PR fortran/52022
!

module check
  integer, save :: icheck = 0
end module check

module t
implicit none
      contains
subroutine  sol(cost)
   use check
   interface
        function cost(p) result(y)
                double precision,dimension(:) :: p
                double precision,dimension(:),allocatable :: y
        end function cost
   end interface

   if (any (cost([1d0,2d0]) /= [2.d0, 4.d0])) STOP 1
   icheck = icheck + 1
end subroutine

end module t

module tt
   procedure(cost1),pointer :: pcost
contains
  subroutine init()
        pcost=>cost1
  end subroutine

  function cost1(x) result(y)
        double precision,dimension(:) :: x
        double precision,dimension(:),allocatable :: y
        allocate(y(2))
        y=2d0*x
  end function cost1

  function cost(x) result(y)
        double precision,dimension(:) :: x
        double precision,dimension(:),allocatable :: y
        allocate(y(2))
        y=pcost(x)
  end function cost
end module

program test
        use tt
        use t
        use check
        implicit none

        call init()
        if (any (cost([3.d0,7.d0]) /= [6.d0, 14.d0])) STOP 2
        if (icheck /= 0) STOP 3
        call sol(cost)
        if (icheck /= 1) STOP 4
end program test


MODULE funlib
  USE global
  IMPLICIT NONE
CONTAINS
  RECURSIVE FUNCTION factorial(i) RESULT(fac)
    IMPLICIT NONE
    INTEGER::fac
    INTEGER,INTENT(IN)::i
    INTEGER::init=0,j
    LOGICAL,DIMENSION(12)::lfacsave
    INTEGER,DIMENSION(12)::facsave
    SAVE facsave,init,lfacsave
    IF(init.EQ.0)THEN
       lfacsave(1:12)=.FALSE.
       init=1
    ENDIF
    IF(i.LT.0)THEN
       WRITE(*,*)"ERROR: i<0 in factorial with i=",i
       STOP
    ENDIF
    IF(i.GT.12)THEN
       WRITE(*,*)"ERROR: i > 12, please take long type (KIND=LINT) integer"
       STOP
    ENDIF
    IF(i.EQ.0)THEN
       fac=1
    ELSE
       IF(lfacsave(i))THEN
          fac=facsave(i)
       ELSE
          fac=i*factorial(i-1)
          facsave(i)=fac
          lfacsave(i)=.TRUE.
       ENDIF
    ENDIF
  END FUNCTION factorial

  SUBROUTINE PCL2PE(NLOOPLINE,PCL,PE)
    ! transfer the loop momenta q,q+p1,q+p1+p2,q+p1+p2+p3,...
    ! to p1,p2,p3,p4,...
    IMPLICIT NONE
    INTEGER,INTENT(IN)::NLOOPLINE
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,0:3),INTENT(IN)::PCL
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,0:3),INTENT(OUT)::PE
    INTEGER::i
    DO i=1,NLOOPLINE-1
       PE(i,0:3)=PCL(i+1,0:3)-PCL(i,0:3)
    ENDDO
    PE(NLOOPLINE,0:3)=PCL(1,0:3)-PCL(NLOOPLINE,0:3)
    RETURN
  END SUBROUTINE PCL2PE

  RECURSIVE SUBROUTINE calc_all_integers(n,ntot,i,sol)
    ! finds all the non-negative solutions to x1,...,xn
    ! that x1+x2+...+xn==i
    ! the number of solutions should be ntot=C(i+n-1)^(n-1)=(i+n-1)!/(n-1)!/i!
    ! it can be recycled for all phase space point
    IMPLICIT NONE
    INTEGER,INTENT(IN)::n,ntot,i
    INTEGER,DIMENSION(ntot,n),INTENT(OUT)::sol
    INTEGER::j,k,k0
    IF(i.EQ.0)THEN
       sol(1,1:n)=0
       RETURN
    ENDIF
    IF(n.EQ.1)THEN
       sol(1,1)=i
       RETURN
    ENDIF
    k0=0
    DO j=0,i
       k=xiarray_arg1(i-j,n-1)
       sol(k0+1:k0+k,1)=j
       CALL calc_all_integers(n-1,k,i-j,sol(k0+1:k0+k,2:n))
       k0=k0+k
    ENDDO
    RETURN
  END SUBROUTINE calc_all_integers

  SUBROUTINE all_Integers(n,ntot,i,sol,factor)
    ! finds all the non-negative solutions to x1,...,xn
    ! that x1+x2+...+xn==i
    ! the number of solutions should be ntot=C(i+n-1)^(n-1)=(i+n-1)!/(n-1)!/i!
    ! it can be recycled for all phase space point
    IMPLICIT NONE
    INTEGER,INTENT(IN)::n,ntot,i
    INTEGER,DIMENSION(ntot,n),INTENT(OUT)::sol
    REAL(KIND(1d0)),DIMENSION(ntot),INTENT(OUT)::factor
    INTEGER::ifirst=0,j,jk,k,ntemptot
    INTEGER::maxxiarray,inum,nnum,maxxiarray1,maxxiarray2
    INTEGER::maxfactor_xiarray
    SAVE ifirst
    ! calculate xiarray_i_n first
    IF(ifirst.EQ.0)THEN
       maxxiarray=(MAXRANK_IREGI+1)*(MAXNLOOP_IREGI-1)
       IF(.NOT.ALLOCATED(xiarray))THEN
          ALLOCATE(xiarray(maxxiarray))
       ENDIF
       maxfactor_xiarray=(MAXRANK_IREGI+1)*(MAXNLOOP_IREGI-2)
       IF(.NOT.ALLOCATED(factor_xiarray))THEN
          ALLOCATE(factor_xiarray(MAXRANK_IREGI+2:maxfactor_xiarray+MAXRANK_IREGI+1))
       ENDIF
       ! x1+x2+...+xn==i
       ! C(i+n-1)^(n-1)=(i+n-1)!/(n-1)!/i!
       DO j=1,maxxiarray
          inum=MOD(j-1,MAXRANK_IREGI+1) ! i
          nnum=(j-1)/(MAXRANK_IREGI+1)+1 ! n
          maxxiarray1=xiarray_arg1(inum,nnum)
          maxxiarray2=nnum
          IF(.NOT.ALLOCATED(xiarray(j)%xiarray_i_n))THEN
             ALLOCATE(xiarray(j)%xiarray_i_n(maxxiarray1,maxxiarray2))
          ENDIF
          IF(nnum.EQ.1)THEN
             xiarray(j)%xiarray_i_n(1,1)=j-1
             CYCLE
          ENDIF
          CALL calc_all_integers(nnum,maxxiarray1,inum,&
               xiarray(j)%xiarray_i_n(1:maxxiarray1,1:maxxiarray2))
          IF(.NOT.ALLOCATED(factor_xiarray(j)%factor_xiarray_i_n))THEN
             ALLOCATE(factor_xiarray(j)%factor_xiarray_i_n(maxxiarray1))
          ENDIF
          DO jk=1,maxxiarray1
             factor_xiarray(j)%factor_xiarray_i_n(jk)=DBLE(factorial(inum))
             DO k=1,nnum
                factor_xiarray(j)%factor_xiarray_i_n(jk)=factor_xiarray(j)%factor_xiarray_i_n(jk)/&
                     DBLE(factorial(xiarray(j)%xiarray_i_n(jk,k)))
             ENDDO
          ENDDO
          ntot_xiarray(inum,nnum)=maxxiarray1
       ENDDO
       ifirst=1
    ENDIF
    IF(n.GT.MAXNLOOP_IREGI-1.OR.n.LT.1)THEN
       WRITE(*,100)"ERROR: n is out of range 1<=n<=",MAXNLOOP_IREGI-1," in all_integers"
       STOP
    ENDIF
    IF(i.GT.MAXRANK_IREGI.OR.i.LT.0)THEN
       WRITE(*,100)"ERROR: r is out of range 0<=r<=",MAXRANK_IREGI," in all_integers"
       STOP
    ENDIF
    IF(n.EQ.1.AND.ntot.NE.1)THEN
       WRITE(*,*)"ERROR:ntot should be 1 when n=1 in all_integers"
       STOP
    ENDIF
    IF(n.GE.2.AND.n.LE.MAXNLOOP_IREGI-1)THEN
       ! Make it work in MadLoop, otherwise it is wrong
       IF(ntot.NE.ntot_xiarray(i,n))THEN
          WRITE(*,*)"ERROR: ntot is not correct in all_integers"
          STOP
       ENDIF
    ENDIF
    j=(n-1)*(MAXRANK_IREGI+1)+i+1
    SELECT CASE(n)
       CASE(1)
          sol(1:ntot,1:n)=xiarray(j)%xiarray_i_n(1:1,1:n)
          factor(1)=1d0
       CASE DEFAULT
          sol(1:ntot,1:n)=xiarray(j)%xiarray_i_n(1:ntot,1:n)
          factor(1:ntot)=factor_xiarray(j)%factor_xiarray_i_n(1:ntot)
    END SELECT
    RETURN
100 FORMAT(2X,A31,I2,A16)
  END SUBROUTINE all_Integers

  SUBROUTINE calc_factorial_pair
    IMPLICIT NONE
    INTEGER::i,j
    factorial_pair(1:MAXINDICES_IREGI,0)=1d0
    DO i=1,MAXINDICES_IREGI
       DO j=1,MAXRANK_IREGI
          factorial_pair(i,j)=DBLE(factorial(i+j-1))&
               /DBLE(factorial(i-1))/DBLE(factorial(j))
       ENDDO
    ENDDO
    RETURN
  END SUBROUTINE calc_factorial_pair

  FUNCTION number_coefs_for_rank(rank) RESULT(res)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::rank
    INTEGER::res,i
    IF(rank.LT.0)res=0
    res=0
    DO i=0,rank
       res=res+((3+i)*(2+i)*(1+i))/6
    ENDDO
    RETURN
  END FUNCTION number_coefs_for_rank

  SUBROUTINE timestamp
    IMPLICIT NONE
    CHARACTER(len=8)::ampm
    INTEGER::d
    INTEGER::h
    INTEGER::m,n
    INTEGER::mm
    CHARACTER( len = 9 ),PARAMETER,DIMENSION(12) :: month = (/ &
         'January  ', 'February ', 'March    ', 'April    ', &
         'May      ', 'June     ', 'July     ', 'August   ', &
         'September', 'October  ', 'November ', 'December ' /)
    INTEGER::dn
    INTEGER::s
    INTEGER,DIMENSION(8)::values
    INTEGER::y
    CALL date_and_time(values=values)
    y = values(1)
    m = values(2)
    d = values(3)
    h = values(5)
    n = values(6)
    s = values(7)
    mm = values(8)
    IF( h.LT.12 )THEN
       ampm = 'AM'
    ELSEIF( h.EQ.12 )THEN
       IF( n.EQ.0 .AND. s.EQ.0 )THEN
          ampm = 'Noon'
       ELSE
          ampm = 'PM'
       ENDIF
    ELSE
       h = h - 12
       IF( h.LT.12 )THEN
          ampm = 'PM'
       ELSEIF( h.EQ.12 )THEN
          IF(n.EQ.0.AND.s.EQ.0)THEN
             ampm = 'Midnight'
          ELSE
             ampm = 'AM'
          ENDIF
       ENDIF
    ENDIF
    WRITE( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
         d, TRIM( month(m) ), y, h, ':', n, ':', s, '.', mm, TRIM( ampm )
    RETURN
  END SUBROUTINE timestamp
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                               !
! FOLLOWING SUBROUTINES/FUNCTIONS ARE ONLY FOR THE REORDERING THE TIR COEFS     !
!                                                                               !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE SORT_IREGICOEFS(RANK,NLOOPCOEFS,OLDCOEFS,NEWCOEFS)
    !
    ! CONVERT THE OUTPUT OF IREGI TO THAT OF (NEW) MADLOOP
    !
    ! THE NEW OUTPUT OF COEFS FROM MADLOOP IS
    ! RANK=0: (,)
    ! RANK=1: (0,),(1,),(2,),(3,)
    ! RANK=2: (0,0),(0,1),(1,1),(0,2),(1,2),(2,2),(0,3),(1,3),(2,3),(3,3)
    ! ...
    ! THE OLD OUTPUT OF COEFS FROM MADLOOP IS
    ! RANK=0: (,)
    ! RANK=1: (0,),(1,),(2,),(3,)
    ! RANK=2: (0,0),(0,1),(0,2),(0,3),(1,1),(2,1),(3,1),(2,2),(2,3),(3,3)
    ! ...
    !
    ! ARGUMENTS
    IMPLICIT NONE
    INTEGER,INTENT(IN)::RANK,NLOOPCOEFS
    COMPLEX(KIND(1d0)),DIMENSION(0:NLOOPCOEFS-1,3),INTENT(IN)::OLDCOEFS
    COMPLEX(KIND(1d0)),DIMENSION(0:NLOOPCOEFS-1,3),INTENT(OUT)::NEWCOEFS
    !
    ! LOCAL VARIABLES
    !
    INTEGER::I
    ! MAX RANK SET AS 10
    ! Sum((3+r)*(2+r)*(1+r)/6,{r,0,10})=1001
    INTEGER,PARAMETER::LOOPMAXCOEFS_IREGI=1001
    INTEGER,DIMENSION(0:LOOPMAXCOEFS_IREGI-1)::POS
    SAVE POS
    LOGICAL::INIT=.TRUE.
    SAVE INIT
    ! ----------
    ! BEGIN CODE
    ! ----------

    IF(INIT)THEN
       IF(NLOOPCOEFS.GT.LOOPMAXCOEFS_IREGI)&
            STOP "ERROR:LOOPMAXCOEFS_IREGI IS TOO SMALL!!!"
       INIT=.FALSE.
       ! ASSIGN THE POSITION OF POS FOR SWAP
       CALL ASSIGN_PJPOS(POS)
    ENDIF

    DO I=0,NLOOPCOEFS-1
    !   NEWCOEFS(I,1:3)=OLDCOEFS(POS(I),1:3)
       NEWCOEFS(POS(I),1:3)=OLDCOEFS(I,1:3)
    ENDDO

  END SUBROUTINE SORT_IREGICOEFS

  SUBROUTINE ASSIGN_PJPOS(POS)
    !
    ! ASSIGN THE POSITION OF POS FOR SWAP
    !
    !
    IMPLICIT NONE
    !
    ! CONSTANS
    !
    ! MAX RANK SET AS 10
    ! Sum((3+r)*(2+r)*(1+r)/6,{r,0,10})=1001
    INTEGER,PARAMETER::LOOPMAXCOEFS_IREGI=1001,MAXRANK=10
    !
    ! ARGUMENTS
    !
    INTEGER,DIMENSION(0:LOOPMAXCOEFS_IREGI-1),INTENT(OUT)::POS
    !
    ! LOCAL VARIABLES
    !
    INTEGER::I,J,K,SHIFT,DN
    INTEGER,DIMENSION(MAXRANK)::POSINDEX,PJPOSINDEX
    ! ----------
    ! BEGIN CODE
    ! ----------
    POS(0)=0
    DO I=1,4
       POS(I)=I
    ENDDO
    SHIFT=4
    DO J=2,MAXRANK
       DN=(J+3)*(J+2)*(J+1)/6
       POSINDEX(1:MAXRANK)=0
       PJPOSINDEX(1:MAXRANK)=0
       DO I=1,DN
          IF(I.GT.1)CALL NEXTINDEX(J,POSINDEX)
          CALL CONVERT_PJPOSINDEX(J,POSINDEX,PJPOSINDEX)
          K=DN-QPOLYPOS(J,PJPOSINDEX)+1+SHIFT
          !POS(K)=I+SHIFT
          POS(I+SHIFT)=K
       ENDDO
       SHIFT=SHIFT+DN
    ENDDO

  END SUBROUTINE ASSIGN_PJPOS

  SUBROUTINE NEXTINDEX(RANK,POSINDEX)
    !
    ! CALL FOR THE NEXT INDEX
    !
    IMPLICIT NONE
    !
    ! CONSTANTS
    !
    INTEGER,PARAMETER::MAXRANK=10
    !
    ! ARGUMENTS
    !
    INTEGER,INTENT(IN)::RANK
    INTEGER,DIMENSION(MAXRANK),INTENT(INOUT)::POSINDEX
    !
    ! LOCAL VARIABLES
    !
    INTEGER::I
    ! ----------
    ! BEGIN CODE
    ! ----------
    DO I=1,RANK
       POSINDEX(I)=POSINDEX(I)+1
       IF(POSINDEX(I).GT.3)THEN
          POSINDEX(I)=0
          IF(I.EQ.RANK)THEN
             RETURN
          ENDIF
       ELSE
          IF(I.GT.1)THEN
             POSINDEX(1:I-1)=POSINDEX(I)
          ENDIF
          RETURN
       ENDIF
    ENDDO

  END SUBROUTINE NEXTINDEX

  SUBROUTINE CONVERT_PJPOSINDEX(RANK,POSINDEX,PJPOSINDEX)
    !
    ! CONVERT POSINDEX TO PJPOSINDEX
    !
    IMPLICIT NONE
    !
    ! CONSTANTS
    !
    INTEGER,PARAMETER::MAXRANK=10
    !
    ! ARGUMENTS
    !
    INTEGER,INTENT(IN)::RANK
    INTEGER,DIMENSION(MAXRANK),INTENT(IN)::POSINDEX
    INTEGER,DIMENSION(MAXRANK),INTENT(OUT)::PJPOSINDEX
    !
    ! LOCAL VARIABLES
    !
    INTEGER::I
    ! ----------
    ! BEGIN CODE
    ! ----------
    DO I=1,RANK
       PJPOSINDEX(RANK+1-I)=3-POSINDEX(I)
    ENDDO
    RETURN
  END SUBROUTINE CONVERT_PJPOSINDEX

  FUNCTION QPOLYPOS(RANK,POSINDEX)
    !
    ! COMPUTATION THE RELATIVE POSITION OF INDEX WITH RANK
    ! IN THE *OLD* MADLOOP CONVENTION
    !
    IMPLICIT NONE
    !
    ! CONSTANTS
    !
    INTEGER,PARAMETER::MAXRANK=10
    !
    ! ARGUMENTS
    !
    INTEGER,INTENT(IN)::RANK
    INTEGER,DIMENSION(MAXRANK),INTENT(IN)::POSINDEX
    INTEGER::QPOLYPOS
    !
    ! LOCAL VARIABLES
    !
    INTEGER::I,J,IMIN
    ! ----------
    ! BEGIN CODE
    ! ----------

    IF(RANK.EQ.0)THEN
       QPOLYPOS=1
       RETURN
    ENDIF

    IF(RANK.EQ.1)THEN
       QPOLYPOS=POSINDEX(1)+1
       RETURN
    ENDIF

    QPOLYPOS=POSINDEX(1)-POSINDEX(2)+1
    DO I=2,RANK
       IF(I.EQ.RANK)THEN
          IMIN=0
       ELSE
          IMIN=POSINDEX(I+1)
       ENDIF
       DO J=IMIN,POSINDEX(I)-1
          QPOLYPOS=QPOLYPOS+QPOLYNUMBER(J,I-1)
       ENDDO
    ENDDO
    RETURN
  END FUNCTION QPOLYPOS

  FUNCTION NEWQPOLYPOS(RANK,POSINDEX)
    !
    ! COMPUTATION THE RELATIVE POSITION OF INDEX WITH RANK
    ! IN THE *NEW* MADLOOP CONVENTION
    !
    IMPLICIT NONE
    !
    ! CONSTANTS
    !
    INTEGER,PARAMETER::MAXRANK=10
    !
    ! ARGUMENTS
    !
    INTEGER,INTENT(IN)::RANK
    INTEGER,DIMENSION(MAXRANK),INTENT(IN)::POSINDEX
    INTEGER::NEWQPOLYPOS
    !
    ! LOCAL VARIABLES
    !
    INTEGER::I,J,IMIN
    ! ----------
    ! BEGIN CODE
    ! ----------

    IF(RANK.EQ.0)THEN
       NEWQPOLYPOS=1
       RETURN
    ENDIF

    IF(RANK.EQ.1)THEN
       NEWQPOLYPOS=POSINDEX(1)+1
       RETURN
    ENDIF

    NEWQPOLYPOS=1
    DO I=1,RANK
       IF(POSINDEX(RANK-I+1).EQ.0)THEN
          IMIN=0
       ELSE
          ! Eq.(3.4.6) in Valentin's PhD Thesis
          IMIN=factorial(POSINDEX(RANK-I+1)+I-1)/factorial(I)&
               /factorial(POSINDEX(RANK-I+1)-1)
       ENDIF
       NEWQPOLYPOS=NEWQPOLYPOS+IMIN
    ENDDO
    RETURN
  END FUNCTION NEWQPOLYPOS

  FUNCTION QPOLYNUMBER(I,RANK)
    !
    ! THE INDEPENDENT NUMBER OF Q POLY WITH \MU=I,...,3 AND RANK
    !
    IMPLICIT NONE
    !
    ! CONSTANTS
    !
    !
    ! ARGUMENTS
    !
    INTEGER,INTENT(IN)::I,RANK
    INTEGER::QPOLYNUMBER
    !
    ! LOCAL VARIABLES
    !
    ! ----------
    ! BEGIN CODE
    ! ----------
    SELECT CASE(I)
    CASE(0)
       QPOLYNUMBER=(3+RANK)*(2+RANK)*(1+RANK)/6
    CASE(1)
       QPOLYNUMBER=(2+RANK)*(1+RANK)/2
    CASE(2)
       QPOLYNUMBER=(1+RANK)
    CASE(3)
       QPOLYNUMBER=1
    CASE DEFAULT
       STOP 'I must be >= 0 and <=3 in QPOLYNUMBER.'
    END SELECT
    RETURN
  END FUNCTION QPOLYNUMBER

  FUNCTION POS2RANK(ipos)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::ipos
    INTEGER::POS2RANK
    LOGICAL::INIT=.TRUE.
    ! NOW ITS MAX RANK IS 10
    INTEGER,PARAMETER::MAXRANK=10
    INTEGER,DIMENSION(0:MAXRANK)::IRANGE
    INTEGER::I
    SAVE IRANGE,INIT
    IF(INIT)THEN
       IRANGE(0)=0
       DO I=1,MAXRANK
          IRANGE(I)=IRANGE(I-1)+(I+3)*(I+2)*(I+1)/6
       ENDDO
       INIT=.FALSE.
    ENDIF
    IF(ipos.EQ.0)THEN
       POS2RANK=0
       RETURN
    ENDIF
    DO I=1,MAXRANK
       IF(ipos.LE.IRANGE(I))THEN
          POS2RANK=I
          RETURN
       ENDIF
    ENDDO
    WRITE(*,*)"ERROR in POS2RANK,ipos=",ipos
    STOP
  END FUNCTION POS2RANK

  FUNCTION RANK_NUM(MAXRANK)
    IMPLICIT NONE
    INTEGER::RANK_NUM
    INTEGER,INTENT(IN)::MAXRANK
    INTEGER::I
    RANK_NUM=0
    IF(MAXRANK.LT.0)RETURN
    DO I=0,MAXRANK
       RANK_NUM=RANK_NUM+(I+3)*(I+2)*(I+1)/6
    ENDDO
    RETURN
  END FUNCTION RANK_NUM

  SUBROUTINE SHIFT_MOM(MOM,NCOEFS,TICOEFS_SAVE,TICOEFS)
    ! SHIFT MOMENTUM MOM
    IMPLICIT NONE
    !
    ! CONSTANS
    !
    ! MAX RANK SET AS 10
    ! Sum((3+r)*(2+r)*(1+r)/6,{r,0,10})=1001 --> LOOPMAXCOEFS_IREGI
    ! MAX OF (i1+1)*(i2+1)*(i3+1)*(i4+1) with i1+i2+i3+i4<=MAXRANK = 144 --> MAXSPLIT
    INTEGER,PARAMETER::LOOPMAXCOEFS_IREGI=1001,MAXRANK=10,MAXSPLIT=144
    REAL(KIND(1d0)),DIMENSION(0:3),INTENT(IN)::MOM
    INTEGER,INTENT(IN)::NCOEFS
    COMPLEX(KIND(1d0)),DIMENSION(0:NCOEFS-1,1:4),INTENT(IN)::TICOEFS_SAVE
    COMPLEX(KIND(1d0)),DIMENSION(0:NCOEFS-1,1:4),INTENT(OUT)::TICOEFS
    LOGICAL::INIT=.TRUE.
    INTEGER,DIMENSION(0:LOOPMAXCOEFS_IREGI-1)::NTERM
    REAL(KIND(1d0)),DIMENSION(0:LOOPMAXCOEFS_IREGI-1,MAXSPLIT)::SPLIT_FACTOR
    ! i=0-3 -> number of lorentz indices =i
    ! i=4 -> the position of TICOEFS that should be multiplied
    ! e.g. (q+MOM)^mu1(q+MOM)^mu2...(q+MOM)^muk
    ! it can be splitted into q^mu1...q^muk+q^mu1...q^mui Mom^mui+1 ...q^muk ...
    ! for some specific term configurateion mu1=0,mu2=0,...muk=3
    ! NTERM stores the total number of terms
    ! SPLIT_FACTOR is the factor for each term
    ! SPLIT_INFO(J,K,0-3) is the number of 0,1,2,3 with MOM^mu
    ! SPLIT_INFO(J,K,4) is the corresponding q^mu (remaining lorentz indices)
    INTEGER,DIMENSION(0:LOOPMAXCOEFS_IREGI-1,MAXSPLIT,0:4)::SPLIT_INFO
    SAVE INIT,NTERM,SPLIT_FACTOR,SPLIT_INFO
    INTEGER::I,J,K,L,NINDEX,r,incr
    INTEGER::i1,i2,i3,i4,nsplit,itit,rte,ND
    REAL(KIND(1d0))::temp
    INTEGER,DIMENSION(MAXRANK)::POSINDEX
    IF(INIT)THEN
       incr=0
       ND=0
       DO r=0,MAXRANK
          DO I=r,0,-1
             DO J=r-I,0,-1
                DO K=r-I-J,0,-1
                   L=r-I-J-K
                   ! exhaust all of the subsets
                   nsplit=0
                   NTERM(incr)=(I+1)*(J+1)*(K+1)*(L+1)
                   DO i1=0,I
                      !DO itit=1,i1
                      !   POSINDEX(itit)=0
                      !ENDDO
                      DO i2=0,J
                         !DO itit=i1+1,i1+i2
                         !   POSINDEX(itit)=1
                         !ENDDO
                         DO i3=0,K
                            !DO itit=i1+i2+1,i1+i2+i3
                            !   POSINDEX(itit)=2
                            !ENDDO
                            DO i4=0,L
                               !DO itit=i1+i2+i3+1,i1+i2+i3+i4
                               !   POSINDEX(itit)=3
                               !ENDDO
                               nsplit=nsplit+1
                               rte=i1+i2+i3+i4
                               DO itit=1,i1
                                  POSINDEX(rte-itit+1)=0
                               ENDDO
                               DO itit=i1+1,i1+i2
                                  POSINDEX(rte-itit+1)=1
                               ENDDO
                               DO itit=i1+i2+1,i1+i2+i3
                                  POSINDEX(rte-itit+1)=2
                               ENDDO
                               DO itit=i1+i2+i3+1,i1+i2+i3+i4
                                  POSINDEX(rte-itit+1)=3
                               ENDDO
                               SPLIT_INFO(incr,nsplit,4)=QPOLYPOS(rte,POSINDEX)+RANK_NUM(rte-1)-1
                               SPLIT_INFO(incr,nsplit,0)=I-i1
                               SPLIT_INFO(incr,nsplit,1)=J-i2
                               SPLIT_INFO(incr,nsplit,2)=K-i3
                               SPLIT_INFO(incr,nsplit,3)=L-i4
                               SPLIT_FACTOR(incr,nsplit)=DBLE(factorial(I))&
                                    /DBLE(factorial(i1)*factorial(I-i1))
                               SPLIT_FACTOR(incr,nsplit)=SPLIT_FACTOR(incr,nsplit)*&
                                    DBLE(factorial(J))/DBLE(factorial(i2)*factorial(J-i2))
                               SPLIT_FACTOR(incr,nsplit)=SPLIT_FACTOR(incr,nsplit)*&
                                    DBLE(factorial(K))/DBLE(factorial(i3)*factorial(K-i3))
                               SPLIT_FACTOR(incr,nsplit)=SPLIT_FACTOR(incr,nsplit)*&
                                    DBLE(factorial(L))/DBLE(factorial(i4)*factorial(L-i4))
                               IF(.NOT.ML5_CONVENTION)THEN
                                  SPLIT_FACTOR(incr,nsplit)=SPLIT_FACTOR(incr,nsplit)*&
                                       DBLE(factorial(r))/DBLE(factorial(I)*factorial(J))&
                                       /DBLE(factorial(K)*factorial(L))
                                  SPLIT_FACTOR(incr,nsplit)=SPLIT_FACTOR(incr,nsplit)/&
                                       DBLE(factorial(rte))*DBLE(factorial(i1))*DBLE(factorial(i2))*&
                                       DBLE(factorial(i3))*DBLE(factorial(i4))
                               ENDIF
                            ENDDO
                         ENDDO
                      ENDDO
                   ENDDO
                   incr=incr+1
                ENDDO
             ENDDO
          ENDDO
          ND=ND+(3+r)*(2+r)*(1+r)/6
       ENDDO
       INIT=.FALSE.
    ENDIF
    DO I=0,NCOEFS-1
       TICOEFS(I,1:4)=DCMPLX(0d0)
       DO J=1,NTERM(I)
          temp=SPLIT_FACTOR(I,J)
          DO K=0,3
             NINDEX=SPLIT_INFO(I,J,K)
             IF(NINDEX.GT.0)THEN
                temp=temp*MOM(K)**NINDEX
             ENDIF
          ENDDO
          TICOEFS(I,1:4)=TICOEFS(I,1:4)&
               +TICOEFS_SAVE(SPLIT_INFO(I,J,4),1:4)*temp
       ENDDO
    ENDDO
    RETURN
  END SUBROUTINE SHIFT_MOM

  FUNCTION xiarray_arg1(i,n)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::i,n
    INTEGER::xiarray_arg1
    INTEGER::imax,imin,j
    !INTEGER(KIND=LINT)::itemp
    IF(i+n-1.GT.12)THEN
       imax=MAX(n-1,i)
       imin=MIN(n-1,i)
       xiarray_arg1=1
       DO j=imax+1,i+n-1
          xiarray_arg1=xiarray_arg1*j
       ENDDO
       IF(imin.LE.12)THEN
          xiarray_arg1=xiarray_arg1/factorial(imin)
       ELSE
          DO j=1,imin
             xiarray_arg1=xiarray_arg1/j
          ENDDO
       ENDIF
    ELSE
       xiarray_arg1=factorial(i+n-1)/factorial(n-1)/factorial(i)
    ENDIF
    RETURN
  END FUNCTION xiarray_arg1
END MODULE FUNLIB


subroutine take_crank_nicolson_step(t, dt, q, success)

! Take a time step using Crank-Nicolson.
!
! Args:
!   t: Time before the step.
!   dt: Length of time step.
!   q: PDE solution being advanced.
!   success: Indicates whether Newton's method in the backward Euler stage
!     converged.

    implicit none

    integer :: mx, mbc, meqn
    double precision :: x_lower, dx
    common /claw_config/ mx, mbc, x_lower, dx, meqn

    double precision, intent(in) :: t, dt
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(inout) :: q
    logical, intent(out) :: success

    call take_forward_euler_step(t, dt/2, q)
    call take_backward_euler_step(t + dt/2, dt/2, q, success)

end subroutine take_crank_nicolson_step


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     AN EXAMPLE SHOWING THE USE OF SEPELI TO SOLVE THE SEPARABLE
C     ELLIPTIC PARTIAL DIFFERENTIAL EQUATION . . .
C     (X+1)**2*UXX+2*(X+1)*UX+EXP(Y)*UYY-(X+Y)*U = G(X,Y) ON
C     0.LE.X.LE.1, 0.LE.Y.LE.1  WITH SPECIFIED BOUNDARY CONDITIONS
C     AT Y=0,1 AND MIXED BOUNDARY CONDITIONS OF THE FORM
C     UX(0,Y)+U(0,Y), UX(1,Y)+U(1,Y) AT X=0,1.
C     THE APPROXIMATION IS GENERATED ON A UNIFORM 33 BY 33 GRID.
C     THE EXACT SOLUTION U(X,Y)=(X*Y)**3+1 IS USED TO SET THE
C     RIGHT HAND SIDE, BOUNDARY CONDITIONS, AND COMPUTE  SECOND AND
C     FOURTH ORDER DISCRETIZATION ERROR
C     THE EXACT WORK SPACE LENGTH REQUIRED IS 1118 WORDS.
C     THIS WAS DETERMINED BY A PREVIOUS CALL TO SEPELI  AND PRINT
C     OUT OF W(1).
C
      DIMENSION       USOL(33,33),GRHS(33,33),BDA(33)    ,BDB(33)    ,
     1                W(1118)
C
C     DECLARE COEFFICIENT SUBROUTINES EXTERNAL
C
      EXTERNAL        COFX       ,COFY
C
C     DEFINE ARITHMETIC FUNCTIONS GIVING EXACT SOLUTION
C
      UE(S,T) = (S*T)**3+1.0
      UXE(S,T) = 3.0*S**2*T**3
      UXXE(S,T) = 6.0*S*T**3
      UYE(S,T) = 3.0*S**3*T**2
      UYYE(S,T) = 6.0*S**3*T
C
C     SET LIMITS ON REGION
C
      A = 0.0
      B = 1.0
      C = 0.0
      D = 1.0
C
C     SET GRID SIZE
C
      M = 32
      N = 32
      DLX = (B-A)/FLOAT(M)
      DLY = (D-C)/FLOAT(N)
      NX = M+1
      NY = N+1
      DO 102 I=1,NX
         X = A+FLOAT(I-1)*DLX
C
C     SET SPECIFIED BOUNDARY CONDITIONS AT Y=C,D
C
         USOL(I,1) = UE(X,C)
         USOL(I,NY) = UE(X,D)
         CALL COFX (X,AF,BF,CF)
         DO 101 J=1,NY
            Y = C+FLOAT(J-1)*DLY
            CALL COFY (Y,DF,EF,FF)
C
C     SET RIGHT HAND SIDE
C
            GRHS(I,J) = AF*UXXE(X,Y)+BF*UXE(X,Y)+CF*UE(X,Y)+
     1                  DF*UYYE(X,Y)+EF*UYE(X,Y)+FF*UE(X,Y)
  101    CONTINUE
  102 CONTINUE
C
C     SET MIXED BOUNDARY CONDITIONS AT X=A,B
C
      ALPHA = 1.0
      BETA = 1.0
      DO 103 J=1,NY
         Y = C+FLOAT(J-1)*DLY
         BDA(J) = UXE(A,Y)+ALPHA*UE(A,Y)
         BDB(J) = UXE(B,Y)+BETA*UE(B,Y)
  103 CONTINUE
C
C     SET BOUNDARY SWITHCES
C
      MBDCND = 3
      NBDCND = 1
C
C     SET FIRST DIMENSION OF USOL,GRHS AND WORK SPACE LENGTH
C
      IDMN = 33
      W(1) = 1118.
C
C     SET WORK SPACE LENGTH IN FIRST WORD
C     SET INITIAL CALL PARAMETER TO ZERO
C
      INTL = 0
C
C     OBTAIN SECOND ORDER APPROXIMATION
C
      IORDER = 2
      CALL SEPELI (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1             NBDCND,DUM,DUM,DUM,DUM,COFX,COFY,GRHS,USOL,IDMN,W,
     2             PERTRB,IERROR)
      ERR = 0.0
      DO 105 I=1,NX
         X = A+FLOAT(I-1)*DLX
         DO 104 J=1,NY
            Y = C+FLOAT(J-1)*DLY
            ERR = AMAX1(ERR,ABS((USOL(I,J)-UE(X,Y))/UE(X,Y)))
  104    CONTINUE
  105 CONTINUE
      ERR2 = ERR
C
C     OBTAIN FOURTH ORDER APPROXIMATION
C
      IORDER = 4
C
C     NON-INITIAL CALL
C
      INTL = 1
      CALL SEPELI (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1             NBDCND,DUM,DUM,DUM,DUM,COFX,COFY,GRHS,USOL,IDMN,W,
     2             PERTRB,IERROR)
C
C     COMPUTE DISCRETIZATION ERROR
C
      ERR = 0.0
      DO 107 J=1,NY
         Y = C+FLOAT(J-1)*DLY
         DO 106 I=1,NX
            X = A+FLOAT(I-1)*DLX
            ERR = AMAX1(ERR,ABS((USOL(I,J)-UE(X,Y))/UE(X,Y)))
  106    CONTINUE
  107 CONTINUE
      ERR4 = ERR
      IW = INT(W(1))
      PRINT 1001 , IERROR,ERR2,ERR4,IW
C
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE SEPELI EXAMPLE///
     1        20X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        20X,10HIERROR = 0/
     3        20X,47HSECOND ORDER DISCRETIZATION ERROR = 9.78910E-05/
     4        20X,47HFOURTH ORDER DISCRETIZATION ERROR = 1.47351E-06/
     5        20X,33HREQUIRED LENGTH OF W ARRAY = 1118//
     6        20X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     7        20X,8HIERROR =,I2/
     8        20X,36HSECOND ORDER DISCRETIZATION ERROR = , E12.5/
     9        20X,36HFOURTH ORDER DISCRETIZATION ERROR = , E12.5/
     +        20X,29HREQUIRED LENGTH OF W ARRAY = , I4)
C
      END
      SUBROUTINE COFX (X,AF,BF,CF)
C
C     SET COEFFICIENTS IN THE X-DIRECTION.
C
      AF = (X+1.)**2
      BF = 2.0*(X+1.)
      CF = -X
      RETURN
      END
      SUBROUTINE COFY (Y,DF,EF,FF)
C
C     SET COEFFICIENTS IN Y DIRECTION
C
      DF = EXP(Y)
      EF = 0.0
      FF = -Y
      RETURN
      END


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!
!     6/98
!
!     a program for testing all vorticity and inverse vorticity routines
!
!
!     (1) first set a stream function and velocity potential scalar fields as
!         polys in x, y, z restricted to the sphere
!
!     (2) derive a vector field (v, w) from (1)
!
!     (3) compute the vorticity vt of (2) and compare with the vorticity
!         computed analytically
!
!     (4) compute vector field (ve, we) using br, bi, cr, ci from (v, w) with
!         br=bi=0.0
!
!     (5) invert the vorticity in (3) and compare with (4)
!

program tvrt

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack, only: &
        ip, & ! Integer precision
        wp, & ! Working precision
        Sphere, &
        Regularsphere, &
        GaussianSphere

    ! Explicit typing only
    implicit none

    ! Dictionary
    class(Sphere), allocatable :: solver

    ! Test gaussian grid
    allocate (GaussianSphere :: solver)
    call test_vorticity_routines(solver)
    deallocate (solver)

    ! Test regular grid
    allocate (RegularSphere :: solver)
    call test_vorticity_routines(solver)
    deallocate (solver)

contains

    subroutine test_vorticity_routines(sphere_type)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: sphere_type

        ! Local variables
        integer(ip), parameter        :: NLONS = 14
        integer(ip), parameter        :: NLATS = 24
        integer(ip), parameter        :: NSYNTHS = 3
        integer(ip)                   :: i, j, k ! Counters
        real(wp)                      :: exact_polar_component(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: exact_azimuthal_component(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: exact_vorticity(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: approximate_polar_component(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: approximate_azimuthal_component(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: approximate_vorticity(NLATS, NLONS, NSYNTHS)
        character(len=:), allocatable :: previous_vorticity_error
        character(len=:), allocatable :: previous_polar_inversion_error
        character(len=:), allocatable :: previous_azimuthal_inversion_error

        !  Set up workspace arrays
        select type(sphere_type)
            type is (GaussianSphere)

            ! Initialize gaussian sphere object
            sphere_type = GaussianSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (previous_vorticity_error, source='     vorticity error     = 8.246182e-14')
            allocate (previous_polar_inversion_error, source='     polar inversion error     = 2.331468e-15')
            allocate (previous_azimuthal_inversion_error, source='     azimuthal inversion error = 4.107825e-15')

            type is (RegularSphere)

            ! Initialize regular sphere object
            sphere_type = RegularSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (previous_vorticity_error, source='     vorticity error     = 2.375877e-14')
            allocate (previous_polar_inversion_error, source='     polar inversion error     = 1.110223e-15')
            allocate (previous_azimuthal_inversion_error, source='     azimuthal inversion error = 1.887379e-15')
        end select

        !
        !  set scalar stream and velocity potential fields as polys in x, y, z
        !    and then set v, w from st, sv scalar fields
        !
        associate (&
            ve => exact_polar_component, &
            we => exact_azimuthal_component, &
            vte => exact_vorticity, &
            radial => sphere_type%unit_vectors%radial, &
            theta => sphere_type%unit_vectors%polar, &
            phi => sphere_type%unit_vectors%azimuthal &
           )
            do k=1, NSYNTHS
                do j=1, NLONS
                    do i=1, NLATS
                        associate (&
                            x => radial(i, j)%x, & !sint*cosp
                            y => radial(i, j)%y, & !sint*sinp
                            z => radial(i, j)%z, & !cost
                            dxdt => theta(i, j)%x, &! cost*cosp
                            dxdp => -radial(i, j)%y, & !-sint*sinp
                            dydt => theta(i, j)%y, &! cost*sinp
                            dydp => radial(i, j)%x, & ! sint*cosp
                            dzdt => theta(i, j)%z, & ! -sint
                            dzdp => phi(i, j)%z, & ! 0.0
                            cosp => phi(i, j)%y, &
                            sinp => -phi(i, j)%x &
                           )
                            select case (k)
                                case (1)
                                    ve(i, j, k) = sinp + dydt !sinp + cost*sinp
                                    we(i, j, k) = cosp + dxdt !cosp + cost*cosp
                                    vte(i, j, k) = -2.0_wp * x !-2.0*sint*cosp
                                case (2)
                                    ve(i, j, k) = -cosp + dzdt !-cosp-sint
                                    we(i, j, k) = dydt !cost*sinp
                                    vte(i, j, k) = -2.0_wp * y !-2.*sint*sinp
                                case (3)
                                    ve(i, j, k) = sinp + dzdt !sinp - sint
                                    we(i, j, k) = dxdt !cost*cosp
                                    vte(i, j, k) = -2.0_wp * x !-2.*sint*cosp
                            end select
                        end associate
                    end do
                end do
            end do
        end associate

        !
        !  Compute vt from (ve, we)
        !
        do k=1, NSYNTHS
            associate (&
                ve => exact_polar_component(:, :, k), &
                we => exact_azimuthal_component(:, :, k), &
                vt => approximate_vorticity(:, :, k) &
               )
                call sphere_type%get_vorticity(ve, we, vt)
            end associate
        end do
        !
        !  Compute vorticity error
        !
        associate (&
            vt => approximate_vorticity, &
            vte => exact_vorticity &
           )
            associate (err2 => maxval(abs(vt-vte)))
                !
                !  Print earlier output from platform with 64-bit floating point
                !    arithmetic followed by the output from this computer
                !
                write (stdout, '(/a/)') '     tvrt *** TEST RUN *** '
                write (stdout, '(a)') '     grid type = '//sphere_type%grid%grid_type
                write (stdout, '(a)') '     Testing vorticity'
                write (stdout, '(2(a, i3))') '     nlat = ', NLATS, ' nlon = ', NLONS
                write (stdout, '(a)') '     Previous 64 bit floating point arithmetic result '
                write (stdout, '(a)') previous_vorticity_error
                write (stdout, '(a)') '     The output from your computer is: '
                write (stdout, '(a, 1pe15.6/)') '     vorticity error     = ', err2
            end associate
        end associate
        !
        !  Now recompute (v, w) inverting vte
        !
        do k=1, NSYNTHS
            associate (&
                v => approximate_polar_component(:, :, k), &
                w => approximate_azimuthal_component(:, :, k), &
                vte => exact_vorticity(:, :, k) &
               )
                call sphere_type%invert_vorticity(vte, v, w)
            end associate
        end do

        !
        !  compute vector field (ve, we) using br, bi, cr, ci from (ve, we) with
        !    br = bi = 0.0
        !
        do k = 1, NSYNTHS
            associate (&
                ve => exact_polar_component(:, :, k), &
                we => exact_azimuthal_component(:, :, k) &
               )
                !
                !  Get polar coefficients (br, bi) and azimuthal coefficients (cr, ci) from (ve, we)
                !
                call sphere_type%vector_analysis_from_spherical_components(ve, we)
                !
                !  Set polar coefficients to zero
                !
                associate (&
                    br => sphere_type%workspace%vector_coefficients%polar%real_component, &
                    bi => sphere_type%workspace%vector_coefficients%polar%imaginary_component &
                   )
                    br = 0.0_wp; bi = 0.0_wp
                end associate
                !
                !  Synthesize azimuthal coefficients (cr, ci) into (ve, we)
                !
                call sphere_type%perform_vector_synthesis(ve, we)
            end associate
        end do
        !
        !  compare this v, w with original
        !
        associate (&
            ve => exact_polar_component, &
            we => exact_azimuthal_component, &
            v => approximate_polar_component, &
            w => approximate_azimuthal_component &
           )
            associate (&
                err2v => maxval(abs(v-ve)), &
                err2w => maxval(abs(w-we)) &
               )
                !
                !  Print earlier output from platform with 64-bit floating point
                !    arithmetic followed by the output from this computer
                !
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     tvrt *** TEST RUN *** '
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     grid type = '//sphere_type%grid%grid_type
                write (stdout, '(a)') '     Testing vorticity inversion'
                write (stdout, '(2(a, i3))') '     nlat = ', NLATS, ' nlon = ', NLONS
                write (stdout, '(a)') '     Previous 64 bit floating point arithmetic result '
                write (stdout, '(a)') previous_polar_inversion_error
                write (stdout, '(a)') previous_azimuthal_inversion_error
                write (stdout, '(a)') '     The output from your computer is: '
                write (stdout, '(a, 1pe15.6)') '     polar inversion error     = ', err2v
                write (stdout, '(a, 1pe15.6)') '     azimuthal inversion error = ', err2w
                write (stdout, '(a)') ''
            end associate
        end associate

        !  Release memory
        deallocate (previous_vorticity_error)
        deallocate (previous_polar_inversion_error)
        deallocate (previous_azimuthal_inversion_error)
        call sphere_type%destroy()

    end subroutine test_vorticity_routines

end program tvrt


      SUBROUTINE FORRT(X, M)
C
C     ALGORITHM AS 97  APPL. STATIST. (1976) VOL.25, NO. 2
C
C     Forward discrete Fourier transform in one dimension of real
C     data using complex transform subroutine FASTG.
C
C     X = array of real input data, type real, dimension M.
C     M = length of the transform, must be a power of 2.
C     The minimum length is 8, maximum 2**21.
C
C     The result is placed in X as described in the text of the paper.
C
C     Auxiliary routines required: SCRAG (or SCRAM) & FASTG from AS 83,
C     but with SCRAG modified as described on page 168 of the paper for
C     this algorithm.
C
      REAL X(M)
      DATA ZERO/0.0/, QUART/0.25/, HALF/0.5/, ONE/1.0/, ONE5/1.5/,
     *	TWO/2.0/, FOUR/4.0/
C
C     Check for valid transform size.
C
      II = 8
      DO 2 K = 3, 21
	IPOW = K
	IF (II .EQ. M) GO TO 3
	II = II * 2
    2 CONTINUE
C
C     If this point is reached, an illegal size was specified.
C
      RETURN
    3 PIE = FOUR * ATAN(ONE)
C
C     Separate odd and even parts into two halves.
C     First bit reverse the whole array of length M.
C
      CALL SCRAG(X, M, IPOW)
C
C     Next bit reverse the half arrays separately.
C
      N = M / 2
      JPOW = IPOW - 1
      CALL SCRAG(X, N, JPOW)
      CALL SCRAG(X(N+1), N, JPOW)
C
C     Faster alternative to the two lines above to SCRAM.
C     	CALL SCRAM(X, X(N+1), N, JPOW)
C
C     Now do the transform.
C
      CALL FASTG(X, X(N+1), N, 1)
C
C     Unscramble the transform results.
C
      CALL SCRAG(X, N, JPOW)
      CALL SCRAG(X(N+1), N, JPOW)
C
C     Faster alternative to the two lines above to SCRAM.
C     	CALL SCRAM(X, X(N+1), N, JPOW)
C
      NN = N / 2
C
C     Now unravel the result; first the special cases.
C
      Z = HALF * (X(1) + X(N+1))
      X(N+1) = HALF * (X(1) - X(N+1))
      X(1) = Z
      NN1 = NN + 1
      NN2 = NN1 + N
      X(NN1) = HALF * X(NN1)
      X(NN2) = -HALF * X(NN2)
      Z = PIE / N
      BCOS = -TWO * (SIN(Z / TWO) **2)
      BSIN = SIN(Z)
      UN = ONE
      VN = ZERO
      DO 4 K = 2, NN
	Z = UN * BCOS + VN * BSIN + UN
	VN = VN * BCOS - UN * BSIN + VN
	SAVE1 = ONE5 - HALF * (Z * Z + VN * VN)
	UN = Z * SAVE1
	VN = VN * SAVE1
	KI = N + K
	L = N + 2 - K
	LI = N + L
	AN = QUART * (X(K) + X(L))
	BN = QUART * (X(KI) - X(LI))
	CN = QUART * (X(KI) + X(LI))
	DN = QUART * (X(L) - X(K))
	XN = UN * CN - VN * DN
	YN = UN * DN + VN * CN
	X(K) = AN + XN
	X(KI) = BN + YN
	X(L) = AN - XN
	X(LI) = YN - BN
    4 CONTINUE
      RETURN
      END
C

      SUBROUTINE REVRT(X, M)
C
C     ALGORITHM AS 97.1  APPL. STATIST. (1976) VOL.25, NO. 2
C
C     Inverse discrete Fourier transform in one dimension of real
C     data using complex transform subroutine FASTG.
C
C     X = array of Fourier components as output from subroutine FORRT,
C         type real, dimension M.
C     M = length of the inverse transform, must be a power of 2.
C     The minimum length is 8, maximum 2**21.
C
C     Auxiliary routines required: SCRAG & FASTG from AS 83, but
C     with SCRAG modified as described on page 168 of the paper for
C     this algorithm.
C
      REAL X(M)
      DATA ZERO/0.0/, HALF/0.5/, ONE/1.0/, ONE5/1.5/,
     *	TWO/2.0/, FOUR/4.0/
C
C     Check for valid transform size.
C
      II = 8
      DO 2 K = 3, 21
	IPOW = K
	IF (II .EQ. M) GO TO 3
	II = II * 2
    2 CONTINUE
C
C     If this point is reached, an illegal size was specified.
C
      RETURN
    3 PIE = FOUR * ATAN(ONE)
      N = M / 2
      NN = N / 2
C
C     Undo the spectrum into that of two interleaved series.
C     First, the special cases.
C
      Z = X(1) + X(N+1)
      X(N+1) = X(1) - X(N+1)
      X(1) = Z
      NN1 = NN + 1
      NN2 = NN1 + N
      X(NN1) = TWO * X(NN1)
      X(NN2) = -TWO * X(NN2)
      Z = PIE / N
      BCOS = -TWO * (SIN(Z / TWO) **2)
      BSIN = SIN(Z)
      UN = ONE
      VN = ZERO
      DO 4 K = 2, NN
	Z = UN * BCOS + VN * BSIN + UN
	VN = VN * BCOS - UN * BSIN + VN
	SAVE1 = ONE5 - HALF * (Z * Z + VN * VN)
	UN = Z * SAVE1
	VN = VN * SAVE1
	KI = N + K
	L = N + 2 - K
	LI = N + L
	AN = X(K) + X(L)
	BN = X(KI) - X(LI)
	PN = X(K) - X(L)
	QN = X(KI) + X(LI)
	CN = UN * PN + VN * QN
	DN = UN * QN - VN * PN
	X(K) = AN - DN
	X(KI) = BN + CN
	X(L) = AN + DN
	X(LI) = CN - BN
    4 CONTINUE
C
C     Now do the inverse transform
C
      CALL FASTG(X, X(N+1), N, -1)
C
C     Now undo the order - the half arrays are already bit reversed;
C     bit reverse the whole array.
C
      CALL SCRAG(X, M, IPOW)
      RETURN
      END
C
	subroutine fastg(xreal, ximag, n, itype)
c
c       Algorithm AS 83.2 Appl. Statist. (1975) vol.24, no.1
c
c       Radix 4 complex discrete fast Fourier transform without
c       unscrambling, suitable for convolutions or other applications
c       which do not require unscrambling.   Called by subroutine
c       FASTF which also does the unscrambling.
c
	real    xreal(n), ximag(n)
	data    zero, half, one, one5, two, four
     +          /0.0,  0.5, 1.0,  1.5, 2.0,  4.0/
	pi = four * atan(one)
	ifaca = n / 4
	if (itype .eq. 0) return
	if (itype .gt. 0) go to 5
c
c       ITYPE < 0 indicates inverse transform required.
c       Calculate conjugate.
c
	do 4 k = 1, n
    4   ximag(k) = -ximag(k)
c
c       Following code is executed for IFACA = N/4, N/16, N/64, ...
c       until IFACA <= 1.
c
    5   ifcab = ifaca * 4
	z = pi / ifcab
	bcos = -two * sin(z)**2
	bsin = sin(two * z)
	cw1 = one
	sw1 = zero
	do 10 litla = 1, ifaca
	  do 8 i0 = litla, n, ifcab
	    i1 = i0 + ifaca
	    i2 = i1 + ifaca
	    i3 = i2 + ifaca
	    xs0 = xreal(i0) + xreal(i2)
	    xs1 = xreal(i0) - xreal(i2)
	    ys0 = ximag(i0) + ximag(i2)
	    ys1 = ximag(i0) - ximag(i2)
	    xs2 = xreal(i1) + xreal(i3)
	    xs3 = xreal(i1) - xreal(i3)
	    ys2 = ximag(i1) + ximag(i3)
	    ys3 = ximag(i1) - ximag(i3)
	    xreal(i0) = xs0 + xs2
	    ximag(i0) = ys0 + ys2
	    x1 = xs1 + ys3
	    y1 = ys1 - xs3
	    x2 = xs0 - xs2
	    y2 = ys0 - ys2
	    x3 = xs1 - ys3
	    y3 = ys1 + xs3
	    if (litla .eq. 1) then
	      xreal(i2) = x1
	      ximag(i2) = y1
	      xreal(i1) = x2
	      ximag(i1) = y2
	      xreal(i3) = x3
	      ximag(i3) = y3
	    else
	      xreal(i2) = x1 * cw1 + y1 * sw1
	      ximag(i2) = y1 * cw1 - x1 * sw1
	      xreal(i1) = x2 * cw2 + y2 * sw2
	      ximag(i1) = y2 * cw2 - x2 * sw2
	      xreal(i3) = x3 * cw3 + y3 * sw3
	      ximag(i3) = y3 * cw3 - x3 * sw3
	    end if
    8     continue
c
c       Calculate a new set of twiddle factors.
c
	  if (litla .lt. ifaca) then
	    z = cw1 * bcos - sw1 * bsin + cw1
	    sw1 = bcos * sw1 + bsin * cw1 + sw1
	    tempr = one5 - half * (z * z + sw1 * sw1)
	    cw1 = z * tempr
	    sw1 = sw1 * tempr
	    cw2 = cw1 * cw1 - sw1 * sw1
	    sw2 = two * cw1 * sw1
	    cw3 = cw1 * cw2 - sw1 * sw2
	    sw3 = cw1 * sw2 + cw2 * sw1
	  end if
   10   continue
	if (ifaca .le. 1) go to 14
c
c       Set up the transform split for the next stage.
c
	ifaca = ifaca / 4
	if (ifaca .gt. 0) go to 5
c
c       Radix 2 calculation, if needed.
c
	if (ifaca .lt. 0) return
	do 13 k = 1, n, 2
	  tempr = xreal(k) + xreal(k+1)
	  xreal(k+1) = xreal(k) - xreal(k+1)
	  xreal(k) = tempr
	  tempr = ximag(k) + ximag(k+1)
	  ximag(k+1) = ximag(k) - ximag(k+1)
	  ximag(k) = tempr
   13   continue
   14   if (itype .lt. 0) then
c
c       Inverse transform; conjugate the result.
c
	  do 16 k = 1, n
   16     ximag(k) = -ximag(k)
	  return
	end if
c
c       Forward transform
c
	z = one / n
	do 18 k = 1, n
	  xreal(k) = xreal(k) * z
	  ximag(k) = ximag(k) * z
   18   continue
c
	return
	end
c
c
c
	subroutine scrag(xreal, n, ipow)
c
c       Algorithm AS 83.3 Appl. Statist. (1975) vol.24, no.1
c ***   MODIFIED FOR USE WITH AS 97 ***
c
c       Subroutine for unscrambling FFT data.
c
	real    xreal(n)
	integer l(19)
	equivalence (l1,l(1)), (l2,l(2)), (l3,l(3)), (l4,l(4)),
     +          (l5,l(5)), (l6,l(6)), (l7,l(7)), (l8,l(8)), (l9,l(9)),
     +          (l10,l(10)), (l11,l(11)), (l12,l(12)), (l13,l(13)),
     +          (l14,l(14)), (l15,l(15)), (l16,l(16)), (l17,l(17)),
     +          (l18,l(18)), (l19,l(19))
c
	ii = 1
	itop = 2 ** (ipow - 1)
	i = 20 - ipow
	do 5 k = 1, i
    5   l(k) = ii
	l0 = ii
	i = i + 1
	do 6 k = i, 19
	  ii = ii * 2
	  l(k) = ii
    6   continue
c
	ii = 0
	do 9 j1 = 1, l1, l0
	  do 9 j2 = j1, l2, l1
	    do 9 j3 = j2, l3, l2
	      do 9 j4 = j3, l4, l3
		do 9 j5 = j4, l5, l4
		  do 9 j6 = j5, l6, l5
		    do 9 j7 = j6, l7, l6
		      do 9 j8 = j7, l8, l7
			do 9 j9 = j8, l9, l8
			  do 9 j10 = j9, l10, l9
			    do 9 j11 = j10, l11, l10
			      do 9 j12 = j11, l12, l11
				do 9 j13 = j12, l13, l12
				  do 9 j14 = j13, l14, l13
				    do 9 j15 = j14, l15, l14
				      do 9 j16 = j15, l16, l15
					do 9 j17 = j16, l17, l16
					  do 9 j18 = j17, l18, l17
					    do 9 j19 = j18, l19, l18
					      j20 = j19
					      do 9 i = 1, 2
						ii = ii + 1
						if (ii .lt. j20) then
c
c       J20 is the bit-reverse of II pairwise interchange.
c
						  tempr = xreal(ii)
						  xreal(ii) = xreal(j20)
						  xreal(j20) = tempr
						end if
						j20 = j20 + itop
    9   continue
c
	return
	end


 SUBROUTINE ZHPSV_F95( AP, B, UPLO, IPIV, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => DP
    USE LA_AUXMOD, ONLY: ERINFO, LSAME
    USE F77_LAPACK, ONLY: HPSV_F77 => LA_HPSV
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IPIV(:)
    COMPLEX(WP), INTENT(INOUT) :: AP(:), B(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!     LA_SPSV computes the solution to a linear system of equations
! A*X = B, where A is a real or complex symmetric matrix stored in packed
! format and X and B are rectangular matrices or vectors. A diagonal
! pivoting method is used to factor A as
!    A = U*D*U^T if UPLO = 'U', or A = L*D*L^T if UPLO = 'L'
! where U (or L) is a product of permutation and unit upper (or lower)
! triangular matrices, and D is a symmetric block diagonal matrix with
! 1 by 1 and 2 by 2 diagonal blocks. The factored form of A is then used
! to solve the above system.
!     LA_HPSV computes the solution to a linear system of equations
! A*X = B, where A is a complex Hermitian matrix stored in packed format
! and X and B are rectangular matrices or vectors. A diagonal pivoting
! method is used to factor A as
!     A = U*D*U^H if UPLO = 'U', or A = L*D*L^H if UPLO = 'L'
! where U (or L) is a product of permutation and unit upper (or lower)
! triangular matrices, and D is a complex Hermitian block diagonal matrix
! with 1 by 1 and 2 by 2 diagonal blocks. The factored form of A is then
! used to solve the above system.
!
! =========
!
!      SUBROUTINE LA_SPSV / LA_HESV( AP, B, UPLO=uplo, &
!                                 IPIV=ipiv, INFO=info )
!          <type>(<wp>), INTENT(INOUT) :: AP(:), <rhs>
!          CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!          INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:)
!          INTEGER, INTENT(OUT), OPTIONAL :: INFO
!      where
!          <type> ::= REAL | COMPLEX
!          <wp>   ::= KIND(1.0) | KIND(1.0D0)
!          <rhs>  ::= B(:,:) | B(:)
!
! Arguments
! =========
!
! AP       (input/output) REAL or COMPLEX array, shape (:) with size(AP)=
!          n*(n + 1)=2, where n is the order of A.
!          On entry, the upper or lower triangle of matrix A in packed
! 	   storage. The elements are stored columnwise as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j<=n;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for 1<=j<=i<=n.
!          On exit, the block diagonal matrix D and the multipliers used
! 	   to obtain U or L from the factorization of A, stored as a
! 	   packed triangular matrix in the same storage format as A.
! B        (input/output) REAL or COMPLEX array, shape (:,:) with
!          size(B,1) = n or shape (:) with size(B) = n.
!          On entry, the matrix B.
!          On exit, the solution matrix X .
! UPLO     Optional (input) CHARACTER(LEN=1)
!             = 'U': Upper triangle of A is stored;
!             = 'L': Lower triangle of A is stored.
!          Default value: 'U'.
! IPIV     Optional (output) INTEGER array, shape (:) with size(IPIV)=n.
!          Details of the row and column interchanges and the block
! 	   structure of D.
!          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
! 	   interchanged, and D(k,k) is a 1 by 1 diagonal block.
!          If IPIV k < 0, then there are two cases:
!            1. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows
! 	      and columns (k-1) and -IPIV(k) were interchanged and
! 	      D(k-1:k,k-1:k) is a 2 by 2 diagonal block.
!            2. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, then rows
! 	      and columns (k + 1) and -IPIV(k) were interchanged and
! 	      D(k:k+1,k:k+1) is a 2 by 2 diagonal block.
! INFO     Optional (output) INTEGER.
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value.
!          > 0: if INFO = i, D(i,i) = 0. The factorization has been
! 	     completed, but the block diagonal matrix D is singular,
! 	     so the solution could not be computed.
!          If INFO is not present and an error occurs, then the program
! 	   is terminated with an error message.
!----------------------------------------------------------------------
!   .. PARAMETERS ..
    CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_HPSV'
!   .. LOCAL SCALARS ..
    CHARACTER(LEN=1) :: LUPLO
    INTEGER :: LINFO, N, NN, NRHS, SIPIV, ISTAT, ISTAT1
    COMPLEX(WP) :: WW
!   .. LOCAL POINTERS ..
    INTEGER, POINTER :: LPIV(:)
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, PRESENT, REAL, INT, AIMAG
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; ISTAT = 0; NN = SIZE(AP); NRHS = SIZE(B,2)
    WW = (-1+SQRT(1+8*REAL(NN,WP)))*0.5; N = INT(WW)
    IF( PRESENT(UPLO) )THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
    IF( PRESENT(IPIV) )THEN; SIPIV = SIZE(IPIV); ELSE; SIPIV = N; END IF
!   .. TEST THE ARGUMENTS
    IF( NN < 0 .OR. AIMAG(WW) /= 0 .OR. REAL(N,WP) /= REAL(WW) ) THEN; LINFO = -1
    ELSE IF( SIZE( B, 1 ) /= N .OR. NRHS < 0 ) THEN; LINFO = -2
    ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -3
    ELSE IF( SIPIV /= N )THEN; LINFO = -4
    ELSE IF ( N > 0 ) THEN
      IF( PRESENT(IPIV) )THEN; LPIV => IPIV
      ELSE; ALLOCATE( LPIV(N), STAT = ISTAT ); END IF
      IF( ISTAT == 0 ) THEN
         CALL HPSV_F77( LUPLO, N, NRHS, AP, LPIV, B, N, LINFO )
      ELSE; LINFO = -100; END IF
      IF( .NOT.PRESENT(IPIV) )DEALLOCATE(LPIV, STAT = ISTAT1 )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
 END SUBROUTINE ZHPSV_F95


! { dg-do  run }
! Test for run-time simplification of minval
program main
  implicit none
  integer, dimension(2,3), parameter :: i = &
       & reshape([-1,2,-3,5,-7,11], shape(i))
  integer, dimension(3), parameter :: im1 = minval(i,dim=1)
  integer, parameter :: im2 = minval(i,mask=i>4)
  integer, dimension(2), parameter :: im3 = minval(i,dim=2)
  integer, parameter :: im4 = minval(i, mask=i>-1)
  integer, dimension(3), parameter :: im5 = minval(i,dim=1,mask=i>4)
  integer, dimension(2), parameter :: im6 = minval(i,dim=2,mask=i>4)

  real, dimension(2,3), parameter :: r = &
       & reshape([-1.,2.,-3.,5.,-7.,11.], shape(r))
  real, dimension(3), parameter :: rm1 = minval(r,dim=1)
  real, parameter :: rm2 = minval(r,mask=r>4)
  real, dimension(2), parameter :: rm3 = minval(r,dim=2)
  real, parameter :: rm4 = minval(r, mask=r>-1)
  real, dimension(3), parameter :: rm5 = minval(r,dim=1,mask=r>4)
  real, dimension(2), parameter :: rm6 = minval(r,dim=2,mask=r>4)

  character(len=3), parameter :: maxv = achar(255) // achar(255) // achar(255)
  character(len=3), dimension(2,3), parameter :: c = &
       reshape(["asd", "fgh", "qwe", "jkl", "ert", "zui"], shape(c))
  character(len=3), parameter :: cm1 = minval(c)
  character(len=3), dimension(3), parameter :: cm2 = minval(c,dim=1)
  character(len=3), dimension(2), parameter :: cm3 = minval(c,dim=2)
  character(len=3), parameter :: cm4 = minval (c, c>"g")
  character(len=3), dimension(3), parameter :: cm5 = minval(c,dim=1,mask=c>"g")

  if (any (im1 /= [ -1, -3, -7])) STOP 1
  if (im2 /= 5) STOP 2
  if (any (im3 /= [ -7,2])) STOP 3
  if (im4 /= 2) STOP 4
  if (any (im5 /= [huge(im5), 5, 11])) STOP 5
  if (any (im6 /= [huge(im6), 5])) STOP 6

  if (any (rm1 /= [ -1., -3., -7.])) STOP 7
  if (rm2 /= 5) STOP 8
  if (any (rm3 /= [ -7.,2.])) STOP 9
  if (rm4 /= 2) STOP 10
  if (any (rm5 /= [huge(rm5), 5., 11.])) STOP 11
  if (any (rm6 /= [huge(rm6), 5.])) STOP 12

  if (cm1 /= "asd") STOP 13
  if (any (cm2 /= ["asd", "jkl", "ert" ])) STOP 14
  if (any (cm3 /= ["asd", "fgh" ])) STOP 15
  if (cm4 /= "jkl") STOP 16
  if (any(cm5 /= [ maxv, "jkl", "zui" ] )) STOP 17
end program main


module class_net
  implicit none

  type, public :: net
    integer :: i_size, h_size, o_size
    real :: lrate
    real, allocatable :: h_w(:,:), o_w(:,:), h_b(:), o_b(:), &
      h_z(:), o_z(:), h_act(:), o_act(:)
  contains
    procedure :: init => init_net
    procedure :: feedf => feed_forward
    procedure :: learn => net_learn
  end type net

contains
  subroutine init_net(this, i, h, o, lrate, seed)
  !! initialize the network with
  !!   'i' input nodes, 'h' hidden neurons and 'o' output nodes
  !! to do: implement in the constructor function
  !!   it seems gfortran doesn's support this at the time (?)
    class(net), intent(inout) :: this
    integer, intent(in) :: i, h, o
    real, intent(in), optional :: lrate
    integer, dimension(:), intent(in), optional :: seed

    !! set size and learning rate of network
    this%i_size = i
    this%h_size = h
    this%o_size = o
    this%lrate = lrate

    !! allocate memory for weights and biases according to size
    allocate(this%h_w(h, i))
    allocate(this%o_w(o, h))
    allocate(this%h_b(h))
    allocate(this%o_b(o))

    allocate(this%h_z(h))
    allocate(this%o_z(o))
    allocate(this%h_act(h))
    allocate(this%o_act(o))

    !! set seed for prng
    if (present(seed)) then
      call random_seed(put=seed)
    else
      call random_seed()
    endif

    !! initialize weights and bias with random values in [-1,1)
    call random_number(this%h_w)
    call random_number(this%h_b)
    call random_number(this%o_w)
    call random_number(this%o_b)

    this%h_w = (this%h_w - 0.5)/sqrt(real(this%h_size))
    this%h_b = this%h_b - 0.5
    this%o_w = (this%o_w - 0.5)/sqrt(real(this%o_size))
    this%o_b = this%o_b - 0.5
  end subroutine init_net

  function act(z)
    real, dimension(:), intent(in) :: z
    real, dimension(size(z)) :: act
    ! act = tanh(z)
    act = 1.0 / (1 - exp(-1*z))
  end function act

  function d_act(a)
    real, dimension(:), intent(in) :: a
    real, dimension(size(a)) :: d_act
    ! d_act = (1 - a*a)
    d_act = a*(1 - a)
  end function d_act

  subroutine feed_forward(this, inputs)
  !! feed forward algorithm
    class(net), intent(inout) :: this
    real, intent(in) :: inputs(this%i_size)

    !! weighted average of inputs plus bias
    this%h_z = matmul(this%h_w, inputs) + this%h_b
    !! apply activation function (hidden layer)
    this%h_act = act(this%h_z)
    !! weiphted average of second layer
    this%o_z = matmul(this%o_w, this%h_act) + this%o_b
    !! result, with output weights plus bias
    this%o_act = act(this%o_z)
  end subroutine feed_forward

  function outer_product(a, b)
    real, dimension(:), intent(in) :: a, b
    real, dimension(size(a), size(b)) :: outer_product
    outer_product = matmul(&
      reshape(a, [size(a), 1]),&
      reshape(b, [1, size(b)])&
    )
  end function outer_product

  function net_learn(this, inputs, expected) result(err2)
  !! learning algorithme from inputs and expected outputs
    class(net), intent(inout) :: this
    real, intent(in) :: inputs(this%i_size), expected(this%o_size)
    real, dimension(this%o_size) :: error, o_del, do_act
    real, dimension(this%h_size) :: h_del, dh_act
    real :: err2

    call this%feedf(inputs)
    error = expected - this%o_act
    dh_act = d_act(this%h_act)
    do_act = d_act(this%o_act)
    o_del = this%lrate * error * do_act
    h_del = matmul(o_del, this%o_w)

    !! outer to inner nodes
    this%o_b = this%o_b - o_del
    this%o_w = this%o_w - outer_product(o_del, this%h_act)
    this%h_b = this%h_b - h_del
    this%h_w = this%h_w - outer_product(h_del, inputs)

    err2 = dot_product(error, error)
  end function net_learn
end module class_net


subroutine ComputeDm(dllm, lmax, m, theta0, degrees, exitstatus)
!------------------------------------------------------------------------------
!
!   This routine will compute the kernel D for the space-concentration
!   problem of a spherical cap for a given spherical harmonic order m. All
!   terms are computed exactly using Gauss-Legendre quadrature. The
!   eigenfunctions of this kernel are 4pi-normalized spherical harmonic
!   coefficients that exclude the Condon-Shortley phase. The diagonal elements
!   of Dllm approaches unity when theta0 appoaches 180 degrees. If the optional
!   vector DEGREES is specified, then the matrix will be computed only for
!   degrees l where DEGREES(l+1) is not zero.
!
!   Calling Parameters
!
!       IN
!           lmax        Maximum spherical harmonic degree.
!           theta0      Angular radius of spherical cap IN RADIANS.
!           m           Angular order used in the concentration problem.
!
!       OUT
!           dllm        Symmetric kernel of size lmax+1 by lmax+1.
!
!       OPTIONAL (IN)
!           degrees     Specify those degrees of the coupling matrix to
!                       compute. If degrees(l+1) is zero, degree l will not
!                       be computed.
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: PreGLQ, PlmBar, NGLQ, PlmIndex
    use ftypes

    implicit none

    real(dp), intent(out) :: dllm(:,:)
    real(dp), intent(in) :: theta0
    integer(int32), intent(in) :: lmax, m
    integer(int32), intent(in), optional :: degrees(:)
    integer(int32), intent(out), optional :: exitstatus
    real(dp) :: upper, zero(2*lmax+1), w(2*lmax+1), x
    real(dp), allocatable :: plm(:)
    integer(int32) :: l, lp, i, n, astat

    if (present(exitstatus)) exitstatus = 0

    if (abs(m) > lmax) then
        print*, "Error --- ComputeDm"
        print*, "M must be less than or equal to LMAX."
        print*, "Input values of LMAX and M are", lmax, m
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    else if (size(dllm(1,:)) < lmax+1 .or. size(dllm(:,1)) < lmax+1) then
        print*, "Error --- ComputeDm"
        print*, "DLLM must be dimensioned as (LMAX+1, LMAX+1) where " // &
                "LMAX is ", lmax
        print*, "Input array is dimensioned as ", size(dllm(1,:)), &
                size(dllm(:,1))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if
    end if

    if (present(degrees)) then
        if (size(degrees) < lmax+1) then
            print*, "Error --- ComputeDm"
            print*, "DEGREES must have dimension LMAX+1, where LMAX is ", lmax
            print*, "Input array is dimensioned as ", size(degrees)
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if
        end if
    end if

    allocate (plm( (lmax+1)*(lmax+2)/2 ), stat = astat)

    if (astat /= 0) then
        print*, "Error --- ComputeDM"
        print*, "Problem allocating array PLM", astat
        if (present(exitstatus)) then
            exitstatus = 3
            return
        else
            stop
        end if
    end if

    dllm = 0.0_dp

    n = NGLQ(2*lmax)

    upper = 1.0_dp
    x = cos(theta0)

    if (present(exitstatus)) then
        call PreGLQ(x, upper, n, zero, w, exitstatus = exitstatus)
        if (exitstatus /= 0) return
    else
        call PreGLQ(x, upper, n, zero, w)
    end if

    do i = 1, n
        if (present(exitstatus)) then
            call PlmBar(plm, lmax, zero(i), exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call PlmBar(plm, lmax, zero(i))
        end if

        do l = abs(m), lmax
            if (present(degrees)) then
                if (degrees(l+1) == 0) cycle
            end if

            do lp = l, lmax
                if (present(degrees)) then
                    if (degrees(lp+1) == 0) cycle
                end if

                dllm(l+1, lp+1) = dllm(l+1,lp+1) + w(i) * &
                                  plm(PlmIndex(l,abs(m))) * &
                                  plm(PlmIndex(lp,abs(m)))
            end do

        end do

    end do

    do l = abs(m), lmax
        do lp = l + 1, lmax, 1
            dllm(lp+1,l+1) = dllm(l+1,lp+1)
        end do
    end do

    if (m == 0) then
        dllm = dllm / 2.0_dp
    else
        dllm = dllm / 4.0_dp
    end if

    call PlmBar(plm, -1, zero(1))   ! deallocate memory

    deallocate (plm)

end subroutine ComputeDm


program TestCilmPlus
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This program will
!
!	(1)	Read in a spherical harmonic file of maximum degree Lmax, expand it in the
!		spatial domain, and then re-expand it into spherical harmonics using
!		Guass-Legendre quadrature. The relativive errors in the space and spectral
!		domaines will be determined.
!	(2) 	Using these routines, the potential coefficients will be computed according
!		to the algorithm of Wieczorek and Phillips (1998). The maximum order of
!		the exspansion will be determined as well.
!	(3)	The difference between using nmax*lmax coefficients when calculating the
!		gravity coefficients vs. n*lmax will be determined.
!	(4)	A 2d gridded data file of the input coefficients with equal latitude and
!		longitude spacings) will be output.
!
!	Notes: The only two parameters in this program that might want
!	to be changed is MAX and MAX2DGRID. The first sets the maximum
!	degree that can be computed in the spherical harmonic expansions,
!	while the second sets the maximum size of the output 2d grid.
!
!	Comments on compiling and modifying this code:
!
!	!. This example code uses a lot of memory, and runs slowly in order to demonstrate
!	the accuracy of the routines. On OS X, it was necessary for me to compile it with
!	the -s option (static memory). Also, if memory is not an issue, then the arrays plx and plxn
!	should be precomputed.
!	2. As is seen in the output, for Mars (and also the Moon) nmax should be about 5
!	in order to achieve an accuracy comparable to the spherical harmonic model.
!	3. In order to exactly calculate the gravity field using the Wieczorek and Phillips (1998)
!	method, if the original field is defined up to lmax, the final output field should
!	be nmax*lmax. This is achieved in practice by zero padding the input field from
!	lmax+1 to nmax*lmax+1. However, as is seen in the output, in practice, it is only
!	necessary to increase the size of the input field by about 50%. At the same time, since the topography
!	spherical harmonic coefficients are NOT really zero beyond lmax, zero padding between
!	(lmax+1, and nmax*lmax+1) still only yields an approximation to the gravity field.
!	This would only be strictly correct if the topography was bandlimited to degree lmax.
!
!	Written by Mark Wieczorek (October, 2003)
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS
	use PlanetsConstants

	implicit none

	integer, parameter ::	degmax = 650, max2dgrid = 181
	real*8 :: 		zero(degmax+1), w(degmax+1), c1ilm(2, degmax+1, degmax+1), &
				zeron(degmax+1), wn(degmax+1), &
				cilm(2, degmax+1, degmax+1), c2ilm(2,degmax+1, degmax+1), grid1glq(degmax+1, 2*degmax+1), &
				gridglq(degmax+1, 2*degmax+1), grid2glq(degmax+1, 2*degmax+1), &
				grid3glq(degmax+1, 2*degmax+1), pi, maxerror, err1, err2, &
				d, rho, mass, grav, gm, grid2d(max2dgrid, 2*max2dgrid), interval, &
				timein, timeout, header(8)
	real*8, allocatable ::		plxn(:,:),  plx(:,:)
	integer :: 		lmax, i, j, l, m, nlat, nlong, nmax, n, &
				lmaxfile, lmaxn, nlatn, nlongn
	character :: 		infile*80, outfile*80

	call cpu_time(timein)

	pi = acos(-1.0d0)

	rho = 2900.0d0			! assumed crustal density
	grav = Grav_Constant
	gm = GM_Mars
	mass = Mass_Mars

	!print*, "Spherical Harmonic file > "
	!read(*,*) infile
	infile = "../ExampleDataFiles/Mars2000.shape"

	!print*, "Maximum degree to read > "
	!read(*,*) lmax
	lmax = 90

	! allocate (plx(lmax+1, (lmax+1)*(lmax+2)/2), stat = astat)
	! if (astat /=0) then
	!	print*, "Problem allocating plx"
	!	stop
	! endif

	if (lmax > degmax) then
		print*, "lmax must be less than or equal to , ", degmax
		print*, "Change max and recompile"
		stop
	endif

	nlat = NGLQSH(lmax)	! These are the sizes of the grids used in  (lmax+1)
	nlong = 2*lmax + 1	! the gauss-legendre quadtrature routines

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Read Spherical harmonic coefficients
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call SHRead(infile, cilm, lmaxfile, header=header(1:8))

	print*, "Maximum degree of input file = ", lmaxfile
	print*, "Maximum degree used in the calculations = ", lmax
	if (lmaxfile > lmax) then
		cilm(:,lmax+2:lmaxfile+1,lmax+2:lmaxfile+1) = 0.0d0	! zero coefficients greater than lmax
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Call a routine which will compute a number of arrays that will be used later on
	!	(these include the guass points, weights, and plx).
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	print*, "Precomputing data structures..."
	!call PreCompute(lmax, zero, w, plx = plx)
	call PreCompute(lmax, zero, w)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Compute a grid from the spherical harmonic coefficients.
	!	Note that this grid is equally spaced in longitude,
	!	but unevenly space in latitude according to the gauss points.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	print*, "Making Grid..."
	!call MakeGridGLQ(gridglq, cilm, lmax, plx = plx)
	call MakeGridGLQ(gridglq, cilm, lmax, zero = zero)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	This routine expands the grid into spherical harmonics
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	print*, "Expanding into spherical harmonics"
	!call SHExpandGLQ(c2ilm, lmax, gridglq, w, plx = plx)
	call SHExpandGLQ(c2ilm, lmax, gridglq, w, zero = zero)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Next, compute relative errors between the original and
	!	computed spherical harmonic coefficients
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	maxerror = 0.0d0
	do l=0, lmax
		do m=0, l
			if (m==0) then
				err1 = abs(cilm(1,l+1,m+1)-c2ilm(1,l+1,m+1))/abs(cilm(1,l+1,m+1))
				if (err1 >= maxerror) maxerror = err1
			else
				err1 = abs(cilm(1,l+1,m+1)-c2ilm(1,l+1,m+1))/abs(cilm(1,l+1,m+1))
				err2 = abs(cilm(2,l+1,m+1)-c2ilm(2,l+1,m+1))/abs(cilm(2,l+1,m+1))
				if (err1 >= maxerror) maxerror = err1
				if (err2 >= maxerror) maxerror = err2
			endif
		enddo
	enddo

	print*, "Maximum relative error between spherical harmonic coefficients = ", maxerror

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Next, compute the maximum error in the space domain
	!	at the gauss points.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	!call MakeGridGLQ(grid2glq, cilm(:,1:lmax+1,1:lmax+1)-c2ilm(:,1:lmax+1,1:lmax+1), lmax, plx = plx)
	call MakeGridGLQ(grid2glq, cilm(:,1:lmax+1,1:lmax+1)-c2ilm(:,1:lmax+1,1:lmax+1), lmax, zero = zero)

	print*, "Maximum error (meters) at the gauss points = ", maxval(abs(grid2glq(1:nlat,1:nlong)))

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Compute the potential coefficients due to the topography
	!	using nmax, and then determine the maximum difference between
	!	this gravity field and that calculated at a smaller n
	!	in the space domain. Note, even though the gravity field
	!	is calculated up to nmax*lmax, the differences that are
	!	output only correspond to the first lmax coefficients.
	!
	!	Note: the minimum gravity anomaly of Lemoine et al. (2001) is
	!	about 6 mgals. I have also determined that the the relative
	!	error for the Moho coefficients is smaller than that of the
	!	topography (The opposite is the case for the Moon). Thus the
	!	value of n used for the topography is sufficient for the moho as well.
	!
	!	The reason that the maximum degree of the spherical harmonic
	!	fields needs to be increased beyond lmax is that raising a field to the nth
	!	power results in a field with coefficients up to n*lmax.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	nmax = 7
	lmaxn = lmax*nmax
	nlatn = NGLQSH(lmaxn)	! These are the sizes of the grids used in  (lmax+1)
	nlongn = 2*lmaxn + 1	! the gauss-legendre quadtrature routines

	print*, "Maximum spherical harmonic degree corresponding to n = ", nmax, " = ", lmaxn
	if (lmaxn > degmax ) then
		print*, "lmaxn is greater than max. Change max and recompile."
		stop
	endif

	! This must be called again since the value of lmax is different than above

	! allocate (plxn(lmaxn+1, (lmaxn+1)*(lmaxn+2)/2), stat = astat)
	! if (astat /=0) then
	!	print*, "Problem allocating plxn"
	!	stop
	! endif

	!call PreCompute(lmaxn, zeron, wn, plx = plxn)
	call PreCompute(lmaxn, zeron, wn)

	print*, "Computing gravity coefficients..."

	!call MakeGridGLQ(gridglq, cilm, lmaxn, plx = plxn)
	call MakeGridGLQ(gridglq, cilm, lmaxn, zero = zeron)

	!call CilmPlus(c1ilm, gridglq, lmaxn, nmax, mass, d, rho, gridtype = 1, w = wn, plx = plxn)
	call CilmPlus(c1ilm, gridglq, lmaxn, nmax, mass, d, rho, gridtype = 1, w = wn, zero = zeron)

	do l=0, lmaxn
		c1ilm(:,l+1,1:l+1) = c1ilm(:,l+1,1:l+1)*(l+1.0d0)*gm*(1.0d5)/d**2	! convert to gravity coefficients in mgals
	enddo

	do n=1, nmax-1

		!call CilmPlus(c2ilm, gridglq, lmaxn, n, mass, d, rho, gridtype = 1, w = wn, plx = plxn)
		call CilmPlus(c2ilm, gridglq, lmaxn, n, mass, d, rho, gridtype = 1, w = wn, zero = zeron)

		do l=0, lmaxn
			c2ilm(:,l+1,1:l+1) = c2ilm(:,l+1,1:l+1)*(l+1.0d0)*gm*(1.0d5)/d**2
		enddo

		! Compute difference only up to lmax, not lmaxn

		!call MakeGridGLQ(grid3glq, c1ilm(:,1:lmax+1,1:lmax+1) - c2ilm(:,1:lmax+1,1:lmax+1), lmax, plx = plx)
		call MakeGridGLQ(grid3glq, c1ilm(:,1:lmax+1,1:lmax+1) - c2ilm(:,1:lmax+1,1:lmax+1), lmax, zero = zero)

		print*, "Maximum difference (mgals) between nmax = ", nmax, " and ", n, " = ", &
			maxval(abs(grid3glq(1:nlat,1:nlong)))

	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Next calculate the difference in the gravity field that arrises from
	!	doing the GLQ integrations with a field zero-padded up to lmaxn as opposed
	!	to nmax*lmax.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do n=1, 10
		!lmaxn = lmax*n
		lmaxn = lmax + (n-1)*10
		nlatn = NGLQSH(lmaxn)
		nlongn = 2*lmaxn + 1

		!call PreCompute(lmaxn, zeron, wn, plx = plxn)
		call PreCompute(lmaxn, zeron, wn)

		!call MakeGridGLQ(gridglq, cilm, lmaxn, plx = plxn)
		call MakeGridGLQ(gridglq, cilm, lmaxn, zero = zeron)

		!call CilmPlus(c2ilm, gridglq, lmaxn, nmax, mass, d, rho, gridtype = 1, w = wn, plx = plxn)
		call CilmPlus(c2ilm, gridglq, lmaxn, nmax, mass, d, rho, gridtype = 1, w = wn, zero = zeron)

		do l=0, lmaxn
			c2ilm(:,l+1,1:l+1) = c2ilm(:,l+1,1:l+1)*(l+1.0d0)*gm*(1.0d5)/d**2	! convert to gravity coefficients in mgals
		enddo

		! Compute difference only up to lmax, not lmaxn

		! call MakeGridGLQ(grid1glq, c1ilm(:,1:lmax+1,1:lmax+1)-c2ilm(:,1:lmax+1,1:lmax+1), lmax, plx = plx)
		call MakeGridGLQ(grid1glq, c1ilm(:,1:lmax+1,1:lmax+1)-c2ilm(:,1:lmax+1,1:lmax+1), lmax, zero = zero)

		print*, "Maximum difference (mgals) between using Lmax of expansion equal to ", lmax*nmax, " and LMAX = ", lmaxn, &
			 maxval(abs(grid1glq(1:nlat,1:nlong)))

	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate a 2d grid with equal longitude and latitude spacings.
	!	Note that if you want a grid finer than 1 degree, that you must
	!	increase the parameter maxgrid2d.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	print*, "Making 2d grid with equal latitude and longitude spacings"
	interval = 2
	cilm(1,1,1) = 0.0d0		! set degree-zero term to zero
	cilm(1,3,1) = 0.0d0		! set j2 term to zero

	outfile = "grid2d.dat"
	open(12,file = outfile)

	call MakeGrid2d(grid2d, cilm, lmax, interval, nlat, nlong)

	write(12,*) nlat, nlong 	! header line giving the dimensions of the following
					! raster image
	do i=1, nlat
		do j=1, nlong
			write(12,*) grid2d(i,j)
		enddo
	enddo

	close(12)

	! deallocate(plx)
	! deallocate(plxn)

	call cpu_time(timeout)
	print*, "time (sec) = ", timeout-timein

end program TestCilmPlus


SUBROUTINE cnum
!======================================
! Coordination Number
!======================================
! Calculates the Analytic Coordination Number for monometallic clusters
! Derivatives are calculated in this version
! To improve performance, switch to the cnum light version
!======================================

   !USE OMP_LIB                                                 !>>> CPU_TIME
   USE PARACLUSTER
   USE CLUSTER
   USE POTENTIAL
   USE ENFORCE
   USE DISTANCE
   USE META

   IMPLICIT NONE

   integer               :: i, j, mminusn_pwr
   double precision      :: ratio_ton, ratio_tom, rnp, rmp, num
   double precision      :: ratio, comfactor
   real(8), dimension(3) :: rij0 ! 3 possible cases: atoms A-A, B-B, A-B
   REAL(8), DIMENSION(nsiz,nsiz)   :: dij, df_dx, df_dy, df_dz
   !REAL(8) :: t_start, t_end                                   !>>> CPU_TIME
   !t_start = OMP_GET_WTIME()                                   !>>> CPU_TIME

   if (ipas.eq.1) write(*,*) 'cnum> first calculation of sigmoid function (CN)'

   !---------------------------------------------------
   mminusn_pwr = m_pwr - n_pwr

   ! Evaluating the values of rij0 parameter in dependence of atom pair kind
   rij0 = dist * rzero * dsqrt(2.d0)

   !---------------------------------------------------
   ! Calculating the analytic coordination number
   ! The sum of these s(i,j) is the analytic coord no.

   ! Default Case: (dij(j,i) .LE. 0.d0)
   s  = 1.d0
   ! Derivative of s
   dS = 0.d0

!$OMP PARALLEL DEFAULT(SHARED)
!$OMP DO PRIVATE(i, j), SCHEDULE(STATIC)
   DO i = 1, natom
      DO j = 1, natom
         ! Distance between atom i and atom j
         ! minus the ref distance for the couple of atoms
         dij(j,i) = pair_dist(j,i) - dist(pairkindmat(j,i))
      END DO
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! Elements on the diagonal
   DO i = 1, natom
      s(i,i) = 0.d0
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i, j, ratio, ratio_ton, ratio_tom, rnp, rmp, num), SCHEDULE(DYNAMIC,20)
   ! Case (dij(j,i) .GT. 0.d0)
   DO i = 1, natom-1
      DO j = i+1, natom
         IF (dij(j,i) .GT. 0.d0) THEN
            ratio = dij(j,i)/rij0(pairkindmat(j,i))
            ! I need to rise to (X_pwr-1) for the derivative
            ratio_ton = ratio**(n_pwr-1)
            ratio_tom = ratio_ton*(ratio**(mminusn_pwr))

            ! Calculating some pieces of derivative
            rnp = n_pwr * ratio_ton
            rmp = m_pwr * ratio_tom

            ! Now ratio_ton becomes really ratio to n_pwr
            ratio_ton = ratio_ton * ratio

            ! Another piece of derivative
            num = rmp - rnp - mminusn_pwr*ratio_ton*ratio_tom
            ! same as:
            ! num = rmp - rnp + ( n_pwr - m_pwr )*ratio**(n_pwr + m_pwr - 1)

            ! Now ratio_tom becomes really ratio to m_pwr
            ratio_tom = ratio_tom * ratio

            ! The sum of these s(i,j) is the analytic coord no.
            s(j,i) = (1.d0-ratio_ton)/(1.d0-ratio_tom)  ! this is f(rij)
            s(i,j) = s(j,i)

            ! Derivative of s
            dS(j,i) = num/( rij0(pairkindmat(j,i))* (1.d0 - ratio_tom)**2)
            dS(i,j) = dS(j,i)
         END IF
      END DO ! on j
   END DO ! on i
!$OMP END DO

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! LP: Calculating the sum of s(i,j), which is CNatom(i), global.
   ! This is the coord num of any single atom i
   ! No problem because s(i,i) is always zero
   DO i = 1, natom
      CNatom(i) = SUM(s(:,i))
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i,j,comfactor), SCHEDULE(STATIC)
   !-------------------------------------------------------------------------
   ! Calculating the sum on j of derivatives of s
   ! with respect to coordinates of every atoms
   DO i = 1, natom
      DO j = 1, natom
         IF (j .NE. i) THEN
            ! Calculating the derivative of coordination number with
            ! respect to distance between atoms i and j, multiplied for
            ! the derivative of distance between atoms i and j
            ! with respect to position of atom i
            comfactor  = dS(j,i)/ pair_dist(j,i)
            df_dx(j,i) = comfactor * xyz_dist(1,j,i) ! order of indexes depends on the definition of xyz_dist
            df_dy(j,i) = comfactor * xyz_dist(2,j,i) ! order of indexes depends on the definition of xyz_dist
            df_dz(j,i) = comfactor * xyz_dist(3,j,i) ! order of indexes depends on the definition of xyz_dist
         ELSE
            df_dx(j,i) = 0.d0
            df_dy(j,i) = 0.d0
            df_dz(j,i) = 0.d0
         END IF
      END DO
   END DO
!$OMP END DO

!$OMP SECTIONS PRIVATE(i)
!$OMP SECTION
   DO i = 1, natom
      dS_dx(i) = 2.d0 * SUM(df_dx(1:natom, i))
   END DO
!$OMP SECTION
   DO i = 1, natom
      dS_dy(i) = 2.d0 * SUM(df_dy(1:natom, i))
   END DO
!$OMP SECTION
   DO i = 1, natom
      dS_dz(i) = 2.d0 * SUM(df_dz(1:natom, i))
   END DO
!$OMP END SECTIONS
!$OMP END PARALLEL
   !---------------------------------------------------------------------------
   !t_end = OMP_GET_WTIME()                                     !>>> CPU_TIME
   !! Writing the cpu time for the subroutine                   !>>> CPU_TIME
   !WRITE(500,'(1I10, 4X, 1F10.8)') ipas, t_end -t_start        !>>> CPU_TIME
END SUBROUTINE cnum


      DOUBLE PRECISION FUNCTION DSI (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 DSI Krogh  Moved external statement up for mangle.
C>> 1995-11-03 DSI Krogh  Removed blanks in numbers for C conversion.
C>> 1994-11-11 DSI Krogh  Declared all vars.
c>> 1994-10-20 DSI Krogh  Changes to use M77CON
c>> 1989-03-14 DSI Original W. V. Snyder at JPL
C
C     COMPUTE THE SINE INTEGRAL OF X =
C     INTEGRAL FROM 0 TO X OF (SIN(T)/T DT).
C
C     FOR ABS(X)<16, USE A CHEBYSHEV SERIES WITH ARGUMENT 2*Z*Z-1 WHERE
C     Z=X/16 TO EVALUATE SI(X)/Z, THEN MULTIPLY THE RESULT BY Z.  THIS
C     AVOIDS STORING ZERO COEFFICIENTS FOR EVEN ORDERS, AND PRESERVES
C     ACCURACY FOR SMALL Z.
C
C     FOR 16.LE.ABS(X).LE.100, USE CHEBYCHEV SERIES WITH ARGUMENT
C     2*Z*Z-1, WHERE Z=16/X ARE USED TO COMPUTE F(X)/X AND G(X)/(X*X).
C     THEN SI(X)=0.5*PI*SIGN(X)-F(X)/X*COS(X)-G(X)/(X*X)*SIN(X).
C
C     WHEN X.GT.100, USE ASYMPTOTIC APPROXIMATIONS FOR F(X)/X AND
C     G(X)/(X*X) AND COMPUTE SI(X) AS ABOVE.
C
C     THIS ALGORITHM YIELDS AT MOST 15 DIGITS OF PRECISION.
C
C--D replaces "?": ?SI, ?CPVAL
C
      INTEGER N
      DOUBLE PRECISION X
      EXTERNAL DCPVAL
      DOUBLE PRECISION PI2,Z,ZW,FZ,GZ,DCPVAL
      DOUBLE PRECISION FT,GT
      DOUBLE PRECISION S(23),F(13),G(13)
      DATA PI2/1.57079632679489662D0/
      DATA S/
     * + 0.5D0,                 + 0.5D0,
     1 + 4.052926477680623D0, - 4.063980844911986D0,
     2 + 2.778756381742663D0, - 1.926565091150656D0,
     3 + 1.389308771171888D0, - 0.968322236987086D0,
     4 + 0.530148847916522D0, - 0.211263780976555D0,
     5 + 0.062033679432003D0, - 0.013867445589417D0,
     6 + 0.002436221404749D0, - 0.000345469155569D0,
     7 + 0.000040420271419D0, - 0.000003972908746D0,
     8 + 0.000000332988589D0, - 0.000000024100076D0,
     9 + 0.000000001522370D0, - 0.000000000084710D0,
     A + 0.000000000004185D0, - 0.000000000000185D0,
     B + 0.000000000000007D0/
      DATA F/
     * + 0.5D0,                 + 0.5D0,
     1 + 0.062263729028927D0, - 0.000233756041393D0,
     2 + 0.000002453755677D0, - 0.000000058670317D0,
     3 + 0.000000002356196D0, - 0.000000000136096D0,
     4 + 0.000000000010308D0, - 0.000000000000964D0,
     5 + 0.000000000000107D0, - 0.000000000000014D0,
     6 + 0.000000000000002D0/
      DATA G/
     * + 0.5D0,                 + 0.5D0,
     1 + 0.003862856096703D0, - 0.000042644182622D0,
     2 + 0.000000724995950D0, - 0.000000023468225D0,
     3 + 0.000000001169202D0, - 0.000000000079604D0,
     4 + 0.000000000006875D0, - 0.000000000000717D0,
     5 + 0.000000000000087D0, - 0.000000000000012D0,
     6 + 0.000000000000002D0/
C
      IF (ABS(X).LT.16.0) THEN
         Z = X/16.0
         ZW = Z*Z
         Z = Z*DCPVAL(S,20,ZW)
      ELSE
        IF (ABS(X).LE.100.0) THEN
C           16.LE.ABS(X).LE.100
            Z = 16.0/X
            ZW = Z*Z
            FZ = Z*DCPVAL(F,10,ZW)
            GZ = ZW*DCPVAL(G,10,ZW)
        ELSE
C           ABS(X).GT.100
            FZ = 1.0/X
            FT = FZ
            GZ = FZ/X
            GT = GZ
            Z = GZ
            DO 25 N = 2, 16, 2
               FT = -DBLE(N*(N-1))*Z*FT
               GT = -DBLE(N*(N+1))*Z*GT
               FZ = FZ + FT
               GZ = GZ + GT
25          CONTINUE
         END IF
         Z = SIGN(PI2,X) - FZ*COS(X) - GZ*SIN(X)
      END IF
C
      DSI = Z
      RETURN
      END