Module sub_flatlens
  USE healpix_types
!USE flatlens_types

Implicit None

type grid

integer(i4b) :: nx,ny
logical isT,isPhi

end type grid

Contains

subroutine getcenter(mygrid,centercoord)
	type (grid), intent(in) :: mygrid
		integer(i8b), intent(out),dimension(0:1) :: centercoord
		if ( (mod(mygrid%nx,2).ne.0) .or. (mod(mygrid%ny,2) .ne. 0) ) then
			stop "only implemented for even grid dimensions"
		end if
		centercoord(0)=mygrid%nx/2
		centercoord(1)=mygrid%ny/2

end subroutine getcenter

subroutine real2matcoord(mygrid,realcoor,mat)
	type (grid), intent(in) :: mygrid

	integer(i8b), intent(in),dimension(0:1) :: realcoor

	integer(i8b), intent(out),dimension(0:1) :: mat
	integer(i8b), dimension(0:1) :: center
	call getcenter(mygrid,center)
	mat(0)=2*center(0)+realcoor(0)
	mat(1)=2*center(1)-realcoor(1)

end subroutine real2matcoord

subroutine mat2realcoord(mygrid,realcoor,mat)
	type (grid), intent(in) :: mygrid

	integer(i8b), intent(in),dimension(0:1) :: realcoor

	integer(i8b), intent(out),dimension(0:1) :: mat
	integer(i8b), dimension(0:1) :: center
	call getcenter(mygrid,center)
	mat(0)=2*center(0)-realcoor(0)
	mat(1)=2*center(1)-realcoor(1)

end subroutine mat2realcoord

!subroutine grid2cl(mygrid,Cl)
!	complex(DPC), intent(in), dimension(:,:) :: mygrid
!	real(DP),intent(out),dimension(:,:)::Cl
!end subroutine grid2cl

!------------------------------------------------------------------------

! subroutine to compute the ps1d(l) by azimuthal averaging the power in each fourier mode

        SUBROUTINE ps_azim(nx,ny,map,icentre,jcentre,lmax,uvcell,ps1d)
        	USE healpix_types

          Implicit None

        Integer(i4b), Intent(In) :: nx, ny, icentre,jcentre,lmax

        Complex(DPC), Intent(In) ::  map(0:nx-1,0:ny-1)
        real(DP), Intent(Out)   :: ps1d(0:lmax)

        Real(DP)  :: uvdist,sumps,uvcell
        Integer :: i,j,k,l, count(0:lmax)
       write(*,*) lmax
        write(*,*) 'center',icentre,jcentre
! initialize variables

        count = 0
        ps1d = 0d0

! Work out which value of l each pixel corresponds to and add up
! the power for each l

!write(*,*) size(map)

     Do i = 0,nx-1
        Do j = 0,ny-1
           uvdist = uvcell * Sqrt(real(i-nx/2)**2+real(j-ny/2)**2)

           l = uvdist

           If((l .le. lmax)) Then
           	  !write(*,*)'l',l,i,j

              ps1d(l) = ps1d(l)+Abs(map(i,j))**2
              count(l) = count(l) + 1
             ! write(*,*)'count(l)', count(l)
          End if
         End Do
      End Do

! the azimuthal average is scaled by uvcell**2

      !ps1d = ps1d * (2.0*pi*uvcell)**2

      !sumps=0.
      !Do k=lmin,lmax
      !   If(ps1d(k).ne.0) Then
       !     sumps = sumps+ps1d(k)
       do l = 1, lmax, 1

           	if ( count(l)/=0 ) then !! prevent by 0 division

            ps1d(l) = ps1d(l)/count(l)

           ! write(*,*) l,'  ',ps1d(l)

        end if

        end do

       !  Endif
     ! End Do

      ! Normalise sumps by map size
      !sumps = sumps * uvcell**2

     ! Write(*,*) 'Sqrt(total power) = ', sqrt(sumps)

        END SUBROUTINE ps_azim

 Subroutine read_camb(infile, cl_array, lmax)

    Use healpix_types

    Implicit none

    Character (len = *), intent(IN) :: infile
    Integer(I4B), intent(INOUT) :: lmax
    Real(DP), Intent(OUT), Dimension(0:lmax,1:2) :: cl_array

    Real(DP) :: clT,clE,clET,clphi
    Integer :: lval = 0
    Real(DP) :: cmbT = 2.726d0
    cl_array(0:1,:)=0
    ! Read in the cl values and convert to units of uK^2
    Open (Unit = 23, file = infile, status = 'old', action = 'read', err = 9980)
    Do while (lval .LT. lmax)
       Read (23, *, end = 800) lval, clT,clE,clET,clphi
       cl_array(lval,1) = clT!/(lval*(lval+1))*cmbT*cmbT*1.d12*TWOPI
       cl_array(lval,2) = clphi!/(lval**4)*cmbT*cmbT*1.d12*TWOPI

    End Do
800 lmax = lval

    Close (23)
    Return

9980 Stop 'Error opening cl file to read'

  End Subroutine read_camb

end module sub_flatlens


! { dg-do compile }
! { dg-options "-O2 -fdump-tree-optimized" }
!
! PR fortran/54556
!
! Contributed by Joost VandeVondele
!
MODULE parallel_rng_types

  IMPLICIT NONE

  ! Global parameters in this module
  INTEGER, PARAMETER :: dp=8

  TYPE rng_stream_type
    PRIVATE
    CHARACTER(LEN=40)             :: name
    INTEGER                       :: distribution_type
    REAL(KIND=dp), DIMENSION(3,2) :: bg,cg,ig
    LOGICAL                       :: antithetic,extended_precision
    REAL(KIND=dp)                 :: buffer
    LOGICAL                       :: buffer_filled
  END TYPE rng_stream_type

  REAL(KIND=dp), DIMENSION(3,3) :: a1p0,a1p76,a1p127,&
                                   a2p0,a2p76,a2p127,&
                                   inv_a1,inv_a2

  INTEGER, PARAMETER          :: GAUSSIAN = 1,&
                                 UNIFORM  = 2

  REAL(KIND=dp), PARAMETER :: norm  = 2.328306549295727688e-10_dp,&
                              m1    = 4294967087.0_dp,&
                              m2    = 4294944443.0_dp,&
                              a12   = 1403580.0_dp,&
                              a13n  = 810728.0_dp,&
                              a21   = 527612.0_dp,&
                              a23n  = 1370589.0_dp,&
                              two17 = 131072.0_dp,&            ! 2**17
                              two53 = 9007199254740992.0_dp,&  ! 2**53
                              fact  = 5.9604644775390625e-8_dp ! 1/2**24

CONTAINS

  FUNCTION rn32(rng_stream) RESULT(u)

    TYPE(rng_stream_type), POINTER           :: rng_stream
    REAL(KIND=dp)                            :: u

    INTEGER                                  :: k
    REAL(KIND=dp)                            :: p1, p2

! -------------------------------------------------------------------------
! Component 1

    p1 = a12*rng_stream%cg(2,1) - a13n*rng_stream%cg(1,1)
    k = INT(p1/m1)
    p1 = p1 - k*m1
    IF (p1 < 0.0_dp) p1 = p1 + m1
    rng_stream%cg(1,1) = rng_stream%cg(2,1)
    rng_stream%cg(2,1) = rng_stream%cg(3,1)
    rng_stream%cg(3,1) = p1

    ! Component 2

    p2 = a21*rng_stream%cg(3,2) - a23n*rng_stream%cg(1,2)
    k = INT(p2/m2)
    p2 = p2 - k*m2
    IF (p2 < 0.0_dp) p2 = p2 + m2
    rng_stream%cg(1,2) = rng_stream%cg(2,2)
    rng_stream%cg(2,2) = rng_stream%cg(3,2)
    rng_stream%cg(3,2) = p2

    ! Combination

    IF (p1 > p2) THEN
      u = (p1 - p2)*norm
    ELSE
      u = (p1 - p2 + m1)*norm
    END IF

    IF (rng_stream%antithetic) u = 1.0_dp - u

  END FUNCTION rn32

! *****************************************************************************
  FUNCTION rn53(rng_stream) RESULT(u)

    TYPE(rng_stream_type), POINTER           :: rng_stream
    REAL(KIND=dp)                            :: u

    u = rn32(rng_stream)

    IF (rng_stream%antithetic) THEN
      u = u + (rn32(rng_stream) - 1.0_dp)*fact
      IF (u < 0.0_dp) u = u + 1.0_dp
    ELSE
      u = u + rn32(rng_stream)*fact
      IF (u >= 1.0_dp) u = u - 1.0_dp
    END IF

  END FUNCTION rn53

END MODULE

! { dg-final { scan-module-absence "parallel_rng_types" "IMPLICIT_PURE" } }
! { dg-final { scan-tree-dump-times "rn32 \\(rng_stream" 3 "optimized" } }


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE CHECK_TE_MATRIX ( TE_IN, NAME_IN )

! Checks TE_IN(t)*TE_IN to see if the element transformation matrix times its transpose is an identity matrix

      USE PENTIUM_II_KIND, ONLY       :  LONG, DOUBLE
      USE IOUNT1, ONLY                :  BUG

      USE CHECK_TE_MATRIX_USE_IFs                          ! Added 2019/07/14

      IMPLICIT NONE

      CHARACTER(LEN=*), INTENT(IN)    :: NAME_IN           ! Name for output purposes

      INTEGER(LONG)                   :: I,J               ! DO loop indices

      REAL(DOUBLE), INTENT(IN)        :: TE_IN(3,3)        ! Input TE matrix
      REAL(DOUBLE)                    :: DUM1(3,3)         ! Dummy matrix in a matrix multiply
      REAL(DOUBLE)                    :: DUM2(3,3)         ! Dummy matrix in a matrix multiply

! **********************************************************************************************************************************
      DO I=1,3
         DO J=1,3
            DUM1(I,J) = TE_IN(I,J)
         ENDDO
      ENDDO

      CALL MATMULT_FFF_T ( DUM1, TE_IN, 3, 3, 3, DUM2 )
      WRITE(BUG,1) NAME_IN, NAME_IN
      DO I=1,3
         WRITE(BUG,2) (DUM2(I,J),J=1,3)
      ENDDO
      WRITE(BUG,*)

      RETURN

! **********************************************************************************************************************************
    1 FORMAT('  Check on ',A,'(t)*',A,' to see if it is the identity matrix:',/,                                                   &
             '  -----------------------------------------------------------------')

    2 FORMAT(3(1ES14.6))

      END SUBROUTINE CHECK_TE_MATRIX


module residuo_interface
  interface
    subroutine residuo(a, u, lambda, r)

      implicit none

      real, dimension(:,:), intent(in) :: a
      real, dimension(:), intent(in) :: u
      real, intent(out) :: lambda

      real, dimension(:), intent(inout) :: r
    end subroutine
  end interface
end module


    Subroutine nagf_blas_damax_val(n, x, incx, k, r)

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

!     K = arg max {ABS(X(J))}, R = max {ABS(X(J))}
!             J                      J

!     for double precision X

!     .. Use Statements ..
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Scalar Arguments ..
      Real (Kind=dp), Intent (Out) :: r
      Integer, Intent (In) :: incx, n
      Integer, Intent (Out) :: k
!     .. Array Arguments ..
      Real (Kind=dp), Intent (In) :: x(1+(n-1)*abs(incx))
!     .. Local Scalars ..
      Integer :: i, ix
!     .. Intrinsic Procedures ..
      Intrinsic :: abs
!     .. Executable Statements ..
      Continue

      If (incx/=0) Then

        If (n>0) Then

          If (incx>0) Then
            ix = 1
          Else
            ix = 1 - (n-1)*incx
          End If

          r = abs(x(ix))
          k = 1

          If (n>1) Then

            Do i = 2, n
              ix = ix + incx

              If (r<abs(x(ix))) Then
                r = abs(x(ix))
                k = i
              End If

            End Do

          End If

        Else
          r = 0.0E0_dp
          k = 0
        End If

      Else
        r = 0.0E0_dp
        k = 0

      End If

      Return

!     End of NAGF_BLAS_DAMAX_VAL.

    End Subroutine


  subroutine doubler( &
     maxstr,    maxstr_internal,  mmax,    &
     nsmax,     ns_elas,          dnu,     &
     m,         one_d0m,          k,       &
     kk,        gmu,              gwt,     &
     accuracy,  Rm,               Tm,      &
     dtau,      RmTot,            TmTot)

!-------------------------------------------------------------------
! Subroutine:
!   doubler
!
! Purpose:
!   Doubling one layer
!
! Input:
!
!   Reflectance and transmittance of input layer:
!     Rm
!     Tm
!     dtau
!
! Output:
!
!   Reflectance and transmittance of doubled layer
!   with optical thickness 2*dtau:
!     RmTot
!     TmTot
!-------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8) !double precision

  integer,intent(in):: &
     maxstr,           &
     maxstr_internal,  &
     k, &
     kk,               & !doubling index
     m,                & !Fourier moment index
     mmax,             & !maximum nr of Fourier moments
     nsmax,            & !dimension of internal arrays
     ns_elas             !index of elastic wavenr

  integer,parameter:: &
     itr = 15            !maximum number of iterations

  real(kind=dp),intent(in):: &
     accuracy    !accuracy at which iteration stops

  integer:: &
     ns1, &
     ns2, &              !wavenumber indices [internal grid]
     ir,  &              !iteration index for Qm
     i1,  &
     i2                  !quad angle indices

