!AC -- read KORAL files 2/2/17
!   -- modified from fluid_model_harm.f90
   module fluid_model_koral3d

      use class_four_vector
      use interpolate, only: interp
      use kerr, only: kerr_metric, lnrf_frame, uks2ubl, bl2ks
      use phys_constants, only: pi
      use math, only: zbrent
      implicit none

      !AC koral will read modified harm .in files for now
      !AC should change to special koral namelist
      namelist /harm/  dfile, hfile, nt, indf

      logical :: doingkoralnth,shortfile
      character(len=100) :: dfile, hfile
      integer :: nx1, nx2, nx3,n, ndumps, nt, indf, dlen, nhead
      integer :: nrelbin=0
      integer :: ndim=3
      integer :: minpolecell=2
      integer, dimension(:), allocatable :: dumps
      real :: tstep=20., h, r0, aa, bb, pp, asim, dx1, dx2, gam, startx1, startx2, toffset=0.
      real :: relgammamin=1., relgammamax=1.
      real(8) :: scalefac
      real, dimension(:), allocatable :: t
      real, dimension(:), allocatable :: x1_arr, x2_arr, x3_arr,r_arr, th_arr,ph_arr
      real, dimension(:), allocatable :: rho_arr, p_arr, Be_arr, u0_arr, vrl_arr, &
           vpl_arr, vtl_arr
      real, dimension(:,:), allocatable :: nth_arr
      real, dimension(:), allocatable :: b0_arr, br_arr, bth_arr, bph_arr

