      program suo
      implicit none

c..solves the su-olson problem
c..cgs units throughout,
c..except some duly noted temperatures that are in ev

c..declare
      character*80     outfile,string
      integer          i,nstep,iargc
      double precision time,zpos,trad_bc_ev,opac,alpha,
     1                 erad,trad,trad_ev,tmat,tmat_ev,
     2                 zlo,zhi,zstep,value,uans,vans,tau

c..some physics
      double precision clight,ssol,asol
      parameter        (clight  = 2.99792458d10,
     1                  ssol     = 5.67051d-5,
     2                  asol    = 4.0d0 * ssol / clight)

c..popular formats
 01   format(1x,t4,a,t10,a,t22,a,t34,a,t46,a,t58,a,t70,a)
 02   format(1x,i4,1p8e12.4)

c..input parameters
      trad_bc_ev = 1.0d0
      opac       = 1.0d0
      alpha      = 4.0d0*asol
      tau        = 1.0d0
      time       = tau * alpha / (4.0d0*asol*clight*opac)

c..number of grid points, spatial domain, spatial step size
      nstep = 100
      zlo   = 0.0d0
      zhi   = 20.0d0
      zstep = (zhi - zlo)/float(nstep)

c..output file
      outfile = '100pt_tau1p0.dat'
      open(unit=2,file=outfile,status='unknown')
c.....write(2,02) nstep,tau
      write(2,01) 'i','x','U','V','Trad/T_H','Tmat/T_H'

c..use the mid-cell points to match various eularian hydrocodes
      do i=1,nstep
       zpos = zlo + 0.5d0*zstep + float(i-1)*zstep

       call so_wave(time,zpos,trad_bc_ev,opac,alpha,
     1              erad,trad,trad_ev,tmat,tmat_ev,uans,vans)

       write(6,40) i,zpos,uans,vans,trad_ev,tmat_ev
       write(2,40) i,zpos,uans,vans,trad_ev,tmat_ev
 40    format(1x,i4,1p8e14.6)

      enddo

c..close up stop
      close(unit=2)
      end

      subroutine so_wave(time,zpos,trad_bc_ev,opac,alpha,
     1                   erad,trad,trad_ev,tmat,tmat_ev,uans,vans)
      implicit none
      save

c..provides solution to the su-olson problem

c..input:
c..time       = time point where solution is desired
c..zpos       = spaatial point where solution is desired
c..trad_bc_ev = boundary condition temperature in electron volts
c..opac       = the opacity in cm**2/g
c..alpha      = coefficient of the material equation of state c_v = alpha T_mat**3

c..output:
c..erad       = energy desnity of radiation field erg/cm**3
c..trad       = temperature of radiation field kelvin
c..trad_ev    = temperature of radiation field electron volts
c..trad       = temperature of material field kelvin
c..trad_ev    = temperature of material field electron volts

c..declare the input
      double precision time,zpos,trad_bc_ev,opac,alpha,
     1                 erad,trad,trad_ev,tmat,tmat_ev,uans,vans

c..local variables
      double precision trad_bc,ener_in,xpos,epsilon,tau,ialpha,
     1                 usolution,vsolution

c..some physics
      double precision clight,ssol,asol,kev,rt3,a4,a4c
      parameter        (clight    = 2.99792458d10,
     1                  ssol      = 5.67051d-5,
     2                  asol      = 4.0d0 * ssol / clight,
     3                  kev       = 8.617385d-5,
     4                  rt3       = 1.7320508075688772d0,
     5                  a4        = 4.0d0*asol,
     6                  a4c       = a4 * clight)

c..derived parameters and conversion factors
      trad_bc = trad_bc_ev/kev
      ener_in = asol * trad_bc**4
      xpos    = rt3 * opac * zpos
      ialpha  = 1.0d0/alpha
      tau     = a4c * opac * ialpha * time
      epsilon = a4 * ialpha

c..get the dimensionless solutions
      uans = usolution(xpos,tau,epsilon)
      vans = vsolution(xpos,tau,epsilon,uans)

c..compute the physical solution

      erad    = uans * ener_in
      trad    = (erad/asol)**(0.25d0)
      trad_ev = trad * kev

      tmat    = (vans*ener_in/asol)**(0.25d0)
      tmat_ev = tmat * kev

      return
      end

      double precision function usolution(posx_in,tau_in,epsilon_in)
      implicit none
      save

c..computes the u solution for the su-olson problem

c..declare the pass
      double precision posx_in,tau_in,epsilon_in

c..common block communication
      double precision posx,tau,epsilon
      common  /bdoor/  posx,tau,epsilon
      integer         jwant
      common /rots/   jwant

c..local variables
      external         midpnt,upart1,upart2,
     1                 gamma_one_root,gamma_two_root
      logical          bracket
      integer          i,niter
      double precision xi1,xi2,midpnt,upart1,upart2,sum1,sum2,
     1                 gamma_one_root,gamma_two_root,
     2                 zbrent,eta_hi,eta_lo,eta_int

      double precision tol,eps,eps2,pi,rt3,rt3opi
      parameter        (tol    = 1.0d-6,
     &                  eps    = 1.0d-10,
     &                  eps2   = 1.0d-8,
     &                  pi     = 3.1415926535897932384d0,
     &                  rt3    = 1.7320508075688772d0,
     &                  rt3opi = rt3/pi)

c..transfer input to common block
      posx    = posx_in
      tau     = tau_in
      epsilon = epsilon_in

c..integrand may not oscillate for small values of posx
      eta_lo  = 0.0d0
      eta_hi  = 1.0d0
      sum1    = 0.0d0
      jwant   = 1
      bracket = (gamma_one_root(eta_lo)*gamma_one_root(eta_hi).le.0.0)
      if (.not.bracket) then
       call qromo(upart1,eta_lo,eta_hi,eps,sum1,midpnt)

c..integrate over each oscillitory piece
      else
       do i=1,100
        jwant = i
        eta_int = zbrent(gamma_one_root,eta_lo,eta_hi,tol,niter)
        call qromo(upart1,eta_lo,eta_int,eps,xi1,midpnt)
        sum1  = sum1 + xi1
        eta_lo = eta_int
        if (abs(xi1) .le. eps2) goto 10
       enddo
 10    continue
      end if

c..integrand may not oscillate for small values of posx
      eta_lo = 0.0d0
      eta_hi = 1.0d0
      sum2   = 0.0d0
      jwant   = 1
      bracket = (gamma_two_root(eta_lo)*gamma_two_root(eta_hi).le.0.0)
      if (.not.bracket) then
       call qromo(upart2,eta_lo,eta_hi,eps,sum2,midpnt)

c..integrate from hi to lo on this piece
      else
       do i=1,100
        jwant = i
        eta_int = zbrent(gamma_two_root,eta_hi,eta_lo,tol,niter)
        call qromo(upart2,eta_hi,eta_int,eps,xi2,midpnt)
        sum2  = sum2 + xi2
        eta_hi = eta_int
        if (abs(xi2) .le. eps2) goto 20
       enddo
 20    continue
       sum2 = -sum2
      endif

c..done
      usolution = 1.0d0 - 2.0d0*rt3opi*sum1 - rt3opi*exp(-tau)*sum2
      return
      end

      double precision function vsolution(posx_in,tau_in,epsilon_in,
     1                                    uans)
      implicit none
      save

c..computes the v solution for the su-olson problem

c..declare the pass
      double precision posx_in,tau_in,epsilon_in,uans

c..common block communication
      double precision posx,tau,epsilon
      common  /bdoor/  posx,tau,epsilon
      integer         jwant
      common /rots/   jwant

c..local variables
      external         midpnt,vpart1,vpart2,
     1                 gamma_two_root,gamma_three_root
      logical          bracket
      integer          i,niter
      double precision xi1,xi2,midpnt,vpart1,vpart2,sum1,sum2,
     1                 gamma_two_root,gamma_three_root,
     2                 zbrent,eta_hi,eta_lo,eta_int

      double precision tol,eps,eps2,pi,rt3,rt3opi
      parameter        (tol    = 1.0d-6,
     &                  eps    = 1.0d-10,
     &                  eps2   = 1.0d-8,
     &                  pi  = 3.1415926535897932384d0,
     &                  rt3 = 1.7320508075688772d0,
     &                  rt3opi = rt3/pi)

c..transfer input to common block
      posx    = posx_in
      tau     = tau_in
      epsilon = epsilon_in

c..integrand may not oscillate for small values of posx
      eta_lo  = 0.0d0
      eta_hi  = 1.0d0
      sum1    = 0.0d0
      jwant   = 1
      bracket = (gamma_three_root(eta_lo)*gamma_three_root(eta_hi)
     1           .le. 0.0)
      if (.not.bracket) then
       call qromo(vpart1,eta_lo,eta_hi,eps,sum1,midpnt)

c..integrate over each oscillitory piece
c..from 1 to 0 on this part; this one really oscillates
      else
       do i=1,100
        jwant = i
        eta_int = zbrent(gamma_three_root,eta_hi,eta_lo,tol,niter)
        call qromo(vpart1,eta_hi,eta_int,eps,xi1,midpnt)
        sum1  = sum1 + xi1
        eta_hi = eta_int
        if (abs(xi1) .le. eps2) goto 10
       enddo
 10    continue
       sum1 = -sum1
      end if

c..integrand may not oscillate for small values of posx
      eta_lo = 0.0d0
      eta_hi = 1.0d0
      sum2   = 0.0d0
      jwant   = 1
      bracket = (gamma_two_root(eta_lo)*gamma_two_root(eta_hi).le.0.0)
      if (.not.bracket) then
       call qromo(vpart2,eta_lo,eta_hi,eps,sum2,midpnt)

c..integrate over each oscillitory piece
c..from 1 to 0 on this part; this one really oscillates
      else
       do i=1,100
        jwant = i
        eta_int = zbrent(gamma_two_root,eta_hi,eta_lo,tol,niter)
        call qromo(vpart2,eta_hi,eta_int,eps,xi2,midpnt)
        sum2  = sum2 + xi2
        eta_hi = eta_int
        if (abs(xi2) .le. eps2) goto 20
       enddo
 20    continue
       sum2 = -sum2
      endif

c..done
      vsolution = uans - 2.0d0*rt3opi*sum1 + rt3opi*exp(-tau)*sum2
      return
      end

      double precision function upart1(eta)
      implicit none
      save

c..equation 36 of su & olson jqsrt 1996, first integrand

c..declare the pass
      double precision eta

c..common block communication
      double precision posx,tau,epsilon
      common  /bdoor/  posx,tau,epsilon

c..local variables
      double precision numer,denom,gamma_one,theta_one,tiny
      parameter        (tiny = 1.0d-14)

      numer = sin(posx*gamma_one(eta,epsilon) + theta_one(eta,epsilon))

      denom = eta * sqrt(3.0d0 + 4.0d0*gamma_one(eta,epsilon)**2)
      denom = max(tiny,denom)

      upart1= exp(-tau*eta*eta) * numer/denom

      return
      end

      double precision function upart2(eta)
      implicit none
      save

c..equation 36 of su & olson jqsrt 1996, second integrand

c..declare the pass
      double precision eta

c..common block communication
      double precision posx,tau,epsilon
      common  /bdoor/  posx,tau,epsilon

c..local variables
      double precision numer,denom,gamma_two,theta_two,tiny
      parameter        (tiny = 1.0d-14)

      numer = sin(posx*gamma_two(eta,epsilon) + theta_two(eta,epsilon))

      denom = eta * (1.0d0 + epsilon*eta) *
     &        sqrt(3.0d0 + 4.0d0*gamma_two(eta,epsilon)**2)
      denom = max(tiny,denom)

      upart2= exp(-tau/(max(tiny,eta*epsilon))) * numer/denom

      return
      end

      double precision function vpart1(eta)
      implicit none
      save

c..equation 42 of su & olson jqsrt 1996, first integrand

c..declare the pass
      double precision eta

c..common block communication
      double precision posx,tau,epsilon
      common  /bdoor/  posx,tau,epsilon

c..local variables
      double precision numer,denom,gamma_two,theta_two,
     &                 gamma_three,theta_three,eta2,tiny
      parameter        (tiny = 1.0d-14)

      eta2   = eta * eta

      numer  = sin(posx*gamma_three(eta,epsilon) +
     &             theta_three(eta,epsilon))

      denom  = sqrt(4.0d0 - eta2 + 4.0d0*epsilon*eta2*(1.0d0 - eta2))
      denom  = max(tiny,denom)

      vpart1 = exp(-tau*(1.0d0 - eta2)) * numer/denom

      return
      end

      double precision function vpart2(eta)
      implicit none
      save