! input
  real(kind=dp):: &
     one_d0m, & !1+delta_0m
     dnu, & !binwidth [cm-1] of wavenumber bins
     Rm(0:nsmax,0:nsmax,maxstr,maxstr), &
     Tm(0:nsmax,0:nsmax,maxstr,maxstr), &
     dtau(0:nsmax), &
     gmu(maxstr), &          !Gaussian quadrature angles
     gwt(maxstr)            !Gaussian quadrature weights

  real(kind=dp):: &
     Xm(0:nsmax,0:nsmax,maxstr,maxstr),     &
     Ym(0:nsmax,0:nsmax,maxstr,maxstr),     &
     Zm(0:nsmax,0:nsmax,maxstr,maxstr),     &
     Q1m(0:nsmax,0:nsmax,maxstr,maxstr),    &
     Qm(0:nsmax,0:nsmax,maxstr,maxstr),     &
     Dm(0:nsmax,0:nsmax,maxstr,maxstr),     &
     Um(0:nsmax,0:nsmax,maxstr,maxstr),     &
     trace_Ym

! output
  real(kind=dp):: &
     RmTot(0:nsmax,0:nsmax,maxstr,maxstr), &
     TmTot(0:nsmax,0:nsmax,maxstr,maxstr)

!---------------------------------------------------------------------
! the Qm matrix - accelerated convergence (nr of matmuls 2 log2[P])
!---------------------------------------------------------------------

! star
  do i2=1,maxstr
     do i1=1,maxstr
        do ns2=0,nsmax
           do ns1=0,nsmax
              Xm(ns1,ns2,i1,i2) = Rm(ns1,ns2,i1,i2) ! Xm = RmStar
           enddo
        enddo
     enddo
  enddo

! prod Ym = RmStar Rm = C1
  call oproduct( &
       m,     one_d0m,   Xm,               &
       Rm,    Ym,        gmu,              &
       gwt,   nsmax,     ns_elas,          &
       dnu,   maxstr,    maxstr_internal)

! assign Zm = C1 = S1
  do i2=1,maxstr
     do i1=1,maxstr
        do ns2=0,nsmax
           do ns1=0,nsmax
              Zm(ns1,ns2,i1,i2)  = Ym(ns1,ns2,i1,i2)
              Q1m(ns1,ns2,i1,i2) = Ym(ns1,ns2,i1,i2)
           enddo
        enddo
     enddo
  enddo

! - Begin of iteration

    ir=0
 10 ir = ir+1

!   prod Xm = Cr Cr = Cr+1
    call oproduct( &
         m,     one_d0m,   Ym,              &
         Ym,    Xm,        gmu,             &
         gwt,   nsmax,     ns_elas,         &
         dnu,   maxstr,    maxstr_internal)

!   assign
    do i2=1,maxstr
       do i1=1,maxstr
          do ns2=0,nsmax
             do ns1=0,nsmax
                Ym(ns1,ns2,i1,i2) = Xm(ns1,ns2,i1,i2) ! Ym = Cr+1
             enddo
          enddo
       enddo
    enddo

!   prod Xm = Sr Cr+1
    call oproduct( &
         m,     one_d0m,   Zm,              &
         Ym,    Xm,        gmu,             &
         gwt,   nsmax,     ns_elas,         &
         dnu,   maxstr,    maxstr_internal)

!   write(*,*) 'Zm'
!   do ns1=0,nsmax
!      write(*,'(9d12.4)') (Zm(ns1,ns2,1,1),ns2=0,nsmax)
!   enddo
!   write(*,*) 'Ym'
!   do ns1=0,nsmax
!      write(*,'(9d12.4)') (Ym(ns1,ns2,1,1),ns2=0,nsmax)
!   enddo
!   write(*,*) 'Xm'
!   do i1=1,maxstr
!      write(*,*) 'i1=',i1
!      do ns1=0,nsmax
!         write(*,'(9d12.4)') (Xm(ns1,ns2,i1,i1),ns2=0,nsmax)
!      enddo
!   enddo
!   write(*,*) '---'

!   addsm Zm = Sr + Sr Cr+1 + Cr+1 = Sr+1
    do i2=1,maxstr
       do i1=1,maxstr
          do ns2=0,nsmax
             do ns1=0,nsmax
                Zm(ns1,ns2,i1,i2) = Zm(ns1,ns2,i1,i2) + &
                                     Xm(ns1,ns2,i1,i2) + &
                                      Ym(ns1,ns2,i1,i2)
                Qm(ns1,ns2,i1,i2) = Zm(ns1,ns2,i1,i2)
             enddo
          enddo
       enddo
    enddo

!   trace(Cr+1)
    trace_Ym = 0.d0
    do i1=1,maxstr_internal
       trace_Ym = trace_Ym + Ym(ns_elas,ns_elas,i1,i1)
    enddo

!    write(*,*) 'trace_Ym',trace_Ym

    if((trace_Ym.gt.accuracy).and.(ir.le.itr)) goto 10

! - End of iteration

  if(ir.gt.itr)then
     write(*,*) m, &
         ' doubler.f: Warning repeated reflections did not', &
         ' converge after',itr,' steps'
     write(*,*) '         proceed anyway !'
  endif

! write(*,*) 'Qm=',m
! do ns1=0,nsmax
!   write(*,'(2i4,D24.16)') ns1,ns_elas,Xm(ns1,ns_elas,3,4)
! enddo

! do ns1=0,nsmax
!    if(m.eq.0)then
!       write(*,'(3i5,A12,D24.16)') &
!         k,kk,ns1,' Qm/[2-d0m]',Zm(ns1,ns_elas,3,4)
!    else
!       write(*,'(3i5,A12,D24.16)') &
!         k,kk,ns1,' Qm/[2-d0m]',Zm(ns1,ns_elas,3,4)/2.d0
!    endif
! enddo

!-----------------------------------------------------------------------
! the Dm matrix
!-----------------------------------------------------------------------

! prod Xm = Qm T
  call oproduct( &
       m,      one_d0m,   Zm,              &
       Tm,     Xm,        gmu,             &
       gwt,    nsmax,     ns_elas,         &
       dnu,    maxstr,    maxstr_internal)

! addsm + addsm + rdiaprod Xm = Tm + Qm Tm + Qm E = Dm
  do i2=1,maxstr
     do i1=1,maxstr
        do ns2=0,nsmax
           do ns1=0,nsmax
              Xm(ns1,ns2,i1,i2) = Tm(ns1,ns2,i1,i2) + &
                                   Xm(ns1,ns2,i1,i2) + &
                                    Zm(ns1,ns2,i1,i2) * &
                                     exp(-dtau(ns2)/gmu(i2))
              Dm(ns1,ns2,i1,i2) = Xm(ns1,ns2,i1,i2)
           enddo
        enddo
     enddo
  enddo

!-----------------------------------------------------------------------
! the Um matrix
!-----------------------------------------------------------------------

! prod Zm = Rm Dm
  call oproduct( &
       m,      one_d0m,   Rm,              &
       Xm,     Zm,        gmu,             &
       gwt,    nsmax,     ns_elas,         &
       dnu,    maxstr,    maxstr_internal)

! rdiapr + addsm Zm = Rm E + Rm Dm = Um
  do i2=1,maxstr
     do i1=1,maxstr
        do ns2=0,nsmax
           do ns1=0,nsmax
              Zm(ns1,ns2,i1,i2) = Zm(ns1,ns2,i1,i2) + &
                                   Rm(ns1,ns2,i1,i2) * &
                                    exp(-dtau(ns2)/gmu(i2))
              Um(ns1,ns2,i1,i2) = Zm(ns1,ns2,i1,i2)
           enddo
         enddo
     enddo
  enddo

!-----------------------------------------------------------------------
! the TmTot matrix
!-----------------------------------------------------------------------

! prod Ym = Tm Dm
  call oproduct( &
       m,      one_d0m,    Tm,              &
       Xm,     Ym,         gmu,             &
       gwt,    nsmax,      ns_elas,         &
       dnu,    maxstr,     maxstr_internal)

! ldiapr + addsm + rdiapr + addsm Ym = Tm Dm + E Dm + Tm E = TmTot
  do i2=1,maxstr
     do i1=1,maxstr
        do ns2=0,nsmax
           do ns1=0,nsmax
              Ym(ns1,ns2,i1,i2) = Ym(ns1,ns2,i1,i2) + &
                                   exp(-dtau(ns1)/gmu(i1)) * &
                                    Xm(ns1,ns2,i1,i2) + &
                                     Tm(ns1,ns2,i1,i2) * &
                                      exp(-dtau(ns2)/gmu(i2))
              TmTot(ns1,ns2,i1,i2) = Ym(ns1,ns2,i1,i2)
           enddo
        enddo
     enddo
  enddo

!-----------------------------------------------------------------------
! the RmTot matrix
!-----------------------------------------------------------------------

!! star
!! do i2=1,maxstr
!!    do i1=1,maxstr
!!       do ns2=0,nsmax
!!          do ns1=0,nsmax
!!             Tm(ns1,ns2,i1,i2) = Tm(ns1,ns2,i1,i2) ! Tm = TmStar
!!          enddo
!!       enddo
!!    enddo
!! enddo

! prod Xm = TmStar Um
  call oproduct( &
       m,      one_d0m,    Tm,              &
       Zm,     Xm,         gmu,             &
       gwt,    nsmax,      ns_elas,         &
       dnu,    maxstr,     maxstr_internal)

! ldiapr + addsm Rm = Rm + TmStar Um + E Um = RmTot
  do i2=1,maxstr
     do i1=1,maxstr
        do ns2=0,nsmax
           do ns1=0,nsmax
              Rm(ns1,ns2,i1,i2) = Rm(ns1,ns2,i1,i2) + &
                                   Xm(ns1,ns2,i1,i2) + &
                                    exp(-dtau(ns1)/gmu(i1)) * &
                                     Zm(ns1,ns2,i1,i2)
              RmTot(ns1,ns2,i1,i2) = Rm(ns1,ns2,i1,i2)
           enddo
        enddo
     enddo
  enddo

  return
  end subroutine doubler


      subroutine fprank(a,f,n,m,na,tol,c,sq,rank,aa,ff,h)
c  subroutine fprank finds the minimum norm solution of a least-
c  squares problem in case of rank deficiency.
c
c  input parameters:
c    a : array, which contains the non-zero elements of the observation
c        matrix after triangularization by givens transformations.
c    f : array, which contains the transformed right hand side.
c    n : integer,wich contains the dimension of a.
c    m : integer, which denotes the bandwidth of a.
c  tol : real value, giving a threshold to determine the rank of a.
c
c  output parameters:
c    c : array, which contains the minimum norm solution.
c   sq : real value, giving the contribution of reducing the rank
c        to the sum of squared residuals.
c rank : integer, which contains the rank of matrix a.
c
c  ..scalar arguments..
      integer n,m,na,rank
      real*8 tol,sq
c  ..array arguments..
      real*8 a(na,m),f(n),c(n),aa(n,m),ff(n),h(m)
c  ..local scalars..
      integer i,ii,ij,i1,i2,j,jj,j1,j2,j3,k,kk,m1,nl
      real*8 cos,fac,piv,sin,yi
      double precision store,stor1,stor2,stor3
c  ..function references..
      integer min0
c  ..subroutine references..
c    fpgivs,fprota
c  ..
      m1 = m-1
c  the rank deficiency nl is considered to be the number of sufficient
c  small diagonal elements of a.
      nl = 0
      sq = 0.
      do 90 i=1,n
        if(a(i,1).gt.tol) go to 90
c  if a sufficient small diagonal element is found, we put it to
c  zero. the remainder of the row corresponding to that zero diagonal
c  element is then rotated into triangle by givens rotations .
c  the rank deficiency is increased by one.
        nl = nl+1
        if(i.eq.n) go to 90
        yi = f(i)
        do 10 j=1,m1
          h(j) = a(i,j+1)
  10    continue
        h(m) = 0.
        i1 = i+1
        do 60 ii=i1,n
          i2 = min0(n-ii,m1)
          piv = h(1)
          if(piv.eq.0.) go to 30
          call fpgivs(piv,a(ii,1),cos,sin)
          call fprota(cos,sin,yi,f(ii))
          if(i2.eq.0) go to 70
          do 20 j=1,i2
            j1 = j+1
            call fprota(cos,sin,h(j1),a(ii,j1))
            h(j) = h(j1)
  20      continue
          go to 50
  30      if(i2.eq.0) go to 70
          do 40 j=1,i2
            h(j) = h(j+1)
  40      continue
  50      h(i2+1) = 0.
  60    continue
c  add to the sum of squared residuals the contribution of deleting
c  the row with small diagonal element.
  70    sq = sq+yi**2
  90  continue
c  rank denotes the rank of a.
      rank = n-nl
c  let b denote the (rank*n) upper trapezoidal matrix which can be
c  obtained from the (n*n) upper triangular matrix a by deleting
c  the rows and interchanging the columns corresponding to a zero
c  diagonal element. if this matrix is factorized using givens
c  transformations as  b = (r) (u)  where
c    r is a (rank*rank) upper triangular matrix,
c    u is a (rank*n) orthonormal matrix
c  then the minimal least-squares solution c is given by c = b' v,
c  where v is the solution of the system  (r) (r)' v = g  and
c  g denotes the vector obtained from the old right hand side f, by
c  removing the elements corresponding to a zero diagonal element of a.
c  initialization.
      do 100 i=1,rank
        do 100 j=1,m
          aa(i,j) = 0.
 100  continue