!      shortfile=.TRUE.

      interface init_koral3d_data
        module procedure init_koral3d_data
      end interface

      interface del_koral3d_data
        module procedure del_koral3d_data
      end interface

      interface initialize_koral3d_model
        module procedure initialize_koral3d_model
      end interface

      interface transformbl2mksh3
         module procedure transformbl2mksh3
      end interface

      interface transformmksh32bl
         module procedure transformmksh32bl
      end interface

      interface koral3d_vals
        module procedure koral3d_vals
      end interface

      contains

        ! transform Boyer-Lindquist theta coordinates to modified Kerr-Schild x2 at a corresponding array of r
        subroutine transformbl2mksh3(th,r,x2,h,a,b,p)

        real, intent(in), dimension(:) :: th,r
        real, intent(out), dimension(size(th)) :: x2
        real, intent(in) :: h,a,b,p

        x2=0.5*(1 + ((r**p)/(h*pi)) * (atan(tan(0.5*h*pi)*(1-2*th/pi))/((b-a)*(2**p)+(a-0.5)*(r**p))))
        end subroutine transformbl2mksh3

        ! transform modified Kerr-Schild x2 to Boyer-Lindquist theta at a corresponding array of r=r0+exp(x1)
        subroutine transformmksh32bl(x2,r,th,h,a,b,p)

        real, intent(in), dimension(:) :: x2,r
        real, intent(out), dimension(size(x2)) :: th
        real, intent(in) :: h,a,b,p

        th = 0.5*pi*(1 + tan(h*pi*(-0.5+x2+(1-2*x2)*(a+(2**p)*(b-a)/(r**p))))/tan(0.5*h*pi))
        !write(6,*) 'x2len: ', size(x2)
        end subroutine transformmksh32bl

        ! Interpolates KORAL data to input coordinates
        subroutine koral3d_vals(x0,a,rho,p,b,u,bmag,Be,nth,type)

        type (four_Vector), intent(in), dimension(:) :: x0
        real, intent(in) :: a
        integer, intent(in) :: type
        real(kind=8), dimension(size(x0)) :: done,nfac,pfac
        real, dimension(size(x0)) :: x3, x2,x1,zm,theta,fone, &
         vpl0,vrl0,vtl0,rd,td,pd,rttd,zr,dzero, &
         vr0,vth0,vph0,bth,dummy,tt,ttd,zt,zphi,zpp
        real, dimension(nx1) :: uniqx1,uniqr
        real, dimension(nx2) :: uniqx2
        real, dimension(nx3) :: uniqx3,uniqph
        real, dimension(size(x0),2**(ndim+1)) :: ppi,Bei,rhoi,vrli,vtli, &
             vpli,bri,bthi,bphi,b0i,u0i, nth_bini

        real, dimension(size(x0)) :: dth,thu,thl,thone,minph
        integer, dimension(size(x0)*2*(2**ndim)) :: indx
        integer, dimension(size(x0)) :: lx1,lx2,lx3,ux1,ux2,ux3,x1l,x1u,x2l,x2u, x3l,x3u, &
         one,tindx,lx2l,lx2u,ux2l,ux2u,lx3l,lx3u,ux3l,ux3u,low,high
        real :: x2mintrust, x2maxtrust,thmintrust,thmaxtrust
        integer :: npts,i,j,maxtindx,ie
        real, dimension(size(x0)) :: b1tmp,b2tmp,b3tmp,b4tmp,u1tmp,ntmp
        real, dimension(size(x0)), intent(out) :: rho,p,bmag,Be
        real, dimension(size(x0),nrelbin), intent(out) :: nth
        type (four_Vector), intent(out), dimension(size(x0)) :: u,b

        one=1
        dzero=0d0; done=1d0; fone=1

        !Get unique code coordinates x1,x2,x3
        uniqx2=x2_arr(1:nx2)
        uniqx1=x1_arr(1:nx2*(nx1-1)+1:nx2)
        uniqx3=x3_arr(1:nx2*(nx1-1)*nx3+1:nx2*nx1)

        !Get unique r,phi Boyer-Lindquist coordinates
        uniqr=r0+exp(uniqx1)
        uniqph=uniqx3
        !there is no uniqth because in mks3, theta grid is r dependent!

        !Transform to Kerr-Schild x1,x2,x3 coordinates
        npts=size(x0)
        theta=x0%data(3)
        zr=x0%data(2)
        zt=x0%data(1)
        tt=bl2ks(dble(zr),dble(zt),dble(a),1) - bl2ks(dble(zr(1)),0d0,dble(a),1)
        tt=-tt+1d-8

        zpp=x0%data(4)
        !!zphi=zpp
        !!zphi=mod(zphi,(2.*pi))

        !!  AC this is necessary for koral dumps that keep phi output in ks!!
        zphi=bl2ks(dble(zr), dble(zpp), dble(a))
        zphi=mod(zphi,(2.*pi))
        if(any(isnan(zphi))) then
           write(6,*) 'nan in zphi!'
        end if

        where(zphi.lt.0.)
            zphi=zphi+2.*pi
        endwhere
        where(zphi.gt.pi)
            zphi=zphi-2.*pi
        endwhere

        x1 = log(dble(zr)-r0)
        x3 = zphi
        call transformbl2mksh3(theta,zr,x2,h,aa,bb,pp)

        !Distance from current points to grid points
        lx1=floor((x1-uniqx1(1))/(uniqx1(nx1)-uniqx1(1))*(nx1-1))+1
        ux1=lx1+1
        lx1=merge(lx1,one,lx1.ge.1)
        ux1=merge(ux1,nx1,ux1.le.nx1)

        lx2=floor((x2-uniqx2(1))/(uniqx2(nx2)-uniqx2(1))*(nx2-1))+1
        ux2=lx2+1
        lx2=merge(lx2,one,lx2.ge.1)
        ux2=merge(ux2,nx2,ux2.le.nx2)

        lx3=floor((x3-uniqx3(1))/(uniqx3(nx3)-uniqx3(1))*(nx3-1))+1
        ux3=lx3+1
        !lx3=merge(lx3,one,lx3.ge.1)
        !ux3=merge(ux3,nx3,ux3.le.nx3)

        ! phi-distance
        ! periodic in phi
        minph=uniqph(lx3)
        ux3=merge(ux3,one,ux3.le.nx3)
        !where(ux3.gt.nx3)
        !    ux3=1
        !endwhere
        where(lx3.lt.1)
            lx3=nx3
            minph=uniqph(lx3)-2.*pi
        endwhere
        pd=(zphi-minph)/(uniqph(2)-uniqph(1))

        ! r-distance
        rd=(zr-uniqr(lx1))/(uniqr(ux1)-uniqr(lx1))

        ! When the geodesic is inside the innermost zone center located outside the horizon,
        ! use nearest neighbor rather than interpolate
        where((uniqr(lx1).le.(1.+sqrt(1.-a**2.))).or.(lx1.eq.1))
           rd=1.
           pfac=1e-3
           nfac=1e-3
        elsewhere
           pfac=1.
           nfac=1.
        endwhere

        ! theta-distance
        ! Deal with poles
        !AC for interpolation, choose rl for theta distance?
        call transformmksh32bl(uniqx2(lx2),uniqr(lx1),thl,h,aa,bb,pp)
        call transformmksh32bl(uniqx2(ux2),uniqr(lx1),thu,h,aa,bb,pp)
        call transformmksh32bl(uniqx2(one),uniqr(lx1),thone,h,aa,bb,pp)

        where(ux2.ne.lx2)
           td=abs((theta-thl)/(thu-thl))
        elsewhere
           td=abs((theta-thl)/thone)
        endwhere

        ! Indices for nearest neighbors in 3D
        ! th is fastest changing index
        x2l=lx2-1;
        x2u=ux2-1
        x1l=(lx1-1)*nx2 ;
        x1u=(ux1-1)*nx2
        x3l=(lx3-1)*nx2*nx1;
        x3u=(ux3-1)*nx2*nx1

        ! Now find timestep indices:
        maxtindx=nt-2
        where(floor(tt/tstep).le.maxtindx)
           tindx=floor(tt/tstep)
           ttd=(tt-tindx*tstep)/tstep
        elsewhere
           tindx=maxtindx+1
           ttd=0.
        endwhere

        ! Create index array across times and 3D nearest neighbors (first half at first time, second half at second time):
        ! Need to make sure there aren't integer problems when these indices get very large
        indx=(/(/x1l+x2l+x3l+1+n*tindx/),(/x1l+x2u+x3l+1+n*tindx/),(/x1u+x2l+x3l+1+n*tindx/), &
            (/x1u+x2u+x3l+1+n*tindx/),(/x1l+x2l+x3u+1+n*tindx/), &
            (/x1l+x2u+x3u+1+n*tindx/),(/x1u+x2l+x3u+1+n*tindx/),(/x1u+x2u+x3u+1+n*tindx/), &
            (/x1l+x2l+x3l+1+n*(tindx+1)/),(/x1l+x2u+x3l+1+n*(tindx+1)/),(/x1u+x2l+x3l+1+n*(tindx+1)/), &
            (/x1u+x2u+x3l+1+n*(tindx+1)/),(/x1l+x2l+x3u+1+n*(tindx+1)/),(/x1l+x2u+x3u+1+n*(tindx+1)/), &
            (/x1u+x2l+x3u+1+n*(tindx+1)/),(/x1u+x2u+x3u+1+n*(tindx+1)/)/)

        ! keep indx from going out of bounds when loading one time slice
        where(indx.gt.size(rho_arr))
           indx=indx-n
        endwhere

        rhoi=reshape(rho_arr(indx),(/npts,2**(ndim+1)/))
        vrli=reshape(vrl_arr(indx),(/npts,2**(ndim+1)/))
        vtli=reshape(vtl_arr(indx),(/npts,2**(ndim+1)/))
        vpli=reshape(vpl_arr(indx),(/npts,2**(ndim+1)/))
        ppi=reshape(p_arr(indx),(/npts,2**(ndim+1)/))
        Bei=reshape(Be_arr(indx),(/npts,2**(ndim+1)/))
        b0i=reshape(b0_arr(indx),(/npts,2**(ndim+1)/))
        bri=reshape(br_arr(indx),(/npts,2**(ndim+1)/))
        bthi=reshape(bth_arr(indx),(/npts,2**(ndim+1)/))
        bphi=reshape(bph_arr(indx),(/npts,2**(ndim+1)/))
        u0i=reshape(u0_arr(indx),(/npts,2**(ndim+1)/))

        !interpolate data
        rttd=0.
        rho=interp(rhoi,rttd,pd,rd,td)
        p=interp(ppi,rttd,pd,rd,td)
        Be=interp(Bei,rttd,pd,rd,td)
        vrl0=interp(vrli,rttd,pd,rd,td)
        vtl0=interp(vtli,rttd,pd,rd,td)
        b1tmp=interp(b0i,rttd,pd,rd,td)
        b2tmp=interp(bri,rttd,pd,rd,td)
        b3tmp=interp(bthi,rttd,pd,rd,td)
        b4tmp=interp(bphi,rttd,pd,rd,td)
        u1tmp=interp(u0i,rttd,pd,rd,td)
        vpl0=interp(vpli,rttd,pd,rd,td)

        !mask data outside trusted region
        rho=merge(rho,dzero,x1.gt.uniqx1(1))*nfac
        p=merge(p,fone,x1.gt.uniqx1(1))*pfac
        Be=merge(Be,dzero,x1.gt.uniqx1(1)) !AC -- does using zero make sense?
        vrl0=merge(vrl0,dzero,x1.gt.uniqx1(1))
        vtl0=merge(vtl0,fone,x1.gt.uniqx1(1))
        b1tmp=merge(b1tmp,fone,x1.gt.uniqx1(1))
        b2tmp=merge(b2tmp,fone,x1.gt.uniqx1(1))
        b3tmp=merge(b3tmp,fone,x1.gt.uniqx1(1))
        b4tmp=merge(b4tmp,fone,x1.gt.uniqx1(1))
        u1tmp=merge(dble(u1tmp),done,x1.gt.uniqx1(1))
        vpl0=merge(vpl0,dzero,x1.gt.uniqx1(1))

        !AC TODO !!!! minimum polar cell - change!
        !AC this is the minimum polar coordinate x2 we trust.
        x2mintrust = uniqx2(minpolecell)
        x2maxtrust = uniqx2(size(uniqx2)-(minpolecell-1))
        thmintrust = 0.
        thmaxtrust = pi

        !cut out 15 degrees away from poles for disk (also cut out high Be in fluid.f90)
        if (type.eq.1) then
           thmintrust = 0.25
           thmaxtrust = pi - 0.25

        !cut out background entirely -- all theta > pi/2 !AC -- assumes symmetric grid!!
        else if(type.eq.2) then
           thmaxtrust = 0.5*pi!0.25*pi.   !uniqx2(int(size(uniqx2)/2)-2)

        !cut out foreground entirely -- all theta > pi/2 !AC -- assumes symmetric grid!!
        else if(type.eq.3) then
           thmintrust = 0.5*pi!0.75*pi. !uniqx2(int(size(uniqx2)/2)+2)
        end if

        !theta based cuts for jet
        if((type.eq.1).or.(type.eq.2).or.(type.eq.3)) then
            rho=merge(rho,dzero,(theta.gt.thmintrust).and.(theta.lt.thmaxtrust))
            p=merge(p,fone,(theta.gt.thmintrust).and.(theta.lt.thmaxtrust))
            Be=merge(Be,dzero,(theta.gt.thmintrust).and.(theta.lt.thmaxtrust))!AC -- does using zero make sense?
            vrl0=merge(vrl0,dzero,(theta.gt.thmintrust).and.(theta.lt.thmaxtrust))
            vtl0=merge(vtl0,fone,(theta.gt.thmintrust).and.(theta.lt.thmaxtrust))
            b1tmp=merge(b1tmp,fone,(theta.gt.thmintrust).and.(theta.lt.thmaxtrust))
            b2tmp=merge(b2tmp,fone,(theta.gt.thmintrust).and.(theta.lt.thmaxtrust))
            b3tmp=merge(b3tmp,fone,(theta.gt.thmintrust).and.(theta.lt.thmaxtrust))
            b4tmp=merge(b4tmp,fone,(theta.gt.thmintrust).and.(theta.lt.thmaxtrust))
            u1tmp=merge(dble(u1tmp),done,(theta.gt.thmintrust).and.(theta.lt.thmaxtrust))
            vpl0=merge(vpl0,dzero,(theta.gt.thmintrust).and.(theta.lt.thmaxtrust))
        end if

        !x2 based cuts for polar axis
        rho=merge(rho,dzero,(x2.gt.x2mintrust).and.(x2.lt.x2maxtrust))
        p=merge(p,fone,(x2.gt.x2mintrust).and.(x2.lt.x2maxtrust))
        Be=merge(Be,dzero,(x2.gt.x2mintrust).and.(x2.lt.x2maxtrust)) !AC -- does using zero make sense?
        vrl0=merge(vrl0,dzero,(x2.gt.x2mintrust).and.(x2.lt.x2maxtrust))
        vtl0=merge(vtl0,fone,(x2.gt.x2mintrust).and.(x2.lt.x2maxtrust))
        b%data(1)=merge(b1tmp,fone,(x2.gt.x2mintrust).and.(x2.lt.x2maxtrust))
        b%data(2)=merge(b2tmp,fone,(x2.gt.x2mintrust).and.(x2.lt.x2maxtrust))
        b%data(3)=merge(b3tmp,fone,(x2.gt.x2mintrust).and.(x2.lt.x2maxtrust))
        b%data(4)=merge(b4tmp,fone,(x2.gt.x2mintrust).and.(x2.lt.x2maxtrust))
        u%data(1)=merge(dble(u1tmp),done,(x2.gt.x2mintrust).and.(x2.lt.x2maxtrust))
        vpl0=merge(vpl0,dzero,(x2.gt.x2mintrust).and.(x2.lt.x2maxtrust))

        !AC load nonthermal
        !AC do we have to do this in a loop?
        if(doingkoralnth) then
           do ie=1, nrelbin
              nth_bini=reshape(nth_arr(indx,ie),(/npts,2**(ndim+1)/))
              ntmp=interp(nth_bini,rttd,rd,td)
              ntmp=merge(ntmp,dzero,x1.gt.uniqx1(1))
              nth(:,ie)=merge(ntmp,dzero,x2.gt.x2mintrust)
           end do
        end if

        ! Compute magnitude of interpolated b-field and force b^2 > 0 (need to look into numerical issues here):
        call assign_metric(b,transpose(kerr_metric(zr, real(x0%data(3)),a)))
        bmag=b*b; bmag=merge(bmag,dzero,bmag.ge.0d0)
        bmag=sqrt(bmag)

        ! Protect azimuthal velocities at poles
        call lnrf_frame(vrl0,vtl0,vpl0,zr,a,real(x0%data(3)),vr0,vth0,vph0,1)
        u%data(2)=u%data(1)*dble(vr0)
        u%data(3)=u%data(1)*dble(vth0)
        u%data(4)=u%data(1)*dble(vph0)
        call assign_metric(u,transpose(kerr_metric(zr,real(x0%data(3)) ,a)))

        end subroutine koral3d_vals

        ! Read inputs from file
        !AC koral will share the harm input file structure for now
        subroutine read_koral3d_inputs(ifile)
        character(len=20), intent(in) :: ifile
        open(unit=8,file=ifile,form='formatted',status='old')
        read(8,nml=harm)
        write(6,*) 'read: ',nt
        close(unit=8)
        end subroutine read_koral3d_inputs

        ! Read header values
        subroutine read_koral3d_data_header(nhead)
        integer, intent(in) :: nhead
        real(8), dimension(nhead) :: header
        real(8), dimension(3) :: header2
        real(8) :: tcur

        write(6,*) 'read header: ', nhead
        open(unit=8,file=hfile,form='formatted',status='old')
        read(8,*) header

        tcur=header(1)
        nx1=header(2)
        nx2=header(3)
        nx3=header(4)
        asim=header(5)
        !mbh=header(6)
        r0=header(7)
        h=header(8)
        aa=header(9)
        bb=header(10)
        pp=header(11)

        !AC nonthermal
        if(doingkoralnth) then
           read(8,*) header2
           nrelbin=header2(1)
           relgammamin=header2(2)
           relgammamax=header2(3)
           write(6,*) 'read nth header vals ', nrelbin, relgammamin, relgammamax

        end if

        write(6,*) 'read header vals: ', asim, r0, h, aa, bb, pp
        close(unit=8)
        end subroutine read_koral3d_data_header

        !Read text files with  data values
        !AC TODO can we read binary data files instead???
        subroutine read_koral3d_data_file(data_file,tcur,rho,p,u,b,Be,nnth)
        character(len=100), intent(in) :: data_file
        integer :: nhead, nhead2, dlen
        integer :: rhopos,ppos,Bepos,vpos,bpos,gdetpos,gridpos,nthpos
        real(8), intent(out) :: tcur
        real(8), dimension(:), allocatable, intent(out) :: p,rho,Be
        real(8), dimension(:,:), allocatable, intent(out) :: nnth
        real(8), dimension(:), allocatable :: gdet, header, header2
        type (four_vector), dimension(:), allocatable, intent(out) :: u,b
        real(8), dimension(:,:), allocatable :: grid, data, tmetric
        integer :: i, nelem

        shortfile = .FALSE.

          !AC TODO still need to change these positions for 3d sim files!!
          if(nrelbin>0) then
             dlen=41+nrelbin;
          else
             dlen = 38
          endif

          if(shortfile) dlen = 23

          nhead=11; nhead2=3
          allocate(header(nhead))
          allocate(header2(nhead2))

          ! M87 library vs. Andrew format difference
          ! FOR SHORTFILE BE IS THE ION TEMPERATURE TO RECONSTRUCT P FOR POST-PROCESSING
          if(shortfile) then
             rhopos=10; vpos=12; bpos=16; ppos=21; gridpos=4; Bepos=22
          else
             rhopos=10; Bepos=32; ppos=33; vpos=12; bpos=25; gdetpos=16; gridpos=4; nthpos=43 !AC: is nthpos correct?? change for 3D?
          endif

          write(6,*) 'dfile: ',dfile
          write(6,*) 'data file: ',data_file
          open(unit=8,file=data_file,form='formatted',status='old',action='read')

          allocate(data(dlen,nx2)); nelem=nx2 !x2 is the fastest changing index
          allocate(grid(nx1*nx2*nx3,6));      !AC (x1,x2,x3,r,theta,phi)
          allocate(p(nx1*nx2*nx3)); allocate(rho(nx1*nx2*nx3)); allocate(Be(nx1*nx2*nx3))
          allocate(u(nx1*nx2*nx3)); allocate(b(nx1*nx2*nx3)); allocate(gdet(nx1*nx2*nx3))
          allocate(nnth(nx1*nx2*nx3, nrelbin));

          write(6,*) 'read koral sizes', dlen, nx1, nx2, nx3, size(data)
          read(8,*) header
          tcur=header(1)

          if(doingkoralnth) then
             read(8,*) header2
          end if

          deallocate(header)
          deallocate(header2)

          write(6,*) 'read koral past header: ', nx1, nx2, nx3, nelem, dlen

          !AC read the data
          do i=0, (nx1*nx2*nx3)/nelem-1
             read(8,*) data
             rho(1+i*nelem:(i+1)*nelem)=data(rhopos,:)
