module numz
    integer, parameter:: b4 = selected_real_kind(4)
end module
module maxsize
        integer nmax
        parameter  (nmax=8000)
end module
module ccm_time_mod
    integer, parameter:: b8 = selected_real_kind(10)
    integer,save,private :: ccm_start_time(8) = (/-1, -1, -1, -1, -1, -1, -1, -1/)
contains
    function ccm_time()
        implicit none
        real(b8) :: ccm_time,tmp
        integer,parameter :: norm(13)=(/  &
               0, 2678400, 5097600, 7776000,10368000,13046400,&
        15638400,18316800,20995200,23587200,26265600,28857600,31536000/)
        integer,parameter :: leap(13)=(/  &
               0, 2678400, 5184000, 7862400,10454400,13132800,&
        15724800,18403200,21081600,23673600,26352000,28944000,31622400/)
        integer :: values(8),m,sec
        call date_and_time(values=values)
        if(ccm_start_time(1) .eq. -1)ccm_start_time=values
        if(mod(values(1),4) .eq. 0)then
           m=leap(values(2))
        else
           m=norm(values(2))
        endif
        sec=((values(3)*24+values(5))*60+values(6))*60+values(7)
        tmp=real(m,b8)+real(sec,b8)+real(values(8),b8)/1000.0_b8
        if(values(1) .ne. ccm_start_time(1))then
            if(mod(ccm_start_time(1),4) .eq. 0)then
                tmp=tmp+real(leap(13),b8)
            else
                tmp=tmp+real(norm(13),b8)
            endif
        endif
        ccm_time=tmp
    end function
end module ccm_time_mod
module special
    contains
    function j1(x)
        use numz
        implicit none
        real(b4) j1,x
        integer n
        real(b4) bjn,by,bin,bk
        n=1
        call besse(x,bjn,by,bin,bk,n)
        j1=bjn
    end function
    function h0(x)
        use numz
        implicit none
        complex(b4) h0,j
        real(b4) x
        integer n
        real(b4) bjn,by,bin,bk
        j=cmplx(0,1)
        n=0
        call besse(x,bjn,by,bin,bk,n)
        h0=bjn-j*by
    end function
    function h1(x)
        use numz
        implicit none
        complex(b4) h1,j
        real(b4) x
        integer n
        real(b4) bjn,by,bin,bk
        j=cmplx(0,1)
        n=1
        call besse(x,bjn,by,bin,bk,n)
        h1=bjn-j*by
    end function

    subroutine besse (x, bjn, by, bin, bk,nord)
    use numz
    implicit none
    real(b4) x, bjn, by, bin, bk
    integer nord
    logical finished, done_wron,done
    real(b4) an, ai, ak, fn, gam, t, s, xa, c, d, phi
    real(b4) pn, qn, u, den, xb, pi, bi, xi
    real(b4) bj0, by0, bi0, bk0, bk1, by1, p
    integer k, n, m, i
    pi = 3.14159265358979323846_b4
    gam =0.57721566490153286060_b4
    fn = nord
!   x=x4
    if ((x - fn - 6.0) .lt. 0.0) then
    xa = x / 2.0
    xb = (xa)**2
    n = 0
! beginning of j_n_i_n_1
    call jnin(an,n,t,s,xa,bjn,bin,done,k,den,xb)
    finished = .false.
 300    if((n .le. 1) .and. (.not. finished))then
    if (n .eq. 0) then
    by = 2.0 / pi * (gam + log(xa)) * bjn
    bk = -(gam + log(xa)) * bin
    t = xb
    s = 1.0
    xi = 1.0
    k = 2
    ak = k
 200    if((by + t * xi - by) .ne. 0.0)then
    bk = bk + t * xi
    by = by + 2.0 / pi * s * t * xi
    t = t * xb / (ak * ak)
    xi = xi + 1.0 / ak
    s = -s
    k = k + 1
    ak = k
    goto 200
        endif
    if (nord .gt. 0) then
    n = 1
    bj0 = bjn
    bi0 = bin
    by0 = by
    bk0 = bk
    call jnin(an,n,t,s,xa,bjn,bin,done,k,den,xb)
    else
        finished = .true.
    endif
    elseif (n .eq. 1) then
    by = (bjn * by0 - 2.0 / (pi * x)) / bj0
    bk = (1.0 / x - bin * bk0) / bi0
    p = 1
    if (nord .gt. 1) then
    done_wron = .false.
 100    if(.not. done_wron)then
    by1 = by
    bk1 = bk
    by = 2.0 * p / x * by1 - by0
    bk = 2.0 * p / x * bk1 + bk0
    p = p + 1
    if (nord .gt. 2) then
    by0 = by1
    bk0 = bk1
    nord = nord - 1
    else
    done_wron = .true.
    endif
    goto 100
    endif
    n = nint(p)
    call jnin(an,n,t,s,xa,bjn,bin,done,k,den,xb)
    else
        finished = .true.
    endif
        else
    finished = .true.
    endif
    goto 300
    endif
    else
! beginning of   asymptot
    c = 4 * nord * nord
    d = 8.0 * x
    an = nord
    phi = x - ((2.0 * an + 1.0) / 4.0) * pi
    m = int(x + 1 + sqrt(x * x + an * an))
    t = (c - 1.0) / d
    s = 1.0
    u = 1.0
    pn = 1.0
    qn = t
    bk = 1.0 + t
    bi = 1.0 - t
    i = 2
 1  continue
    ai = i
    t = (c - (2.0 * ai - 1.0)**2) / d * t / ai
    bk = bk + t
    bi = bi + t * s
    if (s .gt. 0.0) then
    pn = pn - t * s * u
    u = -u
    else
    qn = qn - t * s * u
    endif
    s = -s
    i = i + 1
    if((i.gt.m) .or. (((qn + t) - qn).eq.0.0))goto 2
    goto 1
 2  continue
    bk = exp(-x) * bk * sqrt(pi / (2.0 * x))
    if ((x - fn - 6.0) .ge. 0.0) then
    bjn = (pn * cos(phi) - qn * sin(phi)) * sqrt(2.0 / (pi * x))
    by = (pn * sin(phi) + qn * cos(phi)) * sqrt(2.0 / (pi * x))
    if(x.lt.75.9853)then
    bin = exp(x) * bi / sqrt(2.0 * pi * x)
    else
    bin=1e33
    endif
    endif
! end of   asymptot
    endif
    nord = nint(fn)
    return
    end subroutine
    subroutine jnin(an,n,t,s,xa,bjn,bin,done,k,den,xb)
    use numz
    implicit none
    real(b4) bjn,bin
!   integer nord
!   logical finished, done_wron
    logical done
    real(b4) an, t, s, xa
!   real(b4) pn, qn,pi, bi,c, d, ak, fn,u,bk,by,phi,gam
    real(b4) den, xb
!   real(b4) bj0, by0, bi0, bk0, bk1, by1, p,xi,x,ai,w
    integer k, n
!   integer m, i
    an = n
    t = 1.0
    s = -1.0
 101    if(an .gt. 0.0)then
    t = t * xa / an
    an = an - 1
    goto 101
    endif
    bjn = t
    bin = t
    done = .false.
    k = 1
 201    continue
    den = k * (k + n)
    t = t * xb / den
    if (((bjn + t) - bjn ).ne. 0.0) then
    bjn = bjn + t * s
    bin = bin + t
    s = -s
    k = k + 1
    else
    done = .true.
    endif
    if(done)goto 301
    goto 201
 301    continue
    return
    end subroutine
end module

!###########################################################
program rcs
    use numz
    use maxsize
    use ccm_time_mod
    use special
    implicit none
    external cgesv
    integer n,m,nbox
    real(b8) it1,it2,ts,tend,ttot,tgen
    complex(b4) c(nmax,nmax),i,eps(nmax),j,ei(nmax),e(nmax),es
!   real(b4) zero
    real(b4) k,lambda,pi,x(nmax),y(nmax),a(nmax),r,rhon,xin,yin
    real(b4) ang1
    real(b4) theta1,theta2,theta,thetas,xs,ys,dx,dy
    real(b4) thetamin,thetamax
    real(b4) ereal,eimag
! start stuff for mkl library
    integer nrhs, ipiv(nmax),lda,ldb,info
! end stuff for mkl library
    complex(b4) b(nmax,1)
    complex(b4) cn
    character(len=10) :: method
    ts=ccm_time()
    pi = 3.14159265358979323846_b4
    j=cmplx(0,1)
    i=j
    open(8,file='wing.dat',status='old')
    open(12,file='source.dat',status='old')
    open(10,file='out.dat',status='unknown')
!   open(11,file='scat.dat',status='new')
!   open(file="scat.dat",access="stream",unit=11,form="unformatted")
    read(12,*)method
    read(12,*)lambda
    ys=3000.0_b4
    xs=-250.0_b4
!   read(12,*)xs,ys
    read(12,*)theta1,theta2
    k=2.0_b4*pi/lambda
    do nbox=1,nmax
      read(8,*,end=200)x(nbox),y(nbox),a(nbox),ereal,eimag
      eps(nbox)=cmplx(ereal,eimag)
      a(nbox)=a(nbox)*2.0_b4/sqrt(pi)
!     write(*,*)x(nbox),y(nbox),a(nbox),eps(nbox)
    enddo
 200 nbox=nbox-1
    do n=1,nbox
    	do m=n+1,nbox
    		r=sqrt( ( x(m)-x(n) )**2+( y(m)-y(n) )**2)
            if(r .le. 1e-4)then
                write(*,*)"points overlap",n,m
                stop
            endif
    		c(m,n)=h0(k*r)
    		c(n,m)=c(m,n)
    	enddo
    enddo
    do n=1,nbox
    	c(n,n)=(j/2.0_b4)*(pi*k*a(n)*h1(k*a(n))-2.0_b4*j)
    enddo
    do  n=1,nbox
        cn=(j*pi*k*a(n)/2.0_b4)*(eps(n)-1.0_b4)*j1(k*a(n))
        do  m=1,nbox
            if(n.eq.m)then
                c(n,n)=1.0_b4+(eps(n)-1.0_b4)*c(n,n)
            else
                c(m,n)=c(m,n)*cn
            endif
        enddo
    enddo
!    do  n=1,nbox
!        cn=(j*pi*k*a(n)/2.0_b4)*(eps(n)-1.0_b4)*j1(k*a(n))
!        do  m=1,nbox
!        if(n.eq.m)then
!            c(n,n)=1.0_b4+(eps(n)-1.0_b4)*(j/2.0_b4)*(pi*k*a(n)*h1(k*a(n))-2.0_b4*j)
!        else
!            r=sqrt( ( x(m)-x(n) )**2+( y(m)-y(n) )**2)
!            if(r .le. 1e-4)then
!                write(*,*)"points overlap",n,m
!                stop
!            endif
!            c(m,n)=cn*h0(k*r)
!        endif
!        enddo
!    enddo
    it1=ccm_time()
    tgen=it1-ts
    write(*,*)' matrix generated',tgen," of size ",nbox
! calculate the source field
    theta1=theta1*pi/180.0_b4
    theta2=theta2*pi/180.0_b4
    thetas=atan2(ys,xs)
    thetamin=thetas-theta1
    thetamax=theta2+thetas
    if(thetamax .lt. thetamin)then
        thetamax=thetas-theta1
        thetamin=theta2+thetas
    endif
!   write(*,*)"beam=",thetamin*180.0_b4/pi,thetas*180_b4/pi,thetamax*180.0_b4/pi
    write(*,*)"beam=",thetamin*180.0_b4/pi,thetas*180.0_b4/pi,thetamax*180.0_b4/pi
    do  m=1,nbox
        dx=(xs-x(m))
        dy=(ys-y(m))
        theta=atan2(dy,dx)
        if((theta.ge.thetamin).and.(theta.le.thetamax))then
            r=sqrt(dx*dx+dy*dy)
            ei(m)=exp(j*k*r)
        else
            ei(m)=0.0_b4
        endif
!       write(*,*)' theta=',theta*180.0/pi,ei(m),m
    enddo
    it1=ccm_time()
    method=adjustl(method)
    select case (method)
      case ("cgesv")
! start stuff for mkl library
        nrhs=1
        lda=nmax
        ldb=nmax
        info=0
        b(:,1)=ei
        call cgesv( nbox, nrhs, c, lda, ipiv, b, ldb, info )
        e=b(:,1)
        if( info.gt.0 ) then
         write(*,*)'the diagonal element of the triangular factor of c,'
         write(*,*)'u(',info,',',info,') is zero, so that'
         write(*,*)'c is singular; the solution could not be computed.'
         stop
        end if
      case ("invert")
        call invert(c,nbox)
        call backsub(c,ei,e,nbox)
    end select
    it2=ccm_time()
    it2=it2-it1
    write(*,*)nbox,' did solve',it2,"    using :",method
!   do  n=1,nbox
!       write(11,"(3g20.10)")e(n),cabs(e(n))
!   enddo
 16 format(i4,",",g20.10)
    do m=0,359
        ang1=m
        ang1=ang1*pi/180.0_b4
        xin=1000.0_b8*cos(ang1)
        yin=1000.0_b8*sin(ang1)
        es=cmplx(0,0)
        do n=1,nbox
            rhon=sqrt((xin-x(n))**2+(yin-y(n))**2)
            es=es+(eps(n)-1.0_b4)*e(n)*a(n)*j1(k*a(n))*h0(k*rhon)
        enddo
        es=-es*pi*k*j/2.0_b4
!       write(*,"(4g20.10)")xin,yin,es
!       write(10,16)m,20.0_b4*log10(abs(es)/0.001_b4)
        write(10,'(g13.5,2x,g20.10)')ang1,20.0_b4*log10(abs(es)/0.001_b4)
!       write(11)abs(es)
    enddo
    tend=ccm_time()
    ttot=tend-ts
    write(*,*)'matrix generation time',tgen
    write(*,*)'matrix solve time ',it2
    write(*,*)'total computaion time ',ttot
end program
    subroutine backsub(a,b,c,m)
        use numz
        use maxsize
        implicit none
        integer m,n,i,k
        complex(b4) a(nmax,nmax),b(nmax),c(nmax)
        n=m
        do  i=1,m
          c(i)=0.0_b4
          do  k=1,n
            c(i)=c(i)+a(i,k)*b(k)
          enddo
        enddo
        return
    end subroutine
    subroutine invert (matrix,size)
    use numz
    use maxsize
    implicit none
    integer switch,k, jj, kp1, i, j, l, krow, irow,size
    dimension switch(nmax,2)
    complex(b4) matrix(nmax,nmax)
    complex(b4) pivot, temp
    do 100 k = 1,size
    jj = k
        if (k .ne. size) then
        kp1 = k + 1
        pivot = (matrix(k, k))
        do 1 i = kp1,size
        temp = (matrix(i, k))
        if (abs(pivot) .lt. abs(temp)) then
        pivot = temp
        jj = i
        endif
 1  continue
        endif
    switch(k, 1) = k
    switch(k, 2) = jj
    if (jj .ne. k) then
        do 2  j = 1 ,size
    temp = matrix(jj, j)
    matrix(jj, j) = matrix(k, j)
    matrix(k, j) = temp
 2  continue
    endif
    do 3 j = 1,size
    if (j .ne. k)matrix(k, j) = matrix(k, j) / matrix(k, k)
 3  continue
    matrix(k, k) = 1.0 / matrix(k, k)
    do 4 i = 1,size
    if (i.ne.k) then
    do 40 j = 1,size
    if(j.ne.k)matrix(i,j)=matrix(i,j)-matrix(k,j)*matrix(i,k)
 40 continue
    endif
 4  continue
    do 5 i = 1, size
    if (i .ne. k)matrix(i, k) = -matrix(i, k) * matrix(k, k)
 5  continue
 100    continue
    do 6 l = 1,size
    k = size - l + 1
    krow = switch(k, 1)
    irow = switch(k, 2)
    if (krow .ne. irow) then
    do 60 i = 1,size
    temp = matrix(i, krow)
    matrix(i, krow) = matrix(i, irow)
    matrix(i, irow) = temp
 60 continue
    endif
 6  continue
    return
    end