c  form in aa the upper triangular matrix obtained from a by
c  removing rows and columns with zero diagonal elements. form in ff
c  the new right hand side by removing the elements of the old right
c  hand side corresponding to a deleted row.
      ii = 0
      do 120 i=1,n
        if(a(i,1).le.tol) go to 120
        ii = ii+1
        ff(ii) = f(i)
        aa(ii,1) = a(i,1)
        jj = ii
        kk = 1
        j = i
        j1 = min0(j-1,m1)
        if(j1.eq.0) go to 120
        do 110 k=1,j1
          j = j-1
          if(a(j,1).le.tol) go to 110
          kk = kk+1
          jj = jj-1
          aa(jj,kk) = a(j,k+1)
 110    continue
 120  continue
c  form successively in h the columns of a with a zero diagonal element.
      ii = 0
      do 200 i=1,n
        ii = ii+1
        if(a(i,1).gt.tol) go to 200
        ii = ii-1
        if(ii.eq.0) go to 200
        jj = 1
        j = i
        j1 = min0(j-1,m1)
        do 130 k=1,j1
          j = j-1
          if(a(j,1).le.tol) go to 130
          h(jj) = a(j,k+1)
          jj = jj+1
 130    continue
        do 140 kk=jj,m
          h(kk) = 0.
 140    continue
c  rotate this column into aa by givens transformations.
        jj = ii
        do 190 i1=1,ii
          j1 = min0(jj-1,m1)
          piv = h(1)
          if(piv.ne.0.) go to 160
          if(j1.eq.0) go to 200
          do 150 j2=1,j1
            j3 = j2+1
            h(j2) = h(j3)
 150      continue
          go to 180
 160      call fpgivs(piv,aa(jj,1),cos,sin)
          if(j1.eq.0) go to 200
          kk = jj
          do 170 j2=1,j1
            j3 = j2+1
            kk = kk-1
            call fprota(cos,sin,h(j3),aa(kk,j3))
            h(j2) = h(j3)
 170      continue
 180      jj = jj-1
          h(j3) = 0.
 190    continue
 200  continue
c  solve the system (aa) (f1) = ff
      ff(rank) = ff(rank)/aa(rank,1)
      i = rank-1
      if(i.eq.0) go to 230
      do 220 j=2,rank
        store = ff(i)
        i1 = min0(j-1,m1)
        k = i
        do 210 ii=1,i1
          k = k+1
          stor1 = ff(k)
          stor2 = aa(i,ii+1)
          store = store-stor1*stor2
 210    continue
        stor1 = aa(i,1)
        ff(i) = store/stor1
        i = i-1
 220  continue
c  solve the system  (aa)' (f2) = f1
 230  ff(1) = ff(1)/aa(1,1)
      if(rank.eq.1) go to 260
      do 250 j=2,rank
        store = ff(j)
        i1 = min0(j-1,m1)
        k = j
        do 240 ii=1,i1
          k = k-1
          stor1 = ff(k)
          stor2 = aa(k,ii+1)
          store = store-stor1*stor2
 240    continue
        stor1 = aa(j,1)
        ff(j) = store/stor1
 250  continue
c  premultiply f2 by the transpoze of a.
 260  k = 0
      do 280 i=1,n
        store = 0.
        if(a(i,1).gt.tol) k = k+1
        j1 = min0(i,m)
        kk = k
        ij = i+1
        do 270 j=1,j1
          ij = ij-1
          if(a(ij,1).le.tol) go to 270
          stor1 = a(ij,j)
          stor2 = ff(kk)
          store = store+stor1*stor2
          kk = kk-1
 270    continue
        c(i) = store
 280  continue
c  add to the sum of squared residuals the contribution of putting
c  to zero the small diagonal elements of matrix (a).
      stor3 = 0.
      do 310 i=1,n
        if(a(i,1).gt.tol) go to 310
        store = f(i)
        i1 = min0(n-i,m1)
        if(i1.eq.0) go to 300
        do 290 j=1,i1
          ij = i+j
          stor1 = c(ij)
          stor2 = a(i,j+1)
          store = store-stor1*stor2
 290    continue
 300    fac = a(i,1)*c(i)
        stor1 = a(i,1)
        stor2 = c(i)
        stor1 = stor1*stor2
        stor3 = stor3+stor1*(stor1-store-store)
 310  continue
      fac = stor3
      sq = sq+fac
      return
      end


      subroutine zsvbksb(u,w,v,m,n,b,x)
c--- Adapted from Numerical Recipes
C--- back substitution for real u,w,v and complex b
      implicit none
      integer i,j,jj,m,n,nmax
      parameter (nmax=100)
      double precision u(m,n),w(n),v(n,n)
      double complex b(m),x(n),s,tmp(nmax)

      do j=1,n
        s=dcmplx(0d0,0d0)
        if(w(j).ne.0d0)then
          do i=1,m
            s=s+u(i,j)*b(i)
          enddo
          s=s/w(j)
        endif
        tmp(j)=s
      enddo

      do j=1,n
        s=dcmplx(0d0,0d0)
        do jj=1,n
          s=s+v(j,jj)*tmp(jj)
        enddo
        x(j)=s
      enddo

      return
      end


      subroutine cblas2()
*
      CALL CGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL CGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL CHEMV ( UPLO, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL CHBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL CHPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
*
      CALL CTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*
      CALL CTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
*
      CALL CTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
*
      CALL CTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*
      CALL CTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
*
      CALL CTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
*
      CALL CGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
      CALL CGERC ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
      CALL CHER  ( UPLO, N, ALPHA, X, INCX, A, LDA )
*
      CALL CHPR  ( UPLO, N, ALPHA, X, INCX, AP )
*
      CALL CHER2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
      CALL CHPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
*
      stop
      end


program hmipt
  !########################################################
  !     Program  : HMIPT
  !     TYPE     : Main program
  !     PURPOSE  : Solve the Hubbard model using DMFT-IPT
  !     AUTHORS  : Adriano Amaricci
  !########################################################
  !LOCAL:
  USE DMFT_IPT
  USE SQUARE_LATTICE
  USE VECTORS
  USE IOTOOLS
  USE TIMER
  implicit none

  logical                :: converged
  real(8)                :: n,dw
  integer                :: i,Lk,iloop
  complex(8)             :: zeta
  complex(8),allocatable :: sigma(:),fg(:),fg0(:),fg0less(:),fg0gtr(:)
  real(8),allocatable    :: wr(:),wt(:),epsik(:),nk(:),t(:)

  call read_input("inputIPT.in")
  allocate(fg(L))
  allocate(sigma(L))
  allocate(fg0less(L),fg0gtr(L),fg0(L))
  allocate(wr(L))

  !build freq. array
  wr    = linspace(-wmax,wmax,L,mesh=dw)

  !build square lattice structure:
  Lk   = square_lattice_dimension(Nx)
  allocate(wt(Lk),epsik(Lk),nk(Lk))
  wt   = square_lattice_structure(Lk,Nx)
  epsik= square_lattice_dispersion_array(Lk,ts)

  sigma=zero ; iloop=0 ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop

     !GET GLOC:
     fg=zero
     do i=1,L
        zeta = cmplx(wr(i),eps) - sigma(i)
        fg(i) = sum_overk_zeta(zeta,epsik,wt)
     enddo

     !Update Keldysh components of the Weiss Field:
     fg0     = one/(one/fg + sigma)
     sigma   = solve_ipt_keldysh(fg0,wmax)
     converged=check_convergence(sigma,eps_error,nsuccess,nloop)
     call splot("DOS.ipt",wr,-aimag(fg)/pi,append=printf)
     call splot("G0_realw.ipt",wr,fg0,append=printf)
     call splot("Sigma_realw.ipt",wr,sigma,append=printf)
  enddo

  call get_optical_conductivity
  call get_oc2

contains

  subroutine get_optical_conductivity()
    integer                               :: ix,iy,iz,ik,i,j,iw,it,iv
    integer                               :: Nw
    real(8)                               :: Fiw,Fiviw
    type(vect2D)                          :: vk,kt
    real(8),dimension(:),allocatable      :: omega(:)
    real(8),dimension(:),allocatable      :: reoc(:),imoc(:),ock(:)
    complex(8),dimension(:),allocatable   :: oc(:)
    real(8),dimension(:,:),allocatable    :: Ak
    !
    real(8)                               :: t_(0:L/2)
    real(8)                               :: oct(0:L/2)
    real(8)      :: sx,sy,ex,ey
    Nw=L/2
    allocate(omega(-Nw+1:Nw))
    forall(i=1:L)omega(-Nw+i)=wr(i)

    allocate(Ak(Lk,-Nw+1:Nw))
    forall(ik=1:Lk,i=1:L)Ak(ik,-Nw+i)=-dimag(one/(cmplx(wr(i),eps)-epsik(ik)-sigma(i)))/pi

    allocate(reoc(-Nw+1:Nw),imoc(-Nw+1:Nw),ock(-Nw+1:Nw),oc(-Nw+1:Nw))
    oc   = zero
    reoc = zero
    imoc = zero
    call start_timer
    do ik=1,Lk
       ock = zero
       ix  = ik2ix(ik)
       iy  = ik2iy(ik)
       kt = kgrid(ix,iy)
       sx = 2.d0*sin(kt%x)
       sy = 2.d0*sin(kt%y)
       !vk  = square_lattice_velocity(ix,iy)
       do iv=1,Nw
          do iw=-Nw+1,Nw-iv
             Fiw     = fermi(omega(iw),beta)
             Fiviw   = fermi(omega(iv+iw),beta)
             ock(iv) = ock(iv) + ((Fiw-Fiviw)/omega(iv))*Ak(ik,iw)*Ak(ik,iv+iw)*sx*sy!vk%x*vk%y
          enddo                 !end w-loop
       enddo                    !end v-loop
       reoc(:) = reoc(:)+ock(:)*wt(ik)*ts*dw

       call eta(ik,Lk)
    enddo
    call stop_timer
    ! forall(i=1:Nw)reoc(-i+1)=-reoc(i)
    ! imoc(1:Nw) = kronig(reoc(1:Nw),omega(1:Nw),Nw)
    ! oc   = cmplx(reoc,imoc,8)
    call splot("OC_realw.ipt",omega(1:Nw),reoc(1:Nw))!,imoc)

    t_=linspace(0.d0,pi/wmax*Nw,Nw+1)
    oct=zero
    do it=0,Nw
       do iw=1,Nw
          oct(it)=oct(it) + reoc(iw)*exp(xi*omega(iw)*t_(it))*dw
       enddo
    enddo
    call splot("OC_t.ipt",t_,oct)
  end subroutine get_optical_conductivity

  subroutine get_oc2
    integer                      :: ix,iy,iz,ik,i,j,iw,it,is
    integer                      :: Nw
    real(8)                      :: Fiw,Fiviw,A,dt
    type(vect2D)                 :: kt
    real(8),allocatable          :: omega(:),t(:)
    real(8),allocatable          :: reoc(:),imoc(:),ock(:)
    real(8),allocatable          :: ocij(:,:),chiij(:,:)
    real(8),allocatable          :: oc(:)
    complex(8),allocatable       :: ocw(:)
    type(keldysh_equilibrium_gf) :: Gk
    real(8)                      :: sx,sy,ex,ey

    Nw=L/2

    dt       = pi/wmax
    allocate(t(-Nw:Nw))
    t   = linspace(-dt*real(Nw,8),dt*real(Nw,8),2*Nw+1,mesh=dt)

    allocate(omega(-Nw+1:Nw))
    forall(i=1:L)omega(-Nw+i)=wr(i)

    call allocate_gf(Gk,Nw)

    allocate(ock(-Nw:Nw),oc(-Nw:Nw))
    allocate(ocij(0:Nw,0:Nw),chiij(0:Nw,0:Nw))
    ock=0.d0
    oc =0.d0
    ocij=zero
    chiij=zero
    call start_timer
    do ik=1,Lk
       ix=ik2ix(ik)
       iy=ik2iy(ik)
       kt = kgrid(ix,iy)
       sx = 2.d0*sin(kt%x)
       sy = 2.d0*sin(kt%y)
       ex = 2.d0*cos(kt%x)
       ey = 2.d0*cos(kt%y)
       !Get Gk^x=R,<,>(t)
       Gk%ret%w = one/(cmplx(wr(:),eps)-epsik(ik)-sigma(:))
       do i=1,2*Nw
          A            = -dimag(Gk%ret%w(i))/pi
          Gk%less%w(i) = pi2*xi*fermi(wr(i),beta)*A
          Gk%gtr%w(i)  = pi2*xi*(fermi(wr(i),beta)-1.d0)*A
       enddo
       call fftgf_rw2rt(Gk%less%w,Gk%less%t,Nw) ; Gk%less%t=dw/pi2*Gk%less%t
       call fftgf_rw2rt(Gk%gtr%w,Gk%gtr%t,Nw)   ; Gk%gtr%t =dw/pi2*Gk%gtr%t
       call fftgf_rw2rt(Gk%ret%w,Gk%ret%t,Nw)   ; Gk%ret%t =dw/pi2*Gk%ret%t
       do i=-Nw,Nw
          ock(i)=-2.d0/pi*sx**2*dimag(Gk%ret%t(i)*Gk%less%t(-i))!+2.d0/pi*ex*xi*Gk%less%t(i)
       enddo
       call cfft_1d_ex(one*ock)
       do i=0,Nw
          do j=0,Nw
             chiij(i,j) = chiij(i,j) + wt(ik)*ock(i-j)
          enddo
       enddo
       call eta(ik,Lk)
    enddo
    call stop_timer

    !Get OC from Chi:
    do i=0,Nw
       do j=0,Nw
          do it=j,Nw
             ocij(i,j)=ocij(i,j)-chiij(i,it)*dt
          enddo
       enddo
    enddo

    forall(i=0:Nw,j=0:Nw)oc(i-j)=ocij(i,j)
    call splot("OC2_t.ipt",t(0:),oc(0:))

    allocate(ocw(Nw))
    ocw=0.d0
    do iw=1,Nw
       !do it=0,Nw
       it=Nw
       do is=0,it
          ocw(iw)=ocw(iw) + ocij(it,it-is)*exp(-xi*omega(iw)*t(is))*dt
       enddo
       !enddo
    enddo
    call splot("OC2_realw.ipt",omega(1:Nw),ocw(1:Nw))

  end subroutine get_oc2

