!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2007 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine anisomaxwavspd(elas,rho,iorth,maxwavspd)
!
!     Calculates the propagation wave speed in a material, up to its 21
!     constants. Subroutine for calcmatwavsps.f

!     Based on the procedure in:
!     C. Lane. The Development of a 2D Ultrasonic Array Inspection
!     for Single Crystal Turbine Blades.
!     Switzerland: Springer International Publishing, 2014.
!
!      CARLO MONJARAZ TEC (CMT)
!
!       INPUT:
!
!       elas: double(21) - The elasticity vector, containing 21 entries.
!             Non used are zero. If material is iorthtropic, values are
!             rearranged in middle step to match indexes from anisotropic
!             material card.
!
!        rho: double - Density of the material
!
!       iorth: INTEGER - if the value is 1 : material is iorthtropic
!                        for other vaules:   material is anisotropic
!
!       maxwavspd: double(*) - contains the list of maximum wave speeds
!                  per each material defined in the model. Only materials
!                  that are used in the model are updated, else are left
!                  as -1.0
!
!       OUTPUT:
!
!       maxwavspd
!
      implicit none
!
      real*8 elas(21),c(3,3,3,3),rho,n(3),cm(3,3,3),
     &       cmm(3,3),dd,al(3),alz(3,3),fv1(3),fv2(3),
     &       theta(2*100+1),phi(100+1),pi,p1(3),p2(3),p3(3),v(3),
     &       maxwavspd,speed,nmax(3)
!
      integer i,j,k,l,it,jt,kt,lt,imax,jmax,itheta,jphi,
     &        itensor(4,21),ier,matz,ndim,iorth
!
      data itensor /1,1,1,1,
     &              1,1,2,2,
     &              2,2,2,2,
     &              1,1,3,3,
     &              2,2,3,3,
     &              3,3,3,3,
     &              1,1,1,2,
     &              2,2,1,2,
     &              3,3,1,2,
     &              1,2,1,2,
     &              1,1,1,3,
     &              2,2,1,3,
     &              3,3,1,3,
     &              1,2,1,3,
     &              1,3,1,3,
     &              1,1,2,3,
     &              2,2,2,3,
     &              3,3,2,3,
     &              1,2,2,3,
     &              1,3,2,3,
     &              2,3,2,3/
!
      pi=4.d0*datan(1.d0)
!
      speed=-1.d0
      maxwavspd=-1.d0
!
      write(*,*)'++cMT: calculating max. speed in ANISOTROPIc...'
!
!--------IF IORTHTROPIc-----------------------------
      if(iorth.eq.1)then
!
         elas(10)=elas(9)
         elas(15)=elas(8)
         elas(21)=elas(7)
         elas(9)=0.d0
         elas(8)=0.d0
         elas(7)=0.d0
!
      endif
!
      maxwavspd=-1.d0
      do i=1,101
         phi(i)=(i-1.d0)/100.d0*pi
      enddo
!
      do i=1,201
         theta(i)=((i-1.d0)/100.d0-1.d0 )*pi
      enddo
!--------FIlling  c voigt Matrix-----------------------------
      do i=1,21
         it=itensor(1,i)
         jt=itensor(2,i)
         kt=itensor(3,i)
         lt=itensor(4,i)
!
         c(lt,kt,jt,it)=elas(i)
         c(lt,kt,it,jt)=elas(i)
         c(kt,lt,jt,it)=elas(i)
         c(jt,it,lt,kt)=elas(i)
!     2/3, 1/2, 1/3 swap
         it=itensor(2,i)
         jt=itensor(1,i)
         kt=itensor(4,i)
         lt=itensor(3,i)
         c(lt,kt,jt,it)=elas(i)
         c(lt,kt,it,jt)=elas(i)
         c(kt,lt,jt,it)=elas(i)
         c(jt,it,lt,kt)=elas(i)
      enddo
!
!-----for each direction in the unit sphere------------------
!
      itheta=170
      jphi=30
      do itheta=1,201
         do jphi=1,101
!
            do l=1,3
               n(l)=0.
               v(l)=0.
               do k=1,3
                  cmm(k,l)=0.
                  do j=1,3
                     cm(j,l,k)=0.
                  enddo
               enddo
            enddo
!
            n(1)=cos(theta(itheta))*Sin(phi(jphi))
            n(2)=Sin(theta(itheta))*Sin(phi(jphi))
            n(3)=cos(phi(jphi))
!
!     c ------------ PER EAcH DIREcTION find wave speed-----------------------
!
            dd=dsqrt(n(1)*n(1)+n(2)*n(2) +n(3)*n(3))

            n(1)=n(1) / dd
            n(2)=n(2) / dd
            n(3)=n(3) / dd
!
            do l=1,3
               do k=1,3
                  do i=1,3
                     do j=1,3
                        cm(l,k,i)=cm(l,k,i)+c(l,k,j,i)*n(j)
                     enddo
                  enddo
               enddo
            enddo
!
            do k=1,3
               do i=1,3
                  do l=1,3
                     cmm(k,i)=cmm(k,i)+cm(l,k,i)*n(l)
                  enddo
               enddo
            enddo
!
            ndim=3
            matz=1
            ier=0
!
!     ---------reset vars for EIGvALUES
!
            do j=1,3
               al(j)=0.
               fv1(j)=0.
               fv2(j)=0.
               do i=1,3
                  alz(j,i)=0.
               enddo
            enddo
!
            call rs(ndim,ndim,cmm,al,matz,alz,fv1,fv2,ier)
!
!           ------normalizing eigenvectors to P vectors----------
!
            dd=dsqrt(alz(1,1)**2+alz(2,1)**2+alz(3,1)**2)
            p1(1)=alz(1,1) / dd
            p1(2)=alz(2,1) / dd
            p1(3)=alz(3,1) / dd
            dd=dsqrt(alz(1,2)**2+alz(2,2)**2+alz(3,2)**2)
            p2(1)=alz(1,2) / dd
            p2(2)=alz(2,2) / dd
            p2(3)=alz(3,2) / dd
            dd=dsqrt(alz(1,3)**2+alz(2,3)**2+alz(3,3)**2)
            p3(1)=alz(1,3) / dd
            p3(2)=alz(2,3) / dd
            p3(3)=alz(3,3) / dd
!
            do l=1,3
               do k=1,3
                  cmm(k,l)=0.
                  do j=1,3
                     cm(j,l,k)=0.
                  enddo
               enddo
            enddo
!
            do l=1,3
               do j=1,3
                  do i=1,3
                     do k=1,3
                        cm(l,j,i)=cm(l,j,i)+c(l,k,j,i)*n(k);
                     enddo
                  enddo
               enddo
            enddo
!
            do  l=1,3
               do  j=1,3
                  do  i=1,3
                     cmm(l,j)=cmm(l,j)+cm(l,j,i)*p3(i);
                  enddo
               enddo
            enddo
!
            do j=1,3
               do i=1,3
                  v(j)=v(j)+cmm(j,i)*p3(i)
               enddo
            enddo
!
            dd=dsqrt(v(1)**2+v(2)**2+v(3)**2)
            speed=dsqrt(dd/rho)
!
            if(speed.gt.maxwavspd)then
               maxwavspd=speed
               imax=itheta
               jmax=jphi
               nmax=n
            endif

         enddo
      enddo
!-------END for each direction in the unit sphere-------------
!
      return
      end


      function sersicpot(rad)

      include 'commonblocks'

      real L1,L2
      external gammq,gammqm1,gammln

      if(rad.eq.0.) then
         sersicpot = v0bulge**2.
         return
      endif

      u = rad/Re
      un = u**(1./nnn)
      aaa = nnn*(3.-ppp)
      L1 = Rho0*Re*Re*nnn*butt**(nnn*(ppp-2.))*
     :     gammq(nnn*(2.-ppp),butt*un)*exp(gammln(nnn*(2.-ppp)))
      L2 = Rho0*(Re**3.)*nnn*(butt**(-aaa))*exp(gammln(aaa))
      if(aaa+1.gt.butt*un) then
         L2 = L2*gammqm1(aaa,butt*un)
      else
         L2 = L2*(1.-gammq(aaa,butt*un))
      endif
      sersicpot=4.*pi*(L2/rad + L1)

      return
      END

      subroutine setsersicparameters

      include 'commonblocks'
      common /MOUSE/ comnen
      EXTERNAL funcbutt

      comnen = nnn
      Re = abulge
      if (nnn.gt.0.50) then
         butt1=0.6*(2.0*nnn)
      elseif (nnn.le.0.50) then
         butt1=1.0E-4
      endif
      butt2=1.20*(2.0*nnn)
      buttacc=1.0E-4

      butt=RTBISS(funcbutt,butt1,butt2,buttacc)
c      ppp=1.0d0 - 0.6097d0/nnn + 0.05463d0/(nnn*nnn)

      Rho0 = (v0bulge**2.)/(4.*pi*Re*Re*nnn*butt**(nnn*(ppp-2.))*
     *     exp( gammln(nnn*(2.-ppp))))

      return
      end

      function sersicmass(rad)

      include 'commonblocks'

      u = rad/Re
      un = u**(1./nnn)
      aaa = nnn*(3.-ppp)
      if(aaa+1.gt.butt*un) then
         gm = gammqm1(aaa,butt*un)
      else
         gm = 1.-gammq(aaa,butt*un)
      endif
      sersicmass = 4.*pi*Rho0*(Re**3.)*nnn*(butt**(nnn*(ppp-3.)))*
     +     gm*exp(gammln(nnn*(3.-ppp)))

      return
      end

      function sersicdens(rad)

      include 'commonblocks'

      u = rad/Re
      un = u**(1./nnn)
      sersicdens = Rho0*(u**(-ppp))*exp(-butt*un)

      return
      end

      function sersicdensprime(rad)

      include 'commonblocks'

      u = rad/Re
      un = u**(1./nnn)
      sersicdensprime = -sersicdens(rad)/Re*(ppp*nnn+butt*un)/nnn/u

      return
      end

      function sersicdens2prime(rad)

      include 'commonblocks'

      u = rad/Re
      un = u**(1./nnn)
      sersicdens2prime = sersicdens(rad)/Re/Re*(
     :     (ppp*nnn)**2.+ppp*nnn*nnn+2.*ppp*butt*nnn*un
     :     +butt*un*(nnn-1)+(butt*un)**2.)/((nnn*u)**2.)

      return
      end

      function sersicforce(rad)

      include 'commonblocks'
      real L2

      u = rad/Re
      un = u**(1./nnn)
      aaa = nnn*(3.-ppp)

      L2 = Rho0*(Re**3.)*nnn*(butt**(-aaa))*exp(gammln(aaa))
      if(aaa+1.gt.butt*un) then
         L2 = L2*gammqm1(aaa,butt*un)
      else
         L2 = L2*(1.-gammq(aaa,butt*un))
      endif

      sersicforce = -4.*pi*(L2/rad/rad)

      return
      end
C     ------------------------------------------------------------------
       real function funcbutt(b)
       real b,abe,comnen
       external gammp
       common /MOUSE/ comnen
          abe=2.*comnen
          funcbutt=( gammp(abe,b)-0.5 )
       return
       end

       real FUNCTION rtbiss(funcbutt,x1,x2,xacc)
       INTEGER JMAX
       real x1,x2,xacc,lick
       EXTERNAL funcbutt
       common /MOUSE/ comnen
       PARAMETER (JMAX=100)
       INTEGER j
       real dx,f,fmid,xmid
       lick=comnen

c      write(6,*) 'b: ',2.*lick,x2

       fmid=gammp(2.*lick,x2)-0.5
       f=gammp(2.*lick,x1)-0.5

C      write(6,*) 'c:  F-s: ',fmid,f

       if(f*fmid.ge.0.) pause 'root must be bracketed in rtbiss'
       if(f.lt.0.)then
         rtbiss=x1
         dx=x2-x1
       else
         rtbiss=x2
         dx=x1-x2
       endif
       do 11 j=1,JMAX
         dx=dx*.5
         xmid=rtbiss+dx
         fmid=gammp(2.*lick,xmid)-0.5
         if(fmid.le.0.)rtbiss=xmid
         if(abs(dx).lt.xacc .or. fmid.eq.0.) return
11     continue
       pause 'too many bisections in rtbiss'
       END

      FUNCTION FACTLN (N)
C
      INTEGER  N
      REAL     A(100),FACTLN,GAMMLN
C
      DATA  A/100*-1.0/
C
      IF (N.LT.0) PAUSE 'negative factorial'
      IF (N.LE.99) THEN
        IF (A(N+1).LT.0.0) A(N+1)=GAMMLN(float(N)+1.0)
        FACTLN=A(N+1)
      ELSE
        FACTLN=GAMMLN(float(N)+1.0)
      ENDIF
      RETURN
      END
C
C ------------------------------------------------------------------------------
C
      FUNCTION FACTRL (N)
C
      INTEGER  N,NTOP,J
      REAL     A(33),FACTRL,GAMMLN
C
      DATA  NTOP,A(1)/0,1.0/
C
      IF (N.LT.0) THEN
        PAUSE 'negative factorial'
      ELSE IF (N.LE.NTOP) THEN
        FACTRL=A(N+1)
      ELSE IF (N.LE.32) THEN
        DO 11 J=NTOP+1,N
          A(J+1)=J*A(J)
11      CONTINUE
        NTOP=N
        FACTRL=A(N+1)
      ELSE
        FACTRL=EXP(GAMMLN(float(N)+1.0))
      ENDIF
      RETURN
      END
C
C ------------------------------------------------------------------------------
C
      FUNCTION GAMMLN (XX)
C
      INTEGER  J
      real GAMMLN
      real XX
      real   COF(6),STP,HALF,ONE,FPF,X,TMP,SER
C
      DATA  COF,STP/76.18009173D0,-86.50532033D0,24.01409822D0,
     *    -1.231739516D0,.120858003D-2,-.536382D-5,2.50662827465D0/
      DATA  HALF,ONE,FPF/0.5D0,1.0D0,5.5D0/
