!  updated 04/26/2004
!    This is a program which tests the installation
!    The Airy function pacakge by B.R.Fabijonas.
!      reference:  B.R. Fabijonas, Algorithm XXX: Airy functions,
!       ACM Trans. Math. Softw., Vol. xxx, pp. xxx-xxx.
!    Please report all bug reports to bfabi@mail.smu.edu
!
!  This programs tests all featuers of the package:
!    Airy functions of real argument computed by integration of ODE
!    Airy functions or real argument computed by summation of
!      asymptotic expansions
!    Airy functions of complex argument computed by integration of ODE
!    Airy functions or complex argument computed by summation of
!      asymptotic expansions
!    Real and complex zeros of the Airy functions computed by table lookup
!    Real and complex zeros of the Airy functions computed by
!      summation of asymptotic expansions
!    Vectorized version of zeros of Ai(x) and its derivative with
!      associated values
!    Vectorized version of zeros of Bi(x) and its derivative with
!      associated values
!    Vectorized version of zeros of Bi(z) and its derivative with
!      associated values
!    Auxiliary functions for negative real arguments computed by
!      integration of ODE
!    Auxiliary functions for negative real arguments computed by
!      summation of asymptotic expansions
!
! A module to interface the error computation and switch
!   between relative precision and absolute error.
!   the endings:
!    s = real single
!    d = real double
!    c = complex single
!    z = complex double
!
       module error
       implicit none
       private
       public errg
       integer, parameter :: prs = kind(0.0e0)
       integer, parameter :: prd = kind(0.0d0)
       real(prd), parameter :: zerod = 0.0_prd, &
            pid = 3.1415926535897932384626433832795028841971_prd
       real(prs), parameter :: zeros = 0.0_prs, pis = pid
       interface errg
         module procedure errds
         module procedure errs
         module procedure errd
         module procedure errzc
         module procedure errz
         module procedure errc
       end interface
       interface psi
	 module procedure psis
	 module procedure psid
       end interface
       contains
!
! real double and single
         real(prd) function errds(arg1,arg2)
         real(prd) arg1
         real(prs) arg2
         errds = abs(psi(abs(arg1)) - psi(abs(arg2)))
         end function errds
!
! real single
         real(prs) function errs(arg1,arg2)
         real(prs) arg1, arg2
         errs = abs(psi(arg1) - psi(arg2))
         end function errs
!
! real double
         real(prd) function errd(arg1,arg2)
         real(prd) arg1, arg2
         errd = abs(psi(arg1) - psi(arg2))
         end function errd
!
! complex double and single
         real(prd) function errzc(arg1,arg2)
         complex(prd) arg1, arg3
         complex(prs) arg2
         real(prd) x1,x2
         arg3 = arg2
         if ( abs(arg1) < 1.0_prd .or. abs(arg3) < 1.0_prd ) then
           errzc = abs(arg1-arg2)
         else
           x1 = atan2(aimag(arg1),real(arg1,prd))
           x2 = atan2(aimag(arg3),real(arg3,prd))
           x2 = mod(abs(x1-x2),2.0_prd*pid)
           errzc = abs(cmplx(log(abs(arg1/arg3)),min(x2,2.0_prd*pid-x2),prd))
         end if
         end function errzc
!
! complex single
         real(prs) function errc(arg1,arg2)
         complex(prs) arg1, arg2
         real(prs) x1,x2
         if ( abs(arg1) < 1.0_prs .or. abs(arg2) < 1.0_prs ) then
           errc = abs(arg1-arg2)
         else
           x1 = atan2(aimag(arg1),real(arg1))
           x2 = atan2(aimag(arg2),real(arg2))
           x2 = mod(abs(x1-x2),2.0_prs*pis)
           errc = abs(cmplx(log(abs(arg1/arg2)),min(x2,2.0_prs*pis-x2)))
         end if
         end function errc
!
! complex double
         real(prd) function errz(arg1,arg2)
         complex(prd) arg1, arg2
         real(prd) x1,x2
         if ( abs(arg1) < 1.0_prd .or. abs(arg2) < 1.0_prd ) then
           errz = abs(arg1-arg2)
         else
           x1 = atan2(aimag(arg1),real(arg1,prd))
           x2 = atan2(aimag(arg2),real(arg2,prd))
           x2 = mod(abs(x1-x2),2.0_prd*pid)
           errz = abs(cmplx(log(abs(arg1/arg2)),min(x2,2.0_prd*pid-x2),prd))
         end if
         end function errz
!
! real single
         real(prs) function psis(arg)
         real(prs) arg, at
	 at = abs(arg)
         if (at > 1.0_prs) then
           psis = sign(1.0_prs + log(at),arg)
	 else
	   psis = arg
	 end if
         end function psis
!
! real double
         real(prd) function psid(arg)
         real(prd) arg, at
         at = abs(arg)
         if (at > 1.0_prd) then
           psid = sign(1.0_prd + log(at),arg)
	 else
	   psid = arg
	 end if
         end function psid
       end module error
!
!
! program to test installation
!
      program test
      use airy_functions_real_single
      use airy_functions_real_double
      use airy_functions_complex_single
      use airy_functions_complex_double
      use error
      implicit none
      integer, parameter :: prs = kind(0.0e0)
      integer, parameter :: prd = kind(0.0d0)
      real(prd), parameter :: oned = 1.0_prd, thvd = 1.50_prd
      real(prs), parameter :: ones = 1.0_prs, thvs = 1.50_prs
      real(prs) aias, daias, aibs, daibs, rms, pis, g1, tols, ffacs, hs, rs
      real(prd) x, aix, daix, aiass, daiass, rmd, pid, f1, told, ffacd, hd, rd
      real (prd), dimension(5) ::  aizv, daizv, aiassv, daiassv
      complex(prs) zs, ciunits, aiasz, daiasz, aibsz, daibsz
      complex(prd) z, aiz, daiz, aiassz, daiassz, ciunitd
      complex(prd), dimension(5) ::   bizv, dbizv, biassv, dbiassv
      real(prd), dimension(20) :: ray
      complex(prd), dimension(20) :: airay, dairay
      character(3) ai, dai, bi, dbi
      integer ierr, itol, itol2
      integer ierrcnt, i, iptcnt, ilocerrcnt, ilocptcnt, j, nt, na, np, nam, nap
      open(19,file="airyerr.log",status='unknown')

      pid = 3.14159265358979323846264338327950288419716939937510582097494459230782_prd
      pis = real(pid,prs)
      ciunits = cmplx(0.0_prs,1.0_prs,prs)
      ciunitd = cmplx(0.0_prd,1.0_prd,prd)
!
! factor for testing computed values agains stored values or for computing
!   values at the same point in different precisions
      itol = 100
!
! factor for extremely close, but different, argument values
      itol2 = 100
!
! machine epsilons
      tols = exp((1-digits(tols))*log(real(radix(tols),prs)))
      told = exp((1-digits(told))*log(real(radix(told),prd)))
!
! set the counters and declare a few variables
      ierrcnt = 0
      iptcnt = 0
      ai  = ' Ai'
      dai = 'dAi'
      bi  = ' Bi'
      dbi = 'dBi'
      print*, ' ---------------------------------------------------'
      print*, ' '
      print*, 'This is a program which tests the installation '
      print*, '  the Airy function pacakge by B.R. Fabijonas.'
      print*, '  Please send all bug reports to bfabi@smu.edu'
      print*, ' '
!
! write some preliminaries to the output file
      write(19,*) ' This is a log file for the installation of the Airy function'
      write(19,*) ' package by B.R. Fabijonas.  Please send all bug reports'
      write(19,*) ' to bfabi@smu.edu.  The reference for this package is '
      write(19,*) ' B.R. Fabijonas 2004. Algorithm XXX:  Airy functions. '
      write(19,*) ' ACM Trans. Math. Softw., Vol.xxx, pp.xxx-xxx.'
      write(19,*) ' A detailed description of the computation method and parameter'
      write(19,*) ' determination can be found in B.R. Fabijonas, D.W. Lozier,'
      write(19,*) ' and F.W.J. Olver, Computation of complex Airy functions and '
      write(19,*) ' their zeros using asymptotics and the differential equation. '
      write(19,*) ' ACM Trans. Math. Softw., Vol.xxx, pp. xxx-xxx.'
      write(19,*) ' '
      write(19,'("***Parameter values used in the code which are compiler specific.")')
      write(19,'("  We use the abbreviations no. for number of terms and ")')
      write(19,'("   a.e. for asymptotic expansion.")')
      write(19,'("  Single precision computations: standard Airy functions")')
      call airy_info(rms, hs, nt, na, np)
      write(19,'(A45,e24.16)') '  machine epsilon', epsilon(rms)
      write(19,'(A45,e24.16)') '  radius of the delineating circle rho', rms
      write(19,'(A45,e24.16)') '  integration step size h', hs
      write(19,'(A60,i4)') '  no. in the Taylor series N',nt
      write(19,'(A60,i4)') '  no. in the a.e.s S', na
      write(19,'(A60,i4/)') '  number of partitions of the integration ray P', np
      write(19,'("  Single precision computations: auxiliary functions")')
      call airy_aux_info ( rs, hs, nt, nam, nap, np)
      write(19,'(A45,e24.16)') '  radius of the delineating circle rho_m ',rs
      write(19,'(A45,e24.16)') '  integrationstep size h_m ',hs
      write(19,'(A60,i4)') '  no. of terms in the Taylor series N_m ',nt
      write(19,'(A60,i4)') '  no. of terms in the a.e.s of the modulus functions S_m ',nam
      write(19,'(A60,i4)') '  no. of terms in the a.e.s of the phase functions S_theta ',nap
      write(19,'(A60,i4/)') '  no. of partitions of the integration ray P_m ',np
      write(19,'("  Double precision computations: standard Airy functions")')
      call airy_info(rmd, hd, nt, na, np)
      write(19,'(A45,e24.16)') '  machine epsilon ', epsilon(rmd)
      write(19,'(A45,e24.16)') '  the parameter rho ', rmd
      write(19,'(A45,e24.16)') '  step size h ', hd
      write(19,'(A60,i4)') '  no. in the Taylor series N ',nt
      write(19,'(A60,i4)') '  no. used in the a.e.s S ', na
      write(19,'(A60,i4/)') '  number of partitions of the integration ray P ', np
      write(19,'("  Double precision computations: auxiliary functions")')
      call airy_aux_info ( rd, hd, nt, nam, nap, np)
      write(19,'(A45,e24.16)') '  the parameter rho_m ',rd
      write(19,'(A45,e24.16)') '  step size h_m ',hd
      write(19,'(A60,i4)') '  no. in the t.s. N_m ',nt
      write(19,'(A60,i4)') '  no. in the a.e. of the modulus functions S_m ',nam
      write(19,'(A60,i4)') '  no. in the a.e. of the phase functions S_theta ',nap
      write(19,'(A60,i4//)') '  number of partitions of the integration ray P_m ',np