c..equation 42 of su & olson jqsrt 1996, second integrand

c..declare the pass
      double precision eta

c..common block communication
      double precision posx,tau,epsilon
      common  /bdoor/  posx,tau,epsilon

c..local variables
      double precision numer,denom,gamma_two,theta_two,tiny
      parameter        (tiny = 1.0d-14)

      numer = sin(posx*gamma_two(eta,epsilon) + theta_two(eta,epsilon))

      denom = eta * sqrt(3.0d0 + 4.0d0*gamma_two(eta,epsilon)**2)
      denom = max(tiny,denom)

      vpart2= exp(-tau/(max(tiny,eta*epsilon))) * numer/denom

      return
      end

      double precision function gamma_one_root(eta_in)
      implicit none
      save

c..used by a root finder to determine the integration inveral

c..declare the pass
      double precision eta_in

c..common block communication
      double precision posx,tau,epsilon
      common  /bdoor/  posx,tau,epsilon
      integer         jwant
      common /rots/   jwant

c..local variables
      double precision gamma_one,theta_one,pi,twopi
      parameter        (pi  = 3.1415926535897932384d0,
     1                  twopi = 2.0d0*pi)

c      write(6,*) eta_in,posx,tau,epsilon
c      write(6,*) jwant
c      write(6,*) gamma_one(eta_in,epsilon),theta_one(eta_in,epsilon)

c..go
      gamma_one_root = gamma_one(eta_in,epsilon)*posx
     &                 + theta_one(eta_in,epsilon)
     &                 - jwant * twopi

c      write(6,*) gamma_one_root
c      read(5,*)

      return
      end

      double precision function gamma_two_root(eta_in)
      implicit none
      save

c..used by a root finder to determine the integration inveral

c..declare the pass
      double precision eta_in

c..common block communication
      double precision posx,tau,epsilon
      common  /bdoor/  posx,tau,epsilon

      integer         jwant
      common /rots/   jwant

c..local variables
      double precision gamma_two,theta_two,pi,twopi
      parameter        (pi  = 3.1415926535897932384d0,
     1                  twopi = 2.0d0*pi)

c..go
      gamma_two_root = gamma_two(eta_in,epsilon)*posx
     &                 + theta_two(eta_in,epsilon)
     &                 - jwant * twopi

      return
      end

      double precision function gamma_three_root(eta_in)
      implicit none
      save

c..used by a root finder to determine the integration inveral

c..declare the pass
      double precision eta_in

c..common block communication
      double precision posx,tau,epsilon
      common  /bdoor/  posx,tau,epsilon

      integer         jwant
      common /rots/   jwant

c..local variables
      double precision gamma_three,theta_three,pi,twopi
      parameter        (pi  = 3.1415926535897932384d0,
     1                  twopi = 2.0d0*pi)

c..go
      gamma_three_root = gamma_three(eta_in,epsilon)*posx
     &                 + theta_three(eta_in,epsilon)
     &                 - jwant * twopi

      return
      end

      double precision function theta_one(eta,epsilon)
      implicit none
      save

c..equation 38 of su & olson jqsrt 1996

c..declare the pass
      double precision eta,epsilon

c..local variables
      double precision gamma_one

      theta_one = acos(sqrt(3.0d0 /
     &                 (3.0d0 + 4.0d0*gamma_one(eta,epsilon)**2)))

      return
      end

      double precision function theta_two(eta,epsilon)
      implicit none
      save

c..equation 38 of su & olson jqsrt 1996

c..declare the pass
      double precision eta,epsilon

c..local variables
      double precision gamma_two

      theta_two = acos(sqrt(3.0d0 /
     &                 (3.0d0 + 4.0d0*gamma_two(eta,epsilon)**2)))

      return
      end

      double precision function theta_three(eta,epsilon)
      implicit none
      save

c..equation 43 of su & olson jqsrt 1996

c..declare the pass
      double precision eta,epsilon

c..local variables
      double precision gamma_three

      theta_three = acos(sqrt(3.0d0 /
     &                 (3.0d0 + 4.0d0*gamma_three(eta,epsilon)**2)))

      return
      end

      double precision function gamma_one(eta,epsilon)
      implicit none
      save

c..equation 37 of su & olson jqsrt 1996

c..declare the pass
      double precision eta,epsilon

c..local variables
      double precision ein,tiny
      parameter        (tiny = 1.0d-14)

      ein = max(tiny,min(eta,1.0d0-tiny))
      gamma_one = ein * sqrt(epsilon + 1.0d0/(1.0d0 - ein*ein))

      return
      end

      double precision function gamma_two(eta,epsilon)
      implicit none
      save

c..equation 37 of su & olson jqsrt 1996

c..declare the pass
      double precision eta,epsilon

c..local variables
      double precision ein,tiny
      parameter        (tiny = 1.0d-14)

      ein = max(tiny,min(eta,1.0d0-tiny))
      gamma_two = sqrt((1.0d0 - ein) * (epsilon + 1.0d0/ein))

      return
      end

      double precision function gamma_three(eta,epsilon)
      implicit none
      save

c..equation 43 of su & olson jqsrt 1996

c..declare the pass
      double precision eta,epsilon

c..local variables
      double precision ein,tiny
      parameter        (tiny = 1.0d-14)

      ein = max(tiny,min(eta,1.0d0-tiny))
      gamma_three = sqrt((1.0d0 - ein*ein)*(epsilon + 1.0d0/(ein*ein)))

      return
      end

      subroutine midpnt(func,a,b,s,n)
      implicit none
      save

c..this routine computes the n'th stage of refinement of an extended midpoint
c..rule. func is input as the name of the function to be integrated between
c..limits a and b. when called with n=1, the routine returns as s the crudest
c..estimate of the integralof func from a to b. subsequent calls with n=2,3...
c..improve the accuracy of s by adding 2/3*3**(n-1) addtional interior points.

c..declare
      external          func
      integer           n,it,j
      double precision  func,a,b,s,tnm,del,ddel,x,sum

      if (n.eq.1) then
       s  = (b-a) * func(0.5d0*(a+b))
      else
       it   = 3**(n-2)
       tnm  = it
       del  = (b-a)/(3.0d0*tnm)
       ddel = del + del
       x    = a + (0.5d0 * del)
       sum  = 0.0d0
       do j=1,it
        sum = sum + func(x)
        x   = x + ddel
        sum = sum + func(x)
        x   = x + del
       enddo
       s  = (s + ((b-a) * sum/tnm)) / 3.0d0
      end if
      return
      end

      subroutine qromo(func,a,b,eps,ss,choose)
      implicit none
      save

c..this routine returns as s the integral of the function func from a to b
c..with fractional accuracy eps.
c..jmax limits the number of steps; nsteps = 3**(jmax-1)
c..integration is done via romberg algorithm.

c..it is assumed the call to choose triples the number of steps on each call
c..and that its error series contains only even powers of the number of steps.
c..the external choose may be any of the above drivers, i.e midpnt,midinf...

c..declare
      external          choose,func
      integer           j,jmax,jmaxp,k,km
      parameter         (jmax=14, jmaxp=jmax+1, k=5, km=k-1)
      double precision  a,b,ss,s(jmaxp),h(jmaxp),eps,dss,func

      h(1) = 1.0d0
      do j=1,jmax
       call choose(func,a,b,s(j),j)
       if (j .ge. k) then
        call polint(h(j-km),s(j-km),k,0.0d0,ss,dss)
        if (abs(dss) .le. eps*abs(ss)) return
       end if
       s(j+1) = s(j)
       h(j+1) = h(j)/9.0d0
      enddo
c      write(6,*)  'too many steps in qromo'
      return
      end

      subroutine polint(xa,ya,n,x,y,dy)
      implicit none
      save

c..given arrays xa and ya of length n and a value x, this routine returns a
c..value y and an error estimate dy. if p(x) is the polynomial of degree n-1
c..such that ya = p(xa) ya then the returned value is y = p(x)

c..declare
      integer          n,nmax,ns,i,m
      parameter        (nmax=10)
      double precision xa(n),ya(n),x,y,dy,c(nmax),d(nmax),dif,dift,
     1                 ho,hp,w,den

c..find the index ns of the closest table entry; initialize the c and d tables
      ns  = 1
      dif = abs(x - xa(1))
      do i=1,n
       dift = abs(x - xa(i))
       if (dift .lt. dif) then
        ns  = i
        dif = dift
       end if
       c(i)  = ya(i)
       d(i)  = ya(i)
      enddo

c..first guess for y
      y = ya(ns)

c..for each column of the table, loop over the c's and d's and update them
      ns = ns - 1
      do m=1,n-1
       do i=1,n-m
        ho   = xa(i) - x
        hp   = xa(i+m) - x
        w    = c(i+1) - d(i)
        den  = ho - hp
        if (den .eq. 0.0) stop ' 2 xa entries are the same in polint'
        den  = w/den
        d(i) = hp * den
        c(i) = ho * den
       enddo

c..after each column is completed, decide which correction c or d, to add
c..to the accumulating value of y, that is, which path to take in the table
c..by forking up or down. ns is updated as we go to keep track of where we
c..are. the last dy added is the error indicator.
       if (2*ns .lt. n-m) then
        dy = c(ns+1)
       else
        dy = d(ns)
        ns = ns - 1
       end if
       y = y + dy
      enddo
      return
      end

      double precision function zbrent(func,x1,x2,tol,niter)
      implicit none
      save

c..using brent's method this routine finds the root of a function func
c..between the limits x1 and x2. the root is when accuracy is less than tol.
c..
c..note: eps the the machine floating point precision

c..declare
      external          func
      integer           niter,itmax,iter
      parameter         (itmax = 100)
      double precision  func,x1,x2,tol,a,b,c,d,e,fa,
     1                  fb,fc,xm,tol1,p,q,r,s,eps
      parameter         (eps=3.0d-15)

c..initialize
      niter = 0
      a     = x1
      b     = x2
      fa    = func(a)
      fb    = func(b)
      if ( (fa .gt. 0.0  .and. fb .gt. 0.0)  .or.
     1     (fa .lt. 0.0  .and. fb .lt. 0.0)       ) then
       write(6,100) x1,fa,x2,fb
100    format(1x,' x1=',1pe11.3,' f(x1)=',1pe11.3,/,
     1        1x,' x2=',1pe11.3,' f(x2)=',1pe11.3)
       stop 'root not bracketed in routine zbrent'
      end if
      c  = b
      fc = fb

c..rename a,b,c and adjusting bound interval d
      do iter =1,itmax
       niter = niter + 1
       if ( (fb .gt. 0.0  .and. fc .gt. 0.0)  .or.
     1      (fb .lt. 0.0  .and. fc .lt. 0.0)      ) then
        c  = a
        fc = fa
        d  = b-a
        e  = d
       end if
       if (abs(fc) .lt. abs(fb)) then
        a  = b
        b  = c
        c  = a
        fa = fb
        fb = fc
        fc = fa
       end if
       tol1 = 2.0d0 * eps * abs(b) + 0.5d0 * tol
       xm   = 0.5d0 * (c-b)

c..convergence check
       if (abs(xm) .le. tol1 .or. fb .eq. 0.0) then
        zbrent = b
        return
       end if

c..attempt quadratic interpolation
       if (abs(e) .ge. tol1 .and. abs(fa) .gt. abs(fb)) then
        s = fb/fa
        if (a .eq. c) then
         p = 2.0d0 * xm * s
         q = 1.0d0 - s
        else
         q = fa/fc
         r = fb/fc
         p = s * (2.0d0 * xm * q *(q-r) - (b-a)*(r - 1.0d0))
         q = (q - 1.0d0) * (r - 1.0d0) * (s - 1.0d0)
        end if

c..check if in bounds
        if (p .gt. 0.0) q = -q
        p = abs(p)

c..accept interpolation
        if (2.0d0*p .lt. min(3.0d0*xm*q - abs(tol1*q),abs(e*q))) then
         e = d
         d = p/q

c..or bisect
        else
         d = xm
         e = d
        end if

c..bounds decreasing to slowly use bisection
       else
        d = xm
        e = d
       end if

c..move best guess to a
       a  = b
       fa = fb
       if (abs(d) .gt. tol1) then
        b = b + d
       else
        b = b + sign(tol1,xm)
       end if
       fb = func(b)
      enddo
      stop 'too many iterations in routine zbrent'
      end

      double precision function value(string)
      implicit none
      save

c..this routine takes a character string and converts it to a real number.
c..on error during the conversion, a fortran stop is issued

