C> \file shoot.f
C> \brief Solver routines for eigenvalue shooting and utilities
C> \author S. Scott Collis
C***********************************************************************
C> \author S. Scott Collis
C>
C> \brief Solve eigenvalue problem using Godunov-Conte method
C>
C> \details First order linear boundary value problem solver
C> using Conte's method.  Fourth order Runge-Kutta is used for
C> time advancement
C>
C> \param[in] nstep   number of integration steps between t0 and tf
C> \param[in] n       number of ODEs to integrate
C> \param[in] r       number of particular solutions
C> \param[in] yo      starting values
C> \param[in] yf      ending values
C> \param[in] to      Interval start value
C> \param[in] tf      Interval end value
C> \param[in,out] c   Current eigenvalue
C> \param[in] eigfun  Whether to output eigenfunction at the end
C> \param[in] FHOMO   Subroutine for homogeneous equation
C> \param[in] FPART   Subroutine for particular equation
C> \param[in] INPROD  Function to compute inner product
C***********************************************************************
      subroutine CONTE(nstep, n, r, yo, yf, to, tf, c, eigfun,
     &                 FHOMO, FPART, INPROD)
C***********************************************************************
      integer     nstep, n, r
      complex     yo(n), yf(n)
      real        to, tf, h
      complex     c
      logical     eigfun
      complex     INPROD
      external    INPROD, FHOMO, FPART
C***********************************************************************
      integer     i, m, q, s, mi, mj, qend, IPVT(n-r), icount
      real        t, tq(0:nstep)
      complex     B(n-r,0:nstep), err, cold, ctemp
      complex     U(n,n-r,0:nstep), P(n-r,n-r,0:nstep), z(n,n-r)
      complex     y(n,0:nstep), v(n,0:nstep), w(n), omega(n,0:nstep)
      complex     eta(n), A(n,n-r), x(n), FAC(n-r,n-r), det1, det
      complex     olderr, ut(n,n-r), fd, vmax
      complex     cm1, cm2, errm1, errm2, qt, At, Bt, Ct, Utemp(n)
      real        test, testalpha, pi, det2, AI(n,n-r), angle
      real        aa, bb, cc, fdxr, fdxi, fdyr, fdyi
      logical     norm
      real        errtol, maxcount, eigtol
C***********************************************************************
c
c     initialize variables
c
      errtol = 1.0e-15
      maxcount = 20
      eigtol = 1.0e-15
c
c     set the normalization constraint
c
      pi = ACOS(-1.0)
c
c     Orthonormalize when angle is greater than testalpha
c     angle = [0,90] degrees (10 deg seems good)
c
      angle = 10.0
      testalpha = angle*pi/180.0
c
c     compute the step size
c
      h = (tf-to)/nstep
c
c     Begin the eigenvalue iteration loop
c
      icount = 1
      err = 1.0
      cm1 = c + 1.0
      do while ((abs(err) .ge. errtol .and. icount .le. maxcount) .and.
     &          (abs(c-cm1) .ge. eigtol) )
c
c       q = number of normalizations
c       qend = total number of normalizations
c       tq = time at normalization q
c
        q = 0
        tq(0) = to
c
c       Set the Homogeneous initial conditions
c
        do m = 1, n-r
          do i = 1, n
            if (i .eq. r+m) then
              u(i,m,0) = 1.0
            else
              u(i,m,0) = 0.0
            end if
          end do
        end do
c
c       Set the particular initial conditions
c
        do i = 1, r
          v(i,0) = yo(i)
        end do
        do i = r+1, n
          v(i,0) = 0.0
        end do
c
c       Integrate the homo. and particular equations
c
        do k = 1, nstep
          t = to + h*k
c
c         Loop thru all homogeneous solutions
c
          do m = 1, n-r
#ifdef USE_RKCK45
            call CRKCK45(n, U(1,m,k-1), U(1,m,k), t-h, h, FHOMO)
#else
            call CRK4(n, U(1,m,k-1), U(1,m,k), t-h, h, FHOMO)
#endif
          end do
c
c         Now the particular solution
c
#ifdef USE_RKCK45
          call CRKCK45(n, v(1,k-1), v(1,k), t-h, h, FPART)
#else
          call CRK4(n, v(1,k-1), v(1,k), t-h, h, FPART)
#endif
c
c         Check to see it orthonomalization is required
c
          norm = .false.
          do mi = 1, n-r
            do mj = 1, n-r
              if (mi .ne. mj) then
                aa = ABS(inprod(n, U(1,mi,k), U(1,mi,k)))
                bb = ABS(inprod(n, U(1,mj,k), U(1,mj,k)))
                cc = ABS(inprod(n, U(1,mi,k), U(1,mj,k)))
#ifdef USE_ANALYTIC_INPROD
                test = ACOS(MIN(1.0,ABS(cc)/SQRT(aa*bb)))
#else
                test = ACOS(ABS(cc)/SQRT(aa*bb))
#endif
                if (test .le. testalpha) norm = .true.
#ifdef VERBOSE
                write (*,*) k, mi, mj, 180.0*test/pi,
     &                      180.0*testalpha/pi, norm
#endif
              end if
            end do
          end do
c
c         Perform normalization
c
c         if (norm .or. (k .eq. nstep) .or. (mod(k,10) .eq. 0) ) then
          if (norm .or. (k .eq. nstep)) then
            q = q + 1
            tq(q) = t
            if (k .eq. nstep) qend = q
c
c           Gram-Schmidt
c
            w(1) = SQRT(inprod(n, U(1,1,k), U(1,1,k)))
            do i = 1, n
              z(i,1) = U(i,1,k)/w(1)
            end do
            do mi = 2, (n-r)
              do i = 1, n
                eta(i) = U(i,mi,k)
              end do
              do mj = mi-1, 1, -1
                do i = 1, n
                  eta(i) = eta(i) - inprod(n, U(1,mi,k), z(1,mj))*z(i,mj)
                end do
              end do
              w(mi) = SQRT(inprod(n, eta, eta))
              do i = 1, n
                z(i,mi) = eta(i)/w(mi)
              end do
            end do
c
c           Now I have the orthonormal basis in z and
c           the norms in w so I can compute the P orthonormalization
c           matrix
c
            do j = 1, n-r
              do i = 1, j
                if (j .eq. i) then
                  P(j,i,q) = 1.0/w(j)
                else
                  P(j,i,q) = 0.0
                  do s = i, j-1
                    P(j,i,q) = P(j,i,q)-inprod(n,U(1,j,k),z(1,s))/w(j)*
     &                         P(s,i,q)
                  end do
                end if
              end do
            end do
c
c           Check the P matrix
c
            if (.false.) then
              do i = 1, n
                do m = 1, n-r
                ut(i,m) = 0.0
                  do j = 1, n-r
                    ut(i,m) = ut(i,m) + U(i,j,k)*P(m,j,q)
                  end do
                end do
              end do
              do i = 1,n
                write (*,*) i,(ut(i,m), m = 1, n-r)
              end do
              write (*,*)
              do i = 1,n
                write (*,*) i,( z(i,m), m = 1, n-r)
              end do
              write (*,*)
              write (*,*)
            end if
c
c           Now update the U matrix with the orthonormal values
c
            do i = 1, n
              do m = 1, n-r
                U(i,m,k) = z(i,m)
              end do
            end do
c
c           Form the orthogonal complement of the particular solution
c
            do j = 1, n-r
              omega(j,q) = inprod(n, v(1,k), U(1,j,k))
            end do
            do i = 1, n
              do j = 1, n-r
                v(i,k) = v(i,k) - U(i,j,k)*omega(j,q)
              end do
            end do

          end if
        end do
c
c       write out the current solutions
c
#ifdef VERBOSE_SOLUTIONS
        do k = 1, nstep
          t = to + h*k
          write (20,10) t,REAL(U(1,1,k)),AIMAG(U(1,1,k)),REAL(U(1,2,k)),
     &                    AIMAG(U(1,2,k)),REAL(v(1,k)),AIMAG(v(1,k))
 10       format (1x,7(ES16.8E3,1x))
        end do
#endif
c
c       check boundary conditions
c
        if (.true.) then
c
c         strictly enforce the zero BC
c
          B(1,qend) = -U(1,2,nstep)/U(1,1,nstep)
          B(2,qend) = 1.0
        else
c
c         strictly enforce the zero slope BC
c
          B(1,qend) =  1.0
          B(2,qend) = -U(2,1,nstep)/U(2,2,nstep)
        end if
#ifdef CHECK_DETERMINATE
c
c       Check the determinate (requires IMSL)
c
        do i = 1, n
          x(i) = yf(i) - v(i,nstep)
          do m = 1, n-r
            A(i,m) = U(i,m,nstep)
          end do
        end do
        CALL WRCRN ('A', n, n-r, A, n, 0)
c
c       compute the determinate
c
        call LFTCG( n-r, A, n, fac, n-r, ipvt)
        call LFDCG( n-r, fac, n-r, ipvt, det1, det2)
        det = det1*10**det2
        write (*,*) 'det = ', det
#endif
        ctemp = c
        if (icount .eq. 1) then
          cm2 = c
          err = U(2,1,nstep)*B(1,qend) + U(2,2,nstep)*B(2,qend)
          errm2 = err
          c = CMPLX( REAL(c)*.9999, AIMAG(c) )
        else if (icount .eq. 2) then
          cm1 = c
          err = U(2,1,nstep)*B(1,qend) + U(2,2,nstep)*B(2,qend)
          errm1 = err
c         c = CMPLX( REAL(c), AIMAG(c)*.9999 )
          fdxr =  REAL(err-errm2) / REAL(c-cm2)
          fdxi = AIMAG(err-errm2) / REAL(c-cm2)
          fd = CMPLX( fdxr, fdxi )
          c = c - err/fd
        else
          err = U(2,1,nstep)*B(1,qend) + U(2,2,nstep)*B(2,qend)
          qt = (c-cm1)/(cm1-cm2)
          At = qt*err-qt*(1.+qt)*errm1+qt**2*errm2
          Bt = (2.*qt+1.)*err-(1.+qt)**2*errm1+qt**2*errm2
          Ct = (1.+qt)*err
          if ( ABS(Bt+SQRT(Bt**2-4.*At*Ct)) .gt.
     &         ABS(Bt-SQRT(Bt**2-4.*At*Ct)) )  then
             c = ctemp-(ctemp-cm1)*2.*Ct/(Bt+SQRT(Bt**2-4.*At*Ct))
          else
             c = ctemp-(ctemp-cm1)*2.*Ct/(Bt-SQRT(Bt**2-4.*At*Ct))
          end if
          cm2 = cm1
          cm1 = ctemp
          errm2 = errm1
          errm1 = err
        end if

        write (*,30) icount, real(c), aimag(c), real(err), aimag(err)
  30    format (1x,i4,2(1x,es16.8e3,1x,es16.8e3,3x))

        icount = icount + 1
      end do
c
c.... Output Eigenvalue
c
      write (*,40) real(ctemp), aimag(ctemp), qend
  40  format (/,'Eigenvalue = ',e17.8e3,1x,e17.8e3,2x,i5/)
      write (*,45) icount, abs(err), abs(c-cm1)
  45  format ('  Eigenvalue iterations = ', i5/,'  |error| = ',
     &        es17.8e3/,'  |c-cm1| = ', es17.8e3/)