end program hmipt


MODULE SmoothProblemsInitializationModule

  USE KindModule, ONLY: &
    DP, Pi
  USE ProgramHeaderModule, ONLY: &
    ProgramName, &
    nX, nNodesX
  USE UtilitiesModule, ONLY: &
    NodeNumberX
  USE MeshModule, ONLY: &
    MeshX, &
    NodeCoordinate
  USE FluidFieldsModule, ONLY: &
    uCF, nCF, &
    uPF, nPF, iPF_D, iPF_V1, iPF_V2, iPF_V3, iPF_E, iPF_Ne, &
    uAF, iAF_P, iAF_T, iAF_S, iAF_Ye, iAF_E, iAF_Gm, iAF_Cs
  USE EquationOfStateModule, ONLY: &
    ComputeInternalEnergyDensityFromPressure, &
    ComputeAuxiliary_Fluid
  USE EulerEquationsUtilitiesModule, ONLY: &
    ComputeConserved

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: InitializeLinearWaves1D

CONTAINS

  SUBROUTINE InitializeLinearWaves1D( WaveType, Amplitude_Option )

    CHARACTER(LEN=*) :: WaveType
    REAL(DP), INTENT(in), OPTIONAL :: Amplitude_Option

    INTEGER  :: iX1, iX2, iX3
    INTEGER  :: iNodeX1, iNodeX2, iNodeX3, iNode
    REAL(DP) :: X1, Amplitude

    Amplitude = 1.0d-6
    IF( PRESENT( Amplitude_Option ) ) &
      Amplitude = Amplitude_Option

    WRITE(*,*)
    WRITE(*,'(A2,A6,A)') &
      '', 'INFO: ', TRIM( ProgramName )
    WRITE(*,*)
    WRITE(*,'(A7,A)') &
      '', TRIM( WaveType )
    WRITE(*,'(A7,A12,ES10.3E2)') &
      '', 'Amplitude = ', Amplitude

    DO iX3 = 1, nX(3)
      DO iX2 = 1, nX(2)
        DO iX1 = 1, nX(1)

          DO iNodeX3 = 1, nNodesX(3)
            DO iNodeX2 = 1, nNodesX(2)
              DO iNodeX1 = 1, nNodesX(1)

                X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )

                iNode = NodeNumberX( iNodeX1, iNodeX2, iNodeX3 )

                uPF(iNode,iX1,iX2,iX3,iPF_D)  = 1.0_DP
                uPF(iNode,iX1,iX2,iX3,iPF_V1) = 0.0_DP
                uPF(iNode,iX1,iX2,iX3,iPF_V2) = 0.0_DP
                uPF(iNode,iX1,iX2,iX3,iPF_V3) = 0.0_DP
                uAF(iNode,iX1,iX2,iX3,iAF_P)  = 3.0_DP / 5.0_DP

                SELECT CASE ( TRIM( WaveType ) )

                  CASE ( 'AcousticWaves' )

                    uPF(iNode,iX1,iX2,iX3,iPF_D) &
                      = uPF(iNode,iX1,iX2,iX3,iPF_D) &
                          + Amplitude * SIN( 2.0_DP * Pi * X1 )
                    uPF(iNode,iX1,iX2,iX3,iPF_V1) &
                      = uPF(iNode,iX1,iX2,iX3,iPF_V1) &
                          + Amplitude * SIN( 2.0_DP * Pi * X1 )
                    uPF(iNode,iX1,iX2,iX3,iAF_P) &
                      = uPF(iNode,iX1,iX2,iX3,iAF_P) &
                          + Amplitude * SIN( 2.0_DP * Pi * X1 )

                  CASE ( 'EntropyWaves_Velocity' )

                    uPF(iNode,iX1,iX2,iX3,iPF_V1) &
                      = uPF(iNode,iX1,iX2,iX3,iPF_V1) &
                          + 0.5_DP
                    uPF(iNode,iX1,iX2,iX3,iPF_V2) &
                      = uPF(iNode,iX1,iX2,iX3,iPF_V2) &
                          + Amplitude * SIN( 2.0_DP * Pi * X1 )
                    uPF(iNode,iX1,iX2,iX3,iPF_V3) &
                      = uPF(iNode,iX1,iX2,iX3,iPF_V2) &
                          + Amplitude * SIN( 2.0_DP * Pi * X1 )

                  CASE ( 'EntropyWaves_Density' )

                    uPF(iNode,iX1,iX2,iX3,iPF_D) &
                      = uPF(iNode,iX1,iX2,iX3,iPF_D) &
                          + 0.5_DP * SIN( 2.0_DP * Pi * X1 )
                    uPF(iNode,iX1,iX2,iX3,iPF_V1) &
                      = uPF(iNode,iX1,iX2,iX3,iPF_V1) &
                          + 1.0_DP

                  CASE DEFAULT

                    WRITE(*,'(A7,A18,A)') &
                      '', 'Invalid Wave Type ', TRIM( WaveType )
                    STOP

                END SELECT

              END DO
            END DO
          END DO

          CALL ComputeInternalEnergyDensityFromPressure &
                 ( uPF(:,iX1,iX2,iX3,iPF_D),  uAF(:,iX1,iX2,iX3,iAF_P), &
                   uAF(:,iX1,iX2,iX3,iAF_Ye), uPF(:,iX1,iX2,iX3,iPF_E) )

          CALL ComputeAuxiliary_Fluid &
                 ( uPF(:,iX1,iX2,iX3,iPF_D ), uPF(:,iX1,iX2,iX3,iPF_E ),  &
                   uPF(:,iX1,iX2,iX3,iPF_Ne), uAF(:,iX1,iX2,iX3,iAF_P ),  &
                   uAF(:,iX1,iX2,iX3,iAF_T ), uAF(:,iX1,iX2,iX3,iAF_Ye), &
                   uAF(:,iX1,iX2,iX3,iAF_S ), uAF(:,iX1,iX2,iX3,iAF_E ),  &
                   uAF(:,iX1,iX2,iX3,iAF_Gm), uAF(:,iX1,iX2,iX3,iAF_Cs) )

          CALL ComputeConserved &
                 ( uPF(:,iX1,iX2,iX3,1:nPF), uCF(:,iX1,iX2,iX3,1:nCF) )

        END DO
      END DO
    END DO

  END SUBROUTINE InitializeLinearWaves1D

END MODULE SmoothProblemsInitializationModule


	options/extend_source
!------------------------------------------------------------------------------
	REAL*4		function	APMCAL(IANT,NTM)
	implicit	none
!	include		'apc_fit_def.for/nolist'
	real*4 		coeff(5),const(5),csq(5),corrf(5)
	integer*4 	iant,ntm
!
!	iant=1 is X_PK, 2 is Y_PK, 3 is X_DC, 4 is Y_DC, 5 is Z_DC
!
C	the following were used until Nov 1999
C	data coeff /.084848, .09678, .080956, .10424, .06669/
C	data const /13.315,  16.090,  13.069, 16.613, 9.0504/
C	data csq /-8.4573e-6, 2.2302e-5, 2.2793e-6, -9.197e-6, 5.1049e-6/
!
	data coeff /.087818, .098714, .083789, .10633, .09728/
	data const /13.781,  16.412,  13.526, 16.954, 13.202/
	data csq /-8.7533e-6, 2.2748e-5, 2.3591e-6, -9.381e-6, 7.4466e-6/
c
	apmcal = coeff(iant)*ntm - const(iant) + csq(iant)*ntm**2

	return
	end


module padem

use pickpoints
use leastsquare
use poles
implicit none
include 'gitversion'

contains

subroutine pade(zin,fin,zout,fout)
    implicit none
    ! input arguments to the subroutine:
    complex(kind=16),intent(in) :: zin(:),fin(:)        ! Input points and values
    complex(kind=16),intent(in) :: zout(:)              ! Output points
    complex(kind=8),intent(out),allocatable :: fout(:)  ! Output values (at points zout)
    ! variables read from the parameter file pade.par:
    integer :: nminstart,nminfinish,nminstep
    integer :: Mmin,Mmax,Mstep
    integer :: Nmin,Nmax,Nstep
    logical :: diagonalPade
    integer :: solver
    logical :: calcpoles
    integer :: nprecision
    integer :: mtr
    logical :: exclude_positive
    real(kind=8) :: c1v,c2v
    ! help variables
    integer,allocatable :: nmins(:),Ms(:),Ns(:)         ! the arrays to loop over
    complex(kind=16),allocatable :: zin_p(:),fin_p(:)   ! Picked points used for the analytical continuation
    type conf
       integer :: nmin                             ! index of first matsubara point.
       integer :: M                                ! number of input points used in analytical continuation.
       integer :: N                                ! number of Pade coefficients.
       integer :: w                                ! weight in average (either 0 or 1)
       complex(kind=16),allocatable :: x(:)        ! Pade approximant coefficients.
       complex(kind=8),allocatable :: P(:)         ! Pade approximant evaluated at the points zout.
    end type
    complex(kind=8),allocatable :: P(:,:)          ! For all continuations: Pade approximant evaluated at the points zout.
    type(conf),allocatable :: c(:)                 ! configuration data for each continuation is stored here.
    complex(kind=16),allocatable :: pole(:),res(:) ! poles and residues for one continuation.
    ! dummy variables
    integer :: i,j,k,b,counter

    ! reading the parameter file
    open(80,file='pade.par')
    read(80,*) ! read header
    read(80,*) ! read line about real axis mesh
    read(80,*) ! read line about distance above real axis
    read(80,*) nminstart,nminfinish,nminstep
    read(80,*) Mmin,Mmax,Mstep
    read(80,*) Nmin,Nmax,Nstep
    read(80,*) diagonalPade
    read(80,*) solver
    read(80,*) calcpoles
    read(80,*) nprecision
    read(80,*) mtr
    read(80,*) exclude_positive
    read(80,*) c1v,c2v
    close(80)

    ! write git version number to the information file
    open(90,file='pade_info')
    write(90,'(a,a)') " git hash number: ", trim(git_version)

    ! construct nmins, Ms, Ns
    i = floor((nminfinish-nminstart)/(1d0*nminstep))
    allocate(nmins(i+1))
    nmins = (/ (nminstart+j*nminstep,j=0,i) /)
    i = floor((Mmax-Mmin)/(1d0*Mstep))
    allocate(Ms(i+1))
    Ms = (/ (Mmin+j*Mstep,j=0,i) /)
    i = floor((Nmax-Nmin)/(1d0*Nstep))
    allocate(Ns(i+1))
    Ns = (/ (Nmin+j*Nstep,j=0,i) /)

    write(90,*) 'nmins = ',nmins
    write(90,*) 'Ms = ',Ms
    write(90,*) 'Ns = ',Ns
    write(90,*)

    allocate(c(size(nmins)*size(Ms)*size(Ns))) ! allocate more memory than necessary, since size initially is unknown.
    counter = 0
    do i=1,size(nmins)
        do j=1,size(Ms)
            call pick_points(zin,fin,nmins(i),Ms(j),zin_p,fin_p)
            if (.not. diagonalPade) then
                do k=1,size(Ns)
                    if (Ns(k) <= Ms(j)) then
                        counter = counter + 1
                        write(90,'(a,3I4)') "(nmin,M,N)=",nmins(i),Ms(j),Ns(k)
                        c(counter)%nmin = nmins(i)
                        c(counter)%M = Ms(j)
                        c(counter)%N = Ns(k)
                        allocate(c(counter)%x(Ns(k)),c(counter)%P(size(zout)))
                        call acPade(zin_p,fin_p,Ns(k),zout,solver,nprecision,mtr,c(counter)%x,c(counter)%P)
                        if (calcpoles) then
                            write(90,'(a)') "Calculate poles and residues"
                            write(90,'(a)') "Re[pole], Im[pole], Re[res], Im[res],nmin,M,N"
                            allocate(pole(Ns(k)/2),res(Ns(k)/2))
                            call getpoles(c(counter)%x,pole,res)
                            do b=1,size(pole)
                                write(90,'(4E15.5,3I4)') real(pole(b)),aimag(pole(b)),real(res(b)),aimag(res(b)), &
                                                          nmins(i),Ms(j),Ns(k)
                            enddo
                            deallocate(pole,res)
                        endif
                    endif
                enddo
            else
                counter = counter + 1
                write(90,'(a,3I4)') "(nmin,M,N)=",nmins(i),Ms(j),Ms(j)
                c(counter)%nmin = nmins(i)
                c(counter)%M = Ms(j)
                c(counter)%N = Ms(j)
                allocate(c(counter)%x(Ms(j)),c(counter)%P(size(zout)))
                call acPade(zin_p,fin_p,Ms(j),zout,solver,nprecision,mtr,c(counter)%x,c(counter)%P)
                if (calcpoles) then
                    write(90,'(a)') "Calculate poles and residues"
                    write(90,'(a)') "Re[pole], Im[pole], Re[res], Im[res],nmin,M,N"
                    allocate(pole(Ms(j)/2),res(Ms(j)/2))
                    call getpoles(c(counter)%x,pole,res)
                    do b=1,size(pole)
                        write(90,'(4E15.5,3I4)') real(pole(b)),aimag(pole(b)),real(res(b)),aimag(res(b)),nmins(i),Ms(j),Ms(j)
                    enddo
                    deallocate(pole,res)
                endif
            endif
        enddo
    enddo
    write(90,'(a,I4)') "counter = ", counter

    allocate(P(size(zout),counter))
    do i=1,counter
        P(:,i) = c(i)%P
    enddo
    call getAveragePade(P,exclude_positive,c1v,c2v,c(1:counter)%w,fout)     ! create average
    write(90,'(a,I4)') 'number of continuations with weight:',sum(c(1:counter)%w)

    ! write all spectra to file
    open(71,file='pade_fout_all')
    write(71,'(a)') "# nmin, M, N, w, Re[zout], Re[f(zout)], Im[f(zout)]"
    do i=1,counter
        do j=1,size(zout)
            write(71,'(4I4,3E13.3)') c(i)%nmin,c(i)%M,c(i)%N,c(i)%w,real(zout(j)),real(c(i)%P(j)),aimag(c(i)%P(j))
        enddo
        write(71,*)
    enddo
    close(71)

    close(90) ! close the file: pade_info
    do i=1,counter
        deallocate(c(i)%x,c(i)%P)
    enddo
    deallocate(c)
    deallocate(P)
    deallocate(nmins)
    deallocate(Ms)
    deallocate(Ns)