!             if(.not.shortfile) Be(1+i*nelem:(i+1)*nelem)=data(Bepos,:)
             Be(1+i*nelem:(i+1)*nelem)=data(Bepos,:)
             p(1+i*nelem:(i+1)*nelem)=data(ppos,:) !AC p is actually Te

             b(1+i*nelem:(i+1)*nelem)%data(1)=(data(bpos,:))
             b(1+i*nelem:(i+1)*nelem)%data(2)=(data(bpos+1,:))
             b(1+i*nelem:(i+1)*nelem)%data(3)=(data(bpos+2,:))
             b(1+i*nelem:(i+1)*nelem)%data(4)=(data(bpos+3,:))

             u(1+i*nelem:(i+1)*nelem)%data(1)=(data(vpos,:))
             u(1+i*nelem:(i+1)*nelem)%data(2)=(data(vpos+1,:))
             u(1+i*nelem:(i+1)*nelem)%data(3)=(data(vpos+2,:))
             u(1+i*nelem:(i+1)*nelem)%data(4)=(data(vpos+3,:))

             !AC grid is x1,x2,r,theta
             grid(1+i*nelem:(i+1)*nelem,:)=transpose(data(gridpos:gridpos+5,:))
             gdet(1+i*nelem:(i+1)*nelem)=(data(gdetpos,:))

             if(doingkoralnth) then
                nnth(1+i*nelem:(i+1)*nelem, : ) = transpose(data(nthpos:nthpos+nrelbin-1, : ))
             endif

          end do
          write(6,*) 'after read loop'
          close(unit=8)
          deallocate(data)
          x1_arr=grid(:,1)
          x2_arr=grid(:,2)
          x3_arr=grid(:,3)
          r_arr=grid(:,4)
          th_arr=grid(:,5)
          ph_arr=grid(:,6)
          write(6,*) 'read koral assign grid'
          deallocate(grid)

          ! Transform velocities, magnetic fields from MKS to KS and then BL:
          if(doingkoralnth) then
             write(6,*) 'read koral nnth 1 ', minval(nnth(:,1)), maxval(nnth(:,1))
          endif
          write(6,*) 'read koral grid sizes', size(x1_arr), size(x2_arr), size(x3_arr), size(r_arr), size(th_arr), size(ph_arr)
          write(6,*) 'read koral Te ', minval(p), maxval(p)
          write(6,*) 'read koral Be ', minval(Be), maxval(Be)
          write(6,*) 'read koral gdet ', minval(gdet), maxval(gdet)
          write(6,*) 'read koral rho ', minval(rho), maxval(rho)
          write(6,*) 'read koral b0', minval(b%data(1)), maxval(b%data(1))
          write(6,*) 'read koral u0 ', minval(u%data(1)), maxval(u%data(1))

          write(6,*) 'read koral transform coords r ', minval(r_arr), maxval(r_arr), asim
          write(6,*) 'read koral transform coords theta  ', minval(th_arr), maxval(th_arr), asim
          write(6,*) 'read koral transform coords phi',minval(x3_arr), maxval(x3_arr)

          write(6,*) 'WARNING: ignoring minpolecell=',minpolecell, ' cells on polar axis!!'

          deallocate(gdet)
        end subroutine read_koral3d_data_file

        subroutine initialize_koral3d_model(a,ifile,doingnth,df,hf,ntt,indft,sfac,nrelbin_bk,relgammamin_bk,relgammamax_bk)
        real(kind=8), intent(in) :: a
        integer,intent(out),optional :: nrelbin_bk
        real,intent(out),optional :: relgammamin_bk, relgammamax_bk
        integer :: nx, status, nhead
        logical, intent(in) :: doingnth
        real(8),intent(in),optional :: sfac
        character(len=20), intent(in), optional :: ifile
        character(len=20) :: default_ifile='koral.in' !AC
        character(len=100), intent(in), optional :: df,hf
        integer, intent(in), optional :: ntt,indft
        nhead=11

        doingkoralnth = doingnth

        ! if all inputs are given, assign variables rather than reading from file
        if (present(df)) then
           dfile = df
           hfile = hf
           nt = ntt
           indf = indft
        else
           if (present(ifile)) then
              call read_koral3d_inputs(ifile)
           else
              call read_koral3d_inputs(default_ifile)
           endif
        endif

        if (present(sfac)) then
            scalefac=sfac
        else
            scalefac=1.
        endif

        call read_koral3d_data_header(nhead)

        nrelbin_bk = nrelbin
        relgammamin_bk = relgammamin
        relgammamax_bk = relgammamax

        if (abs(asim-a).gt.1e-4) then
           write(6,*) 'ERROR -- Different simulation and grtrans spin values!'
           return
        endif
        n=nx1*nx2*nx3
        call init_koral3d_data(n,n*nt)
        call load_koral3d_data(nt)
        write(6,*) 'nrelbin',nrelbin
        end subroutine initialize_koral3d_model

        !Read data from file and then transfer to global arrays
        subroutine load_koral3d_data(nt)
        real(8), dimension(:), allocatable :: rho,p,Be
        real(8), dimension(:,:), allocatable :: nnth
        real, dimension(:), allocatable :: vrl, vtl, vpl
        type (four_vector), dimension(:), allocatable :: u, b
        integer, intent(in) :: nt
        character(len=250) :: append
        character(len=100) :: data_file
        integer :: k
        real(8) :: tcur, tstep_test

        allocate(nnth(n,nrelbin))
        allocate(rho(n)); allocate(p(n)); allocate(Be(n))
        allocate(vrl(n)); allocate(vtl(n)); allocate(vpl(n))
        allocate(u(n)); allocate(b(n))
        do k=1,nt
           !read data from  file
           write(append, fmt='(I4.4)') indf-(k-1)
           data_file = trim(dfile) // append
           call read_koral3d_data_file(data_file,tcur,rho,p,u,b,Be,nnth)
           t(k)=tcur

           ! transform velocities to LNRF frame
           call lnrf_frame(real(u%data(2)/u%data(1)),real(u%data(3)/u%data(1)), &
                           real(u%data(4)/u%data(1)), &
                           r_arr,asim,th_arr,vrl,vtl,vpl)
           write(6,*) 'lnrf transform', size(b0_arr), size(b%data(1)), size(b0_arr((k-1)*n+1:k*n))
           write(6,*) 'lnrf transform', size(vrl), size(vtl), size(vpl), size(u0_arr), size(nth_arr(:,1))

           ! now assign to data arrays
           write(6,*) scalefac, sqrt(scalefac)
           rho_arr((k-1)*n+1:k*n)=rho*scalefac
           p_arr((k-1)*n+1:k*n)=p !AC p_arr is actually the ELECTRON TEMPERATURE straight from koral -- no scale fac!
           Be_arr((k-1)*n+1:k*n)=Be
           b0_arr((k-1)*n+1:k*n)=b%data(1)*sqrt(scalefac)
           br_arr((k-1)*n+1:k*n)=b%data(2)*sqrt(scalefac)
           bth_arr((k-1)*n+1:k*n)=b%data(3)*sqrt(scalefac)
           bph_arr((k-1)*n+1:k*n)=b%data(4)*sqrt(scalefac)
           u0_arr((k-1)*n+1:k*n)=u%data(1)
           vrl_arr((k-1)*n+1:k*n)=real(vrl)
           vpl_arr((k-1)*n+1:k*n)=real(vpl)
           vtl_arr((k-1)*n+1:k*n)=real(vtl)

           if(doingkoralnth) then
              nth_arr((k-1)*n+1:k*n, :) = nnth*scalefac;
           endif
        end do

        ! Need to be able to do light curves even when nload (nt) = 1... Maybe read headers for first two files.
        if (nt.gt.1) then
           ! use default sim time step unless told otherwise
           tstep=t(1)-t(2)
           tstep_test=t(nt-1)-t(nt)
           if (abs((tstep-tstep_test)/tstep).gt.0.1) then
              write(6,*) 'WARNING -- Time step changes over dumps!'
           endif
        endif

        deallocate(rho)
        deallocate(p)
        deallocate(Be)
        deallocate(vrl); deallocate(vtl); deallocate(vpl)
        deallocate(u); deallocate(b)
        deallocate(nnth)
        end subroutine  load_koral3d_data

        ! Advance to next timestep file
        subroutine advance_koral3d_timestep(dtobs)
        real(8), intent(in) :: dtobs
        integer :: nupdate
        nupdate = floor(dtobs / tstep)
        toffset = toffset+dtobs-tstep*nupdate
        nupdate=nupdate+floor(toffset/tstep)
        toffset=toffset-floor(toffset/tstep)*tstep
        indf=indf+nupdate
        write(6,*) 'advance koral timestep: ',dtobs,tstep,toffset,indf,nupdate !AC
        call update_koral3d_data(nupdate)
        end subroutine advance_koral3d_timestep

        subroutine update_koral3d_data(nupdate)
        integer, intent(in) :: nupdate
        integer :: nshift
        if(nupdate.gt.nt) then ! this is case where we just load all new data
           call load_koral3d_data(nt)
        else ! this is case where we shift existing data back and then load more
           nshift=n*nupdate+1
           rho_arr(nshift:n*nt)=rho_arr(1:n*nt-nshift)
           p_arr(nshift:n*nt)=p_arr(1:n*nt-nshift)
           Be_arr(nshift:n*nt)=Be_arr(1:n*nt-nshift)
           br_arr(nshift:n*nt)=br_arr(1:n*nt-nshift)
           bth_arr(nshift:n*nt)=bth_arr(1:n*nt-nshift)
           bph_arr(nshift:n*nt)=bph_arr(1:n*nt-nshift)
           b0_arr(nshift:n*nt)=b0_arr(1:n*nt-nshift)
           vrl_arr(nshift:n*nt)=vrl_arr(1:n*nt-nshift)
           vtl_arr(nshift:n*nt)=vtl_arr(1:n*nt-nshift)
           vpl_arr(nshift:n*nt)=vpl_arr(1:n*nt-nshift)
           if(doingkoralnth) then
              nth_arr(nshift:n*nt,:)=nth_arr(1:n*nt-nshift,:)
           endif
           call load_koral3d_data(nupdate)
        end if
        end subroutine update_koral3d_data

        ! allocate arrays
        subroutine init_koral3d_data(nx,n)
          integer, intent(in) :: n,nx
          integer :: i
          real :: logbinspace, binspace
        allocate(rho_arr(n)); allocate(p_arr(n)); allocate(Be_arr(n)); allocate(u0_arr(n))
        allocate(vrl_arr(n)); allocate(vtl_arr(n)); allocate(vpl_arr(n))
        allocate(b0_arr(n)); allocate(br_arr(n)); allocate(bth_arr(n))
        allocate(bph_arr(n))
        allocate(x1_arr(nx)); allocate(x2_arr(nx));
        allocate(r_arr(nx)); allocate(th_arr(nx));
        allocate(x3_arr(nx)); allocate(ph_arr(nx));
        allocate(t(nt))
        if(doingkoralnth) then
           allocate(nth_arr(n,nrelbin))
        end if

        end subroutine init_koral3d_data

        ! deallocate arrays
        subroutine del_koral3d_data()
        deallocate(rho_arr); deallocate(p_arr); deallocate(Be_arr); deallocate(u0_arr)
        deallocate(vrl_arr); deallocate(vtl_arr); deallocate(vpl_arr)
        deallocate(b0_arr); deallocate(br_arr); deallocate(bth_arr)
        deallocate(bph_arr); deallocate(x1_arr); deallocate(x2_arr)
        deallocate(x3_arr); deallocate(ph_arr);
        deallocate(r_arr); deallocate(th_arr); deallocate(t)
        if(doingkoralnth) then
           deallocate(nth_arr)
        end if
        end subroutine del_koral3d_data

      end module fluid_model_koral3d


    subroutine bio_frac
!   *******************
    implicit none
    include 'combine_foam.inc'

!       variable Ep (Kump and Arthur, 1999) (steawal3 file):
    do j=1,nbasin-1
        epsiC(j)=1e-3*(12.03*dlog10(1e3*h2co3(j))+1.19)
!        epsiC(j)=25.-((159.5*var(3,j)+38.39)/h2co3(j))
!       (Berner et al, 2000)
!        epsiC(j)=epsiC(j)/1000.+3.*((var(11,nbasin)/1.)-1)/1000.
!      constant fractionation
!        epsiC(j)=0.012
!        epsiC(j)=epsiC(j)/1.d+3
    enddo

    epsiCont=0.025

    return
    end