c
c     Second Pass to compute the eigenfunctions
c
      if (eigfun) then
        vmax = 0.0
        k = nstep
        do i = 1, n
          y(i,k) = v(i,k)
          do m = 1, n-r
            y(i,k) = y(i,k) + U(i,m,k)*B(m,q)
          end do
        end do
        do m = 1, n-r
          B(m,q-1) = 0.0
          do j = 1, n-r
            B(m,q-1) = B(m,q-1) + P(j,m,q)*(B(j,q)-omega(j,q))
          end do
        end do
        do k = nstep-1, 0, -1
          t = to + h*k
          if ( t .lt. tq(q-1) ) then
            q = q - 1
            do m = 1, n-r
              B(m,q-1) = 0.0
              do j = 1, n-r
                B(m,q-1) = B(m,q-1) + P(j,m,q)*(B(j,q)-omega(j,q))
              end do
            end do
          end if
          do i = 1, n
            y(i,k) = v(i,k)
            do m = 1, n-r
              y(i,k) = y(i,k) + U(i,m,k)*B(m,q-1)
            end do
          end do
          if ( ABS(y(i,k)) .gt. ABS(vmax) ) then
            vmax = y(i,k)
          end if
        end do
c
c       Output eigenfunction and derivatives: u, u', u'', u'''
c
        do k = 0, nstep
          t = to + h*k
          write (11,20) t, REAL(y(1,k)/vmax),AIMAG(y(1,k)/vmax)
          write (12,20) t, REAL(y(2,k)/vmax),AIMAG(y(2,k)/vmax)
          write (13,20) t, REAL(y(3,k)/vmax),AIMAG(y(3,k)/vmax)
          write (14,20) t, REAL(y(4,k)/vmax),AIMAG(y(4,k)/vmax)
  20      format (1x,3(ES16.8E3,1x))
        end do
      end if

      return
      end

C***********************************************************************
      subroutine CONTE_IC(nstep, testalpha, n, r, yo, yf, to, tf, c,
     &                    eigfun, FIC, FHOMO, FPART, INPROD)
C***********************************************************************
C
C     First order linear boundary value problem solver using Conte's
C     method with a non Dirac function initial condition.
C     Runge-Kutta is used for time advancement but there are
C     other options available via compile defines
C
C     nstep  = number of integration steps between [t0,tf]
C     n      = number of ODEs to integrate
C     r      = number of particular solutions
C     yo     = starting values
C     yf     = ending values
C     to     = Interval start value
C     tf     = Interval end value
C     c      = Current eigenvalue
C     eigfun = Whether to output eigenfunction at the end
C     FIC    = Subroutine to compute the initial condition
C     FHOMO  = Subroutine for homogeneous equation
C     FPART  = Subroutin for particular equation
C     INPROD = Function to compute inner product
C
C***********************************************************************
      integer     nstep, n, r
      integer     i, m, q, s, mi, mj, qend, IPVT(n-r), icount, north
      real        t, tq(0:nstep), to, tf, h
      complex     yo(n), yf(n), B(n-r,0:nstep), err, c, cold, ctemp
      complex     U(n,n-r,0:nstep), P(n-r,n-r,0:nstep), z(n,n-r)
      complex     y(n,0:nstep), v(n,0:nstep), w(n-r), omega(n,0:nstep)
      complex     eta(n),A(n,n-r),x(n),FAC(n-r,n-r), det1, det
      complex     olderr, ut(n,n-r), fd, vmax
      complex     cm1, cm2, errm1, errm2, qt, At, Bt, Ct, Utemp(n)
      real        aa, bb, cc
      real        test, testalpha, pi, det2, AI(n,n-r)
      real        fdxr, fdxi, fdyr, fdyi
      logical     norm, eigfun
      complex     INPROD
      external    INPROD, FIC, FHOMO, FPART
      real        errtol, maxcount, eigtol
#ifdef USE_NR_ODEINT
      external    RKQC
#endif
c
c     Setup for ZVODE
c
#ifdef USE_VODE
      real RWORK(20+(n*(n-r)))
      complex ZWORK(15*(n*(n-r)))
      integer IWORK(30+(n*(n-r)))
      external FHOMO_VODE
      real RTOL, ATOL, RPAR
      integer ITOL, ITASK, ISTATE, IOPT, LZW, LRW, LIW, MF, IPAR(2)
      ITOL = 1
      RTOL = 1.0D-9
      ATOL = 1.0D-8
      ITASK = 1
      ISTATE = 1
      IOPT = 0
      LZW = 15*(n*(n-r))
      LRW = 20+(n*(n-r))
      LIW = 30+(n*(n-r))
      MF = 10
      RPAR = 0.0
      IPAR(1) = n
      IPAR(2) = n-r
#endif
c
c     initialize variables
c
      errtol = 1.0e-14
      maxcount = 20
      eigtol = 1.0e-14
c
c     set the normalization constraint
c
      pi = ACOS(-1.0)
c
c     compute the step size
c
      h = (tf-to)/nstep
c
c     Begin the eigenvalue iteration loop
c
      icount = 1
      err = 1.0
      cm1 = c + 1.0
      do while ( ((abs(err) .ge. errtol) .or. (abs(c-cm1) .ge. eigtol))
     &           .and. (icount .le. maxcount) )
        q = 0
        tq(0) = tf
c
c       Set the initial conditions
c
        k = 0
        call FIC(n,r,U(1,1,k))
c
c       Gram-Schmidt
c
        w(1) = SQRT(inprod(n, U(1,1,k), U(1,1,k)))
        do i = 1, n
          z(i,1) = U(i,1,k)/w(1)
        end do
        do mi = 2, (n-r)
          do i = 1, n
            eta(i) = U(i,mi,k)
          end do
          do mj = mi-1, 1, -1
            do i = 1, n
              eta(i) = eta(i) - inprod(n, U(1,mi,k), z(1,mj))*z(i,mj)
            end do
          end do
          w(mi) = SQRT(inprod(n, eta, eta))
          do i = 1, n
            z(i,mi) = eta(i)/w(mi)
          end do
        end do
c
c       Now update the U matrix with the orthonormal values
c
        do i = 1, n
          do m = 1, n-r
            U(i,m,k) = z(i,m)
          end do
        end do
#ifdef CHECK_ORTHOGONALITY
        aa = ABS(inprod(n, U(1,1,k), U(1,1,k)))
        bb = ABS(inprod(n, U(1,2,k), U(1,2,k)))
        cc = ABS(inprod(n, U(1,1,k), U(1,2,k)))
        test = ACOS(cc/SQRT(aa*bb))*180./pi
        write (*,*) k, mi, mj, test
#endif
c
c       Integrate the homo. and particular equations
c
        do k = 1, nstep
          t = tf - h*k
c
c         Loop thru all homogeneous solutions
c
          do m = 1, n-r
#ifdef USE_NR_ODEINT
            do i = 1, n
              Utemp(i) = U(i,m,k-1)
            end do
            call ODEINT(Utemp,n,t+h,t,1.E-6,-h,1.e-20,nok,nbad,
     &                  FHOMO,RKQC)
            do i = 1, n
              U(i,m,k) = Utemp(i)
            end do
c#elif USE_VODE
c            ISTATE=1
c            rt0 = t+h
c            rt1 = t
c            do i = 1, n
c              Utemp(i) = U(i,m,k-1)
c            end do
cc           write(*,*) "Calling ZVODE...", rt0, rt1
c            call ZVODE(FHOMO_VODE,n,Utemp,rt0,rt1,ITOL,RTOL,ATOL,ITASK,
c     &                 ISTATE,IOPT,ZWORK,LZW,RWORK,LRW,IWORK,LIW,JEX,MF,
c     &                 RPAR,IPAR)
c           write(*,*) "Finixhed ZVODE...", rt0, rt1
c            if (ISTATE .lt. 0) then
c              write(*,*) "Error in ZVODE:  ISTATE = ", ISTATE
c              call exit(1)
c            end if
c            do i = 1, n
c              U(i,m,k) = Utemp(i)
c            end do
#elif USE_LSRK14
            call CLSRK14(n, U(1,m,k-1), U(1,m,k), t+h, -h, FHOMO)
#elif USE_RKCK45
            call CRKCK45( n, U(1,m,k-1), U(1,m,k), t+h, -h, FHOMO )
#else
            call CRK4(n, U(1,m,k-1), U(1,m,k), t+h, -h, FHOMO)
#endif
          end do
#if 0
          if (norm .or. k.eq.1) ISTATE=1
          ISTATE=1
          rt0 = t+h
          rt1 = t
          do m = 1, n-r
            do i = 1, n
              U(i,m,k) = U(i,m,k-1)
            end do
          end do
c         write(*,*) "Calling ZVODE...", rt0, rt1, n*(n-r)
          call ZVODE(FHOMO_VODE,n*(n-r),U(1,1,k),rt0,rt1,ITOL,RTOL,ATOL,
     &               ITASK,ISTATE,IOPT,ZWORK,LZW,RWORK,LRW,IWORK,LIW,
     &               JEX,MF,RPAR,IPAR)
          if (ISTATE .lt. 0) then
            write(*,*) "Error in ZVODE:  ISTATE = ", ISTATE
            call exit(1)
          end if
#else
c         write(*,*) "Hack...fix it"
c         stop
#endif
c
c         Test to see if normalization is required
c
          norm = .false.
          ta = pi*testalpha/180.0
          do mi = 1, n-r
            do mj = 1, n-r
              if (mi .ne. mj) then
                aa = ABS(inprod(n, U(1,mi,k), U(1,mi,k)))
                bb = ABS(inprod(n, U(1,mj,k), U(1,mj,k)))
                cc = ABS(inprod(n, U(1,mi,k), U(1,mj,k)))
                test = acos(cc/SQRT(aa*bb))
                if (test .lt. ta) norm = .true.
c               write (*,*) k, mi, mj, test, testalpha, norm
              end if
            end do
          end do
c
c         Perform normalization
c
          if ( norm .or. (k .eq. nstep) ) then
            q = q + 1
c           write (*,*) 'Normalization = ', q
            tq(q) = t
            if (k .eq. nstep) then
              qend = q
c             write (*,*) 'qend = ',qend
            end if
c
c           Gram-Schmidt
c
            w(1) = SQRT(inprod(n, U(1,1,k), U(1,1,k)))
            do i = 1, n
              z(i,1) = U(i,1,k)/w(1)
            end do
            do mi = 2, (n-r)
              do i = 1, n
                eta(i) = U(i,mi,k)
              end do
              do mj = mi-1, 1, -1
                do i = 1, n
                  eta(i) = eta(i) - inprod(n, U(1,mi,k),
     &                     z(1,mj))*z(i,mj)
                end do
              end do
              w(mi) = SQRT(inprod(n, eta, eta))
              do i = 1, n
                z(i,mi) = eta(i)/w(mi)
              end do
            end do