c..declare
      logical          pflag
      character*(*)    string
      character*1      plus,minus,decmal,blank,se,sd,se1,sd1
      integer          noblnk,long,ipoint,power,psign,iten,j,z,i
      double precision x,sign,factor,rten,temp
      parameter        (plus = '+'  , minus = '-' , decmal = '.'   ,
     1                  blank = ' ' , se = 'e'    , sd = 'd'       ,
     2                  se1 = 'E'   , sd1 = 'D'   , rten =  10.0,
     3                  iten = 10                                   )

c..initialize
      x      =  0.0d0
      sign   =  1.0d0
      factor =  rten
      pflag  =  .false.
      noblnk =  0
      power  =  0
      psign  =  1
      long   =  len(string)

c..remove any leading blanks and get the sign of the number
      do z = 1,7
       noblnk = noblnk + 1
       if ( string(noblnk:noblnk) .eq. blank) then
        if (noblnk .gt. 6 ) goto  30
       else
        if (string(noblnk:noblnk) .eq. plus) then
         noblnk = noblnk + 1
        else if (string(noblnk:noblnk) .eq. minus) then
         noblnk = noblnk + 1
         sign =  -1.0d0
        end if
        goto 10
       end if
      enddo

c..main number conversion loop
 10   continue
      do i = noblnk,long
       ipoint = i + 1

c..if a blank character then we are done
       if ( string(i:i) .eq. blank ) then
        x     = x * sign
        value = x
        return

c..if an exponent character, process the whole exponent, and return
       else if (string(i:i).eq.se  .or. string(i:i).eq.sd .or.
     1          string(i:i).eq.se1 .or. string(i:i).eq.sd1   ) then
        if (x .eq. 0.0 .and. ipoint.eq.2)     x = 1.0d0
        if (sign .eq. -1.0 .and. ipoint.eq.3) x = 1.0d0
        if (string(ipoint:ipoint) .eq. plus) ipoint = ipoint + 1
        if (string(ipoint:ipoint) .eq. minus) then
         ipoint = ipoint + 1
         psign = -1
        end if
        do z = ipoint,long
         if (string(z:z) .eq. blank)  then
          x = sign * x * rten**(power*psign)
          value = x
          return
         else
          j = ichar(string(z:z)) - 48
          if ( (j.lt.0) .or. (j.gt.9) ) goto 30
          power= (power * iten)  + j
         end if
        enddo

c..if an ascii number character, process ie
       else if (string(i:i) .ne. decmal) then
        j = ichar(string(i:i)) - 48
        if ( (j.lt.0) .or. (j.gt.9) ) goto 30
        if (.not.(pflag) ) then
         x = (x*rten) + j
        else
         temp   = j
         x      = x + (temp/factor)
         factor = factor * rten
         goto 20
        end if

c..must be a decimal point if none of the above
c..check that there are not two decimal points!
       else
        if (pflag) goto 30
        pflag = .true.
       end if
 20   continue
      end do

c..if we got through the do loop ok, then we must be done
      x     = x * sign
      value = x
      return

c..error processing the number
 30   write(6,40) long,string(1:long)
 40   format(' error converting the ',i4,' characters ',/,
     1       ' >',a,'< ',/,
     2       ' into a real number in function value')
      stop ' error in routine value'
      end


!***********************************************************************
!                                                                      *
      SUBROUTINE GETCPR(RRMS, APARM, CPARM)
!                                                                      *
!   Determines the parameter `c' (CPARM) for a Fermi nucleus,  given   *
!   the root mean square radius (RRMS) and the parameter `a' (APARM).  *
!   We use the formalism developed in F. A. Parpia and A. K. Mohanty   *
!   ``Relativistic basis set  calculations for atoms with  Fermi nu-   *
!   clei'' Phys Rev A (1992) in press.                                 *
!                                                                      *
!   Call(s) to: ESTRMS.                                                *
!                                                                      *
!   Written by Farid A. Parpia            Last revision: 16 Oct 1994   *
!                                                                      *
!***********************************************************************
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  13:31:28   1/ 3/07
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE estrms_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(DOUBLE) , INTENT(IN) :: RRMS
      REAL(DOUBLE)  :: APARM
      REAL(DOUBLE) , INTENT(OUT) :: CPARM
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(DOUBLE) :: ACCY, CPMIN, CPMAX, CPTRY, RMSTRY
!-----------------------------------------------
!
!xhb
!xh Accuracy parameter
!xhe
      ACCY = 1.0D-12
!
!   Bracket CPARM with a lower and upper limit
!
!   Lower limit
!
      CPMIN = RRMS
      CPMIN = 0.5D00*CPMIN
      DO WHILE(ESTRMS(APARM,CPMIN) > RRMS)
         CPMIN = 0.5D00*CPMIN
      END DO
!
!   Upper limit
!
      CPMAX = RRMS
      CPMAX = 2.0D00*CPMAX
      DO WHILE(ESTRMS(APARM,CPMAX) < RRMS)
         CPMAX = 2.0D00*CPMAX
      END DO
!
!   Find CPARM by the method of bisection
!
      CPTRY = 0.5D00*(CPMAX + CPMIN)
!
      RMSTRY = ESTRMS(APARM,CPTRY)
!
      IF (RMSTRY > RRMS) THEN
         CPMAX = CPTRY
      ELSE
         CPMIN = CPTRY
      ENDIF
      DO WHILE((CPMAX - CPMIN)/(CPMAX + CPMIN)>ACCY .AND. ABS(RMSTRY-RRMS)/RRMS&
         >ACCY)
         CPTRY = 0.5D00*(CPMAX + CPMIN)
!
         RMSTRY = ESTRMS(APARM,CPTRY)
!
         IF (RMSTRY > RRMS) THEN
            CPMAX = CPTRY
         ELSE
            CPMIN = CPTRY
         ENDIF
!
      END DO
!
      CPARM = CPTRY
!
      RETURN
      END SUBROUTINE GETCPR


	function dclog(z1)
	double complex z1, z2, dclog
	double precision a,b,c
	double precision dummy(2)
	equivalence (a,z2,dummy(1)), (b,dummy(2))

	z2=z1
	c=dcabs(z2)
	b=datan2(b,a)
	a=dlog(c)
	dclog=z2
	return
	end


program test_sto_hm
use types, only: dp
use sto, only: stoints2, get_basis2
use utils, only: assert
use radialscf, only: doscf, kinetic_energy
use hfprint, only: printall, printlam
implicit none

integer, allocatable :: nl(:, :), nbfl(:)
real(dp), allocatable :: zl(:, :), focc(:, :)

real(dp), allocatable :: S(:, :, :), T(:, :, :), V(:, :, :), slater(:, :)
integer :: n, Z, m, Nscf, Lmax, ndof
real(dp) :: alpha, Etot, tolE, tolP, Ekin
real(dp), allocatable :: H(:, :, :), P_(:, :, :), C(:, :, :), lam(:, :)

allocate(nbfl(0:2), nl(5, 0:2), zl(5, 0:2), focc(2, 0:2))
nbfl = 0
focc = 0
focc(1, 0) = 2
nbfl(0) = 5
nl(:5, 0) = [1, 1, 2, 3, 3]
zl(:5, 0) = [0.28382_dp, 0.51444_dp, 0.8525_dp, 0.79958_dp, 1.09728_dp]
nbfl(1) = 4
nl(:4, 1) = [2, 2, 3, 4]
zl(:4, 1) = [0.103336_dp, 0.145652_dp, 0.221232_dp, 0.228868_dp] * 5
nbfl(2) = 3
nl(:3, 2) = [3, 3, 4]
zl(:3, 2) = [0.14546_dp, 0.193412_dp, 0.278776_dp] * 5

Z = 1
tolE = 1e-8_dp
tolP = 1e-4_dp
alpha = 0.6_dp
Nscf = 100

n = maxval(nbfl)
Lmax = ubound(nbfl, 1)
ndof = sum(nbfl)
print *, "total  DOFs =", ndof
allocate(H(n, n, 0:Lmax), S(n, n, 0:Lmax), T(n, n, 0:Lmax), V(n, n, 0:Lmax))
m = ndof*(ndof+1)/2
allocate(slater(m*(m+1)/2, 0:2*Lmax))
call stoints2(Z, nbfl, nl, zl, S, T, V, slater)

allocate(P_(n, n, 0:Lmax), C(n, n, 0:Lmax), lam(n, 0:Lmax))

H = T + V

print *, "SCF cycle:"
call doscf(nbfl, H, slater, S, focc, Nscf, tolE, tolP, alpha, C, P_, lam, Etot)
Ekin = kinetic_energy(nbfl, P_, T)
call printall(nbfl, nl, zl, lam, C, Ekin, Etot)
call printlam(nbfl, lam, Ekin, Etot)

call assert(abs(Etot - (-0.48789731_dp)) < 1e-8_dp)
call assert(all(abs(lam(:, 0) - [-0.046227_dp, 0.126799_dp, 0.342570_dp, &
    0.914781_dp, 4.111577_dp]) < 1e-6_dp))
call assert(all(abs(lam(:4, 1) - [0.186112_dp, 0.422181_dp, 0.964922_dp, &
    2.399488_dp]) < 1e-6_dp))
call assert(all(abs(lam(:3, 2) - [0.325247_dp, 0.966288_dp, &
    2.656610_dp]) < 1e-6_dp))

end program


program test
      integer :: i,j
      ! change to complex(4) and it will pass.
      !l ikely complex8 atomic issue
      complex(8) :: M,N
      complex(8),pointer :: A(:)

      allocate(A(10))
      M=(0,0)

      do i=1, 10
        A(i)=(1,1)
      enddo

!$omp target  parallel do map(to:A) map(tofrom:M) reduction(+:M)
!!$omp target  parallel do map(to:A) map(tofrom:M) private(N) reduction(+:M)
      do i=1, 10
        N=(0,0)
        do j=1, 10
          N=N+A(j)
        enddo
        M=M+N
      enddo
!$omp end target parallel do

      write(*, *), "M=", M

end program test


*DECK D9LGMC
      DOUBLE PRECISION FUNCTION D9LGMC (X)
C***BEGIN PROLOGUE  D9LGMC
C***SUBSIDIARY
C***PURPOSE  Compute the log Gamma correction factor so that
C            LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X
C            + D9LGMC(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      DOUBLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB,
C             LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the log gamma correction factor for X .GE. 10. so that
C LOG (DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + D9lGMC(X)
C
C Series for ALGM       on the interval  0.          to  1.00000E-02
C                                        with weighted error   1.28E-31
C                                         log weighted error  30.89
C                               significant figures required  29.81
C                                    decimal places required  31.48
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  D9LGMC
      DOUBLE PRECISION X, ALGMCS(15), XBIG, XMAX, DCSEVL, D1MACH
      LOGICAL FIRST
      SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST
      DATA ALGMCS(  1) / +.1666389480 4518632472 0572965082 2 D+0      /
      DATA ALGMCS(  2) / -.1384948176 0675638407 3298605913 5 D-4      /
      DATA ALGMCS(  3) / +.9810825646 9247294261 5717154748 7 D-8      /
      DATA ALGMCS(  4) / -.1809129475 5724941942 6330626671 9 D-10     /
      DATA ALGMCS(  5) / +.6221098041 8926052271 2601554341 6 D-13     /
      DATA ALGMCS(  6) / -.3399615005 4177219443 0333059966 6 D-15     /
      DATA ALGMCS(  7) / +.2683181998 4826987489 5753884666 6 D-17     /
      DATA ALGMCS(  8) / -.2868042435 3346432841 4462239999 9 D-19     /
      DATA ALGMCS(  9) / +.3962837061 0464348036 7930666666 6 D-21     /
      DATA ALGMCS( 10) / -.6831888753 9857668701 1199999999 9 D-23     /
      DATA ALGMCS( 11) / +.1429227355 9424981475 7333333333 3 D-24     /
      DATA ALGMCS( 12) / -.3547598158 1010705471 9999999999 9 D-26     /
      DATA ALGMCS( 13) / +.1025680058 0104709120 0000000000 0 D-27     /
      DATA ALGMCS( 14) / -.3401102254 3167487999 9999999999 9 D-29     /
      DATA ALGMCS( 15) / +.1276642195 6300629333 3333333333 3 D-30     /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  D9LGMC
      IF (FIRST) THEN
         NALGM = INITDS (ALGMCS, 15, REAL(D1MACH(3)) )
         XBIG = 1.0D0/SQRT(D1MACH(3))
         XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1))))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 10.D0) CALL XERMSG ('SLATEC', 'D9LGMC',
     +   'X MUST BE GE 10', 1, 2)
      IF (X.GE.XMAX) GO TO 20
C
      D9LGMC = 1.D0/(12.D0*X)
      IF (X.LT.XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS,
     1  NALGM) / X
      RETURN