C
      X=XX-ONE
      TMP=X+FPF
      TMP=(X+HALF)*LOG(TMP)-TMP
      SER=ONE
      DO 11 J=1,6
        X=X+ONE
        SER=SER+COF(J)/X
11    CONTINUE
      GAMMLN=TMP+LOG(STP*SER)
      RETURN
      END
C
C ------------------------------------------------------------------------------
C
      FUNCTION GAMMP (A,X)
C
      real  GAMMP,A,X,GAMMCF,GLN
C
      IF (X.LT.0.0.OR.A.LE.0.0) PAUSE 'neg argument of gammp'
      IF (X.LT.A+1.0) THEN
        CALL GSER (GAMMP,A,X,GLN)
      ELSE
        CALL GCF (GAMMCF,A,X,GLN)
        GAMMP=1.0-GAMMCF
      ENDIF
      RETURN
      END
C
C ------------------------------------------------------------------------------
C
      FUNCTION GAMMQ (A,X)
C
      real GAMMQ,X,A,GAMSER,GLN
C

      IF (X.LT.0.0.OR.A.LE.0.0) PAUSE 'neg argument of gammq'
      IF (X.LT.A+1.0) THEN
        CALL GSER (GAMSER,A,X,GLN)
        GAMMQ=1.0-GAMSER
      ELSE
        CALL GCF (GAMMQ,A,X,GLN)
      ENDIF
      RETURN
      END
C

      FUNCTION GAMMQm1 (A,X)
C
      real  GAMMQm1,X,A,GAMSER,GLN
C
      IF (X.LT.0.0.OR.A.LE.0.0) PAUSE 'neg argument of gammqm1'
      CALL GSER (GAMSER,A,X,GLN)
      GAMMQm1=GAMSER
      RETURN
      END
C

C ------------------------------------------------------------------------------
C
      SUBROUTINE GCF (GAMMCF,A,X,GLN)
C
      INTEGER    ITMAX,N
      real GAMMCF,A,X,GLN,EPS,GOLD,A0,A1,B0,B1,FAC,AN
      real ANA,ANF,G,GAMMLN
      PARAMETER  (ITMAX=200,EPS=3.E-8)
C

      if(x.gt.100.) then
         gammcf = 0.
         return
      endif

      GLN=GAMMLN(A)
      GOLD=0.0
      A0=1.0
      A1=X
      B0=0.0
      B1=1.0
      FAC=1.0
      DO 11 N=1,ITMAX
        AN=FLOAT(N)
        ANA=AN-A
        A0=(A1+A0*ANA)*FAC
        B0=(B1+B0*ANA)*FAC
        ANF=AN*FAC
        A1=X*A0+ANF*A1
        B1=X*B0+ANF*B1
        IF (A1.NE.0.0) THEN
          FAC=1.0/A1
          G=B1*FAC
          IF (ABS((G-GOLD)/G).LT.EPS) GOTO 1
          GOLD=G
        ENDIF
11    CONTINUE
      gammcf = 0.
      return
1     GAMMCF=EXP(-X+A*log(X)-GLN)*G

      RETURN
      END
C
C ------------------------------------------------------------------------------
C
      SUBROUTINE GSER (GAMSER,A,X,GLN)
C
      INTEGER    ITMAX,N
      real       GAMSER,A,X,GLN,AP,SUM,DEL,EPS,GAMMLN
      PARAMETER  (ITMAX=100,EPS=3.E-30)
C
      GLN=GAMMLN(A)
      IF (X.LE.0.0) THEN
        IF (X.LT.0.0) PAUSE
        GAMSER=0.0
        RETURN
      ENDIF
      AP=A
      SUM=1.0/A
      DEL=SUM
      DO 11 N=1,ITMAX
        AP=AP+1.0
        DEL=DEL*X/AP
        SUM=SUM+DEL
        IF (ABS(DEL).LT.ABS(SUM)*EPS) GOTO 1
11    CONTINUE
      PAUSE 'A too large, ITMAX too small'
      stop
1     GAMSER=SUM*EXP(-X+A*log(X)-GLN)
      RETURN
      END
C
C ------------------------------------------------------------------------------
C
      FUNCTION PLGNDR (L,M,X)
C
      INTEGER  L,M,I,LL
      REAL     X,PMM,SOMX2,FACT,PLGNDR,PMMP1,PLL
C
      IF (M.LT.0.OR.M.GT.L.OR.ABS(X).GT.1.) PAUSE 'bad arguments'
      PMM=1.0
      IF (M.GT.0) THEN
        SOMX2=SQRT((1.0-X)*(1.0+X))
        FACT=1.0
        DO 11 I=1,M
          PMM=-PMM*FACT*SOMX2
          FACT=FACT+2.0
11      CONTINUE
      ENDIF
      IF (L.EQ.M) THEN
        PLGNDR=PMM
      ELSE
        PMMP1=X*(2*M+1)*PMM
        IF (L.EQ.M+1) THEN
          PLGNDR=PMMP1
        ELSE
          DO 12 LL=M+2,L
            PLL=(X*(2*LL-1)*PMMP1-(LL+M-1)*PMM)/(LL-M)
            PMM=PMMP1
            PMMP1=PLL
12        CONTINUE
          PLGNDR=PLL
        ENDIF
      ENDIF
      RETURN
      END

      subroutine findbrackets(func,psi,rmin,rmax)

      real rmin,rmax,psi,psirmin,psirmax

      rmin = 1.
      rmax = 1.

 77   psirmin = func(rmin)
      if(psirmin.le.psi) then
         rmin = rmin*0.1
         goto 77
      endif
 88   psirmax = func(rmax)
      if(psirmax.ge.psi) then
         rmax = rmax*10.
         goto 88
      endif
      return
      end

      subroutine RTBIS (func,psi,X1,X2,XACC,XBEST)
C
      INTEGER    JMAX,J
      PARAMETER  (JMAX=100)
      real X1,X2,XACC,FMID,F,DX,XMID,psi,XBEST
C
      external func

      fmid = func(x2)-psi
      f = func(x1)-psi
      if(f*fmid.ge.0.0) write(*,*) psi,x2,fmid,x1,f
      IF (F*FMID.GE.0.0) PAUSE 'Root must be bracketed for bisection.'
      IF (F.LT.0.0) THEN
        XBEST=X1
        DX=X2-X1
      ELSE
        XBEST=X2
        DX=X1-X2
      ENDIF
      DO 11 J=1,JMAX
        DX=DX*0.5
        XMID=XBEST+DX
        fmid = func(xmid) - psi
        IF (FMID.LT.0.0) XBEST=XMID
        IF ((ABS(DX).LT.XACC).OR.(FMID.EQ.0.0)) RETURN
11    CONTINUE
      PAUSE 'too many bisections'
      END


MODULE MODULE_RMSD
IMPLICIT NONE

CONTAINS

  FUNCTION RMSD(coors_ref,list_ref,coors,list,n_atoms_ref,n_list_ref,n_frames,n_atoms,n_list) RESULT(rmsd_val)

    INTEGER,INTENT(IN)::n_frames,n_atoms,n_list,n_atoms_ref,n_list_ref
    INTEGER,DIMENSION(n_list)::list
    INTEGER,DIMENSION(n_list_ref)::list_ref
    DOUBLE PRECISION,DIMENSION(n_atoms_ref,3),INTENT(IN)::coors_ref
    DOUBLE PRECISION,DIMENSION(n_frames,n_atoms,3),INTENT(IN)::coors
    DOUBLE PRECISION,DIMENSION(n_frames)::rmsd_val

    DOUBLE PRECISION::val_aux
    DOUBLE PRECISION,DIMENSION(3)::vect_aux
    INTEGER::ii,jj,kk,ll

    rmsd_val(:)=0.0d0

    DO ll=1,n_frames
       val_aux = 0.0d0
       DO ii=1,n_list
          jj=list(ii)+1
          kk=list_ref(ii)+1
          vect_aux(:)=coors_ref(kk,:)-coors(ll,jj,:)
          val_aux=val_aux+dot_product(vect_aux(:),vect_aux(:))
       END DO
       rmsd_val(ll)=val_aux
    END DO
    rmsd_val(:)=rmsd_val(:)/(n_list*1.0d0)
    rmsd_val(:)=sqrt(rmsd_val(:))

  END FUNCTION RMSD

  SUBROUTINE LEAST_RMSD(coors_ref,list_ref,coors,list,n_atoms_ref,n_list_ref,n_frames,n_atoms,n_list,rmsd_val)

    INTEGER,INTENT(IN)::n_atoms_ref,n_list_ref,n_frames,n_atoms,n_list
    DOUBLE PRECISION,DIMENSION(n_atoms_ref,3),INTENT(IN)::coors_ref
    DOUBLE PRECISION,DIMENSION(n_frames,n_atoms,3),INTENT(INOUT)::coors
    INTEGER,DIMENSION(n_list_ref),INTENT(IN)::list_ref
    INTEGER,DIMENSION(n_list),INTENT(IN)::list
    DOUBLE PRECISION,DIMENSION(n_frames),INTENT(OUT)::rmsd_val
    DOUBLE PRECISION,DIMENSION(n_list_ref,3)::x
    DOUBLE PRECISION,DIMENSION(n_list,3)::y
    DOUBLE PRECISION,DIMENSION(n_list_ref)::w

    DOUBLE PRECISION,DIMENSION(3,3)::U
    DOUBLE PRECISION,DIMENSION(3)::center_ref,center_2
    DOUBLE PRECISION::rmsd

    INTEGER::i,j,N,ll
    DOUBLE PRECISION::msd,x_norm,y_norm
    DOUBLE PRECISION,DIMENSION(3,3)::R
    DOUBLE PRECISION,DIMENSION(4,4)::F

    !To diagonalise:
    DOUBLE PRECISION,DIMENSION(4,4)::CC
    INTEGER::num_val,info
    INTEGER, DIMENSION(:),ALLOCATABLE::iwork,ifail
    DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE::values,work
    DOUBLE PRECISION, DIMENSION(:,:),ALLOCATABLE::vectors

    rmsd_val(:)=0.0d0

    ALLOCATE(values(4),vectors(4,4),work(8*4),iwork(5*4),ifail(4))

    !!! copio y peso las coordenadas:

    !weights for atoms
    w=1.0d0
    N=n_list_ref

    x=0.0d0
    DO i=1,N
       x(i,:)=w(i)*coors_ref(list_ref(i)+1,:)
    END DO

    !!! calculo baricentros, centroides y normas:
    x_norm=0.0d0
    DO i=1,3
       center_ref(i)=sum(x(:,i))/dble(N)
       x(:,i)=x(:,i)-center_ref(i)
       x_norm=x_norm+dot_product(x(:,i),x(:,i))
    END DO

    DO ll=1,n_frames

      y=0.0d0
      CC=0.0d0
      rmsd=0.0d0
      msd=0.0d0
      values=0.0d0
      vectors=0.0d0
      center_2=0.0d0
      U=0.0d0
      y_norm=0.0d0
      R=0.0d0
      F=0.0d0

      !!! copio y peso las coordenadas:
      DO i=1,N
         y(i,:)=w(i)*coors(ll,list(i)+1,:)
      END DO

      !!! calculo baricentros, centroides y normas:
      DO i=1,3
         center_2(i)=sum(y(:,i))/dble(N)
         y(:,i)=y(:,i)-center_2(i)
         y_norm=y_norm+dot_product(y(:,i),y(:,i))
      END DO

      !!! calculo la matriz R
      DO i=1,3
         DO j=1,3
            R(i,j)=dot_product(x(:,i),y(:,j))
         END DO
      END DO

      !!! construimos la matriz F:

      F(1,1)=R(1,1)+R(2,2)+R(3,3)
      F(2,1)=R(2,3)-R(3,2)
      F(3,1)=R(3,1)-R(1,3)
      F(4,1)=R(1,2)-R(2,1)
      F(1,2)=F(2,1)
      F(2,2)=R(1,1)-R(2,2)-R(3,3)
      F(3,2)=R(1,2)+R(2,1)
      F(4,2)=R(1,3)+R(3,1)
      F(1,3)=F(3,1)
      F(2,3)=F(3,2)
      F(3,3)=-R(1,1)+R(2,2)-R(3,3)
      F(4,3)=R(2,3)+R(3,2)
      F(1,4)=F(4,1)
      F(2,4)=F(4,2)
      F(3,4)=F(4,3)
      F(4,4)=-R(1,1)-R(2,2)+R(3,3)

      !!! calculos los autovalores y autovectores:
      CC=F
      call dsyevx ('V','I','U',4,CC,4,0,0,1,4,0.0d0,num_val&
                    &,values,vectors,4,work,8*4,iwork,ifail,info)

      !!! computo el rmsd
      msd=max(0.0d0,((x_norm+y_norm)-2.0d0*values(4)))/dble(N)
      rmsd=sqrt(msd)
      rmsd_val(ll)=rmsd

    END DO

  END SUBROUTINE LEAST_RMSD

  SUBROUTINE LEAST_RMSD_FIT(coors_ref,list_ref,coors,list,n_atoms_ref,n_list_ref,n_frames,n_atoms,n_list)

    INTEGER,INTENT(IN)::n_atoms_ref,n_list_ref,n_frames,n_atoms,n_list
    DOUBLE PRECISION,DIMENSION(n_atoms_ref,3),INTENT(IN)::coors_ref
    DOUBLE PRECISION,DIMENSION(n_frames,n_atoms,3),INTENT(INOUT)::coors
    INTEGER,DIMENSION(n_list_ref),INTENT(IN)::list_ref
    INTEGER,DIMENSION(n_list),INTENT(IN)::list
    DOUBLE PRECISION,DIMENSION(n_list_ref,3)::x
    DOUBLE PRECISION,DIMENSION(n_list,3)::y
    DOUBLE PRECISION,DIMENSION(n_list_ref)::w

    DOUBLE PRECISION,DIMENSION(3,3)::U,tU
    DOUBLE PRECISION,DIMENSION(3)::center_ref,center_2
    DOUBLE PRECISION::rmsd

    INTEGER::i,j,N,ll
    DOUBLE PRECISION::msd,x_norm,y_norm
    DOUBLE PRECISION,DIMENSION(3,3)::R
    DOUBLE PRECISION,DIMENSION(4,4)::F

    !To diagonalise:
    DOUBLE PRECISION,DIMENSION(4,4)::CC
    INTEGER::num_val,info
    INTEGER, DIMENSION(:),ALLOCATABLE::iwork,ifail
    DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE::values,work
    DOUBLE PRECISION, DIMENSION(:,:),ALLOCATABLE::vectors

    ALLOCATE(values(4),vectors(4,4),work(8*4),iwork(5*4),ifail(4))

    !!! copio y peso las coordenadas:

    !weights for atoms
    w=1.0d0
    N=n_list_ref

    x=0.0d0
    DO i=1,N
       x(i,:)=w(i)*coors_ref(list_ref(i)+1,:)
    END DO

    !!! calculo baricentros, centroides y normas:
    x_norm=0.0d0
    DO i=1,3
       center_ref(i)=sum(x(:,i))/dble(N)
       x(:,i)=x(:,i)-center_ref(i)
       x_norm=x_norm+dot_product(x(:,i),x(:,i))
    END DO

    DO ll=1,n_frames

      y=0.0d0
      CC=0.0d0
      rmsd=0.0d0
      msd=0.0d0
      values=0.0d0
      vectors=0.0d0
      center_2=0.0d0
      U=0.0d0
      y_norm=0.0d0
      R=0.0d0
      F=0.0d0

      !!! copio y peso las coordenadas:
      DO i=1,N
         y(i,:)=w(i)*coors(ll,list(i)+1,:)
      END DO

      !!! calculo baricentros, centroides y normas:
      DO i=1,3
         center_2(i)=sum(y(:,i))/dble(N)
         y(:,i)=y(:,i)-center_2(i)
         y_norm=y_norm+dot_product(y(:,i),y(:,i))
      END DO

      !!! calculo la matriz R
      DO i=1,3
         DO j=1,3
            R(i,j)=dot_product(x(:,i),y(:,j))
         END DO
      END DO

      !!! construimos la matriz F:

      F(1,1)=R(1,1)+R(2,2)+R(3,3)
      F(2,1)=R(2,3)-R(3,2)
      F(3,1)=R(3,1)-R(1,3)
      F(4,1)=R(1,2)-R(2,1)
      F(1,2)=F(2,1)
      F(2,2)=R(1,1)-R(2,2)-R(3,3)
      F(3,2)=R(1,2)+R(2,1)
      F(4,2)=R(1,3)+R(3,1)
      F(1,3)=F(3,1)
      F(2,3)=F(3,2)
      F(3,3)=-R(1,1)+R(2,2)-R(3,3)
      F(4,3)=R(2,3)+R(3,2)
      F(1,4)=F(4,1)
      F(2,4)=F(4,2)
      F(3,4)=F(4,3)
      F(4,4)=-R(1,1)-R(2,2)+R(3,3)

      !!! calculos los autovalores y autovectores:
      CC=F
      call dsyevx ('V','I','U',4,CC,4,0,0,1,4,0.0d0,num_val&
                    &,values,vectors,4,work,8*4,iwork,ifail,info)

      !!! computo el rmsd, la matriz de rotacion y g

      msd=max(0.0d0,((x_norm+y_norm)-2.0d0*values(4)))/dble(N)
      rmsd=sqrt(msd)

      call rotation_matrix(vectors(:,4),U)

      !!! computo el rmsd
      !msd=max(0.0d0,((x_norm+y_norm)-2.0d0*values(4)))/dble(N)
      !rmsd=sqrt(msd)
      !rmsd_val(ll)=rmsd

      !!! calculo las nuevas posiciones con la traslacion y rotacion
      tU=transpose(U)
      DO i=1,n_atoms
         coors(ll,i,:)=matmul(tU(:,:),coors(ll,i,:)-center_2)+center_ref
      END DO
   END DO

  END SUBROUTINE LEAST_RMSD_FIT