c
c           Now I have the orthonormal basis in z and
c           the norms in w so I can compute the P orthonormalization
c           matrix
c
            do j = 1, n-r
              do i = 1, j
                if (j .eq. i) then
                  P(j,i,q) = 1.0/w(j)
                else
                  P(j,i,q) = 0.0
                  do s = i, j-1
                    P(j,i,q) = P(j,i,q)-inprod(n,U(1,j,k),z(1,s))/w(j)*
     &                         P(s,i,q)
                  end do
                end if
              end do
            end do
c
c           Check the P matrix
c
            if (.false.) then
              do i = 1, n
                do m = 1, n-r
                ut(i,m) = 0.0
                  do j = 1, n-r
                    ut(i,m) = ut(i,m) + U(i,j,k)*P(m,j,q)
                  end do
                end do
              end do

              do i = 1,n
                write (*,*) i,(ut(i,m), m = 1, n-r)
              end do
              write (*,*)
              do i = 1,n
                write (*,*) i,( z(i,m), m = 1, n-r)
              end do
              write (*,*)
              write (*,*)
            end if
c
c           Now update the U matrix with the orthonormal values
c
            do i = 1, n
              do m = 1, n-r
                U(i,m,k) = z(i,m)
              end do
            end do

          end if
        end do
c
c       check boundary conditions
c
        if (.true.) then
c
c         strictly enforce the zero BC
c
          B(1,qend) = -U(1,2,nstep)/U(1,1,nstep)
          B(2,qend) = 1.0
c         olderr = err
c         err = U(2,1,nstep)*B(1,qend) + U(2,2,nstep)*B(2,qend)
        else
c
c         strictly enforce the zero slope BC
c
          B(1,qend) =  1.0
          B(2,qend) = -U(2,1,nstep)/U(2,2,nstep)
c         olderr = err
c         err = U(1,1,nstep)*B(1,qend) + U(1,2,nstep)*B(2,qend)
        end if

        ctemp = c
        if (icount .eq. 1) then
          cm2 = c
          err = U(2,1,nstep)*B(1,qend) + U(2,2,nstep)*B(2,qend)
          errm2 = err
          c = CMPLX( REAL(c)*.9999, AIMAG(c) )
        else if (icount .eq. 2) then
          cm1 = c
          err = U(2,1,nstep)*B(1,qend) + U(2,2,nstep)*B(2,qend)
          errm1 = err
c         c = CMPLX( REAL(c), AIMAG(c)*.9999 )
          fdxr =  REAL(err-errm2) / REAL(c-cm2)
          fdxi = AIMAG(err-errm2) / REAL(c-cm2)
          fd = CMPLX( fdxr, fdxi )
          c = c - err/fd
        else
          err = U(2,1,nstep)*B(1,qend) + U(2,2,nstep)*B(2,qend)
          qt = (c-cm1)/(cm1-cm2)
          At = qt*err-qt*(1.+qt)*errm1+qt**2*errm2
          Bt = (2.*qt+1.)*err-(1.+qt)**2*errm1+qt**2*errm2
          Ct = (1.+qt)*err
          if ( ABS(Bt+SQRT(Bt**2-4.*At*Ct)) .gt.
     &         ABS(Bt-SQRT(Bt**2-4.*At*Ct)) )  then
             c = ctemp-(ctemp-cm1)*2.*Ct/(Bt+SQRT(Bt**2-4.*At*Ct))
          else
             c = ctemp-(ctemp-cm1)*2.*Ct/(Bt-SQRT(Bt**2-4.*At*Ct))
          end if
          cm2 = cm1
          cm1 = ctemp
          errm2 = errm1
          errm1 = err
        end if
        write (*,30) icount,real(ctemp),aimag(ctemp),real(err),
     &               aimag(err)
  30    format (1x,i4,2(e17.8,e17.8,3x))
        icount = icount + 1
      end do
c
c.... Output Eigenvalue
c
      icount = icount - 1
      write (*,40) real(ctemp), aimag(ctemp), qend
  40  format (/,'Eigenvalue = ',e17.8,1x,e17.8,2x,i5/)
      write (*,45) icount, abs(err), abs(c-cm1)
  45  format ('  Eigenvalue iterations = ', i5/,'  |error| = ',
     &        es17.8/,'  |c-cm1| = ', es17.8/)
c
c     Second Pass to compute the eigenfunctions
c
      if (eigfun) then
        q  = qend
        vmax = 0.0
        k = nstep
        do i = 1, n
          y(i,k) = v(i,k)
          do m = 1, n-r
            y(i,k) = y(i,k) + U(i,m,k)*B(m,q)
          end do
        end do
        do m = 1, n-r
          B(m,q-1) = 0.0
          do j = 1, n-r
            B(m,q-1) = B(m,q-1) + P(j,m,q)*B(j,q)
          end do
        end do
        do k = nstep-1, 0, -1
          t = tf - h*k
          if ( t .gt. tq(q-1) ) then
            q = q - 1
            do m = 1, n-r
              B(m,q-1) = 0.0
              do j = 1, n-r
                B(m,q-1) = B(m,q-1) + P(j,m,q)*B(j,q)
              end do
            end do
          end if
          do i = 1, n
            y(i,k) = 0.0
            do m = 1, n-r
              y(i,k) = y(i,k) + U(i,m,k)*B(m,q-1)
            end do
          end do
          if ( ABS(y(i,k)) .gt. ABS(vmax) ) then
            vmax = y(i,k)
          end if
        end do
c
c       Output eigenfunction and derivatives: u, u', u'', u'''
c
        do k = 0, nstep
          t = tf - h*k
          write (11,20) t, REAL(y(1,k)/vmax),AIMAG(y(1,k)/vmax)
          write (12,20) t, REAL(y(2,k)/vmax),AIMAG(y(2,k)/vmax)
          write (13,20) t, REAL(y(3,k)/vmax),AIMAG(y(3,k)/vmax)
          write (14,20) t, REAL(y(4,k)/vmax),AIMAG(y(4,k)/vmax)
  20      format (1x,3(ES16.8E3,1x))
        end do
      end if

      return
      end

C***********************************************************************
C>    \brief Advance one time step using fourth order (real) Runge-Kutta
C>    \param[in] neq number of equations
C>    \param[in] yo initial value
C>    \param[out] yf final value
C>    \param[in] to intial time
C>    \param[in] h time step
C>    \param[in] FUNC function to integrate
C***********************************************************************
      subroutine SRK4(neq, yo, yf, to, h, FUNC)
C***********************************************************************
C
C     Advance one time step using fourth order (real) Runge-Kutta
C
C***********************************************************************
      external    FUNC
      integer     neq
      real        to, h
      real        yo(neq), yf(neq)
      real        f(neq), k1(neq), k2(neq), k3(neq), k4(neq), q(neq)

      call FUNC(neq, yo, to, f)
      do j = 1 , neq
        k1(j) = h*f(j)
        q(j) = yo(j) + 0.5*k1(j)
      end do
      call FUNC(neq, q, to+0.5*h, f)
      do j = 1 , neq
        k2(j) = h*f(j)
        q(j) = yo(j) + 0.5*k2(j)
      end do
      call FUNC(neq, q, to+0.5*h, f)
      do j = 1 , neq
        k3(j) = h*f(j)
        q(j) = yo(j) + k3(j)
      end do
      call FUNC(neq, q, to+h, f)
      do j = 1 , neq
        k4(j) = h*f(j)
        yf(j) = yo(j)+k1(j)/6.+(k2(j)+k3(j))/3.+k4(j)/6.
      end do

      return
      end

C***********************************************************************
C>    \brief Advance one time step using fourth order (real) Runge-Kutta
C>    \param[in] neq number of equations
C>    \param[in] yo initial value
C>    \param[out] yf final value
C>    \param[in] to intial time
C>    \param[in] h time step
C>    \param[in] FUNC function to integrate
C***********************************************************************
      subroutine CRK4(neq, yo, yf, to, h, FUNC)
C***********************************************************************
C
C     Advance one time step using fourth order (complex) Runge-Kutta
C
c***********************************************************************
      external    FUNC
      integer     neq
      real        to, h
      complex     yo(neq), yf(neq)
      complex     f(neq), k1(neq), k2(neq), k3(neq), k4(neq), q(neq)

      call FUNC(neq, yo, to, f)
      do j = 1 , neq
        k1(j) = h*f(j)
        q(j) = yo(j) + 0.5*k1(j)
      end do
      call FUNC(neq, q, to+0.5*h, f)
      do j = 1 , neq
        k2(j) = h*f(j)
        q(j) = yo(j) + 0.5*k2(j)
      end do
      call FUNC(neq, q, to+0.5*h, f)
      do j = 1 , neq
        k3(j) = h*f(j)
        q(j) = yo(j) + k3(j)
      end do
      call FUNC(neq, q, to+h, f)
      do j = 1 , neq
        k4(j) = h*f(j)
        yf(j) = yo(j)+k1(j)/6.+(k2(j)+k3(j))/3.+k4(j)/6.
      end do

      return
      end

C***********************************************************************
      SUBROUTINE SPLINE (N,X,Y,FDP)
C***********************************************************************
C
C.... Note: this routine is in the public domain and available
C     at https://web.stanford.edu/class/me200c/
C
C-----THIS SUBROUTINE COMPUTES THE SECOND DERIVATIVES NEEDED
C-----IN CUBIC SPLINE INTERPOLATION.  THE INPUT DATA ARE:
C-----N = NUMBER OF DATA POINTS
C-----X = ARRAY CONTAINING THE VALUES OF THE INDEPENDENT VARIABLE
C-----    (ASSUMED TO BE IN ASCENDING ORDER)
C-----Y = ARRAY CONTAINING THE VALUES OF THE FUNCTION AT THE
C-----    DATA POINTS GIVEN IN THE X ARRAY
C-----THE OUTPUT IS THE ARRAY FDP WHICH CONTAINS THE SECOND
C-----DERIVATIVES OF THE INTERPOLATING CUBIC SPLINE.
      DIMENSION X(N),Y(N),A(N),B(N),C(N),R(N),FDP(N)
C-----COMPUTE THE COEFFICIENTS AND THE RHS OF THE EQUATIONS.
C-----THIS ROUTINE USES THE CANTILEVER CONDITION.  THE PARAMETER
C-----ALAMDA (LAMBDA) IS SET TO 1. BUT THIS CAN BE USER-MODIFIED.
C-----A,B,C ARE THE THREE DIAGONALS OF THE TRIDIAGONAL SYSTEM;
C-----R IS THE RIGHT HAND SIDE.  THESE ARE NOW ASSEMBLED.
      ALAMDA = 1.
      NM2 = N - 2
      NM1 = N - 1
      C(1) = X(2) - X(1)
      DO 1 I=2,NM1
      C(I) = X(I+1) - X(I)
      A(I) = C(I-1)
      B(I) = 2.*(A(I) + C(I))
      R(I) = 6.*((Y(I+1) - Y(I))/C(I) - (Y(I) - Y(I-1))/C(I-1))
    1 CONTINUE
      B(2) = B(2) + ALAMDA * C(1)
      B(NM1) = B(NM1) + ALAMDA * C(NM1)