C
 20   D9LGMC = 0.D0
      CALL XERMSG ('SLATEC', 'D9LGMC', 'X SO BIG D9LGMC UNDERFLOWS', 2,
     +   1)
      RETURN
C
      END


!##############################################################################
!# ****************************************************************************
!# <name> basisdump </name>
!# ****************************************************************************
!#
!# <purpose>
!#
!# </purpose>
!##############################################################################

program basisdump

  use fparser
  use fsystem
  use genoutput
  use storage
  use paramlist
  use basicgeometry
  use triangulation
  use transformation
  use derivatives
  use element
  use elementpreprocessing
  use spdiscprojection
  use ucd

  implicit none

  type(t_parlist) :: rparam
  type(t_triangulation) :: rtria, rtriaDump
  type(t_evalElementSet) :: reval
  integer :: nref, nbasis, nverts, ibas, ivt, ndone, ntodo, nmaxDer, ider
  integer(I32) :: celement, cshape, cevalTag, ctrafoType
  real(DP), dimension(:,:), pointer :: p_Dvtx
  real(DP), dimension(:,:,:), pointer :: p_Dphi
  integer, dimension(1), parameter :: IelList = (/1/)
  real(DP), dimension(:,:,:,:), pointer :: p_Dbas
  logical, dimension(EL_MAXNDER) :: Bder
  character(len=SYS_STRLEN) :: selement, spredir, sucddir
  type(t_ucdExport) :: rexport

  ! The very first thing in every application:
  ! Initialise system-wide settings:
  call sys_init()

  ! The very second thing in every program:
  ! Initialise the FEAT 2.0 storage management:
  call storage_init(999, 100)

  ! Initialise function parser
  call fparser_init()

  if (sys_ncommandLineArgs() .lt. 2) then
    call output_line('USAGE: basisdump <element>')
    call exit
  end if

  ! fetch element name
  call getarg(1, selement)

  ! parse the element id
  celement = elem_igetID(selement)

  ! fetch the element shape
  cshape = elem_igetShape(celement)

  ! Read in reference mesh
  call output_line("Creating meshes...")
  call createRefMesh(rtria, cshape)
  call tria_initStandardMeshFromRaw(rtria)

  ! select number of refinements depending on dimension
  select case(rtria%ndim)
  case (1)
    nref = 9
  case (2)
    nref = 7
  case (3)
    nref = 5
  end select

  ! Refine unto dump level
  call tria_refine2LevelOrdering(rtria, rtriaDump)
  call tria_quickRefine2LevelOrdering (nref-1, rtriaDump)
  call tria_initStandardMeshFromRaw(rtriaDump)

  ! Fetch the vertex-coordinates array from the dump triangulation
  call output_line("Preparing for element evaluation...")
  call storage_getbase_double2d(rtriaDump%h_DvertexCoords, p_Dvtx)
  nverts = rtriaDump%NVT

  ! fetch the number of basis function
  nbasis = elem_igetNDofLoc(celement)

  ! define the evaluation tag
  cevalTag = ior(EL_EVLTAG_REFPOINTS, elem_getEvaluationTag(celement))

  ! fetch the trafo type
  ctrafoType = elem_igetTrafoType(celement)

  ! fetch the maximum derivative
  nmaxDer = min(elem_getMaxDerivative(celement),1+rtria%ndim)

  ! set up bder
  Bder(:) = .false.
  Bder(1:nmaxDer) = .true.

  ! allocate a basis function array
  allocate(p_Dphi(nverts, nmaxDer, nbasis))

  ! allocate basis function evaluation array
  allocate(p_Dbas(nbasis,nmaxDer, 100, 1))

  call output_line("Evaluating basis functions...")
  ! start evaluating
  ! Notes:
  ! 1. We need to run over the dump-mesh vertices in small blocks, because some old
  !    element implementations cause stack overflows for a sufficiently large number
  !    of evaluation points.
  ! 2. We need to release and reinitialise the element evaluation structure in the
  !    last iteration of the loop, as otherwise the elprep_prepareSetForEvaluation
  !    routine will not recognise that the number of points is less than in the
  !    iterations before.
  ndone = 0
  do while(ndone .lt. nverts)

    ntodo = min(100, nverts - ndone)

    ! Define an element evaluation set
    call elprep_init(reval)

    ! prepare element set
    call elprep_prepareSetForEvaluation (reval, cevalTag, rtria, IelList, ctrafoType, &
        p_Dvtx(:,ndone+1:ndone+ntodo))

    ! evaluate
    call elem_generic_sim2 (celement, reval, Bder, p_Dbas)

    ! loop over all basis functions
    do ibas = 1, nbasis
      do ider = 1, nmaxDer
        do ivt = 1, ntodo
          p_Dphi(ndone+ivt, ider, ibas) = p_Dbas(ibas, ider, ivt, 1)
        end do
      end do
    end do

    ndone = ndone + ntodo

    ! release the element set in the last two iterations
    if(ndone + 100 .gt. nverts) &
      call elprep_releaseElementSet(reval)

  end do

  ! Start UCD export to VTK file:
  call output_line("Writing VTK file...")
  if (.not. sys_getenv_string("UCDDIR", sucddir)) sucddir = "./ucd"
  call ucd_startVTK (rexport, UCD_FLAG_STANDARD, rtriaDump, &
      trim(sucddir)//"/"//trim(selement)  // "_lvl" // trim(sys_sil(nref,4)) //".vtk")

  ! loop over all basis functions
  do ider = 1, nmaxDer
    do ibas = 1, nbasis
      ! write UCD variable
      call ucd_addVariableVertexBased (rexport, trim(funcName(ibas,ider)), p_Dphi(:,ider,ibas))
    end do
  end do

  ! write and close ucd
  call ucd_write (rexport)
  call ucd_release (rexport)

  call output_line("Cleaning up...")
  ! clean up
  deallocate(p_Dphi)
  deallocate(p_Dbas)
  call tria_done(rtriaDump)
  call tria_done(rtria)

  ! Clean up the storage management, finish
  call storage_done()

contains

  character(len=SYS_STRLEN) function funcName(ibas, ider)
  integer, intent(in) :: ibas, ider

    select case(ider)
    case (1)
      funcName = "phi_" // trim(sys_si0l(ibas,2))
    case (2)
      funcName = "dx-phi_" // trim(sys_si0l(ibas,2))
    case (3)
      funcName = "dy-phi_" // trim(sys_si0l(ibas,2))
    case (4)
      funcName = "dz-phi_" // trim(sys_si0l(ibas,2))
    end select
  end function

  subroutine createRefMesh(rtria, cshape)
  type(t_triangulation), intent(out) :: rtria
  integer(i32), intent(in) :: cshape

  integer :: i, nvc
  integer, dimension(1) :: Isize1
  integer, dimension(2) :: Isize2
  real(DP), dimension(:,:), pointer :: p_Dvtx, p_Dv2
  integer, dimension(:,:), pointer :: p_Ive
  integer, dimension(:), pointer :: p_Inp

    ! decode shape
    rtria%ndim = mod(int(cshape) / 1000000, 100)
    rtria%NVT  = mod(int(cshape)          , 100)
    rtria%NMT  = mod(int(cshape) /     100, 100)
    rtria%NAT  = mod(int(cshape) /   10000, 100)
    rtria%NEL  = 1
    rtria%NNVE = rtria%nvt
    rtria%NNEE = rtria%nmt
    rtria%NNAE = rtria%nat
    rtria%NBCT = 1

    rtria%InelOfType(rtria%NNVE) = 1

    select case(cshape)
    case (BGEOM_SHAPE_TRIA, BGEOM_SHAPE_TETRA)
      nvc = rtria%ndim + 1
    case default
      nvc = rtria%ndim
    end select

    Isize2 = (/rtria%ndim,rtria%NNVE/)
    call storage_new('createRefMesh', 'DvertexCoords', Isize2, &
        ST_DOUBLE, rtria%h_DvertexCoords, ST_NEWBLOCK_NOINIT)
    call storage_getbase_double2d(rtria%h_DvertexCoords, p_Dvtx)

    Isize2 = (/rtria%NNVE,1/)
    call storage_new('createRefMesh', 'IverticesAtElement', Isize2, &
        ST_INT, rtria%h_IverticesAtElement, ST_NEWBLOCK_NOINIT)
    call storage_getbase_int2d(rtria%h_IverticesAtElement, p_Ive)

    Isize1 = (/rtria%NNVE/)
    call storage_new('createRefMesh', 'InodalProperty', Isize1, &
        ST_INT, rtria%h_InodalProperty, ST_NEWBLOCK_ZERO)
    call storage_getbase_int(rtria%h_InodalProperty, p_Inp)
    do i=1, rtria%NNVE
      p_Inp(i) = 1
    end do

    if(nvc .eq. rtria%ndim) then
      ! create corner vertices
      call spdp_aux_getCornerRefCoords(p_Dvtx, rtria%ndim, rtria%NNVE)
    else
      allocate(p_Dv2(nvc, rtria%NNVE))
      ! create corner vertices
      call spdp_aux_getCornerRefCoords(p_Dv2, rtria%ndim, rtria%NNVE)
      do i = 1, rtria%NNVE
        p_Dvtx(1:rtria%ndim, i) = p_Dv2(2:rtria%ndim+1, i)
      end do
      deallocate(p_Dv2)
    end if

    do i = 1, rtria%NNVE
      p_Ive(i,1) = i
    end do

    call tria_genRawBoundary2D(rtria)
    call tria_initExtendedRawMesh(rtria)

  end subroutine

end program


SUBROUTINE stages(iexit)

!-------------------------------------------------------------
!
! Using number of nodes input, determine the number of
!  V-Cycle stages and the coarsening factor (1,2,4) for each
!  stage in each direction.
!
!-------------------------------------------------------------

USE invar
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: iexit
INTEGER :: i, t, tt

! First compute the total number of stages, ns
t = MAXVAL([npx,npy,npz])
i = 1
tt = 1
DO
   IF (i < t) THEN
      i = 2*i
      tt = tt + 1
      CYCLE
   ELSE IF (i == t) THEN
      EXIT
   ELSE
      WRITE(8,'(/,3X,A)') "ERROR: Pi/Pj/Pk must be a power of 2."
      iexit = iexit + 1
      EXIT
   END IF
END DO
! Compute ns, including 1st coarsening step per processor
ns = 2 + (tt+1)/3
ns1 = ns - 1
ns2 = ns - 2

! Continue by determining the coarsening factors in each direction at each stage
! (if no error from before)
IF (iexit == 0) THEN
   ! Allocate the arrays that store the coarsening factors
   ! Index by zero to keep all the parallel parameters unaffected from PBJ code
   ALLOCATE(xcf(0:ns2),ycf(0:ns2),zcf(0:ns2))

   ! Set the first coarsening factor coarsen all the sub-domains per processor
   xcf(0) = nxsd
   ycf(0) = nysd
   zcf(0) = nzsd

   ! x-direction
   t = npx
   DO i = 1, ns2
      ! Coarsen by 8 if evenly divisible by 8
      IF (MOD(t,8) == 0) THEN
         xcf(i) = 8
         t = t/8
      ! Coarsen by 4 if evenly divisible by 4
      ELSE IF (MOD(t,4) == 0) THEN
         xcf(i) = 4
         t = t/4
      ! Coarsen by 2 if evenly divisible by 2
      ELSE IF (MOD(t,2) == 0) THEN
         xcf(i) = 2
         t = t/2
      ELSE
         ! No need to coarse if already down to P=1
         IF (t == 1) THEN
            xcf(i) = 1
         ! Exit loop if P is not a power of 2
         ELSE
            WRITE(8,'(/,3X,A)') "ERROR: Pi must be a power of 2."
            iexit = iexit + 1
            EXIT
         END IF
      END IF
   END DO

   ! y-direction
   t = npy
   DO i = 1, ns2
      ! Coarsen by 8 if evenly divisible by 8
      IF (MOD(t,8) == 0) THEN
         ycf(i) = 8
         t = t/8
      ! Coarsen by 4 if evenly divisible by 4
      ELSE IF (MOD(t,4) == 0) THEN
         ycf(i) = 4
         t = t/4
      ! Coarsen by 2 if evenly divisible by 2
      ELSE IF (MOD(t,2) == 0) THEN
         ycf(i) = 2
         t = t/2
      ELSE
         ! No need to coarse if already down to P=1
         IF (t == 1) THEN
            ycf(i) = 1
         ! Exit loop if P is not a power of 2
         ELSE
            WRITE(8,'(/,3X,A)') "ERROR: Pj must be a power of 2."
            iexit = iexit + 1
            EXIT
         END IF
      END IF
   END DO

   ! z-direction
   t = npz
   DO i = 1, ns2
      ! Coarsen by 8 if evenly divisible by 8
      IF (MOD(t,8) == 0) THEN
         zcf(i) = 8
         t = t/8
      ! Coarsen by 4 if evenly divisible by 4
      ELSE IF (MOD(t,4) == 0) THEN
         zcf(i) = 4
         t = t/4
      ! Coarsen by 2 if evenly divisible by 2
      ELSE IF (MOD(t,2) == 0) THEN
         zcf(i) = 2
         t = t/2
      ELSE
         ! No need to coarse if already down to P=1
         IF (t == 1) THEN
            zcf(i) = 1
         ! Exit loop if P is not a power of 2
         ELSE
            WRITE(8,'(/,3X,A)') "ERROR: Pk must be a power of 2."
            iexit = iexit + 1
            EXIT
         END IF
      END IF
   END DO
END IF

RETURN
END SUBROUTINE stages


!Simple program to get the scalar and tensor Cls, and print them out (and the sum)

      program tester
       use CAMB
        implicit none
        integer l
        real(dl) ratio

        type(CAMBparams)  P !defined in ModelParams in modules.f90

        call CAMB_SetDefParams(P)

        P%omegab  = .045
        P%omegac  = 0.355
        P%omegav  = 0.6
        P%omegan  = 0.0
        P%H0      = 65

        P%InitPower%nn     = 1 !number of initial power spectra
        P%InitPower%an(1)  = 1 !scalar spectral index
        P%InitPower%ant(1) = 0 !tensor spectra index
        P%InitPower%rat(1) = 1 !ratio of initial amplitudes
         !actually we don't use this here since we generate the Cls separately
         !so set to 1, and then put in the ratio after calculating the Cls

        P%OutputNormalization = outNone

        !Generate scalars first so that start with maximum Max_l that is used
        P%WantScalars = .true.
        P%WantTensors = .true.

        P%Max_l=1500
        P%Max_eta_k=3000
        P%Max_l_tensor=200
        P%Max_eta_k_tensor=500

        P%AccuratePolarization = .false. !We are only interested in the temperature here

        call CAMB_GetResults(P)

        ratio =0.1

        do l=2,P%Max_l
           !print out scalar and tensor temperature, then sum
           if (l <= P%Max_l_tensor) then
              !The indices of the Cl_xxx arrays are l, initial power spectrum index, Cl type
             write(*,'(1I5,3E15.5)') l, Cl_scalar(l,1, C_Temp), ratio*Cl_tensor(l,1,CT_Temp), &
                   ratio*Cl_tensor(l,1,C_Temp)+Cl_scalar(l,1,C_Temp)
           else
             write(*,'(1I5,3E15.5)') l,  Cl_scalar(l,1, C_Temp),0._dl,Cl_scalar(l,1,C_Temp)
           end if
        end do

        end program Tester


	SUBROUTINE GDFILL  ( kx, ky, grid, ioffx, ioffy, iskip, nlvl,
     +			     clvl, icolr, linlbl, iret )
C************************************************************************
C* GCFILL								*
C* 									*
C* This subroutine draws contours through a grid of data.  The 		*
C* algorithm used is based on a two-dimensional Lagrangian fitting of	*
C* the grid points.  It is the original GEMPAK contouring program.	*
C* The original subroutine, GCONTR, had a different calling sequence.	*
C* 									*
C* GCFILL  ( KX, KY, GRID, IOFFX, IOFFY, ISKIP, NLVL, CLVL, ICOLR,	*
C*           LINLBL, IRET )						*
C*									*
C* Input parameters:							*
C*									*
C*	KX		INTEGER		Number of x grid points 	*
C*	KY		INTEGER		Number of y grid points		*
C*	GRID (KX,KY)	REAL		Grid data array			*
C*	IOFFX		INTEGER		X offset to first point		*
C*	IOFFY		INTEGER		Y offset to first point		*
C*	ISKIP		INTEGER		Skip factor in original grid	*
C*	NLVL		INTEGER		Number of contour levels	*
C*	CLVL   (NLVL)	REAL		Contour level values		*
C*	ICOLR  (NLVL)	INTEGER		Contour color numbers		*
C*	LINLBL (NLVL)	INTEGER		Contour label types		*
C*									*
C* Output parameters:							*
C*									*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins/NMC	11/91	From GCONTR				*
C* S. Jacobs/NCEP	 1/96	Added CADJST to adjust grid values	*
C* T. Lee/GSC		 9/97	Fixed typo, NOMOMO -> NOMONO		*
C* S. Jacobs/NCEP	 2/00	Eliminate subboxing when CONTUR=1	*
C* S. Chiswell/Unidata	 2/01	Copied from GCFILL			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE 	'ERROR.PRM'
	INCLUDE		'CONTUR.CMN'
C*
	REAL		grid (*), clvl (*)
	INTEGER		icolr (*), linlbl (*)
C*
	LOGICAL		bad
	REAL		clev (LLCLEV)
	REAL		xg(4), yg(4)
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	Move the contour levels into a local array in order to add a
C*	maximum level.
C
	IF  ( nlvl .lt. LLCLEV )  THEN
	    nlev = nlvl
	  ELSE
	    nlev = LLCLEV - 1
	END IF
	bad = .false.
	DO  i = 1, nlev
	    clev (i) = clvl (i)
	    IF  ( i .gt. 1 )  THEN
		IF  ( clev (i) .le. clev (i-1) )  bad = .true.
	    END IF
	END DO
C
C*	If levels are not in the correct order, set error and return.
C
	IF  ( bad )  THEN
	    iret = NOMONO
	    RETURN
	END IF
C
C*	Build dummy maximum level.
C
	CALL GR_STAT  ( grid, kx, ky, 1, 1, kx, ky, gmin, gmax, gavg,
     +			gdev, ier )
	high = 2 * ABS ( gmax ) + ABS ( gmin )
	IF  ( high .le. clev (nlev) ) high = clev (nlev) + 1
	nlev = nlev + 1
	clev (nlev) = high
C
C*	Save the current color index
C
	CALL GQCOLR(isvcol, iret)
C
C*      Loop through all the grid boxes.
C
	sk = FLOAT ( iskip ) + 1.0
	DO  jll = 1, ky
 	  DO  ill = 1, kx
	     xg(1) = ( ill * sk + ioffx ) - ( .5 * sk )
	     yg(1) = ( jll * sk + ioffy ) - ( .5 * sk )
	     xg(2) = ( ill * sk + ioffx ) + ( .5 * sk )
	     yg(2) = ( jll * sk + ioffy ) - ( .5 * sk )
	     xg(3) = ( ill * sk + ioffx ) + ( .5 * sk )
	     yg(3) = ( jll * sk + ioffy ) + ( .5 * sk )
	     xg(4) = ( ill * sk + ioffx ) - ( .5 * sk )
	     yg(4) = ( jll * sk + ioffy ) + ( .5 * sk )
	     i = (jll - 1) * kx + ill
	     IF ( grid(i) .ne. RMISSD ) THEN
		icol = 1
		DO WHILE (( clev(icol) .lt. grid(i) ).and.
     +                    ( icol .lt. nlev ))
		   icol = icol + 1
	        END DO
		IF ( icolr(icol) .ne. 0 ) THEN
		   CALL GSCOLR(icolr(icol), iret)
	           CALL GFILL('G', 4, xg, yg, ier)
		END IF
	     END IF
          END DO
	END DO

	CALL GSCOLR( isvcol, iret )
	RETURN
	END


module variables

	implicit none
	integer :: nat,npasos
	double precision :: lz,lx,ly
	double precision :: sigma,rho,eps,ulj,rcut, utot, ukin
	double precision :: dt,tempi
	double precision, dimension(:), allocatable :: rx,ry,rz
	double precision, dimension(:), allocatable :: vx,vy,vz
	double precision, dimension(:), allocatable :: fx,fy,fz
	double precision, dimension(:), allocatable :: masa

end module variables

program md

	use variables
	implicit none

	call LeeDatos
	call Memoria
	call Posiciones
	call Velocidades
	call Pelicula(0)
	call Fuerza
	call Repetir
	call Pelicula(2)

end program md

subroutine Memoria

	use variables
	implicit none

	allocate(rx(nat), ry(nat), rz(nat))
	allocate(vx(nat), vy(nat), vz(nat))
	allocate(fx(nat), fy(nat), fz(nat))
	allocate(masa(nat))
	masa = 1.0d0

end subroutine Memoria

subroutine LeeDatos
	use variables
	implicit none

	open(1, file = "run.dat", status = "old", action = "read")

		read(1,*) nat
		read(1,*) rho
		read(1,*) lz
		read(1,*) dt
		read(1,*) sigma
		read(1,*) eps
		read(1,*) npasos
		read(1,*) rcut

	close(1)

end subroutine LeeDatos

subroutine Posiciones
	use variables
	implicit none

	integer :: i,j,k,l
	integer :: nx,ny,nz

	lx = sqrt(dble(nat)/(rho*lz))
	ly = lx

	k = 0

	nx = int(lx/sigma)
	ny = int(ly/sigma)
	nz = int(lz/sigma)

	do j = 1, nz
		do i = 1, ny
			do l = 1, nx
				k = k + 1
				if (k<=nat) then
					write(*,*) k
					rx(k) = dble(l*sigma)
					ry(k) = dble(i*sigma)
					rz(k) = dble(j*sigma)
				endif
			enddo
		enddo
	enddo

end subroutine Posiciones

subroutine Velocidades

	use variables
	implicit none

	integer :: i
	double precision :: rndx, rndy, rndz

	do i = 1, nat

		call random_number(rndx)
		call random_number(rndy)
		call random_number(rndz)

		vx(i) = 2.0d0*rndx - 1.0d0
		vy(i) = 2.0d0*rndy - 1.0d0
		vz(i) = 2.0d0*rndz - 1.0d0

	enddo

end subroutine Velocidades

subroutine Fuerza

    use variables
    implicit none

    integer :: i,j
    double precision :: dx, dy, dz
    double precision :: duij, rij

    fx  = 0.0d0
    fy  = 0.0d0
    fz  = 0.0d0
    ulj = 0.0d0

    do i = 1, nat - 1
        do j = i + 1,nat

            dx    = rx(i) - rx(j)
            dy    = ry(i) - ry(j)
            dz    = rz(i) - rz(j)

            !Mínima imágen

            if (dx > lx*0.50d0) then
            	dx = dx - lx
            else
            	if (dx < -lx*0.50d0) dx = dx + lx
            end if
            if (dy > ly*0.50d0) then
            	dy = dy - ly
            else
            	if (dy < -ly*0.50d0) dy = dy + ly
            end if
            if (dz > lz*0.50d0) then
            	dz = dz -lz
            else
            	if (dz < -lz*0.50d0) dz = dz + lz
            endif

            !Termina Minima Imagen

            rij   = sqrt(dx**2 + dy**2 + dz**2)

            if (rij < rcut) then
	            ulj   = ulj + 4.0d0*eps*((sigma/rij)**12-(sigma/rij)**6)
	            duij  = 48.0d0*eps*((sigma/rij)**12 - 0.50d0*(sigma/rij)**6)/rij

	            fx(i) = fx(i) + duij*(dx/rij)
	            fy(i) = fy(i) + duij*(dy/rij)
	            fz(i) = fz(i) + duij*(dz/rij)

	            fx(j) = fx(j) - duij*(dx/rij)
	            fy(j) = fy(j) - duij*(dy/rij)
	            fz(j) = fz(j) - duij*(dz/rij)
	        end if
        enddo
    enddo

end subroutine Fuerza

subroutine Repetir

	use variables
	implicit none

	integer :: paso,i
	open(9,file='TRJ.dat',status='replace',action='write')

	do paso = 1, npasos

		!write (*,*) paso

		vx = vx + fx*dt/masa
		vy = vy + fy*dt/masa
		vz = vz + fz*dt/masa

		ukin  = sum(0.50d0*masa*vx**2 + 0.50d0*masa*vy**2 + 0.50d0*masa*vz**2)
		tempi = 2.0d0*ukin/dble(3*nat)

		rx = rx + vx*dt
		ry = ry + vy*dt
		rz = rz + vz*dt

		!Condiciones peridicas de fronteras (PBC)

		where (rx < 0.0d0) rx = rx + lx
		where (ry < 0.0d0) ry = ry + ly
		where (rz < 0.0d0) rz = rz + lz

		where (rx > lx) rx = rx - lx
		where (ry > ly) ry = ry - ly
		where (rz > lz) rz = rz - lz

		call Fuerza

		vx = vx + fx*dt/(2.0d0*masa)
		vy = vy + fy*dt/(2.0d0*masa)
		vz = vz + fz*dt/(2.0d0*masa)

		if (mod(paso,50) == 0) call Pelicula(1)
		utot = ukin + ulj
		if (mod(paso,100) == 0)	write(*,100)paso, utot/dble(nat), ukin/dble(nat), ulj/dble(nat), tempi
		if (mod(paso,100) == 0)	write(9,100)paso, utot/dble(nat), ukin/dble(nat), ulj/dble(nat), tempi

	enddo

	close(9)

	100 format(i10,4f12.5)

end subroutine Repetir

subroutine Pelicula(flag)
	use variables
	implicit none

	integer :: i, flag

	if (flag == 0) then

		open(2, file = "animacion.dat", status = "replace", action = "write")
		write(2,*)nat
		write(2,200)'Lattice="', lx, 0.0, 0.0, 0.0, ly, 0.0, 0.0, 0.0, lz,'"'
		do i = 1, nat
			write(2,100) 'C', rx(i), ry(i), rz(i)
		enddo

	elseif (flag == 1) then

		write(2,*) nat
		write(2,200)'Lattice="', lx, 0.0, 0.0, 0.0, ly, 0.0, 0.0, 0.0, lz,'"'

		do i = 1, nat
			write(2,100) 'C', rx(i),ry(i),rz(i)
		enddo
	else
		close(2)
	endif

	100 format(a, 3f12.4)
	200 format(a, 9f5.1, a)

end subroutine Pelicula

subroutine Histograma(flag)
use variables
implicit none

integer                           :: flag
integer                           :: i,nptos,binz
integer,dimension(:), allocatable :: histoz

if(flag==0)then !condicional

 nptos = 900
 vminx = minval(vx)
 vmaxx = maxval(vx)
 dx    = (vmaxx - vminx)/dble(nptos + 1)

 vminy = minval(vy)
 vmaxy = maxval(vy)
 dy    = (vmaxy - vminy)/dble(nptos + 1)

 vminz = minval(vz)
 vmaxz = maxval(vz)
 dz    = (vmaxz - vminz)/dble(nptos + 1)

allocate(histox(-nptos:nptos))
allocate(histoy(-nptos:nptos))
allocate(histoz(-nptos:nptos))
histox = 0
histoy = 0
histoz = 0

do  i = 1,nat
 binx = int (vx(i)/dx)
 biny = int (vy(i)/dy)
 histox(binx) = histox(binx)+1
 histoy(biny) = histoy(biny)+1
enddo

open(9,file='hx.dat',status='replace',action='write')
 do i = -nptos,nptos
 write(9,*)dble(i)*dx,histox(i)/dble(sum(histox))
 enddo
close(9)

open(3,file='hy.dat',status='replace',action='write')
do i = -nptos,nptos
write(3,*)dble(i)*dy,histoy(i)/dble(sum(histoy))
enddo
close(3)

else  !cuando es distinto de cero haz lo de abajo

nptos = 900
 vminx = minval(vx)
 vmaxx = maxval(vx)
 dx    = (vmaxx-vminx)/dble(nptos+1)

 vminy = minval(vy)
 vmaxy = maxval(vy)
 dy    = (vmaxy-vminy)/dble(nptos+1)

allocate(histox(-nptos:nptos))
allocate(histoy(-nptos:nptos))
histox = 0
histoy = 0

do  i = 1,nat
 binx = int (vx(i)/dx)
 biny = int (vy(i)/dy)
 histox(binx) = histox(binx)+1
 histoy(biny) = histoy(biny)+1
enddo

open(9,file='hx1.dat',status='replace',action='write')
 do i = -nptos,nptos
 write(9,*)dble(i)*dx,histox(i)/dble(sum(histox))
 enddo
close(9)

open(3,file='hy1.dat',status='replace',action='write')
do i = -nptos,nptos
write(3,*)dble(i)*dy,histoy(i)/dble(sum(histoy))
enddo
close(3)

endif !termina condicional

end subroutine Histograma


SUBROUTINE gammas

!-------------------------------------------------------------
!
! Construct the gamma sub-matrices from gmat
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER :: i, j

! Now make the submatrices from gmat
! gaa
DO j = 1, ordsq
   DO i = 1, ordsq
      gaa(i,j) = gmat(i,j)
   END DO
END DO
! gax & gay
DO j = 1, order
   DO i = 1, ordsq
      gax(i,j) = gmat(i,(ordsq+j))
      gay(i,j) = gmat(i,(ordsq+order+j))
   END DO
END DO

! gxa & gya
DO j = 1, ordsq
   DO i = 1, order
      gxa(i,j) = gmat((ordsq+i),j)
      gya(i,j) = gmat((ordsq+order+i),j)
   END DO
END DO

! gxx, gxy, gyx, & gyy
DO j = 1, order
   DO i = 1, order
      gxx(i,j) = gmat((ordsq+i),(ordsq+j))
      gxy(i,j) = gmat((ordsq+i),(ordsq+order+j))
      gyx(i,j) = gmat((ordsq+order+i),(ordsq+j))
      gyy(i,j) = gmat((ordsq+order+i),(ordsq+order+j))
   END DO
END DO

RETURN
END SUBROUTINE gammas


      subroutine umat(stress, statev, ddsdde, sse, spd, scd, rpl,
     & ddsddt, drplde, drpldt, stran, dstran, time, dtime, temp, dtemp,
     & predef, dpred, cmname, ndi, nshr, ntens, nstatv, props, nprops,
     & coords, drot, pnewdt, celent, df0, df1, noel, npt, layer,
     & kspt, kstep, kinc)
c
      implicit real*8(a-h,o-z)
      character*8 cmname
c
      dimension stress(ntens), statev(nstatv), ddsdde(ntens, ntens),
     & ddsddt(ntens), drplde(ntens), stran(ntens), dstran(ntens),
     & predef(1), dpred(1), props(nprops), coords(3), drot(3, 3),
     & df0(3, 3), df1(3, 3), flow(6), tempstatv(nstatv)
c
      parameter(zero=0.d0, one=1.d0, two=2.d0, three=3.d0, six=6.d0,
     & enumax=.4999d0, newton=10, toler=1.0d-6)
c
c assign temporary state variables
      do k1=1,nstatv
       tempstatv(k1)=statev(k1)
      enddo
c
c elastic properties
      call shearmod(eg,enu,temp,props,nprops)
      eg2=two*eg
      eg3=three*eg
      emod = eg2*(1.d0+enu)
      ebulk3=emod/(one-two*enu)
      elam=(ebulk3-eg2)/three
c
c elastic stiffness
      do k1=1, ndi
        do k2=1, ndi
          ddsdde(k2, k1)=elam
        end do
        ddsdde(k1, k1)=eg2+elam
      end do
      do k1=ndi+1, ntens
        ddsdde(k1, k1)=eg
      end do
c
c calculate predictor stress and elastic strain
      do k1=1, ntens
        do k2=1, ntens
          stress(k2)=stress(k2)+ddsdde(k2, k1)*dstran(k1)
        end do
      end do
c
c calculate equivalent von mises stress
      smises=(stress(1)-stress(2))**2+(stress(2)-stress(3))**2
     & +(stress(3)-stress(1))**2
      do k1=ndi+1,ntens
        smises=smises+six*stress(k1)**2
      end do
      smises=sqrt(smises/two)
c
      call fisotropic(sy,dsy,zero,dtime,temp,
     & statev,tempstatv,nstatv,props,nprops)
c
c determine if actively yielding
      if (smises.gt.(one+toler)*sy) then
c
c actively yielding
c separate the hydrostatic from the deviatoric stress
c calculate the flow direction
      shydro=(stress(1)+stress(2)+stress(3))/three
      do k1=1,ndi
        flow(k1)=(stress(k1)-shydro)/smises
      end do
      do k1=ndi+1, ntens
        flow(k1)=stress(k1)/smises
      end do
c
c solve for equivalent von mises stress
c and equivalent plastic strain increment using newton iteration
      deqpl=zero
      do kewton=1, newton
        rhs=smises-eg3*deqpl-sy
        deqpl=deqpl+rhs/(eg3+dsy)
	call fisotropic(sy,dsy,deqpl,dtime,temp,
     & statev,tempstatv,nstatv,props,nprops)
        if(abs(rhs).lt.toler) goto 10
      end do
c
c write warning message to .msg file
      write(7,2) newton
 2    format(//,30x,'***warning - plasticity algorithm did not ',
     & 'converge after ',i3,' iterations')
 10   continue
c
c update stress, elastic and plastic strains and
c equivalent plastic strain
      do k1=1,ndi
        stress(k1)=flow(k1)*sy+shydro
      end do
      do k1=ndi+1,ntens
        stress(k1)=flow(k1)*sy
      end do
c
c formulate the jacobian (material tangent)
c first calculate effective moduli
      effg=eg*sy/smises
      effg2=two*effg
      effg3=three/two*effg2
      efflam=(ebulk3-effg2)/three
      effhrd=eg3*dsy/(eg3+dsy)-effg3
      do k1=1, ndi
        do k2=1, ndi
          ddsdde(k2, k1)=efflam
        end do
        ddsdde(k1, k1)=effg2+efflam
      end do
      do k1=ndi+1, ntens
        ddsdde(k1, k1)=effg
      end do
      do k1=1, ntens
        do k2=1, ntens
          ddsdde(k2, k1)=ddsdde(k2, k1)+effhrd*flow(k2)*flow(k1)
        end do
      end do
      endif
c
c update state variable array
      do k1=1,nstatv
       statev(k1)=tempstatv(k1)
      enddo
c
      return
      end
c


c
c -------------------------------------------------------------
c
       subroutine vpredx(q,qx,ur,ul,mitot,mjtot,dt,dx,j,msize)
       implicit double precision(a-h,o-z)
       common   /userdt/ cfl,gamma,gamma1,xprob,yprob,alpha,Re,iprob,
     .                ismp,gradThreshold
       dimension q(mitot,mjtot,4)
       dimension qx(mitot,mjtot,4),ur(msize,4),ul(msize,4)
c
c predictor step for variables at midtime at cell edges for muscl
c working on row number j
c
       hdtdx = .5d0*dt/dx
	  do 20 i = 2, mitot-2
	     rho = q(i,j,1)
	     u   = q(i,j,2)
	     v   = q(i,j,3)
	     pr  = q(i,j,4)
	     cs2 = gamma*pr / rho
	     cs  = dsqrt(cs2)
	     bt1 = hdtdx*(qx(i,j,4)/cs-rho*qx(i,j,2))
	     bt2 = hdtdx*cs*(qx(i,j,1)-qx(i,j,4)/cs2)
	     bt3 = hdtdx*cs*qx(i,j,3)
	     if (u-cs .le. 0.d0) bt1 = 0.d0
	     if (u .le. 0.d0) then
		bt2 = 0.d0
		bt3 = 0.d0
	     endif
	     off = .5d0 - dmax1(u+cs,0.d0)*hdtdx
c
	     ul(i+1,1) = bt1 + bt2 + rho + off*qx(i,j,1)
	     ul(i+1,2) = -bt1*cs/rho + u + off*qx(i,j,2)
	     ul(i+1,3) = bt3 + v + off*qx(i,j,3)
	     ul(i+1,4) = bt1*cs2 + pr + off*qx(i,j,4)
c
	     rho = q(i+1,j,1)
	     u   = q(i+1,j,2)
	     v   = q(i+1,j,3)
             pr =  q(i+1,j,4)
	     cs2 = gamma*pr / rho
	     cs  = dsqrt(cs2)
	     bt2 = hdtdx*cs*(qx(i+1,j,4)/cs2-qx(i+1,j,1))
	     bt3 = -1.d0*hdtdx*cs*qx(i+1,j,3)
	     bt4 = -1.d0*hdtdx*(qx(i+1,j,2)*rho+qx(i+1,j,4)/cs)
	     if (u .gt. 0.d0) then
		bt2 = 0.d0
		bt3 = 0.d0
	     endif
	     if (u+cs .ge. 0.d0) bt4 = 0.d0
	     off = .5d0 + dmin1(u-cs,0.d0)*hdtdx
c
	     ur(i+1,1) = bt2 + bt4 + rho - off*qx(i+1,j,1)
	     ur(i+1,2) = bt4*cs/rho + u - off*qx(i+1,j,2)
	     ur(i+1,3) = bt3 + v - off*qx(i+1,j,3)
	     ur(i+1,4) = bt4*cs2 + pr - off*qx(i+1,j,4)
 20       continue
 40    continue
c
       return
       end


*
*    ------------------------------------------------------------------
*      E C O R E
*    ------------------------------------------------------------------
*
*
      SUBROUTINE ECORE(EL,EC,REL)
*
* *** COMPUTES THE ENERGY OF THE COMMON CLOSED SHELLS
*
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (NOD=220,NWD=30,NWD2=2*NWD)
      COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID
     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
      COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD2),YK(NOD),
     :   YR(NOD),X(NOD),AZ(NWD2),L(NWD2),MAX(NWD2),N(NWD2)
      CHARACTER EL(*)*3
      LOGICAL REL