program matdrv
    use param
    use mathieu

    implicit none
    integer   ndec, i, j, k, l, nex, kindd, kindq, icq, isq, minacc, narg, &
              lnum, izxi, ioprad, iopang, max, maxd, maxj, maxk, maxn, maxp, &
              maxterm, maxbp, maxkbp, maxlp, ismax
    real(knd) cm, q, arg1, darg, r, x1, z, xi

    real(knd), dimension(:), allocatable ::     arg
    real(knd), dimension(:), allocatable ::     mc1c, mc1dc, mc23c, mc23dc, &
                                                ms1c, ms1dc, ms23c, ms23dc
    integer, dimension(:), allocatable ::       mc1e, mc1de, mc23e, mc23de, &
                                                ms1e, ms1de, ms23e, ms23de, &
                                                acc_rc, acc_rs
    integer, dimension(:,:), allocatable ::     acc_acs
    real(knd), dimension (:,:), allocatable ::  ce, ced, se, sed
    character (len = 9) kstr, fstr, astr
    character (len = 256) tstr

    kindd = 8
    kindq = 16

    if(knd == kindd) then
        kstr = "e23.14"
        fstr = "f17.14"
    else if (knd == kindq) then
        kstr = "e39.30"
        fstr = "f17.14"   ! normally "f33.30"
    end if
    astr = "e23.14"

    ndec = precision(cm)
    nex = range(cm) - 1

!   open input and output files
    open(1, file='matfcn.dat')
    open(20 ,file='fort.20')
    open(30, file='fort.30')
    open(40 ,file='fort.20')
    open(50, file='fort.30')
    open(60, file='fort.30')

    read(1, *) lnum, ioprad, iopang, izxi, icq, isq

    if (icq == 1) read(1,*) q
    if (icq == 2) read(1,*) cm
    read(1, *) r
    if (iopang /= 0) read(1, *) arg1, darg, narg

    select case (icq)
    case (1)
        cm = sqrt(2.0e0_knd * abs(q))
        if (q < 0.0e0_knd) isq = -1
    case (2)
          q = cm * cm / 2.0e0_knd
          if (isq == -1) q = -q
    end select

    select case (izxi)
    case (1)
          x1 = 2.0e0_knd * (sinh(0.5e0_knd * z)) ** 2
          z = r
    case (2)
          x1 = r
          z = 0.0e0_knd
    end select
    if(iopang  ==  0) narg = 1

    maxj = 1
    if(ioprad /= 0) maxj = 1.5 * lnum + 4 * ndec + int(cm) + 105

    if(isq == 1) then
        ismax = int(0.85e0_knd * cm)
        if(x1 < 1.0e0_knd) ismax = 1.5 * ismax
        if(x1 < 0.1e0_knd .and. x1 >= 0.00001e0_knd) &
            ismax = ismax * int(3.0e0_knd ** (-1.0e0_knd - log10(x1)))
        if(x1 < 0.00001e0_knd) ismax = 81 * ismax

        maxj = max(maxj, ismax + int(cm / 3.14159 )+ 4 * ndec + int(cm) + 105)
    end if

    maxp = 2 * lnum + 2 * cm + 4 * ndec + 105
    maxn = maxj
    maxk = 1
    maxkbp = 1

    if (ioprad /= 0 .and. isq /= 1 .and. x1 /= 0.0e0_knd) then
        maxkbp = lnum + 4 * ndec + int(cm) + 103
        if(minacc > ndec - 2 .or. (minacc > ndec - 4 .and. cm >  5.0e0_knd) &
                             .or. (minacc > ndec - 6 .and. cm > 10.0e0_knd) &
                             .or. (minacc > ndec - 8 .and. cm > 15.0e0_knd) &
                             .or. cm > 20e0_knd) then
            maxk = 1.5 * cm + 100
            if(x1 < 1.0e0_knd .and. x1 >= 0.01e0_knd) &
                maxk = 40 / x1 + cm / sqrt(x1) + 1.5 * cm + 200
            if(x1 < 0.01e0_knd.and.x1 > 0.0e0_knd) &
                maxk = 34 / x1 + 1.5 * cm + 1.4 * cm / sqrt(x1) + 200
            maxterm = 10000000
            maxk = min(maxk, maxterm)
            maxk = max(maxk, maxj)
        end if
    end if

    maxd = max(maxj, maxn, maxk, maxkbp, maxp) / 2 + 1

    maxlp = lnum + 3
    if(isq == -1) maxlp = max(maxlp, ismax + int(cm /3.14159) + 3)

    xi = x1 + 1.0e0_knd

    if(ioprad /= 0 .and. izxi == 1) write(20, "(1x,' z = '," // kstr // ")") z

    if(ioprad /= 0 .and. izxi == 2) write(20, "(1x,'xi = '," // kstr // ")") xi

    if(icq == 1) then
        if (ioprad /= 0) write(20, "(1x,' q = '," // kstr // ")") q
        if (iopang /= 0) write(30, "(1x,' q = '," // kstr // ")") q
    end if

    if(icq == 2) then
        if (ioprad /= 0) then
            if (isq == 1)  write(20, "(1x,' c = '," // kstr // ")") cm
            if (isq == -1) write(20, "(1x,' c = i times'," // kstr // ")") cm
        end if
        if (iopang /= 0) then
            if (isq == 1)  write(30, "(1x,' c = '," // kstr // ")") cm
            if (isq == -1) write(30, "(1x,' c = i times'," // kstr // ")") cm
        end if
    end if

    allocate (arg(narg), acc_rc(lnum), acc_rs(lnum), acc_acs(lnum, narg))
    allocate (mc1c(lnum),mc1dc(lnum),mc23c(lnum),mc23dc(lnum), &
              ms1c(lnum),ms1dc(lnum),ms23c(lnum),ms23dc(lnum))
    allocate (mc1e(lnum),mc1de(lnum),mc23e(lnum),mc23de(lnum), &
              ms1e(lnum),ms1de(lnum),ms23e(lnum),ms23de(lnum))
    allocate (ce(lnum,narg),ced(lnum,narg), &
              se(lnum,narg),sed(lnum,narg))

    if(iopang /= 0) then
        do j = 1, narg
            arg(j) = arg1 + (j - 1) * darg
        end do
    end if

    call matfcn(lnum, ioprad, izxi, icq, isq, cm, r, iopang, narg, arg, &
                mc1c, mc1e, mc1dc, mc1de, mc23c, mc23e, mc23dc, mc23de, acc_rc, &
                ms1c, ms1e, ms1dc, ms1de, ms23c, ms23e, ms23dc, ms23de, acc_rs, &
                ce, ced, se, sed, acc_acs)

    do i = 1, lnum
        l = i - 1

        if(iopang  /=  0) write(30, 70) l
70      format(1x,'l = ',i6)

        if(isq /= -1) then
            tstr = "(1x,i5,2x,4(" // fstr // ",i6,2x), i2)"
            write(20, tstr) l,mc1c(i),mc1e(i),mc1dc(i),mc1de(i),mc23c(i),mc23e(i),mc23dc(i),mc23de(i),acc_rc(i)
            tstr = "(8x,4(" // fstr // ",i6,2x), i2)"
            if(l > 0) write(20, tstr) ms1c(i),ms1e(i),ms1dc(i),ms1de(i),ms23c(i),ms23e(i),ms23dc(i),ms23de(i),acc_rs(i)
        else
            tstr = "(1x,i5,2x,4(" // fstr // ",i7,2x), i2)"
            write(20, tstr) l,mc1c(i),mc1e(i),mc1dc(i),mc1de(i),mc23c(i),mc23e(i),mc23dc(i),mc23de(i),acc_rc(i)
            tstr = "(8x,4(" // fstr // ",i7,2x), i2)"
            if(l > 0) write(20, tstr) ms1c(i),ms1e(i),ms1dc(i),ms1de(i),ms23c(i),ms23e(i),ms23dc(i),ms23de(i),acc_rs(i)
        end if

       do k = 1,narg
            if(iopang == 1) then
                tstr = "(4x," // fstr // ",5x," // astr // ",2x," // astr // ",2x,i2)"
                write(30, tstr) arg(k),ce(i,k),se(i,k), acc_acs(i,k)
            else if(iopang == 2) then
                tstr = "(4x," // fstr // ",5x," // astr // ",2x," // astr // ",2x,/,26x," // astr // ",2x," // astr // ",2x,i2)"
                write(30, tstr) arg(k),ce(i,k),ced(i,k),se(i,k),sed(i,k), acc_acs(i,k)
            endif
        end do
    end do

    deallocate (mc1c,mc1dc,mc23c,mc23dc,ms1c,ms1dc,ms23c,ms23dc)
    deallocate (mc1e,mc1de,mc23e,mc23de,ms1e,ms1de,ms23e,ms23de)
    deallocate (ce,ced,se,sed)
    deallocate (acc_rc, acc_rs, acc_acs)
    close(60)
    close(50)
    close(40)
    close(30)
    close(20)
    close(1)

end program matdrv


*     SB02SD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDG, LDQ, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, LDT = NMAX,
     $                   LDU = NMAX, LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 8*NMAX*NMAX + 10*NMAX )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCND, RCOND, SEPD
      INTEGER          I, INFO1, INFO2, INFO3, IS, IU, IW, J, N, N2,
     $                 SDIM
      CHARACTER*1      FACT, JOB, JOBS, LYAPUN, TRANA, TRANAT, UPLO
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), AS(LDA,NMAX), DWORK(LDWORK),
     $                 G(LDG,NMAX), Q(LDQ,NMAX), T(LDT,NMAX),
     $                 U(LDU,NMAX), X(LDX,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME, SELECT
      EXTERNAL         LSAME, SELECT
*     .. External Subroutines ..
      EXTERNAL         DGEES, DGESV, DLACPY, DLASET, DSWAP, DSYMM,
     $                 MA02AD, MA02ED, MB01RU, SB02MD, SB02SD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'Full', N, N, A, LDA, AS, LDA )
         CALL DLACPY( UPLO, N, N, Q, LDQ, X, LDX )
         N2 = 2*N
         IS = 2*N2 + 1
         IU = IS + N2*N2
         IW = IU + N2*N2
*        Solve the discrete-time Riccati equation.
         CALL SB02MD( 'discrete', 'direct', UPLO, 'no scaling',
     $                'stable', N, AS, LDA, G, LDG, X, LDX, RCND,
     $                DWORK(1), DWORK(N2+1), DWORK(IS), N2, DWORK(IU),
     $                N2, IWORK, DWORK(IW), LDWORK-IW+1, BWORK, INFO1 )
*
         IF ( INFO1.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99995 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N )
   10       CONTINUE
            IF ( LSAME( FACT, 'F' ) .OR. LSAME( LYAPUN, 'R' ) ) THEN
               CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK, N )
               CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX,
     $                     ONE, DWORK, N )
               IF ( LSAME( TRANA, 'N' ) ) THEN
*                 Compute Ac = inv(I_n + G*X)*A.
                  CALL DLACPY( 'Full', N, N, A, LDA, T, LDT )
                  CALL DGESV( N, N, DWORK, N, IWORK, T, LDT, INFO3 )
               ELSE
*                 Compute Ac = A*inv(I_n + X*G)
                  CALL MA02AD( 'Full', N, N, A, LDA, T, LDT )
                  CALL DGESV( N, N, DWORK, N, IWORK, T, LDT, INFO3 )
                  DO 20 J = 2, N
                     CALL DSWAP( J-1, T(1,J), 1, T(J,1), LDT )
   20             CONTINUE
               END IF
*              Compute the Schur factorization of Ac.
               JOBS = 'V'
               CALL DGEES( JOBS, 'Not ordered', SELECT, N, T, LDT, SDIM,
     $                     DWORK(1), DWORK(N+1), U, LDU, DWORK(2*N+1),
     $                     LDWORK-2*N, BWORK, INFO3 )
               IF( INFO3.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99996 ) INFO3
                  STOP
               END IF
            END IF
*
            IF ( LSAME( LYAPUN, 'R' ) ) THEN
               IF( LSAME( TRANA, 'N' )  ) THEN
                  TRANAT = 'T'
               ELSE
                  TRANAT = 'N'
               END IF
*
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX,
     $                      U, LDU, X, LDX, DWORK, N*N, INFO2 )
               CALL MA02ED( UPLO, N, X, LDX )
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG,
     $                      U, LDU, G, LDG, DWORK, N*N, INFO2 )
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ,
     $                      U, LDU, Q, LDQ, DWORK, N*N, INFO2 )
            END IF
*           Estimate the condition and error bound on the solution.
            CALL SB02SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T,
     $                   LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEPD,
     $                   RCOND, FERR, IWORK, DWORK, LDWORK, INFO2 )