!!!! Tenia de antes esta Funcion que en algun momento deberia de comprobar
!!!!
! subroutine least_rmsd(U,center_ref,center_2,rmsd,g,struct_ref,struct_2,nref,n2,pbc_opt)

!   INTEGER,INTENT(IN)::nref,n2,pbc_opt
!   DOUBLE PRECISION,DIMENSION(nref,3),INTENT(IN)::struct_ref
!   DOUBLE PRECISION,DIMENSION(n2,3),INTENT(IN)::struct_2

!   DOUBLE PRECISION,DIMENSION(3,3),INTENT(OUT)::U
!   DOUBLE PRECISION,DIMENSION(3),INTENT(OUT)::center_ref,center_2
!   DOUBLE PRECISION,INTENT(OUT)::rmsd
!   DOUBLE PRECISION,DIMENSION(nref,3),INTENT(OUT)::g

!   INTEGER::i,j,N
!   DOUBLE PRECISION,DIMENSION(nref,3)::x,y
!   DOUBLE PRECISION,DIMENSION(nref)::w
!   DOUBLE PRECISION::sw,msd,x_norm,y_norm
!   DOUBLE PRECISION,DIMENSION(3,3)::R
!   DOUBLE PRECISION,DIMENSION(4,4)::F
!   DOUBLE PRECISION,DIMENSION(3)::tmp

!   !To diagonalise:
!   DOUBLE PRECISION,DIMENSION(4,4)::CC
!   INTEGER::num_val,info
!   INTEGER, DIMENSION(:),ALLOCATABLE::iwork,ifail
!   DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE::values,work
!   DOUBLE PRECISION, DIMENSION(:,:),ALLOCATABLE::vectors

!   ALLOCATE(values(4),vectors(4,4),work(8*4),iwork(5*4),ifail(4))

!   w=0.0d0
!   x=0.0d0
!   y=0.0d0
!   CC=0.0d0
!   rmsd=0.0d0
!   msd=0.0d0
!   sw=0.0d0
!   values=0.0d0
!   vectors=0.0d0
!   center_ref=0.0d0
!   center_2=0.0d0
!   U=0.0d0
!   g=0.0d0
!   x_norm=0.0d0
!   y_norm=0.0d0
!   R=0.0d0
!   F=0.0d0
!   tmp=0.0d0

! !!! copio y peso las coordenadas: puedo pesar las coordenadas
!   w=1.0d0
!   N=nref
!   DO i=1,N
!      sw=w(i)
!      x(i,:)=sw*dble(struct_ref(i,:))
!      y(i,:)=sw*dble(struct_2(i,:))
!   END DO

! !!! calculo baricentros, centroides y normas:

!   DO i=1,3
!      center_ref(i)=sum(x(:,i))/dble(N) !aqui es donde la matan
!      center_2(i)=sum(y(:,i))/dble(N)   !aqui
!      x(:,i)=x(:,i)-center_ref(i)
!      y(:,i)=y(:,i)-center_2(i)
!      x_norm=x_norm+dot_product(x(:,i),x(:,i))
!      y_norm=y_norm+dot_product(y(:,i),y(:,i))
!   END DO

! !!! calculo la matriz R
!   DO i=1,3
!      DO j=1,3
!         R(i,j)=dot_product(x(:,i),y(:,j))
!      END DO
!   END DO

! !!! construimos la matriz F:

!   F(1,1)=R(1,1)+R(2,2)+R(3,3)
!   F(2,1)=R(2,3)-R(3,2)
!   F(3,1)=R(3,1)-R(1,3)
!   F(4,1)=R(1,2)-R(2,1)
!   F(1,2)=F(2,1)
!   F(2,2)=R(1,1)-R(2,2)-R(3,3)
!   F(3,2)=R(1,2)+R(2,1)
!   F(4,2)=R(1,3)+R(3,1)
!   F(1,3)=F(3,1)
!   F(2,3)=F(3,2)
!   F(3,3)=-R(1,1)+R(2,2)-R(3,3)
!   F(4,3)=R(2,3)+R(3,2)
!   F(1,4)=F(4,1)
!   F(2,4)=F(4,2)
!   F(3,4)=F(4,3)
!   F(4,4)=-R(1,1)-R(2,2)+R(3,3)

! !!! calculos los autovalores y autovectores:
!   CC=F
!   call dsyevx ('V','I','U',4,CC,4,0,0,1,4,0.0d0,num_val&
!        &,values,vectors,4,work,8*4,iwork,ifail,info)

! !!! computo el rmsd, la matriz de rotacion y g !! para que era g???

!   msd=max(0.0d0,((x_norm+y_norm)-2.0d0*values(4)))/dble(N)
!   rmsd=sqrt(msd)

!   call rotation_matrix(vectors(:,4),U)

!   DO i=1,N
!      DO j=1,3
!         tmp(:)=matmul(transpose(U(:,:)),y(i,:))
!         g(i,j)=(x(i,j)-tmp(j))/(rmsd*dble(N))
!      END DO
!   END DO

! !!! calculo las nuevas posiciones con la traslacion y rotacion

!   !DO i=1,N
!   !   pos_new(i,:)=matmul(transpose(U(:,:)),struct_2(i,:)-center_2)+center_ref
!   !END DO

! END subroutine least_rmsd

!subroutine least_rmsd(U,center_ref,center_2,rmsd,g,struct_ref,struct_2,list_ref,list_2,nref,totnref,n2,totn2)
!
!  INTEGER,INTENT(IN)::nref,totnref,n2,totn2
!  DOUBLE PRECISION,DIMENSION(totnref,3),INTENT(IN)::struct_ref
!  DOUBLE PRECISION,DIMENSION(totn2,3),INTENT(IN)::struct_2
!  INTEGER,DIMENSION(nref),INTENT(IN)::list_ref
!  INTEGER,DIMENSION(n2),INTENT(IN)::list_2
!
!
!  DOUBLE PRECISION,DIMENSION(3,3),INTENT(OUT)::U
!  DOUBLE PRECISION,DIMENSION(3),INTENT(OUT)::center_ref,center_2
!  DOUBLE PRECISION,INTENT(OUT)::rmsd
!  DOUBLE PRECISION,DIMENSION(nref,3),INTENT(OUT)::g
!
!
!  INTEGER::i,j,N
!  DOUBLE PRECISION,DIMENSION(nref,3)::x,y
!  DOUBLE PRECISION,DIMENSION(nref)::w
!  DOUBLE PRECISION::sw,msd,x_norm,y_norm
!  DOUBLE PRECISION,DIMENSION(3,3)::R
!  DOUBLE PRECISION,DIMENSION(4,4)::F
!  DOUBLE PRECISION,DIMENSION(3)::tmp
!
!  !To diagonalise:
!  DOUBLE PRECISION,DIMENSION(4,4)::CC
!  INTEGER::num_val,info
!  INTEGER, DIMENSION(:),ALLOCATABLE::iwork,ifail
!  DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE::values,work
!  DOUBLE PRECISION, DIMENSION(:,:),ALLOCATABLE::vectors
!
!
!  ALLOCATE(values(4),vectors(4,4),work(8*4),iwork(5*4),ifail(4))
!
!  w=0.0d0
!  x=0.0d0
!  y=0.0d0
!  CC=0.0d0
!  rmsd=0.0d0
!  msd=0.0d0
!  sw=0.0d0
!  values=0.0d0
!  vectors=0.0d0
!  center_ref=0.0d0
!  center_2=0.0d0
!  U=0.0d0
!  g=0.0d0
!  x_norm=0.0d0
!  y_norm=0.0d0
!  R=0.0d0
!  F=0.0d0
!  tmp=0.0d0
!
!!!! copio y peso las coordenadas:
!  w=1.0d0
!  N=nref
!  DO i=1,N
!     sw=w(i)
!     x(i,:)=sw*dble(struct_ref(list_ref(i)+1,:))
!     y(i,:)=sw*dble(struct_2(list_2(i)+1,:))
!  END DO
!
!
!
!!!! calculo baricentros, centroides y normas:
!
!  DO i=1,3
!     center_ref(i)=sum(x(:,i))/dble(N)
!     center_2(i)=sum(y(:,i))/dble(N)
!     x(:,i)=x(:,i)-center_ref(i)
!     y(:,i)=y(:,i)-center_2(i)
!     x_norm=x_norm+dot_product(x(:,i),x(:,i))
!     y_norm=y_norm+dot_product(y(:,i),y(:,i))
!  END DO
!
!!!! calculo la matriz R
!  DO i=1,3
!     DO j=1,3
!        R(i,j)=dot_product(x(:,i),y(:,j))
!     END DO
!  END DO
!
!!!! construimos la matriz F:
!
!  F(1,1)=R(1,1)+R(2,2)+R(3,3)
!  F(2,1)=R(2,3)-R(3,2)
!  F(3,1)=R(3,1)-R(1,3)
!  F(4,1)=R(1,2)-R(2,1)
!  F(1,2)=F(2,1)
!  F(2,2)=R(1,1)-R(2,2)-R(3,3)
!  F(3,2)=R(1,2)+R(2,1)
!  F(4,2)=R(1,3)+R(3,1)
!  F(1,3)=F(3,1)
!  F(2,3)=F(3,2)
!  F(3,3)=-R(1,1)+R(2,2)-R(3,3)
!  F(4,3)=R(2,3)+R(3,2)
!  F(1,4)=F(4,1)
!  F(2,4)=F(4,2)
!  F(3,4)=F(4,3)
!  F(4,4)=-R(1,1)-R(2,2)+R(3,3)
!
!!!! calculos los autovalores y autovectores:
!  CC=F
!  call dsyevx ('V','I','U',4,CC,4,0,0,1,4,0.0d0,num_val&
!       &,values,vectors,4,work,8*4,iwork,ifail,info)
!
!!!! computo el rmsd, la matriz de rotacion y g
!
!  msd=max(0.0d0,((x_norm+y_norm)-2.0d0*values(4)))/dble(N)
!  rmsd=sqrt(msd)
!
!
!  call rotation_matrix(vectors(:,4),U)
!
!  DO i=1,N
!     DO j=1,3
!        tmp(:)=matmul(transpose(U(:,:)),y(i,:))
!        g(i,j)=(x(i,j)-tmp(j))/(rmsd*dble(N))
!     END DO
!  END DO
!
!!!! calculo las nuevas posiciones con la traslacion y rotacion
!
!  !DO i=1,N
!  !   pos_new(i,:)=matmul(transpose(U(:,:)),struct_2(i,:)-center_2)+center_ref
!  !END DO
!
!
!END subroutine least_rmsd

  subroutine rotation_matrix(q, U)

    DOUBLE PRECISION,DIMENSION(4),INTENT(in)::q
    DOUBLE PRECISION,DIMENSION(3,3),INTENT(out)::U
    DOUBLE PRECISION::q0,q1,q2,q3,b0,b1,b2,b3,q00,q01,q02,q03,q11,q12,q13,q22,q23,q33

    q0=q(1)
    q1=q(2)
    q2=q(3)
    q3=q(4)

    b0=2.0d0*q0
    b1=2.0d0*q1
    b2=2.0d0*q2
    b3=2.0d0*q3

    q00=b0*q0-1.0d0
    q01=b0*q1
    q02=b0*q2
    q03=b0*q3

    q11=b1*q1
    q12=b1*q2
    q13=b1*q3

    q22=b2*q2
    q23=b2*q3

    q33=b3*q3

    U(1,1)=q00+q11
    U(1,2)=q12-q03
    U(1,3)=q13+q02

    U(2,1)=q12+q03
    U(2,2)=q00+q22
    U(2,3)=q23-q01

    U(3,1)=q13-q02
    U(3,2)=q23+q01
    U(3,3)=q00+q33

  end subroutine rotation_matrix