end subroutine

subroutine acPade(z,f,N,zout,solver,nprecision,mtr,x,fout)
    implicit none
    complex(kind=16),intent(in) :: z(:),f(:)
    integer :: N                                 ! number of Pade approximant coefficients
    complex(kind=16),intent(in) :: zout(:)
    integer :: solver
    integer :: nprecision
    integer :: mtr
    complex(kind=16),intent(inout) :: x(:)
    complex(kind=8),intent(out) :: fout(:)
    ! help variables
    complex(kind=16),allocatable  :: fq(:)

    if ( .not. (mod(N,2) == 0 )) then
        stop "The number of Pade coefficients in the acPade routine should be even."
    endif
    ! Beach's matrix formulation
    if (solver == 0) then
        ! construct matrix and rhs in linear system of equations and seek a LS solution.
        call padeMatrix(z,f,N,nprecision,mtr,x)
        allocate(fq(size(zout)))
        call epade(zout,x,fq)
        ! convert from quadruple to double precision
        fout = fq
        deallocate(fq)
    ! Thiele's algorithm
    elseif ( solver == 1) then
        stop "Thiele's algorithm is not implemented yet."
    else
        stop "Solver value not valid."
    endif
end subroutine

subroutine padeMatrix(z,f,N,nprecision,mtr,x)
    ! Returns the obtained Padé coefficients.
    implicit none
    complex(kind=16),intent(in) :: z(:),f(:)
    integer :: N
    integer :: nprecision
    integer :: mtr
    complex(kind=16),intent(out) :: x(:) ! Pade coefficients
    ! help variables
    integer :: M ! number of points
    integer :: r,i,j
    complex(kind=16),allocatable :: A(:,:),y(:)
    complex(kind=16),allocatable :: errv(:)
    complex(kind=16),allocatable :: fp(:)
    ! double precision variables
    complex(kind=8),allocatable :: zd(:),fd(:)
    complex(kind=8),allocatable :: Ad(:,:),yd(:)

    M = size(z)
    r = N/2

    allocate(A(M,N),y(M))

    if (nprecision == 64 ) then ! double precision
        allocate(zd(M),fd(M))
        allocate(Ad(M,N),yd(M))
        zd = z
        fd = f
        yd = fd*zd**r
        do i=1,M
            Ad(i,:r) = zd(i)**( (/ (j,j=0,r-1)   /) )
            Ad(i,r+1:) = -fd(i)*zd(i)**( (/ (j,j=0,r-1)   /) )
        enddo
        deallocate(zd)
        deallocate(fd)
        y = yd
        A = Ad
        deallocate(yd)
        deallocate(Ad)
    elseif (nprecision == 128 ) then ! quadruple precision
        y = f*z**r
        do i=1,M
            A(i,:r) = z(i)**( (/ (j,j=0,r-1)   /) )
            A(i,r+1:) = -f(i)*z(i)**( (/ (j,j=0,r-1)   /) )
        enddo
    endif
    call zls(A,y,mtr,nprecision,x)
    ! print two error checks:
    allocate(errv(M))
    errv=matmul(A,x)-y
    write(90,'(a,E10.4)') '|k*x-y| = ',sqrt(sum(real(errv)**2+aimag(errv)**2))
    allocate(fp(M))
    call epade(z,x,fp)
    write(90,'(a,E10.4)') '|f(zin)-Pade(zin)| = ',sqrt(sum(abs(f-fp)**2))
    deallocate(errv)
    deallocate(fp)
    deallocate(A)
    deallocate(y)
end subroutine

subroutine epade(z,x,f)
    ! Returns the value of the Padé approximant at the points z.
    implicit none
    complex(kind=16),intent(in) :: z(:)  ! points in the complex plane
    complex(kind=16),intent(in) :: x(:)  ! Pade coefficients
    complex(kind=16),intent(out) :: f(:) ! values of the Pade approximant at the points z.
    integer :: i,r
    complex(kind=16),allocatable :: num(:),denum(:)
    r = size(x)/2
    allocate(num(size(z)),denum(size(z)))
    num = 0q0
    denum = 0q0
    do i=1,r
        num = num + x(i)*z**(i-1)
        denum = denum + x(r+i)*z**(i-1)
    enddo
    denum = denum + z**r
    f = num/denum
    deallocate(num,denum)
end subroutine

subroutine getAveragePade(P,exclude_positive,c1v,c2v,w,fout)
    implicit none
    complex(kind=8),intent(in)                :: P(:,:)            ! Pade approximants evaluated at points zout
    logical,intent(in)                        :: exclude_positive  ! If .true., exclude Pade approximants being positive on at least one output point.
    real(kind=8),intent(in)                   :: c1v,c2v           ! average criteria parameters
    integer,intent(out)                       :: w(:)              ! averaging weights
    complex(kind=8),allocatable,intent(inout) :: fout(:)           ! Average of Pade approximants P weighted with weightt w.
    ! help variables
    integer,allocatable      :: g(:)       ! index list with Pade approximants in P fullfilling Im(P)<=0
    real(kind=8),allocatable :: A(:,:)     ! Imaginary part of Pade approximants, fullfilling Im(P)<=0
    real(kind=8),allocatable :: delta(:,:) ! store distances between the continuations in A
    real(kind=8),allocatable :: d(:)       ! store accumulative distances to the other continuations in A
    integer,allocatable      :: ind(:)
    logical,allocatable      :: c1(:),c2(:),mask(:)
    ! dummy variables
    integer :: i,j,k,n,c

    n = size(P,1) ! nbr of points zout
    c = size(P,2) ! nbr of continuations

    if (exclude_positive) then
        ! count the number of "physical" Pade approximants, meaning those who fulfilling Im(P) <= 0
        k=0
        do i=1,c
            if (.not. any(0<aimag(P(:,i)))) then
                k = k+1
            endif
        enddo
        if(k==0) stop "No 'physical' continuations found"
        write(90,'(a,I4)') 'number of continuations with Im(f(zout))<=0 is:',k
    else
        ! use all Pade approximants
        write(90,'(a,I4)') 'Use all Pade approximants.'
        k = c
    endif
    allocate(g(k),A(size(P,1),k))
    k=0
    do i=1,c
        ! If parameter exclude_positive == .false., exclude no Pade approximant.
        ! If parameter exclude_positive == .true., exclude Pade approximants fullfilling 0<Im(P).
        if (.not. (exclude_positive .and. any(0<aimag(P(:,i))))) then
            k = k+1
            g(k) = i
            A(:,k) = aimag(P(:,i))
        endif
    enddo
    w = 0
    if(allocated(fout)) deallocate(fout)
    allocate(fout(size(P,1)))
    fout = 0
    if(k==1) then
        w(g(1)) = 1
        fout = P(:,g(1))
    else
        allocate(delta(k,k),d(k))
        delta = 0
        d = 0
        do i=1,k
            do j=i+1,k
                delta(i,j) = sum(abs(A(:,i)-A(:,j)))
            enddo
        enddo
        do i=1,k
            d(i) = sum(delta(:i-1,i))+sum(delta(i,i+1:))
        enddo
        ! calculate if to include or reject continuations based on two criteria:
        allocate(c1(k),c2(k),mask(k),ind(k))
        c1 = ( d <= c1v*sum(d)/k )
        ind = sortp(d)
        c2 = .false.
        c2(ind(1:int(c2v*k))) = .true. ! the 100*c2v % lowest continuations fulfill criterion 2.
        mask = c1 .and. c2
        j = 0
        do i=1,k
            if( mask(i) ) then
                j = j+1
                w(g(i)) = 1
                fout = fout + P(:,g(i))
            endif
        enddo
        fout = fout/j ! divide with the number of continuations contributing in the average
        deallocate(delta,d,c1,c2,mask,ind)
    endif
    deallocate(g,A)
end subroutine

function sort(A) !bubble sort algorithm, smallest first.
implicit none
real(kind=8),allocatable :: sort(:)
real(kind=8),intent(in) :: A(:)

real(kind=8) :: b
integer :: i,n,newn
n=size(A)
allocate(sort(n))
sort=A
do while(n>1)
    newn=0
    do i=1,n-1
        if(sort(i)>sort(i+1)) then
            b=sort(i)
            sort(i) = sort(i+1)
            sort(i+1) = b
            newn=i
        endif
    enddo
    n=newn
enddo
end function

function sortp(A) !bubble sort algorithm, sort with smallest first. Returns permutation array
! Eg: A=[ 3.1  1.3  2.5  1.3 ]    ->    A_sorted=[1.3 1.3 2.5 3.1] and sortp=[2 4 3 1]  so A=A_old(c)
implicit none
integer,allocatable :: sortp(:)
real(kind=8),intent(in) :: A(:)

integer,allocatable :: d(:),e(:)
real(kind=8),allocatable :: x(:),y(:)
integer :: i,j,k,n,m
n=size(A,1)
allocate(x(n),y(n),d(n),sortp(n))
x=A
y=sort(x) !sorted list
d=[ (i,i=1,n )  ]
do i=1,n !look which indices connect unsorted and sorted array
   j=minloc(abs(y(i)-x(d)),1)
   sortp(i)=d(j)
   !remove d(j) from d
   if(size(d,1)==1) then
      deallocate(d)
   else
      allocate(e(size(d,1)))
      e=d
      deallocate(d)
      allocate(d(size(e,1)-1))
      m=0
      do k=1,size(e,1)
         if(k/=j) then
            m=m+1
            d(m)=e(k)
         endif
      enddo
      deallocate(e)
   endif
enddo
deallocate(x,y)
end function

end module


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      written by the UFO converter
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      SUBROUTINE MP_COUP3()

      IMPLICIT NONE
      INCLUDE 'model_functions.inc'
      REAL*16 MP__PI, MP__ZERO
      PARAMETER (MP__PI=3.1415926535897932384626433832795E0_16)
      PARAMETER (MP__ZERO=0E0_16)
      INCLUDE 'mp_input.inc'
      INCLUDE 'mp_coupl.inc'

      MP__UVWFCT_T_0 = MP_COND(CMPLX(MP__MDL_MT,KIND=16)
     $ ,CMPLX(0.000000E+00_16,KIND=16),CMPLX(-((MP__MDL_G__EXP__2)
     $ /(2.000000E+00_16*1.600000E+01_16*MP__PI**2))*MP__MDL_CF
     $ *(4.000000E+00_16-3.000000E+00_16
     $ *MP_REGLOG(CMPLX((MP__MDL_MT__EXP__2/MP__MDL_MU_R__EXP__2)
     $ ,KIND=16))),KIND=16))
      MP__UVWFCT_G_1 = MP_COND(CMPLX(MP__MDL_MB,KIND=16)
     $ ,CMPLX(0.000000E+00_16,KIND=16),CMPLX(((MP__MDL_G__EXP__2)
     $ /(2.000000E+00_16*4.800000E+01_16*MP__PI**2))*4.000000E+00_16
     $ *MP__MDL_TF*MP_REGLOG(CMPLX((MP__MDL_MB__EXP__2
     $ /MP__MDL_MU_R__EXP__2),KIND=16)),KIND=16))
      MP__UVWFCT_G_2 = MP_COND(CMPLX(MP__MDL_MT,KIND=16)
     $ ,CMPLX(0.000000E+00_16,KIND=16),CMPLX(((MP__MDL_G__EXP__2)
     $ /(2.000000E+00_16*4.800000E+01_16*MP__PI**2))*4.000000E+00_16
     $ *MP__MDL_TF*MP_REGLOG(CMPLX((MP__MDL_MT__EXP__2
     $ /MP__MDL_MU_R__EXP__2),KIND=16)),KIND=16))
      END


      SUBROUTINE MFFTC8(C,FAC)