!
!*****************
! testing real routines
!****************
      ilocerrcnt = 0
      ilocptcnt = 0
      write(6,'(" Comparing the function values returned by the")')
      write(6,'("   real routines against stored values")',advance="NO")
      write(19,'( "***Comparing the function values returned by the")')
      write(19,'("  real routines against stored values")')
      x = 5.82340_prd  ! integration routine
      ffacd = oned !10.0_prd**max(oned,thvd*log(abs(x)))
      call airy_ai(x, aix, daix, ierr)
      call airy_ai(real(x,prs),aias,daias,ierr)
      write(19,1000) ai, x
      write(19,1001) aias, aix, 0.1539272803479132e-04_prd
      f1 = errg(aix,0.1539272803479132e-04_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      f1 = errg(daix,-0.3777943926223622e-04_prd)
      write(19,1000) dai, x
      write(19,1001) daias, daix, -0.3777943926223622e-04_prd
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      call airy_bi(x, aix, daix, ierr)
      call airy_bi(real(x,prs),aias,daias,ierr)
      write(19,1000) bi, x
      write(19,1001) aias, aix, 0.4288114816683048e+04_prd
      f1 = errg(aix,0.4288114816683048e+04_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1000) dbi, x
      write(19,1001) daias, daix, 0.1015462058214280e+05_prd
      f1 = errg(daix,0.1015462058214280e+05_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 4
      x = -17.345890_prd  ! asymptotic expansion routine
      ffacd = oned !10.0_prd**max(oned,thvd*log(abs(x)))
      call airy_ai(x, aix, daix, ierr)
      call airy_ai(real(x,prs),aias,daias,ierr)
      write(19,1000) ai, x
      write(19,1001) aias, aix, -0.2677772589719993e+00_prd
      f1 = errg(aix,-0.2677772589719993e+00_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1000) dai, x
      write(19,1001) daias, daix, -0.2900295189410030e+00_prd
      f1 = errg(daix,-0.2900295189410030e+00_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      call airy_bi(x, aix, daix, ierr)
      call airy_bi(real(x,prs),aias,daias,ierr)
      write(19,1000) bi, x
      write(19,1001) aias, aix, 0.6870907209572491e-01_prd
      f1 = errg(aix,0.6870907209572491e-01_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1000) dbi, x
      write(19,1001) daias, daix, -0.1114292633371775e+01_prd
      f1 = errg(daix,-0.1114292633371775e+01_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 4
      write(19,1500) ilocptcnt
      write(19,1501) ilocerrcnt
      iptcnt = iptcnt + ilocptcnt
      ierrcnt = ierrcnt + ilocerrcnt
      write(6,'("...done with ",i3," errors")') ilocerrcnt
!
!*****************
! testing complex routines
!****************
      ilocerrcnt = 0
      ilocptcnt = 0
      print*, ' '
      write(6,'(" Comparing the function values returned by the")')
      write(6,'("   complex routines against stored values")',advance="NO")
      write(19,'( "***Comparing the function values returned by the complex routines")')
      write(19,'("  against stored values")')
      z = cmplx(1.5662_prd,3.681_prd,prd) ! integration routine
      call airy_ai(z, aiz, daiz, ierr)
      call airy_ai(cmplx(1.5662,3.681),aiasz,daiasz,ierr)
      ffacd = oned !10.0_prd**max(oned,thvd*log(abs(z)))
      write(19,2000) ai, real(z,prd),aimag(z)
      write(19,2001) real(aiasz), aimag(aiasz), real(aiz,prd), aimag(aiz), &
              0.3807338825307106e+00_prd,0.3605171603516821e+00_prd
      f1 = errg(aiz,&
        cmplx(0.3807338825307106e+00_prd,0.3605171603516821e+00_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,2000) dai, real(z,prd),aimag(z)
      write(19,2001) real(daiasz), aimag(daiasz), real(daiz,prd), aimag(daiz), &
             -0.2685171251031442e+00_prd,-0.1010759493443000e+01_prd
      f1 = errg(daiz,&
        cmplx(-0.2685171251031442e+00_prd,-0.1010759493443000e+01_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 2
      z = cmplx(-9.8342_prd,4.2811_prd,prd) ! asymptotic expansion routine
      call airy_ai(z, aiz, daiz, ierr)
      call airy_ai(cmplx(-9.8342,4.2811),aiasz,daiasz,ierr)
      write(19,2000) ai, real(z,prd),aimag(z)
      write(19,2001) real(aiasz), aimag(aiasz), real(aiz,prd), aimag(aiz), &
             0.1069401631365655e+06_prd,-0.4772398758353830e+05_prd
      f1 = errg(aiz,&
        cmplx(0.1069401631365655e+06_prd,-0.4772398758353830e+05_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,2000) dai, real(z,prd),aimag(z)
      write(19,2001) real(daiasz), aimag(daiasz), real(daiz,prd), aimag(daiz), &
             -0.2216534220094920e+06_prd,-0.3110801974925891e+06_prd
      f1 = errg(daiz,&
        cmplx(-0.2216534220094920e+06_prd,-0.3110801974925891e+06_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 2
      write(19,1500) ilocptcnt
      write(19,1501) ilocerrcnt
      iptcnt = iptcnt + ilocptcnt
      ierrcnt = ierrcnt + ilocerrcnt
      write(6,'("...done with ",i3," errors")') ilocerrcnt
!
!*****************
! testing interface of the routines
!****************
!  a perturbation analysis on the asymptotic expansion shows that
!    |Ai(x(1+eps)) - Ai(x)| <= |Ai(x)|*(.25+x**(3/2))*eps.  the
!    same holds for the derivative.
!    we will use this tolerance
      print*, ' '
      write(6,'(" Comparing the function values on both side of the delineating circle")')
      write(6,'("   and verifying continuity within a tolerance")',advance="NO")
      write(19,'("***Testing function values on both side of the delineating circle")')
      write(19,'("  and verifying continuity within a tolerance")')
      write(19,'("  (no output printed unless an error is found)")')
      ilocerrcnt = 0
      ilocptcnt = 0
! for real variables
      call airy_info(rms)
      call airy_info(rmd)
      call airy_ai(rms+epsilon(rms)*2,aias,daias,ierr)
      call airy_ai(rms-epsilon(rms)*2,aibs,daibs,ierr)
      ffacs = abs(aias)*(.250_prs + rms*sqrt(rms))*4*epsilon(rms)
      g1 = errg(aias,aibs)
      if ( g1 > itol*ffacs ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,3000) ai, rms
         write(19,3001) aias, aibs
      end if
      ffacs = abs(daias)*(.250_prs + rms*sqrt(rms))*4*epsilon(rms)
      g1 = errg(daias,daibs)
      if ( g1 > itol*ffacs ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,3000) dai, rms
         write(19,3001) daias, daibs
      end if
      call airy_ai(rmd+epsilon(rmd)*2,aix,daix,ierr)
      call airy_ai(rmd-epsilon(rmd)*2,aiass,daiass,ierr)
      ffacd = abs(aix)*(.250_prd + rmd*sqrt(rmd))*4*epsilon(rmd)
      f1 = errg(aix,aiass)
      if ( f1 > itol*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,3000) ai, rmd
         write(19,3001) aix, aiass
      end if
      f1 = errg(daix,daiass)
      ffacd = abs(daix)*(.250_prd + rmd*sqrt(rmd))*4*epsilon(rmd)
      if ( f1 > itol*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,3000) dai, rmd
         write(19,3001) daix, daiass
      end if
      ilocptcnt = ilocptcnt + 4
! for complex variables
      do i = -99,99
        zs = (rms + epsilon(rms)*2)*exp(ciunits*i*0.01_prs*pis)
        call airy_ai(zs,aiasz,daiasz,ierr)
        zs = (rms - epsilon(rms)*2)*exp(ciunits*i*0.01_prs*pis)
        call airy_ai(zs,aibsz,daibsz,ierr)
        ffacs = abs(aiasz)*(0.250_prs+rms*sqrt(rms))*4*epsilon(rms)
        g1 = errg(aiasz,aibsz)
        if ( g1 > itol*ffacs ) then
          ilocerrcnt = ilocerrcnt+1
          write(19,4000) ai, rms*exp(ciunits*i*0.01_prs*pis)
          write(19,4001) aiasz,aibsz
write(19,*) g1, itol*ffacs
        end if
        g1 = errg(daiasz,daibsz)
        ffacs = abs(daiasz)*(0.250_prs+rms*sqrt(rms))*4*epsilon(rms)
        if ( g1 > itol*ffacs ) then
          ilocerrcnt = ilocerrcnt+1
          write(19,*) g1, ffacs
          write(19,4000) dai, rms*exp(ciunits*i*0.01_prs*pis)
          write(19,4001) daiasz,daibsz
        end if
        z = (rmd + epsilon(rmd)*2)*exp(ciunitd*i*0.01_prd*pid)
        call airy_ai(z,aiz,daiz,ierr)
        z = (rmd - epsilon(rmd)*2)*exp(ciunitd*i*0.01_prd*pid)
        call airy_ai(z,aiassz,daiassz,ierr)
        f1 = errg(aiz,aiassz)
        ffacd = abs(aiz)*(0.250_prd+rmd*sqrt(rmd))*4*epsilon(rmd)
        if ( f1 > itol*ffacd ) then
          ilocerrcnt = ilocerrcnt+1
          write(19,4000) ai, rmd*exp(ciunitd*i*0.01_prd*pid)
          write(19,4002) aiasz,aiassz, aiassz
        end if
        f1 = errg(daiz,daiassz)
        ffacd = abs(daiz)*(0.250_prd+rmd*sqrt(rmd))*4*epsilon(rmd)
        if ( f1 > itol*ffacd ) then
          ilocerrcnt = ilocerrcnt+1
          write(19,4000) dai, rmd*exp(ciunitd*i*0.01_prd*pid)
          write(19,4002) daiz,daiassz
        end if
        ilocptcnt = ilocptcnt + 4
      end do
      write(19,1500) ilocptcnt
      write(19,1501) ilocerrcnt
      iptcnt = iptcnt + ilocptcnt
      ierrcnt = ierrcnt + ilocerrcnt
      write(6,'("...done with ",i3," errors")') ilocerrcnt
!
!*****************
! testing different precisions
!****************
      write(6,'(" ")')
      write(6,'(" Comparing the computation in different precisions at random points")')
      write(6,'("   on the real line and in the complex plane and verifying the")')
      write(6,'("   accuracy of the lower precision function values.")',advance='no')
      write(19,'("***Comparing the computation in different precisions at random points ")')
      write(19,'("  on the real line and in the complex plane and verifying the accuracy of")')
      write(19,'("  the lower precision function values (no output printed unless an error is found).")')
      ilocerrcnt = 0
      ilocptcnt = 0
! for real variables
      do i = 1,200
        call random_number(rmd)
        rms = (rmd-0.50_prd)*20.0_prd
        rmd = rms
        call airy_ai(rmd, aix, daix, ierr)
        call airy_ai(rms, aias, daias, ierr)
        f1 = errg(aix,aias)
        ffacs = ones !10.0_prs**max(ones,thvs*log(abs(rms)))
        if ( f1 > itol2*tols*ffacs ) then
          ilocerrcnt = ilocerrcnt+1
          write(19,5000) ai, rmd
          write(19,5001) aias, aix
        end if
        f1 = errg(daix,daias)
        if ( f1 > itol2*tols*ffacs ) then
          ilocerrcnt = ilocerrcnt+1
          write(19,5000) dai, rmd
          write(19,5001) daias, daix
        end if
        ilocptcnt = ilocptcnt + 2
      end do
! for complex variables
      do i = 1,200
        call random_number(rmd)
        call random_number(x)
        zs = rmd*10*exp(ciunitd*(x-0.50_prd)*2.0_prd*pid)
        z = zs
        call airy_ai(zs,aiasz,daiasz,ierr)
        call airy_ai(z,aiz,daiz,ierr)
        ffacs = ones !10.0_prs**max(ones,thvs*log(abs(zs)))
        f1 = errg(aiz,aiasz)
        if ( f1 > itol*tols*ffacs ) then
          ilocerrcnt = ilocerrcnt+1
          write(19,6000) ai, z
          write(19,6001) aiasz,aiz
        end if
        f1 = errg(daiz,daiasz)
        if ( f1 > itol*tols*ffacs ) then
          ilocerrcnt = ilocerrcnt+1
          write(19,6000) dai, z
          write(19,6001) daiasz,daiz
        end if
        ilocptcnt = ilocptcnt + 2
      end do
      write(19,1500) ilocptcnt
      write(19,1501) ilocerrcnt
      iptcnt = iptcnt + ilocptcnt
      ierrcnt = ierrcnt + ilocerrcnt
      write(6,'("...done with ",i3," errors")') ilocerrcnt
!
!*****************
! testing vectorized airy_ai routine
!****************
      print*, ' '
      write(6,'(" Testing the vectorized routine of the Airy functions")',advance='no')
      write(19,'("***Testing the vectorized routine of the Airy functions (no output printed")')
      write(19,'("  unless an error is found).")')
      ilocerrcnt = 0
      ilocptcnt = 0
      do j = -20,20
        do i = 1,20
          ray(i) = 0.5_prd*i
          ilocptcnt = ilocptcnt + 1
        end do
        call airy_ai(ray,0.05_prd*j*pid,airay,dairay,ierr,.true.)
        do i = 1,20
          call airy_ai(ray(i)*exp(ciunitd*j*0.05_prd*pid), aiz,daiz, ierr)
          g1 = errg (aiz,airay(i))
          ffacd = oned !10.0_prd**max(oned,thvd*log(ray(i)))
          if ( g1 > itol2*told*ffacd ) then
            ilocerrcnt = ilocerrcnt+1
            write(19,2002) ai, ray(i), j*0.05_prd*pid
            write(19,2003) aiz,  airay(i)
          end if
          g1 = errg (daiz,dairay(i))
          if ( g1 > itol2*told*ffacd ) then
            ilocerrcnt = ilocerrcnt+1
            write(19,2002) dai, ray(i), j*0.05_prd*pid
            write(19,2003) daiz, dairay(i)
          end if
        end do
      end do
      write(19,1500) ilocptcnt
      write(19,1501) ilocerrcnt
      iptcnt = iptcnt + ilocptcnt
      ierrcnt = ierrcnt + ilocerrcnt
      write(6,'("...done with ",i3," errors")') ilocerrcnt
!
!*****************
! testing zero routines
!****************
      print*, ' '
      print*, 'Testing the routines for the zeros of the Airy functions'
      write(19,'("***Testing the routines for the zeros of the Airy functions")')
      write(19,'("  real and complex zeros--scalar version")')
      ilocerrcnt = 0
      ilocptcnt = 0
      write(6,'("   real zeros by table lookup")',advance='no')
      write(19,'("  **Zeros by table lookup")')
      call airy_ai_zero (18, aias, ierr, ai_assoc=daias, dai_zero=aibs, &
                          dai_assoc=daibs)
      call airy_ai_zero (18, aix, ierr, ai_assoc=aiass, dai_zero=daix, &
                          dai_assoc=daiass)
      ffacd = 10.0_prd**max(oned,thvd*log(abs(18.0_prd)))
      write(19,1002) 18, ai
      write(19,1001) aias, aix, -19.126380474246954_prd
      f1 = errg(aix, -19.126380474246954_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1003) ai, 18
      write(19,1001) daias, aiass,-1.179880729870146_prd
      f1 = errg(aiass,-1.179880729870146_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1002) 18, dai
      write(19,1001) aibs, daix, -18.764798437665956_prd
      f1 = errg(daix,-18.764798437665956_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1003) dai, 18
      write(19,1001) daibs, daiass,-0.2710702785769711_prd
      f1 = errg(daiass,-0.2710702785769711_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 4
      call airy_bi_zero (18, aias, ierr, bi_assoc=daias, dbi_zero=aibs, &
                          dbi_assoc=daibs)
      call airy_bi_zero (18, aix, ierr, bi_assoc=aiass, dbi_zero=daix, &
                          dbi_assoc=daiass)
      write(19,1002) 18, bi
      write(19,1001) aias, aix, -18.765508284480081_prd
      f1 = errg(aix,-18.765508284480081_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1003) bi, 18
      write(19,1001) daias, aiass, -1.174276253118059_prd
      f1 = errg(aiass,-1.174276253118059_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1002) 18, dbi
      write(19,1001) aibs, daix, -19.125697156412638_prd
      f1 = errg(daix,-19.125697156412638_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1003) dbi, 18
      write(19,1001) daibs, daiass,0.2697826139865426_prd
      f1 = errg(daiass,0.2697826139865426_prd)
      if ( f1 > itol*told*ffacd )  ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 4
      call airy_bi_zero (18, aiasz, ierr, bi_assoc=daiasz, dbi_zero=aibsz, &
                          dbi_assoc=daibsz)
      call airy_bi_zero (18, aiz, ierr, bi_assoc=aiassz, dbi_zero=daiz, &
                          dbi_assoc=daiassz)
      write(19,1004) 18, bi
      write(19,2001) aiasz, aiz, 9.494603679187176_prd,16.603624606898762_prd
      f1 = errg(aiz,cmplx(9.494603679187176_prd,16.603624606898762_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1005) bi, 18
      write(19,2001) daiasz, aiassz, 1.445920793639133_prd,-0.8328073286646578_prd
      f1 = errg(aiassz,cmplx(1.445920793639133_prd,-0.8328073286646578_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1004) 18, dbi
      write(19,2001) aibsz, daiz, 9.313152405593771_prd,16.290870307133684_prd
      f1 = errg(daiz,cmplx(9.313152405593771_prd,16.290870307133684_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1005) dbi, 18
      write(19,2001) daibsz, daiassz, -0.3321948851433578_prd,-0.1913210621443901_prd
      f1 = errg(daiassz,&
           cmplx(-0.3321948851433578_prd,-0.1913210621443901_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 4
      write(19,1500) ilocptcnt
      write(19,1501) ilocerrcnt
      iptcnt = iptcnt + ilocptcnt
      ierrcnt = ierrcnt + ilocerrcnt
      write(6,'("...................done with ",i3," errors")') ilocerrcnt
!
!*****************
! testing zero routines
!****************
      write(6,'("   real zeros by asymptotic expansion")',advance='no')
      write(19,'("  **Zeros by asymptotic expansion")')
      call airy_ai_zero (86, aias, ierr, ai_assoc=daias, dai_zero=aibs, &
                          dai_assoc=daibs)
      call airy_ai_zero (86, aix, ierr, ai_assoc=aiass, dai_zero=daix, &
                          dai_assoc=daiass)
      ffacd = oned !10.0_prd**max(oned,thvd*log(abs(86.0_prd)))
      write(19,1002) 86, ai
      write(19,1001) aias, aix, -54.657586491868699_prd
      f1 = errg(aix,-54.657586491868699_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1003) ai, 86
      write(19,1001) daias, aiass,-1.534044239238300_prd
      f1 = errg(aiass,-1.534044239238300_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1002) 86, dai
      write(19,1001) aibs, daix, -54.444826792609810_prd
      f1 = errg(daix,-54.444826792609810_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1003) dai, 86
      write(19,1001) daibs, daiass,-0.2076995780278862_prd
      f1 = errg(daiass,-0.2076995780278862_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 4
      call airy_bi_zero (86, aias, ierr, bi_assoc=daias, dbi_zero=aibs, &
                          dbi_assoc=daibs)
      call airy_bi_zero (86, aix, ierr, bi_assoc=aiass, dbi_zero=daix, &
                          dbi_assoc=daiass)
      write(19,1002) 86, bi
      write(19,1001) aias, aix, -54.444911130586874_prd
      f1 = errg(aix,-54.444911130586874_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1003) bi, 86
      write(19,1001) daias, aiass,-1.532549805062612_prd
      f1 = errg(aiass,-1.532549805062612_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1002) 86, dbi
      write(19,1001) aibs, daix,-54.657502808936158_prd
      f1 = errg(daix,-54.657502808936158_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1003) dbi, 86
      write(19,1001) daibs, daiass, 0.2074972409267743_prd
      f1 = errg(daiass, 0.2074972409267743_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 4
      call airy_bi_zero (86, aiasz, ierr, bi_assoc=daiasz, dbi_zero=aibsz, &
                          dbi_assoc=daibsz)
      call airy_bi_zero (86, aiz, ierr, bi_assoc=aiassz, dbi_zero=daiz, &
                          dbi_assoc=daiassz)
      write(19,1004) 86, bi
      write(19,2001) aiasz, aiz, 27.288200667644368_prd,47.358306153862507_prd
      f1 = errg(aiz,cmplx(27.288200667644368_prd,47.358306153862507_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1005) bi, 86
      write(19,2001) daiasz, aiassz, 1.879045614304762_prd,-1.084330361798879_prd
      f1 = errg(aiassz,cmplx(1.879045614304762_prd,-1.084330361798879_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1004) 86, dbi
      write(19,2001) aibsz, daiz, 27.181741517075782_prd,47.174096724925626_prd
      f1 = errg(daiz,cmplx(27.181741517075782_prd,47.174096724925626_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1005) dbi, 86
      write(19,2001) daibsz, daiassz, -0.2544106266601735_prd,-0.1468108932911459_prd
      f1 = errg(daiassz,cmplx(-0.2544106266601735_prd,-0.1468108932911459_prd,prd))
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 4
      write(19,1500) ilocptcnt
      write(19,1501) ilocerrcnt
      iptcnt = iptcnt + ilocptcnt
      ierrcnt = ierrcnt + ilocerrcnt
      write(6,'("...........done with ",i3," errors")') ilocerrcnt
!
!*****************
! testing vectorized zero routines
!****************
      write(6,'("   real and complex zeros--vectorized version")',advance="no")
      write(19,'("  **Zeros--vectorized version (no output printed unless an error is found)")')
      ilocerrcnt = 0
      ilocptcnt = 0
      call airy_ai_zero (23, aizv, ierr, ai_assoc=aiassv)
      ffacd = oned !10.0_prd**max(oned,thvd*log(abs(27.0_prd)))
      f1 = errg(aizv(1),-22.567612917496504_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 23, ai
         write(19,1008) aizv(1), -22.567612917496504_prd
      end if
      f1 = errg(aizv(2),-23.224165001121680_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 24, ai
         write(19,1008) aizv(2), -23.224165001121680_prd
      end if
      f1 = errg(aizv(3),-23.871564455535918_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 25, ai
         write(19,1008) aizv(3), -23.871564455535918_prd
      end if
      f1 = errg(aizv(4),-24.510301236589672_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 26, ai
         write(19,1008) aizv(4), -24.510301236589672_prd
      end if
      f1 = errg(aizv(5),-25.140821166148957_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 27, ai
         write(19,1008) aizv(5), -25.140821166148957_prd
      end if
      f1 = errg(aiassv(1),1.229700701509681_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) ai, 23
         write(19,1008) aiassv(1),1.229700701509681_prd
      end if
      f1 = errg(aiassv(2),-1.238547875329632_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) ai, 24
         write(19,1008) aiassv(2),-1.238547875329632_prd
      end if
      f1 = errg(aiassv(3),1.247089945259408_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) ai, 25
         write(19,1008) aiassv(3),1.247089945259408_prd
      end if
      f1 = errg(aiassv(4),-1.255349140475735_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) ai, 26
         write(19,1008) aiassv(4),-1.255349140475735_prd
      end if
      f1 = errg(aiassv(5),1.263345282750799_prd)
      if ( f1 > itol*told*ffacd )then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) ai, 27
         write(19,1008) aiassv(5),1.263345282750799_prd
      end if
      ilocptcnt = ilocptcnt + 10
      call airy_ai_zero (23, aizv, ierr, dai_zero=daizv, dai_assoc=daiassv)
      f1 = errg(daizv(1),-22.235232285348914_prd)
      if ( f1 > itol*told*ffacd )then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 23, dai
         write(19,1008) daizv(1),-22.235232285348914_prd
      end if
      f1 = errg(daizv(2),-22.896588738874620_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 24, dai
         write(19,1008) daizv(2),-22.896588738874620_prd
      end if
      f1 = errg(daizv(3),-23.548526295928802_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 25, dai
         write(19,1008) daizv(3),-23.548526295928802_prd
      end if
      f1 = errg(daizv(4),-24.191559709526349_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 26, dai
         write(19,1008) daizv(4),-24.191559709526349_prd
      end if
      f1 = errg(daizv(5),-24.826156425921152_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 27, dai
         write(19,1008) daizv(5),-24.826156425921152_prd
      end if
      f1 = errg(daiassv(1),0.259812670151466_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dai, 23
         write(19,1008) daiassv(1),0.259812670151466_prd
      end if
      f1 = errg(daiassv(2),-0.257916075332572_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dai, 24
         write(19,1008) daiassv(2),-0.257916075332572_prd
      end if
      f1 = errg(daiassv(3),0.256112333779654_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dai, 25
         write(19,1008) daiassv(3),0.256112333779654_prd
      end if
      f1 = errg(daiassv(4),-0.254393342646825_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dai, 26
         write(19,1008) daiassv(4),-0.254393342646825_prd
      end if
      f1 = errg(daiassv(5),0.252751992576574_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dai, 27
         write(19,1008) daiassv(5),0.252751992576574_prd
      end if
      ilocptcnt = ilocptcnt + 10
!
!*****************
! testing vectorized zero routines
!****************
      call airy_bi_zero (23, aizv, ierr, bi_assoc=aiassv)
      f1 = errg(aizv(1),-22.235737881803384_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 23, bi
         write(19,1008) aizv(1),-22.235737881803384_prd
      end if
      f1 = errg(aizv(2),-22.897065554219793_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 24, bi
         write(19,1008) aizv(2),-22.897065554219793_prd
      end if
      f1 = errg(aizv(3),-23.548977079642448_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 25, bi
         write(19,1008) aizv(3),-23.548977079642448_prd
      end if
      f1 = errg(aizv(4),-24.191986850648995_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 26, bi
         write(19,1008) aizv(4),-24.191986850648995_prd
      end if
      f1 = errg(aizv(5),-24.826562012152888_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 27, bi
         write(19,1008) aizv(5),-24.826562012152888_prd
      end if
      f1 = errg(aiassv(1),1.225154995846960_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) bi, 23
         write(19,1008) aiassv(1),1.225154995846960_prd
      end if
      f1 = errg(aiassv(2),-1.234163920487302_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) bi, 24
         write(19,1008) aiassv(2),-1.234163920487302_prd
      end if
      f1 = errg(aiassv(3),1.242855598092317_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) bi, 25
         write(19,1008) aiassv(3),1.242855598092317_prd
      end if
      f1 = errg(aiassv(4),-1.251253611221631_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) bi, 26
         write(19,1008) aiassv(4),-1.251253611221631_prd
      end if
      f1 = errg(aiassv(5),1.259378938688538_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) bi, 27
         write(19,1008) aiassv(5),1.259378938688538_prd
      end if
      ilocptcnt = ilocptcnt + 10
      call airy_bi_zero (23, aizv, ierr, dbi_zero=daizv, dbi_assoc=daiassv)
      f1 = errg(daizv(1),-22.567122080497199_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 23, dbi
         write(19,1008) daizv(1),-22.567122080497199_prd
      end if
      f1 = errg(daizv(2),-23.223701521208962_prd)
      if ( f1 > itol*told*ffacd )then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 24, dbi
         write(19,1008) daizv(2),-23.223701521208962_prd
      end if
      f1 = errg(daizv(3),-23.871125771677974_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 25, dbi
         write(19,1008) daizv(3),-23.871125771677974_prd
      end if
      f1 = errg(daizv(4),-24.509885117016239_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 26, dbi
         write(19,1008) daizv(4),-24.509885117016239_prd
      end if
      f1 = errg(daizv(5),-25.140425655367874_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 27, dbi
         write(19,1008) daizv(5),-25.140425655367874_prd
      end if
      f1 = errg(daiassv(1),-0.258852215916922_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dbi, 23
         write(19,1008) daiassv(1),-0.258852215916922_prd
      end if
      f1 = errg(daiassv(2),0.257003129647316_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dbi, 24
         write(19,1008) daiassv(2),0.257003129647316_prd
      end if
      f1 = errg(daiassv(3),-0.255242710064815_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dbi, 25
         write(19,1008) daiassv(3),-0.255242710064815_prd
      end if
      f1 = errg(daiassv(4),0.253563372437697_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dbi, 26
         write(19,1008) daiassv(4),0.253563372437697_prd
      end if
      f1 = errg(daiassv(5),-0.251958444330784_prd)
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dbi, 27
         write(19,1008) daiassv(5),-0.251958444330784_prd
      end if
      ilocptcnt = ilocptcnt + 10
!
!*****************
! testing vectorized zero routines
!****************
      call airy_bi_zero (23, bizv, ierr, bi_assoc=biassv)
      f1 = errg(bizv(1),&
        cmplx(11.220656371214879_prd,19.580653883038824_prd,prd))
      if ( f1 > itol*told*ffacd )  then
         ilocerrcnt = ilocerrcnt+1
         write(19,1004) 23, bi
         write(19,2003) bizv(1),11.220656371214879_prd,19.580653883038824_prd
      end if
      f1 = errg(bizv(2),&
        cmplx(11.549830143889196_prd,20.148722567309367_prd,prd))
      if ( f1 > itol*told*ffacd )  then
         ilocerrcnt = ilocerrcnt+1
         write(19,1004) 24, bi
         write(19,2003) bizv(2), 11.549830143889196_prd,20.148722567309367_prd
      end if
      f1 = errg(bizv(3),&
        cmplx(11.874378641347221_prd,20.708893464731311_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1004) 25, bi
         write(19,2003) bizv(3),11.874378641347221_prd,20.708893464731311_prd
      end if
      f1 = errg(bizv(4),&
        cmplx(12.194551330833875_prd,21.261588251953778_prd,prd))
      if ( f1 > itol*told*ffacd )  then
         ilocerrcnt = ilocerrcnt+1
         write(19,1004) 26, bi
         write(19,2003) bizv(4),12.194551330833875_prd,21.261588251953778_prd
      end if
      f1 = errg(bizv(5),&
        cmplx(12.510575046777394_prd,21.807190718498749_prd,prd))
      if ( f1 > itol*told*ffacd )  then
         ilocerrcnt = ilocerrcnt+1
         write(19,1004) 27, bi
         write(19,2003) bizv(5),12.510575046777394_prd,21.807190718498749_prd
      end if
      f1 = errg(biassv(1),&
        cmplx(-1.506774749698633_prd,0.868314074899650_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1005) bi, 23
         write(19,2003) biassv(1),-1.506774749698633_prd,0.868314074899650_prd
      end if
      f1 = errg(biassv(2),&
        cmplx(1.517585357164310_prd,-0.874612709515018_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1005) bi, 24
         write(19,2003) biassv(2),1.517585357164310_prd,-0.874612709515018_prd
      end if
      f1 = errg(biassv(3),&
        cmplx(-1.528024149210944_prd,0.880692431621191_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1005) bi, 25
         write(19,2003) biassv(3),-1.528024149210944_prd,0.880692431621191_prd
      end if
      f1 = errg(biassv(4),&
        cmplx(1.538118145012280_prd,-0.886569309158123_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1005) bi, 26
         write(19,2003) biassv(4),1.538118145012280_prd,-0.886569309158123_prd
      end if
      f1 = errg(biassv(5),&
        cmplx(-1.547891444975066_prd,0.892257657608977_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1005) bi, 27
         write(19,2003) biassv(5),-1.547891444975066_prd,0.892257657608977_prd
      end if
      ilocptcnt = ilocptcnt + 10
      call airy_bi_zero (23, bizv, ierr, dbi_zero=dbizv, dbi_assoc=dbiassv)
      f1 = errg(dbizv(1),&
        cmplx(11.053994360667899_prd,19.293078213959429_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 23, dbi
         write(19,2003) dbizv(1),11.053994360667899_prd,19.293078213959429_prd
      end if
      f1 = errg(dbizv(2),&
        cmplx(11.385596969302076_prd,19.865292017137630_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 24, dbi
         write(19,2003) dbizv(2),11.385596969302076_prd,19.865292017137630_prd
      end if
      f1 = errg(dbizv(3),&
        cmplx(11.712438641126221_prd,20.429378925421950_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 25, dbi
         write(19,2003) dbizv(3),11.712438641126221_prd,20.429378925421950_prd
      end if
      f1 = errg(dbizv(4),&
        cmplx(12.034781571133943_prd,20.985781895965161_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 26, dbi
         write(19,2003) dbizv(4),12.034781571133943_prd,20.985781895965161_prd
      end if
      f1 = errg(dbizv(5),&
        cmplx(12.352863681490561_prd,21.534903282918666_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1002) 27, dbi
         write(19,2003) dbizv(5),12.352863681490561_prd,21.534903282918666_prd
      end if
      f1 = errg(dbiassv(1),&
        cmplx(0.318355274563740_prd,0.183451937317410_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dbi, 23
         write(19,2003) dbiassv(1),0.318355274563740_prd,0.183451937317410_prd
      end if
      f1 = errg(dbiassv(2),&
        cmplx(-0.316024910474316_prd,-0.182124025592498_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dbi, 24
         write(19,2003) dbiassv(2),-0.316024910474316_prd,-0.182124025592498_prd
      end if
      f1 = errg(dbiassv(3),&
        cmplx(0.313808934629479_prd,0.180860595992543_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dbi, 25
         write(19,2003) dbiassv(3),0.313808934629479_prd,0.180860595992543_prd
      end if
      f1 = errg(dbiassv(4),&
        cmplx(-0.311697340122842_prd,-0.179656065952459_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dbi, 26
         write(19,2003) dbiassv(4),-0.311697340122842_prd,-0.179656065952459_prd
      end if
      f1 = errg(dbiassv(5),&
        cmplx(0.309681349894832_prd,0.178505532129885_prd,prd))
      if ( f1 > itol*told*ffacd ) then
         ilocerrcnt = ilocerrcnt+1
         write(19,1003) dbi, 27
         write(19,2003) dbiassv(5),0.309681349894832_prd,0.178505532129885_prd
      end if
      ilocptcnt = ilocptcnt + 10
      write(19,1500) ilocptcnt
      write(19,1501) ilocerrcnt
      iptcnt = iptcnt + ilocptcnt
      ierrcnt = ierrcnt + ilocerrcnt
      write(6,'("...done with ",i3," errors")') ilocerrcnt
!
!*****************
! testing modulus and phase routines
!****************
      print*, ' '
      write(6,'(" Comparing the computed modulus, phase, and associated values")')
      write(6,'("   against stored values")',advance='no')
      write(19,'("***Comparing the computed modulus, phase, and associated values against stored values")')
      ilocerrcnt = 0
      ilocptcnt = 0
      x = -5.234_prd
      write(19,'("  **by ODE integration")')
      call airy_aux ( real(x,prs), aias, daias, ierr, aibs, daibs)
      call airy_aux ( x, aix, daix, ierr, aiass, daiass)
      ffacd = oned !10.0_prd**max(oned,thvd*log(abs(x)))
      write(19,1006) 'M(x)', x
      write(19,1001) aias, aix,0.3728081698402362_prd
      f1 = errg(aix,0.3728081698402362_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1007) 'theta(x)', x
      write(19,1001) daias, daix,8.759640547244738_prd
      f1 = errg(daix,8.759640547244738_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1006) 'M(x)', x
      write(19,1001) aibs, aiass,0.8540001773409781_prd
      f1 = errg(aiass,0.8540001773409781_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1007) 'phi(x)', x
      write(19,1001) daibs, daiass,7.209566736849307_prd
      f1 = errg(daiass,7.209566736849307_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 4
!
!*****************
! testing modulus and phase routines
!****************
      x = -25.392_prd
      write(19,'("  **by asymptotic expansion")')
      call airy_aux ( real(x,prs), aias, daias, ierr, aibs, daibs)
      call airy_aux ( x, aix, daix, ierr, aiass, daiass)
      ffacd = oned !10.0_prd**max(oned,thvd*log(abs(x)))
      write(19,1006) 'M(x)', x
      write(19,1001) aias, aix,0.2513325654640693_prd
      f1 = errg(aix,0.2513325654640693_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1007) 'theta(x)', x
      write(19,1001) daias, daix,86.085580681739742_prd
      f1 = errg(daix,86.085580681739742_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1006) 'N(x)', x
      write(19,1001) aibs, aiass,1.2664912447881540_prd
      f1 = errg(aiass,1.2664912447881540_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      write(19,1007) 'phi(x)', x
      write(19,1001) daibs, daiass,84.516738087389200_prd
      f1 = errg(daiass,84.516738087389200_prd)
      if ( f1 > itol*told*ffacd ) ilocerrcnt = ilocerrcnt+1
      ilocptcnt = ilocptcnt + 4
!*****************
! testing modulus and phase in different precisions
!****************
      write(19,'("  **in different precisions (no output printed unless an error is found)")')
      do i = 1,200
        call random_number(rmd)
        rms = -rmd*10.0_prd
        rmd = rms
        call airy_aux ( rmd, aix, daix, ierr, aiass, daiass)
        call airy_aux ( rms, aias, daias, ierr, aibs, daibs)
        ffacd = ones !10.0_prs**max(ones,thvs*log(abs(rms)))
        f1 = errg(aix,aias)
        if ( f1 > itol*tols*ffacs ) then
          ilocerrcnt = ilocerrcnt+1
         write(19,5002) ai, rmd
         write(19,5001) aias,aix
        end if
        f1 = errg(daix,daias)
        if ( f1 > itol*tols*ffacs ) then
          ilocerrcnt = ilocerrcnt+1
         write(19,5002) ai, rmd
         write(19,5001) daias,daix
        end if
        f1 = errg(aiass,aibs)
        if ( f1 > itol*tols*ffacs ) then
          ilocerrcnt = ilocerrcnt+1
         write(19,5003) ai, rmd
         write(19,5001) aibs,aiass
        end if
        f1 = errg(daiass,daibs)
        if ( f1 > itol*tols*ffacs ) then
          ilocerrcnt = ilocerrcnt+11
         write(19,5003) ai, rmd
         write(19,5001) daibs,daiass
        end if
        ilocptcnt = ilocptcnt + 4
      end do
      write(19,1500) ilocptcnt
      write(19,1501) ilocerrcnt
      iptcnt = iptcnt + ilocptcnt
      ierrcnt = ierrcnt + ilocerrcnt
      write(6,'("...done with ",i3," errors")') ilocerrcnt
      write(19,'("Number of tests performed:",i6)') iptcnt
      write(19,'("Number of errors found:",i6)') ierrcnt
      print*, ' '
      print*, 'Number of tests performed:',iptcnt
      print*, 'Number of errors found:',ierrcnt
      print*, ' '
      print*, ' '
      print*, 'End of run'
      print*, ' '
      print*, ' '
      close(21)
1500 format('  The number of points tested is ',i4)
1501 format('  The number of errors found is  ',i4//)
1000 format(2x,'Computing',2x,A3,2x,'at x=',f9.5)
1001 format(17x,'We computed ',e15.8,' in single precision'/,17x,'We computed ', &
                  e23.16,' in double precision',/,5x,'and the stored value is ',e23.16/)
1002 format('  Testing the ',i2,'th zero of ',A3)
1008 format(17x,'We computed ',e23.16,' in double precision',/,5x,'and the stored value is ',e23.16/)
1003 format('  Testing the associated function value of ',A3,' at the ',i2,' zero')
1004 format('  Testing the ',i2,'th complex zero of ',A3)
1005 format('  Testing the associated function value of ',A3,' at the ',i2,' complex zero')
1006 format('  Testing the modulus ',A4,' at x= ',f9.5)
1007 format('  Testing the phase ',A8,' at x= ',f9.5)
2000 format(2x,'Computing',2x,A3,2x,'at z=',f9.5,' +I*(',f9.5,')')
2001 format(2x,'In single precision, we computed ',e15.8,8x,' +I*(',e15.8,')',/,2x, &
                  'In double precision, we computed ',e23.16,' +I*(',e23.16,')',/,11x, &
                  'and the stored value is ',e23.16,' +I*(',e23.16,')',/)
2002 format('Error encountered testing'/'   the vectorized version of ',2x,A3, &
                   2x,'at (r,theta)= (',f9.5,',',f9.5,')')
2003 format(2x,'In double precision, we computed ',e23.16,' +I*(',e23.16,')',/,11x, &
                  'and the stored value is ',e23.16,' +I*(',e23.16,')',/)
3000 format('Error encountered testing each side of ',2x,A3,2x,'at x=',f9.5)
3001 format(12x,'Below we got ',e23.16,/8x,'and above we got ',e23.16/)
4000 format('Error encountered testing each side of ',2x,A3,2x,'at z=',f9.5, &
             ' +I*(',f9.5,')')
4001 format(12x,'Below we got ',e15.8,' +I*(',e15.8,')',/&
          8x,'and above we got ',e15.8,' +I*(',e15.8,')'/)
4002 format(12x,'Below we got ',e23.16,' +I*(',e23.16,')',/&
          8x,'and above we got ',e23.16,' +I*(',e23.16,')'/)
5000 format('Error encountered testing',2x,A3,2x,'at x=',f9.5)
5001 format(9x,'Single returned ',e15.8,/5x,'and double returned ',e23.16/)
5002 format('Error encountered testing the modulus of ',2x,A3,2x,'at x=',f9.5)
5003 format('Error encountered testing the phase of   ',2x,A3,2x,'at x=',f9.5)
6000 format('Error encountered testing',2x,A3,2x,'at z=',f9.5, &
             ' +I*(',f9.5,')')
6001 format(8x,'Single returned ',e15.8,9x,' +I*(',e15.8,')',/&
          4x,'and double returned ',e23.16,' +I*(',e23.16,')'/)
      end program test


*DECK XPMU
      SUBROUTINE XPMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA,
     1   IERROR)
C***BEGIN PROLOGUE  XPMU
C***SUBSIDIARY
C***PURPOSE  To compute the values of Legendre functions for XLEGF.
C            Method: backward mu-wise recurrence for P(-MU,NU,X) for
C            fixed nu to obtain P(-MU2,NU1,X), P(-(MU2-1),NU1,X), ...,
C            P(-MU1,NU1,X) and store in ascending mu order.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      SINGLE PRECISION (XPMU-S, DXPMU-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  XADD, XADJ, XPQNU
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  XPMU
      REAL PQA,NU1,NU2,P0,X,SX,THETA,X1,X2
      DIMENSION PQA(*),IPQA(*)
C
C        CALL XPQNU TO OBTAIN P(-MU2,NU,X)
C
C***FIRST EXECUTABLE STATEMENT  XPMU
      IERROR=0
      CALL XPQNU(NU1,NU2,MU2,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      P0=PQA(1)
      IP0=IPQA(1)
      MU=MU2-1
C
C        CALL XPQNU TO OBTAIN P(-MU2-1,NU,X)
C
      CALL XPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      N=MU2-MU1+1
      PQA(N)=P0
      IPQA(N)=IP0
      IF(N.EQ.1) GO TO 300
      PQA(N-1)=PQA(1)
      IPQA(N-1)=IPQA(1)
      IF(N.EQ.2) GO TO 300
      J=N-2
  290 CONTINUE
C
C        BACKWARD RECURRENCE IN MU TO OBTAIN
C              P(-MU2,NU1,X),P(-(MU2-1),NU1,X),....P(-MU1,NU1,X)
C              USING
C              (NU-MU)*(NU+MU+1.)*P(-(MU+1),NU,X)=
C                2.*MU*X*SQRT((1./(1.-X**2))*P(-MU,NU,X)-P(-(MU-1),NU,X)
C
      X1=2.*MU*X*SX*PQA(J+1)
      X2=-(NU1-MU)*(NU1+MU+1.)*PQA(J+2)
      CALL XADD(X1,IPQA(J+1),X2,IPQA(J+2),PQA(J),IPQA(J),IERROR)
      IF (IERROR.NE.0) RETURN
      CALL XADJ(PQA(J),IPQA(J),IERROR)
      IF (IERROR.NE.0) RETURN
      IF(J.EQ.1) GO TO 300
      J=J-1
      MU=MU-1
      GO TO 290
  300 RETURN
      END


        SUBROUTINE makeStecils(x0)
        ! Subroutine finding nearest neighbour and calculating local
        ! interpolation stencils

        !Input:
        !       x0: Array with dimension(3) [x y z]
        !
        !Output: void
        !
        ! Written by Bo Terp Paulsen (botp), botp@mek.dtu.dk
        !

        USE GlobalVariables

        !Input parameters
        !
        REAL(KIND=long), DIMENSION(:) :: x0(3)

        ! Local variables
        !
        INTEGER, POINTER :: inOrOut
        INTEGER, DIMENSION(:), POINTER :: NN
        REAL(KIND=long), DIMENSION(:) :: x0Local(3)
        REAL(KIND=long), DIMENSION(:), POINTER :: xStencil, yStencil, zStencil

        ! Assign local pointers
        !
        xStencil => interpolation%stencilX
        yStencil => interpolation%stencilY
        zStencil => interpolation%stencilZ
        NN       => interpolation%NN
        inOrOut  => interpolation%inOrOut

        ! Find Nearest Neighbour
        !
        CALL OpenFoamNearestNeighbourXY(x0)
        ! We make a coordinate transformation from physical domain to
        ! OCW3D domain such that $x0(3) \in [0;eta]
        x0Local(1) = x0(1)
        x0Local(2) = x0(2)
        x0Local(3) = x0(3) + FineGrid%h(NN(1),NN(2))
        CALL OpenFoamNearestNeighbourZ(x0Local)

        ! Evaluation of local interpolation stencils
        !
        CALL TaylorInterpolation(1,x0Local,SIZE(xStencil))
        CALL TaylorInterpolation(2,x0Local,SIZE(yStencil))
        IF(inOrOut .EQ. 0) THEN
        CALL TaylorInterpolation(3,x0Local,SIZE(zStencil))
        ELSE
        NN(3) = -1000
        END IF
        END SUBROUTINE makeStecils


c-----------------------------------------------------------------------
      subroutine semhat(a,b,c,d,dp,jp,z,n,w)
c
c     Generate matrices for single element, 1D operators:
c
c        a  = Laplacian
c        b  = diagonal mass matrix
c        c  = convection operator b*d
c        d  = derivative matrix
c        dp = derivative matrix, mapping from pressure nodes to velocity
c        jp = interpolation matrix, mapping from pressure nodes to velocity
c        z  = GLL points
c        n  = polynomial degree (velocity space)
c        w  = work array of size 2*n+2
c
c     Currently, this is set up for pressure nodes on the interior GLL pts.
c
c
      real a(0:n,0:n),b(0:n),c(0:n,0:n),d(0:n,0:n),z(0:n)
      real dp(0:n,1:n-1),jp(0:n,1:n-1)
      real w(0:1)
c
      np = n+1
      nm = n-1
      n2 = n-2
c
      call zwgll (z,b,np)
c
      do i=0,n
         call fd_weights_full(z(i),z,n,1,w)
         do j=0,n
            d(i,j) = w(j+np)                   !  Derivative matrix
         enddo
      enddo
c
      do i=0,n
         call fd_weights_full(z(i),z(1),n2,1,w(1))
         do j=1,nm
            jp(i,j) = w(j   )                  !  Interpolation matrix
            dp(i,j) = w(j+nm)                  !  Derivative    matrix
         enddo
      enddo
c
      call rzero(a,np*np)
      do j=0,n
      do i=0,n
         do k=0,n
            a(i,j) = a(i,j) + d(k,i)*b(k)*d(k,j)
         enddo
         c(i,j) = b(i)*d(i,j)
      enddo
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine fd_weights_full(xx,x,n,m,c)
c
c     This routine evaluates the derivative based on all points
c     in the stencils.  It is more memory efficient than "fd_weights"
c
c     This set of routines comes from the appendix of
c     A Practical Guide to Pseudospectral Methods, B. Fornberg
c     Cambridge Univ. Press, 1996.   (pff)
c
c     Input parameters:
c       xx -- point at wich the approximations are to be accurate
c       x  -- array of x-ordinates:   x(0:n)
c       n  -- polynomial degree of interpolant (# of points := n+1)
c       m  -- highest order of derivative to be approxxmated at xi
c
c     Output:
c       c  -- set of coefficients c(0:n,0:m).
c             c(j,k) is to be applied at x(j) when
c             the kth derivative is approxxmated by a
c             stencil extending over x(0),x(1),...x(n).
c
c
      real x(0:n),c(0:n,0:m)
c
      c1       = 1.
      c4       = x(0) - xx
c
      do k=0,m
      do j=0,n
         c(j,k) = 0.
      enddo
      enddo
      c(0,0) = 1.
c
      do i=1,n
         mn = min(i,m)
         c2 = 1.
         c5 = c4
         c4 = x(i)-xx
         do j=0,i-1
            c3 = x(i)-x(j)
            c2 = c2*c3
            do k=mn,1,-1
               c(i,k) = c1*(k*c(i-1,k-1)-c5*c(i-1,k))/c2
            enddo
            c(i,0) = -c1*c5*c(i-1,0)/c2
            do k=mn,1,-1
               c(j,k) = (c4*c(j,k)-k*c(j,k-1))/c3
            enddo
            c(j,0) = c4*c(j,0)/c3
         enddo
         c1 = c2
      enddo
c     call outmat(c,n+1,m+1,'fdw',n)
      return
      end
c-----------------------------------------------------------------------


program findFragmentIntersection
	use cubeClass
	implicit none
	type(cube)::cube1,cube2
	character(len=200)::input1,input2,output

	real(kind=8)::x,y,z,dx,dy,dz,zFragmentIntersection,densToAngstrom,bohrToAngstrom
	real(kind=8)::x0Value,y0Value,zTmp,tmpval1,tmpval2,deltaZ,zDensity1AtIntersection,zDensity2AtIntersection
	integer::x0,y0,z0Length,z0SP
	real(kind=8),allocatable,dimension(:)::zDensity1,zDensity2,difDensity,z0Value,z0Density
	integer(kind=8),allocatable,dimension(:)::z0

	integer :: i1,i2,i3

	call getarg(1,input1)
	call getarg(2,input2)
	call getarg(3,output)

	if (trim(output) == "")then
		output="intersection.dat"
	end if

	cube1 = readCube(input1)
	cube2 = readCube(input2)

	if (cube1%nx.NE.cube2%nx.OR.cube1%ny.NE.cube2%ny.OR.cube1%nz.NE.cube2%nz.OR. &
		cube1%origin_x.NE.cube2%origin_x.OR.cube1%origin_y.NE.cube2%origin_y.OR.cube1%origin_z.NE.cube2%origin_z.OR. &
		all(cube1%axis_x.NE.cube2%axis_x).OR.all(cube1%axis_y.NE.cube2%axis_y).OR.all(cube1%axis_z.NE.cube2%axis_z)) then
			write(*,*) 'The grids of the input files "',trim(input1),'" and "',trim(input2),'" is not equal!'
			stop
	end if

	x=cube1%origin_x
	y=cube1%origin_y
	z=cube1%origin_z
	dx=cube1%axis_x(1)
	dy=cube1%axis_y(2)
	dz=cube1%axis_z(3)

	allocate(zDensity1(cube1%nz))
	allocate(zDensity2(cube1%nz))
	allocate(difDensity(cube1%nz))
	allocate(z0(cube1%nz))
	allocate(z0Value(cube1%nz))
	allocate(z0Density(cube1%nz))

	!!!!!!!!!!!
	!It cannot be assumed that a data point lies exactly on the z-axis.
	!Therefore, the data points (x0,y0), (x0-1,y0), (x0,y0-1) and (x0-1,y0-1) around the z-axis are determined.
	!x0 and y0 are the array indexes.
	!x0Value and y0Value the x and y coordinates of point (x0,y0).
	!!!!!!!!!!!

	x0Value = x
	do i1 = 1, cube1%nx
		if ((x0Value<0) .NEQV. (x<0))then
			x0 = I1
			exit
		end if
		x0Value = x0Value + dx
	end do

	y0Value = y
	do i2 = 1, cube1%ny
		if ((y0Value<0) .NEQV. (y<0))then
			y0 = i2
			exit
		end if
		y0Value = y0Value + dy
	end do

	!Interpolation of the electron density on the z-axis for each fragment
	!First along the x-axis  -> tmpval1 and tmpval2
	!Then along the y-axis -> zDensity

	do i3 = 1, cube1%nz
		tmpval1 = cube1%values(x0,y0,i3) - ( x0Value * (cube1%values(x0,y0,i3) - cube1%values(x0-1,y0,i3)) / dx)
		tmpval2 = cube1%values(x0,y0-1,i3) - ( x0Value * (cube1%values(x0,y0-1,i3) - cube1%values(x0-1,y0-1,i3)) / dx)
		zDensity1(i3) = tmpval1 - ( y0Value * (tmpval1 - tmpval2) / dy)

		tmpval1 = cube2%values(x0,y0,i3) - ( x0Value * (cube2%values(x0,y0,i3) - cube2%values(x0-1,y0,i3)) / dx)
		tmpval2 = cube2%values(x0,y0-1,i3) - ( x0Value * (cube2%values(x0,y0-1,i3) - cube2%values(x0-1,y0-1,i3)) / dx)
		zDensity2(i3) = tmpval1 - ( y0Value * (tmpval1 - tmpval2) / dy)
	end do

	!Calculate difference electron density between both fragments on the z-axis
	difDensity = zDensity1 - zDensity2

	!Determine all sign changes of difDensity and save them in z0 (array indexes), z0Values (z coordinates)
    !and z0Density (Sum of electron density of both fragment at this point)
	zTmp = z + dz
	z0Length = 0
	do i3 = 2, cube1%nz
		if ((difDensity(i3-1) < 0) .NEQV. (difDensity(i3)<0))then
			z0Length = z0Length + 1
			z0(z0Length) = i3
			z0Value(z0Length) = zTmp
			z0Density(z0Length) = zDensity1(i3) + zDensity2(i3)
		end if
		zTmp = zTmp + dz
	end do

	!The point on the z-axis, where the electron density of both fragments is the same,
	!has the highes value of z0Density of all sign chane points
	if (z0Length == 0) then
		write(*,*) 'No fragment intersection found! Exit!'
		stop
	end if

	z0SP = maxloc(z0Density(1:z0Length),1)

	!write(*,*) 'Found sign changes:'
	!write(*,*) '#zValue = ',z0Value(1:z0Length)
	!write(*,*) '#zDensity = ',z0Density(1:z0Length)
	!write(*,*) '#Index with highest density = ',z0SP

	!The real point is probably between the data points z0(z0SP) and z0(zoSP)-1 -> Interpolation

	deltaZ = - ( difDensity(z0(z0SP))/ ((difDensity(z0(z0SP)) - difDensity(z0(z0SP)-1)) / dz))
	zFragmentIntersection = z0Value(z0SP) + deltaZ

	zDensity1AtIntersection= zDensity1(z0(z0SP)) + ( deltaZ * (zDensity1(z0(z0SP)) - zDensity1(z0(z0SP)-1)) / dz)
	zDensity2AtIntersection= zDensity2(z0(z0SP)) + ( deltaZ * (zDensity2(z0(z0SP)) - zDensity2(z0(z0SP)-1)) / dz)

	!write results

	open(unit=13,file=output,status='replace')
	write(13,*) '#Intersection of both fragments/ point of same e-density on the z-axis):'
	write(13,*) '#z[Angstrom] = ',bohrToAngstrom(zFragmentIntersection)
	write(13,*) '#e-Density(Frag1)[e Angstrom^-3] = ',densToAngstrom(zDensity1AtIntersection)
	write(13,*) '#e-Density(Frag2)[e Angstrom^-3] = ',densToAngstrom(zDensity2AtIntersection)
	write(13,*)	'#Values on the z-axis: z / e-Density(Frag1) / e-Density(Frag2) / e-Density difference'

	zTmp = z
	do i3 = 1, cube1%nz
	 write(13,*) bohrToAngstrom(zTmp),densToAngstrom(zDensity1(i3)),densToAngstrom(zDensity2(i3)),densToAngstrom(difDensity(i3))
	 zTmp=zTmp+dz
	end do

	close(13)

end program findFragmentIntersection

real(kind=8) function densToAngstrom(a)
	implicit none
	real(kind=8),intent(in)::a
	densToAngstrom = a / (0.529177210903_8 ** 3)
end function densToAngstrom

real(kind=8) function bohrToAngstrom(a)
	implicit none
	real(kind=8),intent(in)::a
	bohrToAngstrom = a * 0.529177210903_8
end function bohrToAngstrom


C     TODO: rename to change_color
      subroutine chanco(V, UB, BV, VR, RI, g, xug, xgr, xri, xiz, xgi)
C         Transformation between the Johnson-Cousins UBVRI photometry
C         system and the SDSS ugriz system. Follow the eq. 1 to 8 from
C         Jordi,Grebel & Ammon, 2006, A&A,460
          implicit none

C         Used parameters (Table 3)
          real, parameter :: a1 = 0.630,
     &                       a2 = 1.007,
     &                       a3 = 1.584,
     &                       a5 = 0.750,
     &                       a7 = 1.646,
     &                       b1 = -0.124,
     &                       b2 = -0.236,
     &                       b3 = -0.386,
     &                       b5 = 0.770,
     &                       b7 = -0.139,
     &                       c5 = 0.720
C         TODO: give better names
          real :: V, UB, BV, VR, RI, g, xug, xgr, xri, xiz, xgi

          g = V + a1 * BV + b1
          xug = a5 * UB + b5 * BV + c5
          xgr = a7 * VR + b7
          xri = a2 * RI + b2
          xiz = (a3 - a2) * RI + (b3 - b2)
          xgi = xgr + xri
      end subroutine


      subroutine force(s,z,fs,fz,pot)

      parameter (pc0=0.282094792, pc2=0.630783131, pc4=0.846284375)
      parameter (pc6=1.017107236, pc8=1.163106623)
      real pc(20), p(20), dp(20)
      real pot

      include 'commonblocks.h'

      r=sqrt(s*s+z*z)
      ihi=int(r/dr)+1
      if (ihi.lt.1) ihi=1
      if (ihi.gt.nr) ihi=nr
      r1=dr*(ihi-1)
      r2=dr*ihi
      redge = nr*dr
      t=(r-r1)/(r2-r1)
      ihim1 = ihi - 1
      tm1 = 1.0 - t
      if (r.eq.0.) then
         fs = 0.0
         fz = 0.0
      else
         costheta=z/r
         ct2 = costheta*costheta
         sintheta=s/r

         do l=0,lmax,2
            pc(l/2+1) = sqrt((2.0*l + 1)/(4.0*pi))
            p(l/2+1) = plgndr1(l,costheta)
            if( costheta .eq. 1.0 ) then
               dp(l/2+1) = 0.0
            else
               st2 = 1.0 - costheta*costheta
               dp(l/2+1) = l*(plgndr1(l-1, costheta) -
     +              costheta*p(l/2+1))/st2
            endif
         enddo
         do i=1,lmax/2+1
            p(i) = p(i)*pc(i)
            dp(i) = dp(i)*pc(i)
         enddo

         if( r .le. redge ) then
             frr = 0.0
             do i=1,lmax/2+1
                frr = frr + p(i)*(t*fr(i,ihi) + tm1*fr(i,ihim1))
             enddo
             fth = 0.0
             do i=2,lmax/2+1
                fth = fth + sintheta*dp(i)*(t*apot(i,ihi) +
     +               tm1*apot(i,ihim1))
             enddo
             pot = 0.0
             do i=1,lmax/2+1
                pot = pot + p(i)*(t*apot(i,ihi) + tm1*apot(i,ihim1))
             enddo
         else
             frr = 0.0
             do i=1,lmax/2+1
                 l = 2*(i-1)
                 frr = frr + (l+1)*p(i)*apot(i,nr) /
     +                    redge*(redge/r)**(l+2)
             enddo
             fth = 0.0
             do i=2,lmax/2+1
                 l = 2*(i-1)
                 fth = fth + sintheta*dp(i)*apot(i,nr)*(redge/r)**(l+1)
             enddo
             pot = 0.0
             do i=1,lmax/2+1
                l = 2*(i-1)
                pot = pot + p(i)*apot(i,nr)*(redge/r)**(l+1)
             enddo
         endif
         if( idiskflag .eq. 1 ) then
             pot = pot + appdiskpot(s,z)
         endif

         fs = -(sintheta*frr + costheta/r*fth)
         fz = -(costheta*frr - sintheta/r*fth)
         if( idiskflag .eq. 1 ) then
            call appdiskforce(s,z,fsad,fzad)
            fs = fs + fsad
            fz = fz + fzad
         endif
      endif
      return
      end


module dflt_intent

contains

subroutine foo(c, d)
real :: c, d, e, g
e = f(c)
g = f(d)

contains

real function f(x)
real, intent(in) :: x
f = 2*x
print *, f
end function f

end subroutine foo

end module

program main
  use dflt_intent
  call foo(0.0, 2.0)
end program


!! R417 complex-literal-constant
!    is ( real-part , imag-part )

COMPLEX :: z = (0.0098,0.e9)
COMPLEX :: y = ( 1. , 13.e9)

END


module histograms
  implicit none
  !! Simple histogram types and methods

  type HistoR8
    integer(8), allocatable :: nh(:)
    real(8), allocatable :: h(:)
    real(8) :: dri, rmin
    integer(8) :: nupd
  end type

contains

subroutine histor8_init(p, dr, rmin, n)
  !! Initialize an histogram
  type(HistoR8), intent(out) :: p
  real(8), intent(in) :: dr   !! step
  real(8), intent(in) :: rmin !! minimum value
  integer, intent(in) :: n    !! number of points

  p%nupd = 0
  p%dri = 1.d0 / dr
  p%rmin = rmin
  if(allocated(p%nh)) then
    if(ubound(p%nh, 1) /= n) then
      deallocate(p%nh)
      allocate(p%nh(n))
    end if
  else
    allocate(p%nh(n))
  end if
  p%nh = 0.0

end subroutine

subroutine histor8_reset(p)
  !! Reset an histogram to do a new sampling
  type(HistoR8), intent(inout) :: p

  p%nupd = 0
  p%nh = 0.0
end subroutine

subroutine histor8_update(p, val)
  !! Update an histogram
  type(HistoR8), intent(inout) :: p
  real(8) :: val
  integer :: ival
  ival = floor(p%dri * (val-p%rmin)) + 1
  if(ival >= lbound(p%nh,1) .and. ival <= ubound(p%nh,1)) then
    p%nh(ival) = p%nh(ival) + 1
  end if
  p%nupd = p%nupd + 1

end subroutine

subroutine histor8_update_n(p, val, n)
  !! Update an histogram with `n` values
  type(HistoR8), intent(inout) :: p
  real(8), intent(in) :: val
  integer, intent(in) :: n
  integer :: ival
  ival = floor(p%dri * (val-p%rmin)) + 1
  if(ival >= lbound(p%nh,1) .and. ival <= ubound(p%nh,1)) then
    p%nh(ival) = p%nh(ival) + n
  end if
  p%nupd = p%nupd + n
end subroutine

subroutine histor8_set_distribution(p)
  !! Sets p%h to a distribution
  type(HistoR8), intent(inout) :: p

  real(8) :: toti

  if(allocated(p%h)) then
    if(ubound(p%h,1) /= ubound(p%nh,1)) then
      deallocate(p%h)
      allocate(p%h(ubound(p%nh,1)))
    end if
  else
    allocate(p%h(ubound(p%nh,1)))
  end if

  toti = 1.d0/sum(p%nh) ! or p%nupd

  p%h = real(p%nh,8)*p%dri*toti

end subroutine

end module


!>  Example of computing a fill-reducing ordering of a sparse matrix
!
!   Source: http://comp.lang.fortran.narkive.com/uFmDM7Bo/how-to-call-a-metis-subroutine-from-my-fortran-code
!
program test_NodeND

    use metis_interface, only: idx_t, METIS_SetDefaultOptions, METIS_NodeND, &
        METIS_NOPTIONS, METIS_OK, METIS_OPTION_NUMBERING
    implicit none

    integer(idx_t), parameter :: n = 15 ! number of vertices
    integer(idx_t), parameter :: m = 22 ! number of edges

    integer(idx_t) :: xadj(n+1), adjncy(2*m) ! graph adjacency structure
    integer(idx_t) :: perm(n), iperm(n) ! fill-reducing permutation and inverse permutation

    integer(idx_t) :: options(0:METIS_NOPTIONS-1), ios

    write(*,'(A)') "TEST METIS_NodeND"

    !  1---2---3---4---5
    !  |   |   |   |   |
    !  6---7---8---9---10
    !  |   |   |   |   |
    !  11--12--13--14--15

    xadj = [1,3,6,9,12,14,17,21,25,29,32,34,37,40,43,45]
    adjncy = [2,6,1,3,7,2,4,8,3,5,9,4,10,1,7,11,2,6, &
              8,12,3,7,9,13,4,8,10,14,5,9,15,6,12,7,11,13, &
              8,12,14,9,13,15,10,14]

    ios = METIS_SetDefaultOptions(options)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_SetDefaultOptions failed with error: ", ios
        error stop 1
    end if
    options(METIS_OPTION_NUMBERING) = 1 ! Fortran-style numbering

    ios = METIS_NodeND(n,xadj,adjncy,options=options,perm=perm,iperm=iperm)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_NodeND failed with error: ", ios
        error stop 1
    end if

    write(*,'(A,*(I2,:,1X))') "perm  = ", perm
    write(*,'(A,*(I2,:,1X))') "iperm = ", iperm

end program


subroutine logvis_to_vis(logvis,vis)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    logvis_to_vis  tlm for logvis to vis
!   prgmmr: zhu               org: np20                date: 2011-06-30
!
! abstract: get visibility vis from logarithm of vis
!
! program history log:
!   2011-06-30  zhu
!
!   input argument list:
!      logvis
!
!   output argument list:
!      vis
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds, only: r_kind,i_kind
  use gridmod, only: lat2,lon2
  use derivsmod, only: dvisdlog

  implicit none
  real(r_kind),intent(in   ) :: logvis(lat2,lon2)
  real(r_kind),intent(  out) :: vis(lat2,lon2)

  integer(i_kind) i,j

  do j=1,lon2
     do i=1,lat2
        vis(i,j)=dvisdlog(i,j)*logvis(i,j)
     end do
  end do
end subroutine logvis_to_vis

subroutine logvis_to_vis_ad(logvis,vis)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    logvis_to_vis_ad  adjoint of logvis_to_vis
!   prgmmr: zhu               org: np20                date: 2011-06-30
!
! abstract: adjoint of logvis_to_vis
!
! program history log:
!   2011-06-30  zhu
!
!   input argument list:
!      logvis
!      vis
!
!   output argument list:
!      logvis
!      vis
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: zero
  use gridmod, only: lat2,lon2
  use derivsmod, only: dvisdlog

  implicit none
  real(r_kind),intent(inout) :: logvis(lat2,lon2)
  real(r_kind),intent(inout) :: vis(lat2,lon2)

  integer(i_kind) i,j

  do j=1,lon2
     do i=1,lat2
        logvis(i,j)=logvis(i,j)+dvisdlog(i,j)*vis(i,j)
        vis(i,j)=zero
     end do
  end do
end subroutine logvis_to_vis_ad


PROGRAM LA_SSBGVX_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_SBGVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
   CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: UPLO
   INTEGER :: I, J, INFO, N, KA, KB, M, IL, IU
   REAL(WP) ::  VL, VU
!  .. LOCAL ARRAYS ..
   INTEGER, ALLOCATABLE :: IFAIL(:)
   REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:), W(:)
   REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), Z(:,:), DUMMY(:,:), Q(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'SSBGVX ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N, KA, KB
   PRINT *, 'N = ', N, ' KA = ', KA, ' KB = ', KB
   ALLOCATE ( A(KA+1,N), AA(KA+1,N), B(KB+1,N), BB(KB+1,N), W(N), Z(N,N) )
   ALLOCATE (IFAIL(N), Q(N,N))
!
   VL = -10.0; VU=10.0; IL=1; IU=N; UPLO = 'U'
   AA = HUGE(1.0_WP); BB = HUGE(1.0_WP)
   DO I = 1, KA+1; READ (NIN, *) (AA(I, J), J = KA-I+2, N); ENDDO
   DO I = 1, KB+1; READ (NIN, *) (BB(I, J), J = KB-I+2, N); ENDDO
   A=AA; B=BB
   WRITE(NOUT,*) 'The matrix A:'
   DO I = 1, KA+1; WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) AA(I,:); ENDDO
   WRITE(NOUT,*) 'The matrix B:'
   DO I = 1, KB+1; WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) BB(I,:); ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_SSBGVX LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, ''U'', Z, INFO )'
   A=AA; B=BB
   CALL LA_SBGVX( A, B, W, UPLO, Z, INFO = INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
   WRITE(NOUT,FMT) W
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
!
     UPLO = 'U'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, ''U'', Z )'
   A=AA; B=BB
   CALL LA_SBGVX( A, B, W, UPLO, Z )
   WRITE(NOUT,*) ' EIGENVALUES:'
   WRITE(NOUT,FMT) W
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, Z=Z )'
   A=AA; B=BB
   CALL LA_SBGVX( A, B, W, Z=Z )
   WRITE(NOUT,*) ' EIGENVALUES:'
   WRITE(NOUT,FMT) W
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, ''L'', Z, INFO=INFO )'
   A=AA; B=BB; W = HUGE(1.0_WP); Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, Z, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
   WRITE(NOUT,FMT) W
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W )
   WRITE(NOUT,*) ' EIGENVALUES:'
   WRITE(NOUT,FMT) W
! STARTING THE ERROR TESTS:
! ERROR 1
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( DUMMY, B, W, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( DUMMY, B, W, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 2
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, DUMMY, W, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, DUMMY, W, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 3
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W(1:N-1), INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W(1:N-1), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 4
   UPLO = '9'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, UPLO=''9'', INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 5
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, UPLO, Z(:, 1:N-1), INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, Z(:, 1:N-1), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 5
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, UPLO, Z(1:N-1,:), INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, Z(1:N-1,:), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 6
   VL = 10.0; VU = -10.0
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, UPLO, Z, VL, VU, M, IFAIL, Q, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, Z,  VL, VU, M=M, IFAIL=IFAIL, Q=Q, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 7
   IL = 1; IU = N; VL=-10.0; VU=10.0
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, UPLO, Z, VL, VU, IL, IU, M, IFAIL, Q, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, Z, VL, VU, IL, IU, M, IFAIL, Q, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
   IU=N; IL=1
! ERROR 8
   IL = -1; IU = N+1
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, UPLO, Z, IL=IL, IU=IU, M=M, IFAIL=IFAIL, Q=Q, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, Z, IL=IL, IU=IU, M=M, IFAIL=IFAIL, Q=Q, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
   IU=N; IL=1
! ERROR 9
   IU = N+1
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, UPLO, Z, IL=IL, IU=IU, M=M, IFAIL=IFAIL, Q=Q, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, Z, IL=IL, IU=IU, M=M, IFAIL=IFAIL, Q=Q, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
   IU=N
! ERROR 10
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W,  UPLO, Z, VL, VU, M=M, IFAIL=IFAIL(1:N-1), Q=Q, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, Z, VL, VU, M=M, IFAIL=IFAIL(1:N-1), Q=Q, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 10
   UPLO= 'L'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W,  UPLO, VL=VL, VU=VU, M=M, IFAIL=IFAIL, Q=Q, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, VL=VL, VU=VU, M=M, IFAIL=IFAIL, Q=Q, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 11
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, UPLO, Z, VL, VU, M=M, IFAIL=IFAIL, Q=Q(1:N-1,:), INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, Z,  VL, VU, M=M, IFAIL=IFAIL, Q=Q(1:N-1,:), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 11
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, UPLO, Z, VL, VU, M=M, IFAIL=IFAIL, Q=Q(:,1:N-1), INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, Z,  VL, VU, M=M, IFAIL=IFAIL, Q=Q(:,1:N-1), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 11
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SBGVX( A, B, W, UPLO, VL=VL, VU=VU, M=M, IFAIL=IFAIL, Q=Q, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SBGVX( A, B, W, UPLO, VL=VL, VU=VU, M=M, IFAIL=IFAIL, Q=Q, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
END PROGRAM LA_SSBGVX_ET_EXAMPLE