!  subroutine rot_trans(struct,rot,center_2,center_ref,N,new_struct)
!
!    IMPLICIT NONE
!    INTEGER,INTENT(IN)::N
!    DOUBLE PRECISION,DIMENSION(N,3),INTENT(IN)::struct
!    DOUBLE PRECISION,DIMENSION(3,3),INTENT(IN)::rot
!    DOUBLE PRECISION,DIMENSION(3),INTENT(IN)::center_2,center_ref
!    DOUBLE PRECISION,DIMENSION(N,3),INTENT(OUT)::new_struct
!    INTEGER::i
!
!    DO i=1,N
!       new_struct(i,:)=matmul(transpose(rot(:,:)),(struct(i,:)-center_2(:)))+center_ref(:)
!    END DO
!
!  END subroutine rot_trans

END MODULE MODULE_RMSD


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_urffact_deflationcheck
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine diagonalizes a unitary upper hessenberg matrix that is stored as
! a product of N Givens rotations, without computing square roots.
!
! | u1       -v1 |
! | v1  conj(u1) | | u2       -v2 |
!                  | v2  conj(u2) | | u3       -v3 | | 1   0 |
!                                   | v3  conj(u3) | | 0  u4 |
!
! The square root free algorithm only requires the storage of the vi^2,
! so the arrays U and VV contain the following:
!
!  U(i) = ui
! VV(i) = vi^2
!
! The input must satisfy the following:
!
!  |U(i)|^2 + VV(i) = 1
!             VV(N) = 0
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  U               COMPLEX(8) array of dimension N
!                    array of complex generators for Givens rotations
!
!  VV              REAL(8) array of dimension N
!                    array of real generators (squared) for Givens rotations
!
! OUTPUT VARIABLES:
!
!  ZERO            INTEGER
!                    largest index such that VV(i) < tol
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_urffact_deflationcheck(N,U,VV,ZERO)

  implicit none

  ! input variables
  integer, intent(in) :: N
  integer, intent(inout) :: ZERO
  complex(8), intent(inout) :: U(N)
  real(8), intent(inout) :: VV(N)

  ! compute variables
  integer :: ii
  real(8), parameter :: tol = (EISCOR_DBL_EPS)**2
  real(8) :: xx

  ! intialize ZERO
  ZERO = 0

  ! check for deflation
  do ii=1,N

    ! deflate if subdiagonal is small enough
    if (VV(N+1-ii) < tol) then

      ! set ZERO
      ZERO = N+1-ii

      ! set rotation to diagonal
      VV(ZERO) = 0d0

      ! renormalize U
      xx = dble(U(ZERO))**2 + aimag(U(ZERO))**2
      U(ZERO) = 5d-1*U(ZERO)*(3d0-xx)

    end if

  end do

end subroutine z_urffact_deflationcheck


subroutine SHReturnTapers(theta0, lmax, tapers, eigenvalues, taper_order, &
                          degrees, exitstatus)
!------------------------------------------------------------------------------
!
!   This subroutine will return all the eigenvalues and eigenfunctions for the
!   space-concentration problem of a spherical cap of angular radius theta0.
!   The returned eigenfunctions correspond to "geodesy" normalized spherical
!   harmonic coefficients, and the eigenfunctions are further normalized such
!   that they have unit power (i.e., the integral of the function squared over
!   the sphere divided by 4 pi is 1, and the sum of the squares of their
!   coefficients is 1). If the optional vector DEGREES is specified, then the
!   eigenfunctions will be computed using only those degrees where DEGREES(l+1)
!   is not zero.
!
!   When possible, the eigenfunctions are calculated using the kernel of
!   Grunbaum et al. 1982 and the eigenvalues are then calculated by integration
!   using the definition of the space-concentration problem. Use of the
!   Grunbaum et al. kernel is prefered over the space-concentration kernel as
!   the eigenfunctions of the later are unreliable when there are several
!   eigenvalues identical (within machine precision) to either 1 or zero. If,
!   the optional parameter DEGREES is specified, and at least one element is
!   zero for degrees greater or equal to abs(m), then the eigenfunctions and
!   eigenvalues will instead be computed directly using the space-concentration
!   kernel.
!
!   Calling Parameters
!
!       IN
!           theta0          Angular radius of spherical cap in RADIANS.
!           lmax            Maximum spherical harmonic degree
!                           for the concentration problem.
!
!       OUT
!           tapers          An (lmax+1) by (lmax+1)**2 array containing
!                           all the eigenfunctions of the space-
!                           concentration kernel. Eigenfunctions
!                           are listed by columns in decreasing order
!                           corresponding to value of their eigenvalue.
!           eigenvalues     A vector of length lmax+1 containing the
!                           eigenvalued corresponding to the individual
!                           eigenfunctions.
!           taper_order     A vector of dimension (lmax+1)**2 denoting which
!                           order m corresponds to the column of tapers and
!                           eigenvalues.
!
!       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: SHReturnTapersM
    use ftypes

    implicit none

    real(dp), intent(in) :: theta0
    integer, intent(in) :: lmax
    real(dp), intent(out) :: tapers(:,:), eigenvalues(:)
    integer, intent(out) :: taper_order(:)
    integer, intent(in), optional :: degrees(:)
    integer, intent(out), optional :: exitstatus
    integer :: m, nt, nt2, n, i, j, jj(1), astat(8)
    real(dp), allocatable :: eval(:), evec(:, :), tapers_unordered(:,:), &
                             eval_unordered(:)
    integer, allocatable :: m_unordered(:)

    if (present(exitstatus)) exitstatus = 0

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

    else if (size(eigenvalues) < (lmax+1)**2) then
        print*, "Error --- SHReturnTapers"
        print*, "EIGENVALUES must be dimensioned as (LMAX+1)**2 " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned as ", size(eigenvalues)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(taper_order) < (lmax+1)**2) then
        print*, "Error --- SHReturnTapers"
        print*, "TAPER_ORDER must be dimensioned as (LMAX+1)**2 " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned as ", size(taper_order)
        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 --- SHReturnTapers"
            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 (eval(lmax+1), stat = astat(1))
    allocate (evec(lmax+1, lmax+1), stat = astat(2))
    allocate (tapers_unordered(lmax+1, (lmax+1)**2), stat = astat(3))
    allocate (eval_unordered((lmax+1)**2), stat = astat(4))
    allocate (m_unordered((lmax+1)**2), stat = astat(5))

    if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0 .or. &
            astat(4) /= 0 .or. astat(5) /= 0) then
        print*, "Error ---- SHReturnTapers"
        print*, "Problem allocating memory for temporary arrays: ", astat(1:5)
        if (present(exitstatus)) then
            exitstatus = 3
            return
        else
            stop
        end if

    end if

    tapers = 0.0_dp
    tapers_unordered = 0.0_dp
    eigenvalues = 0.0_dp
    eval_unordered = 0.0_dp
    m_unordered = 0
    taper_order = 0

    !----------------------------------------------------------------------
    !
    !   Calculate eigenfunctions and eigenvalues using SHReturnTapersM.
    !   When possible, this routine will use the kernel of Grunbaum et al.
    !   (1982).
    !
    !----------------------------------------------------------------------
    nt = 0

    do m = 0, lmax

        if (present(exitstatus)) then
            if (present(degrees)) then
                call SHReturnTapersM(theta0, lmax, m, evec, eval, ntapers=n, &
                                     degrees=degrees, exitstatus=exitstatus)
            else
                call SHReturnTapersM(theta0, lmax, m, evec, eval, ntapers=n, &
                                     exitstatus=exitstatus)
            end if

            if (exitstatus /= 0) return

        else
            if (present(degrees)) then
                call SHReturnTapersM(theta0, lmax, m, evec, eval, ntapers=n, &
                                     degrees=degrees)
            else
                call SHReturnTapersM(theta0, lmax, m, evec, eval, ntapers=n)
            end if

        end if

        if (n /= 0) then
            tapers_unordered(1:lmax+1, nt+1:nt+n) = evec(1:lmax+1,1:n)
            m_unordered(nt+1:nt+n) = m
            eval_unordered(nt+1:nt+n) = eval(1:n)

            nt = nt + n

        end if

    end do

    !--------------------------------------------------------------------------
    !
    !   Reorder tapers and eigenvalues, and add negative angular orders tapers.
    !
    !--------------------------------------------------------------------------
    nt2 = 0

    do i = 1, nt
        jj = maxloc(eval_unordered(1:nt))
        j = jj(1)

        if (m_unordered(j) == 0) then
            nt2 = nt2 + 1
            taper_order(nt2) = m_unordered(j)
            eigenvalues(nt2) = eval_unordered(j)
            tapers(1:lmax+1,nt2) = tapers_unordered(1:lmax+1,j)

        else
            nt2 = nt2 + 1
            taper_order(nt2) = -m_unordered(j)
            eigenvalues(nt2) = eval_unordered(j)
            tapers(1:lmax+1,nt2) = tapers_unordered(1:lmax+1,j)
            nt2 = nt2 + 1
            taper_order(nt2) = m_unordered(j)
            eigenvalues(nt2) = eval_unordered(j)
            tapers(1:lmax+1,nt2) = tapers_unordered(1:lmax+1,j)

        end if

        eval_unordered(j) = -1.0d25

    end do

    deallocate (eval)
    deallocate (evec)
    deallocate (tapers_unordered)
    deallocate (eval_unordered)
    deallocate (m_unordered)

end subroutine SHReturnTapers


C Example of Fortran II program:
C This program has one data card input, with simple zero-data edit check.
C If one of the input values is zero, then the program will end with an
C error code of "STOP 1" in the job control card listing following the
C execution of the program. Normal output will be one line printed with
C A, B, C, and AREA on the "report" page following the compilation with
C no specific units are stated; and with a normal "STOP" in the job card
C listing.

C AREA OF A TRIANGLE WITH A STANDARD SQUARE ROOT FUNCTION
C INPUT - CARD READER UNIT 5, INTEGER INPUT
C OUTPUT - LINE PRINTER UNIT 6, REAL OUTPUT
C INPUT ERROR DISPAY ERROR OUTPUT CODE 1 IN JOB CONTROL LISTING
      INTEGER A,B,C
      READ(5,501) A,B,C
  501 FORMAT(3I5)
      IF(A.EQ.0 .OR. B.EQ.0 .OR. C.EQ.0) STOP 1
      S = (A + B + C) / 2.0
      AREA = SQRT( S * (S - A) * (S - B) * (S - C) / 2.0)
      WRITE(6,601) A,B,C,AREA
  601 FORMAT(4H A=,I5,5H B=,I5,5H C= ,I5,8H AREA=,F10.2,12HSQUARE)
      STOP
      END


      subroutine dcrft(init,x,ldx,y,ldy,n,m,isign,scale,
     &                 table,n1,wrk,n2,z,nz)

      implicit none
      integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j
      real x(2*ldx,*),y(ldy,*),scale,table(44002),wrk,z

      if (init.ne.0) then
        call rffti(n,table)
      else
!ocl novrec
        do j=1,m
          y(1,j)=x(1,j)
          do i=2,n
            y(i,j)=x(i+1,j)
          enddo
          call rfftb(n,y(1,j),table)
          do i=1,n
            y(i,j)=scale*y(i,j)
          enddo
        enddo
      endif

      return
      end
      subroutine scrft(init,x,ldx,y,ldy,n,m,isign,scale,
     &                 table,n1,wrk,n2,z,nz)

      implicit none
      integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j
      real x(2*ldx,*),y(ldy,*),scale,table(44002),wrk,z

      if (init.ne.0) then
        call rffti(n,table)
      else
!ocl novrec
        do j=1,m
          y(1,j)=x(1,j)
          do i=2,n
            y(i,j)=x(i+1,j)
          enddo
          call rfftb(n,y(1,j),table)
          do i=1,n
            y(i,j)=scale*y(i,j)
          enddo
        enddo
      endif

      return
      end
c
c***********************************************************************
c
      subroutine csfft(isign,n,scale,x,y,table,work,isys)

      implicit none
      integer isign,n,isys,i
      real scale,x(*),y(*),table(*),work(*)

      if (isign.eq.0) then
        call rffti(n,table)
      endif
      if (isign.eq.1) then
        y(1)=x(1)
        do i=2,n
          y(i)=x(i+1)
        enddo
        call rfftb(n,y,table)
        do i=1,n
          y(i)=scale*y(i)
        enddo
      endif

      return
      end