*
*   PURPOSE:
*       ELEMENTARY GENTLEMAN-SANDE RADIX 5 STEP APPLIED TO A VECTOR-OF
*       2-VECTORS-OF-COMPLEX C[IMS,NM [IVS,NV [IES,NE]]].
*       SEE REF.[1] FOR NOTATIONS.
*       THIS ROUTINE CAN BE USED ONLY BY ROUTINE MFFTDS, WHICH CONTROLS
*       ITS OPERATION THROUGH THE MFFTPA COMMON
*
*   DUMMY ARGUMENTS :
*
*   C   ARRAY BEING FOURIER  TRANSFORMED
*   FAC PHASE FACTORS, PREPARED BY MFFTP; NOT MODIFIED IN OUTPUT
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /MFFTPA/  IMS,IVS,IES,NM,NV,NE,MX,LX,MLIM,MSTEP,LLIM,LSTEP,
     $ NUSTEP,IVLIM,ILIM,MD2LIM,LD2LIM
      INTEGER NUSTEP
      DOUBLE COMPLEX C(0:NUSTEP-1,0:4),FAC(0:*)
      DOUBLE COMPLEX T1,T2,T3,T4,T5
      REAL *8 SIN72,RAD5D4,S36D72
      PARAMETER (
     $ SIN72 =  9.51056516295153572116439333E-1,
     $ RAD5D4 =  5.59016994374947424102293417E-1,
     $ S36D72 =  6.18033988749894848204586834E-1 )
      IF(MX.NE.1)THEN
            DO 200 LAM=0,LLIM,LSTEP
              DO 190 IV=LAM,LAM+IVLIM,IVS
                IMUF=0
                IMUF2=NUSTEP
                IMUF3=2*NUSTEP
                IMUF4=3*NUSTEP
                DO 180 IMU=IV,IV+ILIM
                  T1=C(IMU,1)+C(IMU,4)
                  T2=C(IMU,2)+C(IMU,3)
                  T3=(C(IMU,1)-C(IMU,4))*SIN72
                  T4=(C(IMU,2)-C(IMU,3))*SIN72
                  T5=T1+T2
                  T1=RAD5D4*(T1-T2)
                  T2=C(IMU,0)-0.25*T5
                  C(IMU,0)=C(IMU,0)+T5
                  T5=T2+T1
                  T2=T2-T1
                  T1=T3+S36D72*T4
                  T3=S36D72*T3-T4
                  C(IMU,1)=(T5-DCMPLX(-DIMAG(T1),DREAL(T1)))*FAC(IMUF )
                  C(IMU,4)=(T5+DCMPLX(-DIMAG(T1),DREAL(T1)))*FAC(IMUF4)
                  C(IMU,2)=(T2-DCMPLX(-DIMAG(T3),DREAL(T3)))*FAC(IMUF2)
                  C(IMU,3)=(T2+DCMPLX(-DIMAG(T3),DREAL(T3)))*FAC(IMUF3)
                  IMUF=IMUF+1
                  IMUF2=IMUF2+1
                  IMUF3=IMUF3+1
                  IMUF4=IMUF4+1
  180           CONTINUE
  190         CONTINUE
200         CONTINUE
        ELSE
            DO 400 LAM=0,LLIM,LSTEP
              DO 390 IV=LAM,LAM+IVLIM,IVS
                DO 380 IMU=IV,IV+ILIM
                  T1=C(IMU,1)+C(IMU,4)
                  T2=C(IMU,2)+C(IMU,3)
                  T3=(C(IMU,1)-C(IMU,4))*SIN72
                  T4=(C(IMU,2)-C(IMU,3))*SIN72
                  T5=T1+T2
                  T1=RAD5D4*(T1-T2)
                  T2=C(IMU,0)-0.25*T5
                  C(IMU,0)=C(IMU,0)+T5
                  T5=T2+T1
                  T2=T2-T1
                  T1=T3+S36D72*T4
                  T3=S36D72*T3-T4
                  C(IMU,1)=T5-DCMPLX(-DIMAG(T1),DREAL(T1))
                  C(IMU,4)=T5+DCMPLX(-DIMAG(T1),DREAL(T1))
                  C(IMU,2)=T2-DCMPLX(-DIMAG(T3),DREAL(T3))
                  C(IMU,3)=T2+DCMPLX(-DIMAG(T3),DREAL(T3))
380             CONTINUE
390           CONTINUE
400         CONTINUE
        ENDIF
      END


      SUBROUTINE TG01NX( JOBT, N, M, P, NDIM, A, LDA, E, LDE, B, LDB,
     $                   C, LDC, Q, LDQ, Z, LDZ, IWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute equivalence transformation matrices Q and Z which
C     reduce the regular pole pencil A-lambda*E of the descriptor system
C     (A-lambda*E,B,C), with (A,E) in a generalized real Schur form, to
C     the block-diagonal form
C
C                ( A1  0  )             ( E1  0  )
C        Q*A*Z = (        ) ,   Q*E*Z = (        ) ,                 (1)
C                ( 0   A2 )             ( 0   E2 )
C
C     where the pair (Q*A*Z,Q*E*Z) is in a generalized real Schur form,
C     with (A1,E1) and (A2,E2) having no common generalized eigenvalues.
C     This decomposition corresponds to an additive spectral
C     decomposition of the transfer-function matrix of the descriptor
C     system as the sum of two terms containing the generalized
C     eigenvalues of (A1,E1) and (A2,E2), respectively.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBT    CHARACTER*1
C             = 'D':  compute the direct transformation matrices;
C             = 'I':  compute the inverse transformation matrices
C                     inv(Q) and inv(Z).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of rows of the matrix B, the number of columns
C             of the matrix C and the order of the square matrices A
C             and E.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of the matrix C.  P >= 0.
C
C     NDIM    (input) INTEGER
C             The dimension of the leading diagonal blocks of (A,E)
C             having generalized eigenvalues distinct from those of the
C             trailing diagonal block.  0 <= NDIM <= N.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N state matrix A in a real Schur form.
C             On exit, the leading N-by-N part of this array contains
C             the transformed state matrix Q*A*Z (if JOBT = 'D') or
C             inv(Q)*A*inv(Z) (if JOBT = 'I'), in the form (1), where
C             A1 is a NDIM-by-NDIM matrix.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N descriptor matrix E in upper triangular
C             form.
C             On exit, the leading N-by-N part of this array contains
C             the transformed descriptor matrix Q*E*Z (if JOBT = 'D') or
C             inv(Q)*E*inv(Z) (if JOBT = 'I'), in the form (1), where
C             E1 is an NDIM-by-NDIM matrix.
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the N-by-M input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix Q*B (if JOBT = 'D') or
C             inv(Q)*B (if JOBT = 'I').
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*Z (if JOBT = 'D') or C*inv(Z)
C             (if JOBT = 'I').
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             On entry, the leading N-by-N part of this array contains
C             Q1, the orthogonal left transformation matrix Q used to
C             reduce the pair (A,E) to the generalized real Schur form.
C             On exit, the leading N-by-N part of this array contains
C             the left transformation matrix Q = Q2*Q1, if JOBT = 'D',
C             or its inverse inv(Q), if JOBT = 'I'.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= MAX(1,N).
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             On entry, the leading N-by-N part of this array contains
C             the orthogonal right transformation matrix Z1 used to
C             reduce the pair (A,E) to the generalized real Schur form.
C             On exit, the leading N-by-N part of this array contains
C             the right transformation matrix Z = Z1*Z2, if JOBT = 'D',
C             or its inverse inv(Z), if JOBT = 'I'.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= MAX(1,N).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N+6)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the separation of the two diagonal blocks failed
C                   because of very close eigenvalues.
C
C     METHOD
C
C     For the separation, transformation matrices Q2 and Z2 of the form
C
C             ( I -X )          ( I  Y )
C        Q2 = (      ) ,   Z2 = (      )
C             ( 0  I )          ( 0  I )
C
C     are determined, such that Q2*A*Z2 and Q2*E*Z2 are block diagonal
C     as in (1). X and Y are computed by solving generalized Sylvester
C     equations.
C
C     If we partition Q2*B and C*Z2 according to (1) in the form ( B1 )
C                                                                ( B2 )
C     and ( C1 C2 ), then (A1-lambda*E1,B1,C1) and (A2-lambda*E2,B2,C2)
C     represent an additive spectral decomposition of the system
C     transfer-function matrix.
C
C     REFERENCES
C
C     [1] Kagstrom, B. and Van Dooren, P.
C         Additive decomposition of a transfer function with respect
C         to a specified region.
C         Proc. MTNS Symp., Brussels, 1989.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( N**3 )  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     November 2002.
C
C     REVISIONS
C
C     V. Sima, Dec. 2016.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, system poles, multivariable
C     system, additive decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          JOBT
      INTEGER            INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, M, N, NDIM,
     $                   P