program problem14
  implicit none
  integer, parameter :: limit=1000000,stack_limit=100000000,cache_limit=100000000
  integer*8          :: i,temp,best,longest=-1
  integer*8, allocatable, dimension(:) :: cache,stack

  allocate(stack(stack_limit))
  allocate(cache(cache_limit))
  forall (i=1:cache_limit) cache(i)=-1
  cache(1)=1

  do i=1,limit
     temp=collatz(i)
     if (temp > longest) then
        longest=temp
        best=i
     end if
  end do

  print *, best

  deallocate(cache)
  deallocate(stack)

contains
  function collatz(starting_n)
    implicit none
    integer*8, intent(in) :: starting_n
    integer*8             :: sp,n,collatz

    n=starting_n

    do sp=1,stack_limit ! wind stack
       stack(sp)=n
       if (n <= cache_limit) then ! cannot assume short-circuit evaluation of conditional
          if (cache(n) > -1) then ! found cached value
             collatz=cache(n)-1
             go to 1
          end if
       end if
       if (mod(n,2) == 0) then    ! uncached even value
          n=n/2
       else                       ! uncached odd value
          n=3*n+1
       end if
    end do
    error stop 'stack limit exceeded'

1   do sp=sp,1,-1 ! unwind stack
       n=stack(sp)
       collatz=collatz+1
       if (n <= cache_limit) then
          cache(n)=collatz
       end if
    end do

  end function collatz

end program problem14


program fd2d

    use finiteDifference2d

    implicit none

    real(4)         :: simTime, cpuStart, cpuFinish
    type(dim3)      :: gridSp, blockSp
    type(cudaEvent) :: startEvent, stopEvent
    !! cuda events to measure timings

    call box_init('der2d.nml')
    call get_block_size()

    call cuda_check_stat(cudaEventCreate(startEvent))
    call cuda_check_stat(cudaEventCreate(stopEvent))
    !! create cuda_events

    call allocate_arrays()
    call initial_condition()
    call set_factors()

    blockSp   = dim3(blockSize(1),blockSize(2),1)
    gridSp    = dim3(nGrid/blockSp%x,nGrid/blockSp%y,1)

    call cuda_check_stat(cudaEventRecord(startEvent,0))
    do itime = 0, numIterations
        call divergence_mod<<<gridSp, blockSp>>>(nGrid)
    end do
    call cuda_check_stat(cudaEventRecord(stopEvent,0))
    call cuda_check_stat(cudaEventSynchronize(stopEvent))
    call cuda_check_stat(cudaEventElapsedTime(simTime,startEvent,stopEvent))
    du = du_d
    write(*,*) 'mod            :', blockSp, simTime, maxval(du_exact-du)

end program fd2d


!

module funsignedwrapper
  use iso_fortran_env
  implicit none

  integer(int8)  , parameter:: max8bitsignedin8bit  =                     127
  integer(int16) , parameter:: max8bitsignedin16bit =                     127
  integer(int32) , parameter:: max8bitsignedin32bit =                     127
  integer(int64) , parameter:: max8bitsignedin64bit =                     127

  integer(int16) , parameter:: max8bitunsignedin16bit =                   255
  integer(int32) , parameter:: max8bitunsignedin32bit =                   255
  integer(int64) , parameter:: max8bitunsignedin64bit =                   255

  integer(int8)  , parameter:: min8bitsignedin8bit  =                    -128
  integer(int16) , parameter:: min8bitsignedin16bit =                    -128
  integer(int32) , parameter:: min8bitsignedin32bit =                    -128
  integer(int64) , parameter:: min8bitsignedin64bit =                    -128

  integer(int16) , parameter:: max16bitsignedin16bit  =                 32767
  integer(int32) , parameter:: max16bitsignedin32bit  =                 32767
  integer(int64) , parameter:: max16bitsignedin64bit  =                 32767

  integer(int32) , parameter:: max16bitunsignedin32bit =                65535
  integer(int64) , parameter:: max16bitunsignedin64bit =                65535

  integer(int16) , parameter:: min16bitsignedin16bit   =               -32768
  integer(int32) , parameter:: min16bitsignedin32bit   =               -32768
  integer(int64) , parameter:: min16bitsignedin64bit   =               -32768

  integer(int32) , parameter:: max32bitsignedin32bit   =           2147483647
  integer(int64) , parameter:: max32bitsignedin64bit   =           2147483647

  integer(int64) , parameter:: max32bitunsignedin64bit =           4294967295_int64

  integer(int32) , parameter:: min32bitsignedin32bit   =          -2147483647-1
  integer(int64) , parameter:: min32bitsignedin64bit   =          -2147483648_int64

  integer(int64) , parameter:: max64bitsignedin64bit   =  9223372036854775807_int64

  ! Hack: At least gfortran can not handle the  literal 9223372036854775808 and thus also
  ! not - 9223372036854775808, althogh the value is a valid int64 value
  integer(int64) , parameter:: min64bitsignedin64bit   = -9223372036854775807_int64-1_int64

  contains

    integer(int8) function int16_to_uint8(in)
      integer(int16) :: in
      integer(int16) :: working_copy
      working_copy = int( mod(in, 256_int16) , kind =int16)
      if (working_copy .lt. 128_int16) then
         int16_to_uint8 = int(working_copy, kind=int8 )
      else
         int16_to_uint8 = int(-256_int16+working_copy, kind=int8 )
      endif
    end function int16_to_uint8

    integer(int8) function int32_to_uint8(in)
      integer(int32) :: in
      integer(int32) :: working_copy
      working_copy = int( mod(in, 256_int32) , kind =int32)
      if (working_copy .lt. 128_int32) then
         int32_to_uint8 = int(working_copy, kind=int8 )
      else
         int32_to_uint8 = int(-256_int32+working_copy, kind=int8 )
      endif
    end function int32_to_uint8

    integer(int8) function int64_to_uint8(in)
      integer(int64) :: in
      integer(int64) :: working_copy
      working_copy = int( mod(in, 256_int64) , kind =int64)
      if (working_copy .lt. 128_int64) then
         int64_to_uint8 = int(working_copy, kind=int8 )
      else
         int64_to_uint8 = int(-256_int64+working_copy, kind=int8 )
      endif
    end function int64_to_uint8

    integer(int16) function int32_to_uint16(in)
      integer(int32) :: in
      integer(int32) :: working_copy
      working_copy = int( mod(in, 65536_int32) , kind =int32)
      if (working_copy .lt. 32768_int32) then
         int32_to_uint16 = int(working_copy, kind=int16 )
      else
         int32_to_uint16 = int(-65536_int32+working_copy, kind=int16 )
      endif
    end function int32_to_uint16

    integer(int16) function int64_to_uint16(in)
      integer(int64) :: in
      integer(int64) :: working_copy
      working_copy = int( mod(in, 65536_int64) , kind =int64)
      if (working_copy .lt. 32768_int64) then
         int64_to_uint16 = int(working_copy, kind=int16 )
      else
         int64_to_uint16 = int(-65536_int64+working_copy, kind=int16 )
      endif
    end function int64_to_uint16

    integer(int32) function int64_to_uint32(in)
      integer(int64) :: in
      integer(int64) :: working_copy
      working_copy = int( mod(in, 4294967296_int64) , kind =int64)
      if (working_copy .lt. 2147483648_int64) then
         int64_to_uint32 = int(working_copy, kind=int32 )
      else
         int64_to_uint32 = int(-4294967296_int64+working_copy, kind=int32 )
      endif
    end function int64_to_uint32

    integer(int16) function uint8_to_int16(in)
      integer(int8) :: in
      if (in .ge. 0) then
         uint8_to_int16 = int(in, kind = int16)
      else
         uint8_to_int16 = 256_int16 + int(in, kind = int16)
      endif
    end function uint8_to_int16

    integer(int32) function uint8_to_int32(in)
      integer(int8) :: in
      if (in .ge. 0) then
         uint8_to_int32 = int(in, kind = int32)
      else
         uint8_to_int32 = 256_int16 + int(in, kind = int32)
      endif
    end function uint8_to_int32

    integer(int64) function uint8_to_int64(in)
      integer(int8) :: in
      if (in .ge. 0) then
         uint8_to_int64 = int(in, kind = int64)
      else
         uint8_to_int64 = 256_int16 + int(in, kind = int64)
      endif
    end function uint8_to_int64

    integer(int32) function uint16_to_int32(in)
      integer(int16) :: in
      if (in .ge. 0) then
         uint16_to_int32 = int(in, kind = int32)
      else
         uint16_to_int32 = 65536_int32 + int(in, kind = int32)
      endif
    end function uint16_to_int32

    integer(int64) function uint16_to_int64(in)
      integer(int16) :: in
      if (in .ge. 0) then
         uint16_to_int64 = int(in, kind = int64)
      else
         uint16_to_int64 = 65536_int64 + int(in, kind = int64)
      endif
    end function uint16_to_int64

    integer(int64) function uint32_to_int64(in)
      integer(int32) :: in
      if (in .ge. 0) then
         uint32_to_int64 = int(in, kind = int64)
      else
         uint32_to_int64 = 4294967296_int64 + int(in, kind = int64)
      endif
    end function uint32_to_int64

end module funsignedwrapper


c
c     file tcud3.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... author and specialist
c
c          John C. Adams (National Center for Atmospheric Research)
c          email: johnad@ucar.edu, phone: 303-497-1213