c
c***********************************************************************
c
      subroutine drcft(init,x,ldx,y,ldy,n,m,isign,scale,
     &                 table,n1,wrk,n2,z,nz)

      implicit none
      integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j
      real x(ldx,*),y(2*ldy,*),scale,table(44002),wrk,z

      if (init.ne.0) then
        call rffti(n,table)
      else
        do j=1,m
          do i=1,n
            y(i,j)=x(i,j)
          enddo
          call rfftf(n,y(1,j),table)
          do i=1,n
            y(i,j)=scale*y(i,j)
          enddo
          do i=n,2,-1
            y(i+1,j)=y(i,j)
          enddo
          y(2,j)   = 0.
          y(n+2,j) = 0.
        enddo
      endif

      return
      end
c
c***********************************************************************
c
      subroutine srcft(init,x,ldx,y,ldy,n,m,isign,scale,
     &                 table,n1,wrk,n2,z,nz)

      implicit none
      integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j
      real x(ldx,*),y(2*ldy,*),scale,table(44002),wrk,z

      if (init.ne.0) then
        call rffti(n,table)
      else
        do j=1,m
          do i=1,n
            y(i,j)=x(i,j)
          enddo
          call rfftf(n,y(1,j),table)
          do i=1,n
            y(i,j)=scale*y(i,j)
          enddo
          do i=n,2,-1
            y(i+1,j)=y(i,j)
          enddo
          y(2,j)   = 0.
          y(n+2,j) = 0.
        enddo
      endif

      return
      end
c
c***********************************************************************
c
      subroutine scfft(isign,n,scale,x,y,table,work,isys)

      implicit none
      integer isign,n,isys,i
      real scale,x(*),y(*),table(*),work(*)

      if (isign.eq.0) then
        call rffti(n,table)
      endif
      if (isign.eq.-1) then
        do i=1,n
          y(i)=x(i)
        enddo
        call rfftf(n,y,table)
        do i=1,n
          y(i)=scale*y(i)
        enddo
        do i=n,2,-1
          y(i+1)=y(i)
        enddo
        y(2)=0.
      endif

      return
      end


subroutine surface_jacobian_wrap(u, v, tu, tv, ku, kv, nctlu, nctlv, nu, nv, vals, &
     row_ptr, col_ind)

  use precision
  implicit none

  ! Input
  integer            , intent(in)      :: ku, kv, nctlu, nctlv, nu, nv
  real(kind=realType), intent(in)      :: u(nv, nu), v(nv, nu)
  real(kind=realType), intent(in)      :: tu(nctlu+ku), tv(nctlv+kv)

  ! Output
  real(kind=realType), intent(out)     :: vals(nu*nv*ku*kv)
  integer            , intent(out)     :: col_ind(nu*nv*ku*kv), row_ptr(nu*nv+1)

  ! Working
  real(kind=realType)                  :: basisu(ku), basisv(kv)
  integer                              :: ileftu, ileftv
  integer                              :: i, j, ii, jj, counter

  counter = 1
  do i=1, nu
     do j = 1, nv
        ! Get u interval
        call findSpan(u(j, i), ku, tu, nctlu, ileftu)
        call basis(tu, nctlu, ku, u(j, i), ileftu, basisu)

        ! Get v interval
        call findSpan(v(j, i), kv, tv, nctlv, ileftv)
        call basis(tv, nctlv, kv, v(j, i), ileftv, basisv)

        row_ptr( (i-1)*nv + j  ) = counter-1
        do ii=1, ku
           do jj = 1, kv
              col_ind(counter) = (ileftu-ku+ii-1)*Nctlv + (ileftv-kv+jj-1)
              vals(counter) = basisu(ii)*basisv(jj)
              counter = counter + 1

           end do
        end do
     end do
  end do
  row_ptr(nu*nv+1) = counter-1

end subroutine surface_jacobian_wrap

subroutine surface_para_corr(tu, tv, ku, kv, u, v, coef, nctlu, nctlv, ndim, nu, nv, X, rms)

  ! Do Hoschek parameter correction
  use precision
  implicit none

  ! Input/Output
  integer              , intent(in)      :: ku, kv, nctlu, nctlv, ndim, nu, nv
  real(kind=realType)  , intent(in)      :: tu(ku+nctlu), tv(kv+nctlv)
  real(kind=realType)  , intent(inout)   :: u(nv, nu), v(nv, nu)
  real(kind=realType)  , intent(in)      :: coef(ndim, nctlv, nctlu)
  real(kind=realType)  , intent(in)      :: X(ndim, nv, nu)
  real(kind=realType)  , intent(out)     :: rms

  ! Working
  integer                               :: i, j, jj, max_inner_iter
  real(kind=realType)                   :: D(ndim), D2(ndim)
  real(kind=realType)                   :: val(ndim), deriv(ndim, 2), deriv2(ndim, 2, 2)
  real(kind=realType)                   :: u_tilde, v_tilde
  real(kind=realType)                   :: A(2, 2), ki(2), delta(2)

  max_inner_iter = 10
  rms = 0.0

  do i=2, nu-1
     do j = 2, nv-2
        call eval_surface(u(j, i), v(j, i), tu, tv, ku, kv, coef, nctlu, nctlv, ndim, val)
        call eval_surface_deriv(u(j, i), v(j, i), tu, tv, ku, kv, coef, nctlu, nctlv, ndim, deriv)
        call eval_surface_deriv2(u(j, i), v(j, i), tu, tv, ku, kv, coef, nctlu, nctlv, ndim, deriv2)

        D = val-X(:, j, i)

        A(1, 1) = NORM2(deriv(:, i))**2 + dot_product(D, deriv2(:, 1, 1))
        A(1, 2) = dot_product(deriv(:, 1), deriv(:, 2)) + dot_product(D, deriv2(:, 1, 2))
        A(2, 1) = A(1, 2)
        A(2, 2) = NORM2(deriv(:, 2))**2 + dot_product(D, deriv2(:, 2, 2))

        ki(1) = -dot_product(D, deriv(:, 1))
        ki(2) = -dot_product(D, deriv(:, 2))

        call solve_2by2(A, ki, delta)

        if (j .eq.1 .or. j .eq. nv) then
           delta(1) = 0.0
        end if
        if (i .eq.1 .or. i .eq. nu) then
           delta(2) = 0.0
        end if
        inner_loop: do jj=1, max_inner_iter
           u_tilde = u(j, i) + delta(1)
           v_tilde = v(j, i) + delta(2)

           call eval_surface(u_tilde, v_tilde, tu, tv, ku, kv, coef, nctlu, nctlv, ndim, val)
           D2 = val-X(i, j, :)
           if (NORM2(D) .ge. NORM2(D2)) then
              u(j, i) = u_tilde
              v(j, i) = v_tilde
              exit inner_loop
           else
              delta = delta*0.5
           end if
        end do inner_loop
     end do
  end do

  ! Lets redo the full RMS
  rms = 0.0

  do i=1, nu
     do j=1, nv
        call eval_surface(u(j, i), v(j, i), tu, tv, ku, kv, coef, nctlu, nctlv, ndim, val)
        D = X(i, j, :)-val
        rms = rms + dot_product(D, D)
     end do
  end do
  rms = sqrt(rms/(nu*nv))

end subroutine surface_para_corr

function compute_rms_surface(tu, tv, ku, kv, u, v, coef, nctlu, nctlv, ndim, nu, nv, X)
 ! Do Hoschek parameter correction
  use precision
  implicit none

  ! Input/Output
  integer              , intent(in)      :: ku, kv, nctlu, nctlv, ndim, nu, nv
  real(kind=realType)  , intent(in)      :: tu(ku+nctlu), tv(kv+nctlv)
  real(kind=realType)  , intent(inout)   :: u(nv, nu), v(nv, nu)
  real(kind=realType)  , intent(in)      :: coef(ndim, nctlv, nctlu)
  real(kind=realType)  , intent(in)      :: X(ndim, nv, nu)

  ! Working
  integer                            :: i, j, idim
  real(kind=realType)                   :: val(ndim), D(ndim)
  real(kind=realType)                   :: compute_rms_surface

  compute_rms_surface = 0.0
  do i=1, nu
     do j=1, nv
        call eval_surface(u(j, i), v(j, i), tu, tv, ku, kv, coef, nctlu, nctlv, ndim, val)
        D = val-X(:, j, i)
        do idim=1, ndim
           compute_rms_surface = compute_rms_surface + D(idim)**2
        end do
     end do
  end do
  compute_rms_surface = sqrt(compute_rms_surface/(nu*nv))

end function compute_rms_surface


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(three_dimensional_solvers) general_linear_systems_solver_3d