C-----AT THIS POINT WE COULD CALL A TRIDIAGONAL SOLVER SUBROUTINE
C-----BUT THE NOTATION IS CLUMSY SO WE WILL SOLVE DIRECTLY.  THE
C-----NEXT SECTION SOLVES THE SYSTEM WE HAVE JUST SET UP.
      DO 2 I=3,NM1
      T = A(I)/B(I-1)
      B(I) = B(I) - T * C(I-1)
      R(I) = R(I) - T * R(I-1)
    2 CONTINUE
      FDP(NM1) = R(NM1)/B(NM1)
      DO 3 I=2,NM2
      NMI = N - I
      FDP(NMI) = (R(NMI) - C(NMI)*FDP(NMI+1))/B(NMI)
    3 CONTINUE
      FDP(1) = ALAMDA * FDP(2)
      FDP(N) = ALAMDA * FDP(NM1)
C-----WE NOW HAVE THE DESIRED DERIVATIVES SO WE RETURN TO THE
C-----MAIN PROGRAM.
      RETURN
      END

C***********************************************************************
      SUBROUTINE SPEVAL (N,X,Y,FDP,XX,F)
C***********************************************************************
C
C.... Note: this routine is in the public domain and available
C     at https://web.stanford.edu/class/me200c/
C
C-----THIS SUBROUTINE EVALUATES THE CUBIC SPLINE GIVEN
C-----THE 2ND DERIVATIVE COMPUTED BY SUBROUTINE SPLINE.
C-----THE INPUT PARAMETERS N,X,Y,FDP HAVE THE SAME
C-----MEANING AS IN SPLINE.
C-----XX = VALUE OF INDEPENDENT VARIABLE FOR WHICH
C-----     AN INTERPOLATED VALUE IS REQUESTED
C-----F =  THE INTERPOLATED RESULT
      DIMENSION X(N),Y(N),FDP(N)
C-----THE FIRST JOB IS TO FIND THE PROPER INTERVAL.
#if USE_NR_HUNT
c
c     Search using bisection with a good guess
c
      I = IOLD
      IF (XX.EQ.X(1)) THEN
        I = 1
      ELSE IF (XX.EQ.X(N)) THEN
        I = N
      ELSE
        call HUNT (X,N,XX,I)
      END IF
      IOLD = I
#elif 1
      I = IOLD
      IF (XX.EQ.X(1)) THEN
        I = 1
      ELSE IF (XX.EQ.X(N)) THEN
        I = N
      ELSE
        call BISECT (X,N,XX,I)
      ENDiF
      IOLD = I
#else
c
c     This is really a slow way of searching
c
      NM1 = N - 1
      DO 1 I=1,NM1
      IF (XX.LE.X(I+1)) GO TO 10
    1 CONTINUE
#endif
C-----NOW EVALUATE THE CUBIC
   10 DXM = XX - X(I)
      DXP = X(I+1) - XX
      DEL = X(I+1) - X(I)
      F = FDP(I)*DXP*(DXP*DXP/DEL - DEL)/6.
     1   +FDP(I+1)*DXM*(DXM*DXM/DEL - DEL)/6.
     2   +Y(I)*DXP/DEL + Y(I+1)*DXM/DEL
      RETURN
      END

C***********************************************************************
      subroutine BISECT(X,N,XX,I)
C***********************************************************************
      dimension X(N)
C***********************************************************************
      il = I-1
      ir = N-1
      do while (ir-il .gt. 1)
        im = ISHFT(ir+il,-1)
        if ( X(im+1) > xx ) then
          ir = im
        else
          il = im
        end if
      end do
      I = il+1
      return
      end

C***********************************************************************
      SUBROUTINE SPDER(N,X,Y,FDP,XX,F,FP,FPP)
C***********************************************************************
C
C.... Note: this routine is in the public domain and available
C     at https://web.stanford.edu/class/me200c/
C
C-----THIS SUBROUTINE EVALUATES THE CUBIC SPLINE GIVEN
C-----THE 2ND DERIVATIVE COMPUTED BY SUBROUTINE SPLINE.
C-----THE INPUT PARAMETERS N,X,Y,FDP HAVE THE SAME
C-----MEANING AS IN SPLINE.
C-----XX = VALUE OF INDEPENDENT VARIABLE FOR WHICH
C-----     AN INTERPOLATED VALUE IS REQUESTED
C-----F =  THE INTERPOLATED RESULT
C-----FP = THE INTERPOLATED DERIVATIVE RESULT
      INTEGER N
      DIMENSION X(N),Y(N),FDP(N)
      REAL XX, F, FP, FPP
C-----THE FIRST JOB IS TO FIND THE PROPER INTERVAL.
#if USE_NR_HUNT
c
c     Search using bisection with a good guess
c
      I = IOLD
      IF (XX.EQ.X(1)) THEN
        I = 1
      ELSE IF (XX.EQ.X(N)) THEN
        I = N
      ELSE
        call HUNT (X,N,XX,I)
      END IF
      IOLD = I
#elif 1
      I = IOLD
      IF (XX.EQ.X(1)) THEN
        I = 1
      ELSE IF (XX.EQ.X(N)) THEN
        I = N
      ELSE
        call BISECT (X,N,XX,I)
      ENDiF
      IOLD = I
#else
c
c     This is really a slow way of searching
c
      NM1 = N - 1
      DO 1 I=1,NM1
      IF (XX.LE.X(I+1)) GO TO 10
    1 CONTINUE
#endif
C-----NOW EVALUATE THE CUBIC
   10 continue
C     write(*,*) I, X(I), XX, X(I+1)
      DXM = XX - X(I)
      DXP = X(I+1) - XX
      DEL = X(I+1) - X(I)
      F = FDP(I)*DXP*(DXP*DXP/DEL - DEL)/6.0
     1   +FDP(I+1)*DXM*(DXM*DXM/DEL - DEL)/6.0
     2   +Y(I)*DXP/DEL + Y(I+1)*DXM/DEL
      FP= FDP(I)*(-3.0*DXP*DXP/DEL + DEL)/6.0
     1   +FDP(I+1)*(3.0*DXM*DXM/DEL - DEL)/6.0
     2   -Y(I)/DEL + Y(I+1)/DEL
      FPP=FDP(I)*DXP/DEL+FDP(I+1)*DXM/DEL
      RETURN
      END

C***********************************************************************
      subroutine SLSRK14(neq, yo, yf, to, h, FUNC)
C***********************************************************************
C
C     Advance one time step with low-storage Runge Kutta 14
C
C***********************************************************************
      external FUNC
      integer  neq
      real     to, h
      real     yo(neq), yf(neq)
      real     f(neq), yt(neq)
C***********************************************************************
      parameter (nsubstep=14)
      real A(0:14), B(0:13), c(0:13), w(0:14)
      data A / 0.0,
     &         -0.7188012108672410,
     &         -0.7785331173421570,
     &         -0.0053282796654044,
     &         -0.8552979934029281,
     &         -3.9564138245774565,
     &         -1.5780575380587385,
     &         -2.0837094552574054,
     &         -0.7483334182761610,
     &         -0.7032861106563359,
     &          0.0013917096117681,
     &         -0.0932075369637460,
     &         -0.9514200470875948,
     &         -7.1151571693922548,
     &         0.0/
      data B / 0.0367762454319673,
     &         0.3136296607553959,
     &         0.1531848691869027,
     &         0.0030097086818182,
     &         0.3326293790646110,
     &         0.2440251405350864,
     &         0.3718879239592277,
     &         0.6204126221582444,
     &         0.1524043173028741,
     &         0.0760894927419266,
     &         0.0077604214040978,
     &         0.0024647284755382,
     &         0.0780348340049386,
     &         5.5059777270269628 /
      data c / 0.0,
     &         0.0367762454319673,
     &         0.1249685262725025,
     &         0.2446177702277698,
     &         0.2476149531070420,
     &         0.2969311120382472,
     &         0.3978149645802642,
     &         0.5270854589440328,
     &         0.6981269994175695,
     &         0.8190890835352128,
     &         0.8527059887098624,
     &         0.8604711817462826,
     &         0.8627060376969976,
     &         0.8734213127600976 /
      data w / -0.116683473041717417,
     &         0.213493962104674251,
     &         0.128620987881127052,
     &         4.610096100109887907,
     &         -5.386527768056724064,
     &         1.445540684241274576,
     &         -0.761388932107154526,
     &         0.543874700576422732,
     &         0.102277834602298279,
     &         0.07127466608688701188,
     &         -3.459648919807762457,
     &         37.20095449534884580,
     &         -39.09786206496502814,
     &         5.505977727026962754,
     &         0.0 /
      do j = 1, neq
        yf(j) = yo(j)
      end do
      do i = 0, nsubstep-1
        t = to + c(i)*h
        call FUNC(neq, yf, t, f)
        do j = 1, neq
          yt(j) = A(i)*yt(j) + h*f(j)
        end do
        do j = 1, neq
          yf(j) = yf(j) + B(i)*yt(j)
        end do
        if (i+1 .lt. nsubstep) then
          t = to + c(i+1)*h
        else
          t = to + h
        end if
      end do
      return
      end

C***********************************************************************
      subroutine CLSRK14(neq, yo, yf, to, h, FUNC)
C***********************************************************************
C
C     Advance one time step with low-storage Runge Kutta 14
C
C***********************************************************************
      external FUNC
      integer  neq
      real     to, h
      complex  yo(neq), yf(neq)
      complex  f(neq), yt(neq)
C***********************************************************************
      parameter (nsubstep=14)
      real A(0:14), B(0:13), c(0:13), w(0:14)
      data A / 0.0,
     &         -0.7188012108672410,
     &         -0.7785331173421570,
     &         -0.0053282796654044,
     &         -0.8552979934029281,
     &         -3.9564138245774565,
     &         -1.5780575380587385,
     &         -2.0837094552574054,
     &         -0.7483334182761610,
     &         -0.7032861106563359,
     &          0.0013917096117681,
     &         -0.0932075369637460,
     &         -0.9514200470875948,
     &         -7.1151571693922548,
     &         0.0/
      data B / 0.0367762454319673,
     &         0.3136296607553959,
     &         0.1531848691869027,
     &         0.0030097086818182,
     &         0.3326293790646110,
     &         0.2440251405350864,
     &         0.3718879239592277,
     &         0.6204126221582444,
     &         0.1524043173028741,
     &         0.0760894927419266,
     &         0.0077604214040978,
     &         0.0024647284755382,
     &         0.0780348340049386,
     &         5.5059777270269628 /
      data c / 0.0,
     &         0.0367762454319673,
     &         0.1249685262725025,
     &         0.2446177702277698,
     &         0.2476149531070420,
     &         0.2969311120382472,
     &         0.3978149645802642,
     &         0.5270854589440328,
     &         0.6981269994175695,
     &         0.8190890835352128,
     &         0.8527059887098624,
     &         0.8604711817462826,
     &         0.8627060376969976,
     &         0.8734213127600976 /
      data w / -0.116683473041717417,
     &         0.213493962104674251,
     &         0.128620987881127052,
     &         4.610096100109887907,
     &         -5.386527768056724064,
     &         1.445540684241274576,
     &         -0.761388932107154526,
     &         0.543874700576422732,
     &         0.102277834602298279,
     &         0.07127466608688701188,
     &         -3.459648919807762457,
     &         37.20095449534884580,
     &         -39.09786206496502814,
     &         5.505977727026962754,
     &         0.0 /
      do j = 1, neq
        yf(j) = yo(j)
      end do
      do i = 0, nsubstep-1
        t = to + c(i)*h
        call FUNC(neq, yf, t, f)
        do j = 1, neq
          yt(j) = A(i)*yt(j) + h*f(j)
        end do
        do j = 1, neq
          yf(j) = yf(j) + B(i)*yt(j)
        end do
        if (i+1 .lt. nsubstep) then
          t = to + c(i+1)*h
        else
          t = to + h
        end if
      end do
      return
      end