c ... For MUDPACK 5.0 information, visit the website:
c     (http://www.scd.ucar.edu/css/software/mudpack)
c
c
c ... purpose
c
c     test program for the MUDPACK solver cud3
c
c ... required MUDPACK files
c
c     cud3.f, cudcom.f, cud3ln.f, cud3pn.f
c
c
c *********************************************************
c *********************************************************
c
c     sample program/test driver for cud3
c
c **********************************************************
c **********************************************************
c
c
c     a sample program/test driver for cud3 is below. it can be
c     executed as an initial test.  the output is listed for the
c     test case described.
c
c     test the driver below by solving the complex nonseparable
c     linear elliptic pde
c
c          cmplx(y,z)*d(dp/dx)/dx + cmplx(x,z)*d(dp/dy)/dy +
c
c          cmplx(x,y)*d(dp/dz)/dz - cmplx(y+z,x+y)*pe(x,y,z)
c
c          = r(x,y,z)
c
c     on the box [0.5,1.0] x [0.5,1.0] x [0.0,1.0] with dirchlet
c     boundary conditions at the x and y boundaries and periodic
c     boundary conditions in the z direction.  use point relaxation
c     and choose a grid 33 by 33 by 97 grid.  use the exact solution
c
c          pe(x,y,z) = exp(x*y)*cmplx(cos(tpi*z),sin(tpi*z))
c
c     for testing (tpi = 8.0*atan(1.0)).
c
c
c ******************************************************
c     output (32 bit floating point arithmetic)
c *******************************************************
c
c     cud3 test
c
c     input arguments
c     intl =  0 nxa =  1 nxb =  1 nyc =  1 nyd =  1
c     nze =  0 nzf =  0
c     ixp =  2 jyq =  2 kzr =  3
c     iex =  5 jey =  5 kez =  6
c     nx =  33 ny =  33 nz =  97 iguess =  0 maxcy =  1
c     method =  3 work space length input = 1940400
c     xa =  0.50 xb =  1.00
c     yc =  0.50 yd =  1.00
c     ze =  0.00 zf =  1.00
c     tolmax =  0.000e+00
c
c     multigrid options
c     kcycle =  2
c     iprer =  2
c     ipost =  1
c     intpol =  3
c
c     discretization call to cud3 intl =  0
c     ierror =  0 minimum work space = 1854498
c
c     approximation call to cud3
c     intl =  1 method =  3 iguess =  0 maxcy =  1
c     ierror =  0
c     maximum error  =   0.361e-03
c
c ************************************************************
c     end of output
c ************************************************************
c
      program tcud3
      implicit none
c
c     set grid sizes with parameter statements
c
      integer iixp,jjyq,kkzr,iiex,jjey,kkez,llwork,nnx,nny,nnz
      parameter(iixp=2,jjyq=2,kkzr=3)
      parameter(iiex=5,jjey=5,kkez=6)
      parameter (nnx = iixp*2**(iiex-1)+1)
      parameter (nny = jjyq*2**(jjey-1)+1)
      parameter (nnz = kkzr*2**(kkez-1)+1)
c
c     set work space length estimate for method=3 (see cud3.d).
c     this will probably overestimate required space
c
      parameter (llwork = 16*(nnx+2)*(nny+2)*(nnz+2) )
c
c
c     dimension solution,right hand side, and work arrays
c
      complex phi(nnx,nny,nnz),rhs(nnx,nny,nnz),work(llwork)
      integer iprm(23),mgopt(4)
      real fprm(8)
c
c     put integer and floating point arguments names in contiguous
c     storeage labelling
c
      integer intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,
     +              kez,nx,ny,nz,iguess,maxcy,method,meth2,nwork,
     +              lwrkqd,itero
      common/itcud3/intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,
     +              kez,nx,ny,nz,iguess,maxcy,method,meth2,nwork,
     +              lwrkqd,itero

      real xa,xb,yc,yd,ze,zf,tolmax,relmax,tpi
      common/ftcud3/xa,xb,yc,yd,ze,zf,tolmax,relmax,tpi
      real dlx,dly,dlz,x,y,z,errm
      complex cxx,cyy,czz,cx,cy,cz,ce, pxx,pyy,pzz,px,py,pz,pe
      integer i,j,k,ierror
      equivalence(intl,iprm)
      equivalence(xa,fprm)
c
c     declare coefficient and boundary condition input subroutines external
c
      external cof,bndc
      tpi = 8.0*atan(1.0)
c
c     set for initial call
c
      intl = 0
c
c     set boundary condition flags
c
      nxa = 1
      nxb = 1
      nyc = 1
      nyd = 1
      nze = 0
      nzf = 0
c
c     set grid sizes from parameter statements
c
      ixp = iixp
      jyq = jjyq
      kzr = kkzr
      iex = iiex
      jey = jjey
      kez = kkez
      nx = nnx
      ny = nny
      nz = nnz
c
c     set for one multigrid cycles
c
      maxcy = 1
c
c     set work space length approximation from parameter statement
c
      nwork = llwork
c
c     set method of relaxation--line in the z direction
c
      method = 3
c
c     meth2 only used in planar relaxation--but set
c
      meth2 = 0
c
c     set full multigrid cycling by flagging no initial guess at the finest
c     grid level
c
      iguess = 0
c
c     set end points of solution region in (x,y,z) space
c
      xa = 0.5
      xb = 1.0
      yc = 0.5
      yd = 1.0
      ze = 0.0
      zf = 1.0
c
c     set default multigrid options
c
      mgopt(1) = 2
      mgopt(2) = 2
      mgopt(3) = 1
      mgopt(4) = 3
c
c     set mesh increments
c
      dlx = (xb-xa)/float(nx-1)
      dly = (yd-yc)/float(ny-1)
      dlz = (zf-ze)/float(nz-1)
c
c     set for no error control
c
      tolmax = 0.0
c
c     set right hand side in rhs and phi to zero
c
      do k=1,nz
	z = ze+(k-1)*dlz
	do j=1,ny
	  y = yc+float(j-1)*dly
	  do i=1,nx
	    x = xa+float(i-1)*dlx
	    call cof(x,y,z,cxx,cyy,czz,cx,cy,cz,ce)
	    call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	    rhs(i,j,k) = cxx*pxx+cyy*pyy+czz*pzz+cx*px+cy*py+cz*pz+ce*pe
	    phi(i,j,k) = (0.,0.)
	  end do
	end do
      end do
c
c     set specified values at x and y boundaries in phi
c
      x = xa
      do k=1,nz
	z = ze+(k-1)*dlz
	do j=1,ny
	  y = yc+float(j-1)*dly
	  call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	  phi(1,j,k) = pe
	end do
      end do
      x = xb
      do k=1,nz
	z = ze+(k-1)*dlz
	do j=1,ny
	  y = yc+float(j-1)*dly
	  call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	  phi(nx,j,k) = pe
	end do
      end do
      y = yc
      do k=1,nz
	z = ze+(k-1)*dlz
	do i=1,nx
	  x = xa+float(i-1)*dlx
	  call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	  phi(i,1,k) = pe
	end do
      end do
      y = yd
      do k=1,nz
	z = ze+(k-1)*dlz
	do i=1,nx
	  x = xa+float(i-1)*dlx
	  call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	  phi(i,ny,k) = pe
	end do
      end do
      write(6,50)
   50 format(//' cud3 test ')
c
c     print input arguments
c
      write(6,100)intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,kez,
     +            nx,ny,nz,iguess,maxcy,method,nwork,xa,xb,yc,yd,ze,zf,
     +            tolmax,mgopt(1),mgopt(2),mgopt(3),mgopt(4)
  100 format(/' input arguments ',
     +/'intl = ',i2,' nxa = ',i2,' nxb = ',i2,' nyc = ',i2,' nyd = ',i2,
     +/' nze = ',i2, ' nzf = ',i2,
     +/' ixp = ',i2,' jyq = ',i2,' kzr = ',i2,
     +/' iex = ',i2, ' jey = ',i2, ' kez = ',i2,
     +/' nx = ',i3,' ny = ',i3,' nz = ',i3, ' iguess = ',i2,
     +/' maxcy = ',i2,
     +/' method = ',i2, ' work space length input = ',i7,
     +/' xa = ',f5.2,' xb = ',f5.2,
     +/' yc = ',f5.2,' yd = ',f5.2,
     +/' ze = ',f5.2,' zf = ',f5.2,
     +/' tolmax = ' ,e10.3
     +//' multigrid options '
     +/' kcycle = ',i2
     +/' iprer = ',i2
     +/' ipost = ',i2
     +/' intpol = ',i2 )
c
c     discretize pde
c
      write(*,104) intl
  104 format(/' discretization call to cud3', ' intl = ', i2)
      call cud3(iprm,fprm,work,cof,bndc,rhs,phi,mgopt,ierror)
      write (*,105) ierror,iprm(22)
  105 format(' ierror = ',i2, ' minimum work space = ',i7)
      if (ierror.gt.0) call exit(0)
c
c     approximate pde
c
      intl = 1
      write(*,106) intl,method,iguess,maxcy
  106 format(/' approximation call to cud3 ',
     +/' intl = ',i2, ' method = ',i2,' iguess = ',i2, ' maxcy = ',i2)
      call cud3(iprm,fprm,work,cof,bndc,rhs,phi,mgopt,ierror)
      write (*,107) ierror
  107 format(' ierror = ',i2)
      if (ierror.gt.0) call exit(0)
c
c     compute and print maximum error
c
      call error(nx,ny,nz,phi,errm)
      write(*,108) errm
  108 format(' maximum error  =  ',e10.3)
      end

      subroutine error(nx,ny,nz,phi,errm)
c
c     compute the error in the estimate in phi
c
      implicit none
      integer nx,ny,nz
      complex phi(nx,ny,nz)
      real xa,xb,yc,yd,ze,zf,tolmax,relmax,errm,tpi
      common/ftcud3/xa,xb,yc,yd,ze,zf,tolmax,relmax,tpi
      real dlx,dly,dlz,x,y,z
      complex pxx,pyy,pzz,px,py,pz,pe
      integer i,j,k
      dlx = (xb-xa)/(nx-1)
      dly = (yd-yc)/(ny-1)
      dlz = (zf-ze)/(nz-1)
      errm = 0.0
      do k=1,nz
	z = ze+(k-1)*dlz
	do j=1,ny
	  y = yc+float(j-1)*dly
	  do i=1,nx
	    x = xa+float(i-1)*dlx
	    call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	    errm = amax1(errm,abs(phi(i,j,k)-pe))
	  end do
	end do
      end do
      return
      end

      subroutine cof(x,y,z,cxx,cyy,czz,cx,cy,cz,ce)
c
c     input pde coefficients at grid point (x,y,z) in the solution region
c     to subroutine cud3
c
      implicit none
      complex cxx,cyy,czz,cx,cy,cz,ce
      real x,y,z
      cxx = cmplx(y,z)
      cyy = cmplx(x,z)
      czz = cmplx(x,y)
      cx = (0.,0.)
      cy = cx
      cz = cz
      ce = -cmplx(y+z,x+z)
      return
      end

      subroutine bndc(kbdy,xory,yorz,alfa,gbdy)
c
c     dummy subroutine since no mixed derivative b.c.
c
      implicit none
      integer kbdy
      real xory,yorz
      complex alfa,gbdy
      return
      end

      subroutine exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
c
c     this subroutine is used to set an exact solution for testing cud3
c
      implicit none
      real x,y,z
      complex pxx,pyy,pzz,px,py,pz,pe
      real xa,xb,yc,yd,ze,zf,tolmax,relmax,tpi
      common/ftcud3/xa,xb,yc,yd,ze,zf,tolmax,relmax,tpi
      pe = exp(x*y)*cmplx(cos(tpi*z),sin(tpi*z))
      px = y*pe
      py = x*pe
      pz = tpi*exp(x*y)*cmplx(-sin(tpi*z),cos(tpi*z))
      pxx = y*y*pe
      pyy = x*x*pe
      pzz = -tpi*tpi*pe
      return
      end


! test_cgi.f90 --
!     Test program/example for the cgi_protocol module
!     The program will generate a table of function values:
!     sin(x), cos(x) or J0(x) (as the latter is not implemented
!     this will cause an error).
!     The program illustrates the use of the various routines
!     in the module and the use of the mode "output_no_header"
!
program test_cgi

    use cgi_protocol

    type(DICT_STRUCT), pointer :: dict => null() ! Initialisation is important!
    integer                    :: i
    integer                    :: luout
    integer                    :: steps
    real                       :: xmin
    real                       :: xmax
    character(len=20)          :: function
    character(len=20)          :: output

    real, dimension(:), allocatable :: x
    real, dimension(:), allocatable :: y

    !
    ! Get the CGI information. As we do not know the type of
    ! output yet (either an HTML page or a CSV file), we use
    ! output_no_header.
    !
    call cgi_begin( output_no_header, dict, luout )

    function = '?'
    xmin     = 0.0
    xmax     = 1.0
    steps    = 10
    call cgi_get( dict, "function", function )
    call cgi_get( dict, "minimum",  xmin     )
    call cgi_get( dict, "maximum",  xmax     )
    call cgi_get( dict, "steps",    steps    )

    call cgi_get( dict, "output",   output   )

    !
    ! Simple checks (could probably better be done via JavaScript in the
    ! page itself, but this is an illustration)
    !
    if ( function == '?' ) then
        call cgi_error( 'No function selected', 'error_message.html' )
    endif
    if ( abs(xmin) > 100.0 .or. abs(xmax) > 100.0 ) then
        call cgi_error( 'Minimum and maximum should be in the range -100 to 100', &
           'error_message.html' )
    endif
    if ( function == 'J0' ) then
        call cgi_error( 'Sorry, the Bessel function is not yet implemented', &
           'error_message.html' )
    endif

    !
    ! Actual processing
    !
    allocate( x(steps+1), y(steps+1) )

    x = (/ (xmin + i*(xmax-xmin)/steps, i=0,steps) /)
    if ( function == 'sin' ) then
        y = sin(x)
    endif
    if ( function == 'cos' ) then
        y = cos(x)
    endif

    !
    ! Write the HTML output or the CSV file
    !
    if ( output == 'html' ) then
        call cgi_header( output_html )
        write( luout, '(a)' ) ''
        write( luout, '(a)' ) '<title>Table</title>'
        write( luout, '(a)' ) ''
        write( luout, '(a)' ) '
'
        write( luout, '(a)' ) '
'
        write( luout, '(3a)' ) '   X	', trim(function), '(X)	'
        write( luout, '(a)' ) '
'

        do i = 0,steps
            write( luout, '(a)' ) '
'
            write( luout, '(a,f10.4,a,f10.4,a)' ) &
                '    ', x(i), '	', y(i), '	'
            write( luout, '(a)' ) '
'
        enddo
        write( luout, '(a)' ) '
'
        write( luout, '(a)' ) ''
        write( luout, '(a)' ) ''
    else
        call cgi_header( output_text )
        write( luout, '(2a)' ) 'X,', trim(function)

        do i = 0,steps
            write( luout, '(f10.4,a,f10.4)' ) x(i), ',', y(i)
        enddo
    endif

    !
    ! We are done
    !
    call cgi_end

end program


!*******************************************************************************
!  Copyright(C) 2001-2014 Intel Corporation. All Rights Reserved.
!  The source code contained  or  described herein and all documents related to
!  the source code ("Material") are owned by Intel Corporation or its suppliers
!  or licensors.  Title to the  Material remains with  Intel Corporation or its
!  suppliers and licensors. The Material contains trade secrets and proprietary
!  and  confidential  information of  Intel or its suppliers and licensors. The
!  Material  is  protected  by  worldwide  copyright  and trade secret laws and
!  treaty  provisions. No part of the Material may be used, copied, reproduced,
!  modified, published, uploaded, posted, transmitted, distributed or disclosed
!  in any way without Intel's prior express written permission.
!  No license  under any  patent, copyright, trade secret or other intellectual
!  property right is granted to or conferred upon you by disclosure or delivery
!  of the Materials,  either expressly, by implication, inducement, estoppel or
!  otherwise.  Any  license  under  such  intellectual property  rights must be
!  express and approved by Intel in writing.
!
!*******************************************************************************
!  Content:
!    SGEMM Example Program Text
!*******************************************************************************

      PROGRAM MKL_SGEMM_HC
      USE OMP_LIB
      USE MIC_LIB
      include 'mkl_blas.fi'

      INTEGER :: N = 5, NP, I, NARG, ERROR
      REAL, ALLOCATABLE, DIMENSION( :, : ) :: A, B, C
      CHARACTER(len=32) :: arg

      NARG = IARGC()

      IF (NARG .LT. 1) THEN
        CALL GETARG(0, arg)
        WRITE (*,*), 'Usage: ', TRIM(arg), ' <N>'
        WRITE (*,*)
      ELSE
        CALL GETARG(1, arg)
        READ(arg, '(I10)') N
      ENDIF

      IF (N .le. 0) THEN
        WRITE(*,*) 'Invalid matrix size'
        STOP
      ENDIF

      WRITE(*,*) 'Matrix dimension is being set to', N
      WRITE(*,*)

      ALLOCATE( A( N, N ), B( N, N ), C( N, N ), STAT=ERROR)

      IF (ERROR .ne. 0) THEN
        WRITE(*,*) 'Could not allocate matrix A, B or C'
        STOP
      ENDIF

      A = 1.0
      B = 2.0
      C = 0.0

      !DEC$ ATTRIBUTES OFFLOAD : MIC :: SGEMM
      !DEC$ OFFLOAD TARGET( MIC ) IN( N ), IN( A: LENGTH( N * N )), &
      !DEC$ IN( B: LENGTH( N * N )), INOUT( C: LENGTH( N * N ))
      CALL SGEMM( 'N', 'N', N, N, N, 1.0, A, N, B, N, 1.0, C, N )

      WRITE (*,*), 'Resulting matrix C:'
      IF (N .GT. 10) THEN
        WRITE(*,*) 'NOTE: C is too large, so print only its upper-left 10x10 block...'
        NP=10
      ELSE
        NP=N;
      ENDIF

      WRITE (*,*)

      DO I=1,NP
        WRITE(*,'(10(1X,F9.3))'), C(I,1:NP)
      ENDDO

      DEALLOCATE( A, B, C )
      END PROGRAM


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

! test of the various sort routines in the utilities module.
!
! things to add:
!  repeat the sorts (w/ different but reproducible data?) and time them
!  to get better statistics

program sort_test

use types_mod,         only : r8, digits12

use utilities_mod,     only : error_handler, E_MSG, E_ERR, initialize_utilities, finalize_utilities

use sort_mod,          only : sort, index_sort, insertion_sort, index_insertion_sort

use random_seq_mod,    only: random_seq_type, init_random_seq, random_gaussian

use mpi_utilities_mod, only : start_mpi_timer, read_mpi_timer

!> timer usage example:
!>
!>  real(digits12) :: base, time_elapsed
!>
!>  call start_mpi_timer(base)
!>  ! do stuff here
!>  time_elapsed = read_mpi_timer(base)

! buffer sizes
integer, parameter :: MAXSIZE = 20480
integer, parameter :: SMALLER =  4096
integer, parameter :: SMALLE1 =  2048
integer, parameter :: SMALLE2 =  1024
integer, parameter :: TINY    =    80

type(random_seq_type) :: seq

! fill arrays with gaussian distribution of numeric values
real(r8), parameter :: BASEVAL = 2500.0_r8
real(r8), parameter :: STDDEV  = 500.0_r8

real(r8) :: base_real_array(MAXSIZE)
integer  :: base_int_array(MAXSIZE)

! real and integer arrays of 'm' (maxsize), 's' (smaller)
! and 't' (tiny) for sorting and timing.
real(r8) :: mr_array1(MAXSIZE), mr_array2(MAXSIZE)
real(r8) :: sr_array1(SMALLER), sr_array2(SMALLER)
real(r8) :: sr1array1(SMALLE1), sr1array2(SMALLE1)
real(r8) :: sr2array1(SMALLE2), sr2array2(SMALLE2)
real(r8) :: tr_array1(TINY),    tr_array2(TINY)
integer  :: mi_array1(MAXSIZE), mi_array2(MAXSIZE)
integer  :: si_array1(SMALLER), si_array2(SMALLER)
integer  :: si1array1(SMALLE1), si1array2(SMALLE1)
integer  :: si2array1(SMALLE2), si2array2(SMALLE2)
integer  :: ti_array1(TINY),    ti_array2(TINY)

integer  :: i, itmp
real(r8) :: tmp
character(len=64) :: content_type

character(len=*), parameter :: routine = 'sort_test'

! start of executable code

call initialize_utilities('sort_test')

print *, 'sort test.  array sizes: '
print *, '  large  = ', MAXSIZE
print *, 'smaller  = ', SMALLER
print *, 'smaller1 = ', SMALLE1
print *, 'smaller2 = ', SMALLE2
print *, '   tiny  = ', TINY
print *, ''

! fill the base array with random values for sorting.

call init_random_seq(seq)

do i=1, MAXSIZE
   base_real_array(i) = random_gaussian(seq, BASEVAL, STDDEV)
enddo

base_int_array(:) = floor(base_real_array(:))

mr_array1(:) = base_real_array(:)
mi_array1(:) = floor(mr_array1(:))

sr_array1(:) = base_real_array(1:SMALLER)
si_array1(:) = floor(sr_array1(:))

sr1array1(:) = base_real_array(1:SMALLE1)
si1array1(:) = floor(sr1array1(:))

sr2array1(:) = base_real_array(1:SMALLE2)
si2array1(:) = floor(sr2array1(:))

tr_array1(:) = base_real_array(1:TINY)
ti_array1(:) = floor(tr_array1(:))

content_type = "random"

call do_each_real_type(mr_array1, MAXSIZE, content_type)
call do_each_real_type(sr_array1, SMALLER, content_type)
call do_each_real_type(sr1array1, SMALLE1, content_type)
call do_each_real_type(sr2array1, SMALLE2, content_type)
call do_each_real_type(tr_array1, TINY, content_type)

call do_each_int_type (mi_array1, MAXSIZE, content_type)
call do_each_int_type (si_array1, SMALLER, content_type)
call do_each_int_type (si1array1, SMALLE1, content_type)
call do_each_int_type (si2array1, SMALLE2, content_type)
call do_each_int_type (ti_array1, TINY, content_type)

content_type = "inverted"

mr_array1 = sort(base_real_array)
do i=1, MAXSIZE
   mr_array2(i) = mr_array1(MAXSIZE - i + 1)
enddo

mi_array2(:) = floor(mr_array2(:))

sr_array2(:) = mr_array2(1:SMALLER)
si_array2(:) = floor(sr_array2(:))

sr1array2(:) = mr_array2(1:SMALLE1)
si1array2(:) = floor(sr1array2(:))

sr2array2(:) = mr_array2(1:SMALLE2)
si2array2(:) = floor(sr2array2(:))

tr_array2(:) = mr_array2(1:TINY)
ti_array2(:) = floor(tr_array2(:))

call do_each_real_type(mr_array2, MAXSIZE, content_type)
call do_each_real_type(sr_array2, SMALLER, content_type)
call do_each_real_type(sr1array2, SMALLE1, content_type)
call do_each_real_type(sr2array2, SMALLE2, content_type)
call do_each_real_type(tr_array2, TINY, content_type)

call do_each_int_type (mi_array2, MAXSIZE, content_type)
call do_each_int_type (si_array2, SMALLER, content_type)
call do_each_int_type (si1array2, SMALLE1, content_type)
call do_each_int_type (si2array2, SMALLE2, content_type)
call do_each_int_type (ti_array2, TINY, content_type)

content_type = "almost sorted"

! almost sorted order arrays
mr_array2(:) = mr_array1(:)
mi_array2(:) = floor(mr_array2(:))

call reorder_pair(mr_array2, mi_array2)
call reorder_pair(sr_array2, si_array2)
call reorder_pair(sr1array2, si1array2)
call reorder_pair(sr2array2, si2array2)
call reorder_pair(tr_array2, ti_array2)

call do_each_real_type(mr_array2, MAXSIZE, content_type)
call do_each_real_type(sr_array2, SMALLER, content_type)
call do_each_real_type(sr1array2, SMALLE1, content_type)
call do_each_real_type(sr2array2, SMALLE2, content_type)
call do_each_real_type(tr_array2, TINY, content_type)

call do_each_int_type (mi_array2, MAXSIZE, content_type)
call do_each_int_type (si_array2, SMALLER, content_type)
call do_each_int_type (si1array2, SMALLE1, content_type)
call do_each_int_type (si2array2, SMALLE2, content_type)
call do_each_int_type (ti_array2, TINY, content_type)

write(*,*) 'end of test'

call finalize_utilities('sort_test')

!-------------------------------------------------------------------------------

contains

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------

! here is where templated functions would be nice.

subroutine do_each_real_type(array, asize, label)
 real(r8), intent(in) :: array(:)
 integer,  intent(in) :: asize
 character(len=*), intent(in) :: label

real(digits12) :: b, inc
real(r8) :: array1(asize), sorted1(asize)
integer :: indirect1(asize)

call start_mpi_timer(b)
sorted1 = sort(array)
inc = read_mpi_timer(b)
call print_time(inc, label, 'basic sort, real ', asize)
call validate(sorted1, asize)

call start_mpi_timer(b)
call index_sort(array, indirect1, asize)
inc = read_mpi_timer(b)
call print_time(inc, label, 'index sort, real ', asize)
call validate_indx(array, indirect1, asize)

array1 = array

call start_mpi_timer(b)
call insertion_sort(array1)
inc = read_mpi_timer(b)
call print_time(inc, label, 'insertion sort, real', asize)
call validate(array1, asize)

call start_mpi_timer(b)
call index_insertion_sort(array, indirect1, asize)
inc = read_mpi_timer(b)
call print_time(inc, label, 'index insertion sort, real', asize)
call validate_indx(array, indirect1, asize)

print *, ''

end subroutine do_each_real_type

!-------------------------------------------------------------------------------

subroutine do_each_int_type(array, asize, label)
 integer, intent(in) :: array(:)
 integer, intent(in) :: asize
 character(len=*), intent(in) :: label

real(digits12) :: b, inc
integer :: array1(asize), sorted1(asize)
integer :: indirect1(asize)

call start_mpi_timer(b)
sorted1 = sort(array)
inc = read_mpi_timer(b)
call print_time(inc, label, 'basic sort, integer', asize)
call ivalidate(sorted1, asize)

call start_mpi_timer(b)
call index_sort(array, indirect1, asize)
inc = read_mpi_timer(b)
call print_time(inc, label, 'index sort, integer', asize)
call ivalidate_indx(array, indirect1, asize)

array1 = array

call start_mpi_timer(b)
call insertion_sort(array1)
inc = read_mpi_timer(b)
call print_time(inc, label, 'insertion sort, integer', asize)
call ivalidate(array1, asize)

call start_mpi_timer(b)
call index_insertion_sort(array, indirect1, asize)
inc = read_mpi_timer(b)
call print_time(inc, label, 'index insertion sort, integer', asize)
call ivalidate_indx(array, indirect1, asize)

print *, ''

end subroutine do_each_int_type

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------

subroutine validate(thisarray, asize)
 real(r8), intent(in) :: thisarray(:)
 integer,  intent(in) :: asize

integer :: i

do i=2, asize
   if (thisarray(i-1) > thisarray(i)) then
      write(*, *) 'items not in order: ', i-1, thisarray(i-1), &
                  ' not less than or equal to ', i, thisarray(i)
   endif
enddo

end subroutine validate

!-------------------------------------------------------------------------------

subroutine validate_indx(thisarray, thisindx, asize)
 real(r8), intent(in) :: thisarray(:)
 integer,  intent(in) :: thisindx(:)
 integer,  intent(in) :: asize

integer :: i

do i=2, asize
   if (thisarray(thisindx(i-1)) > thisarray(thisindx(i))) then
      write(*, *) 'items not in order: ', i-1, thisindx(i-1), thisarray(thisindx(i-1)), &
                  ' not less than or equal to ', i, thisindx(i), thisarray(thisindx(i))
   endif
enddo

end subroutine validate_indx

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------

subroutine ivalidate(thisarray, asize)
 integer, intent(in) :: thisarray(:)
 integer, intent(in) :: asize

integer :: i

do i=2, asize
   if (thisarray(i-1) > thisarray(i)) then
      write(*, *) 'items not in order: ', i-1, thisarray(i-1), &
                  ' not less than or equal to ', i, thisarray(i)
   endif
enddo

end subroutine ivalidate

!-------------------------------------------------------------------------------

subroutine ivalidate_indx(thisarray, thisindx, asize)
 integer, intent(in) :: thisarray(:)
 integer, intent(in) :: thisindx(:)
 integer, intent(in) :: asize

integer :: i

do i=2, asize
   if (thisarray(thisindx(i-1)) > thisarray(thisindx(i))) then
      write(*, *) 'items not in order: ', i-1, thisindx(i-1), thisarray(thisindx(i-1)), &
                  ' not less than or equal to ', i, thisindx(i), thisarray(thisindx(i))
   endif
enddo

end subroutine ivalidate_indx

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------

! swap the values at about index N*1/3 with the value at about N*2/3

subroutine reorder_pair(rarray, iarray)
 real(r8), intent(inout) :: rarray(:)
 integer,  intent(inout) :: iarray(:)

integer :: j

real(r8) :: rtmp
integer  :: itmp

j = size(rarray) / 3

rtmp        = rarray(j)
rarray(j)   = rarray(j*2)
rarray(j*2) = rtmp

j = size(iarray) / 3

itmp        = iarray(j)
iarray(j)   = iarray(j*2)
iarray(j*2) = itmp

end subroutine reorder_pair

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------

subroutine print_time(timespan, label1, label2, asize)
 real(digits12),   intent(in) :: timespan
 character(len=*), intent(in) :: label1, label2
 integer,          intent(in) :: asize

real(digits12) :: mt, t

mt = timespan / 1000.0_digits12
t = timespan

write(*, '(A16,A32,I8,A,2(F22.5,A))') trim(label1), trim(label2)//' ', asize, ' items ', mt, ' msec total, ', t/real(asize,digits12), ' usec/item'

end subroutine print_time

!-------------------------------------------------------------------------------

end program sort_test


! { dg-do run }
!
! PR 40646: [F03] array-valued procedure pointer components
!
! Original test case by Charlie Sharpsteen <chuck@sharpsteen.net>
! Modified by Janus Weil <janus@gcc.gnu.org>

module bugTestMod
  implicit none
  procedure(returnMat), pointer :: pp2
contains
  function returnMat( a, b ) result( mat )
    integer:: a, b
    double precision, dimension(a,b):: mat
    mat = 1d0
  end function returnMat
end module bugTestMod

program bugTest
  use bugTestMod
  implicit none
  procedure(returnMat), pointer :: pp
  pp => returnMat
  if (sum(pp(2,2))/=4) call abort()
  pp2 => returnMat
  if (sum(pp2(3,2))/=6) call abort()
end program bugTest

! { dg-final { cleanup-modules "bugTestMod" } }


      module m_elliptic
      private
      public  PWSSSP
      contains
C***********************************************************************
      SUBROUTINE PWSSSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,
     >                   BDPS,BDPF,ELMBDA,F,IDIMF,PERTRB,IERROR,W)
      implicit none
      integer,intent(in) :: INTL
      real,intent(in) :: TS,TF
      integer,intent(in) :: M,MBDCND
      REAL,intent(in) :: BDTS(*),BDTF(*)
      real,intent(in) :: PS,PF
      integer,intent(in) :: N,NBDCND
      real,intent(in) :: BDPS(*),BDPF(*)
      real,intent(in) :: ELMBDA
      integer,intent(in) :: IDIMF
      REAL,intent(inout) :: F(IDIMF,*)
      real,intent(out) :: PERTRB
      integer,intent(out) :: IERROR
      REAL,intent(inout) :: W(*)
C***********************************************************************
C
C          VERSION  2  OCTOBER 1976  INCLUDING ERRATA  OCTOBER 1976
C
C         DOCUMENTATION FOR THIS PROGRAM IS GIVEN IN
C
C        EFFICIENT FORTRAN SUBPROGRAMS FOR THE SOLUTION OF
C            ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS
C
C                              BY
C
C          PAUL SWARZTRAUBER   AND  ROLAND SWEET
C
C             TECHNICAL NOTE TN/IA-109   JULY 1975
C
C       NATIONAL CENTER FOR ATMOSPHERIC RESEARCH  BOULDER,COLORADO 80307
C
C        WHICH IS SPONSORED BY THE NATIONAL SCIENCE FOUNDATION
C
C***********************************************************************
C
C
C
C     SUBROUTINE PWSSSP SOLVES A FINITE DIFFERENCE APPROXIMATION TO THE
C     HELMHOLTZ EQUATION IN SPHERICAL COORDINATES AND ON THE SURFACE OF
C     THE UNIT SPHERE (RADIUS OF 1)0
C
C          (1/SIN(THETA))(D/DTHETA)(SIN(THETA)(D/DTHETA)U)
C
C             + (1/SIN(THETA)**2)(D/DPHI)(D/DPHI)U
C
C             + LAMBDA*U = F(THETA,PHI)
C
C     WHERE THETA IS COLATITUDE AND PHI IS LONGITUDE.
C
C     THE ARGUMENTS ARE DEFINED AS0
C
C
C     * * * * * * * * * *     ON INPUT     * * * * * * * * * *
C
C     INTL
C       = 0  ON INITIAL ENTRY TO PWSSSP OR IF N,NBDCND,PS OR PF ARE
C            CHANGED  FROM A PREVIOUS CALL
C       = 1  IF PS,PF,N AND NBDCND ARE UNCHANGED FROM A PREVIOUS CALL
C
C       NOTE0  A CALL WITH INTL = 1 IS ABOUT 1 PERCENT FASTER THAN A
C              CALL WITH INTL = 0  .
C
C     TS,TF
C       THE RANGE OF THETA (COLATITUDE), I.E., TS .LE. THETA .LE. TF.
C       TS MUST BE LESS THAN TF.  TS AND TF ARE IN RADIANS.  A TS OF
C       ZERO CORRESPONDS TO THE NORTH POLE AND A TF OF PI CORRESPONDS TO
C       THE SOUTH POLE.
C
C     M
C       THE NUMBER OF PANELS INTO WHICH THE INTERVAL (TS,TF) IS
C       SUBDIVIDED.  HENCE, THERE WILL BE M+1 GRID POINTS IN THE
C       THETA-DIRECTION GIVEN BY THETA(I) = (I-1)DTHETA+TS FOR
C       I = 1,2,...,M+1, WHERE DTHETA = (TF-TS)/M IS THE PANEL WIDTH.
C
C     MBDCND
C       INDICATES THE TYPE OF BOUNDARY CONDITION AT THETA = TS AND
C       THETA = TF.
C
C       = 1  IF THE SOLUTION IS SPECIFIED AT THETA = TS AND THETA = TF.
C       = 2  IF THE SOLUTION IS SPECIFIED AT THETA = TS AND THE
C            DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C            SPECIFIED AT THETA = TF (SEE NOTE 2 BELOW).
C       = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C            SPECIFIED AT THETA = TS AND THETA = TF (SEE NOTES 1,2
C            BELOW).
C       = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C            SPECIFIED AT THETA = TS (SEE NOTE 1 BELOW) AND THE
C            SOLUTION IS SPECIFIED AT THETA = TF.
C       = 5  IF THE SOLUTION IS UNSPECIFIED AT THETA = TS = 0 AND THE
C            SOLUTION IS SPECIFIED AT THETA = TF.
C       = 6  IF THE SOLUTION IS UNSPECIFIED AT THETA = TS = 0 AND THE
C            DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C            SPECIFIED AT THETA = TF (SEE NOTE 2 BELOW).
C       = 7  IF THE SOLUTION IS SPECIFIED AT THETA = TS AND THE
C            SOLUTION IS UNSPECIFIED AT THETA = TF = PI.
C       = 8  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C            SPECIFIED AT THETA = TS (SEE NOTE 1 BELOW) AND THE
C            SOLUTION IS UNSPECIFIED AT THETA = TF = PI.
C       = 9  IF THE SOLUTION IS UNSPECIFIED AT THETA = TS = 0 AND
C            THETA = TF = PI.
C
C       NOTES0  1.  IF TS = 0, DO NOT USE MBDCND = 3,4, OR 8, BUT
C                   INSTEAD USE MBDCND = 5,6, OR 9  .
C               2.  IF TF = PI, DO NOT USE MBDCND = 2,3, OR 6, BUT
C                   INSTEAD USE MBDCND = 7,8, OR 9  .
C
C     BDTS
C       A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA AT
C       THETA = TS.  WHEN MBDCND = 3,4, OR 8,
C
C            BDTS(J) = (D/DTHETA)U(TS,PHI(J)), J = 1,2,...,N+1  .
C
C       WHEN MBDCND HAS ANY OTHER VALUE, BDTS IS A DUMMY VARIABLE.
C
C     BDTF
C       A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA AT
C       THETA = TF.  WHEN MBDCND = 2,3, OR 6,
C
C            BDTF(J) = (D/DTHETA)U(TF,PHI(J)), J = 1,2,...,N+1  .
C
C       WHEN MBDCND HAS ANY OTHER VALUE, BDTF IS A DUMMY VARIABLE.
C
C     PS,PF
C       THE RANGE OF PHI (LONGITUDE), I.E., PS .LE. PHI .LE. PF.  PS
C       MUST BE LESS THAN PF.  PS AND PF ARE IN RADIANS.  IF PS = 0 AND
C       PF = 2*PI, PERIODIC BOUNDARY CONDITIONS ARE USUALLY PRESCRIBED.
C
C     N
C       THE NUMBER OF PANELS INTO WHICH THE INTERVAL (PS,PF) IS
C       SUBDIVIDED.  HENCE, THERE WILL BE N+1 GRID POINTS IN THE
C       PHI-DIRECTION GIVEN BY PHI(J) = (J-1)DPHI+PS  FOR
C       J = 1,2,...,N+1, WHERE DPHI = (PF-PS)/N IS THE PANEL WIDTH.  N
C       MUST BE OF THE FORM (2**P)(3**Q)(5**R) WHERE P, Q, AND R ARE ANY
C       NON-NEGATIVE INTEGERS.  N MUST BE GREATER THAN 2  .
C
C     NBDCND
C       INDICATES THE TYPE OF BOUNDARY CONDITION AT PHI = PS AND
C       PHI = PF.
C
C       = 0  IF THE SOLUTION IS PERIODIC IN PHI, I.E.,
C            U(I,1) = U(I,N+1).
C       = 1  IF THE SOLUTION IS SPECIFIED AT PHI = PS AND PHI = PF
C            (SEE NOTE BELOW).
C       = 2  IF THE SOLUTION IS SPECIFIED AT PHI = PS (SEE NOTE BELOW)
C            AND THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO PHI IS
C            SPECIFIED AT PHI = PF.
C       = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO PHI IS
C            SPECIFIED AT PHI = PS AND PHI = PF.
C       = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO PHI IS
C            SPECIFIED AT PS AND THE SOLUTION IS SPECIFIED AT PHI = PF
C            (SEE NOTE BELOW).
C
C       NOTE0  NBDCND = 1,2, OR 4 CANNOT BE USED WITH
C              MBDCND = 5,6,7,8, OR 9 (THE FORMER INDICATES THAT THE
C                       SOLUTION IS SPECIFIED AT A POLE, THE LATTER
C                       INDICATES THAT THE SOLUTION IS UNSPECIFIED).
C                       USE INSTEAD
C              MBDCND = 1 OR 2  .
C
C     BDPS
C       A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO PHI AT
C       PHI = PS.  WHEN NBDCND = 3 OR 4,
C
C            BDPS(I) = (D/DPHI)U(THETA(I),PS), I = 1,2,...,M+1  .
C
C       WHEN NBDCND HAS ANY OTHER VALUE, BDPS IS A DUMMY VARIABLE.
C
C     BDPF
C       A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO PHI AT
C       PHI = PF.  WHEN NBDCND = 2 OR 3,
C
C            BDPF(I) = (D/DPHI)U(THETA(I),PF), I = 1,2,...,M+1  .
C
C       WHEN NBDCND HAS ANY OTHER VALUE, BDPF IS A DUMMY VARIABLE.
C
C     ELMBDA
C       THE CONSTANT LAMBDA IN THE HELMHOLTZ EQUATION.  IF
C       LAMBDA .GT. 0, A SOLUTION MAY NOT EXIST.  HOWEVER, PWSSSP WILL
C       ATTEMPT TO FIND A SOLUTION.
C
C     F
C       A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUE OF THE RIGHT
C       SIDE OF THE HELMHOLTZ EQUATION AND BOUNDARY VALUES (IF ANY).
C       FOR I = 2,3,...,M  AND  J = 2,3,...,N
C
C            F(I,J) = F(THETA(I),PHI(J)).
C
C       ON THE BOUNDARIES F IS DEFINED BY
C
C            MBDCND   F(1,J)            F(M+1,J)
C            ------   ------------      ------------
C
C              1      U(TS,PHI(J))      U(TF,PHI(J))
C              2      U(TS,PHI(J))      F(TF,PHI(J))
C              3      F(TS,PHI(J))      F(TF,PHI(J))
C              4      F(TS,PHI(J))      U(TF,PHI(J))
C              5      F(0,PS)           U(TF,PHI(J))   J = 1,2,...,N+1
C              6      F(0,PS)           F(TF,PHI(J))
C              7      U(TS,PHI(J))      F(PI,PS)
C              8      F(TS,PHI(J))      F(PI,PS)
C              9      F(0,PS)           F(PI,PS)
C
C            NBDCND   F(I,1)            F(I,N+1)
C            ------   --------------    --------------
C
C              0      F(THETA(I),PS)    F(THETA(I),PS)
C              1      U(THETA(I),PS)    U(THETA(I),PF)
C              2      U(THETA(I),PS)    F(THETA(I),PF)   I = 1,2,...,M+1
C              3      F(THETA(I),PS)    F(THETA(I),PF)
C              4      F(THETA(I),PS)    U(THETA(I),PF)
C
C       F MUST BE DIMENSIONED AT LEAST (M+1)*(N+1).
C
C       NOTE
C
C       IF THE TABLE CALLS FOR BOTH THE SOLUTION U AND THE RIGHT SIDE F
C       AT  A CORNER THEN THE SOLUTION MUST BE SPECIFIED.
C
C     IDIMF
C       THE ROW (OR FIRST) DIMENSION OF THE ARRAY F AS IT APPEARS IN THE
C       PROGRAM CALLING PWSSSP.  THIS PARAMETER IS USED TO SPECIFY THE
C       VARIABLE DIMENSION OF F.  IDIMF MUST BE AT LEAST M+1  .
C
C     W
C       A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C       WORK SPACE.  THE LENGTH OF W MUST BE AT LEAST 11(M+1)+6(N+1).
C
C
C
C     F
C       CONTAINS THE SOLUTION U(I,J) OF THE FINITE DIFFERENCE
C       APPROXIMATION FOR THE GRID POINT (THETA(I),PHI(J)),
C       I = 1,2,...,M+1,   J = 1,2,...,N+1  .
C
C     PERTRB
C       IF ONE SPECIFIES A COMBINATION OF PERIODIC, DERIVATIVE OR
C       UNSPECIFIED BOUNDARY CONDITIONS FOR A POISSON EQUATION
C       (LAMBDA = 0), A SOLUTION MAY NOT EXIST.  PERTRB IS A CONSTANT,
C       CALCULATED AND SUBTRACTED FROM F, WHICH ENSURES THAT A SOLUTION
C       EXISTS.  PWSSSP THEN COMPUTES THIS SOLUTION, WHICH IS A LEAST
C       SQUARES SOLUTION TO THE ORIGINAL APPROXIMATION.  THIS SOLUTION
C       IS NOT UNIQUE AND IS UNNORMALIZED. THE VALUE OF PERTRB SHOULD
C       BE SMALL COMPARED TO THE RIGHT SIDE F. OTHERWISE , A SOLUTION
C       IS OBTAINED TO AN ESSENTIALLY DIFFERENT PROBLEM. THIS COMPARISON
C       SHOULD ALWAYS BE MADE TO INSURE THAT A MEANINGFUL SOLUTION HAS
C       BEEN OBTAINED
C
C     IERROR
C       AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.  EXCEPT
C       FOR NUMBERS 0 AND 8, A SOLUTION IS NOT ATTEMPTED.
C
C       = 0  NO ERROR.
C       = 1  TS .LT. 0  OR  TF .GT. PI
C       = 2  TS .GE. TF.
C       = 3  MBDCND .LT. 1 OR MBDCND .GT. 9  .
C       = 4  PS .GE. PF.
C       = 5  N IS NOT OF THE FORM (2**P)(3**Q)(5**R) OR N .LE. 2  .
C       = 6  NBDCND .LT. 0 OR NBDCND .GT. 4  .
C       = 7  AN NBDCND OF 1,2, OR 4 IS USED WITH AN
C            MBDCND OF 5,6,7,8, OR 9  .
C       = 8  ELMBDA .GT. 0  .
C       = 9  IDIMF .LT. M+1  .
C       = 10 TS=0 AND MBDCND=3,4 OR 8  OR  TF=PI AND MBDCND=2,3 OR 6
C
C       SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY INCORRECT
C       CALL TO PWSSSP, THE USER SHOULD TEST IERROR AFTER A CALL.
C
C     W
C       CONTAINS INTERMEDIATE VALUES THAT MUST NOT BE DESTROYED IF
C       PWSSSP WILL BE CALLED AGAIN WITH INTL = 1  .
C
C
C
      integer :: NBR
      real :: PI
      integer,parameter :: KP=KIND(PI)
      real,external :: ELLIPTIC_APXEPS
      integer :: MP1,IW1,IW2,IW3,IW4,IW5,IW6
      real,save :: EPS
      real :: DUM
      NBR = NBDCND+1
      PI = 3.14159265358979
      PI = 4._KP*atan(1._KP)
      IF(INTL.EQ.0) EPS = ELLIPTIC_APXEPS(DUM)
      IERROR = 9
      IF (IDIMF-M) 119,119,101
  101 IERROR = 1
      IF (TS) 119,102,102
  102 IF (PI-TF+EPS) 119,119,103
  103 IERROR = 2
      IF (TF-TS) 119,119,104
  104 IERROR = 3
      IF (MBDCND) 119,119,105
  105 IF (MBDCND-9) 106,106,119
  106 IERROR = 4
      IF (PF-PS) 119,119,107
  107 IERROR = 5
CCCCC IF (NCHECK(N)-2) 108,119,108
  108 IERROR = 6
      IF (NBDCND) 119,109,109
  109 IF (NBDCND-4) 110,110,119
  110 IERROR = 7
      IF (MBDCND-4) 112,112,111
  111 GO TO (112,119,119,112,119),NBR
  112 IERROR = 8
      IF (ELMBDA) 113,113,118
  113 IERROR = 10
      IF (TS) 114,114,115
  114 GO TO (115,115,118,118,115,115,115,118,115),MBDCND
  115 IF (PI-TF-EPS) 116,116,117
  116 GO TO (117,118,118,117,117,118,117,117,117),MBDCND
  117 IERROR = 0
  118 MP1 = M+1
      IW1 = 6*(N+1)+5*MP1+1
      IW2 = IW1+MP1
      IW3 = IW2+MP1
      IW4 = IW3+MP1
      IW5 = IW4+MP1
      IW6 = IW5+MP1
      CALL PWSSS1 (INTL,TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS,
     1             BDPF,ELMBDA,F,IDIMF,PERTRB,W(IW1),W(IW2),W(IW3),
     2             W(IW4),W(IW5),W(IW6),W)
  119 CONTINUE
      call perr_pwsssp(IERROR,PI)
      RETURN
      contains
      subroutine perr_pwsssp(ier,PI)
      use m_die,only : perr
      use m_stdio,only : stderr
      implicit none
      integer,intent(in) :: ier
      real,intent(in) :: pi
      character(len=*),parameter :: myname='PWSSSP'

	select case(ier)
	case(0)

	case(1)
	  call perr(myname,'TS < 0 .OR. TF > PI')
	  write(stderr,*) myname,'(): TS,TF = ',TS,TF
	  write(stderr,*) myname,'(): PI,TF-PI = ',PI,TF-PI

	case(2)
	  call perr(myname,'TS >= TF')
	  write(stderr,*) myname,'(): TS,TF = ',TS,TF

	case(3)
	  call perr(myname,'MBDCND < 1 .OR. MBDCND > 9')
	  write(stderr,*) myname,'(): MBDCND = ',MBDCND

	case(4)
	  call perr(myname,'PS >= PF')
	  write(stderr,*) myname,'(): PS,PF =',PS,PF

	case(5)
	  call perr(myname,'N /= (2**P)(3**Q)(5**R) .OR. N <= 2')
	  write(stderr,*) myname,'(): N =',N

	case(6)
	  call perr(myname,'NBDCND < 0 .OR. NBDCND > 4')
	  write(stderr,*) myname,'(): NBDCND = ',NBDCND

	case(7)
	  call perr(myname,'NBDCND==1|2|4 .AND. MBDCND==[5-9]')
	  write(stderr,*) myname,'(): NBDCND,MBDCND = ',NBDCND,MBDCND

	case(8)
	  call perr(myname,'ELMBDA > 0')
	  write(stderr,*) myname,'(): ELMBDA = ',ELMBDA

	case(9)
	  call perr(myname,'IDIMF < M+1')
	  write(stderr,*) myname,'(): IDIMF,M =',IDIMF,M

	case(10)
	  call perr(myname,
     &	    'TS==0.AND.MBDCND==3|4|8  .OR.  TF==PI.AND.MBDCND==2|3|6')
	  write(stderr,*) myname,'(): TS,TF,MBDCND =',TS,TF,MBDCND

	case default
	  call perr(myname,'unknown IERROR code',ier)

	end select

      end subroutine perr_pwsssp
      END SUBROUTINE PWSSSP
      SUBROUTINE PWSSS1 (INTL,TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,
     1                   BDPS,BDPF,ELMBDA,F,IDIMF,PERTRB,AM,BM,CM,SN,
     2                   SS,SINT,D)
      implicit none
      integer,intent(in) :: INTL
      real,intent(in) :: TS,TF
      integer,intent(in) :: M,MBDCND
      REAL,intent(in) :: BDTS(*),BDTF(*)
      real,intent(in) :: PS,PF
      integer,intent(in) :: N,NBDCND
      real,intent(in) :: BDPS(*),BDPF(*)
      real,intent(in) :: ELMBDA
      integer,intent(in) :: IDIMF
      REAL,intent(inout) :: F(IDIMF,*)
      real,intent(out) :: PERTRB
      real,intent(inout) ::       AM(*)      ,BM(*)      ,CM(*)      ,
     2                SS(*)      ,SN(*)      ,D(*)       ,SINT(*)
C
C     MACHINE DEPENDENT CONSTANT
C
C     PI=3.1415926535897932384626433832795028841971693993751058209749446
C
      real :: PI
      integer,parameter :: KP=kind(PI)
      real :: TPI,HPI
      integer :: MP1,NP1
      real :: FN,FM,DTH,HDTH,TDT,DPHI,TDP,DPHI2,EDP2,DTH2,CP,WP
      real :: FIM1,THETA,T1
      integer :: MBR,INP,ISP,ITS,ITF,ITSP,ITFM,MUNK,IID,II,I
      integer :: NBR,JPS,JPF,JPSP,JPFM,NUNK,ISING,J,NBDC,JFN,JFRD,JBRD
      real :: AT,CT,WTS,WTF,WPS,WPF,FJJ,CF,SUM,SUM1,SUM2,HNE,YHLD,HLD
      real :: DFN,DNN,DSN,CNP,DFS,DSS,DNS,CSP,RTN,RTS,DEN
      integer :: IERROR

!!      PI = 3.14159265358979
      PI = 4._KP*atan(1._KP)
      TPI = PI+PI
      HPI = PI/2.
      MP1 = M+1
      NP1 = N+1
      FN = N
      FM = M
      DTH = (TF-TS)/FM
      HDTH = DTH/2.
      TDT = DTH+DTH
      DPHI = (PF-PS)/FN
      TDP = DPHI+DPHI
      DPHI2 = DPHI*DPHI
      EDP2 = ELMBDA*DPHI2
      DTH2 = DTH*DTH
      CP = 4./(FN*DTH2)
      WP = FN*SIN(HDTH)/4.
      DO 102 I=1,MP1
         FIM1 = I-1
         THETA = FIM1*DTH+TS
         SINT(I) = SIN(THETA)
         IF (SINT(I)) 101,102,101
  101    T1 = 1./(DTH2*SINT(I))
         AM(I) = T1*SIN(THETA-HDTH)
         CM(I) = T1*SIN(THETA+HDTH)
         BM(I) = -AM(I)-CM(I)+ELMBDA
  102 CONTINUE
      INP = 0
      ISP = 0
C
C BOUNDARY CONDITION AT THETA=TS
C
      MBR = MBDCND+1
      GO TO (103,104,104,105,105,106,106,104,105,106),MBR
  103 ITS = 1
      GO TO 107
  104 AT = AM(2)
      ITS = 2
      GO TO 107
  105 AT = AM(1)
      ITS = 1
      CM(1) = AM(1)+CM(1)
      GO TO 107
  106 AT = AM(2)
      INP = 1
      ITS = 2
C
C BOUNDARY CONDITION THETA=TF
C
  107 GO TO (108,109,110,110,109,109,110,111,111,111),MBR
  108 ITF = M
      GO TO 112
  109 CT = CM(M)
      ITF = M
      GO TO 112
  110 CT = CM(M+1)
      AM(M+1) = AM(M+1)+CM(M+1)
      ITF = M+1
      GO TO 112
  111 ITF = M
      ISP = 1
      CT = CM(M)
C
C COMPUTE HOMOGENEOUS SOLUTION WITH SOLUTION AT POLE EQUAL TO ONE
C
  112 ITSP = ITS+1
      ITFM = ITF-1
      WTS = SINT(ITS+1)*AM(ITS+1)/CM(ITS)
      WTF = SINT(ITF-1)*CM(ITF-1)/AM(ITF)
      MUNK = ITF-ITS+1
      IF (ISP) 116,116,113
  113 D(ITS) = CM(ITS)/BM(ITS)
      DO 114 I=ITSP,M
         D(I) = CM(I)/(BM(I)-AM(I)*D(I-1))
  114 CONTINUE
      SS(M) = -D(M)
      IID = M-ITS
      DO 115 II=1,IID
         I = M-II
         SS(I) = -D(I)*SS(I+1)
  115 CONTINUE
      SS(M+1) = 1.
  116 IF (INP) 120,120,117
  117 SN(1) = 1.
      D(ITF) = AM(ITF)/BM(ITF)
      IID = ITF-2
      DO 118 II=1,IID
         I = ITF-II
         D(I) = AM(I)/(BM(I)-CM(I)*D(I+1))
  118 CONTINUE
      SN(2) = -D(2)
      DO 119 I=3,ITF
         SN(I) = -D(I)*SN(I-1)
  119 CONTINUE
C
C BOUNDARY CONDITIONS AT PHI=PS
C
  120 NBR = NBDCND+1
      WPS = 1.
      WPF = 1.
      GO TO (121,122,122,123,123),NBR
  121 JPS = 1
      GO TO 124
  122 JPS = 2
      GO TO 124
  123 JPS = 1
      WPS = .5
C
C BOUNDARY CONDITION AT PHI=PF
C
  124 GO TO (125,126,127,127,126),NBR
  125 JPF = N
      GO TO 128
  126 JPF = N
      GO TO 128
  127 WPF = .5
      JPF = N+1
  128 JPSP = JPS+1
      JPFM = JPF-1
      NUNK = JPF-JPS+1
      FJJ = JPFM-JPSP+1
C
C SCALE COEFFICIENTS FOR SUBROUTINE POIS
C
      DO 129 I=ITS,ITF
         CF = DPHI2*SINT(I)*SINT(I)
         AM(I) = CF*AM(I)
         BM(I) = CF*BM(I)
         CM(I) = CF*CM(I)
  129 CONTINUE
      ISING = 0
      GO TO (130,138,138,130,138,138,130,138,130,130),MBR
  130 GO TO (131,138,138,131,138),NBR
  131 IF (ELMBDA) 138,132,132
  132 ISING = 1
      SUM = WTS*WPS+WTS*WPF+WTF*WPS+WTF*WPF
      IF (INP) 134,134,133
  133 SUM = SUM+WP
  134 IF (ISP) 136,136,135
  135 SUM = SUM+WP
  136 SUM1 = 0.
      DO 137 I=ITSP,ITFM
         SUM1 = SUM1+SINT(I)
  137 CONTINUE
      SUM = SUM+FJJ*(SUM1+WTS+WTF)
      SUM = SUM+(WPS+WPF)*SUM1
      HNE = SUM
  138 GO TO (146,142,142,144,144,139,139,142,144,139),MBR
  139 IF (NBDCND-3) 146,140,146
  140 YHLD = F(1,JPS)-4./(FN*DPHI*DTH2)*(BDPF(2)-BDPS(2))
      DO 141 J=1,NP1
         F(1,J) = YHLD
  141 CONTINUE
      GO TO 146
  142 DO 143 J=JPS,JPF
         F(2,J) = F(2,J)-AT*F(1,J)
  143 CONTINUE
      GO TO 146
  144 DO 145 J=JPS,JPF
         F(1,J) = F(1,J)+TDT*BDTS(J)*AT
  145 CONTINUE
  146 GO TO (154,150,152,152,150,150,152,147,147,147),MBR
  147 IF (NBDCND-3) 154,148,154
  148 YHLD = F(M+1,JPS)-4./(FN*DPHI*DTH2)*(BDPF(M)-BDPS(M))
      DO 149 J=1,NP1
         F(M+1,J) = YHLD
  149 CONTINUE
      GO TO 154
  150 DO 151 J=JPS,JPF
         F(M,J) = F(M,J)-CT*F(M+1,J)
  151 CONTINUE
      GO TO 154
  152 DO 153 J=JPS,JPF
         F(M+1,J) = F(M+1,J)-TDT*BDTF(J)*CT
  153 CONTINUE
  154 GO TO (159,155,155,157,157),NBR
  155 DO 156 I=ITS,ITF
         F(I,2) = F(I,2)-F(I,1)/(DPHI2*SINT(I)*SINT(I))
  156 CONTINUE
      GO TO 159
  157 DO 158 I=ITS,ITF
         F(I,1) = F(I,1)+TDP*BDPS(I)/(DPHI2*SINT(I)*SINT(I))
  158 CONTINUE
  159 GO TO (164,160,162,162,160),NBR
  160 DO 161 I=ITS,ITF
         F(I,N) = F(I,N)-F(I,N+1)/(DPHI2*SINT(I)*SINT(I))
  161 CONTINUE
      GO TO 164
  162 DO 163 I=ITS,ITF
         F(I,N+1) = F(I,N+1)-TDP*BDPF(I)/(DPHI2*SINT(I)*SINT(I))
  163 CONTINUE
  164 CONTINUE
      PERTRB = 0.
      IF (ISING) 165,176,165
  165 SUM = WTS*WPS*F(ITS,JPS)+WTS*WPF*F(ITS,JPF)+WTF*WPS*F(ITF,JPS)+
     1      WTF*WPF*F(ITF,JPF)
      IF (INP) 167,167,166
  166 SUM = SUM+WP*F(1,JPS)
  167 IF (ISP) 169,169,168
  168 SUM = SUM+WP*F(M+1,JPS)
  169 DO 171 I=ITSP,ITFM
         SUM1 = 0.
         DO 170 J=JPSP,JPFM
            SUM1 = SUM1+F(I,J)
  170    CONTINUE
         SUM = SUM+SINT(I)*SUM1
  171 CONTINUE
      SUM1 = 0.
      SUM2 = 0.
      DO 172 J=JPSP,JPFM
         SUM1 = SUM1+F(ITS,J)
         SUM2 = SUM2+F(ITF,J)
  172 CONTINUE
      SUM = SUM+WTS*SUM1+WTF*SUM2
      SUM1 = 0.
      SUM2 = 0.
      DO 173 I=ITSP,ITFM
         SUM1 = SUM1+SINT(I)*F(I,JPS)
         SUM2 = SUM2+SINT(I)*F(I,JPF)
  173 CONTINUE
      SUM = SUM+WPS*SUM1+WPF*SUM2
      PERTRB = SUM/HNE
      DO 175 J=1,NP1
         DO 174 I=1,MP1
            F(I,J) = F(I,J)-PERTRB
  174    CONTINUE
  175 CONTINUE
C
C SCALE RIGHT SIDE FOR SUBROUTINE POIS
C
  176 DO 178 I=ITS,ITF
         CF = DPHI2*SINT(I)*SINT(I)
         DO 177 J=JPS,JPF
            F(I,J) = CF*F(I,J)
  177    CONTINUE
  178 CONTINUE
      NBDC = NBDCND
      IF (NBDCND-4) 182,179,182
  179 JFN = NUNK/2
      DO 181 J=1,JFN
         JFRD = J+JPS-1
         JBRD = JPF-J+1
         DO 180 I=ITS,ITF
            HLD = F(I,JFRD)
            F(I,JFRD) = F(I,JBRD)
            F(I,JBRD) = HLD
  180    CONTINUE
  181 CONTINUE
      NBDC = 2
  182 CALL POIS (INTL,NBDC,NUNK,MBDCND,MUNK,AM(ITS),BM(ITS),CM(ITS),
     1           IDIMF,F(ITS,JPS),IERROR,D)
      IF (NBDCND-4) 186,183,186
  183 DO 185 J=1,JFN
         JFRD = J+JPS-1
         JBRD = JPF-J+1
         DO 184 I=ITS,ITF
            HLD = F(I,JFRD)
            F(I,JFRD) = F(I,JBRD)
            F(I,JBRD) = HLD
  184    CONTINUE
  185 CONTINUE
  186 IF (ISING) 194,194,187
  187 IF (INP) 191,191,188
  188 IF (ISP) 189,189,194
  189 DO 190 J=1,NP1
         F(1,J) = 0.
  190 CONTINUE
      GO TO 217
  191 IF (ISP) 194,194,192
  192 DO 193 J=1,NP1
         F(M+1,J) = 0.
  193 CONTINUE
      GO TO 217
  194 IF (INP) 201,201,195
  195 SUM = WPS*F(ITS,JPS)+WPF*F(ITS,JPF)
      DO 196 J=JPSP,JPFM
         SUM = SUM+F(ITS,J)
  196 CONTINUE
      DFN = CP*SUM
      DNN = CP*((WPS+WPF+FJJ)*(SN(2)-1.))+ELMBDA
      DSN = CP*(WPS+WPF+FJJ)*SN(M)
      IF (ISP) 197,197,202
  197 CNP = (F(1,1)-DFN)/DNN
      DO 199 I=ITS,ITF
         HLD = CNP*SN(I)
         DO 198 J=JPS,JPF
            F(I,J) = F(I,J)+HLD
  198    CONTINUE
  199 CONTINUE
      DO 200 J=1,NP1
         F(1,J) = CNP
  200 CONTINUE
      GO TO 217
  201 IF (ISP) 217,217,202
  202 SUM = WPS*F(ITF,JPS)+WPF*F(ITF,JPF)
      DO 203 J=JPSP,JPFM
         SUM = SUM+F(ITF,J)
  203 CONTINUE
      DFS = CP*SUM
      DSS = CP*((WPS+WPF+FJJ)*(SS(M)-1.))+ELMBDA
      DNS = CP*(WPS+WPF+FJJ)*SS(2)
      IF (INP) 204,204,208
  204 CSP = (F(M+1,1)-DFS)/DSS
      DO 206 I=ITS,ITF
         HLD = CSP*SS(I)
         DO 205 J=JPS,JPF
            F(I,J) = F(I,J)+HLD
  205    CONTINUE
  206 CONTINUE
      DO 207 J=1,NP1
         F(M+1,J) = CSP
  207 CONTINUE
      GO TO 217
  208 RTN = F(1,1)-DFN
      RTS = F(M+1,1)-DFS
      IF (ISING) 210,210,209
  209 CSP = 0.
      CNP = RTN/DNN
      GO TO 213
  210 IF (ABS(DNN)-ABS(DSN)) 212,212,211
  211 DEN = DSS-DNS*DSN/DNN
      RTS = RTS-RTN*DSN/DNN
      CSP = RTS/DEN
      CNP = (RTN-CSP*DNS)/DNN
      GO TO 213
  212 DEN = DNS-DSS*DNN/DSN
      RTN = RTN-RTS*DNN/DSN
      CSP = RTN/DEN
      CNP = (RTS-DSS*CSP)/DSN
  213 DO 215 I=ITS,ITF
         HLD = CNP*SN(I)+CSP*SS(I)
         DO 214 J=JPS,JPF
            F(I,J) = F(I,J)+HLD
  214    CONTINUE
  215 CONTINUE
      DO 216 J=1,NP1
         F(1,J) = CNP
         F(M+1,J) = CSP
  216 CONTINUE
  217 IF (NBDCND) 220,218,220
  218 DO 219 I=1,MP1
         F(I,JPF+1) = F(I,JPS)
  219 CONTINUE
  220 RETURN
      END SUBROUTINE PWSSS1
C     LAST UPDATE SEPT 16 1981    RAMESH C.BALGOVIND
C POIS       FROM PORTLIB             VERSION   5          10/20/77
      SUBROUTINE POIS (IFLG,NPEROD,N,MPEROD,M,A,B,C,IDIMY,Y,IERROR,W)
C
C
C***********************************************************************
C
C          VERSION  2  OCTOBER 1976  INCLUDING ERRATA  OCTOBER 1976
C
C         DOCUMENTATION FOR THIS PROGRAM IS GIVEN IN
C
C        EFFICIENT FORTRAN SUBPROGRAMS FOR THE SOLUTION OF
C            ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS
C
C                              BY
C
C          PAUL SWARZTRAUBER   AND  ROLAND SWEET
C
C             TECHNICAL NOTE TN/IA-109   JULY 1975
C
C       NATIONAL CENTER FOR ATMOSPHERIC RESEARCH  BOULDER,COLORADO 80307
C
C        WHICH IS SPONSORED BY THE NATIONAL SCIENCE FOUNDATION
C
C***********************************************************************
C
C
C
C     SUBROUTINE POIS SOLVES THE LINEAR SYSTEM OF EQUATIONS
C
C          A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J)
C
C          + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J)
C
C               FOR I = 1,2,...,M  AND  J = 1,2,...,N.
C
C     THE INDICES I+1 AND I-1 ARE EVALUATED MODULO M, I.E.,
C     X(0,J) = X(M,J) AND X(M+1,J) = X(1,J), AND X(I,0) MAY BE EQUAL TO
C     0, X(I,2), OR X(I,N) AND X(I,N+1) MAY BE EQUAL TO 0, X(I,N-1), OR
C     X(I,1) DEPENDING ON AN INPUT PARAMETER.
C
C
C     * * * * * * * * * *     ON INPUT     * * * * * * * * * *
C
C     IFLG
C       = 0  ON INITIAL ENTRY TO POIS OR IF N AND NPEROD ARE CHANGED
C            FROM PREVIOUS CALL.
C       = 1  IF N AND NPEROD ARE UNCHANGED FROM PREVIOUS CALL TO POIS.
C
C       NOTE0  A CALL WITH IFLG = 1 IS ABOUT 1 PERCENT FASTER THAN A
C              CALL WITH IFLG = 0  .
C
C     NPEROD
C       INDICATES THE VALUES WHICH X(I,0) AND X(I,N+1) ARE ASSUMED TO
C       HAVE.
C
C       = 0  IF X(I,0) = X(I,N) AND X(I,N+1) = X(I,1).
C       = 1  IF X(I,0) = X(I,N+1) = 0  .
C       = 2  IF X(I,0) = 0 AND X(I,N+1) = X(I,N-1).
C       = 3  IF X(I,0) = X(I,2) AND X(I,N+1) = X(I,N-1).
C
C     N
C       THE NUMBER OF UNKNOWNS IN THE J-DIRECTION.  N IS DEPENDENT ON
C       NPEROD AND MUST HAVE THE FOLLOWING FORM0
C
C            NPEROD
C              = 0 OR 2, THEN N = (2**P)(3**Q)(5**R)
C              = 1, THEN N = (2**P)(3**Q)(5**R)-1
C              = 3, THEN N = (2**P)(3**Q)(5**R)+1
C
C            WHERE P, Q, AND R MAY BE ANY NON-NEGATIVE INTEGERS.  N MUST
C            BE GREATER THAN 2  .
C
C     MPEROD
C       = 0 IF A(1) AND C(M) ARE NOT ZERO
C       = 1 IF A(1) = C(M) = 0
C
C     M
C       THE NUMBER OF UNKNOWNS IN THE I-DIRECTION.  M MAY BE ANY INTEGER
C       GREATER THAN 1  .
C
C     A,B,C
C       ONE-DIMENSIONAL ARRAYS OF LENGTH M WHICH SPECIFY THE
C       COEFFICIENTS IN THE LINEAR EQUATIONS GIVEN ABOVE.
C
C     IDIMY
C       THE ROW (OR FIRST) DIMENSION OF THE TWO-DIMENSIONAL ARRAY Y AS
C       IT APPEARS IN THE PROGRAM CALLING POIS.  THIS PARAMETER IS USED
C       TO SPECIFY THE VARIABLE DIMENSION OF Y.  IDIMY MUST BE AT LEAST
C       M.
C
C     Y
C       A TWO-DIMENSIONAL ARRAY WHICH SPECIFIES THE VALUES OF THE RIGHT
C       SIDE OF THE LINEAR SYSTEM OF EQUATIONS GIVEN ABOVE.  Y MUST BE
C       DIMENSIONED AT LEAST M*N.
C
C     W
C       A ONE-DIMENSIONAL ARRAY-WHICH MUST BE PROVIDED BY THE USER FOR
C       WORK SPACE.  THE LENGTH OF W MUST BE AT LEAST 6N+5M.
C
C
C     * * * * * * * * * *     ON OUTPUT     * * * * * * * * * *
C
C     Y
C       CONTAINS THE SOLUTION X.
C
C     IERROR
C       AN ERROR FLAG WHICH INDICATES INVALID INPUT PARAMETERS  EXCEPT
C       FOR NUMBER ZERO, A SOLUTION IS NOT ATTEMPTED.
C
C       = 0  NO ERROR.
C       = 1  M .LE. 2  .
C       = 2  N .LE. 2 OR NOT OF THE RIGHT FORM.
C       = 3  IDIMY .LT. M.
C       = 4  NPEROD .LT. 0 OR NPEROD .GT. 3  .
C
C     W
C       CONTAINS INTERMEDIATE VALUES THAT MUST NOT BE DESTROYED IF
C       POIS WILL BE CALLED AGAIN WITH IFLAG = 1  .
C
C
C
      EXTERNAL        ELLIPTIC_TRIDD       ,ELLIPTIC_TRIDP
      REAL       Y(IDIMY,1)
      REAL       W(1)       ,B(1)       ,A(1)       ,C(1)
      IERROR = 0
      IF (M .LE. 2) IERROR = 1