contains

    ! SUBROUTINE pois3d(lperod, l, c1, mperod, m, c2, nperod, n, &
    !            a, b, c, ldimf, mdimf, f, ierror)
    !
    !
    ! DIMENSION OF           a(n), b(n), c(n), f(ldimf, mdimf, n)
    ! ARGUMENTS
    !
    ! PURPOSE                Solves the linear system of equations
    !                        for unknown x values, where i=1, 2, ..., l,
    !                        j=1, 2, ..., m, and k=1, 2, ..., n
    !
    !                        c1*(x(i-1, j, k) -TWO *x(i, j, k) +x(i+1, j, k)) +
    !                        c2*(x(i, j-1, k) -TWO *x(i, j, k) +x(i, j+1, k)) +
    !                        a(k)*x(i, j, k-1) +b(k)*x(i, j, k)+ c(k)*x(i, j, k+1)
    !                        = f(i, j, k)
    !
    !                        the indices k-1 and k+1 are evaluated modulo n,
    !                        i.e. x(i, j, 0)=x(i, j, n) and x(i, j, n+1)=x(i, j, 1).
    !                        the unknowns
    !                        x(0, j, k), x(l+1, j, k), x(i, 0, k), and x(i, m+1, k)
    !                        are assumed to take on certain prescribed
    !                        values described below.
    !
    ! USAGE                  call pois3d (lperod, l, c1, mperod, m, c2, nperod,
    !                        n, a, b, c, ldimf, mdimf, f, ierror)
    !
    ! ARGUMENTS
    !
    ! ON INPUT
    !                        lperod
    !                          indicates the values that x(0, j, k) and
    !                          x(l+1, j, k) are assumed to have.
    !                          = 0  x(0, j, k)=x(l, j, k), x(l+1, j, k)=x(1, j, k)
    !                          = 1  x(0, j, k) = 0,      x(l+1, j, k) = 0
    !                          = 2  x(0, j, k)=0,        x(l+1, j, k)=x(l-1, j, k)
    !                          = 3  x(0, j, k)=x(2, j, k), x(l+1, j, k)=x(l-1, j, k)
    !                          = 4  x(0, j, k)=x(2, j, k), x(l+1, j, k) = 0.
    !
    !                        l
    !                          the number of unknowns in the i-direction.
    !                          l must be at least 3.
    !
    !                        c1
    !                          real constant in the above linear system
    !                          of equations to be solved.
    !
    !                        mperod
    !                          indicates the values that x(i, 0, k) and
    !                          x(i, m+1, k) are assumed to have.
    !                          = 0  x(i, 0, k)=x(i, m, k), x(i, m+1, k)=x(i, 1, k)
    !                          = 1  x(i, 0, k)=0,        x(i, m+1, k)=0
    !                          = 2  x(i, 0, k)=0,        x(i, m+1, k)=x(i, m-1, k)
    !                          = 3  x(i, 0, k)=x(i, 2, k)  x(i, m+1, k)=x(i, m-1, k)
    !                          = 4  x(i, 0, k)=x(i, 2, k)  x(i, m+1, k)=0
    !
    !                        m
    !                          the number of unknowns in the j-direction.
    !                          m must be at least 3.
    !
    !                        c2
    !                          real constant in the above linear system
    !                          of equations to be solved.
    !
    !                        nperod
    !                          = 0  if a(1) and c(n) are not zero.
    !                          = 1  if a(1) = c(n) = 0.
    !
    !                        n
    !                          the number of unknowns in the k-direction.
    !                          n must be at least 3.
    !
    !                        a, b, c
    !                          one-dimensional arrays of length n that
    !                          specify the coefficients in the linear
    !                          equations given above.
    !
    !                          if nperod = 0 the array elements must not
    !                          depend upon index k, but must be constant.
    !                          specifically, the subroutine checks the
    !                          following condition
    !                            a(k) = c(1)
    !                            c(k) = c(1)
    !                            b(k) = b(1)
    !                          for k=1, 2, ..., n.
    !
    !                        ldimf
    !                          The row (or first) dimension of the three-
    !                          dimensional array f as it appears in the
    !                          program calling pois3d.  this parameter is
    !                          used to specify the variable dimension
    !                          of f.  ldimf must be at least l.
    !
    !                        mdimf
    !                          The column (or second) dimension of the three
    !                          dimensional array f as it appears in the
    !                          program calling pois3d.  this parameter is
    !                          used to specify the variable dimension
    !                          of f.  mdimf must be at least m.
    !
    !                        f
    !                          A three-dimensional array that specifies the
    !                          values of the right side of the linear system
    !                          of equations given above.  f must be
    !                          dimensioned at least l x m x n.
    !
    ! ON OUTPUT
    !
    !                        f
    !                          Contains the solution x.
    !
    !                        ierror
    !                          An error flag that indicates invalid input
    !                          parameters.  except for number zero, a
    !                          solution is not attempted.
    !                          = 0  no error
    !                          = 1  if lperod < 0 or > 4
    !                          = 2  if l < 3
    !                          = 3  if mperod < 0 or > 4
    !                          = 4  if m < 3
    !                          = 5  if nperod < 0 or > 1
    !                          = 6  if n < 3
    !                          = 7  if ldimf < l
    !                          = 8  if mdimf < m
    !                          = 9  if a(k) /= c(1) or c(k) /= c(1)
    !                               or b(i) /=b(1) for some k=1, 2, ..., n.
    !                          = 10 if nperod = 1 and a(1) /= 0
    !                               or c(n) /= 0
    !                          = 20 If the dynamic allocation of real and
    !                               complex workspace required for solution
    !                               fails (for example if n, m are too large
    !                               for your computer)
    !
    !                          Since this is the only means of indicating a
    !                          possibly incorrect call to pois3d, the user
    !                          should test ierror after the call.
    !
    ! HISTORY                * Written by Roland Sweet at NCAR in the late
    !                          1970's.  released on NCAR's public software
    !                          libraries in January, 1980.
    !                        * Revised in June 2004 by John Adams using
    !                          Fortran 90 dynamically allocated workspace.
    !
    ! ALGORITHM              This subroutine solves three-dimensional block
    !                        tridiagonal linear systems arising from finite
    !                        difference approximations to three-dimensional
    !                        poisson equations using the FFT package
    !                        fftpack written by Paul Swarztrauber.
    !
    ! TIMING                 For large l, m and n, the operation count
    !                        is roughly proportional to
    !                          l*m*n*(log2(l)+log2(m)+5)
    !                        but also depends on input parameters lperod
    !                        and mperod.
    !
    ! ACCURACY               To measure the accuracy of the algorithm a
    !                        uniform random number generator was used to
    !                        create a solution array x for the system given
    !                        in the 'purpose' section with
    !                          a(k) = c(k) = -HALF *b(k) = 1,  k=1, 2, ..., n
    !                        and, when nperod = 1
    !                          a(1) = c(n) = 0
    !                          a(n) = c(1) = 2.
    !
    !                        The solution x was substituted into the given
    !                        system and, using double precision, a right
    !                        side y was computed.  using this array y
    !                        subroutine pois3d was called to produce an
    !                        approximate solution z.  Relative error
    !
    !                         = max(abs(z(i, j, k)-x(i, j, k)))/max(abs(x(i, j, k
    !
    !                        was computed, where the two maxima are taken
    !                        over i=1, 2, ..., l, j=1, 2, ..., m and k=1, 2, ..., n.
    !                        values of e are given in the table below for
    !                        some typical values of l, m and n.
    !
    !                        l(=m=n)   lperod    mperod       e
    !                        ------    ------    ------     ------
    !
    !                          16        0         0        1.e-13
    !                          15        1         1        4.e-13
    !                          17        3         3        2.e-13
    !                          32        0         0        2.e-13
    !                          31        1         1        2.e-12
    !                          33        3         3        7.e-13
    !
    module subroutine pois3d(lperod, l, c1, mperod, m, c2, nperod, n, a, b, c, &
        ldimf, mdimf, f, ierror)

        ! Dummy arguments
        integer(ip), intent(in)    :: lperod
        integer(ip), intent(in)    :: l
        integer(ip), intent(in)    :: mperod
        integer(ip), intent(in)    :: m
        integer(ip), intent(in)    :: nperod
        integer(ip), intent(in)    :: n
        integer(ip), intent(in)    :: ldimf
        integer(ip), intent(in)    :: mdimf
        integer(ip), intent(out)   :: ierror
        real(wp),    intent(in)    :: c1
        real(wp),    intent(in)    :: c2
        real(wp),    intent(inout) :: a(:)
        real(wp),    intent(inout) :: b(:)
        real(wp),    intent(inout) :: c(:)
        real(wp),    intent(inout) :: f(:,:,:)

        ! Local variables
        type(FishpackWorkspace) :: workspace
        type(SolverUtility3D)   :: util3d

        ! Check input arguments
        call util3d%check_input_arguments(lperod, l, mperod, m, nperod, n, &
            a, b, c, ldimf, mdimf, ierror)

        ! Check error flag
        if (ierror /= 0) return

        ! Allocate memory
        call initialize_workspace(n, m, l, workspace)

        ! Solve system
        associate( &
            rew => workspace%real_workspace, &
            indx => workspace%workspace_indices &
            )
            call util3d%pois3dd(lperod, l, c1, mperod, m, c2, nperod, n, &
                a, b, c, ldimf, mdimf, f, ierror, rew, indx)
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine pois3d

    subroutine initialize_workspace(n, m, l, workspace)

        ! Dummy arguments
        integer(ip),              intent(in)  :: n
        integer(ip),              intent(in)  :: m
        integer(ip),              intent(in)  :: l
        class(FishpackWorkspace), intent(out) :: workspace

        ! Local variables
        integer(ip)     :: irwk, icwk
        type(SolverUtility3D) :: aux

        ! Adjust workspace for pois3d
        irwk = 30 + l + m + (2 * n) + max(l, m, n) + 7 * ( (l + 1)/2 + (m + 1)/2)
        icwk = 0

        ! Allocate memory
        call workspace%create(irwk, icwk, aux%IIWK)

        ! Set workspace indices
        workspace%workspace_indices = aux%get_workspace_indices(l, m, n)

    end subroutine initialize_workspace

end submodule general_linear_systems_solver_3d


program SpherePSEConvTest

use NumberKindsModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use EdgesModule
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use SphereGeomModule
use PSEDirectSumModule

implicit none

include 'mpif.h'

!
! mesh variables
!
type(PolyMesh2d) :: sphere
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: faceKind
integer(kint) :: meshSeed
integer(kint) :: amrLimit
real(kreal) :: radius = 1.0_kreal
namelist /meshDefine/ faceKind, initNest, amrLimit, radius, psePower
!
! pse variables
!
type(PSE) :: pseSetup
real(kreal) :: psePower
!
! test case variables
!
type(Field) :: constScalar
type(Field) :: constScalarInterp
type(Field) :: constScalarInterpErr
type(Field) :: constScalarLap
real(kreal), parameter :: constVal = 2.0_kreal
type(Field) :: harmonic
type(Field) :: harmonicInterp
type(Field) :: harmonicInterpError
type(Field) :: harmonicLapExact
type(Field) :: harmonicLapPSE
type(Field) :: harmonicLapError
type(Field) :: streamFnScalar
integer(kint), parameter :: nLat = 181
integer(kint), parameter :: nLon = 360
real(kreal) :: dlam
real(kreal) :: lats(nLat)
real(kreal) :: lons(nLon)
real(kreal) :: constData(nLat, nLon)
real(kreal) :: constInterp(nLat, nLon)
real(kreal) :: constInterpErr(nLat,nLon)
real(kreal) :: constLap(nLat, nLon)
real(kreal) :: harmData(nLat, nLon)
real(kreal) :: harmInterp(nLat, nLon)
real(kreal) :: harmInterpError(nLat, nLon)
real(kreal) :: harmLap(nLat, nLon)
real(kreal) :: harmLapExact(nLat,nLon)
real(kreal) :: harmLapError(nLat,nLon)
real(kreal) :: stream(nLat,nLon)
real(kreal) ::unifLinfConst
real(kreal) ::unifL2Const
real(kreal) ::unifLinfConstLap
real(kreal) ::unifL2ConstLap
real(kreal) ::unifLinfHarm
real(kreal) ::unifL2Harm
real(kreal) ::unifLinfHarmLap
real(kreal) ::unifL2HarmLap
real(kreal) ::particlesLinfConst
real(kreal) ::particlesL2Const
real(kreal) ::particlesLinfConstLap
real(kreal) ::particlesL2ConstLap
real(kreal) ::particlesLinfHarm
real(kreal) ::particlesL2Harm
real(kreal) ::particlesLinfHarmLap
real(kreal) ::particlesL2HarmLap
real(kreal) :: harmDenom
real(kreal) :: harmLapDenom

!
! i/o
!
character(len=MAX_STRING_LENGTH) :: testTitle
character(len=MAX_STRING_LENGTH) :: outputDir
character(len=MAX_STRING_LENGTH) :: outputRoot
character(len=MAX_STRING_LENGTH) :: vtkFile
character(len=MAX_STRING_LENGTH) :: matlabFile
character(len=MAX_STRING_LENGTH) :: meshString
namelist /fileIO/ outputDir, outputRoot
integer(kint) :: writeStat
!
! computing environment / general
!
type(MPISetup) :: mpiParticles
type(MPISetup) :: mpiLongitudes
type(Logger) :: exeLog
character(len=MAX_STRING_LENGTH) :: logString
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL
character(len=28) :: logKey = "SpherePSEConvTest"
integer(kint) :: mpiErrCode
real(kreal) :: timeStart, timeEnd
integer(kint) :: i, j, k
real(kreal), dimension(3) :: xi, xj
real(kreal) :: xx, yy, zz, pseKin, lapKernel, greensKernel
real(kreal), parameter :: fourPi = 4.0_kreal * PI

!--------------------------------
!	initialize : setup mesh and computing environment
!--------------------------------

call MPI_INIT(mpiErrCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD, numProcs, mpiErrCode)
call MPI_COMM_RANK(MPI_COMM_WORLD, procRank, mpiErrCode)

call InitLogger(exeLog, procRank)

call ReadNamelistFile( procRank )

timeStart = MPI_WTIME()

!
!	mesh and spatial field setup
!
call New(sphere, meshSeed, initNest, maxNest, amrLimit, radius)
if ( procRank == 0 ) then
	write(testTitle,'(A,X,F9.6)') trim(testTitle), MaxEdgeLength(sphere%edges, sphere%particles)
endif
call StartSection(exeLog, trim(testTitle))

call New(constScalar, 1, sphere%particles%N_Max, "constantScalar")
call New(harmonic, 1, sphere%particles%N_Max, "harmonicExact")
call New(harmonicLapExact, 1, sphere%particles%N_Max, "harmLapExact")
call New(streamFnScalar,1,sphere%particles%N_Max, "streamFn")
call SetScalarFieldOnMesh( sphere, constScalar, ConstantScalarFn )
call SetScalarFieldOnMesh( sphere, harmonic, SphericalHarmonicFn )
call SetScalarFieldOnMesh( sphere, harmonicLapExact, ExactHarmonicLaplacian )

call New(constScalarLap, 1, sphere%particles%N, "constScalarLap")
call New(harmonicLapError, 1, sphere%particles%N_Max, "harmLapError")
call New(harmonicLapPSE, 1, sphere%particles%N_Max, "harmLapPSE")

call New(constScalarInterp, 1, sphere%particles%N, "constScalarInterp")
call New(harmonicInterp, 1, sphere%particles%N, "harmonicInterp")
call New(harmonicInterpError, 1, sphere%particles%N, "harmonicInterpError")

dlam = 360.0_kreal / nLon
do i = 1, nLat
	lats(i) = - 0.5_kreal * PI + (i-1) * dlam * DEG_2_RAD
enddo
do j = 1, nLon
	lons(j) = (j-1) * dlam * DEG_2_RAD
enddo

do j = 1, nLon
	do i = 1, nLat
		xx = radius * cos( lons(j) ) * cos(lats(i))
		yy = radius * sin( lons(j) ) * cos(lats(i))
		zz = radius * sin( lats(i) )
		constData(i,j) = constVal
		harmData(i,j) = SphericalHarmonicFn( xx, yy, zz)
		harmLapExact(i,j) = ExactHarmonicLaplacian( xx, yy, zz)
	enddo
enddo

!--------------------------------
!	run : perform interpolation tests
!--------------------------------
call New( mpiLongitudes, nLon, numProcs )
call New( mpiParticles, sphere%particles%N, numProcs)

call New(pseSetup, sphere, psepower)

!
!	interpolation to uniform lat-lon grid
!
constLap = 0.0_kreal
harmLap = 0.0_kreal
stream = 0.0_kreal
do j = mpiLongitudes%indexStart(procRank), mpiLongitudes%indexEnd(procRank)
	do i = 1, nLat
		xx = radius * cos( lons(j) ) * cos(lats(i))
		yy = radius * sin( lons(j) ) * cos(lats(i))
		zz = radius * sin( lats(i) )
		constInterp(i,j) = PSESphereInterpolateScalar( pseSetup, sphere, constScalar, [xx, yy, zz])
		harmInterp(i,j) = PSESphereInterpolateScalar( pseSetup, sphere, harmonic, [xx, yy, zz] )

		do k = 1, sphere%particles%N
			if ( sphere%particles%isActive(k) ) then
				pseKin = SphereDistance( PhysCoord(sphere%particles, k), [xx, yy, zz]) / pseSetup%eps
				lapKernel = bivariateLaplacianKernel8( pseKin ) / pseSetup%eps**2
				greensKernel = log( radius * radius - xx * sphere%particles%x(k) - yy * sphere%particles%y(k) - &
					zz * sphere%particles%z(k) ) / fourPi

				constLap(i,j) = constLap(i,j) + lapKernel * ( constScalar%scalar(k) - constData(i,j) ) * &
					sphere%particles%area(k) / pseSetup%eps**2
				harmLap(i,j) = harmLap(i,j) + lapKernel * ( harmonic%scalar(k) - harmData(i,j) ) * &
					sphere%particles%area(k) / pseSetup%eps**2
				stream(i,j) = stream(i,j) + greensKernel * harmonicLapExact%scalar(k) * sphere%particles%area(k)
			endif
		enddo
	enddo
enddo

do i = 0, numProcs - 1
	call MPI_BCAST( constInterp(:, mpiLongitudes%indexStart(i):mpiLongitudes%indexEnd(i)), &
		nLat * mpiLongitudes%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode )
	call MPI_BCAST( harmInterp(:, mpiLongitudes%indexStart(i):mpiLongitudes%indexEnd(i)), &
		nLat * mpiLongitudes%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode )
	call MPI_BCAST( constLap(:, mpiLongitudes%indexStart(i):mpiLongitudes%indexEnd(i)), &
		nLat * mpiLongitudes%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode )
	call MPI_BCAST( harmLap(:, mpiLongitudes%indexStart(i):mpiLongitudes%indexEnd(i)), &
		nLat * mpiLongitudes%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode )
	call MPI_BCAST( stream(:, mpiLongitudes%indexStart(i):mpiLongitudes%indexEnd(i)), &
		nLat * mpiLongitudes%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode )
enddo

constInterpErr = abs( constInterp - constVal )
harmInterpError = abs( harmInterp - harmData )
harmLapError = abs( harmLap - harmLapExact )

!
!	interpolation to particles & fields
!
constScalarLap%N = sphere%particles%N
harmonicLapPSE%N = sphere%particles%N
harmonicLapError%N = sphere%particles%N
harmonicInterp%N = sphere%particles%N
harmonicInterpError%N = sphere%particles%N
constScalarInterp%N = sphere%particles%N
streamFnScalar%N = sphere%particles%N

call SetFieldToZero( constScalarLap )
call SetFieldToZero( harmonicLapPSE )
call SetFieldToZero( streamFnScalar )

do i = mpiParticles%indexStart(procRank), mpiParticles%indexEnd(procRank)
	xi = PhysCoord(sphere%particles, i)

	constScalarInterp%scalar(i) = PSESphereInterpolateScalar( pseSetup, sphere, constScalar, xi )
	harmonicInterp%scalar(i) = PSESphereInterpolateScalar( pseSetup, sphere, harmonic, xi)

	do j = 1, sphere%particles%N
		if ( sphere%particles%isActive(j) ) then
			xj = PhysCoord(sphere%particles, j)
			pseKin = SphereDistance( xi, xj ) / pseSetup%eps
			lapKernel = bivariateLaplacianKernel8( pseKin ) / pseSetup%eps**2
			greensKernel = log( radius * radius - sum(xi*xj) ) / fourPi

			if ( j == i ) greensKernel = 0.0_kreal

			constScalarLap%scalar(i) = constScalarLap%scalar(i) + lapKernel * ( constScalar%scalar(j) - constScalar%scalar(i)) * &
				sphere%particles%area(j) / pseSetup%eps**2
			harmonicLapPSE%scalar(i) = harmonicLapPSE%scalar(i) + lapKernel * ( harmonic%scalar(j) - harmonic%scalar(i) ) * &
				sphere%particles%area(j) / pseSetup%eps**2

			streamFnScalar%scalar(i) = streamFnScalar%scalar(i) + greensKernel * harmonicLapExact%scalar(j) * &
				sphere%particles%area(j)
		endif
	enddo
enddo

do i = 0, numProcs - 1
	call MPI_BCAST( constScalarInterp%scalar( mpiParticles%indexStart(i): mpiParticles%indexEnd(i)), &
		mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	call MPI_BCAST( constScalarLap%scalar( mpiParticles%indexStart(i): mpiParticles%indexEnd(i)), &
		mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	call MPI_BCAST( harmonicInterp%scalar( mpiParticles%indexStart(i): mpiParticles%indexEnd(i)), &
		mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	call MPI_BCAST( harmonicLapPSE%scalar( mpiParticles%indexStart(i): mpiParticles%indexEnd(i)), &
		mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	call MPI_BCAST( streamFnScalar%scalar( mpiParticles%indexStart(i): mpiParticles%indexEnd(i)), &
		mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
enddo

harmonicInterpError%scalar = abs( harmonicInterp%scalar - harmonic%scalar )
harmonicLapError%scalar = abs( harmonicLapPSE%scalar - harmonicLapExact%scalar )

!
!	compute error norms
!
particlesLinfConst = maxval(abs( constScalarInterp%scalar - constVal )) / abs( constVal)
particlesLinfConstLap = maxval( abs( constScalarLap%scalar ))
particlesLinfHarm = maxval( harmonicInterpError%scalar ) / maxval(abs(harmonic%scalar))
particlesLinfHarmLap = maxval( harmonicLapError%scalar ) / maxval(abs(harmonicLapExact%scalar))

harmDenom = 0.0_kreal
harmLapDenom = 0.0_kreal
particlesL2Const = 0.0_kreal
particlesL2ConstLap = 0.0_kreal
particlesL2Harm = 0.0_kreal
particlesL2HarmLap = 0.0_kreal
do k = mpiParticles%indexStart(procRank), mpiParticles%indexEnd(procRank)
	if ( sphere%particles%isActive(k) ) then
		harmDenom = harmDenom + harmonic%scalar(k)**2 * sphere%particles%area(k)
		harmLapDenom = harmLapDenom + harmonicLapExact%scalar(k)**2 * sphere%particles%area(k)

		particlesL2Const = particlesL2Const + ( constScalarInterp%scalar(k) - constVal )**2 * sphere%particles%area(k)
		particlesL2ConstLap = particlesL2ConstLap + constScalarLap%scalar(k)**2 * sphere%particles%area(k)

		particlesL2Harm = particlesL2Harm + harmonicInterpError%scalar(k)**2 * sphere%particles%area(k)
		particlesL2HarmLap = particlesL2HarmLap + harmonicLapError%scalar(k)**2 * sphere%particles%area(k)
	endif
enddo

call MPI_Reduce( [harmDenom, harmLapDenom, particlesL2Const, particlesL2ConstLap, particlesL2Harm, particlesL2HarmLap], &
	[harmDenom, harmLapDenom, particlesL2Const, particlesL2ConstLap, particlesL2Harm, particlesL2HarmLap],&
	6, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, mpiErrCode )

particlesL2Const = particlesL2Const / ( 4.0_kreal * PI * radius * radius * constVal * constVal )
particlesL2Harm = particlesL2Harm / harmDenom
particlesL2HarmLap = particlesL2HarmLap / harmLapDenom

unifL2Const = 0.0_kreal
unifL2ConstLap = 0.0_kreal
unifL2Harm = 0.0_kreal
unifL2HarmLap = 0.0_kreal
do j = mpiLongitudes%indexStart(procRank), mpiLongitudes%indexEnd(procRank)
	do i = 1, nLat
		unifL2Const = unifL2Const + ( constInterp(i,j) - constVal )**2 * cos(lats(i))
		unifL2Harm = unifL2Harm + ( harmInterp(i,j) - harmData(i,j) )**2 * cos(lats(i))
		unifL2ConstLap = unifL2ConstLap + constLap(i,j) ** 2 * cos(lats(i))
		unifL2HarmLap = unifL2HarmLap + ( harmLap(i,j) - harmLapExact(i,j) )**2 * cos(lats(i))
	enddo
enddo

call MPI_Reduce( [unifL2Const, unifL2ConstLap, unifL2Harm, unifL2HarmLap], &
				 [unifL2Const, unifL2ConstLap, unifL2Harm, unifL2HarmLap], 4, MPI_DOUBLE_PRECISION, MPI_SUM, 0, &
				 MPI_COMM_WORLD, mpiErrCode )

unifLinfConst = maxval( abs( constInterp - constVal )) / abs( constVal )
unifLinfConstLap = maxval( abs( constLap ) )
unifLinfHarm = maxval( abs( harmInterp - harmData )) / maxval(abs(harmData))
unifLinfHarmLap = maxval( abs( harmLap - harmLapExact)) / maxval(abs(harmLapExact))

unifL2Const = unifL2Const / ( 4.0_kreal * PI * radius * radius * constVal * constVal )
unifL2Harm = unifL2Harm / harmDenom
unifL2HarmLap = unifL2HarmLap / harmLapDenom

call StartSection(exeLog, "Particles to Uniform Grid approximations")
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "constInterpLinf = ", unifLinfConst )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "constInterpL2 = ", unifL2Const )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "constLapLinf = ", unifLinfConstLap )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "constLapL2 = ", unifL2ConstLap )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "harmInterpLinf = ", unifLinfHarm )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "harmInterpL2 = ", unifL2Harm )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "harmLapLinf = ", unifLinfHarmLap )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "harmLapL2 = ", unifL2HarmLap )
call EndSection(exeLog)

