      program main
      double precision a,b,result,abserr,resabs,resasc
      double precision book1,book3,book11,book15,book16
      double precision book454,book455,book457,book458,book459
      double precision myfn1,myfn2,myfn3,myfn4
      double precision alpha,beta
      double precision alist(1000),blist(1000),rlist(1000)
      double precision elist(1000),pts(1000)
      double precision rslst(1000),erlst(1000)
      double precision points(4)
      double precision chebmo(1000,25)
      integer iord(1000)
      integer nnlog(1000)
      integer ndin(1000)
      integer level(1000)
      integer ierlst(1000)
      integer maxp1,momcom
      integer inf
      integer integr
      common /ALPHA/alpha
      external book1,book3,book11,book15,book16
      external book454,book455,book457,book458,book459
      external myfn1,myfn2,myfn3,myfn4
      call gsl_ieee_env_setup

      a = 0.0
      b = 1.0

c      alpha = 2.6
c      print *,'alpha = ',alpha
c      call dqk15(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc
c      call dqk21(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc
c      call dqk31(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc
c      call dqk41(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc
c      call dqk51(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc
c      call dqk61(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc

c      alpha = -0.9
c      print *,'alpha = ',alpha
c      call dqk15(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc
c      call dqk21(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc
c      call dqk31(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc
c      call dqk41(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc
c      call dqk51(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc
c      call dqk61(book1,a,b,result,abserr,resabs,resasc)
c      write(6,1) result, abserr, resabs, resasc

c     alpha = 1.3
      a = 0.3
      b = 2.71
c     print *,'OSCILLATINg alpha = ',alpha
c     call dqk15(book3,a,b,result,abserr,resabs,resasc)
c     write(6,1) result, abserr, resabs, resasc
c     call dqk21(book3,a,b,result,abserr,resabs,resasc)
c     write(6,1) result, abserr, resabs, resasc
c     call dqk31(book3,a,b,result,abserr,resabs,resasc)
c     write(6,1) result, abserr, resabs, resasc
c     call dqk41(book3,a,b,result,abserr,resabs,resasc)
c     write(6,1) result, abserr, resabs, resasc
c     call dqk51(book3,a,b,result,abserr,resabs,resasc)
c     write(6,1) result, abserr, resabs, resasc
c     call dqk61(book3,a,b,result,abserr,resabs,resasc)
c     write(6,1) result, abserr, resabs, resasc

c      ier = 0
c      neval = 0
c      alpha = 2.6
c      epsabs = 1.0e-1
c      epsrel = 0.0
c      a = 0.0
c      b = 1.0
c      print *,'QNG book1'
c      print *,'alpha = ',alpha
c      call dqng(book1,a,b,epsabs,epsrel,result,abserr,neval,ier)
c      write(6,2) result, abserr, neval, ier
c      epsabs = 0.0
c      epsrel = 1e-9
c      call dqng(book1,a,b,epsabs,epsrel,result,abserr,neval,ier)
c      write(6,2) result, abserr, neval, ier
c      epsabs = 0.0
c      epsrel = 1e-13
c      call dqng(book1,a,b,epsabs,epsrel,result,abserr,neval,ier)
c      write(6,2) result, abserr, neval, ier
c      alpha = -0.9
c      epsabs = 0.0
c      epsrel = 1e-3
c      call dqng(book1,a,b,epsabs,epsrel,result,abserr,neval,ier)
c      write(6,2) result, abserr, neval, ier

c     alpha = 1.3
c      a = 0.3
c      b = 2.71
c      epsabs = 0.0
c      epsrel = 1e-12
c      call dqng(book3,a,b,epsabs,epsrel,result,abserr,neval,ier)
c      write(6,2) result, abserr, neval, ier

c      alpha = 2.6
c      a = 0.0
c      b = 1.0
c      epsabs = 0.0
c      epsrel = 1d-10
c      key = 1
c      limit = 1000
c      print *, 'DQAGE'
c      call dqage(book1,a,b,epsabs,epsrel,KEY,LIMIT,result,abserr,
c     $     neval,ier,alist,blist,rlist,elist,iord,last)
c      write(6,3) result, abserr, neval, ier, last
c      do 10 i=1,10
c         write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c 10   continue

c      alpha = 2.6
c      a = 0.0
c      b = 1.0
c      epsabs = 1d-14
c      epsrel = 0
c      key = 2
c      limit = 1000
c      print *, 'DQAGE'
c      call dqage(book1,a,b,epsabs,epsrel,KEY,LIMIT,result,abserr,
c     $     neval,ier,alist,blist,rlist,elist,iord,last)
c      write(6,3) result, abserr, neval, ier, last
c      do 11 i=1,10
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c 11   continue

c     alpha = 1.3
c     a = 0.3
c     b = 2.71
c     epsabs = 1d-14
c     epsrel = 0
c     key = 3
c     limit = 1000
c     print *, 'DQAGE oscill'
c     call dqage(book3,a,b,epsabs,epsrel,KEY,LIMIT,result,abserr,
c    $     neval,ier,alist,blist,rlist,elist,iord,last)
c     write(6,3) result, abserr, neval, ier, last
c     do 12 i=1,10
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c12   continue

c     alpha = 2.0
c     a = -1.0
c     b =  1.0
c     epsabs = 1d-14
c     epsrel = 0
c     key = 5
c     limit = 1000
c     print *, 'DQAGE sing'
c     call dqage(book16,a,b,epsabs,epsrel,KEY,LIMIT,result,abserr,
c    $     neval,ier,alist,blist,rlist,elist,iord,last)
c     write(6,3) result, abserr, neval, ier, last
c     do 13 i=1,10
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c13   continue

c     alpha = 1.0
c     a = -1.0
c     b =  1.0
c     epsabs = 1d-7
c     epsrel = 0
c     key = 6
c     limit = 3
c     print *, 'DQAGE sing'
c     call dqage(book16,a,b,epsabs,epsrel,KEY,LIMIT,result,abserr,
c    $     neval,ier,alist,blist,rlist,elist,iord,last)
c     write(6,3) result, abserr, neval, ier, last
c     do 14 i=1,10
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c14   continue

c     alpha = 2.6
c     a = 0.0
c     b = 1.0
c     epsabs = 0.0
c     epsrel = 1d-10
c     limit = 1000
c     print *, 'DQAGSE'
c     call dqagse(book1,a,b,epsabs,epsrel,LIMIT,result,abserr,
c    $     neval,ier,alist,blist,rlist,elist,iord,last)
c     write(6,3) result, abserr, neval, ier, last
c     do 15 i=1,10
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c15   continue

c     alpha = 2.6
c     a = 0.0
c     b = 1.0
c     epsabs = 1d-14
c     epsrel = 0.0
c     limit = 1000
c     print *, 'DQAGSE abs'
c     call dqagse(book1,a,b,epsabs,epsrel,LIMIT,result,abserr,
c    $     neval,ier,alist,blist,rlist,elist,iord,last)
c     write(6,3) result, abserr, neval, ier, last
c     do 16 i=1,10
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c16   continue

c      alpha = 2.0
c      a = 1.0
c      b = 1000.0
c      epsabs = 1d-7
c      epsrel = 0.0
c      limit = 1000
c      print *, 'DQAGSE abs'
c      call dqagse(book11,a,b,epsabs,epsrel,LIMIT,result,abserr,
c     $     neval,ier,alist,blist,rlist,elist,iord,last)
c      write(6,3) result, abserr, neval, ier, last
c      do i=1,10
c         write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c      enddo

c      alpha = 2.0
c      a = 0.0
c      inf = 1
c      epsabs = 0.0
c      epsrel = 1.0d-3
c      limit = 1000
c      print *, 'DQAGI abs'
c      call dqagie(book455,a,inf,epsabs,epsrel,limit,result,abserr,
c     $     neval,ier,alist,blist,rlist,elist,iord,last)
c      write(6,3) result, abserr, neval, ier, last
c      do i=1,20
c         write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c      enddo

c      alpha = 5.0
c      a = 0.0
c      inf = 1
c      epsabs = 0.0
c      epsrel = 1.0d-7
c      limit = 1000
c      print *, 'DQAGI abs'
c      call dqagie(book15,a,inf,epsabs,epsrel,limit,result,abserr,
c     $     neval,ier,alist,blist,rlist,elist,iord,last)
c      write(6,3) result, abserr, neval, ier, last
c      do i=1,20
c         write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c      enddo

c      alpha = 1.0
c      a = 99.9
c      inf = 1
c      epsabs = 1.0d-7
c      epsrel = 0.0
c      limit = 1000
c      print *, 'DQAGI abs'
c      call dqagie(book16,a,inf,epsabs,epsrel,limit,result,abserr,
c     $     neval,ier,alist,blist,rlist,elist,iord,last)
c      write(6,3) result, abserr, neval, ier, last
c      do i=1,20
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c      enddo

c      alpha = 1.0
c      a = 0.0
c      inf = 2
c      epsabs = 1.0d-7
c      epsrel = 0.0
c      limit = 1000
c      print *, 'DQAGI abs'
c      call dqagie(myfn1,a,inf,epsabs,epsrel,limit,result,abserr,
c     $     neval,ier,alist,blist,rlist,elist,iord,last)
c      write(6,3) result, abserr, neval, ier, last
c      do i=1,20
c         write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c      enddo

c      alpha = 1.0
c      b = 1.0
c      inf = -1
c      epsabs = 1.0d-7
c      epsrel = 0.0
c      limit = 1000
c      print *, 'DQAGI abs'
c      call dqagie(myfn2,b,inf,epsabs,epsrel,limit,result,abserr,
c     $     neval,ier,alist,blist,rlist,elist,iord,last)
c      write(6,3) result, abserr, neval, ier, last
c      do i=1,20
c         write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c      enddo

c     alpha = 1.0
c     a = 0.0
c     b = 3.0
c     npts2 = 4
c     points(1) = 1.0
c     points(2) = sqrt(2.0d0)
c     epsabs = 0.0
c     epsrel = 1.0d-3
c     limit = 1000
c     print *, 'DQAGP'
c     call dqagpe(book454,a,b,npts2,points,epsabs,epsrel,limit,
c    $     result, abserr, neval,ier,alist,blist,rlist,elist,
c    $     pts,iord,level,ndin,last)
c     write(6,3) result, abserr, neval, ier, last
c     do i=1,25
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c     enddo

c      alpha = 1.0
c      a = -1.0
c      b = 5.0
c      c = 0.0
c      epsabs = 0.0
c      epsrel = 1.0d-3
c      limit = 1000
c      print *, 'DQAGP'
c      call dqawce(book459,a,b,c,epsabs,epsrel,limit,
c     $     result, abserr, neval,ier,alist,blist,rlist,elist,
c     $     iord,last)
c      write(6,3) result, abserr, neval, ier, last
c      do i=1,25
c         write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c      enddo

c     alpha = 0.0
c     beta = 0.0
c     integr = 2
c     a = 0.0
c     b = 1.0
c     epsabs = 0.0
c     epsrel = 1.0d-7
c     limit = 1000
c     print *, 'DQAGP'
c     call dqawse(book458,a,b,alpha,beta,integr,epsabs,epsrel,limit,
c    $     result, abserr, neval,ier,alist,blist,rlist,elist,
c    $     iord,last)
c     write(6,3) result, abserr, neval, ier, last
c     do i=1,25
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c     enddo

c     alpha = -0.5
c     beta = -0.3
c     integr = 4
c     a = 0.0
c     b = 1.0
c     epsabs = 0.0
c     epsrel = 1.0d-7
c     limit = 1000
c     print *, 'DQAGP'
c     call dqawse(book458,a,b,alpha,beta,integr,epsabs,epsrel,limit,
c    $     result, abserr, neval,ier,alist,blist,rlist,elist,
c    $     iord,last)
c     write(6,3) result, abserr, neval, ier, last
c     do i=1,10
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c     enddo

c     alpha = -0.5
c     beta = -0.3
c     integr = 4
c     a = 0.0
c     b = 1.0
c     epsabs = 0.0
c     epsrel = 1.0d-7
c     limit = 1000
c     print *, 'DQAGP'
c     call dqawse(book458,a,b,alpha,beta,integr,epsabs,epsrel,limit,
c    $     result, abserr, neval,ier,alist,blist,rlist,elist,
c    $     iord,last)
c     write(6,3) result, abserr, neval, ier, last
c     do i=1,10
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c     enddo

c     a = 0.0
c     b = 1.0
c     omega = 10.0 * 3.14159265358979323846
c     epsabs = 0.0
c     epsrel = 1.0d-7
c     limit = 1000
c     integr = 2
c     icall = 1
c     maxp1 = 1000
c     momcom = 0
c     print *, 'DQAGP'
c     call dqawoe(myfn4,a,b,omega,integr,epsabs,epsrel,limit,
c    $     icall, maxp1,
c    $     result, abserr, neval,ier,last,alist,blist,rlist,elist,
c    $     iord, nnlog, momcom, chebmo)
c     write(6,3) result, abserr, neval, ier, last
c     do i=1,10
c        write(6,4) i,alist(i),blist(i),rlist(i),elist(i),iord(i)
c     enddo

      a = 0.0
      b = 1.0
      omega = 3.14159265358979323846 / 2.0
      epsabs = 1.0d-7
      epsrel = 0.0
      limit = 1000
      limlst = 1000
      integr = 1
      icall = 1
      maxp1 = 1000
      momcom = 0
      print *, 'DQAGP'
      call dqawfe(book457,a,omega,integr,epsabs,limlst, limit,
     $     maxp1,
     $     result, abserr, neval,ier,rslst, erlst, ierlst, lst,
     $     alist,blist,rlist,elist,
     $     iord, nnlog, chebmo)
      write(6,3) result, abserr, neval, ier, last
      do i=1,20
         write(6,4) i,rslst(i),erlst(i)
      enddo

 1    format(
     $     '-----------------',/
     $     'double exp_result =',1pe25.18, ';',/
     $     'double exp_abserr =',1pe25.18, ';',/
     $     'double exp_resabs =',1pe25.18, ';',/
     $     'double exp_resasc =',1pe25.18, ';')
 2    format(
     $     '-----------------',/
     $     'double exp_result =',1pe25.18, ';',/
     $     'double exp_abserr =',1pe25.18, ';',/
     $     'double exp_neval  =',I8, ';',/
     $     'double exp_ier    =',I8, ';')
 3    format(
     $     '-----------------',/
     $     'double exp_result =',1pe25.18, ';',/
     $     'double exp_abserr =',1pe25.18, ';',/
     $     'int    exp_neval  =',I8, ';',/
     $     'int    exp_ier    =',I8, ';',/
     $     'int    last       =',I8, ';')
 4    format('i=',i4,' a=',1pe25.18,' b=',1pe25.18,
     $     ' r=',1pe25.18,' e=',1pe25.18, ' iord=',i4)
      end

      double precision function book1(x)
      double precision alpha,x
      common /ALPHA/alpha
      book1=x**alpha*log(1.0/x)
      end

      double precision function book3(x)
      double precision alpha,x
      common /ALPHA/alpha
      book3=cos((2**alpha)*sin(x))
      end

      double precision function book11(x)
      double precision alpha,x
      common /ALPHA/alpha
      book11=(log(1/x))**(alpha-1.0)
      end

      double precision function book15(x)
      double precision alpha,x
      common /ALPHA/alpha
      book15=(x**2.0)*exp(-x*(2.0**-alpha))
      end

      double precision function book16(x)
      double precision alpha,x
      common /ALPHA/alpha
      book16=(x**(alpha-1.0))/((1.0+10.0*x)**2.0)
      end

      double precision function book454(x)
      double precision alpha,x
      common /ALPHA/alpha
      book454=(x**3.0) * log(abs((x**2.0 - 1.0)*(x**2.0 - 2.0)))
      write(6,6661) x, book454
 6661 format("FF x = ", 1pe25.18, " book454 = ", 1pe25.18)
      end

      double precision function book455(x)
      double precision alpha,x
      common /ALPHA/alpha
      book455=log(x)/(1.0 + 100.0*x*x)
      write(6,6661) x, book455
 6661 format("FF x = ", 1pe25.18, " book455 = ", 1pe25.18)
      end

      double precision function book457(x)
      double precision alpha,x
      common /ALPHA/alpha
      book457 = 0
      if (x.gt.0) book457= 1.0/sqrt(x)
      write(6,6661) x, book457
 6661 format("FF x = ", 1pe25.18, " book457 = ", 1pe25.18)
      end

      double precision function book458(x)
      double precision alpha,x
      common /ALPHA/alpha
      book458=1.0/(1.0 + log(x)**2)**2
      write(6,6661) x, book458
 6661 format("FF x = ", 1pe25.18, " book458 = ", 1pe25.18)
      end

      double precision function book459(x)
      double precision alpha,x
      common /ALPHA/alpha
      book459=1.0/(5.0*x**3 + 6.0)
      write(6,6661) x, book459
 6661 format("FF x = ", 1pe25.18, " book459 = ", 1pe25.18)
      end

      double precision function myfn1(x)
      double precision alpha,x
      common /ALPHA/alpha
      myfn1=exp(-x - x**2.0)
      end

      double precision function myfn2(x)
      double precision alpha,x
      common /ALPHA/alpha
      myfn2=exp(alpha*x)
      end

      double precision function myfn3(x)
      double precision alpha,x
      common /ALPHA/alpha
      myfn3=exp(-x)
      write(6,6661) x, myfn3
 6661 format("FF x = ", 1pe25.18, " myfn3 = ", 1pe25.18)
      end

      double precision function myfn4(x)
      double precision alpha,x
      common /ALPHA/alpha
      myfn4=0
      if (x.gt.0.0) myfn4=log(x)
      write(6,6661) x, myfn4
 6661 format("FF x = ", 1pe25.18, " myfn4 = ", 1pe25.18)
      end


      subroutine bglsdc(n, l, m, a, ia, iflag)
c
c     description
c
c     given a banded matrix a with l lower subdiagonals and m super
c     diagonals, this routine factors the matrix into a = lu.  these
c     factors can then be used by routine bglssl to solve the system
c     a*x = lu*x = y.  the upper and lower bandwidths must both be
c     less than or equal to 64.  no pivoting is performed.
c
c     the m super diagonals of the matrix a are stored in the first
c     m rows of the array a.  the main diagonal of the matrix a is
c     stored in the m+1 row of the array a.  the l subdiagonals of the
c     matrix a are stored in rows m+2 through m+l+1 of the array a.
c     the columns of the matrix a correspond to the columns of array a.
c     for example, if n=4, l=2, and m=1, the matrix elements a(i,j)
c     will be stored in array a as follows:
c
c          0       a(1,2)  a(2,3)  a(3,4)
c          a(1,1)  a(2,2)  a(3,3)  a(4,4)
c          a(2,1)  a(3,2)  a(4,3)  0
c          a(3,1)  a(4,2)  0       0
c
c     on entry
c        n = the order of the system
c        l = the number of lower diagonals  l .le. 64
c        m = the number of upper diagonals  m .le. 64
c        a = a 2d array that contains the matrix to be factored
c            the diagonals are stored in the rows of a as
c            described above
c       ia = the first dimension of a      ia .gt. m + l
c
c     on return
c         a = lu, where l is in place of the lower diagonals and u
c             is in rows above l
c     iflag = 0 if ok
c           = 1 if (n .le. 0 .or. m + l .ge. ia)
c           = 2 if a is singular
c
      implicit real*8  (a - h, o - z)
      implicit integer (i - n)
c
      dimension a(ia,n)
c
      iflag = 0
c
      if (n .le. 0 .or. m + l .ge. ia) then
				       iflag = 1
				       return
      end if
c
      mp1 = m + 1
      mp2 = m + 2
c
      if (n .gt. 1) then
c
           do 1 j = 2, n
           jm1 = j - 1
           if ( a(mp1, jm1) .eq. 0.0D0 ) then
	                                 iflag = 2
                                         return
           end if
           a(mp1, jm1) = 1.0D0 / a(mp1, jm1)
           jp = max(1, j -  m )
           lp = min(l, n - jm1)
           call sscal (    lp,     a(mp1, jm1),     a(mp2     , jm1), 1)
           call bglsrd(n,l,jp,jm1, a(mp2, jp ), ia, a(mp1-j+jp, j  )   )
    1      continue
           return
      end if
c
      if (n .eq. 1) then
c
           if ( a(mp1,   n) .eq. 0.0D0 ) then
	                                 iflag = 2
                                         return
           end if
           a(mp1, n) = 1.0D0 / a(mp1, n)
           return
      end if
c
      end
      subroutine bglsrd(n, jm1, m, k, a, ia, b)
c
      return
      end
      subroutine bglssl(n, l, m, a, ia, y, iflag)
c
c     purpose: to solve the general banded linear system
c              of equations a*x=b, where a has been previously
c              factored into a=lu.
c
c     description:
c
c     this routine solves the general banded linear system of
c     equations a*x=b, using the lu factorization of a done by
c     the routine bglsdc.  the upper and lower bandwidths must
c     each be less than or equal to 64.  no pivoting is performed.
c     therefore, there are dangers if the matrix does not have
c     sufficient diagonal dominance.
c
c     on entry:
c        n = the order of the system
c        l = the number of lower diagonals  l .le. 64
c        m = the number of upper diagonals  m .le. 64
c        a = lu, where l and u are the factorization from
c            routine bglsdc
c       ia = the first dimension of a      ia .gt. m + l
c        y = the right hand side of the equations
c
c     on return:
c         y = the solution to the system of equations
c     iflag = 0 if ok
c           = 1 if (n .le. 0 .or. m + l .ge. ia)
c
      implicit real*8  (a - h, o - z)
      implicit integer (i - n)
c
      dimension a(ia, n), y(n)
c
      iflag = 0
c
      if (n .le. 0 .or. m + l .ge. ia) then
				       iflag = 1
                                       return
      end if
c
      mp1 = m + 1
      mp2 = m + 2
c
      if (n .gt. 1) then
                      call bglsrd(n,  l, 1, n-1, a(mp2, 1),  ia, y(1))
                      call bglsrd(n, -m, 1, n-1, a(m  , n), -ia, y(n))
		      return
      end if
c
      if (n .eq. 1) then
                      y(1) = y(1) * a(mp1, 1)
                      return
      end if
c
      end
      subroutine sgefad(a, lda, n, info)
c
c***********************************************************************
c     factors a real matrix by gaussian elimination with no pivoting
c***********************************************************************
c
      include 'titan.imp'
      dimension a(lda,1)
c
c-----------------------------------------------------------------------
c on entry:
c        a      real(lda, n): matrix to be factored.
c        lda    integer: leading dimension of array a.
c        n      integer: order of matrix a.
c
c on return:
c        a      factorization a = l*u, where l is product of permutation
c               and unit lower triangular matrices and u is upper
c               triangular.
c        info   integer:
c                = 0  normal value.
c                = k  if u(k,k) .eq. 0.0.
c                not an error condition for this subroutine, but
c                indicates that sgesl will divide by zero if called.
c-----------------------------------------------------------------------
c
      info = 0
      nm1  = n - 1
      if (nm1 .lt. 1) then
                      info = nm1
                      return
      end if
c
      do 60 k = 1, nm1
      kp1 = k + 1
c
c     zero pivot implies this column already triangularized
c
      if (a(k, k) .eq. 0.0D0) then
                              info = k
                              return
      end if
c
c     compute multipliers
c
      t = - 1.0D0 / a(k, k)
      call sscal( n-k, t, a(k+1, k), 1 )
c
c     row elimination with column indexing
c
      do 30 j = kp1, n
      t = a(k, j)
      call saxpy( n-k, t, a(k+1, k), 1, a(k+1, j), 1 )
   30 continue
   60 continue
c
      return
      end
      subroutine sgefaj(a, ia, n, info)
c
c***********************************************************************
c     sgefaj computes the l-u decomposition of a general real matrix   c
c     using gaussian elimination. no pivoting. adapted from code by    c
c     t. l. jordan                                                     c
c***********************************************************************
c
      include 'titan.imp'
      dimension a(ia, n)
c
      info = 0
      if (n .eq. 1) then
                    info = 1
                    return
      end if
c
c     perform reduction on each column of a
c
      do 103 j = 2, n
c
c     scale the preceding column
c
            jm1 = j - 1
      if (a(jm1, jm1) .ne. 0.0E0) then
c
                   call sscal(n - jm1, 1.0E0/a(jm1, jm1), a(j, jm1), 1)
c
c                  reduce the jth column of a
c
                   call trslbl(n, jm1, a(1, 1), ia, 1, a(1, j))
      end if
  103 continue
c
      info = jm1
c
c     check for singular matrix
c
      if (a(n,n) .ne. 0.0E0) return
      info = n
c
      return
      end
      subroutine sgesld(a, lda, n, b, job)
c
c***********************************************************************
c     solves the real system a*x = b or trans(a)*x = b using the factors
c     computed by sgefa. no pivoting.
c***********************************************************************
c
      include 'titan.imp'
      dimension a(lda, 1), b(1)
c
c----------------------------------------------------------------------
c     on entry:
c        a       real(lda, n), output from sgefa
c        lda     integer, leading dimension of array a
c        n       integer, the order of the matrix a
c        b       real(n), right hand side vector
c        job     integer
c                = 0         solve a*x = b
c                = nonzero   solve trans(a)*x = b
c
c     on return:
c        b       solution vector  x
c
c     error condition
c        division by zero will occur if input factor contains a
c        zero on the diagonal
c----------------------------------------------------------------------
c
      nm1 = n - 1
      if (job .eq. 0) then
c
c        job = zero , solve  a * x = b. first solve  l*y = b
c
         if (nm1 .ge. 1) then
            do 20 k = 1, nm1
               do 15 ili = 1, n-k
                  b(k+ili) = b(k+ili) + b(k) * a(k+ili, k)
   15          continue
   20       continue
         end if
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k) / a(k, k)
            do 35 ili = 1, k-1
               b(ili) = b(ili) - b(k) * a(ili, k)
   35       continue
   40    continue
      return
      end if
c
c        job = nonzero, solve trans(a) * x = b
c        first solve trans(u)*y = b
c
      if (job .ne. 0) then
         do 60 k = 1, n
            b(k) = b(k) / a(k,k)
cdir$ ivdep
            do 60 ili = k+1, n
               b(ili) = b(ili) - a(k, ili) * b(k)
   60       continue
c
c        now solve trans(l)*x = y
c
         if (nm1 .ge. 1) then
            do 80 kb = 1, nm1
               k = n - kb
               b(k) = b(k) + sdot( n-k, a(k+1, k), 1, b(k+1), 1)
   80       continue
         end if
c
      return
      end if
c
      end
      subroutine sgeslj( a, ia, n, y )
c
c***********************************************************************
c     sgeslj computes the solution of a general real system which has  c
c     been decomposed by sgefaj. no pivoting. adapted from code by     c
c     t. l. jordan                                                     c
c***********************************************************************
c
      include 'titan.imp'
      dimension a(ia, 1), y(1)
c
c==================================================================
c     solution x=y/a
c==================================================================
c
      if (n .eq. 1) then
                    y(1) = y(1) / a(1,1)
                    return
      endif
c
c==================================================================
c     solve ax=y
c==================================================================
c
c     perform the forward substitution
c
      call trslbl ( n, n - 1, a(1, 1),  ia,  1, y(1) )
c
c     perform the back substitution
c
      call trslbl ( n, n    , a(n, n), -ia, -1, y(n) )
c
      return
      end
      subroutine sgeslmj(a, ia, n, b, ib, lot)
c
c***********************************************************************
c     solve a system of linear equations with many right hand sides.   c
c     no pivoting. adapted from code by t.l. jordan. modified to use   c
c     standard linpack sgemv calling sequence                          c
c***********************************************************************
c
c     description:
c     solves real system of equations a*x=b, where x and b are matrices.
c     lu  factorization of routine sgefaj assumed. no pivoting performed
c     internally.
c
c     on entry:
c        a = output from sgefaj
c       ia = leading dimension of array a
c        n = order of matrix a
c        b = matrix of right hand sides
c       ib = leading dimension of the array b
c      lot = number of right hand sides
c
c     on return
c        b = solution matrix x
c
c***********************************************************************
c
      include 'titan.imp'
      dimension a(ia,1), b(ib,1)
c
c=======================================================================
c
      if (lot .lt. 20 .and. n .gt. 4*lot) then
c
c     for small number of long rhs's use sgeslj
c
	    do 10 j = 1, lot
	    call sgeslj(a, ia, n, b(1, j))
   10       continue
      else
c
c     for large number of rhs's use sgemv to solve l*y = b
c
            do 20 k = 1, n - 1
            call sgemv('t',   k, lot, -1.0D0, b(  1, 1), ib, a(k+1, 1),
     .                                         ia, 1.0D0, b(k+1, 1), ib)
   20       continue
c
c     then solve u*x = y
c
            do 30 k = n, 1, -1
            call sgemv('t', n-k, lot, -1.0D0, b(k+1, 1), ib, a(k, k+1),
     .                                         ia, 1.0D0, b(k  , 1), ib)
            call sscal(lot, 1.0D0 / a(k, k), b(k, 1), ib)
   30       continue
      end if
c
      return
      end


C  (C) Copr. 1986-92 Numerical Recipes Software ]2w.1,r1..

C--- Version where idum is passed as an argument
      double precision FUNCTION ran1(idum)
      implicit none
      INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
      double precision AM,EPS,RNMX
      PARAMETER (IA=16807,IM=2147483647,AM=1d0/IM,IQ=127773,
     .IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=3d-16,RNMX=1d0-EPS)
      INTEGER j,k,iv(NTAB),iy
      DATA iv /NTAB*0/, iy /0/
      SAVE iv,iy

      if (idum.le.0.or.iy.eq.0) then
        idum=max(-idum,1)
        do 11 j=NTAB+8,1,-1
          k=idum/IQ
          idum=IA*(idum-k*IQ)-IR*k
          if (idum.lt.0) idum=idum+IM
          if (j.le.NTAB) iv(j)=idum
11      continue
        iy=iv(1)
      endif
      k=idum/IQ
      idum=IA*(idum-k*IQ)-IR*k
      if (idum.lt.0) idum=idum+IM
      j=1+iy/NDIV
      iy=iv(j)
      iv(j)=idum
      ran1=min(AM*dble(iy),RNMX)

c      write(6,*) 'idum',idum
c      write(6,*) 'AM=',AM
c      write(6,*) 'iy=',iy
c      write(6,*) 'AM*dble(iy)',AM*dble(iy)
c      write(6,*) 'ran1',ran1

      return
      end

C  (C) Copr. 1986-92 Numerical Recipes Software ]2w.1,r1..

C--- Version where idum is passed via common block
      double precision FUNCTION ran2()
      implicit none
      INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
      double precision AM,EPS,RNMX
      PARAMETER (IA=16807,IM=2147483647,AM=1d0/IM,IQ=127773,
     .IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=3d-16,RNMX=1d0-EPS)
      INTEGER j,k,iv(NTAB),iy
      COMMON /ranno/ idum
      DATA iv /NTAB*0/, iy /0/
      SAVE iv,iy

      if (idum.le.0.or.iy.eq.0) then
        idum=max(-idum,1)
        do 11 j=NTAB+8,1,-1
          k=idum/IQ
          idum=IA*(idum-k*IQ)-IR*k
          if (idum.lt.0) idum=idum+IM
          if (j.le.NTAB) iv(j)=idum
11      continue
        iy=iv(1)
      endif
      k=idum/IQ
      idum=IA*(idum-k*IQ)-IR*k
      if (idum.lt.0) idum=idum+IM
      j=1+iy/NDIV
      iy=iv(j)
      iv(j)=idum
      ran2=min(AM*dble(iy),RNMX)

!       write(6,*) 'idum',idum
!       write(6,*) 'AM=',AM
!       write(6,*) 'iy=',iy
!       write(6,*) 'AM*dble(iy)',AM*dble(iy)
!      write(6,*) 'ran2',ran2

      return
      END


	SUBROUTINE GH_SWLN ( ise, ine, inw, isw, alat, alon, nstrm,
     +                       hvhur, iret)
C************************************************************************
C* GH_SWLN								*
C*									*
C* This subroutine calculates and plots the radii of the tropical       *
C* storm quadrants from one quadrant to the next for tropical storm     *
C* (34KT) and hurricane (64KT) force winds.				*
C*									*
C* GH_SWLN ( ISE, INE, INW, ISW, ALAT, ALON, NSTRM, HVHUR, IRET) 	*
C*									*
C* Input parameters:							*
C*	ISE (2, nstrm)	INTEGER		Southeast wind distance (nm)	*
C*	INE (2, nstrm)	INTEGER		Northeast wind distance (nm)	*
C*	INW (2, nstrm)	INTEGER		Northwest wind distance (nm)	*
C*	ISW (2, nstrm)	INTEGER		Southwest wind distance (nm)	*
C*      ALAT (nstrm)	REAL		Array of initial latitudes	*
C*      ALON (nstrm)	REAL		Array of initial longitudes	*
C*	NSTRM		INTEGER		Total number of files read	*
C*	HVHUR		LOGICAL		One report of hurricane winds	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*									*
C**									*
C* Log:									*
C* A. Hardy/GSC		 2/01   					*
C* A. Hardy/GSC		 6/01 	Added color tag parameter		*
C* D. Kidwell/NCEP	 9/01	Rewrote for interpoln & smooth; cleanup *
C* D. Kidwell/NCEP	 2/02	Removed unused variable idrop           *
C* D. Kidwell/NCEP	 4/02	Tapered down to 0 at end                *
C* D. Kidwell/NCEP	 5/03	Added argument iptsm to GG_TCSM call    *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	PARAMETER	( MXINTP = 1000 )
C*
 	INTEGER         ise(2,*), ine(2,*), inw(2,*), isw(2,*)
        REAL		alat(*), alon(*)
        LOGICAL         hvhur
C*
        INTEGER		istart (20), iend (20)
        REAL		blat (364),
     +			blon (364),
     +			dlat (MXINTP), dlon (MXINTP), angle (4),
     +          	dist (5), dse (2,MXINTP), dne (2,MXINTP),
     +		  	dnw (2,MXINTP), dsw (2,MXINTP)
        LOGICAL		blob
        CHARACTER       coltag*33
C-----------------------------------------------------------------------
        iret  = 0
        iang1 = 0
        iang2 = 90
        angle (1) = 45
        angle (2) = 135
        angle (3) = 225
        angle (4) = 315
C
    	nsmth = 50
    	iptsm = 5
C
C*      Set loop for tropical storm and/or hurricane.
C
        IF ( hvhur ) THEN
            ifini = 2
          ELSE
            ifini = 1
        END IF
C
        DO kk = 1, ifini
            IF ( kk .eq. 1 ) THEN
                icol   = 18
                coltag = 's_ts_wind'
		iradif = 9
            END IF
            IF ( kk .eq. 2 ) THEN
                icol   = 2
                coltag = 's_hur_wind'
		iradif = 6
            END IF
C
C*          Determine the starting and end points for each "blob".
C
            DO mb = 1, 20
                istart ( mb ) = IMISSD
                iend   ( mb ) = IMISSD
            END DO
C
            iblob = 1
            blob  = .false.
            DO ik = 1, nstrm
                isum = ise ( kk, ik ) +  ine ( kk, ik ) +
     +                 inw ( kk, ik ) +  isw ( kk, ik )
                IF ( ( isum .ne. 0 ) .and. ( .not. blob ) ) THEN
		    istart (iblob) = ik
                    blob = .true.
                END IF
                IF ( ( isum .eq. 0 ) .and. blob ) THEN
                    iend ( iblob ) = ik
                    blob  = .false.
                    iblob = iblob + 1
                END IF
            END DO
C
            IF ( ( istart ( iblob ) .ne. IMISSD ) .and.
     +           ( iend ( iblob ) .eq. IMISSD ) ) THEN
	        iend ( iblob ) = nstrm
	      ELSE
                iblob = iblob - 1
            END IF
C
C*	    Loop over the discrete "blobs" in the swath.
C
            DO mm = 1, iblob
                ib  = istart (mm)
                ie  = iend (mm)
C
C*		Interpolate track points and radii for a smooth plot.
C
		ipt = 1
		DO ip = ib, ie
		    dlat ( ipt ) = alat ( ip )
		    dlon ( ipt ) = alon ( ip )
		    dse ( kk, ipt ) = FLOAT ( ise ( kk, ip ) )
		    dne ( kk, ipt ) = FLOAT ( ine ( kk, ip ) )
		    dnw ( kk, ipt ) = FLOAT ( inw ( kk, ip ) )
		    dsw ( kk, ipt ) = FLOAT ( isw ( kk, ip ) )
		    IF ( ip .lt. ie ) THEN
	                CALL CLO_DIST ( alat ( ip ), alon ( ip ), 1,
     +				       alat ( ip + 1 ), alon ( ip + 1 ),
     +			               dd, ier )
		        IF ( dd .gt. 5000. ) THEN
                            radmin = AMIN0 ( ise (kk,ip), ine (kk,ip),
     +                                       inw (kk,ip), isw (kk,ip),
     +                                       ise(kk,ip+1), ine(kk,ip+1),
     +                                       inw(kk,ip+1), isw(kk,ip+1))
			    radavg = NINT ( FLOAT ( ise (kk,ip) +
     +				     ine (kk,ip) +
     +				     inw (kk,ip) + isw (kk,ip) +
     +				     ise(kk,ip+1) + ine(kk,ip+1) +
     +				     inw(kk,ip+1) + isw(kk,ip+1) )
     +				     / 8. )
			    IF ( radavg .lt. 6. ) radavg = 6.
			    space = PR_HGNM ( radavg )
	                    intrp = NINT ( dd / space + .6 )
			    incr  = NINT ( radavg - radmin ) / iradif
			    intrp = intrp + incr
			    intvl = intrp + 1
		            delta = dd / FLOAT ( intvl )
		            CALL CLO_DIRECT ( alat (ip+1), alon (ip+1),
     +				           alat ( ip ), alon ( ip ),
     +					   ddir, ier )
			    ddist = delta
			    DO ii = 1, intrp
			        ipt = ipt + 1
			        CALL CLO_DLTLN ( alat (ip), alon (ip),
     +					        ddist, ddir, dlat (ipt),
     +					        dlon (ipt), ier )
			        wt2 = FLOAT ( ii ) / FLOAT ( intvl )
			        wt1 = 1. - wt2
				dse ( kk, ipt ) = ise ( kk,ip ) * wt1
     +					        + ise ( kk, ip+1 ) * wt2
				dne ( kk, ipt ) = ine ( kk,ip ) * wt1
     +					        + ine ( kk, ip+1 ) * wt2
				dnw ( kk, ipt ) = inw ( kk,ip ) * wt1
     +					        + inw ( kk, ip+1 ) * wt2
				dsw ( kk, ipt ) = isw ( kk,ip ) * wt1
     +					        + isw ( kk, ip+1 ) * wt2
   			        ddist = ddist + delta
			    END DO
			END IF
		        ipt = ipt + 1
		    END IF
		END DO
C
C*              Calculate tropical storm and hurricane force wind zones
C*		within a "blob".
C
		rdmin = 0.
                DO ip = 1, ipt
C
                    dist (1) = AMAX1 ( dse ( kk, ip ), rdmin )
                    dist (2) = AMAX1 ( dne ( kk, ip ), rdmin )
                    dist (3) = AMAX1 ( dnw ( kk, ip ), rdmin )
                    dist (4) = AMAX1 ( dsw ( kk, ip ), rdmin )
                    dist (5) = dist (1)
C
C*	 	    Loop through each quadrant of the polygon.  The
C*                  radii are currently calculated to generate a
C*                  smooth contour when sweeping from one quadrant
C*                  to the next in 1 degree azimuthal increments.
C
                    icnt  = 0
                    DO ii = 1, 4
                        DO iangle  = iang1, iang2
                            icnt   = icnt + 1
			    theta  = FLOAT ( iangle )
			    rtheta = DTR * theta
                            rad    = COS ( rtheta ) * COS ( rtheta )
     +                               * dist ( ii )
     +                               + SIN ( rtheta ) * SIN ( rtheta )
     +                               * dist ( ii + 1 )
C
			    rtheta = DTR * ( theta + 270.0 + angle(ii) )
                            y1     = rad * SIN ( rtheta ) / 60.0
                            x1     = (-rad) * COS ( rtheta ) / 60.0
     +                               / COS ( DTR * dlat ( ip ) )
C
                            blat (icnt) = dlat (ip) + y1
                            blon (icnt) = dlon (ip) - x1
                        END DO
                    END DO
C
		    CALL GG_TCSM ( nsmth, icnt, iptsm, blat, blon, ier )
C
C*		    Draw and fill the polygon.
C
 		    CALL GH_SWDF ( coltag, icol, icnt, blat, blon, ier )
		END DO
            END DO
        END DO
C*
        RETURN
        END


C
C
       subroutine fun_gser(gamser,a,x,gln,istat)
C      -----------------------------------------
C
C Internal subroutine returning incomplete gamma function from series
C
C Given:
C  parameters of function
       real*4     a,x
C Returned:
C  value of function and log(Gamma(a))
       real*4     gamser,gln
C Updated:
C   error return code
       integer    istat
C
C P. Alexander, MRAO, Cambridge.
C Ref: Numerical recipes, Press et al., Cambridge. pg. 162
C-
       include '../include/utilities_errors.inc'

       integer    itmax, n
       real*4     eps, ap, sum, del
       parameter (itmax=100,eps=3.0E-7)

C functions used
       real*4     fun_gammln

       if (istat.ne.0) return
       gln = fun_gammln( a, istat )
       if (istat.ne.0) goto 999
       if (x.lt.0.0) then
         istat = ill_inputs
       else if (x.eq.0.0) then
         gamser = 0.0
       else
         ap = a
         sum = 1.0/a
         del = sum
         do n=1,itmax
           ap = ap + 1.0
           del = del*x/ap
           sum = sum + del
           if (abs(del).lt.abs(sum)*eps) goto 1
         end do
         istat = ill_precision
         goto 999
 1       gamser = sum*exp(-x+a*log(x)-gln)
       end if
 999   call utl_err( istat,'fun_gser',' ' )
       end