C***********************************************************************
      subroutine SRKCK45(neq, yo, yf, to, h, FUNC)
C***********************************************************************
C
C     Advance one time step Runge-Kutta Cash-Karp method
C
C***********************************************************************
      external FUNC
      integer  neq
      real     to, h, t
      real     yo(neq), yf(neq), yt(neq)
      real     yk(neq,6), ye(neq)
C***********************************************************************
      real b(6,5)
      real a(6), c(6), d(6)
      data a / 0.0, 0.2, 0.3, 0.6, 1.0, 0.875 /
      data b / 0.0, 0.2, 0.075, 0.3, -0.2037037037037037,
     &         0.029495804398148147,
     &         0.0, 0.0, 0.225, -0.9, 2.5, 0.341796875,
     &         0.0, 0.0, 0.0, 1.2, -2.5925925925925926,
     &         0.041594328703703706,
     &         0.0, 0.0, 0.0, 0.0, 1.2962962962962963,
     &         0.40034541377314814,
     &         0.0, 0.0, 0.0, 0.0, 0.0, 0.061767578125 /
      data c / 0.09788359788359788, 0.0, 0.4025764895330113,
     &         0.21043771043771045, 0.0, 0.2891022021456804 /
      data d / -0.004293774801587311, 0.0, 0.018668586093857853,
     &         -0.034155026830808066, -0.019321986607142856,
     &         0.03910220214568039 /
c
c     Test data
c
#ifdef OS_DEBUG
      do i = 1, 6
        do j = 1, 5
          write(*,*) i, j, b(i,j)
        end do
      end do
      stop
#endif
c
c     Stage 1 - 6
c
      do m = 1, 6
        t = to + a(m)*h
        do n = 1, neq
          yt(n) = yo(n)
        end do
        do k = 1, m-1
          do n = 1, neq
            yt(n) = yt(n) + b(m,k)*yk(n,k)
          end do
        end do
        call FUNC(neq, yt, t, yk(1,m))
        do n = 1, neq
          yk(n,m) = h * yk(n,m)
        end do
      end do
c
c     Final solution and error
c
      do n = 1, neq
        yf(n) = yo(n)
        ye(n) = 0.0
      end do
      do k = 1, 6
        do n = 1, neq
          yf(n) = yf(n) + c(k)*yk(n,k)
          ye(n) = ye(n) + d(k)*yk(n,k)
        end do
      end do

      return
      end

C***********************************************************************
      subroutine CRKCK45(neq, yo, yf, to, h, FUNC)
C***********************************************************************
C
C     Advance one time step Runge-Kutta Cash-Karp method
C
C***********************************************************************
      external FUNC
      integer  neq
      real     to, h, t
      complex  yo(neq), yf(neq), yt(neq)
      complex  yk(neq,6), ye(neq)
C***********************************************************************
      real b(6,5)
      real a(6), c(6), d(6)
      data a / 0.0, 0.2, 0.3, 0.6, 1.0, 0.875 /
      data b / 0.0, 0.2, 0.075, 0.3, -0.2037037037037037,
     &         0.029495804398148147,
     &         0.0, 0.0, 0.225, -0.9, 2.5, 0.341796875,
     &         0.0, 0.0, 0.0, 1.2, -2.5925925925925926,
     &         0.041594328703703706,
     &         0.0, 0.0, 0.0, 0.0, 1.2962962962962963,
     &         0.40034541377314814,
     &         0.0, 0.0, 0.0, 0.0, 0.0, 0.061767578125 /
      data c / 0.09788359788359788, 0.0, 0.4025764895330113,
     &         0.21043771043771045, 0.0, 0.2891022021456804 /
      data d / -0.004293774801587311, 0.0, 0.018668586093857853,
     &         -0.034155026830808066, -0.019321986607142856,
     &         0.03910220214568039 /
c
c     Test data
c
#ifdef OS_DEBUG
      do i = 1, 6
        do j = 1, 5
          write(*,*) i, j, b(i,j)
        end do
      end do
      stop
#endif
c
c     Stage 1 - 6
c
      do m = 1, 6
        t = to + a(m)*h
        do n = 1, neq
          yt(n) = yo(n)
        end do
        do k = 1, m-1
          do n = 1, neq
            yt(n) = yt(n) + b(m,k)*yk(n,k)
          end do
        end do
        call FUNC(neq, yt, t, yk(1,m))
        do n = 1, neq
          yk(n,m) = h * yk(n,m)
        end do
      end do
c
c     Final solution and error
c
      do n = 1, neq
        yf(n) = yo(n)
        ye(n) = 0.0
      end do
      do k = 1, 6
        do n = 1, neq
          yf(n) = yf(n) + c(k)*yk(n,k)
          ye(n) = ye(n) + d(k)*yk(n,k)
        end do
      end do

      return
      end


program dot_test
    implicit none
    integer, parameter :: v_size = 5
    integer :: i
    real, dimension(v_size) :: vector1 = [ (0.5*I, i=1, v_size) ], &
                               vector2 = [ (0.1*i, i=1, v_size) ]
    real, dimension(v_size, v_size) :: matrix = reshape( &
        [ (real(i), i=1, v_size*v_size) ], [ v_size, v_size ] &
    )
    real, external :: sdot

    print '(A20, *(F5.1))', 'vector 1: ', vector1
    print '(A20, *(F5.1))', 'vector 2: ', vector2
    print '(A20, F6.2)', 'dot N 1 1: ', &
        sdot(size(vector1), vector1, 1, vector2, 1)

    print '(A)', 'matrix:'
    do i = 1, size(matrix, 1)
        print '(*(F5.1))', matrix(i, :)
    end do
    print '(A, F6.1)', 'col 2 . col 4:', &
        sdot(size(matrix, 2), matrix(:, 2), 1, matrix(:, 4), 1)
    print '(A, F6.1)', 'row 2 . row 4:', &
        sdot(size(matrix, 1), matrix(2, :), 1, matrix(4, :), 1)
end program dot_test


! -*- f90 -*-

!#############################################################
! COMPUTE 2D SPECTRUM OF AN ARRAY
!#############################################################

subroutine pspec2d(a,kp,kspec,axis,nk1,nk2,nx,ny,nz)
   integer, intent (in) :: nx,ny,nz,nk1,nk2,axis
   double precision, dimension(nx,ny,nz), intent (in) :: a
   double precision, dimension(nk1,nk2), intent (out) :: kp,kspec
!f2py intent (in) nx,ny,nz,axis,nk
!f2py intent (in) a
!f2py intent (out) kp, kspec
   ! LOCAL VARIABLES
   double complex  , allocatable, dimension(:,:,:) :: ffld
   double precision, allocatable, dimension(:,:,:) :: fenergy
   double precision, allocatable, dimension(:,:) :: kx, ky, kz
   integer*8 plan, LX1, NORM, i, j, k, ntop, nnx, nny

   include 'fftw3.f'

   LX1=nx/2 + 1; NORM = nx*ny*nz
   select case (axis+1)
      case (1)
        !allocate(fenp(ny,nz), kp(ny,nz), ky(ny,nz), kz(ny,nz))
         allocate(ky(ny,nz), kz(ny,nz))
         do i=1,ny; ky(i,:)=dble(mod(i-1+ny/2,ny)-ny/2); end do
         do i=1,nz; kz(:,i)=dble(mod(i-1+nz/2,nz)-nz/2); end do
         kp=sqrt(ky*ky+kz*kz); kp(1,1) = dble(1.e-6)
         ntop=min(ny,nz)/2; nnx=ny; nny=nz
         deallocate(ky,kz)
      case (2)
        !allocate(fenp(LX1,nz),kp(LX1,nz), kx(LX1,nz), kz(LX1,nz))
         allocate(kx(LX1,nz), kz(LX1,nz))
         do i=1,LX1; kx(i,:)=dble(i-1.0); enddo
         do i=1,nz;  kz(:,i)=dble(mod(i-1+nz/2,nz)-nz/2); end do
         kp=sqrt(kx*kx+kz*kz); kp(1,1) = dble(1.e-6)
         ntop=min(nx,nz)/2; nnx=LX1; nny=nz
         deallocate(kx,kz)
      case (3)
        !allocate(fenp(LX1,ny),kp(LX1,ny), kx(LX1,ny), ky(LX1,ny))
         allocate(kx(LX1,ny), ky(LX1,ny))
         do i=1,LX1; kx(i,:)=dble(i-1.0); enddo
         do i=1,ny;  ky(:,i)=dble(mod(i-1+ny/2,ny)-ny/2); end do
         kp=sqrt(kx*kx+ky*ky); kp(1,1) = dble(1.e-6)
         ntop=min(nx,ny)/2; nnx=LX1; nny=ny
         deallocate(kx,ky)
   end select

   allocate(ffld(LX1,ny,nz), fenergy(LX1,ny,nz))
   ! CREATE THE FFTW PLAN
   call dfftw_plan_dft_r2c_3d(plan,Nx,Ny,Nz,a,ffld,FFTW_ESTIMATE)
   call dfftw_execute_dft_r2c(plan, a, ffld)
   ffld=ffld/NORM ! normalize the quantities in fourier space

   ! Calculate the energy in the fourier space, make sure
   ! that (1,:) part of the array is multiplied by half.
   fenergy=ffld*conjg(ffld); fenergy(1,:,:)=0.5*fenergy(1,:,:)
   kspec = sum(fenergy,dim=axis+1)
   ! DESTROY THE PLAN AND DEALLOCATE ARRAYS
   call dfftw_destroy_plan(plan)
   deallocate(ffld,fenergy)
end subroutine pspec2d

!#############################################################
! COMPUTE SPECTRUM OF AN ARRAY
!#############################################################

subroutine perpspec(a,kk,kspec,axis,nk,nx,ny,nz)
   integer, intent (in) :: nx,ny,nz,nk,axis
   double precision, dimension(nx,ny,nz), intent (in) :: a
   double precision, dimension(0:nk), intent (out) :: kk,kspec