call StartSection(exeLog, "Particles to Particles approximations")
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "constInterpLinf = ", particlesLinfConst )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "constInterpL2 = ", particlesL2Const )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "constLapLinf = ", particlesLinfConstLap )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "constLapL2 = ", particlesL2ConstLap )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "harmInterpLinf = ", particlesLinfHarm )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "harmInterpL2 = ", particlesL2Harm )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "harmLapLinf = ", particlesLinfHarmLap )
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "harmLapL2 = ", particlesL2HarmLap )
call EndSection(exeLog)

harmonicInterpError%scalar = harmonicInterpError%scalar / maxval(abs(harmonic%scalar))
harmonicLapError%scalar = harmonicLapError%scalar / maxval(abs(harmonicLapExact%scalar))

if (procRank==0) then
    if (unifLinfConstLap > ZERO_TOL .OR. unifL2ConstLap > ZERO_TOL .OR. &
        particlesLinfConstLap > ZERO_TOL .OR. particlesL2ConstLap > ZERO_TOL) then
            call logMessage(exeLog, ERROR_LOGGING_LEVEL, "", "TEST FAIL: Constant Laplacian /= 0.0")
    endif

    if (unifLinfHarm > 0.018 .OR. unifLinfHarmLap > 0.01805) then
        call LogMessage(exeLog, ERROR_LOGGING_LEVEL, " ", "TEST FAIL: uniform harmonic regression.")
    endif

    if (particlesLinfHarm > 0.0176 .OR. particlesL2Harm > 0.0002) then
        call LogMessage(exeLog, ERROR_LOGGING_LEVEL, " ", "TEST FAIL: particles harmonic interpolation regression")
    endif

    if (particlesLinfHarmLap > 0.0175 .OR. particlesL2HarmLap > 0.000118) then
        call LogMessage(exeLog, ERROR_LOGGING_LEVEL, "", "TEST FAIL: particles laplacian approximation regression.")
    endif
endif

!--------------------------------
!	finalize : write output, clean up
!--------------------------------
if ( procRank == 0 ) then
	!
	!	write output to vtk/paraview
	!
	open( unit=WRITE_UNIT_1, file=vtkFile, status='REPLACE', action='WRITE', iostat=writeStat)
		if ( writeStat /= 0 ) then
			call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logkey)//" OutputToVTK ERROR writing to file = ", trim(vtkFile))
		else
			call WriteVTKPoints( sphere%particles, WRITE_UNIT_1)
			call WriteFacesToVTKPolygons( sphere%faces, WRITE_UNIT_1)

			call WriteVTKPointDataSectionHeader(WRITE_UNIT_1, sphere%particles%N)

			call WriteFieldToVTKPointData( constScalar, WRITE_UNIT_1)
			call WriteFieldToVTKPointData( constScalarInterp, WRITE_UNIT_1)
			call WriteFieldToVTKPointData( constScalarLap, WRITE_UNIT_1)

			call WriteFieldToVTKPointData( harmonic, WRITE_UNIT_1 )
			call WriteFieldToVTKPointData( harmonicInterp, WRITE_UNIT_1 )
			call WriteFieldToVTKPointData( harmonicInterpError, WRITE_UNIT_1 )

			call WriteFieldToVTKPointData( harmonicLapPSE, WRITE_UNIT_1 )
			call WriteFieldToVTKPointData( harmonicLapExact, WRITE_UNIT_1 )
			call WriteFieldToVTKPointData( harmonicLapError, WRITE_UNIT_1 )

			call WriteFieldToVTKPointData( streamFnScalar, WRITE_UNIT_1 )

			call WriteFaceAreaToVTKCellData( sphere%faces, sphere%particles, WRITE_UNIT_1)
		endif
	close(WRITE_UNIT_1)
	!
	!	write output to matlab
	!
	open( unit=WRITE_UNIT_1, file=matlabFile, status='REPLACE', action='WRITE', iostat=writeStat)
		if ( writeStat /= 0 ) then
			call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logkey)//" OutputToMatlab ERROR writing to file = ", trim(matlabFile))
		else
			call WriteToMatlab(lons, WRITE_UNIT_1, "lons")
			call WriteToMatlab(lats, WRITE_UNIT_1, "lats")

			call WriteToMatlab( constData, WRITE_UNIT_1, "const")
			call WriteToMatlab( constLap, WRITE_UNIT_1, "constLap")
			call WriteToMatlab( constInterp, WRITE_UNIT_1, "constInterp")

			call WriteToMatlab( harmData, WRITE_UNIT_1, "harm54")
			call WriteToMatlab( harmInterp, WRITE_UNIT_1, "harmInterp")
			call WriteToMatlab( harmLap, WRITE_UNIT_1, "harmLap")
			call WriteToMatlab( harmLapExact, WRITE_UNIT_1, "harmLapExact")

			call WriteToMatlab( stream, WRITE_UNIT_1, "streamFn")
		endif
	close(WRITE_UNIT_1)
endif
!
!----------------
! PROGRAM END
!----------------
!
timeEnd = MPI_WTIME()

write(logstring,'(A,F12.2,A)') "PROGRAM COMPLETE : elapsed time ", timeEnd - timeStart, " seconds."
call LogMessage(exelog, TRACE_LOGGING_LEVEL, trim(logkey)//" ", logString)

call EndSection(exeLog)

call Delete(harmonicLapError)
call Delete(harmonicLapExact)
call Delete(harmonicLapPSE)
call Delete(pseSetup)
call Delete(mpiParticles)
call Delete(mpiLongitudes)
call Delete(constScalar)
call Delete(harmonic)
call Delete(sphere)

if (testPass) call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "test result: ", "PASSED.")

call MPI_FINALIZE(mpiErrCode)

contains

subroutine SetScalarFieldOnMesh(sphere, aField, scalarFn)
	type(PolyMesh2d), intent(in) :: sphere
	type(Field), intent(inout) :: aField
	procedure(scalarFnOf3DSpace) :: scalarFn
	!
	integer(kint) :: i

	aField%N = sphere%particles%N
	do i = 1, sphere%particles%N
		aField%scalar(i) = scalarFn( sphere%particles%x(i), sphere%particles%y(i), sphere%particles%z(i) )
	enddo
end subroutine

pure function ConstantScalarFn( x, y, z )
	real(kreal) :: ConstantScalarFn
	real(kreal), intent(in) :: x, y, z
	ConstantScalarFn = constVal
end function

pure function SphericalHarmonicFn( x, y, z )
	real(kreal) :: SphericalHarmonicFn
	real(kreal), intent(in) :: x, y, z
	!
	real(kreal) :: lat, lon

	lat = Latitude( x, y, z )
	lon = Longitude( x, y, z)

	SphericalHarmonicFn = 3.0_kreal * sqrt(35.0_kreal) * cos( 4.0_kreal * lon ) * sin( lat ) *  &
		(-1.0_kreal + sin( lat ) * sin( lat ) )**2
end function

pure function ExactHarmonicLaplacian( x, y, z )
	real(kreal) :: ExactHarmonicLaplacian
	real(kreal), intent(in) :: x, y, z
	ExactHarmonicLaplacian = -30.0_kreal * SphericalHarmonicFn(x,y,z)