C     I = NCHECK(NPEROD-2*((2*NPEROD)/3)+N)
C     IF (N.LE.2 .OR. I.GT.1) IERROR = 2
      IF (IDIMY .LT. M) IERROR = 3
      IF (NPEROD.LT.0 .OR. NPEROD.GT.3) IERROR = 4
      IF (IERROR .NE. 0) GO TO 105
      IWDIM1 = 6*N+1
      IWDIM2 = IWDIM1+M
      IWDIM3 = IWDIM2+M
      IWDIM4 = IWDIM3+M
      IWDIM5 = IWDIM4+M
      DO 101 I=1,M
         A(I) = -A(I)
         C(I) = -C(I)
         K = IWDIM5+I-1
         W(K) = -B(I)+2.
  101 CONTINUE
      IF (MPEROD .EQ. 0) GO TO 102
      CALL POISGN (NPEROD,N,IFLG,M,A,W(IWDIM5),C,IDIMY,Y,W(1),
     1             W(IWDIM1),W(IWDIM2),W(IWDIM3),W(IWDIM4),ELLIPTIC_TRIDD)
      GO TO 103
  102 CALL POISGN (NPEROD,N,IFLG,M,A,W(IWDIM5),C,IDIMY,Y,W(1),
     1             W(IWDIM1),W(IWDIM2),W(IWDIM3),W(IWDIM4),ELLIPTIC_TRIDP)
  103 DO 104 I=1,M
         A(I) = -A(I)
         C(I) = -C(I)
  104 CONTINUE
  105 RETURN
      END SUBROUTINE POIS
      SUBROUTINE POISGN (NPEROD,N,IFLG,M,BA,BB,BC,IDIMQ,Q,TWOCOS,B,T,D,
     1                   W,TRI)
      REAL       Q(IDIMQ,1)
      REAL       BA(1)      ,BB(1)      ,BC(1)      ,TWOCOS(1)  ,
     1                B(1)       ,T(1)       ,D(1)       ,W(1)
      EXTERNAL TRI
      IF (IFLG .NE. 0) GO TO 101