*
      EC = D0
      DO 10 I = 1,NCLOSD
         SUMI = 4*L(I)+2
         TI   = FK(I,I,0,REL)
         DO 20 K = 2,2*L(I),2
            TI = TI - CA(L(I),K)*FK(I,I,K,REL)
   20    CONTINUE
         EC = EC + SUMI*((SUMI-1)*TI - HL(EL,I,I,REL))/D2
         DO 30 J = 1,I-1
            SUMJ = 4*L(J)+2
            TIJ = FK(I,J,0,REL)
            DO 40 K=IABS(L(I)-L(J)),L(I)+L(J),2
               TIJ = TIJ -CB(L(I),L(J),K)*GK(I,J,K,REL)
   40       CONTINUE
            EC = EC + SUMI*SUMJ*TIJ
   30    CONTINUE
   10 CONTINUE
      END


! { dg-options "-floop-nest-optimize -O2" }

MODULE dbcsr_geev
  INTEGER, PARAMETER :: real_8=8
CONTAINS
  SUBROUTINE dbcsr_dgeev(jobvl,jobvr,matrix,ndim,evals,revec,levec)
    CHARACTER(1)                             :: jobvl, jobvr
    REAL(real_8), DIMENSION(:, :)            :: matrix
    INTEGER                                  :: ndim
    COMPLEX(real_8), DIMENSION(:)            :: evals
    COMPLEX(real_8), DIMENSION(:, :)         :: revec, levec
    INTEGER                                  :: i, info, lwork
    REAL(real_8)                             :: norm, tmp_array(ndim,ndim), &
                                                work(20*ndim)
    REAL(real_8), DIMENSION(ndim)            :: eval1, eval2
    REAL(real_8), DIMENSION(ndim, ndim)      :: evec_l, evec_r
    DO WHILE (i.le.ndim)
      IF(ABS(eval2(i)).LT.EPSILON(REAL(0.0,real_8)))THEN
        norm=SQRT(SUM(evec_r(:,i)**2.0_real_8)+SUM(evec_r(:,i+1)**2.0_real_8))
        revec(:,i)=CMPLX(evec_r(:,i),evec_r(:,i+1),real_8)/norm
      END IF
    END DO
  END SUBROUTINE  dbcsr_dgeev