*
            IF ( INFO2.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO2
            END IF
            IF ( INFO2.EQ.0 .OR. INFO2.EQ.N+1 ) THEN
               WRITE ( NOUT, FMT = 99992 ) SEPD
               WRITE ( NOUT, FMT = 99991 ) RCOND
               WRITE ( NOUT, FMT = 99990 ) FERR
            END IF
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO1
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB02SD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02MD =',I2)
99997 FORMAT (' INFO on exit from SB02SD =',I2)
99996 FORMAT (' INFO on exit from DGEES  =',I2)
99995 FORMAT (' The solution matrix X is')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' Estimated separation = ',F8.4)
99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99990 FORMAT (/' Estimated error bound = ',F8.4)
      END


        module specfun
        contains
        SUBROUTINE CJYVB(V,Z,VM,CBJ,CDJ,CBY,CDY)
C
C       ===========================================================
C       Purpose: Compute Bessel functions Jv(z), Yv(z) and their
C                derivatives for a complex argument
C       Input :  z --- Complex argument
C                v --- Order of Jv(z) and Yv(z)
C                      ( v = n+v0, n = 0,1,2,..., 0 Û v0 < 1 )
C       Output:  CBJ(n) --- Jn+v0(z)
C                CDJ(n) --- Jn+v0'(z)
C                CBY(n) --- Yn+v0(z)
C                CDY(n) --- Yn+v0'(z)
C                VM --- Highest order computed
C       Routines called:
C            (1) GAMMA for computing the gamma function
C            (2) MSTA1 and MSTA2 for computing the starting
C                point for backward recurrence
C       ===========================================================
C
        IMPLICIT DOUBLE PRECISION (A,B,G,O-Y)
        IMPLICIT COMPLEX*16 (C,Z)
        DIMENSION CBJ(0:*),CDJ(0:*),CBY(0:*),CDY(0:*)
        PI=3.141592653589793D0
        RP2=.63661977236758D0
        CI=(0.0D0,1.0D0)
        A0=CDABS(Z)
        Z1=Z
        Z2=Z*Z
        N=INT(V)
        V0=V-N
        PV0=PI*V0
        IF (A0.LT.1.0D-100) THEN
           DO 10 K=0,N
              CBJ(K)=(0.0D0,0.0D0)
              CDJ(K)=(0.0D0,0.0D0)
              CBY(K)=-(1.0D+300,0.0D0)
10            CDY(K)=(1.0D+300,0.0D0)
           IF (V0.EQ.0.0) THEN
              CBJ(0)=(1.0D0,0.0D0)
              CDJ(1)=(0.5D0,0.0D0)
           ELSE
              CDJ(0)=(1.0D+300,0.0D0)
           ENDIF
           VM=V
           RETURN
        ENDIF
        IF (REAL(Z).LT.0.0D0) Z1=-Z
        IF (A0.LE.12.0) THEN
           CJV0=(1.0D0,0.0D0)
           CR=(1.0D0,0.0D0)
           DO 15 K=1,40
              CR=-0.25D0*CR*Z2/(K*(K+V0))
              CJV0=CJV0+CR
              IF (CDABS(CR).LT.CDABS(CJV0)*1.0D-15) GO TO 20
15         CONTINUE
20         VG=1.0D0+V0
           CALL GAMMA(VG,GA)
           CA=(0.5D0*Z1)**V0/GA
           CJV0=CJV0*CA
        ELSE
           K0=11
           IF (A0.GE.35.0) K0=10
           IF (A0.GE.50.0) K0=8
           VV=4.0D0*V0*V0
           CPZ=(1.0D0,0.0D0)
           CRP=(1.0D0,0.0D0)
           DO 25 K=1,K0
              CRP=-0.78125D-2*CRP*(VV-(4.0*K-3.0)**2.0)*(VV-
     &            (4.0*K-1.0)**2.0)/(K*(2.0*K-1.0)*Z2)
25            CPZ=CPZ+CRP
           CQZ=(1.0D0,0.0D0)
           CRQ=(1.0D0,0.0D0)
           DO 30 K=1,K0
              CRQ=-0.78125D-2*CRQ*(VV-(4.0*K-1.0)**2.0)*(VV-
     &            (4.0*K+1.0)**2.0)/(K*(2.0*K+1.0)*Z2)
30            CQZ=CQZ+CRQ
           CQZ=0.125D0*(VV-1.0)*CQZ/Z1
           ZK=Z1-(0.5D0*V0+0.25D0)*PI
           CA0=CDSQRT(RP2/Z1)
           CCK=CDCOS(ZK)
           CSK=CDSIN(ZK)
           CJV0=CA0*(CPZ*CCK-CQZ*CSK)
           CYV0=CA0*(CPZ*CSK+CQZ*CCK)
        ENDIF
        IF (A0.LE.12.0) THEN
           IF (V0.NE.0.0) THEN
              CJVN=(1.0D0,0.0D0)
              CR=(1.0D0,0.0D0)
              DO 35 K=1,40
                 CR=-0.25D0*CR*Z2/(K*(K-V0))
                 CJVN=CJVN+CR
                 IF (CDABS(CR).LT.CDABS(CJVN)*1.0D-15) GO TO 40
35            CONTINUE
40            VG=1.0D0-V0
              CALL GAMMA(VG,GB)
              CB=(2.0D0/Z1)**V0/GB
              CJU0=CJVN*CB
              CYV0=(CJV0*DCOS(PV0)-CJU0)/DSIN(PV0)
           ELSE
              CEC=CDLOG(Z1/2.0D0)+.5772156649015329D0
              CS0=(0.0D0,0.0D0)
              W0=0.0D0
              CR0=(1.0D0,0.0D0)
              DO 45 K=1,30
                 W0=W0+1.0D0/K
                 CR0=-0.25D0*CR0/(K*K)*Z2
45               CS0=CS0+CR0*W0
              CYV0=RP2*(CEC*CJV0-CS0)
           ENDIF
        ENDIF
        IF (N.EQ.0) N=1
        M=MSTA1(A0,200)
        IF (M.LT.N) THEN
           N=M
        ELSE
           M=MSTA2(A0,N,15)
        ENDIF
        CF2=(0.0D0,0.0D0)
        CF1=(1.0D-100,0.0D0)
        DO 50 K=M,0,-1
           CF=2.0D0*(V0+K+1.0D0)/Z1*CF1-CF2
           IF (K.LE.N) CBJ(K)=CF
           CF2=CF1
50         CF1=CF
        CS=CJV0/CF
        DO 55 K=0,N
55         CBJ(K)=CS*CBJ(K)
        IF (REAL(Z).LT.0.0D0) THEN
           CFAC0=CDEXP(PV0*CI)
           IF (DIMAG(Z).LT.0.0D0) THEN
              CYV0=CFAC0*CYV0-2.0D0*CI*DCOS(PV0)*CJV0
           ELSE IF (DIMAG(Z).GT.0.0D0) THEN
              CYV0=CYV0/CFAC0+2.0D0*CI*DCOS(PV0)*CJV0
           ENDIF
           DO 60 K=0,N
              IF (DIMAG(Z).LT.0.0D0) THEN
                 CBJ(K)=CDEXP(-PI*(K+V0)*CI)*CBJ(K)
              ELSE IF (DIMAG(Z).GT.0.0D0) THEN
                 CBJ(K)=CDEXP(PI*(K+V0)*CI)*CBJ(K)
              ENDIF
60         CONTINUE
           Z1=Z1
        ENDIF
        CBY(0)=CYV0
        DO 65 K=1,N
           CYY=(CBJ(K)*CBY(K-1)-2.0D0/(PI*Z))/CBJ(K-1)
           CBY(K)=CYY
65      CONTINUE
        CDJ(0)=V0/Z*CBJ(0)-CBJ(1)
        DO 70 K=1,N
70         CDJ(K)=-(K+V0)/Z*CBJ(K)+CBJ(K-1)
        CDY(0)=V0/Z*CBY(0)-CBY(1)
        DO 75 K=1,N
75         CDY(K)=CBY(K-1)-(K+V0)/Z*CBY(K)
        VM=N+V0
        RETURN
        END

        SUBROUTINE GAMMA(X,GA)
C
C       ==================================================
C       Purpose: Compute gamma function ‚(x)
C       Input :  x  --- Argument of ‚(x)
C                       ( x is not equal to 0,-1,-2,˙˙˙)
C       Output:  GA --- ‚(x)
C       ==================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION G(26)
        PI=3.141592653589793D0
        IF (X.EQ.INT(X)) THEN
           IF (X.GT.0.0D0) THEN
              GA=1.0D0
              M1=X-1
              DO 10 K=2,M1
10               GA=GA*K
           ELSE
              GA=1.0D+300
           ENDIF
        ELSE
           IF (DABS(X).GT.1.0D0) THEN
              Z=DABS(X)
              M=INT(Z)
              R=1.0D0
              DO 15 K=1,M
15               R=R*(Z-K)
              Z=Z-M
           ELSE
              Z=X
           ENDIF
           DATA G/1.0D0,0.5772156649015329D0,
     &          -0.6558780715202538D0, -0.420026350340952D-1,
     &          0.1665386113822915D0,-.421977345555443D-1,
     &          -.96219715278770D-2, .72189432466630D-2,
     &          -.11651675918591D-2, -.2152416741149D-3,
     &          .1280502823882D-3, -.201348547807D-4,
     &          -.12504934821D-5, .11330272320D-5,
     &          -.2056338417D-6, .61160950D-8,
     &          .50020075D-8, -.11812746D-8,
     &          .1043427D-9, .77823D-11,
     &          -.36968D-11, .51D-12,
     &          -.206D-13, -.54D-14, .14D-14, .1D-15/
           GR=G(26)
           DO 20 K=25,1,-1
20            GR=GR*Z+G(K)
           GA=1.0D0/(GR*Z)
           IF (DABS(X).GT.1.0D0) THEN
              GA=GA*R
              IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X))
           ENDIF
        ENDIF
        RETURN
        END

        INTEGER FUNCTION MSTA1(X,MP)
C
C       ===================================================
C       Purpose: Determine the starting point for backward
C                recurrence such that the magnitude of
C                Jn(x) at that point is about 10^(-MP)
C       Input :  x     --- Argument of Jn(x)
C                MP    --- Value of magnitude
C       Output:  MSTA1 --- Starting point
C       ===================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        A0=DABS(X)
        N0=INT(1.1*A0)+1
        F0=ENVJ(N0,A0)-MP
        N1=N0+5
        F1=ENVJ(N1,A0)-MP
        DO 10 IT=1,20
           NN=N1-(N1-N0)/(1.0D0-F0/F1)
           F=ENVJ(NN,A0)-MP
           IF(ABS(NN-N1).LT.1) GO TO 20
           N0=N1
           F0=F1
           N1=NN
 10        F1=F
 20     MSTA1=NN
        RETURN
        END

        INTEGER FUNCTION MSTA2(X,N,MP)