!f2py intent (in) nx,ny,nz,axis,nk
!f2py intent (in) a
!f2py intent (out) kk, kspec
   ! LOCAL VARIABLES
   double complex  , allocatable, dimension(:,:,:) :: ffld
   double precision, allocatable, dimension(:,:,:) :: fenergy
   double precision, allocatable, dimension(:,:) :: fenp, kx, ky, kz, kp
   integer*8 plan, LX1, NORM, i, j, k, ntop, nnx, nny

   include 'fftw3.f'

   LX1=nx/2 + 1; NORM = nx*ny*nz
   select case (axis+1)
      case (1)
         allocate(fenp(ny,nz), kp(ny,nz), ky(ny,nz), kz(ny,nz))
         do i=1,ny; ky(i,:)=dble(mod(i-1+ny/2,ny)-ny/2); end do
         do i=1,nz; kz(:,i)=dble(mod(i-1+nz/2,nz)-nz/2); end do
         kp=sqrt(ky*ky+kz*kz); kp(1,1) = dble(1.e-6)
         ntop=min(ny,nz)/2; nnx=ny; nny=nz
         deallocate(ky,kz)
      case (2)
         allocate(fenp(LX1,nz),kp(LX1,nz), kx(LX1,nz), kz(LX1,nz))
         do i=1,LX1; kx(i,:)=dble(i-1.0); enddo
         do i=1,nz;  kz(:,i)=dble(mod(i-1+nz/2,nz)-nz/2); end do
         kp=sqrt(kx*kx+kz*kz); kp(1,1) = dble(1.e-6)
         ntop=min(nx,nz)/2; nnx=LX1; nny=nz
         deallocate(kx,kz)
      case (3)
         allocate(fenp(LX1,ny),kp(LX1,ny), kx(LX1,ny), ky(LX1,ny))
         do i=1,LX1; kx(i,:)=dble(i-1.0); enddo
         do i=1,ny;  ky(:,i)=dble(mod(i-1+ny/2,ny)-ny/2); end do
         kp=sqrt(kx*kx+ky*ky); kp(1,1) = dble(1.e-6)
         ntop=min(nx,ny)/2; nnx=LX1; nny=ny
         deallocate(kx,ky)
   end select

   allocate(ffld(LX1,ny,nz), fenergy(LX1,ny,nz))
   ! CREATE THE FFTW PLAN
   call dfftw_plan_dft_r2c_3d(plan,Nx,Ny,Nz,a,ffld,FFTW_ESTIMATE)
   call dfftw_execute_dft_r2c(plan, a, ffld)
   ffld=ffld/NORM ! normalize the quantities in fourier space

   ! Calculate the energy in the fourier space, make sure
   ! that (1,:) part of the array is multiplied by half.
   fenergy=ffld*conjg(ffld); fenergy(1,:,:)=0.5*fenergy(1,:,:)
   fenp = sum(fenergy,dim=axis+1)
   kspec=0. ! Initialize the spectrum to zero
   ! Do the sum of energy over shells of k and save in the spectrum
   do i=1,nnx; do j=1,nny
      k=nint(kp(i,j))
      if (k <= ntop) then
         kspec(k)=kspec(k)+fenp(i,j)
         kk(k) = k
      endif
   enddo; enddo
   ! DESTROY THE PLAN AND DEALLOCATE ARRAYS
   call dfftw_destroy_plan(plan)
   deallocate(ffld,fenergy,fenp,kp)
end subroutine perpspec

!###############################################################
! COMPUTE SPECTRUM OF AN ARRAY FOR A BOX WITH DIFFERENT LENGTHS
!###############################################################

subroutine lperpspec(a,axis,nk,lx,ly,lz,nx,ny,nz,kk,kspec)
   double precision, parameter :: pi=3.1415926535897932385
   integer, intent (in) :: nx,ny,nz,nk,axis
   double precision, intent (in) :: lx, ly, lz
   double precision, dimension(nx,ny,nz), intent (in) :: a
   double precision, dimension(0:nk), intent (out) :: kk,kspec
   ! LOCAL VARIABLES
   double complex  , allocatable, dimension(:,:,:) :: ffld
   double precision, allocatable, dimension(:,:,:) :: fenergy
   double precision, allocatable, dimension(:,:) :: fenp
   double precision, allocatable, dimension(:) :: kkx, kky
   double precision :: kminx, kminy, kminz, kp, kmin
   integer(kind=8) plan, FFTW_ESTIMATE, LX1, NORM, i, j, k, ktop, nnx, nny
   PARAMETER (FFTW_ESTIMATE=64)
!f2py intent (in) axis,nk,lx,ly,lz,nx,ny,nz
!f2py intent (in) a
!f2py intent (out) kk, kspec

   LX1=nx/2 + 1; NORM = nx*ny*nz
   kminx=2*pi/lx; kminy = 2*pi/ly; kminz = 2*pi/lz
   select case (axis+1)
      case (1)
         allocate(fenp(ny,nz), kkx(ny), kky(nz))
         !! kkx = ky, kky = kz
         do i=1,ny; kkx(i)=dble(mod(i-1+ny/2,ny)-ny/2)*kminy; end do
         do i=1,nz; kky(i)=dble(mod(i-1+nz/2,nz)-nz/2)*kminz; end do
         ktop=min(ny*kminy/2,nz*kminz/2); nnx=ny; nny=nz
         kmin=min(kminy,kminz)
      case (2)
         allocate(fenp(LX1,nz), kkx(LX1), kky(nz))
         !! kkx = kx, kky = kz
         do i=1,LX1; kkx(i)=dble(i-1.0)*kminx; enddo
         do i=1,nz;  kky(i)=dble(mod(i-1+nz/2,nz)-nz/2)*kminz; end do
         ktop=min(nx*kminx/2,nz*kminz/2); nnx=LX1; nny=nz
         kmin=min(kminx,kminz)
      case (3)
         allocate(fenp(LX1,ny), kkx(LX1), kky(ny))
         !! kkx = kx, kky = ky
         do i=1,LX1; kkx(i)=dble(i-1.0)*kminx; enddo
         do i=1,ny;  kky(i)=dble(mod(i-1+ny/2,ny)-ny/2)*kminy; end do
         ktop=min(nx*kminx/2,ny*kminy/2); nnx=LX1; nny=ny
         kmin=min(kminx,kminy)
   end select

   allocate(ffld(LX1,ny,nz), fenergy(LX1,ny,nz))
   ! CREATE THE FFTW PLAN
   call dfftw_plan_dft_r2c_3d(plan,nx,ny,nz,a,ffld,FFTW_ESTIMATE)
   call dfftw_execute_dft_r2c(plan, a, ffld)
   ffld=ffld/NORM ! normalize the quantities in fourier space

   ! Calculate the energy in the fourier space, make sure
   ! that (1,:) part of the array is multiplied by half.
   fenergy=ffld*conjg(ffld); fenergy(1,:,:)=0.5*fenergy(1,:,:)
   fenp = sum(fenergy,dim=axis+1)
   kspec=0. ! Initialize the spectrum to zero
   ! Do the sum of energy over shells of k and save in the spectrum
   do i=1,nnx; do j=1,nny
      kp=dsqrt(kkx(i)**2+kky(j)**2)
      if (kp <= ktop) then
         k = int(dsqrt((kkx(i)/kmin)**2+(kky(j)/kmin)**2)+0.5)
         kspec(k)=kspec(k)+fenp(i,j)
         kk(k) = kp
      endif
   enddo; enddo
   ! DESTROY THE PLAN AND DEALLOCATE ARRAYS
   call dfftw_destroy_plan(plan)
   deallocate(ffld,fenergy,fenp,kkx,kky)
end subroutine lperpspec


    module psycho_m
        use kind_m
        use fft_m
        implicit none
        private
        public :: psychoacoustics
        real (kd), save :: freq_fft(512), ath_fft(512), pseud_bark(512)
        real (kd), save :: crbw_fft(512), cbwl_fft(512)
        real (kd), save :: sp(512, 512) ! spreading function for masking
        real (kd), save :: scale
        real (kd), parameter :: alpha = 0.27_kd ! non-linear factor

    contains

        function psychoacoustics(pcm, isample_rate) result(smr) ! impure
            real (kd), intent(in ) :: pcm(:, :)
            integer  , intent(in ) :: isample_rate
            real (kd) :: smr(32, size(pcm, 2))
            complex(kd) :: cfft(1024)
            integer :: ichannel, i0, i1
            logical, save :: qfirst = .true.
            if (qfirst) then
                qfirst = .false.
                call init_absolute_threshold(isample_rate)
            end if
            i0 = (1632 - 1024) / 2
            i1 = i0 + 1024 - 1
            do ichannel = 1, size(pcm, 2)
                call fft_window(pcm(i0:i1, ichannel), cfft)
                call calc_smr(cfft, smr(:, ichannel))
            end do
        end function psychoacoustics

        subroutine init_absolute_threshold(isample_rate)
            integer, intent(in) :: isample_rate
            real (kd) :: freq, tmp
            integer :: i, m
            do i = 1, size(freq_fft)
                freq = real(isample_rate, kind = kd) / 2.0_kd / 1000.0_kd &
                     * real(i - 1, kind = kd) / real(size(freq_fft), kind = kd)
                ath_fft(i) = 3.64_kd * freq**(-0.8_kd)  & !
                           - 6.5_kd * exp(-0.6_kd * (freq - 3.3_kd)**2) + 0.001_kd * freq**4.0_kd
                freq = freq * 1000.0_kd ! khz -> hz
                freq_fft(i) = freq
            end do
            scale =  real(isample_rate, kind = kd) / 2 / 512 ! freq to fft-line scale
            crbw_fft = critical_band_width( freq_fft )       ! critical band width in hz
            cbwl_fft = decibel( crbw_fft )                   ! critical band width in log
            tmp = 0.0_kd ! pseud bark: integrate critical band
            do m = 1, 512
                tmp = tmp + 1.0_kd / crbw_fft(m) ! integration
                pseud_bark(m) = tmp * scale
            end do
            ! spreading function
            forall(i = 1:512, m = 1:512) sp(i, m) = spreading( pseud_bark( i ) - pseud_bark( m ) ) ! top normalized to 1.0
        end subroutine init_absolute_threshold

        pure elemental real(kd) function spreading(z)
            real(kd), intent(in) :: z ! pseud-bark
            if ( z > 0.0_kd ) then
                spreading = -25.0_kd * z
            else
                spreading =  75.0_kd * z
            end if
            spreading = max(-160.0_kd, spreading)
        end function spreading

        pure elemental real(kd) function critical_band_width(f)
            real(kd), intent(in) :: f ! hz
            real(kd), parameter :: gamma = 0.69_kd
            critical_band_width = 25.0_kd + 75.0_kd * ( 1.0_kd + 1.4_kd * (f / 1000.0_kd)**2 )**gamma
            !  critical_band_width = 100.0_kd * ( 1.0_kd + 1.0_kd * (f / 1000.0_kd)**2 )**gamma
        end function critical_band_width

        pure elemental real(kd) function decibel(x)
            real (kd), intent(in) :: x
            decibel = 10.0e0_kd * log10( max(x, 1.0e-100_kd) )
        end function decibel

        subroutine calc_smr(cfft, smr)
            complex(kd), intent(in) :: cfft(:)
            real   (kd), intent(out) :: smr(:)
            real   (kd) :: snr(32), amnr(32)
            real   (kd) :: xa(512), ya(512), za(512)
            integer :: iband, i, m, i0, i1
            xa = 2 * decibel( abs(cfft(1:512)) )
            xa(1) = 0.0_kd ! dc cut
        ! convolution of spreading function
            ya = 0.0_kd
            do i = 1, 512
                do m = 1, 512  ! i maskee, m masker
                    ya(i) = ya(i) + 10.0_kd**( ((sp(i, m) + xa(m) - ath_fft(m)) * alpha - cbwl_fft(m)) / 10.0_kd ) ! non-linear sum
                end do
            end do
            ya = max(decibel(ya * scale) / alpha - 11.5_kd, ath_fft - 90.3_kd) ! 11.5 mask factor, 90.3dB = 2^15  ATH shift empirical
        ! effective spl
            do i = 1, 512
                m = nint( crbw_fft(i) / scale )
                i0 = max(i  - m / 2,   1)       !f0 - bw(f0) / 2
                i1 = min(i0 + m - 1, 512)       !f0 + bw(f0) / 2
                za(i) = sum( 10.0_kd**( (xa(i0:i1) * alpha  - cbwl_fft(i)) / 10.0_kd ) )
            end do
            za = decibel(za * scale) / alpha
            ! smr = snr' - mnr'
            do iband = 1, 32
                m = (iband - 1) * 16 + 1
                i0 = m - nint( crbw_fft(m) / 2 / scale ) ! fl - bw(fl) / 2  ; subband [fl..fh]
                i0 = max(i0,   1)
                m = m + 15
                i1 = m + nint( crbw_fft(m) / 2 / scale ) ! fh + bw(fh) / 2
                i1 = min(i1, 512)
                snr(iband)  = maxval( za(i0:i1) )
                amnr(iband) = minval( ya(i0:i1) )
            end do
            smr = snr - amnr
        end subroutine calc_smr

    end module psycho_m