end function

!> @brief Reads a namelist file, which must be specified on the command line at run-time execution as the first argument,
!> to define the user-specified variables for this driver program.
!>
!> Only MPI rank 0 reads the file; it then broadcasts the relevant data to all other ranks.
!>
!> @param[in] rank MPI rank
subroutine ReadNamelistFile( rank )
	integer(kint), intent(in) :: rank
	!
	character(len=MAX_STRING_LENGTH) :: namelistFilename
	integer(kint), parameter :: initBcast_intSize = 4
	integer(kint), parameter :: initBcast_realSize = 2
	integer(kint), dimension(initBcast_intSize) :: bcastIntegers
	real(kreal), dimension(initBcast_realSize) :: bcastReals
	integer(kint) :: mpiErrCode, readStat

	if ( COMMAND_ARGUMENT_COUNT() /= 1 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey), " ERROR: expected namelist file as 1st argument.")
		stop
	endif

	if ( rank == 0 ) then
		call GET_COMMAND_ARGUMENT(1, namelistFilename)

		open(unit=READ_UNIT, file=namelistFilename, status='OLD', action='READ', iostat=readStat)
			if ( readStat /= 0 ) then
				call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey), " ERROR: cannot read namelist file.")
				stop
			endif

			read(READ_UNIT, nml=meshDefine)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=fileIO)
		close(READ_UNIT)

		if ( faceKind == 3 ) then
			meshSeed = ICOS_TRI_SPHERE_SEED
		elseif ( faceKind == 4) then
			meshSeed = CUBED_SPHERE_SEED
		else
			call LogMessage(exeLog, WARNING_LOGGING_LEVEL, trim(logkey)//" ReadNamelistFile WARNING : ", &
				" invalid faceKind -- using triangles.")
			meshSeed = ICOS_TRI_SPHERE_SEED
		endif

		maxNest = initNest + amrLimit

		if (meshSeed == ICOS_TRI_SPHERE_SEED) then
			if ( initNest == maxNest ) then
				write(meshString, '(A,I1)') '_icosTri', initNest
				write(testTitle,'(A,I1,A)') "PSE Convergence Test, Icos. Tri., nest = ", initNest, " mesh size = "
			else
				write(meshString, '(2(A,I1))') '_icosTriAMR', initNest, 'to', maxNest
			endif
		elseif (meshSeed == CUBED_SPHERE_SEED ) then
			if ( initNest == maxNest ) then
				write(meshString, '(A,I1)') '_cubedSphere', initNest
				write(testTitle,'(A,I1,A)') "PSE Convergence Test, Cubed Sphere, nest = ", initNest, " mesh size = "
			else
				write(meshString, '(2(A,I1))') '_cubedSphereAMR', initNest, 'to', maxNest
			endif
		endif

		write(vtkFile,'(4A)') trim(outputDir), trim(outputRoot), trim(meshString), '.vtk'
		write(matlabFile,'(5A)') trim(outputDir), '/', trim(outputRoot), trim(meshString), '.m'

		bcastIntegers(1) = meshSeed
		bcastIntegers(2) = initNest
		bcastIntegers(3) = maxNest
		bcastIntegers(4) = amrLimit

		bcastReals(1) = radius
		bcastReals(2) = psePower
	endif

	call MPI_BCAST(bcastIntegers, initBCAST_intSize, MPI_INTEGER, 0, MPI_COMM_WORLD, mpiErrCode)
	if ( mpiErrCode /= 0 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey)//" bcastIntegers, MPI_BCAST ERROR : ", mpiErrCode)
	endif

	call MPI_BCAST(bcastReals, initBCAST_realSize, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, mpiErrCode)
	if ( mpiErrCode /= 0 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey)//" bcastReals, MPI_BCAST ERROR : ", mpiErrCode)
	endif

	meshSeed = bcastIntegers(1)
	initNest = bcastIntegers(2)
	maxNest = bcastIntegers(3)
	amrLimit = bcastIntegers(4)

	radius = bcastReals(1)
	psePower = bcastReals(2)
end subroutine

!> @brief Initializes a @ref Logger for this executable program.
!>
!> Output is controlled by message priority level and MPI rank.
!>
!> @param[in] log @ref Logger to initialize
!> @param[in] rank MPI rank

subroutine InitLogger(log, rank)
	type(Logger), intent(inout) :: log
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		call New(log, logLevel)
	else
		call New(log, ERROR_LOGGING_LEVEL)
	endif
	write(logKey,'(A,I0.2,A)') trim(logKey)//"_", rank, ":"
end subroutine

end program


      subroutine cubsplb ( tau, c, n, ibcbeg, ibcend )
c
c  from  * a practical guide to splines *  by c. de boor
c     ************************  input  ***************************
c     n = number of data points. assumed to be .ge. 2.
c     (tau(i), c(1,i), i=1,...,n) = abscissae and ordinates of the
c        data points. tau is assumed to be strictly increasing.
c     ibcbeg, ibcend = boundary condition indicators, and
c     c(2,1), c(2,n) = boundary condition information. specifically,
c        ibcbeg = 0  means no boundary condition at tau(1) is given.
c           in this case, the not-a-knot condition is used, i.e. the
c           jump in the third derivative across tau(2) is forced to
c           zero, thus the first and the second cubic polynomial pieces
c           are made to coincide.)
c        ibcbeg = 1  means that the slope at tau(1) is made to equal
c           c(2,1), supplied by input.
c        ibcbeg = 2  means that the second derivative at tau(1) is
c           made to equal c(2,1), supplied by input.
c        ibcend = 0, 1, or 2 has analogous meaning concerning the
c           boundary condition at tau(n), with the additional infor-
c           mation taken from c(2,n).
c     ***********************  output  **************************
c     c(j,i), j=1,...,4; i=1,...,l (= n-1) = the polynomial coefficients
c        of the cubic interpolating spline with interior knots (or
c        joints) tau(2), ..., tau(n-1). precisely, in the interval
c        (tau(i), tau(i+1)), the spline f is given by
c           f(x) = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.)
c        where h = x - tau(i). the function program *ppvalu* may be
c        used to evaluate f or its derivatives from tau,c, l = n-1,
c        and k=4.
c
      implicit none
      integer ibcbeg,ibcend,n,   i,j,l,m
c
      real c(4,n),tau(n),   divdf1,divdf3,dtau,g
c
c****** a tridiagonal linear system for the unknown slopes s(i) of
c  f  at tau(i), i=1,...,n, is generated and then solved by gauss elim-
c  ination, with s(i) ending up in c(2,i), all i.
c     c(3,.) and c(4,.) are used initially for temporary storage.
      l = n-1
compute first differences of tau sequence and store in c(3,.). also,
compute first divided difference of data and store in c(4,.).
      do m=2,n
         c(3,m) = tau(m) - tau(m-1)
         c(4,m) = (c(1,m) - c(1,m-1))/c(3,m)
      end do

construct first equation from the boundary condition, of the form
c             c(4,1)*s(1) + c(3,1)*s(2) = c(2,1)
      if (ibcbeg - 1 .lt. 0) then
         goto 11
      else if (ibcbeg - 1 .eq. 0) then
         goto 15
      else
         goto 16
      end if
   11 if (n .gt. 2)                     go to 12
c     no condition at left end and n = 2.
      c(4,1) = 1.
      c(3,1) = 1.
      c(2,1) = 2.*c(4,2)
                                        go to 25
c     not-a-knot condition at left end and n .gt. 2.
   12 c(4,1) = c(3,3)
      c(3,1) = c(3,2) + c(3,3)
      c(2,1) =((c(3,2)+2.*c(3,1))*c(4,2)*c(3,3)+
     >   c(3,2)**2*c(4,3))/c(3,1)
                                        go to 19
c     slope prescribed at left end.
   15 c(4,1) = 1.
      c(3,1) = 0.
                                        go to 18
c     second derivative prescribed at left end.
   16 c(4,1) = 2.
      c(3,1) = 1.
      c(2,1) = 3.*c(4,2) - c(3,2)/2.*c(2,1)
   18 if(n .eq. 2)                      go to 25
c  if there are interior knots, generate the corresp. equations and car-
c  ry out the forward pass of gauss elimination, after which the m-th
c  equation reads    c(4,m)*s(m) + c(3,m)*s(m+1) = c(2,m).
   19 do m=2,l
         g = -c(3,m+1)/c(4,m-1)
         c(2,m) = g*c(2,m-1) + 3.*(c(3,m)*c(4,m+1)+c(3,m+1)*c(4,m))
         c(4,m) = g*c(3,m-1) + 2.*(c(3,m) + c(3,m+1))
      end do
construct last equation from the second boundary condition, of the form
c           (-g*c(4,n-1))*s(n-1) + c(4,n)*s(n) = c(2,n)
c     if slope is prescribed at right end, one can go directly to back-
c     substitution, since c array happens to be set up just right for it
c     at this point.
      if (ibcend - 1 .lt. 0) then
         goto 21
      else if (ibcend - 1 .eq. 0) then
         goto 30
      else
         goto 24
      end if
   21 if (n .eq. 3 .and. ibcbeg .eq. 0) go to 22
c     not-a-knot and n .ge. 3, and either n.gt.3 or  also not-a-knot at
c     left end point.
      g = c(3,n-1) + c(3,n)
      c(2,n) = ((c(3,n)+2.*g)*c(4,n)*c(3,n-1)
     *            + c(3,n)**2*(c(1,n-1)-c(1,n-2))/c(3,n-1))/g
      g = -g/c(4,n-1)
      c(4,n) = c(3,n-1)
                                        go to 29
c     either (n=3 and not-a-knot also at left) or (n=2 and not not-a-
c     knot at left end point).
   22 c(2,n) = 2.*c(4,n)
      c(4,n) = 1.
                                        go to 28
c     second derivative prescribed at right endpoint.
   24 c(2,n) = 3.*c(4,n) + c(3,n)/2.*c(2,n)
      c(4,n) = 2.
                                        go to 28
   25 if (ibcend - 1 .lt. 0) then
         goto 26
      else if (ibcend - 1 .eq. 0) then
         goto 30
      else
         goto 24
      end if
   26 if (ibcbeg .gt. 0)                go to 22
c     not-a-knot at right endpoint and at left endpoint and n = 2.
      c(2,n) = c(4,n)
                                        go to 30
   28 g = -1./c(4,n-1)
complete forward pass of gauss elimination.
   29 c(4,n) = g*c(3,n-1) + c(4,n)
      c(2,n) = (g*c(2,n-1) + c(2,n))/c(4,n)
carry out back substitution
   30 j = l
   40    c(2,j) = (c(2,j) - c(3,j)*c(2,j+1))/c(4,j)
         j = j - 1
         if (j .gt. 0)                  go to 40
c****** generate cubic coefficients in each interval, i.e., the deriv.s
c  at its left endpoint, from value and slope at its endpoints.
      do i=2,n
         dtau = c(3,i)
         divdf1 = (c(1,i) - c(1,i-1))/dtau
         divdf3 = c(2,i-1) + c(2,i) - 2.*divdf1
         c(3,i-1) = 2.*(divdf1 - c(2,i-1) - divdf3)/dtau
         c(4,i-1) = (divdf3/dtau)*(6./dtau)
      end do
c
                                        return
      end


      SUBROUTINE SHOOTF(NVAR,V1,V2,DELV1,DELV2,N1,N2,X1,X2,XF,EPS,H1,HMI
     *N,F,DV1,DV2)
      PARAMETER (NP=20)
      DIMENSION V1(N2),DELV1(N2),V2(N1),DELV2(N1),F(NVAR),DV1(N2),
     *    DV2(N1),Y(NP),F1(NP),F2(NP),DFDV(NP,NP),INDX(NP)
      EXTERNAL DERIVS,RKQC
      CALL LOAD1(X1,V1,Y)
      CALL ODEINT(Y,NVAR,X1,XF,EPS,H1,HMIN,NOK,NBAD,DERIVS,RKQC)
      CALL SCORE(XF,Y,F1)
      CALL LOAD2(X2,V2,Y)
      CALL ODEINT(Y,NVAR,X2,XF,EPS,H1,HMIN,NOK,NBAD,DERIVS,RKQC)
      CALL SCORE(XF,Y,F2)
      J=0
      DO 12 IV=1,N2
        J=J+1
        SAV=V1(IV)
        V1(IV)=V1(IV)+DELV1(IV)
        CALL LOAD1(X1,V1,Y)
        CALL ODEINT(Y,NVAR,X1,XF,EPS,H1,HMIN,NOK,NBAD,DERIVS,RKQC)
        CALL SCORE(XF,Y,F)
        DO 11 I=1,NVAR
          DFDV(I,J)=(F(I)-F1(I))/DELV1(IV)
11      CONTINUE
        V1(IV)=SAV
12    CONTINUE
      DO 14 IV=1,N1
        J=J+1
        SAV=V2(IV)
        V2(IV)=V2(IV)+DELV2(IV)
        CALL LOAD2(X2,V2,Y)
        CALL ODEINT(Y,NVAR,X2,XF,EPS,H1,HMIN,NOK,NBAD,DERIVS,RKQC)
        CALL SCORE(XF,Y,F)
        DO 13 I=1,NVAR
          DFDV(I,J)=(F2(I)-F(I))/DELV2(IV)
13      CONTINUE
        V2(IV)=SAV
14    CONTINUE
      DO 15 I=1,NVAR
        F(I)=F1(I)-F2(I)
        F1(I)=-F(I)
15    CONTINUE
      CALL LUDCMP(DFDV,NVAR,NP,INDX,DET)
      CALL LUBKSB(DFDV,NVAR,NP,INDX,F1)
      J=0
      DO 16 IV=1,N2
        J=J+1
        V1(IV)=V1(IV)+F1(J)
        DV1(IV)=F1(J)
16    CONTINUE
      DO 17 IV=1,N1
        J=J+1
        V2(IV)=V2(IV)+F1(J)
        DV2(IV)=F1(J)
17    CONTINUE
      RETURN
      END