C
C       ===================================================
C       Purpose: Determine the starting point for backward
C                recurrence such that all Jn(x) has MP
C                significant digits
C       Input :  x  --- Argument of Jn(x)
C                n  --- Order of Jn(x)
C                MP --- Significant digit
C       Output:  MSTA2 --- Starting point
C       ===================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        A0=DABS(X)
        HMP=0.5D0*MP
        EJN=ENVJ(N,A0)
        IF (EJN.LE.HMP) THEN
           OBJ=MP
           N0=INT(1.1*A0)
        ELSE
           OBJ=HMP+EJN
           N0=N
        ENDIF
        F0=ENVJ(N0,A0)-OBJ
        N1=N0+5
        F1=ENVJ(N1,A0)-OBJ
        DO 10 IT=1,20
           NN=N1-(N1-N0)/(1.0D0-F0/F1)
           F=ENVJ(NN,A0)-OBJ
           IF (ABS(NN-N1).LT.1) GO TO 20
           N0=N1
           F0=F1
           N1=NN
10         F1=F
20      MSTA2=NN+10
        RETURN
        END

        REAL*8 FUNCTION ENVJ(N,X)
        DOUBLE PRECISION X
        ENVJ=0.5D0*DLOG10(6.28D0*N)-N*DLOG10(1.36D0*X/N)
        RETURN
        END
        end module specfun


! “ButterflyPACK” Copyright (c) 2018, The Regents of the University of California, through
! Lawrence Berkeley National Laboratory (subject to receipt of any required approvals from the
! U.S. Dept. of Energy). All rights reserved.

! If you have questions about your rights to use or distribute this software, please contact
! Berkeley Lab's Intellectual Property Office at  IPO@lbl.gov.

! NOTICE.  This Software was developed under funding from the U.S. Department of Energy and the
! U.S. Government consequently retains certain rights. As such, the U.S. Government has been
! granted for itself and others acting on its behalf a paid-up, nonexclusive, irrevocable
! worldwide license in the Software to reproduce, distribute copies to the public, prepare
! derivative works, and perform publicly and display publicly, and to permit other to do so.

! Developers: Yang Liu
!             (Lawrence Berkeley National Lab, Computational Research Division).

! This exmple works with double-complex precision data
#define DAT 0

#include "ButterflyPACK_config.fi"

PROGRAM ButterflyPACK_IE_2D
    use BPACK_DEFS
    use EMCURV_MODULE

	use BPACK_structure
	use BPACK_Solve_Mul
	use BPACK_factor
	use BPACK_constr
	use BPACK_Utilities
	use omp_lib
	use MISC_Utilities
	use BPACK_wrapper
    implicit none

	! include "mkl_vml.fi"

    real(kind=8) para
    real(kind=8) tolerance
    integer Primary_block, nn, mm,kk,mn,rank,ii,jj
    integer i,j,k, threads_num
	integer seed_myid(50)
	integer times(8)
	integer edge
	real(kind=8) t1,t2,t3, x,y,z,r,theta,phi
	complex(kind=8),allocatable:: matU(:,:),matV(:,:),matZ(:,:),LL(:,:),RR(:,:),matZ1(:,:)

	character(len=:),allocatable  :: string
	character(len=1024)  :: strings,strings1
	character(len=6)  :: info_env
	integer :: length
	integer :: ierr
	integer*8 oldmode,newmode
	type(Hoption),target::option,option1
	type(Hstat),target::stats,stats1
	type(mesh),target::msh,msh1
	type(kernelquant),target::ker,ker1
	type(Bmatrix),target::bmat,bmat1
	integer,allocatable:: groupmembers(:)
	integer nmpi
	type(proctree),target::ptree,ptree1
	type(quant_EMCURV),target::quant
	type(quant_bmat),target::quant1
	CHARACTER (LEN=1000) DATA_DIR
	integer:: randsize=50
	real(kind=8),allocatable::xyz(:,:)
	integer,allocatable::Permutation(:),tree(:)
	integer Nunk_loc,Maxlevel
	integer nargs,flag
	integer v_major,v_minor,v_bugfix

	! nmpi and groupmembers should be provided by the user
	call MPI_Init(ierr)
	call MPI_Comm_size(MPI_Comm_World,nmpi,ierr)
	allocate(groupmembers(nmpi))
	do ii=1,nmpi
		groupmembers(ii)=(ii-1)
	enddo

	! generate the process tree
	call CreatePtree(nmpi,groupmembers,MPI_Comm_World,ptree)
	deallocate(groupmembers)

	if(ptree%MyID==Main_ID)then
    write(*,*) "-------------------------------Program Start----------------------------------"
    write(*,*) "ButterflyPACK_IE_2D"
	call BPACK_GetVersionNumber(v_major,v_minor,v_bugfix)
	write(*,'(A23,I1,A1,I1,A1,I1,A1)') " ButterflyPACK Version:",v_major,".",v_minor,".",v_bugfix
    write(*,*) "   "
	endif

	!**** initialize stats and option
	call InitStat(stats)
	call SetDefaultOptions(option)

	!**** intialize the user-defined derived type quant
	quant%RCS_static=1
    quant%RCS_Nsample=1
	quant%model2d=10
	quant%wavelength=0.08
	quant%freq=1/quant%wavelength/sqrt(mu0*eps0)
	quant%Nunk=5000

	option%ErrSol=1
	option%format=  HODLR !HMAT!  HODLR !
	option%near_para=0.01d0
	option%verbosity=2
	option%ILU=0
	option%forwardN15flag=0
        ! option%schulzlevel=0
        ! option%LRlevel=100
       ! option%level_check=1
    option%tol_itersol=1d-5
    ! option%sample_para=4d0

	! do ii=2,15
	! call C_BPACK_TreeIndex_Merged2Child(ii,jj)
	! write(*,*)ii,jj
	! enddo

	nargs = iargc()
	ii=1
	do while(ii<=nargs)
		call getarg(ii,strings)
		if(trim(strings)=='-quant')then ! user-defined quantity parameters
			flag=1
			do while(flag==1)
				ii=ii+1
				if(ii<=nargs)then
					call getarg(ii,strings)
					if(strings(1:2)=='--')then
						ii=ii+1
						call getarg(ii,strings1)
						if(trim(strings)=='--model2d')then
							read(strings1,*)quant%model2d
						else if	(trim(strings)=='--nunk')then
							read(strings1,*)quant%Nunk
						else if	(trim(strings)=='--wavelength')then
							read(strings1,*)quant%wavelength
							quant%freq=1/quant%wavelength/sqrt(mu0*eps0)
						else if (trim(strings)=='--freq')then
							read(strings1,*)quant%freq
							quant%wavelength=1/quant%freq/sqrt(mu0*eps0)
						else
							if(ptree%MyID==Main_ID)write(*,*)'ignoring unknown quant: ', trim(strings)
						endif
					else
						flag=0
					endif
				else
					flag=0
				endif
			enddo
		else if(trim(strings)=='-option')then ! options of ButterflyPACK
			call ReadOption(option,ptree,ii)
		else
			if(ptree%MyID==Main_ID)write(*,*)'ignoring unknown argument: ',trim(strings)
			ii=ii+1
		endif
	enddo

    quant%wavenum=2*pi/quant%wavelength

   !***********************************************************************
   if(ptree%MyID==Main_ID)then
   write (*,*) ''
   write (*,*) 'EFIE computing'
   write (*,*) 'frequency:',quant%freq
   write (*,*) 'wavelength:',quant%wavelength
   write (*,*) ''
   endif
   !***********************************************************************

	!**** geometry generalization and discretization
    call geo_modeling_CURV(quant,ptree%Comm)

	option%touch_para = 3* quant%minedgelength

	!**** register the user-defined function and type in ker
	ker%QuantApp => quant
	ker%FuncZmn => Zelem_EMCURV

	!**** initialization of the construction phase
	allocate(xyz(2,quant%Nunk))
	do edge=1, quant%Nunk
		xyz(:,edge) = quant%xyz(:,edge*2-1)
	enddo
    allocate(Permutation(quant%Nunk))
	call PrintOptions(option,ptree)
	call BPACK_construction_Init(quant%Nunk,Permutation,Nunk_loc,bmat,option,stats,msh,ker,ptree,Coordinates=xyz)
	deallocate(Permutation) ! caller can use this permutation vector if needed
	deallocate(xyz)

	!**** computation of the construction phase
    call BPACK_construction_Element(bmat,option,stats,msh,ker,ptree)

	select case(option%format)
	case(HODLR)
		Maxlevel=bmat%ho_bf%Maxlevel
	case(HMAT)
		Maxlevel=bmat%h_mat%Maxlevel
	end select
	if(option%lnoBP>Maxlevel)then	 ! haven't implement the following for Bplus.

		!*********** Construct the second HODLR by using the first HODLR as parallel element extraction
		call CopyOptions(option,option1)
		option1%nogeo=1   ! this indicates the second HOLDR construction requires no geometry information
		option1%xyzsort=NATURAL ! this indicates the second HOLDR construction requires no reordering
		option1%elem_extract=1 ! this indicates the second HOLDR construction uses user-defined parallel element extraction

		!**** register the user-defined function and type in ker
		ker1%FuncZmn=>Zelem_EMCURV
		ker1%FuncZmnBlock=>Zelem_block_Extraction
		ker1%QuantApp=>quant1

		quant1%bmat=>bmat
		quant1%msh=>msh
		quant1%ptree=>ptree
		quant1%stats=>stats
		quant1%option=>option

		msh1%Nunk = msh%Nunk

		allocate(xyz(2,quant%Nunk))
		do edge=1, quant%Nunk
			xyz(:,edge) = quant%xyz(:,edge*2-1)
		enddo
		allocate(msh1%xyz(2,quant%Nunk)) ! xyz is used to compute group centers to determine admissibility
		do edge=1,quant%Nunk
			msh1%xyz(:,edge) = xyz(:,msh%new2old(edge))
		enddo
		deallocate(xyz)

		call InitStat(stats1)

		! !**** generate the process tree for the second HODLR, can use larger number of MPIs if you want to
		! allocate(groupmembers(nmpi))
		! do ii=1,nmpi
			! groupmembers(ii)=(ii-1)
		! enddo
		! call CreatePtree(nmpi,groupmembers,MPI_Comm_World,ptree1)
		! deallocate(groupmembers)

		!**** use the clustering tree from the first HODLR
		allocate (tree(2**Maxlevel))
		do ii=1,2**Maxlevel
			tree(ii)=msh%basis_group(2**Maxlevel+ii-1)%tail-msh%basis_group(2**Maxlevel+ii-1)%head+1
		enddo

		!**** initialization of the construction phase
		allocate(Permutation(msh1%Nunk))
		call BPACK_construction_Init(msh1%Nunk,Permutation,Nunk_loc,bmat1,option1,stats1,msh1,ker1,ptree,tree=tree)
		deallocate(Permutation) ! caller can use this permutation vector if needed
		deallocate(tree)

		!**** computation of the construction phase
		call BPACK_construction_Element(bmat1,option1,stats1,msh1,ker1,ptree)

		!**** deletion of quantities
		! call delete_proctree(ptree1)
		call delete_Hstat(stats1)
		call delete_mesh(msh1)
		call delete_kernelquant(ker1)
		call BPACK_delete(bmat1)
	endif

	!**** factorization phase
    call BPACK_Factorization(bmat,option,stats,ptree,msh)

	!**** solve phase
   ! call EM_solve_CURV(bmat,option,msh,quant,ptree,stats)

	!**** print statistics
	call PrintStat(stats,ptree)

	!**** deletion of quantities
	call delete_quant_EMCURV(quant)
	call delete_proctree(ptree)
	call delete_Hstat(stats)
	call delete_mesh(msh)
	call delete_kernelquant(ker)
	call BPACK_delete(bmat)

    if(ptree%MyID==Main_ID .and. option%verbosity>=0)write(*,*) "-------------------------------program end-------------------------------------"

	call blacs_exit(1)
	call MPI_Finalize(ierr)

end PROGRAM ButterflyPACK_IE_2D