END MODULE dbcsr_geev


program SHMag
!------------------------------------------------------------------------------
!
!    This program will read in a set of magnetic spherical harmonic
!    coefficients and make 2D equally spaced grid of the three vector
!    components of the magnetic field, the total magnetic field strength, and
!    the magnetic potential. The field is calculated on a speroid with mean
!    radius r and flattening f.
!
!    The included spherical harmonic file FSU_mars90.sh is the martian magnetic
!    field model of Cain et al., 2003.
!
!    Copyright (c) 2012, SHTOOLS
!    All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS
    use ftypes

    implicit none

    character(200) :: infile, radf, thetaf, phif, totalf, potf
    real(dp) :: header(4), interval, r0, a, f, mpr, z, timein, timeout, temp
    real(dp), allocatable :: glm(:,:,:), rad(:,:), phi(:,:), theta(:,:), &
                             total(:,:), pot(:,:)
    integer :: lmax, lmaxp, n, n_out, nlong, nlat, i, j, astat(6), sampling

    infile = "../../ExampleDataFiles/FSU_mars90.sh"

    f = 1.0_dp / 169.864881_dp    ! Mars flattening = (R_eq - R_p)/R_eq
    mpr = 3389.508e3_dp           ! Mean radius of mars
    z = 145.e3_dp                 ! mean altitude to calculate field at.

    lmax = 359    ! Maximum spherical harmonic degree that is resolved in the output grids.
    N = 2 * lmax + 2    ! Number of latitudinal samples in the output grids.
    interval = 180.0_dp / dble(n)    ! Sampling interval in latitude.

    sampling = 2
    nlat = n
    nlong = 2 * n

    print*, "LMAX of output grids = ", lmax
    print*, "N = ", n
    print*, "Latitudinal sampling interval = ", interval

    allocate(glm(2,lmax+1,lmax+1), stat = astat(1))
    allocate(rad(nlat,nlong), stat = astat(2))
    allocate(theta(nlat,nlong), stat = astat(3))
    allocate(phi(nlat,nlong), stat = astat(4))
    allocate(total(nlat,nlong), stat = astat(5))
    allocate(pot(nlat,nlong), stat = astat(6))

    if (sum(astat(1:6)) /= 0) then
        print*, "Problem allocating GLM, RAD, THETA, PHI, TOTAL, and POT", &
            astat(1), astat(2), astat(3), astat(4), astat(5), astat(6)
        stop
    end if

    call SHRead(infile, glm, lmaxp, header=header(1:4), skip=1)
    r0 = header(1) * 1.e3_dp
    print*, "Reference radius of spherical harmonic coefficients R0 (km) = ", r0 / 1.e3_dp
    print*, "Lmax of spherical harmonic model = ", lmaxp

    a = mpr + z
    print*, "Field calculated on a flattened ellipsoid with semi-major axis A (km) = ", a / 1.e3_dp
    print*, "Flattening of the ellipsoid = ", f

    radf = "radial_145f.dat"
    thetaf = "theta_145f.dat"
    phif = "phi_145f.dat"
    totalf = "total_145f.dat"
    potf = "pot_145f.dat"

    call cpu_time(timein)

    call MakeMagGridDH(glm, lmax, r0, a, f, rad, theta, phi, total, n_out, &
                       sampling = sampling, lmax_calc = lmaxp, pot_grid = pot)

    call cpu_time(timeout)

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

    if (n /= n_out) then
        print*, "Problem. N is not equal to N_OUT."
        print*, "N_OUT = ", n_out
        stop
    end if

    print*, "Maximum and minimum field intensity (nT) = ", maxval(total(1:nlat,1:nlong)), minval(total(1:nlat,1:nlong))
    print*, "Maximum and minimum Br (nT) = ", maxval(rad(1:nlat,1:nlong)), minval(rad(1:nlat,1:nlong))
    print*, "Maximum and minimum Btheta (nT) = ", maxval(theta(1:nlat,1:nlong)), minval(theta(1:nlat,1:nlong))
    print*, "Maximum and minimum Bphi (nT) = ", maxval(phi(1:nlat,1:nlong)), minval(phi(1:nlat,1:nlong))
    print*, "Maximum and minimum potential (nT m) = ", maxval(pot(1:nlat,1:nlong)), minval(pot(1:nlat,1:nlong))

    open(12,file=radf)
    open(13,file=phif)
    open(14,file=thetaf)
    open(15,file=totalf)
    open(16,file=potf)

    write(12,*) nlat+1, nlong+1
    write(13,*) nlat+1, nlong+1
    write(14,*) nlat+1, nlong+1
    write(15,*) nlat+1, nlong+1
    write(16,*) nlat+1, nlong+1

    do i = 1, nlat
        do j = 1, nlong
            write(12,*) rad(i,j)
            write(13,*) phi(i,j)
            write(14,*) theta(i,j)
            write(15,*) total(i,j)
            write(16,*) pot(i,j)
        end do
        ! write out value at 360 degrees longitude, which is redundant
        write(12,*) rad(i,1)
        write(13,*) phi(i,1)
        write(14,*) theta(i,1)
        write(15,*) total(i,1)
        write(16,*) pot(i,1)
    end do

    ! write out values at 90 S, which are not calculated in the Driscoll and
    ! Healy routine, and which are just the average of the values of the last row.
    temp = sum(rad(nlat,1:nlong)) / dble(nlong)
    do j = 1, nlong + 1
        write(12,*) temp
    end do
    temp = sum(phi(nlat,1:nlong)) / dble(nlong)
    do j = 1, nlong + 1
        write(13,*) temp
    end do
    temp = sum(theta(nlat,1:nlong)) / dble(nlong)
    do j = 1, nlong + 1
        write(14,*) temp
    end do
    temp = sum(total(nlat,1:nlong)) / dble(nlong)
    do j = 1, nlong + 1
        write(15,*) temp
    end do
    temp = sum(pot(nlat,1:nlong)) / dble(nlong)
    do j = 1, nlong + 1
        write(16,*) temp
    end do

    close(12)
    close(13)
    close(14)
    close(15)
    close(16)

    deallocate(rad)
    deallocate(theta)
    deallocate(phi)
    deallocate(total)
    deallocate(pot)
    deallocate(glm)