! Sample solution to the problem posed in Lab 12.
! Version with coarse grain parallelism

program main

    use omp_lib
    use random_util, only: init_random_seed

    implicit none
    integer :: seed, nthreads
    integer, parameter :: ntests = 7
    real (kind=8), allocatable :: x(:)
    real (kind=8) :: sum, count1, count4
    real (kind=8), dimension(ntests)  :: mean,q1,q4
    integer :: i,n,k,kstart,kend,thread_num,points_per_thread

    ! Specify number of threads to use:
    nthreads = 1       ! need this value in serial mode
    !$ nthreads = 2
    !$ call omp_set_num_threads(nthreads)
    !$ print "('Using OpenMP with ',i3,' threads')", nthreads

    print *, "input seed"
    read *, seed

    call init_random_seed(seed)

    print *, "      n          mean        quartile 1    quartile 4"

    points_per_thread = (ntests + nthreads - 1) / nthreads
    print *, "points_per_thread = ",points_per_thread

    !$omp parallel private(k,x,count1,count4,sum,kstart,kend,thread_num,n)

    thread_num = 0     ! needed in serial mode
    !$ thread_num = omp_get_thread_num()    ! unique for each thread

    ! Determine start and end index for the set of points to be
    ! handled by this thread:
    kstart = thread_num * points_per_thread + 1
    kend = min((thread_num+1) * points_per_thread, ntests)

    !$omp critical
    print 201, thread_num, kstart, kend
    !$omp end critical
201 format("Thread ",i2," will take k = ",i6," through k = ",i6)

    do k=kstart,kend
        n = 10**(k+1)
        allocate(x(n))
        call random_number(x)
        sum = 0.d0
        count1 = 0
        count4 = 0
        do i=1,n
            sum = sum + x(i)
            if (x(i) < 0.25) then
                count1 = count1 + 1
                endif
            if (x(i) > 0.75) then
                count4 = count4 + 1
                endif
            enddo
        mean(k) = sum / float(n)
        q1(k) = count1 / float(n)
        q4(k) = count4 / float(n)
        deallocate(x)
        enddo
    !$omp end parallel

    do k=1,ntests
        n = 10**(k+1)
        print 601, n,mean(k),q1(k),q4(k)
 601    format(i10,3f15.8)
        enddo

end program main


c      program DRSSBASD
c>> 1996-07-09 DRSSBASD Krogh  Format changes for conversion to C.
c>> 1994-10-19 DRSSBASD Krogh  Changes to use M77CON
c>> 1993-01-12 DRSSBASD CLL @ JPL
c>> 1992-11-12 CLL @ JPL
c>> 1992-11-04 CLL @ JPL
c   Demo driver for SSBASD, SSBASI, SSDIF, SSFIND, SSVALA.
c     ------------------------------------------------------------------
c--S replaces "?": DR?SBASD, ?SBASD, ?SBASI, ?SDIF, ?SFIND, ?SVALA
c     ------------------------------------------------------------------
      integer I, IDERIV, J1, J2, KORDER, LEFT, MODE, NCOEF, NDERIV
      parameter(KORDER = 4, NCOEF = 6)
      parameter( IDERIV = 2, NDERIV = 3)
      real             BASI(NCOEF), BCOEF(NCOEF), BDERIV(KORDER)
      real             BDIF(NCOEF*(NDERIV+1)), BVALS(KORDER)
      real             SVALUE(NDERIV+1)
      real             TKNOTS(KORDER+NCOEF), X, X1, X2
      parameter( X = 0.4e0 , X1 = 0.1e0, X2 = 0.9e0)
      data TKNOTS / 4*0.0e0, 0.3e0, 0.8e0, 4*1.0e0 /
      data BCOEF / 0.1e0, 0.4e0, 0.2e0, -0.3e0, -0.5e0, -0.2e0 /
c     ------------------------------------------------------------------
      print '('' DRSSBASD..  Demo driver for''/
     *  ''             SSBASD, SSBASI, SSDIF, SSFIND, SSVALA.''/
     *  3x,'' KORDER ='',i2,'',  NCOEF ='',i2/ 3x,'' TKNOTS() ='',
     *  10f5.1)', KORDER, NCOEF, (TKNOTS(I),I=1,KORDER+NCOEF)
      print '('' Using SSFIND with X = '',f5.1)', X
      LEFT = 1
      call SSFIND(TKNOTS, KORDER, NCOEF+1, X, LEFT, MODE)
      print '(3x,'' LEFT = '',i2,'',  MODE ='',i2)', LEFT, MODE
      print '('' Using SSBASD with IDERIV = 0'')'
      call SSBASD( KORDER, LEFT, TKNOTS, X, 0, BVALS)
      print'(3x,'' Values at X of basis functions indexed from '',i2,
     *  '' to '',i2/6x,4f12.6)',  LEFT+1-KORDER, LEFT,
     *  (BVALS(I),I=1,KORDER)
      print'('' Using SSBASD with IDERIV ='',i2)', IDERIV
      call SSBASD(KORDER, LEFT, TKNOTS, X, IDERIV, BDERIV)
      print'(3x,
     * '' Values at X of 2nd deriv of basis functions indexed from '',
     * i2,'' to '',i2/6x,4f12.5)', LEFT+1-KORDER, LEFT,
     * (BDERIV(I),I=1,KORDER)
      print'('' Using SSBASI with X1 = '',f5.1,'' and X2 = '',f5.1)',
     *    X1,X2
      J1 = 1
      J2 = 1
      call SSBASI(KORDER, NCOEF, TKNOTS, X1, X2, J1, J2, BASI)
      print'(3x,'' J1 ='',i2,'',  J2 ='',i2/3x,
     * '' Integrals from X1 to X2 of basis functions:''/3x,6f11.6)',
     * J1, J2, (BASI(I),I=1,NCOEF)
      print'('' Using SSDIF and SSVALA with NDERIV ='',i2,'' and''/3x,
     * '' BCOEF() = '', 6f5.1)', NDERIV, (BCOEF(I),I=1,NCOEF)
      call SSDIF(KORDER, NCOEF, TKNOTS, BCOEF, NDERIV, BDIF)
      call SSVALA(KORDER, NCOEF, TKNOTS, NDERIV, BDIF, X, SVALUE)
      print'(3x,'' Values of derivs 0 through '',i2,'' at X: ''/
     *   6x,4f11.6)',  NDERIV, (SVALUE(I),I=1,NDERIV+1)
      end


module mathf
    implicit none
    contains

    subroutine mag(n, a, a_mag)
        implicit none
        integer, intent(in) :: n
        real, intent(in)    :: a(n)
        real, intent(out)   :: a_mag
        a_mag = sqrt(sum(a**2))
        return
    end subroutine mag

    subroutine unit(n, a, a_unit)
        implicit none
        integer, intent(in) :: n
        real, intent(in)    :: a(n)
        real, intent(out)   :: a_unit(n)
        real    :: a_mag
        call mag(n, a, a_mag)
        a_unit = a / a_mag
        return
    end subroutine unit

    subroutine find_gcd(a, b, gcd)
        implicit none
        integer, intent(in)     :: a, b
        integer                 :: c, d
        integer, intent(out)    :: gcd
        c = a
        gcd = b
        do while (c /= 0)
            d = c
            c = modulo(gcd, c)
            gcd = d
        end do
    end subroutine find_gcd

    subroutine mandelbrot_set(z, c, n, n_iter, z_f)
        implicit none
        integer, intent(in) :: n, n_iter
        complex, intent(in), dimension(n, n) :: z, c
        complex, intent(out), dimension(n, n) :: z_f
        integer :: i
        z_f = z
        do i=1, n_iter
            z_f = z_f**2 + c
        end do
    end subroutine mandelbrot_set

    subroutine mandelbrot_rate(z, c, n, n_iter, z_f)
        implicit none
        integer, intent(in) :: n, n_iter
        complex, intent(in), dimension(n, n) :: z, c
        complex, intent(out), dimension(n_iter + 1, n, n) :: z_f
        integer :: i
        z_f(1, :, :) = z(:, :)
        do i=1, n_iter
            z_f(i+1, :, :) = z_f(i, :, :)**2 + c
        end do
    end subroutine mandelbrot_rate

end module mathf


program problem12
  use euler
  implicit none
  integer*8          :: i,triangle=1
  integer, parameter :: n=500

  i=2
  do while (.true.)
     triangle=triangle+i
     i=i+1
     if (tau(triangle) .gt. n) then
        exit
     end if
  end do

  print *, triangle

end program problem12