C
C     DO INITIALIZATION IF FIRST TIME THROUGH.
C
      CALL POINIT (NPEROD,N,IEX2,IEX3,IEX5,N2PW,N2P3P,N2P3P5,KS3,KS5,
     1             NPSTOP,TWOCOS)
  101 MM1 = M-1
      DO 104 J=1,N
         DO 102 I=1,M
            B(I) = -Q(I,J)
  102    CONTINUE
         CALL TRI (1,1,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
         DO 103 I=1,M
            Q(I,J) = B(I)
  103    CONTINUE
  104 CONTINUE
      NP = 1
C
C     START REDUCTION FOR POWERS OF TWO
C
      IF (IEX2 .EQ. 0) GO TO 112
      L = IEX2
      IF (IEX3+IEX5 .NE. 0) GO TO 105
      IF (NPEROD .EQ. 1) L = L-1
      IF (L .EQ. 0) GO TO 138
  105 DO 111 KOUNT=1,L
         K = NP
         NP = 2*NP
         K2 = NP-1
         K3 = NP
         K4 = 2*NP-1
         JSTART = NP
         IF (NPEROD .EQ. 3) JSTART = 1
         DO 110 J=JSTART,N,NP
            JM1 = J-K
            JP1 = J+K
            IF (J .EQ. 1) JM1 = JP1
            IF (J .NE. N) GO TO 106
            JP1 = JM1
            IF (NPEROD .EQ. 0) JP1 = K
  106       DO 107 I=1,M
               B(I) = Q(I,JM1)+Q(I,JP1)
  107       CONTINUE
            CALL TRI (K,K2,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 108 I=1,M
               T(I) = Q(I,J)+B(I)
               B(I) = T(I)
  108       CONTINUE
            CALL TRI (K3,K4,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 109 I=1,M
               Q(I,J) = T(I)+2.*B(I)
  109       CONTINUE
  110    CONTINUE
  111 CONTINUE
C
C     START REDUCTION FOR POWERS OF THREE
C
  112 IF (IEX3 .EQ. 0) GO TO 124
      L = IEX3
      IF (IEX5 .NE. 0) GO TO 113
      IF (NPEROD .EQ. 1) L = L-1
      IF (L .EQ. 0) GO TO 138
  113 K2 = NP-1
      DO 123 KOUNT=1,L
         K = NP
         NP = 3*NP
         K1 = K2+1
         K2 = K2+K
         K3 = K2+1
         K4 = K2+NP
         JSTART = NP
         IF (NPEROD .EQ. 3) JSTART = 1
         DO 122 J=JSTART,N,NP
            IF (J .NE. 1) GO TO 114
            JM1 = J+K
            JM2 = JM1+K
            GO TO 116
  114       JM1 = J-K
            JM2 = JM1-K
            IF (J .NE. N) GO TO 116
            IF (NPEROD .EQ. 0) GO TO 115
            JP1 = JM1
            JP2 = JM2
            GO TO 117
  115       JP1 = K
            JP2 = JP1+K
            GO TO 117
  116       JP1 = J+K
            JP2 = JP1+K
  117       DO 118 I=1,M
               B(I) = 2.*Q(I,J)+Q(I,JM2)+Q(I,JP2)
  118       CONTINUE
            CALL TRI (K1,K2,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 119 I=1,M
               T(I) = B(I)+Q(I,JM1)+Q(I,JP1)
               B(I) = T(I)
  119       CONTINUE
            CALL TRI (K1,K2,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 120 I=1,M
               Q(I,J) = Q(I,J)+B(I)
               B(I) = T(I)
  120       CONTINUE
            CALL TRI (K3,K4,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 121 I=1,M
               Q(I,J) = Q(I,J)+3.*B(I)
  121       CONTINUE
  122    CONTINUE
  123 CONTINUE
C
C     START REDUCTION FOR POWERS OF FIVE
C
  124 L = IEX5
      IF (NPEROD .EQ. 1) L = L-1
      IF (L .LE. 0) GO TO 138
      K2 = (N2PW+N2P3P)/2-1
      DO 137 KOUNT=1,L
         K = NP
         NP = 5*NP
         K1 = K2+1
         K2 = K2+K
         K3 = K2+1
         K4 = K2+NP
         JSTART = NP
         IF (NPEROD .EQ. 3) JSTART = 1
         DO 136 J=JSTART,N,NP
            IF (J .NE. 1) GO TO 125
            JM1 = J+K
            JM2 = JM1+K
            JM3 = JM2+K
            JM4 = JM3+K
            GO TO 127
  125       JM1 = J-K
            JM2 = JM1-K
            JM3 = JM2-K
            JM4 = JM3-K
            IF (J .NE. N) GO TO 127
            IF (NPEROD .EQ. 0) GO TO 126
            JP1 = JM1
            JP2 = JM2
            JP3 = JM3
            JP4 = JM4
            GO TO 128
  126       JP1 = K
            JP2 = JP1+K
            JP3 = JP2+K
            JP4 = JP3+K
            GO TO 128
  127       JP1 = J+K
            JP2 = JP1+K
            JP3 = JP2+K
            JP4 = JP3+K
  128       DO 129 I=1,M
               B(I) = 6.*Q(I,J)+4.*(Q(I,JM2)+Q(I,JP2))+Q(I,JM4)+Q(I,JP4)
  129       CONTINUE
            CALL TRI (K1,K2,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 130 I=1,M
               B(I) = B(I)+3.*(Q(I,JM1)+Q(I,JP1))+Q(I,JM3)+Q(I,JP3)
  130       CONTINUE
            CALL TRI (K1,K2,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 131 I=1,M
               T(I) = B(I)
               B(I) = 2.*Q(I,J)+Q(I,JM2)+Q(I,JP2)+B(I)
  131       CONTINUE
            CALL TRI (K1,K2,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 132 I=1,M
               B(I) = B(I)+Q(I,JM1)+Q(I,JP1)
  132       CONTINUE
            CALL TRI (K1,K2,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 133 I=1,M
               TEMP = B(I)+Q(I,J)
               B(I) = 4.*Q(I,J)+3.*(Q(I,JM2)+Q(I,JP2))+Q(I,JM4)+
     1                Q(I,JP4)-T(I)
               Q(I,J) = TEMP
  133       CONTINUE
            CALL TRI (K1,K2,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 134 I=1,M
               B(I) = B(I)+2.*(Q(I,JM1)+Q(I,JP1))+Q(I,JM3)+Q(I,JP3)
  134       CONTINUE
            CALL TRI (K3,K4,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 135 I=1,M
               Q(I,J) = Q(I,J)+5.*B(I)
  135       CONTINUE
  136    CONTINUE
  137 CONTINUE
C
C     INITIAL PHASE OF BACK SUBSTITUTION
C
  138 IF (NPEROD.EQ.1 .OR. NPEROD.EQ.2) GO TO 147
      IF (NPEROD .EQ. 0) GO TO 141
      DO 139 I=1,M
         B(I) = 2.*Q(I,1)
  139 CONTINUE
      CALL TRI (K3,K4,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
      DO 140 I=1,M
         Q(I,N) = Q(I,N)+B(I)
         B(I) = 4.*Q(I,N)
  140 CONTINUE
      CALL TRI (K4+1,K4+2*NP-1,2,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
      GO TO 143
  141 DO 142 I=1,M
         B(I) = 2.*Q(I,N)
  142 CONTINUE
      CALL TRI (K4+1,K4+NP-1,2,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
  143 DO 144 I=1,M
         Q(I,N) = Q(I,N)+B(I)
  144 CONTINUE
      IF (NPEROD .EQ. 0) GO TO 147
      DO 145 I=1,M
         B(I) = 2.*Q(I,N)
  145 CONTINUE
      CALL TRI (K3,K4,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
      DO 146 I=1,M
         Q(I,1) = Q(I,1)+B(I)
  146 CONTINUE
C
C     REGULAR BACK SUBSTITUTION FOR POWERS OF FIVE
C
  147 CONTINUE
      IF (IEX5 .EQ. 0) GO TO 171
      NP = N2P3P5
      K8 = KS5
      IF (NPEROD .EQ. 1) K3 = K3+NP/5
      DO 170 KOUNT=1,IEX5
         K = NP
         NP = NP/5
         K4 = K3-1
         K3 = K3-NP
         K1 = K8+1
         K2 = K8+2*NP
         K5 = K2+1
         K6 = K2+4*NP
         K7 = K6+1
         K8 = K6+2*NP
         JSTART = NP
         IF (NPEROD .EQ. 3) JSTART = 1+NP
         DO 169 J=JSTART,N,K
            JM1 = J-NP
            JP1 = J+NP
            JP2 = JP1+NP
            JP3 = JP2+NP
            JP4 = JP3+NP
            IF (JM1 .NE. 0) GO TO 151
            IF (NPEROD .EQ. 0) GO TO 149
            DO 148 I=1,M
               B(I) = Q(I,JP1)
  148       CONTINUE
            GO TO 153
  149       DO 150 I=1,M
               B(I) = Q(I,JP1)+Q(I,N)
  150       CONTINUE
            GO TO 153
  151       DO 152 I=1,M
               B(I) = Q(I,JP1)+Q(I,JM1)
  152       CONTINUE
  153       CALL TRI (K3,K4,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 154 I=1,M
               Q(I,J) = Q(I,J)+B(I)
               B(I) = Q(I,JP1)+Q(I,JP3)
  154       CONTINUE
            CALL TRI (K3,K4,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 155 I=1,M
               Q(I,JP2) = Q(I,JP2)+B(I)
  155       CONTINUE
            IF (JP4 .GT. N) GO TO 157
            DO 156 I=1,M
               B(I) = 2.*Q(I,JP2)+Q(I,J)+Q(I,JP4)
  156       CONTINUE
            GO TO 159
  157       DO 158 I=1,M
               B(I) = 2.*Q(I,JP2)+Q(I,J)
  158       CONTINUE
  159       CALL TRI (K1,K2,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 160 I=1,M
               Q(I,JP2) = Q(I,JP2)+B(I)
               B(I) = Q(I,JP2)+Q(I,J)
  160       CONTINUE
            CALL TRI (K5,K6,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 161 I=1,M
               Q(I,JP2) = Q(I,JP2)+B(I)
               B(I) = Q(I,J)+Q(I,JP2)
  161       CONTINUE
            CALL TRI (K7,K8,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 162 I=1,M
               Q(I,J) = Q(I,J)+B(I)
               B(I) = Q(I,J)+Q(I,JP2)
  162       CONTINUE
            CALL TRI (K3,K4,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 163 I=1,M
               Q(I,JP1) = Q(I,JP1)+B(I)
  163       CONTINUE
            IF (JP4 .GT. N) GO TO 165
            DO 164 I=1,M
               B(I) = Q(I,JP2)+Q(I,JP4)
  164       CONTINUE
            GO TO 167
  165       DO 166 I=1,M
               B(I) = Q(I,JP2)
  166       CONTINUE
  167       CALL TRI (K3,K4,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 168 I=1,M
               Q(I,JP3) = Q(I,JP3)+B(I)
  168       CONTINUE
  169    CONTINUE
  170 CONTINUE
C
C     REGULAR BACK SUBSTITUTION FOR POWERS OF THREE
C
  171 IF (IEX3 .EQ. 0) GO TO 191
      NP = N2P3P
      K2 = KS3
      IF (NPEROD.EQ.1 .AND. IEX5.EQ.0) K3 = K3+NP/3
      DO 190 KOUNT=1,IEX3
         K = NP
         NP = NP/3
         K4 = K3-1
         K3 = K3-NP
         K1 = K2+1
         K2 = K2+2*NP
         JSTART = NP
         IF (NPEROD .EQ. 3) JSTART = NP+1
         DO 189 J=JSTART,N,K
            JM1 = J-NP
            JP1 = J+NP
            JP2 = JP1+NP
            IF (JM1 .EQ. 0) GO TO 173
            DO 172 I=1,M
               B(I) = Q(I,JP1)+Q(I,JM1)
  172       CONTINUE
            GO TO 177
  173       IF (NPEROD .EQ. 0) GO TO 175
            DO 174 I=1,M
               B(I) = Q(I,JP1)
  174       CONTINUE
            GO TO 177
  175       DO 176 I=1,M
               B(I) = Q(I,JP1)+Q(I,N)
  176       CONTINUE
  177       CALL TRI (K3,K4,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 178 I=1,M
               Q(I,J) = Q(I,J)+B(I)
  178       CONTINUE
            IF (JP2 .GT. N) GO TO 180
            DO 179 I=1,M
               B(I) = Q(I,J)+Q(I,JP2)
  179       CONTINUE
            GO TO 182
  180       DO 181 I=1,M
               B(I) = Q(I,J)
  181       CONTINUE
  182       CALL TRI (K1,K2,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 183 I=1,M
               Q(I,J) = Q(I,J)+B(I)
  183       CONTINUE
            IF (JP2 .GT. N) GO TO 185
            DO 184 I=1,M
               B(I) = Q(I,J)+Q(I,JP2)
  184       CONTINUE
            GO TO 187
  185       DO 186 I=1,M
               B(I) = Q(I,J)
  186       CONTINUE
  187       CALL TRI (K3,K4,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 188 I=1,M
               Q(I,JP1) = Q(I,JP1)+B(I)
  188       CONTINUE
  189    CONTINUE
  190 CONTINUE
C
C     REGULAR BACK SUBSTITUTION FOR POWERS OF TWO
C
  191 IF (IEX2 .EQ. 0) GO TO 202
      NP = N2PW
      DO 201 KOUNT=1,IEX2
         K = NP
         NP = NP/2
         K3 = K-1
         JSTART = NP
         IF (NPEROD .EQ. 3) JSTART = 1+NP
         DO 200 J=JSTART,N,K
            JM1 = J-NP
            JP1 = J+NP
            IF (JM1 .NE. 0) GO TO 194
            IF (JP1 .GT. N) GO TO 200
            IF (NPEROD.EQ.1 .OR. NPEROD.EQ.2) GO TO 192
            JM1 = N
            GO TO 196
  192       DO 193 I=1,M
               B(I) = Q(I,JP1)
  193       CONTINUE
            GO TO 198
  194       IF (JP1 .LE. N) GO TO 196
            DO 195 I=1,M
               B(I) = Q(I,JM1)
  195       CONTINUE
            GO TO 198
  196       DO 197 I=1,M
               B(I) = Q(I,JM1)+Q(I,JP1)
  197       CONTINUE
  198       CALL TRI (NP,K3,1,M,MM1,BA,BB,BC,B,TWOCOS,D,W)
            DO 199 I=1,M
               Q(I,J) = Q(I,J)+B(I)
  199       CONTINUE
  200    CONTINUE
  201 CONTINUE
  202 RETURN
      END SUBROUTINE POISGN
      SUBROUTINE POINIT (NPEROD,N,IEX2,IEX3,IEX5,N2PW,N2P3P,N2P3P5,KS3,
     1                   KS5,NPSTOP,TWOCOS)
      REAL       TWOCOS(1)
C
C     PARAMETER NPSTOP IS NOT USED IN THIS SUBROUTINE.
C
C
C     MACHINE DEPENDENT CONSTANT
C
C     PI=3.1415926535897932384626433832795028841971693993751058209749446
C
      PI = 3.14159265358979
C
C     COMPUTE EXPONENTS OF 2,3, AND 5 IN N.
C
      NP = N
      IF (NPEROD .EQ. 1) NP = NP+1
      IF (NPEROD .EQ. 3) NP = NP-1
      IEX2 = 0
  101 K = NP/2
      IF (2*K .NE. NP) GO TO 102
      IEX2 = IEX2+1
      NP = K
      GO TO 101
  102 IEX3 = 0
  103 K = NP/3
      IF (3*K .NE. NP) GO TO 104
      IEX3 = IEX3+1
      NP = K
      GO TO 103
  104 IEX5 = 0
  105 K = NP/5
      IF (5*K .NE. NP) GO TO 106
      IEX5 = IEX5+1
      NP = K
      GO TO 105
  106 CONTINUE
      N2PW = 2**IEX2
      N2P3P = N2PW*(3**IEX3)
      N2P3P5 = N2P3P*(5**IEX5)
C
C     COMPUTE NECESSARY VALUES OF 2*COS(X)
C
      NP = 1
      TWOCOS(1) = 0.
      K = 1
      IF (IEX2 .EQ. 0) GO TO 110
      L = IEX2
      IF (IEX3+IEX5 .NE. 0) GO TO 107
      IF (NPEROD .EQ. 1) L = L-1
      IF (L .EQ. 0) GO TO 129
  107 DO 109 KOUNT=1,L
         NP = 2*NP
         DO 108 I=1,NP
            J = K+I
            TWOCOS(J) = 2.*COS((FLOAT(I)-.5)*PI/FLOAT(NP))
  108    CONTINUE
         K = K+NP
  109 CONTINUE
  110 IF (IEX3 .EQ. 0) GO TO 114
      L = IEX3
      IF (IEX5 .NE. 0) GO TO 111
      IF (NPEROD .EQ. 1) L = L-1
      IF (L .EQ. 0) GO TO 117
  111 DO 113 KOUNT=1,L
         NP = 3*NP
         DO 112 I=1,NP
            J = K+I
            TWOCOS(J) = 2.*COS((FLOAT(I)-.5)*PI/FLOAT(NP))
  112    CONTINUE
         K = K+NP
  113 CONTINUE
  114 L = IEX5
      IF (NPEROD .EQ. 1) L = L-1
      IF (L .LE. 0) GO TO 117
      DO 116 KOUNT=1,L
         NP = 5*NP
         DO 115 I=1,NP
            J = K+I
            TWOCOS(J) = 2.*COS((FLOAT(I)-.5)*PI/FLOAT(NP))
  115    CONTINUE
         K = K+NP
  116 CONTINUE
  117 IF (NPEROD.EQ.1 .OR. NPEROD.EQ.2) GO TO 121
      IF (NPEROD .EQ. 0) GO TO 119
      NPT2 = 2*NP
      DO 118 I=1,NPT2
         J = K+I
         TWOCOS(J) = 2.*COS(FLOAT(I)*PI/FLOAT(NP))
  118 CONTINUE
      K = K+NPT2
      GO TO 121
  119 DO 120 I=1,NP
         J = K+I
         TWOCOS(J) = 2.*COS(2.*FLOAT(I)*PI/FLOAT(NP))
  120 CONTINUE
      K = K+NP
  121 NP = N2P3P5
      IF (IEX5 .EQ. 0) GO TO 126
      KS5 = K
      DO 125 KOUNT=1,IEX5
         NP = NP/5
         NPT2 = 2*NP
         DO 122 I=1,NPT2
            J = K+I
            TWOCOS(J) = 2.*COS((FLOAT(I)-.5)*PI/FLOAT(NPT2))
  122    CONTINUE
         K = K+NPT2
         DO 123 I=1,NP
            J = K+4*I
            TWOCOS(J-3) = 2.*COS((FLOAT(I)-.8)*PI/FLOAT(NP))
            TWOCOS(J-2) = 2.*COS((FLOAT(I)-.6)*PI/FLOAT(NP))
            TWOCOS(J-1) = 2.*COS((FLOAT(I)-.4)*PI/FLOAT(NP))
            TWOCOS(J) = 2.*COS((FLOAT(I)-.2)*PI/FLOAT(NP))
  123    CONTINUE
         K = K+4*NP
         DO 124 I=1,NP
            J = K+2*I
            TWOCOS(J-1) = 2.*COS(FLOAT(3*I-2)*PI/FLOAT(3*NP))
            TWOCOS(J) = 2.*COS(FLOAT(3*I-1)*PI/FLOAT(3*NP))
  124    CONTINUE
         K = K+2*NP
  125 CONTINUE
  126 IF (IEX3 .EQ. 0) GO TO 129
      KS3 = K
      DO 128 KOUNT=1,IEX3
         NP = NP/3
         DO 127 I=1,NP
            J = K+2*I
            TWOCOS(J-1) = 2.*COS(FLOAT(3*I-2)*PI/FLOAT(3*NP))
            TWOCOS(J) = 2.*COS(FLOAT(3*I-1)*PI/FLOAT(3*NP))
  127    CONTINUE
         K = K+2*NP
  128 CONTINUE
  129 RETURN
      END SUBROUTINE POINIT
      end module m_elliptic
      SUBROUTINE ELLIPTIC_TRIDD (KSTART,KSTOP,ISING,M,MM1,A,B,C,Y,TWOCOS,D,W)
      REAL       A(1)       ,B(1)       ,C(1)       ,Y(1)       ,
     1                TWOCOS(1)  ,D(1)       ,W(1)
C
C     SUBROUTINE TO SOLVE TRIDIAGONAL SYSTEMS
C
C
C     PARAMETER W NOT USED IN THIS SUBROUTINE.
C
      DO 103 K=KSTART,KSTOP
         X = -TWOCOS(K)
         D(1) = C(1)/(B(1)+X)
         Y(1) = Y(1)/(B(1)+X)
         DO 101 I=2,M
            Z = B(I)+X-A(I)*D(I-1)
            D(I) = C(I)/Z
            Y(I) = (Y(I)-A(I)*Y(I-1))/Z
  101    CONTINUE
         DO 102 IP=1,MM1
            I = M-IP
            Y(I) = Y(I)-D(I)*Y(I+1)
  102    CONTINUE
  103 CONTINUE
      IF (ISING .EQ. 1) RETURN
      D(1) = C(1)/(B(1)-2.)
      Y(1) = Y(1)/(B(1)-2.)
      DO 104 I=2,MM1
         Z = B(I)-2.-A(I)*D(I-1)
         D(I) = C(I)/Z
         Y(I) = (Y(I)-A(I)*Y(I-1))/Z
  104 CONTINUE
      Z = B(M)-2.-A(M)*D(M-1)
      X = Y(M)-A(M)*Y(M-1)
      IF (Z .NE. 0.) GO TO 105
      Y(M) = 0.
      GO TO 106
  105 Y(M) = X/Z
  106 DO 107 IP=1,MM1
         I = M-IP
         Y(I) = Y(I)-D(I)*Y(I+1)
  107 CONTINUE
      RETURN
      END SUBROUTINE ELLIPTIC_TRIDD
      SUBROUTINE ELLIPTIC_TRIDP (KSTART,KSTOP,ISING,M,MM1,A,B,C,Y,TWOCOS,D,W)
      REAL       A(1)       ,B(1)       ,C(1)       ,Y(1)       ,
     1                TWOCOS(1)  ,D(1)       ,W(1)
C
C     SUBROUTINE TO SOLVE PERIODIC TRIDIAGONAL SYSTEM
C
      DO 103 K=KSTART,KSTOP
         X = -TWOCOS(K)
         D(1) = C(1)/(B(1)+X)
         W(1) = A(1)/(B(1)+X)
         Y(1) = Y(1)/(B(1)+X)
         BM = B(M)
         Z = C(M)
         DO 101 I=2,MM1
            DEN = B(I)+X-A(I)*D(I-1)
            D(I) = C(I)/DEN
            W(I) = -A(I)*W(I-1)/DEN
            Y(I) = (Y(I)-A(I)*Y(I-1))/DEN
            Y(M) = Y(M)-Z*Y(I-1)
            BM = BM-Z*W(I-1)
            Z = -Z*D(I-1)
  101    CONTINUE
         D(MM1) = D(MM1)+W(MM1)
         Z = A(M)+Z
         DEN = BM+X-Z*D(MM1)
         Y(M) = Y(M)-Z*Y(M-1)
         Y(M) = Y(M)/DEN
         Y(MM1) = Y(MM1)-D(MM1)*Y(M)
         DO 102 IP=2,MM1
            I = M-IP
            Y(I) = Y(I)-D(I)*Y(I+1)-W(I)*Y(M)
  102    CONTINUE
  103 CONTINUE
      IF (ISING .EQ. 1) RETURN
      D(1) = C(1)/(B(1)-2.)
      W(1) = A(1)/(B(1)-2.)
      Y(1) = Y(1)/(B(1)-2.)
      BM = B(M)
      Z = C(M)
      DO 104 I=2,MM1
         DEN = B(I)-2.-A(I)*D(I-1)
         D(I) = C(I)/DEN
         W(I) = -A(I)*W(I-1)/DEN
         Y(I) = (Y(I)-A(I)*Y(I-1))/DEN
         Y(M) = Y(M)-Z*Y(I-1)
         BM = BM-Z*W(I-1)
         Z = -Z*D(I-1)
  104 CONTINUE
      D(MM1) = D(MM1)+W(MM1)
      Z = A(M)+Z
      DEN = BM-2.-Z*D(MM1)
      Y(M) = Y(M)-Z*Y(M-1)
      IF (DEN .NE. 0.) GO TO 105
      Y(M) = 0.
      GO TO 106
  105 Y(M) = Y(M)/DEN
  106 Y(MM1) = Y(MM1)-D(MM1)*Y(M)
      DO 107 IP=2,MM1
         I = M-IP
         Y(I) = Y(I)-D(I)*Y(I+1)-W(I)*Y(M)
  107 CONTINUE
      RETURN
      END SUBROUTINE ELLIPTIC_TRIDP
      FUNCTION ELLIPTIC_APXEPS (DUM)
C          RETURN MACHINE ACC.
      ELLIPTIC_APXEPS = 1.00  E -4
      DO 20 I = 1,100
      S = ELLIPTIC_APXEPS * 0.01
      S = S + 1.
      S = S - 1.
C     PRINT 10,I,S,ELLIPTIC_APXEPS
      IF (S.LE.DUM) RETURN
   20 ELLIPTIC_APXEPS = ELLIPTIC_APXEPS *.1
      RETURN
   10 FORMAT (10X,'I = ',I4,' S = ',F21.18,' EPS = ',F21.18)
      END FUNCTION ELLIPTIC_APXEPS