end program SHMag


      program spectrum
c
c***********************************************************************
c
c     dl_poly utility program for spectral analysis using the fast
c     fourier transform
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith june 1992.
c
c     note - this program includes a naff fft routine purely for
c     portability and verification reasons. users are strongly
c     recommended to substitute a machine specific fft, which
c     should vastly improve performance.
c
c     note - you will probably need to change some of the array
c     dimensions using the following parameters.
c
c     note - ndiv must be a power of 2. ndiv2 will change according to
c     the fft routine you use.
c
c***********************************************************************
c

      implicit real*8(a-h,o-z)

      parameter (ndiv=8192,ndiv2=ndiv)
      parameter (mxcols=15,mxspec=10)

      character*2 name

      complex*16 g(ndiv),w(ndiv2),cmplx,sum
      dimension sample(mxcols),u(ndiv)
      dimension icol(mxspec),key(ndiv)

      data pi/3.1415926536d0/

c
c     define the window function (blackman-harris 4 term)

      win(x)=0.35875d0-0.48829d0*cos(x)+0.14128d0*cos(2.d0*x)-
     x       0.01168d0*cos(3.d0*x)

c
c     declare how many fourier transforms are required
c     and how many columns of data there in the input data
c     (excluding the time column)

      write(*,'(a)')'enter number of required transforms'
      read(*,*)nspecs
      write(*,'(a)')'enter number of data columns in input'
      read(*,*)ncols
      write(*,'(a)')'enter data stride length'
      read(*,*)nstrid

      ncols=min(mxcols,ncols)
      nspecs=min(mxspec,nspecs)

c
c     specify the columns to be fourier transformed

      write(*,'(a)')'specify columns to be transformed'
      read(*,*)(icol(i),i=1,nspecs)

c
c     initialise the fft work arrays

      call fft(1,1,ndiv,key,g,w,g)

c
c     now process each fourier transform in turn

      do ispecs=1,nspecs

c
c     zero the complex data array

         do i=1,ndiv
            g(i)=(0.d0,0.d0)
         enddo

c
c     open the file containing the columns of data

         open(7,file='input.data')

c
c     now read the required columns (note first column is time)

         k=0
         sum=(0.d0,0.d0)
         do i=1,ndiv
            read(7,*,end=100)t,(sample(j),j=1,ncols)
            if(i.eq.1)t0=t
            if(mod(i-1,nstrid).eq.0)then
               k=k+1
               g(k)=cmplx(sample(icol(ispecs)),0.d0)
               sum=sum+g(k)
            endif
         enddo

  100    m=k
         sum=sum/dble(m)

c
c     close data file

         close(7)

         dtim=(t-t0)/dble(m-1)
         period=dble(m)*dtim

c
c     apply window function

         do i=1,m
            g(i)=(g(i)-sum)*win((2.d0*pi*dtim/period)*dble(i-1))
         enddo

c
c     fourier transform the data

         call fft(0,-1,ndiv,key,g,w,g)

c
c     normalise the fourier transform

         do i=1,ndiv
            g(i)=dtim*g(i)
            u(i)=sqrt(dreal(g(i))**2+dimag(g(i))**2)
         enddo