*> \brief  ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEEV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
*                         WORK, LWORK, RWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          JOBVL, JOBVR
*       INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   RWORK( * )
*       COMPLEX*16         A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
*      $                   W( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the
*> eigenvalues and, optionally, the left and/or right eigenvectors.
*>
*> The right eigenvector v(j) of A satisfies
*>                  A * v(j) = lambda(j) * v(j)
*> where lambda(j) is its eigenvalue.
*> The left eigenvector u(j) of A satisfies
*>               u(j)**H * A = lambda(j) * u(j)**H
*> where u(j)**H denotes the conjugate transpose of u(j).
*>
*> The computed eigenvectors are normalized to have Euclidean norm
*> equal to 1 and largest component real.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] JOBVL
*> \verbatim
*>          JOBVL is CHARACTER*1
*>          = 'N': left eigenvectors of A are not computed;
*>          = 'V': left eigenvectors of are computed.
*> \endverbatim
*>
*> \param[in] JOBVR
*> \verbatim
*>          JOBVR is CHARACTER*1
*>          = 'N': right eigenvectors of A are not computed;
*>          = 'V': right eigenvectors of A are computed.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          On entry, the N-by-N matrix A.
*>          On exit, A has been overwritten.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*>          W is COMPLEX*16 array, dimension (N)
*>          W contains the computed eigenvalues.
*> \endverbatim
*>
*> \param[out] VL
*> \verbatim
*>          VL is COMPLEX*16 array, dimension (LDVL,N)
*>          If JOBVL = 'V', the left eigenvectors u(j) are stored one
*>          after another in the columns of VL, in the same order
*>          as their eigenvalues.
*>          If JOBVL = 'N', VL is not referenced.
*>          u(j) = VL(:,j), the j-th column of VL.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*>          LDVL is INTEGER
*>          The leading dimension of the array VL.  LDVL >= 1; if
*>          JOBVL = 'V', LDVL >= N.
*> \endverbatim
*>
*> \param[out] VR
*> \verbatim
*>          VR is COMPLEX*16 array, dimension (LDVR,N)
*>          If JOBVR = 'V', the right eigenvectors v(j) are stored one
*>          after another in the columns of VR, in the same order
*>          as their eigenvalues.
*>          If JOBVR = 'N', VR is not referenced.
*>          v(j) = VR(:,j), the j-th column of VR.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*>          LDVR is INTEGER
*>          The leading dimension of the array VR.  LDVR >= 1; if
*>          JOBVR = 'V', LDVR >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.  LWORK >= max(1,2*N).
*>          For good performance, LWORK must generally be larger.
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*>          > 0:  if INFO = i, the QR algorithm failed to compute all the
*>                eigenvalues, and no eigenvectors have been computed;
*>                elements i+1:N of W contain eigenvalues which have
*>                converged.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*  @precisions fortran z -> c
*
*> \ingroup complex16GEeigen
*
*  =====================================================================
      SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
     $                  WORK, LWORK, RWORK, INFO )
      implicit none
*
*  -- LAPACK driver routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2016
*
*     .. Scalar Arguments ..
      CHARACTER          JOBVL, JOBVR
      INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   RWORK( * )
      COMPLEX*16         A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
     $                   W( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY, SCALEA, WANTVL, WANTVR
      CHARACTER          SIDE
      INTEGER            HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU,
     $                   IWRK, K, LWORK_TREVC, MAXWRK, MINWRK, NOUT
      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM
      COMPLEX*16         TMP
*     ..
*     .. Local Arrays ..
      LOGICAL            SELECT( 1 )
      DOUBLE PRECISION   DUM( 1 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD,
     $                   ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC3, ZUNGHR
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX, ILAENV
      DOUBLE PRECISION   DLAMCH, DZNRM2, ZLANGE
      EXTERNAL           LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCMPLX, CONJG, AIMAG, MAX, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      WANTVL = LSAME( JOBVL, 'V' )
      WANTVR = LSAME( JOBVR, 'V' )
      IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
         INFO = -8
      ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
         INFO = -10
      END IF
*
*     Compute workspace
*      (Note: Comments in the code beginning "Workspace:" describe the
*       minimal amount of workspace needed at that point in the code,
*       as well as the preferred amount for good performance.
*       CWorkspace refers to complex workspace, and RWorkspace to real
*       workspace. NB refers to the optimal block size for the
*       immediately following subroutine, as returned by ILAENV.
*       HSWORK refers to the workspace preferred by ZHSEQR, as
*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
*       the worst case.)
*
      IF( INFO.EQ.0 ) THEN
         IF( N.EQ.0 ) THEN
            MINWRK = 1
            MAXWRK = 1
         ELSE
            MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 )
            MINWRK = 2*N
            IF( WANTVL ) THEN
               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
     $                       ' ', N, 1, N, -1 ) )
               CALL ZTREVC3( 'L', 'B', SELECT, N, A, LDA,
     $                       VL, LDVL, VR, LDVR,
     $                       N, NOUT, WORK, -1, RWORK, -1, IERR )
               LWORK_TREVC = INT( WORK(1) )
               MAXWRK = MAX( MAXWRK, N + LWORK_TREVC )
               CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL,
     $                      WORK, -1, INFO )
            ELSE IF( WANTVR ) THEN
               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
     $                       ' ', N, 1, N, -1 ) )
               CALL ZTREVC3( 'R', 'B', SELECT, N, A, LDA,
     $                       VL, LDVL, VR, LDVR,
     $                       N, NOUT, WORK, -1, RWORK, -1, IERR )
               LWORK_TREVC = INT( WORK(1) )
               MAXWRK = MAX( MAXWRK, N + LWORK_TREVC )
               CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR,
     $                      WORK, -1, INFO )
            ELSE
               CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR,
     $                      WORK, -1, INFO )
            END IF
            HSWORK = INT( WORK(1) )
            MAXWRK = MAX( MAXWRK, HSWORK, MINWRK )
         END IF
         WORK( 1 ) = MAXWRK
*
         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            INFO = -12
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGEEV ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Get machine constants
*
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
*
*     Scale A if max element outside range [SMLNUM,BIGNUM]
*
      ANRM = ZLANGE( 'M', N, N, A, LDA, DUM )
      SCALEA = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = SMLNUM
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF( SCALEA )
     $   CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
*     Balance the matrix
*     (CWorkspace: none)
*     (RWorkspace: need N)
*
      IBAL = 1
      CALL ZGEBAL( 'B', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR )
*
*     Reduce to upper Hessenberg form
*     (CWorkspace: need 2*N, prefer N+N*NB)
*     (RWorkspace: none)
*
      ITAU = 1
      IWRK = ITAU + N
      CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
     $             LWORK-IWRK+1, IERR )
*
      IF( WANTVL ) THEN
*
*        Want left eigenvectors
*        Copy Householder vectors to VL
*
         SIDE = 'L'
         CALL ZLACPY( 'L', N, N, A, LDA, VL, LDVL )
*
*        Generate unitary matrix in VL
*        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
*        (RWorkspace: none)
*
         CALL ZUNGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
     $                LWORK-IWRK+1, IERR )
*
*        Perform QR iteration, accumulating Schur vectors in VL
*        (CWorkspace: need 1, prefer HSWORK (see comments) )
*        (RWorkspace: none)
*
         IWRK = ITAU
         CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VL, LDVL,
     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
*
         IF( WANTVR ) THEN
*
*           Want left and right eigenvectors
*           Copy Schur vectors to VR
*
            SIDE = 'B'
            CALL ZLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
         END IF
*
      ELSE IF( WANTVR ) THEN
*
*        Want right eigenvectors
*        Copy Householder vectors to VR
*
         SIDE = 'R'
         CALL ZLACPY( 'L', N, N, A, LDA, VR, LDVR )
*
*        Generate unitary matrix in VR
*        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
*        (RWorkspace: none)
*
         CALL ZUNGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
     $                LWORK-IWRK+1, IERR )
*
*        Perform QR iteration, accumulating Schur vectors in VR
*        (CWorkspace: need 1, prefer HSWORK (see comments) )
*        (RWorkspace: none)
*
         IWRK = ITAU
         CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VR, LDVR,
     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
*
      ELSE
*
*        Compute eigenvalues only
*        (CWorkspace: need 1, prefer HSWORK (see comments) )
*        (RWorkspace: none)
*
         IWRK = ITAU
         CALL ZHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, W, VR, LDVR,
     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
      END IF
*
*     If INFO .NE. 0 from ZHSEQR, then quit
*
      IF( INFO.NE.0 )
     $   GO TO 50
*
      IF( WANTVL .OR. WANTVR ) THEN
*
*        Compute left and/or right eigenvectors
*        (CWorkspace: need 2*N, prefer N + 2*N*NB)
*        (RWorkspace: need 2*N)
*
         IRWORK = IBAL + N
         CALL ZTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
     $                 N, NOUT, WORK( IWRK ), LWORK-IWRK+1,
     $                 RWORK( IRWORK ), N, IERR )
      END IF
*
      IF( WANTVL ) THEN
*
*        Undo balancing of left eigenvectors
*        (CWorkspace: none)
*        (RWorkspace: need N)
*
         CALL ZGEBAK( 'B', 'L', N, ILO, IHI, RWORK( IBAL ), N, VL, LDVL,
     $                IERR )
*
*        Normalize left eigenvectors and make largest component real
*
         DO 20 I = 1, N
            SCL = ONE / DZNRM2( N, VL( 1, I ), 1 )
            CALL ZDSCAL( N, SCL, VL( 1, I ), 1 )
            DO 10 K = 1, N
               RWORK( IRWORK+K-1 ) = DBLE( VL( K, I ) )**2 +
     $                               AIMAG( VL( K, I ) )**2
   10       CONTINUE
            K = IDAMAX( N, RWORK( IRWORK ), 1 )
            TMP = CONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
            CALL ZSCAL( N, TMP, VL( 1, I ), 1 )
            VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO )
   20    CONTINUE
      END IF
*
      IF( WANTVR ) THEN
*
*        Undo balancing of right eigenvectors
*        (CWorkspace: none)
*        (RWorkspace: need N)
*
         CALL ZGEBAK( 'B', 'R', N, ILO, IHI, RWORK( IBAL ), N, VR, LDVR,
     $                IERR )
*
*        Normalize right eigenvectors and make largest component real
*
         DO 40 I = 1, N
            SCL = ONE / DZNRM2( N, VR( 1, I ), 1 )
            CALL ZDSCAL( N, SCL, VR( 1, I ), 1 )
            DO 30 K = 1, N
               RWORK( IRWORK+K-1 ) = DBLE( VR( K, I ) )**2 +
     $                               AIMAG( VR( K, I ) )**2
   30       CONTINUE
            K = IDAMAX( N, RWORK( IRWORK ), 1 )
            TMP = CONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
            CALL ZSCAL( N, TMP, VR( 1, I ), 1 )
            VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO )
   40    CONTINUE
      END IF
*
*     Undo scaling if necessary
*
   50 CONTINUE
      IF( SCALEA ) THEN
         CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ),
     $                MAX( N-INFO, 1 ), IERR )
         IF( INFO.GT.0 ) THEN
            CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR )
         END IF
      END IF
*
      WORK( 1 ) = MAXWRK
      RETURN
*
*     End of ZGEEV
*
      END


Module Gauss_quad
!
  Real, Dimension(5,5) :: XMU_Gauss_Quad, WMU_Gauss_Quad
!
  Data XMU_Gauss_Quad(1,:)/0.5,0.,0.,0.,0./
  Data WMU_Gauss_Quad(1,:)/1. ,0.,0.,0.,0./
!
  Data XMU_Gauss_Quad(2,:)/0.1127017,0.7886751,0.,0.,0./
  Data WMU_Gauss_Quad(2,:)/0.5,0.5,0.,0.,0./
!
  Data XMU_Gauss_Quad(3,:)/0.1127017,0.5000000,0.8872983,0.,0./
  Data WMU_Gauss_Quad(3,:)/0.2777778,0.4444444,0.2777778,0.,0./
!
  Data XMU_Gauss_Quad(4,:)/6.9431841E-02,0.3300095,0.6699905,0.9305682,0./
  Data WMU_Gauss_Quad(4,:)/0.1739274,0.3260726,0.3260726,0.1739274,0./
!
  Data XMU_Gauss_Quad(5,:)/4.6910077E-02,0.2307653,0.5000000,.7692347,0.9530900/
  Data WMU_Gauss_Quad(5,:)/0.1184634,0.2393143,0.2844445,0.2393143,0.1184634/
!
End Module Gauss_quad