program nca_test
  USE DMFT_NCA
  USE SCIFOR
  USE DMFT_TOOLS
  implicit none
  integer,parameter                           :: Nbath=7
  complex(8),dimension(:),allocatable         :: fg0
  complex(8),dimension(:,:,:,:,:),allocatable :: Delta
  integer                                     :: i,iorb
  !
  logical :: converged
  integer :: dmft_loop

  print*, "NCA_TEST:"
  call nca_read_input("inputNCA.conf")

  allocate(Delta(Nspin,Nspin,Norb,Norb,Lmats))
  Delta=zero
  open(100,file="Delta_iw.input")
  do i=1,Lmats
     Delta(1,1,1,1,i) = 0.5d0/(xi*pi/beta*(2*i-1) - Uloc(1)/2d0)+0.5d0/(xi*pi/beta*(2*i-1) + Uloc(1)/2d0)
     write(100,*)pi/beta*(2*i-1),dimag(Delta(1,1,1,1,i)),dreal(Delta(1,1,1,1,i))
  enddo

  call nca_init_solver()

  converged=.false. ; dmft_loop=0
  do while(.not.converged)
     dmft_loop=dmft_loop+1
     call start_loop(dmft_loop,nloop,"DMFT-loop")
     call nca_solver(Delta)
     Delta = 0.25d0*impGmats
     converged = check_convergence(delta(1,1,1,1,:),dmft_error,nsuccess,nloop,reset=.false.)
     call end_loop
  enddo
  open(100,file="Delta_iw.nca")
  do i=1,Lmats
     write(100,*)pi/beta*(2*i-1),dimag(Delta(1,1,1,1,i)),dreal(Delta(1,1,1,1,i))
  enddo
  close(100)
end program nca_test


! Copyright (c) 2013, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
! Tests F2003 defined I/O (unformatted write)
! This example is based on example from the Fortran 2003 Handbook (page 336)

module rational_stuff
  type rational
    integer n, d
    real :: rat_rslt=0.0
  end type

  interface write (unformatted)
    module procedure write_rational_value
  end interface write (unformatted)
  interface read (unformatted)
    module procedure read_rational_value
  end interface read (unformatted)

 contains
  subroutine write_rational_value(dtv, unit, iostat, iomsg)

  class(rational), intent(inout) :: dtv
  integer, intent(in) :: unit
  integer, intent(out) :: iostat
  character(len=*), intent(inout) :: iomsg
  real rat

     if (dtv%d .ne. 0) then
       dtv%rat_rslt = real(dtv%n)/real(dtv%d)
       write(unit), dtv%n, dtv%d, dtv%rat_rslt
     endif
  end subroutine

  subroutine read_rational_value(dtv, unit, iostat, iomsg)

  class(rational), intent(inout) :: dtv
  integer, intent(in) :: unit
  integer, intent(out) :: iostat
  character(len=*), intent(inout) :: iomsg

  end subroutine
end module

  use rational_stuff
  type(rational) x, y
  logical rslt(3), expect(3)
  x = rational(2,3)
  open(10, file='io13.output', status='replace', form='unformatted')
  write(10) , x
  close(10)
  open(10, file='io13.output', status='old', form='unformatted')
  read(10), y%n, y%d, y%rat_rslt
  close(10)

  !print *, x%n, x%d, x%rat_rslt
  !print *, y%n, y%d, y%rat_rslt

  expect = .true.
  rslt(1) = x%n .eq. y%n
  rslt(2) = x%d .eq. y%d
  rslt(3) = x%rat_rslt .eq. y%rat_rslt

  call check(rslt, expect, 3)
  end


module type_faceQuadrature
#include <messenger.h>
    use mod_kinds,              only: rk,ik
    use mod_constants,          only: NFACES,XI_MIN,XI_MAX,ETA_MIN,ETA_MAX,ZETA_MIN,ZETA_MAX, &
                                      XI_DIR,ETA_DIR,ZETA_DIR, TWO_DIM, THREE_DIM, ZERO, ONE
    use mod_polynomial,         only: polynomial_val,dpolynomial_val
    use mod_quadrature_tools,   only: compute_nnodes1d_face
    use mod_gauss_legendre,     only: gl_nodes, gl_weights
    use mod_inv,                only: inv

    use type_point,             only: point_t

    implicit none
    private

    !>
    !!
    !!  @author Nathan A. Wukie
    !!
    !!
    !!
    !-----------------------------------------------------------------------------------------
    type, public :: faceQuadrature_t
        integer(ik)                                     :: nnodes
        type(point_t),  dimension(:,:),     allocatable :: nodes    !< (:, iface)
        real(rk),       dimension(:,:),     allocatable :: weights  !< (:, iface)

        real(rk),       dimension(:,:,:),   allocatable :: val      !< (:,:,iface)
        real(rk),       dimension(:,:,:),   allocatable :: val_trans
        real(rk),       dimension(:,:,:),   allocatable :: ddxi     !< ''
        real(rk),       dimension(:,:,:),   allocatable :: ddeta    !< ''
        real(rk),       dimension(:,:,:),   allocatable :: ddzeta   !< ''

    contains

        procedure :: init

    end type faceQuadrature_t
    !*****************************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!
    !!
    !!  TODO: TEST SPACEDIM
    !!
    !!
    !-----------------------------------------------------------------------------------------
    subroutine init(self,spacedim,nnodes_face,nterms)
        class(faceQuadrature_t),    intent(inout)   :: self
        integer(ik),                intent(in)      :: spacedim
        integer(ik),                intent(in)      :: nnodes_face
        integer(ik),                intent(in)      :: nterms

        integer(ik)                             :: inode, iterm, iface, cface
        integer(ik)                             :: nnodes1d
        integer(ik)                             :: ixi,          ieta,           izeta
        real(rk)                                :: xi,           eta,            zeta
        real(rk), dimension(:), allocatable     :: xi_vals,      eta_vals,       zeta_vals
        real(rk), dimension(:), allocatable     :: xi_weights,   eta_weights,    zeta_weights
        real(rk), dimension(:), allocatable     :: face_indices
        type(point_t)                           :: node

        self%nnodes = nnodes_face

        !
        ! allocate quadrature storage
        !
        allocate(self%nodes(nnodes_face,NFACES),self%weights(nnodes_face,NFACES))
        allocate(self%val(   nnodes_face,nterms,NFACES))
        allocate(self%ddxi(  nnodes_face,nterms,NFACES))
        allocate(self%ddeta( nnodes_face,nterms,NFACES))
        allocate(self%ddzeta(nnodes_face,nterms,NFACES))

        allocate(self%val_trans(   nterms,nnodes_face,NFACES))

        !
        ! Initialize quadrature node coordinates for face sets
        !
        ! find number nodes in 1D polynomial
        nnodes1d = compute_nnodes1d_face(spacedim,nnodes_face)

        allocate(xi_vals(nnodes1d),eta_vals(nnodes1d),zeta_vals(nnodes1d))
        allocate(xi_weights(nnodes1d),eta_weights(nnodes1d),zeta_weights(nnodes1d))

        xi_vals      = gl_nodes(nnodes1d)
        eta_vals     = gl_nodes(nnodes1d)
        zeta_vals    = gl_nodes(nnodes1d)
        xi_weights   = gl_weights(nnodes1d)
        eta_weights  = gl_weights(nnodes1d)
        zeta_weights = gl_weights(nnodes1d)

        if ( spacedim == THREE_DIM ) then

            !
            ! xi_min face coordinates
            !
            inode = 1
            do izeta = 1,nnodes1d
                do ieta = 1,nnodes1d
                    xi   = -1._rk
                    eta  = eta_vals(ieta)
                    zeta = zeta_vals(izeta)

                    call self%nodes(inode,XI_MIN)%set(xi,eta,zeta)
                    self%weights(inode,XI_MIN) = eta_weights(ieta)*zeta_weights(izeta)
                    inode = inode + 1
                end do
            end do

            !
            ! xi_max face coordinates
            !
            inode = 1
            do izeta = 1,nnodes1d
                do ieta = 1,nnodes1d
                    xi   = 1._rk
                    eta  = eta_vals(ieta)
                    zeta = zeta_vals(izeta)

                    call self%nodes(inode,XI_MAX)%set(xi,eta,zeta)
                    self%weights(inode,XI_MAX) = eta_weights(ieta)*zeta_weights(izeta)
                    inode = inode + 1
                end do
            end do

            !
            ! eta_min face coordinates
            !
            inode = 1
            do izeta = 1,nnodes1d
                do ixi = 1,nnodes1d
                    xi   = xi_vals(ixi)
                    eta  = -1._rk
                    zeta = zeta_vals(izeta)

                    call self%nodes(inode,ETA_MIN)%set(xi,eta,zeta)
                    self%weights(inode,ETA_MIN) = xi_weights(ixi)*zeta_weights(izeta)
                    inode = inode + 1
                end do
            end do

            !
            ! eta_max face coordinates
            !
            inode = 1
            do izeta = 1,nnodes1d
                do ixi = 1,nnodes1d
                    xi   = xi_vals(ixi)
                    eta  = 1._rk
                    zeta = zeta_vals(izeta)

                    call self%nodes(inode,ETA_MAX)%set(xi,eta,zeta)
                    self%weights(inode,ETA_MAX) = xi_weights(ixi)*zeta_weights(izeta)
                    inode = inode + 1
                end do
            end do

            !
            ! zeta_min face coordinates
            !
            inode = 1
            do ieta = 1,nnodes1d
                do ixi = 1,nnodes1d
                    xi   = xi_vals(ixi)
                    eta  = eta_vals(ieta)
                    zeta = -1._rk

                    call self%nodes(inode,ZETA_MIN)%set(xi,eta,zeta)
                    self%weights(inode,ZETA_MIN) = xi_weights(ixi)*eta_weights(ieta)
                    inode = inode + 1
                end do
            end do

            !
            ! zeta_max face coordinates
            !
            inode = 1
            do ieta = 1,nnodes1d
                do ixi = 1,nnodes1d
                    xi   = xi_vals(ixi)
                    eta  = eta_vals(ieta)
                    zeta = 1._rk

                    call self%nodes(inode,ZETA_MAX)%set(xi,eta,zeta)
                    self%weights(inode,ZETA_MAX) = xi_weights(ixi)*eta_weights(ieta)
                    inode = inode + 1
                end do
            end do

        else if ( spacedim == TWO_DIM ) then

            !
            ! xi_min face coordinates
            !
            inode = 1
            do ieta = 1,nnodes1d
                xi   = -1._rk
                eta  = eta_vals(ieta)
                zeta = ZERO

                call self%nodes(inode,XI_MIN)%set(xi,eta,zeta)
                self%weights(inode,XI_MIN) = eta_weights(ieta)
                inode = inode + 1
            end do

            !
            ! xi_max face coordinates
            !
            inode = 1
            do ieta = 1,nnodes1d
                xi   = 1._rk
                eta  = eta_vals(ieta)
                zeta = ZERO

                call self%nodes(inode,XI_MAX)%set(xi,eta,zeta)
                self%weights(inode,XI_MAX) = eta_weights(ieta)
                inode = inode + 1
            end do

            !
            ! eta_min face coordinates
            !
            inode = 1
            do ixi = 1,nnodes1d
                xi   = xi_vals(ixi)
                eta  = -1._rk
                zeta = ZERO

                call self%nodes(inode,ETA_MIN)%set(xi,eta,zeta)
                self%weights(inode,ETA_MIN) = xi_weights(ixi)
                inode = inode + 1
            end do

            !
            ! eta_max face coordinates
            !
            inode = 1
            do ixi = 1,nnodes1d
                xi   = xi_vals(ixi)
                eta  = 1._rk
                zeta = ZERO

                call self%nodes(inode,ETA_MAX)%set(xi,eta,zeta)
                self%weights(inode,ETA_MAX) = xi_weights(ixi)
                inode = inode + 1
            end do

            !
            ! zeta_min face coordinates
            !
            do inode = 1,nnodes1d
                    xi   = ZERO
                    eta  = ZERO
                    zeta = ZERO

                    call self%nodes(inode,ZETA_MIN)%set(xi,eta,zeta)
                    self%weights(inode,ZETA_MIN) = ZERO
            end do

            !
            ! zeta_max face coordinates
            !
            do inode = 1,nnodes1d
                    xi   = ZERO
                    eta  = ZERO
                    zeta = ZERO

                    call self%nodes(inode,ZETA_MAX)%set(xi,eta,zeta)
                    self%weights(inode,ZETA_MAX) = ZERO
            end do

        else
            call chidg_signal(FATAL,"faceQuadrature%init: Invalid SPACEDIM")

        end if

        !===========================================================================
        ! Initialize values and partial derivatives of each modal
        ! polynomial at each face quadrature node
        !===========================================================================

        face_indices = [XI_MIN, XI_MAX, ETA_MIN, ETA_MAX, ZETA_MIN, ZETA_MAX]

        do iterm = 1,nterms
            do inode = 1,nnodes_face
                do iface = 1,size(face_indices)

                    !
                    ! Get current face
                    !
                    cface = face_indices(iface)

                    !
                    ! on the xi_min face
                    !
                    node = self%nodes(inode,cface)
                    self%val(   inode,iterm,cface) =  polynomial_val(spacedim,nterms,iterm,[node%c1_, node%c2_, node%c3_])
                    self%ddxi(  inode,iterm,cface) = dpolynomial_val(spacedim,nterms,iterm,[node%c1_, node%c2_, node%c3_],XI_DIR)
                    self%ddeta( inode,iterm,cface) = dpolynomial_val(spacedim,nterms,iterm,[node%c1_, node%c2_, node%c3_],ETA_DIR)
                    self%ddzeta(inode,iterm,cface) = dpolynomial_val(spacedim,nterms,iterm,[node%c1_, node%c2_, node%c3_],ZETA_DIR)

                end do
            end do
        end do

        do iface = 1,size(face_indices)
            self%val_trans(:,:,iface) = transpose(self%val(:,:,iface))
        end do

    end subroutine init
    !****************************************************************************************