c
c     open output file to receive fourier transform

         write(name,'(i2.2)')icol(ispecs)
         open(8,file='ft'//name)

c
c     write out fourier transform

         do i=1,ndiv/2
            fre=dble(i-1)/(dtim*dble(ndiv))
            write(8,'(1p,4e12.4)')fre,u(i),g(i)
         enddo

c
c     close fourier transform file

         close(8)

      enddo

      stop
      end

      subroutine fft(ind,isw,ndiv,key,aaa,wfft,bbb)
c***********************************************************************
c
c     fast fourier transform routine
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith june 1992.
c
c***********************************************************************

      implicit real*8(a-h,o-z)

      logical check
      complex*16 aaa(ndiv),bbb(ndiv),wfft(ndiv),ttt
      dimension key(ndiv)
      data tpi/6.2831853072d0/
   10 format(1h0,'error - number of points not a power of two')

c
c     check that array is of suitable length
      nt=1
      check=.true.
      do i=1,20
         nt=2*nt
         if(nt.eq.ndiv)then
            check=.false.
            nu=i
         endif
      enddo
      if(check)then
         write(*,10)
         stop
      endif

      if(ind.gt.0)then
c
c     set reverse bit address array

         do kkk=1,ndiv
            iii=0
            jjj=kkk-1
            do j=1,nu
               jj2=jjj/2
               iii=2*(iii-jj2)+jjj
               jjj=jj2
            enddo
            key(kkk)=iii+1
         enddo
c
c     initialise complex exponential factors

         tpn=tpi/dble(ndiv)
         arg=0.d0
         np1=ndiv+1
         np2=ndiv/2
         wfft(1)=(1.d0,0.d0)
         do i=1,np2
            arg=tpn*dble(i)
            wfft(i+1)=cmplx(cos(arg),sin(arg))
            wfft(np1-i)=conjg(wfft(i+1))
         enddo

         return
      endif

c
c     take conjugate of exponentials if required

      if(isw.lt.0)then

         do i=1,ndiv
            wfft(i)=conjg(wfft(i))
         enddo

      endif

c
c     take copy input array

      do i=1,ndiv
         bbb(i)=aaa(i)
      enddo
c
c     perform fourier transform

      kkk=0
      nu1=nu-1
      np2=ndiv/2
      do l=1,nu

  100    do i=1,np2
            iii=key(kkk/2**nu1+1)
            kk1=kkk+1
            k12=kk1+np2
            ttt=bbb(k12)*wfft(iii)
            bbb(k12)=bbb(kk1)-ttt
            bbb(kk1)=bbb(kk1)+ttt
            kkk=kkk+1
         enddo
         kkk=kkk+np2
         if(kkk.lt.ndiv)go to 100
         kkk=0
         nu1=nu1-1
         np2=np2/2

      enddo
c
c     unscramble the fft using bit address array

      do kkk=1,ndiv
         iii=key(kkk)
         if(iii.gt.kkk)then
            ttt=bbb(kkk)
            bbb(kkk)=bbb(iii)
            bbb(iii)=ttt
         endif
      enddo
c
c     restore exponentials to unconjugated values if necessary

      if(isw.lt.0)then

         do i=1,ndiv
            wfft(i)=conjg(wfft(i))
         enddo

      endif

      return
      end


*
************************************************************************
*
*     File of the EXTENDED-REAL             Level-2 BLAS.
*     ===================================================
*
*     SUBROUTINE ESGEMV( TRANS, M, N, ALPHA, A, LDA, X, INCX,
*    $                   BETA, Y, INCY )
*
*     SUBROUTINE ESGBMV( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
*    $                   BETA, Y, INCY )
*
*     SUBROUTINE ESSYMV( UPLO, N, ALPHA, A, LDA, X, INCX,
*    $                   BETA, Y, INCY )
*
*     SUBROUTINE ESSBMV( UPLO, N, K, ALPHA, A, LDA, X, INCX,
*    $                   BETA, Y, INCY )
*
*     SUBROUTINE ESSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
*
*     SUBROUTINE ESTRMV( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*
*     SUBROUTINE ESTBMV( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
*
*     SUBROUTINE ESTPMV( UPLO, TRANS, DIAG, N, AP, X, INCX )
*
*     SUBROUTINE ESTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*
*     SUBROUTINE ESTBSV( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
*
*     SUBROUTINE ESTPSV( UPLO, TRANS, DIAG, N, AP, X, INCX )
*
*     SUBROUTINE ESGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
*     SUBROUTINE ESSYR ( UPLO, N, ALPHA, X, INCX, A, LDA )
*
*     SUBROUTINE ESSPR ( UPLO, N, ALPHA, X, INCX, AP )
*
*     SUBROUTINE ESSYR2( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
*     SUBROUTINE ESSPR2( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
*
*     See:
*
*        Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
*        A proposal for an extended set of Fortran Basic Linear Algebra
*        Subprograms.
*
*        Technical Memorandum No.41 (revision 1), Mathematics and
*        Computer Science Division, Argonne National Laboratory, 9700
*        South Cass Avenue, Argonne, Illinois 60439, US.
*
*        Or
*
*        NAG Technical Report TR3/86, Numerical Algorithms Group Ltd.,
*        NAG Central Office, 256 Banbury Road, Oxford OX2 7DE, UK, and
*        Numerical Algorithms Group Inc., 1101 31st Street, Suite 100,
*        Downers Grove, Illinois 60515-1263, USA.
*
************************************************************************
*
      SUBROUTINE ESGEMV( TRANS, M, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*     .. Scalar Arguments ..
      REAL               ALPHA, BETA
      INTEGER            INCX, INCY, LDA, M, N
      CHARACTER*1        TRANS
*     .. Array Arguments ..
      DOUBLE PRECISION   Y( * )
      REAL               A( LDA, * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  ESGEMV performs one of the matrix-vector operations
*
*     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
*
*  where alpha and beta are scalars, x and y are vectors and A is an
*  m by n matrix. Additional precision arithmetic is used in the
*  computation.
*
*  Parameters
*  ==========
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the operation to be performed as
*           follows:
*
*              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
*
*              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
*
*              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y
*.
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of the matrix A.
*           M must be at least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - REAL            .
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - REAL             array of DIMENSION ( LDA, n ).
*           Before entry, the leading m by n part of the array A must
*           contain the matrix of coefficients.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, m ).
*           Unchanged on exit.
*
*  X      - REAL             array of DIMENSION at least
*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
*           and at least
*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
*           Before entry, the incremented array X must contain the
*           vector x.
*           Unchanged on exit.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  BETA   - REAL            .
*           On entry, BETA specifies the scalar beta. When BETA is
*           supplied as zero then Y need not be set on input.
*           Unchanged on exit.
*
*  Y      - DOUBLE PRECISION array of DIMENSION at least
*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
*           and at least
*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
*           Before entry with BETA non-zero, the incremented array Y
*           must contain the vector y. On exit, Y is overwritten by the
*           updated vector y. At least REAL             arithmetic is
*           used in the computation of y.
*
*  INCY   - INTEGER.
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 20-July-1986.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      REAL               ONE          , ZERO
      PARAMETER        ( ONE  = 1.0E+0, ZERO = 0.0E+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, DBLE
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF      ( .NOT.LSAME( TRANS, 'N' ).AND.
     $          .NOT.LSAME( TRANS, 'T' ).AND.
     $          .NOT.LSAME( TRANS, 'C' )      ) THEN
         INFO = 1
      ELSE IF ( M.LT.0 ) THEN
         INFO = 2
      ELSE IF ( N.LT.0 ) THEN
         INFO = 3
      ELSE IF ( LDA.LT.MAX(1,M) ) THEN
         INFO = 6
      ELSE IF ( INCX.EQ.0 ) THEN
         INFO = 8
      ELSE IF ( INCY.EQ.0 ) THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'ESGEMV', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     Set LENX and LENY, the lengths of the vectors x and y.
*
      IF( LSAME( TRANS, 'N' ) )THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
*     First form  y := beta*y  and set up the start points in X and Y if
*     the increments are not both unity.
*
      IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
         IF( BETA.NE.ONE )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, LENY
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, LENY
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         END IF
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( LENX - 1 )*INCX
         END IF
         IF( INCY.GT.0 )THEN
            KY = 1
         ELSE
            KY = 1 - ( LENY - 1 )*INCY
         END IF
         IF( BETA.NE.ONE )THEN
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, LENY
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, LENY
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO )
     $   RETURN
      IF( LSAME( TRANS, 'N' ) )THEN
*
*        Form  y := alpha*A*x + y.
*
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 60, J = 1, N
               IF( X( J ).NE.ZERO )THEN
                  TEMP = DBLE( ALPHA )*X( J )
                  DO 50, I = 1, M
                     Y( I ) = Y( I ) + TEMP*A( I, J )
   50             CONTINUE
               END IF
   60       CONTINUE
         ELSE
            JX = KX
            DO 80, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = DBLE( ALPHA )*X( JX )
                  IY = KY
                  DO 70, I = 1, M
                     Y( IY ) = Y( IY ) + TEMP*A( I, J )
                     IY      = IY      + INCY
   70             CONTINUE
               END IF
               JX = JX + INCX
   80       CONTINUE
         END IF
      ELSE
*
*        Form  y := alpha*A'*x + y.
*
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 100, J = 1, N
               TEMP = ZERO
               DO 90, I = 1, M
                  TEMP = TEMP + A( I, J )*DBLE( X( I ) )
   90          CONTINUE
               Y( J ) = Y( J ) + ALPHA*TEMP
  100       CONTINUE
         ELSE
            JY = KY
            DO 120, J = 1, N
               TEMP = ZERO
               IX = KX
               DO 110, I = 1, M
                  TEMP = TEMP + A( I, J )*DBLE( X( IX ) )
                  IX   = IX   + INCX
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  120       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of ESGEMV.
*
      END


program rmin_conv

! Calculates rmin convergence for the lowest 26 eigenvalues of the double
! minimum potential. Results are saved to 'energies_rmin.txt'.

use dftatom
use utils, only: savetxt
use interpolation, only: spline3, loadtxt
implicit none

! For non-singular potential, we need to set Z=0:
integer, parameter :: Z = 0
! Mesh parameters:
real(dp), parameter :: r_max = 12._dp, a = 2._dp
integer, parameter :: NN = 50000

real(dp), parameter :: c = 137.035999037_dp, eps = 1e-12_dp
integer :: n, l, relat, converged, i, maxiter, maxn
real(dp) :: r(NN+1), u(size(r)), Ein, E, P(size(r)), Q(size(r))
real(dp) :: Rp(NN+1)
real(dp) :: Emin_init, Emax_init
real(dp), allocatable :: data(:, :), Eall(:, :)
real(dp) :: E0, au, mu
real(dp) :: r_min

call loadtxt("potential_table.txt", data)

maxn = 26
maxiter = 50
allocate(Eall(0:maxn, maxiter))
do i = 1, maxiter
    r_min = 1.2_dp - (1.2_dp-0.47_dp) * (i-1)/(maxiter-1)
    Eall(0, i) = r_min

    R = mesh_exp(r_min, r_max, a, NN)
    Rp = mesh_exp_deriv(r_min, r_max, a, NN)
    u = spline3(data(:, 1), data(:, 2), R)

    au = 219474.62_dp
    E0 = -0.625_dp
    mu = 1836.12_dp / 2
    u = u * mu
    print *, "rmin = ", r_min
    print *, "Double minimum potential"
    print *, "Mesh parameters (r_min, r_max, a, N):"
    print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
    print *
    print "(A3, A18, A18)", "n", "E [a.u.]", "D [cm^-1]"
    print *
    do n = 1, maxn
        l = 0
        relat = 0
        Ein = -0.5
        Emin_init = -100*mu
        Emax_init = 100
        call solve_radial_eigenproblem(n, l, Ein, eps, 100, r, rp, u, &
            Z, c, relat, .false., Emin_init, Emax_init, converged, E, P, Q)
        if (converged /= 0) then
            print "(I3, A18, A18)", n-1, "0", "0"
            Eall(n, i) = 0
        else
            E = E / mu
            Eall(n, i) = E
            print "(I3, F18.6, F18.6)", n-1, E, (E0-E)*au
        end if
    end do
end do
call savetxt("energies_rmin.txt", Eall)
end program


! @@name:	target_data.5f
! @@type:	F-free
! @@compilable:	yes
! @@linkable:	no
! @@expect:	success
module my_mult
contains
subroutine foo(p0,v1,v2,N)
real,dimension(:) :: p0, v1, v2
integer           :: N,i
   call init(v1, v2, N)
   !$omp target data map(to: v1, v2) map(from: p0)
    call vec_mult(p0,v1,v2,N)
   !$omp end target data
   call output(p0, N)
end subroutine
subroutine vec_mult(p1,v3,v4,N)
real,dimension(:) :: p1, v3, v4
integer           :: N,i
   !$omp target map(to: v3, v4) map(from: p1)
   !$omp parallel do
   do i=1,N
      p1(i) = v3(i) * v4(i)
   end do
   !$omp end target
end subroutine
end module
program main
use my_mult
integer, parameter :: N=1024
real,allocatable, dimension(:) :: p, v1, v2
   allocate( p(N), v1(N), v2(N) )
   call foo(p,v1,v2,N)
end program