C     .. Array Arguments ..
      INTEGER            IWORK(*)
      DOUBLE PRECISION   A(LDA,*), B(LDB,*), C(LDC,*), E(LDE,*),
     $                   Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL            TRINV
      DOUBLE PRECISION   DIF, SCALE
      INTEGER            I, N1, N11, N2
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1)
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DLASET, DSWAP, DTGSYL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO  =  0
      TRINV =  LSAME( JOBT, 'I' )
      IF( .NOT.LSAME( JOBT, 'D' ) .AND. .NOT.TRINV  ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( NDIM.LT.0 .OR. NDIM.GT.N ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -13
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -17
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01NX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.EQ.0 )
     $   RETURN
C
      IF( TRINV ) THEN
C
C        Transpose Z in-situ.
C
         DO 10 I = 2, N
            CALL DSWAP( I-1, Z(1,I), 1, Z(I,1), LDZ )
   10    CONTINUE
C
C        Transpose Q in-situ.
C
         DO 20 I = 2, N
            CALL DSWAP( I-1, Q(1,I), 1, Q(I,1), LDQ )
   20    CONTINUE
      END IF
C
C     Let be A and E partitioned as ( A11 A12 ) and ( E11 E12 ).
C                                   (  0  A22 )     (  0  E22 )
C     Split the pairs (A11,E11) and (A22,E22) by using the following
C     left and right transformation matrices
C             ( I -X )          ( I  Y )
C        Q2 = (      ) ,   Z2 = (      ) ,
C             ( 0  I )          ( 0  I )
C     where X and Y are computed by solving the generalized
C     Sylvester equations
C
C              A11 * Y - X * A22 = scale * A12
C              E11 * Y - X * E22 = scale * E12.
C
C     -Y is computed in A12 and -X is computed in E12.
C
C     Integer workspace: need  N+6.
C
      N1  = NDIM
      N2  = N - NDIM
      N11 = MIN( N1 + 1, N )
C
      IF( N1.GT.0 .AND. N2.GT.0 ) THEN
         CALL DTGSYL( 'No transpose', 0, N1, N2, A, LDA, A(N11,N11),
     $                LDA, A(1,N11), LDA, E, LDE, E(N11,N11), LDE,
     $                E(1,N11), LDE, SCALE, DIF, DUM, 1, IWORK, INFO )
         IF( INFO.NE.0 ) THEN
            INFO = 1
            RETURN
         END IF
C
C        Transform B = ( B1 ) and C = ( C1 C2 ).
C                      ( B2 )
C
         IF( SCALE.GT.0 )
     $       SCALE = ONE/SCALE
C
C        B1 <- B1 - X*B2.
C
         CALL DGEMM( 'N', 'N', N1, M, N2, SCALE, E(1,N11), LDE,
     $               B(N11,1), LDB, ONE, B, LDB )
C
C        C2 <- C2 + C1*Y.
C
         CALL DGEMM( 'N', 'N', P, N2, N1, -SCALE, C, LDC, A(1,N11),
     $               LDA, ONE, C(1,N11), LDC )
C
         IF( TRINV ) THEN
C
C           Transform Q1 = ( Q11 Q12 ) and Z1 = ( Z11 ).
C                                               ( Z21 )
C
C           Q12 <- Q12 + Q11*X.
C
            CALL DGEMM( 'N', 'N', N, N2, N1, -SCALE, Q, LDQ, E(1,N11),
     $                  LDE, ONE, Q(1,N11), LDQ )
C
C           Z11 <- Z11 - Y*Z21.
C
            CALL DGEMM( 'N', 'N', N1, N, N2, SCALE, A(1,N11), LDA,
     $                  Z(N11,1), LDZ, ONE, Z, LDZ )
         ELSE
C
C           Transform Q1 = ( Q11 ) and Z1 = ( Z11 Z12 ).
C                          ( Q21 )
C
C           Q11 <- Q11 - X*Q21.
C
            CALL DGEMM( 'N', 'N', N1, N, N2, SCALE, E(1,N11), LDE,
     $                  Q(N11,1), LDQ, ONE, Q, LDQ )
C
C           Z12 <- Z12 + Z11*Y.
C
            CALL DGEMM( 'N', 'N', N, N2, N1, -SCALE, Z, LDZ, A(1,N11),
     $                  LDA, ONE, Z(1,N11), LDZ )
         END IF
C
C        Set A12 and E12 to zero.
C
         CALL DLASET( 'Full', N1, N2, ZERO, ZERO, A(1,N11), LDA )
         CALL DLASET( 'Full', N1, N2, ZERO, ZERO, E(1,N11), LDE )
      END IF
C
      RETURN
C *** Last line of TG01NX ***
      END


module atomic_partition_mod
implicit none
contains
!-----------------------------------------------------------------
! This subroutine calculates the atomic partition function for a given element
!	nel: atomic number
!	t: array with the temperature
!	u1: partition function for the neutral element (also an array of the same size as t)
!	u2: partition function for the 1st ionization (also an array of the same size as t)
!	u3: partition function for the 2nd ionization (also an array of the same size as t)
!     A. D. Wittmann, Goettingen (1975).(1974, solar phys. 35, 11)
!-----------------------------------------------------------------
	subroutine partition_atomic(t, nel, u1, u2, u3)
	real(kind=8) :: t(:), u1(size(t)), u2(size(t)), u3(size(t))
	real(kind=8), allocatable :: x(:), y(:), coeff(:), zz(:)
	integer :: nel, n, i

		n = size(t)
		allocate(x(n))
		allocate(y(n))

		x = alog(5040.e0/real(t))
		y = 1.d-3*t
		select case(nel)
! H
			case(1)
				allocate(coeff(6))
				allocate(zz(n))
				zz = log10(t)
				coeff(1) = -2.61655891d2
				coeff(2) = 1.63428326d2
				coeff(3) = -4.06133526d1
				coeff(4) = 5.03282928d0
				coeff(5) = -3.10998364d-1
				coeff(6) = 7.66654594d-3
				zz=dlog(t)
				u1=(((((coeff(6)*zz+coeff(5))*zz)+coeff(4))*zz+coeff(3))*zz+coeff(2))*zz+coeff(1)
				u1=exp(u1)
				where(t > 16000.d0)
					u1 = dexp(7.19420668d-1)
				endwhere
				u2 = 1.d0
				u3 = 0.d0
				deallocate(coeff)
				deallocate(zz)
! He
			case(2)
				u1 = 1.d0 + 0.d0*t
				u2 = 2.d0 + 0.d0*t
				u3 = 1.d0 + 0.d0*t

! Li
			case(3)
				u1 = 2.081d0 - y*(6.8926d-2-y*1.4081d-2)
				where(t > 6.d3)
					u1 = 3.4864 + t*(-7.3292d-4+t*8.5586d-8)
				endwhere
				u2 = 1.d0 + 0.d0*t
      			u3 = 2.d0 + 0.d0*t

! Be
			case(4)
				do i = 1, n
					u1(i) = max(1.d0+0.d0*t(i),0.631d0+7.032d-5*t(i))
				enddo
				u2 = 2.d0 + 0.d0*t
				u3 = 1.d0 + 0.d0*t

! B
			case(5)
				u1 = 5.9351d0 + 1.0438d-2*y
				u2 = 1.d0 + 0.d0*t
				u3 = 2.d0 + 0.d0*t

! C
			case(6)
				u1 = 8.6985d0 + y * (2.0485d-2 + y * (1.7629d-2 - 3.9091d-4 * y))
				where(t > 1.2d4)
					u1 = 13.97d0 + t*(-1.3907d-3 + 9.0844d-8 * t)
				endwhere
				u2 = 5.838d0 + 1.6833d-5 * t
				where(t > 2.4d4)
					u2 = 10.989d0 + t * (-6.9347d-4 + t * 2.0861d-8)
				endwhere
				u3 = 1.d0 + 0.d0*t
				where(t > 1.95d4)
					u2 = -0.555d0 + 8.d-5 * t
				endwhere

! N
			case(7)
				u1 = 3.9914d0 + y * (1.7491d-2 - y * (1.0148d-2 - y * 1.7138d-3))
				where(t > 8800.d0 .and. t <= 1.8d4)
					u1 = 2.171d0 + 2.54d-4*t
				endwhere
				where(t > 1.8d4)
					u1 = 11.396d0 + t * (-1.7139d-3 + t * 8.633d-8)
				endwhere
				u2 = 8.060d0 + 1.420d-4*t
				where(t > 3.3d4)
					u2 = 26.793d0 + t * (-1.8931d-3 + t * 4.4612d-8)
				endwhere
				u3 = 5.9835d0 + t * (-2.6651d-5 + t * 1.8228d-9)
				where(t > 7310.5d0)
					u3 = 5.89d0
				endwhere
! O
			case(8)
				u1 = 8.29d0 + 1.10d-4*t
				where(t > 1.9d4)
					u1 = 66.81 + t * (-6.019d-3 + t * 1.657d-7)
				endwhere
				do i = 1, n
					u2(i) = max(4.d0+0.d0*t(i),3.51d0+8.d-5*t(i))
				enddo
				where(t > 2.d4)
					u2 = 68.7+t*(-4.216d-3+t*6.885d-8)
				endwhere
				u3 = 7.865d0 + 1.1348d-4*t

! F
			case(9)
				u1 = 4.5832d0+y*(0.77683d0+y*(-.20884d0+y*(2.6771d-2-1.3035d-3*y)))
				where(t > 8750.d0 .and. t <= 2.d4)
					u1 = 5.9d0
				endwhere
				where(t > 2.d4)
					u1 = 15.16+t*(-9.229d-4+t*2.312d-8)
				endwhere
				u2 = 8.15d0 + 8.9d-5*t
      			u3 = 2.315d0 + 1.38d-4*t
! Ne
			case(10)
				u1 = 1.d0
				where(t > 2.69d4)
					u1 = 26.3d0+t*(-2.113d-3+t*4.359d-8)
				endwhere
				u2 = 5.4d0 + 4.d-5 * t
				u3 = 7.973d0 + 7.956d-5 * t
! Na
			case(11)
				do i = 1, n
					u1(i) = max(2.+0.*t(i),1.72+9.3d-5*t(i))
				enddo
				where(t > 5400.d0 .and. t <= 8.5d3)
					u1 = -0.83+5.66d-4*t
				endwhere
				where(t > 8.5d3)
					u1 = 4.5568d0+t*(-1.2415d-3+t*1.3861d-7)
				endwhere
				u2 = 1.d0
				u3 = 5.69d0 + 5.69d-6 * t
! Mg
			case(12)
				u1 = 1.d0+exp(-4.027262-x*(6.173172+x*(2.889176+x*(2.393895+.784131*x))))
				where(t > 8.d3)
					u1 = 2.757+t*(-7.8909e-4+t*7.4531e-8)
				endwhere
				u2 = 2.d0+exp(-7.721172-x*(7.600678+x*(1.966097+.212417*x)))
				where(t > 2.d4)
					u2 = 7.1041+t*(-1.0817e-3+t*4.7841d-8)
				endwhere
				u3 = 1.d0

! Al
			case(13)
				u1 = 5.2955+y*(.27833-y*(4.7529d-2-y*3.0199d-3))
				do i = 1, n
					u2(i) = max(1.d0, 0.725+3.245d-5*t(i))
				enddo
				where(t > 2.24d4)
					u2 = 61.06+t*(-5.987e-3+t*1.485e-7)
				endwhere
				do i = 1, n
					u3(i) = max(2.d0,1.976d0+3.43d-6*t(i))
				enddo
				where(t > 1.814d4)
					u3 = 3.522+t*(-1.59d-4+t*4.382d-9)
				endwhere
! Si
			case(14)
				u1 = 6.7868+y*(.86319+y*(-.11622+y*(.013109-6.2013d-4*y)))
				where(t > 1.04d4)
					u1 = 86.01+t*(-1.465d-2+t*7.282d-7)
				endwhere
				u2 = 5.470+4.e-5*t
				where(t > 1.8d4)
					u2 = 26.44+t*(-2.22d-3+t*6.188d-8)
				endwhere
				do i = 1, n
					u3(i) = max(1.d0,0.911+1.1d-5*t(i))
				enddo
				where(t > 3.33d4)
					u3 = 19.14+t*(-1.408d-3+t*2.617d-8)
				endwhere
! P
			case(15)
				u1 = 4.2251+y*(-.22476+y*(.057306-y*1.0381e-3))
				where (t > 6.d3)
					u1 = 1.56+5.2e-4*t
				endwhere
				u2 = 4.4151+y*(2.2494+y*(-.55371+y*(.071913-y*3.5156e-3)))
				where(t > 7250.d0)
					u2 = 4.62+5.38d-4*t
				endwhere
				u3 = 5.595+3.4e-5*t
! S
			case(16)
				u1 = 7.5+2.15e-4*t
				where(t > 1.16d4)
					u1 = 38.76+t*(-4.906e-3+t*2.125e-7)
				endwhere
				u2 = 2.845+2.43e-4*t
				where(t > 1.05d4)
					u2 = 6.406+t*(-1.68e-4+t*1.323e-8)
				endwhere
				u3 = 7.38d0 + 1.88d-4*t
! Cl
			case(17)
				u1 = 5.2+6.e-5*t
				where(t > 1.84d4)
					u1 = -81.6+4.8e-3*t
				endwhere
				u2 = 7.0+2.43e-4*t
      			u3 = 2.2+2.62e-4*t
! Ar
			case(18)
				u1 = 1.d0
				u2 = 5.20+3.8e-5*t
				u3 = 7.474+1.554e-4*t
! K
			case(19)
				u1 = 1.9909+y*(.023169-y*(.017432-y*4.0938e-3))
				where(t > 5800.d0)
					u1 = -9.93+2.124e-3*t
				endwhere
				u2 = 1.d0
				u3 = 5.304d0 + 1.93d-5*t
! Ca
			case(20)
				u1 = 1.+exp(-1.731273-x*(5.004556+x*(1.645456+x*(1.326861+.508553*x))))
				u2 = 2.+exp(-1.582112-x*(3.996089+x*(1.890737+.539672*x)))
      			u3 = 1.d0+0.*t
! Sc
			case(21)
				u1 = 4.+exp(2.071563+x*(-1.2392+x*(1.173504+.517796*x)))
      			u2 = 3.+exp(2.988362+x*(-.596238+.054658*x))
      			u3 = 10.+0.*t
! Ti
			case(22)
				u1 = 5.+exp(3.200453+x*(-1.227798+x*(.799613+.278963*x)))
				where(t > 5.5d3)
					u1 = 16.37+t*(-2.838e-4+t*5.819e-7)
				endwhere
				u2 = 4.+exp(3.94529+x*(-.551431+.115693*x))
      			u3 = 16.4+8.5e-4*t
! V
			case(23)
				u1 = 4.+exp(3.769611+x*(-.906352+x*(.724694+.1622*x)))
				u2 = 1.+exp(3.755917+x*(-.757371+.21043*x))
      			u3 = -18.+1.03e-2*t
				where(t < 2.25d3)
					u3 = 2.4d-3 * t
				endwhere
! Cr
			case(24)
				u1 = 7.+exp(1.225042+x*(-2.923459+x*(.154709+.09527*x)))
      			u2 = 6.+exp(.128752-x*(4.143973+x*(1.096548+.230073*x)))
      			u3 = 10.4+2.1e-3*t
! Mn
			case(25)
				u1 = 6.+exp(-.86963-x*(5.531252+x*(2.13632+x*(1.061055+.265557*x))))
      			u2 = 7.+exp(-.282961-x*(3.77279+x*(.814675+.159822*x)))
      			u3 = 10.+t*0.
! Fe
			case(26)
				u1 = 9.+exp(2.930047+x*(-.979745+x*(.76027+.118218*x)))
				where(t < 4.d3)
					u1 = 15.85+t*(1.306e-3+t*2.04e-7)
				endwhere
				where(t > 9.d3)
					u1 = 39.149+t*(-9.5922e-3+t*1.2477e-6)
				endwhere
				u2 = 10.+exp(3.501597+x*(-.612094+.280982*x))
				where(t > 1.8d4)
					u2 = 68.356+t*(-6.1104e-3+t*5.1567e-7)
				endwhere
				u3 = 17.336+t*(5.5048e-4+t*5.7514e-8)
! Co
			case(27)
				u1 = 8.65+4.9e-3*t
      			u2 = 11.2+3.58e-3*t
      			u3 = 15.0+1.42e-3*t
! Ni
			case(28)
				u1 = 9.+exp(3.084552+x*(-.401323+x*(.077498-.278468*x)))
      			u2 = 6.+exp(1.593047-x*(1.528966+.115654*x))
      			u3 = 13.3+6.9e-4*t
! Cu
			case(29)
				do i = 1, n
					u1(i) = max(2.d0,1.50+1.51d-4*t(i))
				enddo
				where(t > 6250.d0)
					u1 = -.3+4.58e-4*t
				endwhere
				do i = 1, n
					u2(i) = max(1.d0,0.22+1.49d-4*t(i))
				enddo
				u3 = 8.025+9.4e-5*t
! Zn
			case(30)
				do i = 1, n
					u1(i) = max(1.d0,0.632d0+5.11d-5*t(i))
				enddo
				u2 = 2.d0
				u3 = 1.d0
! Ga
			case(31)
				u1 = 1.7931+y*(1.9338+y*(-.4643+y*(.054876-y*2.5054e-3)))
				where(t > 6.d3)
					u1 = 4.18+2.03e-4*t
				endwhere
				u2 = 1.d0
				u3 = 2.d0
! Ge
			case(32)
				u1 = 6.12+4.08e-4*t
      			u2 = 3.445+1.78e-4*t
      			u3 = 1.1+0.*t
! As
			case(33)
				u1 = 2.65+3.65e-4*t
				u2 = -.25384+y*(2.284+y*(-.33383+y*(.030408-y*1.1609e-3)))
				where(t > 1.2d4)
					u2 = 8.d0
				endwhere
				u3 = 8.d0
! Se
			case(34)
				u1 = 6.34+1.71e-4*t
      			u2 = 4.1786+y*(-.15392+3.2053e-2*y)
      			u3 = 8.+0.*t
! Br
			case(35)
				u1 = 4.12+1.12e-4*t
      			u2 = 5.22+3.08e-4*t
      			u3 = 2.3+2.86e-4*t
! Kr
			case(36)
				u1 = 1.d0
				u2 = 4.11+7.4e-5*t
      			u3 = 5.35+2.23e-4*t
! Rb
			case(37)
				do i = 1, n
					u1(i) = max(2.d0,1.38+1.94d-4*t(i))
				enddo
				where (t> 6250.d0)
					u1 = -14.9+2.79e-3*t
				endwhere
				u2 = 1.d0
				u3 = 4.207+4.85e-5*t
! Sr
			case(38)
				u1 = .87127+y*(.20148+y*(-.10746+y*(.021424-y*1.0231e-3)))
				where(t > 6500.d0)
					u1 = -6.12+1.224e-3*t
				endwhere
				do i = 1, n
					u2(i) = max(2.d0,0.84+2.6d-4*t(i))
				enddo
				u3 = 1.d0
! Y
			case(39)
				u1 = .2+2.58e-3*t
      			u2 = 7.15+1.855e-3*t
      			u3 = 9.71+9.9e-5*t
! Zr
			case(40)
				u1 = 76.31+t*(-1.866e-2+t*2.199e-6)
				where(t < 6236d0)
					u1 = 6.8+t*(2.806e-3+t*5.386e-7)
				endwhere
				u2 = 4.+exp(3.721329-.906502*x)
      			u3 = 12.3+1.385e-3*t
! Nb
			case(41)
				do i = 1, n
					u1(i) = max(1.d0,-0.19+1.43d-2*t(i))
				enddo
				u2 = -4.+1.015e-2*t
      			u3 = 25.+0.*t
! Mo
			case(42)
				do i = 1, n
					u1(i) = max(7.d0,2.1+1.5d-3*t(i))
				enddo
				where(t < 7.d3)
					u1 = -38.1+7.28e-3*t
				endwhere
				u2 = 1.25+1.17e-3*t
				where(t > 6900.d0)
					u2 = -28.5+5.48e-3*t
				endwhere
				u3 = 24.04+1.464e-4*t
! Tc
			case(43)
				u1 = 4.439+y*(.30648+y*(1.6525+y*(-.4078+y*(.048401-y*2.1538e-3))))
				where(t > 6.d3)
					u1 = 24.d0
				endwhere
				u2 = 8.1096+y*(-2.963+y*(2.369+y*(-.502+y*(.049656-y*1.9087e-3))))
				where(t > 6.d3)
					u2 = 17.d0
				endwhere
				u3 = 220.d0
! Ru
			case(44)
				u1 = -3.+7.17e-3*t
      			u2 = 3.+4.26e-3*t
      			u3 = 22.+0.*t
! Rh
			case(45)
				u1 = 6.9164+y*(3.8468+y*(.043125-y*(8.7907e-3-y*5.9589e-4)))
      			u2 = 7.2902+y*(1.7476+y*(-.038257+y*(2.014e-3+y*2.1218e-4)))
      			u3 = 30.+t*0.
! Pd
			case(46)
				do i = 1, n
					u1(i) = max(1.d0,-1.75+9.86d-4*t(i))
				enddo
				u2 = 5.60+3.62e-4*t
      			u3 = 20.+t*0.
! Ag
			case(47)
				do i = 1, n
					u1(i) = max(2.d0,1.537+7.88d-5*t(i))
					u2(i) = max(1.d0,0.73d0+3.4d-5*t(i))
				enddo
				u3 = 6.773+1.248e-4*t
! Cd
			case(48)
				do i = 1, n
					u1(i) = max(1.d0,0.43+7.6d-5*t(i))
				enddo
				u2 = 2.d0
				u3 = 1.d0
! In
			case(49)
				u1 = 2.16+3.92e-4*t
      			u2 = 1.0+t*0.
      			u3 = 2.00+t*0.
! Sn
			case(50)
				u1 = 2.14+6.16e-4*t
      			u2 = 2.06+2.27e-4*t
      			u3 = 1.05+0.*t
! Sb
			case(51)
				u1 = 2.34+4.86e-4*t
      			u2 = .69+5.36e-4*t
      			u3 = 3.5+0.*t
! Te
			case(52)
				u1 = 3.948+4.56e-4*t
      			u2 = 4.2555+y*(-.25894+y*(.06939-y*2.4271e-3))
				where(t > 1.2d4)
					u2 = 7.d0
				endwhere
				u3 = 5.d0
! I
			case(53)
				do i = 1, n
					u1(i) = max(4.d0,3.8d0+9.5d-5*t(i))
				enddo
				u2 = 4.12+3.e-4*t
      			u3 = 7.+0.*t
! Xe
			case(54)
				u1 = 1.d0
				u2 = 3.75+6.876e-5*t
      			u3 = 4.121+2.323e-4*t
! Cs
			case(55)
				do i = 1, n
					u1(i) = max(2.d0,1.56d0+1.67d-4*t(i))
				enddo
				where(t > 4750.d0)
					u1 = -2.680+1.04e-3*t
				endwhere
				u2 = 1.d0
				u3 = 3.769+4.971e-5*t
! Ba
			case(56)
				do i = 1, n
					u1(i) = max(1.d0,-1.8+9.85e-4*t(i))
				enddo
				where(t > 6850.d0)
					u1 = -16.2+3.08e-3*t
				endwhere
				u2 = 1.11+5.94e-4*t
      			u3 = 1.00+0.*t
! La
			case(57)
				u1 = 15.42+9.5e-4*t
				where(t > 5060.d0)
					u1 = 1.+3.8e-3*t
				endwhere
				u2 = 13.2+3.56e-3*t
      			u3 = 12.+0.*t
! Ce
			case(58)
				u1 = 9.+exp(5.202903+x*(-1.98399+x*(.119673+.179675*x)))
      			u2 = 8.+exp(5.634882-x*(1.459196+x*(.310515+.052221*x)))
      			u3 = 9.+exp(3.629123-x*(1.340945+x*(.372409+x*(.03186-.014676*x))))
! Pr
			case(59)
				u2 = 9.+exp(4.32396-x*(1.191467+x*(.149498+.028999*x)))
      			u1 = u2
      			u3 = 10.+exp(3.206855+x*(-1.614554+x*(.489574+.277916*x)))
! Nb
			case(60)
				u1 = 9.+exp(4.456882+x*(-2.779176+x*(.082258+x*(.50666+.127326*x))))
      			u2 = 8.+exp(4.689643+x*(-2.039946+x*(.17193+x*(.26392+.038225*x))))
      			u3 = u2
! Pm
			case(61)
				u1 = 20.d0
				u2 = 25.d0
				u3 = 100.d0
! Sm
			case(62)
				u1 = 1.+exp(3.549595+x*(-1.851549+x*(.9964+.566263*x)))
      			u2 = 2.+exp(4.052404+x*(-1.418222+x*(.358695+.161944*x)))
      			u3 = 1.+exp(3.222807-x*(.699473+x*(-.056205+x*(.533833+.251011*x))))
! Eu
			case(63)
				u1 = 8.+exp(1.024374-x*(4.533653+x*(1.540805+x*(.827789+.286737*x))))
      			u2 = 9.+exp(1.92776+x*(-1.50646+x*(.379584+.05684*x)))
      			u3 = 8.+0.*t
! Gd
			case(64)
				u1=5.+exp(4.009587+x*(-1.583513+x*(.800411+.388845*x)))
      			u2=6.+exp(4.362107-x*(1.208124+x*(-.074813+x*(.076453+.055475*x))))
      			u3=5.+exp(3.412951-x*(.50271+x*(.042489-4.017e-3*x)))
! Tb
			case(65)
				u1 = 16.+exp(4.791661+x*(-1.249355+x*(.570094+.240203*x)))
      			u2 = 15.+exp(4.472549-x*(.295965+x*(5.88e-3+.131631*x)))
      			u3 = u2
! Dy
			case(66)
				u1 = 17.+exp(3.029646-x*(3.121036+x*(.086671-.216214*x)))
      			u2 = 18.+exp(3.465323-x*(1.27062+x*(-.382265+x*(.431447+.303575*x))))
      			u3 = u2
! Ho
			case(67)
				u3 = 16.+exp(1.610084-x*(2.373926+x*(.133139-.071196*x)))
      			u1 = u3
      			u2 = u3
! Er
			case(68)
				u1 = 13.+exp(2.895648-x*(2.968603+x*(.561515+x*(.215267+.095813*x))))
      			u2 = 14.+exp(3.202542-x*(.852209+x*(-.226622+x*(.343738+.186042*x))))
      			u3 = u2
! Tm
			case(69)
				u1 = 8.+exp(1.021172-x*(4.94757+x*(1.081603+.034811*x)))
      			u2 = 9.+exp(2.173152+x*(-1.295327+x*(1.940395+.813303*x)))
      			u3 = 8.+exp(-.567398+x*(-3.383369+x*(.799911+.554397*x)))
! Yb
			case(70)
				u1 = 1.+exp(-2.350549-x*(6.688837+x*(1.93869+.269237*x)))
      			u2 = 2.+exp(-3.047465-x*(7.390444+x*(2.355267+.44757*x)))
      			u3 = 1.+exp(-6.192056-x*(10.560552+x*(4.579385+.940171*x)))
! Lu
			case(71)
				u1 = 4.+exp(1.537094+x*(-1.140264+x*(.608536+.193362*x)))
				do i = 1, n
					u2(i) = max(1.d0,0.66+1.52d-4*t(i))
				enddo
				where(t > 5250.d0)
					u2 = -1.09+4.86e-4*t
				endwhere
				u3 = 5.d0
! Hf
			case(72)
				u1 = 4.1758+y*(.407+y*(.57862-y*(.072887-y*3.6848e-3)))
      			u2 = -2.979+3.095e-3*t
      			u3 = 30. +0.*t
! Ta
			case(73)
				u1 = 3.0679+y*(.81776+y*(.34936+y*(7.4861e-3+y*3.0739e-4)))
      			u2 = 1.6834+y*(2.0103+y*(.56443-y*(.031036-y*8.9565e-4)))
      			u3 = 15.+0.*t
! W
			case(74)
				u1 = .3951+y*(-.25057+y*(1.4433+y*(-.34373+y*(.041924-y*1.84e-3))))
				where(t > 1.2d4)
					u1 = 23.d0
				endwhere
				u2 = 1.055+y*(1.0396+y*(.3303-y*(8.4971e-3-y*5.5794e-4)))
      			u3 = 20.+0.*t
! Re
			case(75)
				u1 = 5.5671+y*(.72721+y*(-.42096+y*(.09075-y*3.9331e-3)))
				where(t > 1.2d4)
					u1 = 29.d0
				endwhere
				u2 = 6.5699+y*(.59999+y*(-.28532+y*(.050724-y*1.8544e-3)))
				where(t > 1.2d4)
					u2 = 22.d0
				endwhere
				u3 = 20.d0
! Os
			case(76)
				u1 = 8.6643+y*(-.32516+y*(.68181-y*(.044252-y*1.9975e-3)))
      			u2 = 9.7086+y*(-.3814+y*(.65292-y*(.064984-y*2.8792e-3)))
      			u3 = 10.+0.*t
! Ir
			case(77)
				u1 = 11.07+y*(-2.412+y*(1.9388+y*(-.34389+y*(.033511-1.3376e-3*y))))
				where(t > 1.2d4)
					u1 = 30.d0
				endwhere
				u2 = 15.d0
				u3 = 20.d0
! Pt
			case(78)
				u1 = 16.4+1.27e-3*t
      			u2 = 6.5712+y*(-1.0363+y*(.57234-y*(.061219-2.6878e-3*y)))
      			u3 = 15.d0
! Au
			case(79)
				u1 = 1.24+2.79e-4*t
      			u2 = 1.0546+y*(-.040809+y*(2.8439e-3+y*1.6586e-3))
      			u3 = 7.+0.*t
! Hg
			case(80)
				u1 = 1.0+0.*t
      			u2 = 2.+0.*t
				do i = 1, n
					u3(i) = max(1.d0,.669+3.976e-5*t(i))
				enddo
! Tl
			case(81)
				do i = 1, n
					u1(i) = max(2.d0,0.63+3.35e-4*t(i))
				enddo
				u2 = 1.d0
				u3 = 2.d0
! Pb
			case(82)
				do i = 1, n
					u1(i) = max(1.d0,0.42+2.35e-4*t(i))
				enddo
				where(t > 6125.d0)
					u1 = -1.2+5.e-4*t
				endwhere
				do i = 1, n
					u2(i) = max(2.d0,1.72+7.9e-5*t(i))
				enddo
				u3 = 1.d0
! Bi
			case(83)
				u1 = 2.78+2.87e-4*t
				do i = 1, n
					u2(i) = max(1.d0,.37+1.41e-4*t(i))
				enddo
				u3 = 2.5d0
! Po
			case(84)
				u1 = 5.+0.*t
      			u2 = 5.+0.*t
      			u3 = 4.+0.*t
! At
			case(85)
				u1 = 4.+0.*t
      			u2 = 6.+0.*t
      			u3 = 6.+0.*t
! Rn
			case(86)
				u1 = 1. +0.*t
      			u2 = 4.+0.*t
      			u3 = 6.+0.*t
! Fr
			case(87)
				u1 = 2. +0.*t
      			u2 = 1.+0.*t
      			u3 = 4.5+0.*t
! Ra
			case(88)
				u1 = 1. +0.*t
      			u2 = 2.+0.*t
      			u3 = 1.+0.*t
! Ac
			case(89)
				u1 = 6. +0.*t
      			u2 = 3.+0.*t
      			u3 = 7.+0.*t
! Th
			case(90)
				u1 = 8. +0.*t
      			u2 = 8.+0.*t
      			u3 = 8.+0.*t
! Pa
			case(91)
				u1 = 50. +0.*t
      			u2 = 50.+0.*t
      			u3 = 50.+0.*t
! U
			case(92)
				u1 = 25. +0.*t
      			u2 = 25.+0.*t
      			u3 = 25.+0.*t
			case DEFAULT
				print *, 'Partition function not available...'
		end select
		deallocate(x)
		deallocate(y)
	end subroutine partition_atomic
end module atomic_partition_mod


module gausspp_interface
  interface
    subroutine gausspp(a, b, l, deter)
      real, dimension(:,:), intent(inout) :: a
      real, dimension(:), intent(inout) :: b
      integer, dimension(:), intent(inout) :: l
      real, intent(out) :: deter
    end subroutine
  end interface
end module