end module type_faceQuadrature


*     SG03BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER           NIN, NOUT
      PARAMETER         ( NIN = 5, NOUT = 6 )
      INTEGER           NMAX
      PARAMETER         ( NMAX = 20 )
      INTEGER           LDA, LDB, LDE, LDQ, LDZ
      PARAMETER         ( LDA = NMAX, LDB = NMAX, LDE = NMAX,
     $                    LDQ = NMAX, LDZ = NMAX )
      INTEGER           LDWORK
      PARAMETER         ( LDWORK = MAX( 1, 4*NMAX, 6*NMAX-6 ) )
*     .. Local Scalars ..
      CHARACTER*1       DICO, FACT, TRANS
      DOUBLE PRECISION  SCALE
      INTEGER           I, INFO, J, N, M
*     .. Local Arrays ..
      DOUBLE PRECISION  A(LDA,NMAX), ALPHAI(NMAX), ALPHAR(NMAX),
     $                  B(LDB,NMAX), BETA(NMAX), DWORK(LDWORK),
     $                  E(LDE,NMAX), Q(LDQ,NMAX), Z(LDZ,NMAX)
*     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
*     .. External Subroutines ..
      EXTERNAL          SG03BD
*     .. Intrinsic Functions ..
      INTRINSIC         MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, DICO, FACT, TRANS
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) M
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) THEN
            READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( Z(I,J), J = 1,N ), I = 1,N )
         END IF
         IF ( LSAME( FACT, 'T' ) ) THEN
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,M )
         END IF
*        Find the Cholesky factor U of the solution matrix.
         CALL SG03BD( DICO, FACT, TRANS, N, M, A, LDA, E, LDE, Q, LDQ,
     $                Z, LDZ, B, LDB, SCALE, ALPHAR, ALPHAI, BETA,
     $                DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 ) SCALE
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,N )
   20       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' SG03BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SG03BD = ',I2)
99997 FORMAT (' SCALE = ',F8.4,//' The Cholesky factor U of the solution
     $ matrix is')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' M is out of range.',/' M = ',I5)
      END


      subroutine sgeco(a,lda,n,ipvt,rcond,z)
      integer lda,n,ipvt(1)
      real a(lda,1),z(1)
      real rcond
c
c     sgeco factors a real matrix by gaussian elimination
c     and estimates the condition of the matrix.
c
c     if  rcond  is not needed, sgefa is slightly faster.
c     to solve  a*x = b , follow sgeco by sgesl.
c     to compute  inverse(a)*c , follow sgeco by sgesl.
c     to compute  determinant(a) , follow sgeco by sgedi.
c     to compute  inverse(a) , follow sgeco by sgedi.
c
c     on entry
c
c        a       real(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        rcond   real
c                an estimate of the reciprocal condition of  a .
c                for the system  a*x = b , relative perturbations
c                in  a  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  a  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.
c
c        z       real(n)
c                a work vector whose contents are usually unimportant.
c                if  a  is close to a singular matrix, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     linpack sgefa
c     blas saxpy,sdot,sscal,sasum
c     fortran abs,amax1,sign
c
c     internal variables
c
      real sdot,ek,t,wk,wkm
      real anorm,s,sasum,sm,ynorm
      integer info,j,k,kb,kp1,l
c
c
c     compute 1-norm of a
c
      anorm = 0.0e0
      do 10 j = 1, n
         anorm = amax1(anorm,sasum(n,a(1,j),1))
   10 continue
c
c     factor
c
      call sgefa(a,lda,n,ipvt,info)
c
c     rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
c     estimate = norm(z)/norm(y) where  a*z = y  and  trans(a)*y = e .
c     trans(a)  is the transpose of a .  the components of  e  are
c     chosen to cause maximum local growth in the elements of w  where
c     trans(u)*w = e .  the vectors are frequently rescaled to avoid
c     overflow.
c
c     solve trans(u)*w = e
c
      ek = 1.0e0
      do 20 j = 1, n
         z(j) = 0.0e0
   20 continue
      do 100 k = 1, n
         if (z(k) .ne. 0.0e0) ek = sign(ek,-z(k))
         if (abs(ek-z(k)) .le. abs(a(k,k))) go to 30
            s = abs(a(k,k))/abs(ek-z(k))
            call sscal(n,s,z,1)
            ek = s*ek
   30    continue
         wk = ek - z(k)
         wkm = -ek - z(k)
         s = abs(wk)
         sm = abs(wkm)
         if (a(k,k) .eq. 0.0e0) go to 40
            wk = wk/a(k,k)
            wkm = wkm/a(k,k)
         go to 50
   40    continue
            wk = 1.0e0
            wkm = 1.0e0
   50    continue
         kp1 = k + 1
         if (kp1 .gt. n) go to 90
            do 60 j = kp1, n
               sm = sm + abs(z(j)+wkm*a(k,j))
               z(j) = z(j) + wk*a(k,j)
               s = s + abs(z(j))
   60       continue
            if (s .ge. sm) go to 80
               t = wkm - wk
               wk = wkm
               do 70 j = kp1, n
                  z(j) = z(j) + t*a(k,j)
   70          continue
   80       continue
   90    continue
         z(k) = wk
  100 continue
      s = 1.0e0/sasum(n,z,1)
      call sscal(n,s,z,1)
c
c     solve trans(l)*y = w
c
      do 120 kb = 1, n
         k = n + 1 - kb
         if (k .lt. n) z(k) = z(k) + sdot(n-k,a(k+1,k),1,z(k+1),1)
         if (abs(z(k)) .le. 1.0e0) go to 110
            s = 1.0e0/abs(z(k))
            call sscal(n,s,z,1)
  110    continue
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
  120 continue
      s = 1.0e0/sasum(n,z,1)
      call sscal(n,s,z,1)
c
      ynorm = 1.0e0
c
c     solve l*v = y
c
      do 140 k = 1, n
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
         if (k .lt. n) call saxpy(n-k,t,a(k+1,k),1,z(k+1),1)
         if (abs(z(k)) .le. 1.0e0) go to 130
            s = 1.0e0/abs(z(k))
            call sscal(n,s,z,1)
            ynorm = s*ynorm
  130    continue
  140 continue
      s = 1.0e0/sasum(n,z,1)
      call sscal(n,s,z,1)
      ynorm = s*ynorm
c
c     solve  u*z = v
c
      do 160 kb = 1, n
         k = n + 1 - kb
         if (abs(z(k)) .le. abs(a(k,k))) go to 150
            s = abs(a(k,k))/abs(z(k))
            call sscal(n,s,z,1)
            ynorm = s*ynorm
  150    continue
         if (a(k,k) .ne. 0.0e0) z(k) = z(k)/a(k,k)
         if (a(k,k) .eq. 0.0e0) z(k) = 1.0e0
         t = -z(k)
         call saxpy(k-1,t,a(1,k),1,z(1),1)
  160 continue
c     make znorm = 1.0
      s = 1.0e0/sasum(n,z,1)
      call sscal(n,s,z,1)
      ynorm = s*ynorm
c
      if (anorm .ne. 0.0e0) rcond = ynorm/anorm
      if (anorm .eq. 0.0e0) rcond = 0.0e0
      return
      end


! tempc(1:nsd)=res_t(1:nsd)
do inl=1,nen
    node=ien(inl,ie)
    do isd=1,nsd
        do jsd=1,nsd
            res_t(isd) = res_t(isd) - sh(jsd,inl)*hattauij(isd,jsd,node)
        enddo
    enddo
enddo

!            if (node==5000) then
!                write (*,*) tempc(1:nsd)
!                write (*,*) "residual", res_t(1:nsd)
!            endif


! { dg-do run }
! { dg-options "-O3 -fdump-tree-original" }
! Tests the fix for PR33850, in which one of the two assignments
! below would produce an unnecessary temporary for the index
! expression, following the fix for PR33749.
!
! Contributed by Dick Hendrickson on comp.lang.fortran,
! " Most elegant syntax for inverting a permutation?" 20071006
!
  integer(4) :: p4(4) = (/2,4,1,3/)
  integer(4) :: q4(4) = (/2,4,1,3/)
  integer(8) :: p8(4) = (/2,4,1,3/)
  integer(8) :: q8(4) = (/2,4,1,3/)
  p4(q4) = (/(i, i = 1, 4)/)
  q4(q4) = (/(i, i = 1, 4)/)
  p8(q8) = (/(i, i = 1, 4)/)
  q8(q8) = (/(i, i = 1, 4)/)
  if (any(p4 .ne. q4)) call abort ()
  if (any(p8 .ne. q8)) call abort ()
end
! Whichever is the default length for array indices will yield
! parm 18 times, because a temporary is not necessary.  The other
! cases will all yield a temporary, so that atmp appears 18 times.
! Note that it is the kind conversion that generates the temp.
!
! { dg-final { scan-tree-dump-times "parm" 18 "original" } }
! { dg-final { scan-tree-dump-times "atmp" 18 "original" } }


MODULE mdl_tides

! ---------------------------------------------------------------------------
! Purpose:
!  Module used in the subroutines for computing the Tidal effects to orbit
! ---------------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou, Geoscience Australia              November 2015
! ---------------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 30 January 2019:
!   The Doodson arguments multipliers have now been applied and stored
!   as global dynamic allocatable array through this module.
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE
      SAVE

! Allocatable Arrays
! ---------------------------------------------------------------------------
! ---------------------------------------------------------------------------
! Allocated in "tides_ocean.f90"
!      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: dCnm_ocean, dSnm_ocean
! ---------------------------------------------------------------------------
! Allocated in "tides_fes2004.f90"
      !REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: DelaunayNf
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: Delaunay_FES, Doodson_mult_glb
      REAL (KIND = prec_q), DIMENSION(:,:,:), ALLOCATABLE :: dCnm_p,dSnm_p, dCnm_m,dSnm_m
! ---------------------------------------------------------------------------
! Allocated in "lib4_tides.f90"
!      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: dCnm_tides, dSnm_tides
! ---------------------------------------------------------------------------

END