c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2010 by Chuanjie Wu and Jay William Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine evcorr  --  long range vdw energy correction  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "evcorr" computes the long range van der Waals correction
c     to the energy via numerical integration
c
c     literature reference:
c
c     M. P. Allen and D. J. Tildesley, "Computer Simulation of
c     Liquids", Oxford University Press, 1987, Section 2.8
c
c
      subroutine evcorr (elrc)
      implicit none
      include 'sizes.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cutoff.i'
      include 'math.i'
      include 'shunt.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,it,kt
      integer nstep,ndelta
      real*8 elrc,etot
      real*8 range,rdelta
      real*8 termi,termik
      real*8 e,eps
      real*8 offset,taper
      real*8 rv,rv2,rv6,rv7
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 p,p6,p12
      real*8 rho,tau,tau7
      real*8 expterm
      character*6 mode
c
c
c     zero out the long range van der Waals correction
c
      elrc = 0.0d0
c
c     only applicable if periodic boundaries are in use
c
      if (.not. use_bounds)  return
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     set number of steps and range for numerical integration
c
      nstep = 20
      range = 200.0d0
      ndelta = int(dble(nstep)*(range-cut))
      rdelta = (range-cut) / dble(ndelta)
      offset = cut - 0.5d0*rdelta
c
c     find the van der Waals energy via double loop search
c
      elrc = 0.0d0
      do i = 1, nvt
         it = ivt(i)
         termi = 2.0d0 * pi * dble(jvt(i))
         do k = 1, nvt
            kt = ivt(k)
            termik = termi * dble(jvt(k))
	    rv = radmin(kt,it)
	    eps = epsilon(kt,it)
            rv2 = rv * rv
            rv6 = rv2 * rv2 * rv2
            rv7 = rv6 * rv
            etot = 0.0d0
            do j = 1, ndelta
               r = offset + dble(j)*rdelta
               r2 = r * r
               r3 = r2 * r
               r6 = r3 * r3
               r7 = r6 * r
               e = 0.0d0
               if (vdwtyp .eq. 'LENNARD-JONES') then
                  p6 = rv6 / r6
                  p12 = p6 * p6
                  e = eps * (p12 - 2.0d0*p6)
               else if (vdwtyp .eq. 'BUFFERED-14-7') then
	          rho = r7 + ghal*rv7
	          tau = (dhal+1.0d0) / (r+dhal*rv)
                  tau7 = tau**7
	          e = eps * rv7 * tau7 * ((ghal+1.0d0)*rv7/rho-2.0d0)
               else if (vdwtyp.eq.'BUCKINGHAM' .or.
     &                  vdwtyp.eq.'MM3-HBOND') then
                  p = sqrt(rv2/r2)
                  p6 = rv6 / r6
                  expterm = abuck * exp(-bbuck/p)
                  e = eps * (expterm - cbuck*p6)
               end if
               if (r .lt. off) then
                  r4 = r2 * r2
                  r5 = r2 * r3
                  taper = c5*r5 + c4*r4 + c3*r3 + c2*r2 + c1*r + c0
                  e = e * (1.0d0-taper)
               end if
               etot = etot + e*rdelta*r2
            end do
            elrc = elrc + termik*etot
         end do
      end do
      elrc = elrc / volbox
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine evcorr1  --  long range vdw energy & virial  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "evcorr1" computes the long range van der Waals correction
c     to the energy and virial via numerical integration
c
c     literature reference:
c
c     M. P. Allen and D. J. Tildesley, "Computer Simulation of
c     Liquids", Oxford University Press, 1987, Section 2.8
c
c
      subroutine evcorr1 (elrc,vlrc)
      implicit none
      include 'sizes.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cutoff.i'
      include 'math.i'
      include 'shunt.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,it,kt
      integer nstep,ndelta
      real*8 elrc,vlrc
      real*8 etot,vtot
      real*8 range,rdelta
      real*8 termi,termik
      real*8 e,de,eps
      real*8 offset
      real*8 taper,dtaper
      real*8 rv,rv2,rv6,rv7
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 p,p6,p12
      real*8 rho,tau,tau7
      real*8 dtau,gtau
      real*8 rvterm,expterm
      character*6 mode
c
c
c     zero out the long range van der Waals corrections
c
      elrc = 0.0d0
      vlrc = 0.0d0
c
c     only applicable if periodic boundaries are in use
c
      if (.not. use_bounds)  return
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     set number of steps and range for numerical integration
c
      nstep = 20
      range = 200.0d0
      ndelta = int(dble(nstep)*(range-cut))
      rdelta = (range-cut) / dble(ndelta)
      offset = cut - 0.5d0*rdelta
c
c     find the van der Waals energy via double loop search
c
      do i = 1, nvt
         it = ivt(i)
         termi = 2.0d0 * pi * dble(jvt(i))
         do k = 1, nvt
            kt = ivt(k)
            termik = termi * dble(jvt(k))
	    rv = radmin(kt,it)
	    eps = epsilon(kt,it)
            rv2 = rv * rv
            rv6 = rv2 * rv2 * rv2
            rv7 = rv6 * rv
            etot = 0.0d0
            vtot = 0.0d0
            do j = 1, ndelta
               r = offset + dble(j)*rdelta
               r2 = r * r
               r3 = r2 * r
               r6 = r3 * r3
               r7 = r6 * r
               e = 0.0d0
               de = 0.0d0
               if (vdwtyp .eq. 'LENNARD-JONES') then
                  p6 = rv6 / r6
                  p12 = p6 * p6
                  e = eps * (p12 - 2.0d0*p6)
                  de = eps * (p12-p6) * (-12.0d0/r)
               else if (vdwtyp .eq. 'BUFFERED-14-7') then
	          rho = r7 + ghal*rv7
	          tau = (dhal+1.0d0) / (r+dhal*rv)
                  tau7 = tau**7
                  dtau = tau / (dhal+1.0d0)
                  gtau = eps*tau7*r6*(ghal+1.0d0)*(rv7/rho)**2
	          e = eps * rv7 * tau7 * ((ghal+1.0d0)*rv7/rho-2.0d0)
                  de = -7.0d0 * (dtau*e+gtau)
               else if (vdwtyp.eq.'BUCKINGHAM' .or.
     &                  vdwtyp.eq.'MM3-HBOND') then
                  p = sqrt(rv2/r2)
                  p6 = rv6 / r6
                  rvterm = -bbuck / rv
                  expterm = abuck * exp(-bbuck/p)
                  e = eps * (expterm - cbuck*p6)
                  de = eps * (rvterm*expterm+6.0d0*cbuck*p6/r)
               end if
               if (r .lt. off) then
                  r4 = r2 * r2
                  r5 = r2 * r3
                  taper = c5*r5 + c4*r4 + c3*r3 + c2*r2 + c1*r + c0
                  dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                        + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                  de = de*(1.0d0-taper) - e*dtaper
                  e = e*(1.0d0-taper)
               end if
               etot = etot + e*rdelta*r2
               vtot = vtot + de*rdelta*r3
            end do
            elrc = elrc + termik*etot
            vlrc = vlrc + termik*vtot
         end do
      end do
      elrc = elrc / volbox
      vlrc = vlrc / (3.0d0*volbox)
      return
      end


!volume data building

module volume_m
    use ut_m
    use field_m
    use params_m
    use debug_m
    use solver_m
    implicit none
    private
    public :: volume__initialize,  &
              volume__write

!3-D single precision real arrays.
real(SR), dimension(:,:,:), allocatable :: volume_ps !pressure
real(SR), dimension(:,:,:), allocatable :: volume_en !enstrophy

logical, save :: Initialize_done = .false.
integer(SI), parameter :: FILE_VOLUME0 = 21
integer(SI), parameter :: FILE_VOLUME1 = 22
integer(SI), parameter :: FILE_VOLUME2 = 23
integer(SI), parameter :: FILE_VOLUME3 = 24

contains

  subroutine make_single_precision_field(vel,ps)
    type(field__vector3d_t),       intent(in) :: vel
    real(DR), dimension(NX,NY,NZ), intent(in) :: ps

    type(field__vector3d_t)       :: vor   ! vorticity
    real(DR), dimension(NX,NY,NZ) :: enstrophy

    vor = operator_curl(vel)
    enstrophy = operator_dot_product(vor,vor)

    volume_ps = real(       ps(:,:,:),SR)
    volume_en = real(enstrophy(:,:,:),SR)

    call debug__print('called volume/make_single_precision_field.')
    end subroutine make_single_precision_field

!
!Private
!============
!Public
!

    subroutine volume__initialize
    allocate(volume_ps(NX,NY,NZ),   &
             volume_en(NX,NY,NZ))

    call debug__print('volume data allocated')

    open(FILE_VOLUME0,file='PESSURE_DATA1', form='unformatted', access='direct', recl=NX*NY*NZ*4)
    open(FILE_VOLUME1,file='ENSTROPHY_DATA1', form='unformatted', access='direct', recl=NX*NY*NZ*4)
    open(FILE_VOLUME2,file='PESSURE_DATA2', form='unformatted', access='direct', recl=NX*NY*NZ*4)
    open(FILE_VOLUME3,file='ENSTROPHY_DATA2', form='unformatted', access='direct', recl=NX*NY*NZ*4)
    Initialize_done = .true.

    call debug__print('called volume__initlilize')
 end subroutine volume__initialize

subroutine volume__write(nloop,fluid)
    integer(DI),          intent(in) :: nloop
    type(field__fluid_t), intent(in) :: fluid

    type(field__vector3d_t) :: vel
    call solver__get_subfield(fluid,vel)
    call make_single_precision_field(vel,fluid%pressure)
    if (nloop==500) then
     write(FILE_VOLUME0) volume_ps
     write(FILE_VOLUME1) volume_en
    else if (nloop==1000) then
     write(FILE_VOLUME2) volume_ps
     write(FILE_VOLUME3) volume_en
    end if
 end subroutine volume__write

end module volume_m


subroutine prep_Hmat
  use global_variables
  implicit none
  integer :: aion,icell

  zH_mat = zH0_mat
  do aion = 1,Nion
    do icell = 1,NK

      zH_mat(:,:) = zH_mat(:,:) - zF_mat_full(:,:,icell,aion)*Uion(icell,aion) &
        -zG_mat_full(:,:,icell,aion)*Uion(icell,aion)**2 ! &
!        - zG3_mat_full(:,:,icell,aion)*Uion(icell,aion)**3

    end do
  end do

  return
end subroutine prep_Hmat


** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
**
** Licensed under the Apache License, Version 2.0 (the "License");
** you may not use this file except in compliance with the License.
** You may obtain a copy of the License at
**
**     http://www.apache.org/licenses/LICENSE-2.0
**
** Unless required by applicable law or agreed to in writing, software
** distributed under the License is distributed on an "AS IS" BASIS,
** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
** See the License for the specific language governing permissions and
** limitations under the License.

*   Miscellaneous Scheduler and other bugs.

c    (1) Complex store problem.
c    (2) Dependency between CALL and cblock load.
c    (3) Multiplication of complex functions.
c    (4) Complex array subscripts
c    (5) CMPLX, DCMPLX intrinsics

	program p
	parameter(n = 8)
	complex c, arr(2)
	double complex darr(2)
	real rslts(n), expect(n)
	double precision dfunc
	real rfunc
	external dfunc, rfunc

	common kk

c  --- tests 1, 2:  Complex store problem:

	data expect(1), expect(2) / 4.0, 2.0 /
	data c / (2, 4) /
	c = cmplx(aimag(c), real(c))
	rslts(1) = real(c)
	rslts(2) = aimag(c)

c  --- test 3:  kk should be reloaded after call:

	data expect(3) / 3.0 /
	kk = 0
	call sub
	rslts(3) = kk

c  --- test 4 - 5:  Multiply two complex functions:

	data expect(4), expect(5) / -13.0, 52.0 /
	c = cos((1,2)) * sin((-2,-1))
	rslts(4) = int( 10 * real(c) )
	rslts(5) = int( 10 * aimag(c) )

c  --- test 6: number of times a subscript of a complex array is evaluated

	data expect(6) /1.0/
	rslts(6) = 0.0
	arr(ifunc(rslts(6))) = 0.0

c  ---  test 7: number of times the operand of cmplx is evaluated

	data expect(7) /1.0/
	rslts(7) = 0.0
	arr(1) = (1.0, 2.0)
	arr(2) = cmplx(rfunc(rslts(7))) * arr(1)

c  ---  test 8: number of times the operand of dcmplx is evaluated

	data expect(8) /1.0/
	rslts(8) = 0.0
	darr(1) = (1.0, 2.0)
	darr(2) = dcmplx(dfunc(rslts(8))) * darr(1)

c  --- check results:

	call check(rslts, expect, n)
	end

cccccccccccccccccccccccccccccc

	subroutine sub
	common kk
	kk = 3
	end

	integer function ifunc(x)
	x = x + 1
	ifunc = 1
	return
	end

	real function rfunc(x)
	x = x + 1
	rfunc = 1.0
	return
	end

	double precision function dfunc(x)
	x = x + 1
	dfunc = 1.0
	return
	end


      program runall
c-----------------------------------------------------------------------
c     not present: CG and FGMRES
c-----------------------------------------------------------------------
c     program for running all examples -- for book tables.
c-----------------------------------------------------------------------
      parameter (nmax=10000,np1=nmax+1,nt2=2*nmax,nzmax = 100000,
     *     lw=31*nmax,nzumax = 20*nzmax)
c-----------------------------------------------------------------------
      implicit none
c
      integer ia(nt2),ja(nzmax),jlu(nzumax),levs(nzumax),ju(nmax+1)
      real*8 wk(lw),rhs(nmax),a(nzmax),alu(nzumax)
      integer jw(nt2), iperm(nt2)
      real*8 w(nt2),sol(nt2)
      integer n, mbloc
      character guesol*2, title*72, key*8, type*3
c-----------------------------------------------------------------------
      integer iout,lfil,j,k,maxits,i,ncol,numat,mat,iwk,nnz,ipo,ipi,iin,
     *   job,nrhs,im,outf,ipre,its,ierr,ipre1,ipre2,lf,it,itp,
     *     icode,imat,kk,lfinc, niter
      character*50 filnam
      integer iters(20)
c
c     up to 10 matrices
c
      real*8 droptol, dropinc, t, permtol, tol, eps, rand, alph, dnrm2
c
c-----------------------------------------------------------------------
      data iin/4/, iout/8/
c-----------------------------------------------------------------------
      iwk = nzumax
c
c read in matrix pathname from file. == then read matrix itself
c
      open (2, file ='matfile')
      read (2,*)  numat
      i=20
c-----------------------------------------------------------------------
      open (iin,file='inputs')
      read (iin,*) alph
      read (iin,*) im, maxits
      read (iin,*) eps
      read (iin,*) ipre1, ipre2, niter
      read (iin,*) tol, dropinc, permtol
      read (iin,*) lf, lfinc
      outf = 30
c
c     BIG MATRIX LOOP
c
c-----------------------------------------------------------------------
c     LOOP THROUGH MATRICES
c-----------------------------------------------------------------------
      do 300 mat =1, numat
         read (2,'(a50)') filnam
         imat = 20
         open (imat,file =filnam)
         write (7,*) filnam
         job = 3
         nrhs = nmax
         call readmt (nmax,nzmax,job,imat,a,ja,ia, rhs, nrhs,
     *        guesol,n,ncol,nnz,title,key,type,ierr)
c-----------------------------------------------------------------------
         rewind(imat)
         write (7,*) ' -- read -- returned with  ierr = ', ierr
         write (7,*) ' matrix ', filnam
         write (7,*) ' *** n  =  ', n, ' nnz ', nnz
         if (ierr .ne. 0) stop ' not able to read *** '
c
c     sort matrix
c
         call csort(n,a,ja,ia,jlu,.true.)
         job = 0
         call roscal(n,job,1,a,ja,ia,wk,a,ja,ia,ierr)
         call coscal(n,job,1,a,ja,ia,wk,a,ja,ia,ierr)
c-----------------------------------------------------------------------
c     LOOP THROUGH PRECONDITONERS
c-----------------------------------------------------------------------
         droptol = tol
         lfil = lf
         kk = 0
         do 500 ipre = ipre1, ipre2
c-----------------------------------------------------------------------
c     ipre = 1 --> ILUD
c     ipre = 2 --> ILUT
c     ipre = 3 --> ILUDP
c     ipre = 4 --> ILUTP
c     ipre = 5 --> ILUK
c-----------------------------------------------------------------------
            lfil = lf
            droptol = tol
            do 350 itp =1, niter
               do k=1,n
                  sol(k) = 1.0
               enddo
c
               call amux (n, sol, rhs, a, ja, ia)
c
               goto (1,2,3,4) ipre
c
 1             continue
               call ilud (n,a,ja,ia,alph,droptol,alu,jlu,ju,iwk,
     *              w,jw,ierr)
               if (ierr .ne. 0) write (7,*) ' ilud ierr = ', ierr
               call stb_test(n,rhs,alu,jlu,ju,t)
               write (7,*) ' ILUD-drpt =', droptol, ' stbtest = ', t
               write (7,*) '  --- fill-in =', jlu(n+1)-jlu(1)
c
               goto 100
 2             continue
c
               call ilutn (n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,
     *              ierr)
               if (ierr .ne. 0) write (7,*) ' ILUT ierr = ', ierr
               call stb_test(n,rhs,alu,jlu,ju,t)
               write (7,*) ' ILUT-drpt =', droptol,
     *              ' lfil = ', lfil, ' stbtest = ', t
               write (7,*) '  --- fill-in =', jlu(n+1)-jlu(1)
c
               goto 100
c
c     pivoting codes
c
 3             continue
               mbloc = n
               call iludp (n,a,ja,ia,alph,droptol,permtol,mbloc,alu,
     *              jlu,ju,iwk,w,jw,iperm,ierr)
               if (ierr .ne. 0) write (7,*) ' ilud ierr = ', ierr
               call stb_test(n,rhs,alu,jlu,ju,t)
               write (7,*) ' ILUD-drpt =', droptol, ' stbtest = ', t
               write (7,*) '  --- fill-in =', jlu(n+1)-jlu(1)
               goto 100
 4             continue
               mbloc = n
               call ilutpn (n,a,ja,ia,lfil,droptol,permtol,mbloc,alu,
     *              jlu,ju,iwk,w,jw,iperm,ierr)
               if (ierr .ne. 0) write (7,*) ' milutp ierr = ', ierr
c
               call stb_test(n,rhs,alu,jlu,ju,t)
               write (7,*) ' ILUTP-drpt =', droptol,
     *              ' lfil = ', lfil, ' stbtest = ', t
               write (7,*) '  --- fill-in =', jlu(n+1)-jlu(1)

               goto 100
 5             continue
c
               call ilukn(n,a,ja,ia,lfil,alu,jlu,ju,levs,iwk,w,jw,ierr)
               if (ierr .ne. 0) write (7,*) ' ILUT ierr = ', ierr
               call stb_test(n,rhs,alu,jlu,ju,t)
               write (7,*) ' ILUK -- lfil = ', lfil,' stbtest = ', t
               write (7,*) '  --- fill-in =', jlu(n+1)-jlu(1)
c               goto 100
c     -----------
c     big loop --
c     -----------
 100        continue

            do 11 k=1,n
               sol(k) = 1.0
 11         continue

            call amux (n, sol, rhs, a, ja, ia)
            do 12 j=1, n
               sol(j) = rand(j)
 12         continue
            its = 0
c-----------------------------------------------------------------------
 10         continue
c
            call fgmr (n,im,rhs,sol,it,wk,ipo,ipi,eps,maxits,0,icode)
c-----------------------------------------------------------------------
            if (icode.eq.1) then
               call amux(n, wk(ipo), wk(ipi), a, ja, ia)
               its =  its+1
               goto 10
            else if (icode.eq.3 .or. icode.eq.5) then
c
c     output the residuals here ...
c
               if (ipre .eq. 0) then
c     NOPRE
                  call dcopy(n, wk(ipo),1,wk(ipi),1)
               else
                  call lusol(n,wk(ipo),wk(ipi),alu,jlu,ju)
               endif
               goto 10
            endif
c
c     done ***
c
            call amux(n,sol,wk,a,ja,ia)
c
            do i = 1, n
               wk(n+i) = sol(i) -1.0D0
               wk(i) = wk(i) - rhs(i)
            end do
c
            kk = kk+1
            iters(kk) = its
c     res(kk) = dnrm2(n,wk,1)
c     err(kk) = dnrm2(n,wk(n+1),1)
            write (iout, *) '# actual residual norm ', dnrm2(n,wk,1)
            write (iout, *) '# error norm ', dnrm2(n,wk(1+n),1)
c
            droptol = droptol*dropinc
            lfil = lfil + lfinc
c
c     pivoting codes
c
            if (ipre .ge. 3)  then
               do k=1, ia(n+1)-1
                  ja(k) = iperm(ja(k))
               enddo
            endif
 350        continue
c
 500     continue
         call entline(outf,filnam,iters,kk)
         close (imat)
 300  continue
      stop
c-------------end-of-main-program-ilut_solve_new------------------------
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      function distdot(n,x,ix,y,iy)
      integer n, ix, iy
      real*8 distdot, x(*), y(*), ddot
      external ddot
      distdot = ddot(n,x,ix,y,iy)
      return
c-----end-of-distdot
c-----------------------------------------------------------------------
      end
c-----------------------------------------------------------------------
      subroutine entline(outf,mat,its,kk)
      implicit none
      integer outf, kk,its(kk),k
      character mat*70
c      real*8 err(kk), res(kk)
c-----------------------------------------------------------------------
      write(outf,100)  mat(19:29),(its(k),k=1,8)
 100  format
     * (a,' & ', 8(i4,' & '),'\\\\ \\hline')
      return
      end
c-----------------------------------------------------------------------
      subroutine stb_test(n,sol,alu,jlu,ju,tmax)
      implicit none
      integer n, jlu(*),ju(*)
      real*8 sol(n),alu(*),tmax
c-----------------------------------------------------------------------
      real*8 max, t, abs
      integer j
c
      call lusol(n,sol,sol,alu,jlu,ju)
c
      tmax = 0.0
      do j=1, n
         t = abs(sol(j))
         tmax = max(t,tmax)
      enddo
      return
      end


c ==============================================================================
c =                                                                            =
c = Author: Sylwester Wysocki <sw143@wp.pl>                                    =
c = Created on: 2008                                                           =
c =                                                                            =
c = This is free and unencumbered software released into the public domain.    =
c =                                                                            =
c = Anyone is free to copy, modify, publish, use, compile, sell, or            =
c = distribute this software, either in source code form or as a compiled      =
c = binary, for any purpose, commercial or non-commercial, and by any          =
c = means.                                                                     =
c =                                                                            =
c = In jurisdictions that recognize copyright laws, the author or authors      =
c = of this software dedicate any and all copyright interest in the            =
c = software to the public domain. We make this dedication for the benefit     =
c = of the public at large and to the detriment of our heirs and               =
c = successors. We intend this dedication to be an overt act of                =
c = relinquishment in perpetuity of all present and future rights to this      =
c = software under copyright law.                                              =
c =                                                                            =
c = THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,            =
c = EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF         =
c = MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.     =
c = IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR          =
c = OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,      =
c = ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR      =
c = OTHER DEALINGS IN THE SOFTWARE.                                            =
c =                                                                            =
c = For more information, please refer to <https://unlicense.org>              =
c =                                                                            =
c ==============================================================================

c123456
c=============================================
c== Oblicza macierz calek nakrywania <p|q>  ==
c==                                         ==
c==     S = macierz calek nakrywania (WY)   ==
c=============================================

      subroutine ComputeOverlap(S)
        IMPLICIT NONE
        real*8 Base(1000,2)                           ! {wyk,C}
        integer BaseIndex(100)                        ! index w bazie dla danej
                                                      ! liczby atomowej

        integer Norb                                  ! ile orbitali AO
        real*8 AO(1000,5)                             ! lista orbitali AO
                                                      ! (index,m,x,y,z)
        COMMON /BASE/ Base, BaseIndex
        COMMON /AO/ AO,Norb

        integer  p,q
        integer  i,j

        real*8  suma
        real*8  S(Norb,Norb)                         ! macierz cal. nakryw.

        real*8  wp,wq                                ! wykladniki p i q
        real*8  cp,cq                                ! wsp. kontrakcji
        real*8  X                                    ! zm. pomocnicza
        real*8  Rpq,Rpq2                             ! odl. miedzy centrami
        real*8  dx,dy,dz                             ! roznice wsp. cetrow

        integer  lp,lq
        integer  np,nq
        integer  Ip,Iq
        integer  Ilep, Ileq

        do p=1,Norb
          do q=p,Norb
            Ip = AO(p,1)                             ! znajdz indeksy
            Iq = AO(q,1)                             ! orbitali w bazie

            lp = Base(Ip,1)                          ! pobierz typ
            lq = Base(Iq,1)                          ! orbitalu (l)

            Ilep = Base(ip,2)                        ! ile prymitywnych
            Ileq = Base(iq,2)                        ! gaussow?

            ip = ip + 1                              ! przeskocz do
            iq = iq + 1                              ! danych prymitywow

c           ===========================
c           = odleglosc miedzy centr. =
c           ===========================

            dx = AO(p,3)-AO(q,3)
            dy = AO(p,4)-AO(q,4)
            dz = AO(p,5)-AO(q,5)
            Rpq2 = (dx*dx + dy*dy + dz*dz)

c           =========================
c           = licz calke nakrywania =
c           =========================

            suma = 0.0
            do i=ip, ip+Ilep -1
              wp = Base(i,1)
              cp = Base(i,2)

              do j=iq, iq+Ileq -1
                wq = Base(j,1)
                cq = Base(j,2)

                X = (2.*wp*wq)/(wp+wq)

                suma = suma + cp*cq*(wp*wq)**(-0.75)
     &                      * X**(1.5)
     &                      * exp(-0.5*X*Rpq2)
              enddo
            enddo

            S(p,q) = suma
            S(q,p) = suma
          enddo
        enddo
      end subroutine

c=============================================
c== Oblicza macierz calek jednoelekt.<p|h|q>==
c==                                         ==
c==     h = macierz calek nakrywania (WY)   ==
c=============================================

      subroutine ComputeOneElectron (h)
        IMPLICIT NONE
        integer Nat                                  ! ile atomow
        real*8 GEOM(1000,4)                          ! geometria (3 wsp. + Z)
        real*8 Base(1000,2)                          ! {wyk,C}
        integer BaseIndex(100)                       ! index w bazie dla danej
                                                     ! liczby atomowej

        integer Norb                                 ! ile orbitali AO
        real*8 AO(1000,5)                            ! lista orbitali AO
                                                     ! (index,m,x,y,z)

        COMMON /BASE/ Base, BaseIndex
        COMMON /GEOM/ GEOM,Nat
        COMMON /AO/ AO,Norb

        real*8 F0
        integer p,q
        integer i,j

        real*8 suma
        real*8 h(Norb,Norb)                         ! calki jednoelektr.

        real*8 wp,wq                                ! wykladniki p i q
        real*8 cp,cq                                ! wsp. kontrakcji
        real*8 X                                    ! zm. pomocnicza
        real*8 Rpq,Rpq2, R2                         ! odl. miedzy centrami
        real*8 dx,dy,dz                             ! roznice wsp. cetrow
        real*8 xa,ya,za                             ! odl. od atomu
        real*8 rox,roy,roz

        integer lp,lq
        integer np,nq
        integer Ip,Iq
        integer Ilep, Ileq
        integer a                                   ! numer atomu
        real*8 Tpq,Vpq, S
        real*8 t                                    ! pomocnicza do F0
        real*8 c

        do p=1,Norb
          do q=p,Norb
            Ip = AO(p,1)                            ! znajdz indeksy
            Iq = AO(q,1)                            ! orbitali w bazie

            lp = Base(Ip,1)                         ! pobierz typ
            lq = Base(Iq,1)                         ! orbitalu (l)

            Ilep = Base(ip,2)                       ! ile prymitywnych
            Ileq = Base(iq,2)                       ! gaussow?

            ip = ip + 1                             ! przeskocz do
            iq = iq + 1                             ! danych prymitywow

c           ===========================
c           = odleglosc miedzy centr. =
c           ===========================

            dx = AO(p,3)-AO(q,3)
            dy = AO(p,4)-AO(q,4)
            dz = AO(p,5)-AO(q,5)
            Rpq2 = (dx*dx + dy*dy + dz*dz)

c           ==============
c           = licz calki =
c           ==============

            Tpq = 0.0
            Vpq = 0.0

            do i=ip, ip+Ilep -1
              wp = Base(i,1)
              cp = Base(i,2)

              do j=iq, iq+Ileq -1
                wq = Base(j,1)
                cq = Base(j,2)

c               =========================
c               = licz calke nakrywania =
c               =========================

                X = (2.*wp*wq)/(wp+wq)
                S = cp*cq* (2.*X/(wp+wq))**(0.75)*exp(-0.5*X*Rpq2)

c               =========================
c               = licz calke en. kinet. =
c               =========================

                Tpq = Tpq + X*(1.5-0.5*X*Rpq2)*S

c               =========================
c               = licz calke prz. jadr. =
c               =========================

                rox = (wp*AO(p,3)+wq*AO(q,3))/(wp+wq)
                roy = (wp*AO(p,4)+wq*AO(q,4))/(wp+wq)
                roz = (wp*AO(p,5)+wq*AO(q,5))/(wp+wq)

                do a=1,Nat
                  xa = GEOM(a,1) - rox
                  ya = GEOM(a,2) - roy
                  za = GEOM(a,3) - roz
                  R2 = (xa*xa + ya*ya + za*za)

                  t = (wp+wq)*R2
                  c = - 1.12837916709551257*GEOM(a,4)*sqrt(wp+wq)

                  Vpq= Vpq + c*F0(t)*S
                enddo
              enddo
            enddo
            h(p,q) = Vpq + Tpq
            h(q,p) = h(p,q)
          enddo
        enddo
      end subroutine

c=============================================
c== Oblicza macierz calek dwuelektr..<p|G|q>==
c==                                         ==
c==     G = macierz calek nakrywania (WY)   ==
c=============================================

      subroutine ComputeTwoElectron (G)
        IMPLICIT NONE
        integer Nat                                   ! ile atomow
        real*8 GEOM(1000,4)                           ! geometria (3 wsp. + Z)
        real*8 Base(1000,2)                           ! {wyk,C}
        integer BaseIndex(100)                        ! index w bazie dla danej
                                                      ! liczby atomowej

        integer Norb                                  ! ile orbitali AO
        real*8 AO(1000,5)                             ! lista orbitali AO
                                                      ! (index,m,x,y,z)
        COMMON /BASE/ Base, BaseIndex
        COMMON /GEOM/ GEOM,Nat
        COMMON /AO/ AO,Norb

        real*8 F0
        integer r,s,p,q
        integer i,j,k,l

        real*8 suma
        real*8 G(Norb,Norb,Norb,Norb)               ! calki dwuelektr.

        real*8 wr,ws,wp,wq                          ! wykladniki p i q
        real*8 cr,cs,cp,cq                          ! wsp. kontrakcji
        real*8 X                                    ! zm. pomocnicza
        real*8 Rpq2,Rrs2                            ! odl. miedzy centrami
        real*8 Ro2                                  ! odl. miedyz nowymi c.
        real*8 dx,dy,dz                             ! roznice wsp. cetrow
        real*8 xrs,yrs,zrs                          ! wsp. nowego centrum
        real*8 xpq,ypq,zpq                          ! wsp. nowego centrum
        real*8 Rpq,Rrs

        integer lr,ls,lp,lq
        integer nr,ns,np,nq
        integer Ir,Is,Ip,Iq
        integer Iler,Iles,Ilep, Ileq

        real*8 Srs, Spq
        real*8 t                                    ! pomocnicza do F0
        real*8 c
        real*8 PI

        parameter (PI=3.14159265358979324)

        do r=1,Norb
          do s=1,Norb
            do p=1,Norb
              do q=1,Norb
                Ir = AO(r,1)                        ! znajdz indeksy
                Is = AO(s,1)                        ! orbitali w bazie
                Ip = AO(p,1)                        ! znajdz indeksy
                Iq = AO(q,1)                        ! orbitali w bazie

                lr = Base(Ir,1)                     ! pobierz typ
                ls = Base(Is,1)                     ! orbitalu (l)
                lp = Base(Ip,1)                     ! pobierz typ
                lq = Base(Iq,1)                     ! orbitalu (l)

                Iler = Base(ir,2)                   ! ile prymitywnych
                Iles = Base(is,2)                   ! gaussow?
                Ilep = Base(ip,2)                   ! ile prymitywnych
                Ileq = Base(iq,2)                   ! gaussow?

                ir = ir + 1                         ! przeskocz do
                is = is + 1                         ! danych prymitywow
                ip = ip + 1                         ! przeskocz do
                iq = iq + 1                         ! danych prymitywow

c               ===========================
c               = licz odl. miedzy centr. =
c               ===========================

                dx = AO(p,3)-AO(q,3)
                dy = AO(p,4)-AO(q,4)
                dz = AO(p,5)-AO(q,5)
                Rpq2 = (dx*dx + dy*dy +dz*dz)

                dx = AO(r,3)-AO(s,3)
                dy = AO(r,4)-AO(s,4)
                dz = AO(r,5)-AO(s,5)
                Rrs2 = (dx*dx + dy*dy +dz*dz)

c               ==============
c               = licz calki =
c               ==============

                suma = 0.0

                do i=ir, ir+Iler -1
                  wr = Base(i,1)
                  cr = Base(i,2)

                  do j=is, is+Iles -1
                    ws = Base(j,1)
                    cs = Base(j,2)

                    do k=ip, ip+Ilep -1
                      wp = Base(k,1)
                      cp = Base(k,2)

                      do l=iq, iq+Ileq -1
                        wq = Base(l,1)
                        cq = Base(l,2)

c                       =========================
c                       = licz calki nakrywania =
c                       =========================

                        X = (2.*wp*wq)/(wp+wq)

                        Spq = cp*cq*(wp*wq)**(-0.75)*X**(1.5)
     &                      * exp(-0.5*X*Rpq2)

                        X = (2.*wr*ws)/(wr+ws)

                        Srs = cr*cs*(wr*ws)**(-0.75)*X**(1.5)
     &                      * exp(-0.5*X*Rrs2)

c                       =========================
c                       = licz calke dwuelektr. =
c                       =========================

                        xrs = (wr*AO(r,3)+ws*AO(s,3))/(wr+ws)
                        yrs = (wr*AO(r,4)+ws*AO(s,4))/(wr+ws)
                        zrs = (wr*AO(r,5)+ws*AO(s,5))/(wr+ws)

                        xpq = (wp*AO(p,3)+wq*AO(q,3))/(wp+wq)
                        ypq = (wp*AO(p,4)+wq*AO(q,4))/(wp+wq)
                        zpq = (wp*AO(p,5)+wq*AO(q,5))/(wp+wq)

                        Ro2 = (xrs-xpq)**2 + (yrs-ypq)**2 + (zrs-zpq)**2

                        X = (wr+ws)*(wp+wq)/(wr+ws+wp+wq)
                        c = 1.12837916709551257 * sqrt(X)          ! 2*sqr(X/pi)
                        t = X*Ro2

                        suma = suma + c*F0(t)*Srs*Spq
                      enddo
                    enddo
                  enddo
                enddo

                G(p,r,q,s) = suma
              enddo
            enddo
          enddo
        enddo
      end subroutine


      double precision function fastj_gaussian_range(n, alpha, eps)
*
* $Id$
*
      implicit none
c
      integer n
      double precision alpha, eps
c
c     Return an approximation to the outer solution of
c     .     r^n*exp(-ar^2) = eps
c     .     r = (n*ln(-ln(eps)) - n*ln(a) - 4*ln(eps)) /
c     .         4*sqrt(-alpha*ln(eps))
c
c     Accuracy improves with smaller eps.
c
      double precision logeps
c
      logeps = log(eps)
c
      fastj_gaussian_range =
     $     (n*log(-logeps) - n*log(alpha) - 4.0d0*logeps) /
     $     sqrt(-16.0d0*alpha*logeps)
c
      end

      double precision function fnlm(n,l,m,alpha,a,b,c,x,y,z)
      implicit none
c
      integer n, l, m
      double precision alpha, a, b, c, x, y, z
c
c     r^(n-l) Xlm exp(-a*r*r) centered about (a,b,c)
c
      double precision rsq, r, radial, q(-10:10,0:10)
c
      rsq = (x-a)**2 + (y-b)**2 + (z-c)**2
      r   = sqrt(rsq)
c
      radial = exp(-alpha*rsq)
      if (n .ne. l) radial = radial * r**(n-l)
c
      call xlm(l, x-a, y-b, z-c, q, 10)
c
      fnlm = radial * q(m,l)
c
*      if (r .lt. 0.5d0) then
*         write(6,*) n, l, m, alpha, a, b, c, x, y, z, r
*         call xlm_print(l, q, 10)
*         write(6,*) radial, q(m,l), radial
*      end if
c
**      fnlm = exp(-alpha*rsq) * (z-c)
c
      end
      double precision function vnlm(n,l,m,alpha,a,b,c,x,y,z)
      implicit none
c
      integer n, l, m
      double precision alpha, a, b, c, x, y, z
c
c     Return the potential due to
c         r^(n-l) Xlm exp(-a*r*r) centered about (a,b,c)
c
c     A(sqrt(a)*r) * 4*pi/(a**((n+2)/2)) * Xlm / r^l
c
c     A(x) = (0.5*x**(n-l) (n+l+1)F((n+l)/2,x**2) + (n-l)**I(n-l-1)/2)
c     .         / (2l+1)
c
c
      double precision rsq, r, radial, q(-10:10,0:10)
      double precision anl_fit
      external anl
c
      rsq = (x-a)**2 + (y-b)**2 + (z-c)**2
      r   = sqrt(rsq)
c
      radial = anl_fit(
     $     n,l,sqrt(alpha)*r) * 4.0d0 * 3.1415926535897932d0 /
     $     (alpha**(dble(n-l+2)/2.0d0))
c
      call xlm(l, x-a, y-b, z-c, q, 10)
      vnlm = radial * q(m,l)

**      vnlm = radial * (z-c)
c
      end
      double precision function fastj_r_neglected(k, alpha, eps)
      implicit none
c
      integer k
      double precision alpha, eps
c
c     For a function f(r) = r^k*exp(-alpha*r^2) determine
c     the radial distance r such that the fraction of the
c     function norm that is neglected if the 3D volume
c     integration is terminated at a distance r is less
c     than or equal to eps.
c
c     The returned value is accurate to about 0.01.
c
      double precision r, test, fastj_neglected, step
c
      r = sqrt(-log(eps)/alpha)
      step = 0.125d0*r
 10   test = fastj_neglected(k,alpha,r)
**      write(6,*) ' r error ', r, test
      if (test .gt. eps) then
         r = r + step
      else
         r = r - step
         if (r .lt. 0.0d0) r = 0.0d0
         step = step*0.5d0
         r = r + step
      endif
      if (step .gt. 0.01d0) goto 10
c
      fastj_r_neglected = r
c
      end
      double precision function fastj_neglected(k,alpha,r)
      implicit none
c
      integer k
      double precision alpha, r
c
c     For a function f(r) = r^k*exp(-alpha*r^2) determine
c     the fraction of the function norm that is neglected
c     if the 3D volume integration is terminated at a
c     distance r.
c
c     neglected = int(t^2*f(t),t=r..infinity)/int(t^2*f(t),t=0..infinity)
c
      double precision fastj_ik
c
      fastj_neglected = fastj_ik(k+2,alpha,r) /
     $     fastj_ik(k+2,alpha,0.0d0)
c
      end
      double precision function fastj_ik(k,alpha,r)
      implicit none
c
      integer k
      double precision alpha, r
c
c     I(k) = int(t^k exp(-alpha*t^2), t=0..infinity)
c
c     I(k) = [(k-1)*I(k-2) + r^(k-1)*exp(-alpha*r^2)]/(2*alpha)
c
      integer i, ilo
      double precision value
c
      double precision erfc
c
      ilo = mod(k,2)
c
      if (ilo .eq. 0) then
         value = 0.5d0*sqrt(4.0d0*atan(1.0d0)/alpha)*
     $        erfc(sqrt(alpha)*r)
      else
         value = exp(-alpha*r*r)/(2.0d0*alpha)
      endif
c
      do i = ilo+2,k,2
         value = ((i-1)*value + r**(i-1)*exp(-alpha*r*r)) /
     $        (2.0d0*alpha)
      enddo
c
      fastj_ik = value
c
      end


C Contains some character declarations
      SUBROUTINE H03ABF(KOST,MMM,MA,MB,M,K15,MAXIT,K7,K9,NUMIT,K6,K8,
     *                  K11,K12,Z,IFAIL)
C     NAG COPYRIGHT 1975
C     MARK 4.5 REVISED
C     MARK 6 REVISED  IER-91
C     MARK 7C REVISED IER-189 (MAY 1979)
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     H03ABF SOLVES THE CLASSICAL TRANSPORTATION PROBLEM IN THAT IT
C     MINIMIZES THE COST OF SENDING GOODS FROM SOURCES TO
C     DESTINATIONS
C     SUBJECT TO CONSTRAINTS ON THE AVAILABILITIES AND
C     REQUIREMENTS.
C     .. Parameters ..
      CHARACTER*6     SRNAME
      PARAMETER         (SRNAME='H03ABF')
C     .. Scalar Arguments ..
      DOUBLE PRECISION  Z
      INTEGER           IFAIL, M, MA, MAXIT, MB, MMM, NUMIT
C     .. Array Arguments ..
      INTEGER           K11(M), K12(M), K15(M), K6(M), K7(M), K8(M),
     *                  K9(M), KOST(MMM,MB)
C     .. Local Scalars ..
      DOUBLE PRECISION  X
      INTEGER           I, II, INF, J, J11, J21, J22, J23, J24, J25,
     *                  J26, J27, J28, JC, JV, KI, KJ, KK, KKK, L, LC,
     *                  LCK, LD, LDEL, LF, LR, LRH, LRK, LRMI, LSTA, LT,
     *                  LTK, LTMI, LV, LVK, LVMI, LX, M1, MIN, MU
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      INTEGER           P01ABF, X02BBF
      EXTERNAL          P01ABF, X02BBF
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE
C     .. Executable Statements ..
      NUMIT = 0
      IF (MA) 180, 180, 20
   20 IF (MB) 180, 180, 40
   40 IF (MA-MMM) 60, 60, 180
   60 IF (MAXIT) 160, 160, 80
   80 IF (M-MA-MB) 180, 100, 180
  100 KKK = 0
      DO 120 I = 1, MA
         KKK = KKK + K15(I)
  120 CONTINUE
      II = MA + 1
      DO 140 I = II, M
         KKK = KKK - K15(I)
  140 CONTINUE
      IF (KKK) 200, 220, 200
  160 KKK = 3
      GO TO 1660
  180 KKK = 4
      GO TO 1660
  200 KKK = 1
      GO TO 1660
  220 M1 = M - 1
      INF = X02BBF(X)
      K11(M) = 0
      DO 240 I = 1, MA
         K7(I) = I
  240 CONTINUE
      DO 260 I = 1, MB
         K9(I) = I
  260 CONTINUE
      LTK = 0
      KI = MA
      KJ = MB
      MIN = INF
      DO 320 I = 1, MA
         DO 300 J = 1, MB
            IF (KOST(I,J)-MIN) 280, 300, 300
  280       MIN = KOST(I,J)
            LRMI = I
            LTMI = J
  300    CONTINUE
  320 CONTINUE
C
C     KOST(LRMI,LTMI) CONTAINS THE SMALLEST COST COFFICIENT IN
C     ARRAY KOST
C
      LVMI = LTMI + MA
      IF (K15(LRMI)-K15(LVMI)) 340, 360, 360
  340 LDEL = K15(LVMI)
      K9(LTMI) = K9(KJ)
      KJ = KJ - 1
      LSTA = -1
      GO TO 380
  360 LDEL = K15(LRMI)
      K7(LRMI) = K7(KI)
      KI = KI - 1
      LSTA = 1
C
C     LDEL CONTAINS THE MAX OF THE ROW OR COL TOTALS,LSTA=1 IF THE
C     ROW
C     IS THE MAXIMUM OR =0 OTHERWISE. APPROPRIATE MARKERS ARE SET
C     IN K14.
C
  380 DO 640 I = 1, M1
  400    LSTA = -LSTA
         MIN = INF
         IF (LSTA) 500, 500, 420
  420    K8(I) = LVMI
         IF (KI) 400, 400, 440
  440    DO 480 J = 1, KI
            II = K7(J)
            IF (KOST(II,LTMI)-MIN) 460, 460, 480
  460       MIN = KOST(II,LTMI)
            LRMI = II
            KK = J
  480    CONTINUE
         LF = LRMI
         K7(KK) = K7(KI)
         KI = KI - 1
         K6(I) = LF
         GO TO 580
  500    K6(I) = LRMI
         IF (KJ) 400, 400, 520
  520    DO 560 J = 1, KJ
            II = K9(J)
            IF (KOST(LRMI,II)-MIN) 540, 540, 560
  540       MIN = KOST(LRMI,II)
            LTMI = II
            KK = J
  560    CONTINUE
         LF = LTMI + MA
         K9(KK) = K9(KJ)
         KJ = KJ - 1
         LVMI = LF
         K8(I) = LF
  580    K12(I) = MIN
         LD = LDEL - K15(LF)
         IF (LD) 600, 620, 620
  600    K11(I) = LDEL
         LDEL = -LD
         GO TO 640
  620    K11(I) = K15(LF)
         LDEL = LD
         LSTA = -LSTA
  640 CONTINUE
  660 IF (NUMIT-MAXIT) 700, 680, 680
  680 KKK = 2
      GO TO 1660
  700 NUMIT = NUMIT + 1
      DO 720 I = 1, M
         K7(I) = 0
         K15(I) = 0
  720 CONTINUE
      LR = K6(1)
      K7(LR) = 1
      LT = 1
  740 DO 880 I = 1, M1
         IF (K15(I)) 760, 760, 880
  760    LR = K6(I)
         LV = K8(I)
         IF (K7(LR)) 800, 800, 780
  780    K7(LV) = 1
         K9(LT) = I
         GO TO 840
  800    IF (K7(LV)) 880, 880, 820
  820    K7(LR) = 1
         K9(LT) = -I
  840    K15(I) = 1
         IF (LT-M1) 860, 900, 900
  860    LT = LT + 1
  880 CONTINUE
      GO TO 740
  900 DO 920 I = 1, M1
         MU = ABS(K9(I))
         K7(I) = K6(MU)
         K15(I) = K8(MU)
  920 CONTINUE
C
C
C
      DO 940 I = 1, M1
         K6(I) = K7(I)
         K8(I) = K15(I)
  940 CONTINUE
C
C
      DO 960 I = 1, M1
         MU = ABS(K9(I))
         K7(I) = K11(MU)
         K15(I) = K12(MU)
  960 CONTINUE
      DO 980 I = 1, M1
         K11(I) = K7(I)
         K12(I) = K15(I)
  980 CONTINUE
C
      LR = K6(1)
      K7(LR) = 0
      LV = K8(1)
      K7(LV) = 0
C
      DO 1040 I = 1, M1
         LR = K6(I)
         LV = K8(I)
         LC = K12(I)
         IF (K9(I)) 1000, 1020, 1020
 1000    K7(LR) = LC - K7(LV)
         GO TO 1040
 1020    K7(LV) = LC - K7(LR)
 1040 CONTINUE
C
      MIN = 0
      DO 1100 I = 1, MA
         DO 1080 J = 1, MB
            LV = J + MA
            L = KOST(I,J) - K7(I) - K7(LV)
            IF (L-MIN) 1060, 1080, 1080
 1060       MIN = L
            LRK = I
            LTK = J
 1080    CONTINUE
 1100 CONTINUE
C
      LVK = LTK + MA
      IF (MIN) 1120, 1620, 1620
 1120 LCK = KOST(LRK,LTK)
      K6(M) = LRK
      K8(M) = LVK
      DO 1140 I = 1, M
         K9(I) = -1
 1140 CONTINUE
C
      DO 1220 I = 1, M1
         J = K6(I)
         IF (K9(J)) 1160, 1180, 1180
 1160    K9(J) = I
 1180    J = K8(I)
         IF (K9(J)) 1200, 1220, 1220
 1200    K9(J) = I
 1220 CONTINUE
C
      MU = M
      J21 = -1
      J22 = INF
      J23 = M
      J24 = 1
      J25 = INF
      J26 = 0
      JV = M
      JC = 1
      K7(JC) = M
      GO TO 1340
 1240 IF (J21) 1260, 1260, 1280
 1260 JC = JC + 1
      K7(JC) = J28
      GO TO 1300
 1280 K7(JV) = J28
      JV = JV - 1
 1300 MU = J28
      J26 = 1 - J26
 1320 IF (J26) 1360, 1340, 1360
 1340 J27 = K6(MU)
      GO TO 1380
 1360 J27 = K8(MU)
 1380 IF (J27-J25) 1400, 1440, 1400
 1400 J28 = K9(J27)
      IF (J28-J22) 1420, 1240, 1240
 1420 J22 = J28
      J11 = MU
      MU = J23
      J23 = J11
      I = J26
      J26 = J24
      J24 = I
      J25 = J27
      J21 = -J21
      GO TO 1320
C
C
C
 1440 IF (JV-M) 1460, 1540, 1460
 1460 IF (JC-JV) 1480, 1520, 1480
 1480 JV = JV + 1
      DO 1500 I = JV, M
         JC = JC + 1
         K7(JC) = K7(I)
 1500 CONTINUE
      GO TO 1540
 1520 JC = M
 1540 MIN = INF
      DO 1580 I = 2, JC, 2
         MU = K7(I)
         LX = K11(MU)
         IF (LX-MIN) 1560, 1580, 1580
 1560    MIN = LX
         LRH = MU
 1580 CONTINUE
      K6(LRH) = LRK
      K8(LRH) = LVK
      DO 1600 I = 1, JC, 2
         MU = K7(I)
         K11(MU) = K11(MU) + MIN
         MU = K7(I+1)
         K11(MU) = K11(MU) - MIN
 1600 CONTINUE
      K11(LRH) = MIN
      K12(LRH) = LCK
      GO TO 660
C
 1620 Z = 0.D0
      DO 1640 I = 1, M1
         Z = Z + DBLE(K11(I)*K12(I))
         K8(I) = K8(I) - MA
 1640 CONTINUE
C
      IFAIL = 0
      RETURN
 1660 IFAIL = P01ABF(IFAIL,KKK,SRNAME,0,P01REC)
      RETURN
      END


      subroutine nin(mmax,nmax,f,y,y0,h,idir)
c---------------------------------------------------------------------
c                  numerische integration
c---------------------------------------------------------------------
c     mmax ... anzahl punkte
c     f   ... zu integrierende funktion
c     y   ... integralfunktion
c     y0  ... startwert
c     h   ... schrittweite
c     idir... integrationsrichtung   1: von unten nach oben
c                                   -1: von oben  nach unten
c---------------------------------------------------------------------
      implicit none

      integer mmax,nmax,idir,m,j,z
      real p1,p2,p3,h,y0
      real f(mmax,nmax)
      real y(mmax,nmax)

      p1=h/24.
      p2=13.*p1
      p3=h/3.
      if (idir.eq.1) then
        do z=1,nmax
          y(1,z)=y0
          y(2,z)=y(1,z)+p1*(9.*f(1,z)+19.*f(2,z)-5.*f(3,z)+f(4,z))
          j=mmax-1
          do 100 m=3,mmax-1
            y(m,z)=y(m-1,z)-p1*(f(m-2,z)+f(m+1,z))+p2*(f(m-1,z)+f(m,z))
 100      continue
          y(mmax,z)=y(j-1,z)+p3*(f(j-1,z)+4.*f(j,z)+f(mmax,z))
        enddo
      else
        do z=1,nmax
         y(mmax  ,z) = y0
         y(mmax-1,z) = y(1,z)+p1*(9.*f(1,z)+19.*f(2,z)-5.*f(3,z)+f(4,z))
         j=2
         do 200 m=mmax-2,2,-1
           y(m,z)=y(m+1,z)-p1*(f(m+2,z)+f(m-1,z))+p2*(f(m+1,z)+f(m,z))
 200     continue
         y(1,z)=y(j+1,z)+p3*(f(j+1,z)+4.*f(j,z)+f(1,z))
        enddo
      endif
      return
      end


      SUBROUTINE SPLINE2
     &          (mxx,nrx,xi,xd,xb,xs,xdp,
     &           mxy,nry,yi,yd,yb,ys,ydp,
     &           fi,pi,fx,fxy,pf,init)

c***********************************************************************

c     Two dimensional interpolation using cubic splines. The procedure
c     is as follows:

c        Use the function Fi(i,j) to compute spline coefficients x'';
c        interpolate onto the y plane at x;
c        call these interpolated values Fx(j).

c        Use Fx(j) to compute spline coefficients y'';
c        interpolate in y to get Fxy at x,y.

c     The derivatives of Fxy: dFdx, dFdy, are returned in PF.
c     The derivatives are calculated analytically.

c***********************************************************************

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

      logical       init
      integer       xflag,yflag
      real     *  8 xi (mxx),    yi (mxy),
     &              xd (mxx,mxx),yd (mxy,mxy),
     &              xb (mxx),    yb (mxy),
     &              xs (mxx),    ys (mxy),
     &              xdp(mxx,mxy),ydp(mxy),
     &              fi (mxx,mxy),fx (mxy),
     &              pi(2),fxy,pf(2)

      if (init) then

         init=.false.

cxxcDEBUG
cxx         write(4,'(''x''/(8(i4,f8.2)))')
cxx     &        (i,xi(i),i=1,nrx)
cxx         write(4,'(''y''/(8(i4,f8.2)))')
cxx     &        (j,yi(j),j=1,nry)

c        NOTE:  The order of indices of XD and YD is reversed
c        because DLinEq uses the mathematical convention in which
c        the second index increases faster than the first.

         xflag=0
         do l=2,nrx-1
            j=l-1
            do k=2,nrx-1
               i=k-1
               if (k .eq. l) then
                  xd(j,i)=(xi(k+1)-xi(k-1))/3.
               else
     &         if (k .eq. l-1 .or. k .eq. l+1) then
                  xd(j,i)=(xi(k  )-xi(k-1))/6.
               else
                  xd(j,i)=0.
               end if
            end do
         end do

         yflag=0
         do l=2,nry-1
            j=l-1
            do k=2,nry-1
               i=k-1
               if (k .eq. l) then
                  yd(j,i)=(yi(k+1)-yi(k-1))/3.
               else
     &         if (k .eq. l-1 .or. k .eq. l+1) then
                  yd(j,i)=(yi(k  )-yi(k-1))/6.
               else
                  yd(j,i)=0.
               end if
            end do
         end do

c        Calculate the coefficients for interpolation onto the
c        y plane: x''
         do j=1,nry
            do i=2,nrx-1
               xb(i-1)=(fi(i+1,j)-fi(i  ,j))/(xi(i+1)-xi(i  ))
     &                -(fi(i  ,j)-fi(i-1,j))/(xi(i  )-xi(i-1))
            end do
            call DLinEq (xd,xb,xs,nrx-2,mxx,xflag,err)
            xdp(1,j)=0.
            do i=2,nrx-1
               xdp(i,j)=xs(i-1)
            end do
            xdp(nrx,j)=0.
            xflag=1
         end do
      end if

c     Store current position
      px=pi(1)
      py=pi(2)

c     Find indices for current position
      if (xi(1) .lt. xi(2)) then

c        Xi are in ascending order
         if (px .le. xi(2)) then
            i1=1
            i2=2
         else
     &   if (px .gt. xi(nrx-1)) then
            i1=nrx-1
            i2=nrx
         else
            i2=3
            do while (px .gt. xi(i2))
               i2=i2+1
            end do
            i1=i2-1
         end if
      else

c        Xi are in descending order
         if (px .gt. xi(2)) then
            i1=1
            i2=2
         else
     &   if (px .le. xi(nrx-1)) then
            i1=nrx-1
            i2=nrx
         else
            i2=nrx-2
            do while (px .gt. xi(i2))
               i2=i2-1
            end do
            i1=i2+1
         end if
      end if
      hx=xi(i2)-xi(i1)
      tx=hx**2/6.
      dx1=(px-xi(i1))/hx
      dx2=(px-xi(i2))/hx

      if (yi(1) .lt. yi(2)) then

c        Yi are in ascending order
         if (py .le. yi(2)) then
            j1=1
            j2=2
         else
     &   if (py .gt. yi(nry-1)) then
            j1=nry-1
            j2=nry
         else
            j2=3
            do while (py .gt. yi(j2))
               j2=j2+1
            end do
            j1=j2-1
         end if
      else

c        Yi are in descending order
         if (py .gt. yi(2)) then
            j1=1
            j2=2
         else
     &   if (py .le. yi(nry-1)) then
            j1=nry-1
            j2=nry
         else
            j2=nry-2
            do while (py .gt. yi(j2))
               j2=j2-1
            end do
            j1=j2+1
         end if
      end if
      hy=yi(j2)-yi(j1)
      ty=hy**2/6.
      dy1=(py-yi(j1))/hy
      dy2=(py-yi(j2))/hy

c     Interpolate onto the y axis at x
c     to get the distribution of F along the y axis: Fx
      c1=(dx1-dx1**3)*tx
      c2=(dx2-dx2**3)*tx
      do j=1,nry
         fx(j)=fi(i2,j)*dx1-xdp(i2,j)*c1
     &        -fi(i1,j)*dx2+xdp(i1,j)*c2
      end do

c     Calculate the coefficients for interpolation
c     onto the y axis: y''
      do j=2,nry-1
         yb(j-1)=(fx(j+1)-fx(j  ))/(yi(j+1)-yi(j  ))
     &          -(fx(j  )-fx(j-1))/(yi(j  )-yi(j-1))
      end do
      call DLinEq (yd,yb,ys,nry-2,mxy,yflag,err)
      ydp( 1 )=0.
      do j=2,nry-1
         ydp(j)=ys(j-1)
      end do
      ydp(nry)=0.
      yflag=1

c     Interpolate to the point at x,y: Fxy
      c1=(dy1-dy1**3)*ty
      c2=(dy2-dy2**3)*ty
      fxy=fx(j2)*dy1-ydp(j2)*c1
     &   -fx(j1)*dy2+ydp(j1)*c2

c     Derivatives

c     We currently have the distribution of F along the y axis;
c     calculate dF/dy
      dc1dy=(1.-3.*dy1**2)*ty/hy
      dc2dy=(1.-3.*dy2**2)*ty/hy
      dfdy=fx(j2)/hy-ydp(j2)*dc1dy
     &    -fx(j1)/hy+ydp(j1)*dc2dy

c     Go back to the original distribution of F in the x,y plane;
c     use the coefficients for interpolation onto the y axis to
c     get the distribution of dF/dx along the y axis
      dc1dx=(1.-3.*dx1**2)*tx/hx
      dc2dx=(1.-3.*dx2**2)*tx/hx
      do j=1,nry
         fx(j)=fi(i2,j)/hx-xdp(i2,j)*dc1dx
     &        -fi(i1,j)/hx+xdp(i1,j)*dc2dx
      end do

c     Calculate the coefficients for interpolation
c     onto the x axis
      do j=2,nry-1
         yb(j-1)=(fx(j+1)-fx(j  ))/(yi(j+1)-yi(j  ))
     &          -(fx(j  )-fx(j-1))/(yi(j  )-yi(j-1))
      end do
      call DLinEq (yd,yb,ys,nry-2,mxy,yflag,err)
      ydp( 1 )=0.
      do j=2,nry-1
         ydp(j)=ys(j-1)
      end do
      ydp(nry)=0.

c     Use the coefficients for interpolation onto the x axis to
c     get dF/dx at the point x,y
      c1=(dy1-dy1**3)*ty
      c2=(dy2-dy2**3)*ty
      dfdx=fx(j2)*dy1-ydp(j2)*c1
     &    -fx(j1)*dy2+ydp(j1)*c2

c     Store the derivatives
      pf(1)=dfdx
      pf(2)=dfdy

      RETURN
      END      ! SPLINE2


C     LAST UPDATE 27/02/96
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      REAL FUNCTION GAMMQ(A,X)
      IMPLICIT NONE
C
C Purpose: Calculates the incomplete gamma function Q(a,x) = 1 - P(a,x)
C
C Calls   2: GSER   , GCF
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Arguments:
C
      REAL A,X
C
C Local variables:
C
      REAL GAMSER,GAMMCF,GLN
C
C-----------------------------------------------------------------------
      GAMMQ = 0.0
      IF(X.LT.0.0.OR.A.LE.0.0)THEN
         WRITE(6,1000)
         RETURN
      ENDIF
      IF(X.LT.A+1.0)THEN
         CALL GSER(GAMSER,A,X,GLN)
         GAMMQ = 1.0 - GAMSER
      ELSE
         CALL GCF(GAMMCF,A,X,GLN)
         GAMMQ = GAMMCF
      ENDIF
      RETURN
C
 1000 FORMAT(1X,'Error - invalid argument to gamma function')
      END


      SUBROUTINE SEPX4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1NBDCND,BDC,BDD,COFX,GRHS,USOL,IDMN,W,PERTRB,IERROR)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C
C DIMENSION OF           BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1),
C ARGUMENTS              USOL(IDMN,N+1), GRHS(IDMN,N+1),
C                        W (SEE ARGUMENT LIST)
C
C LATEST REVISION        SEPTEMBER 1996
C
C
C PURPOSE                SEPX4 SOLVES FOR EITHER THE SECOND-ORDER
C                        FINITE DIFFERENCE APPROXIMATION OR A
C                        A FOURTH-ORDER APPROXIMATION  TO THE
C                        SOLUTION OF A SEPARABLE ELLIPTIC EQUATION
C                             AF(X)*UXX+BF(X)*UX+CF(X)*U+UYY = G(X,Y)
C
C                        ON A RECTANGLE (X GREATER THAN OR EQUAL TO A
C                        AND LESS THAN OR EQUAL TO B; Y GREATER THAN
C                        OR EQUAL TO C AND LESS THAN OR EQUAL TO D).
C                        ANY COMBINATION OF PERIODIC OR MIXED BOUNDARY
C                        CONDITIONS IS ALLOWED.
C                        IF BOUNDARY CONDITIONS IN THE X DIRECTION
C                        ARE PERIODIC (SEE MBDCND=0 BELOW) THEN THE
C                        COEFFICIENTS MUST SATISFY
C                        AF(X)=C1,BF(X)=0,CF(X)=C2 FOR ALL X.
C                        HERE C1,C2 ARE CONSTANTS, C1.GT.0.
C
C                        THE POSSIBLE BOUNDARY CONDITIONS ARE
C                        IN THE X-DIRECTION:
C                         (0) PERIODIC, U(X+B-A,Y)=U(X,Y) FOR ALL Y,X
C                         (1) U(A,Y), U(B,Y) ARE SPECIFIED FOR ALL Y
C                         (2) U(A,Y), DU(B,Y)/DX+BETA*U(B,Y) ARE
C                             SPECIFIED FOR ALL Y
C                         (3) DU(A,Y)/DX+ALPHA*U(A,Y),DU(B,Y)/DX+
C                             BETA*U(B,Y) ARE SPECIFIED FOR ALL Y
C                         (4) DU(A,Y)/DX+ALPHA*U(A,Y),U(B,Y) ARE
C                             SPECIFIED FOR ALL Y
C
C                        IN THE Y-DIRECTION:
C                         (0) PERIODIC, U(X,Y+D-C)=U(X,Y) FOR ALL X,Y
C                         (1) U(X,C),U(X,D) ARE SPECIFIED FOR ALL X
C                         (2) U(X,C),DU(X,D)/DY ARE SPECIFIED FOR ALL X
C                         (3) DU(X,C)/DY,DU(X,D)/DY ARE SPECIFIED FOR
C                            ALL X
C                        (4) DU(X,C)/DY,U(X,D) ARE SPECIFIED FOR ALL X
C
C USAGE                  CALL SEPX4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,
C                                  BETA,C,D,N,NBDCND,BDC,BDD,COFX,
C                                  GRHS,USOL,IDMN,W,PERTRB,IERROR)
C
C ARGUMENTS
C
C
C                        IORDER
C                          = 2 IF A SECOND-ORDER APPROXIMATION IS SOUGHT
C                          = 4 IF A FOURTH-ORDER APPROXIMATION IS SOUGHT
C
C                        A,B
C                          THE RANGE OF THE X-INDEPENDENT VARIABLE;
C                          I.E., X IS GREATER THAN OR EQUAL TO A AND
C                          LESS THAN OR EQUAL TO B.  A MUST BE LESS THAN
C                          B.
C
C                        M
C                          THE NUMBER OF PANELS INTO WHICH THE INTERVAL
C                          [A,B] IS SUBDIVIDED.  HENCE, THERE WILL BE
C                          M+1 GRID POINTS IN THE X-DIRECTION GIVEN BY
C                          XI=A+(I-1)*DLX FOR I=1,2,...,M+1 WHERE
C                          DLX=(B-A)/M IS THE PANEL WIDTH.  M MUST BE
C                          LESS THAN IDMN AND GREATER THAN 5.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITION AT
C                          X=A AND X=B
C                          = 0 IF THE SOLUTION IS PERIODIC IN X; I.E.,
C                              U(X+B-A,Y)=U(X,Y) FOR ALL Y,X
C                          = 1 IF THE SOLUTION IS SPECIFIED AT X=A AND
C                              X=B; I.E., U(A,Y) AND U(B,Y) ARE
C                              SPECIFIED FOR ALL Y
C                          = 2 IF THE SOLUTION IS SPECIFIED AT X=A AND
C                              THE BOUNDARY CONDITION IS MIXED AT X=B;
C                              I.E., U(A,Y) AND DU(B,Y)/DX+BETA*U(B,Y)
C                              ARE SPECIFIED FOR ALL Y
C                          = 3 IF THE BOUNDARY CONDITIONS AT X=A AND X=B
C                              ARE MIXED; I.E., DU(A,Y)/DX+ALPHA*U(A,Y)
C                              AND DU(B,Y)/DX+BETA*U(B,Y) ARE SPECIFIED
C                              FOR ALL Y
C                          = 4 IF THE BOUNDARY CONDITION AT X=A IS MIXED
C                              AND THE SOLUTION IS SPECIFIED AT X=B;
C                              I.E., DU(A,Y)/DX+ALPHA*U(A,Y) AND U(B,Y)
C                              ARE SPECIFIED FOR ALL Y
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF DU(A,Y)/DX+
C                          ALPHA*U(A,Y) AT X=A, WHEN MBDCND=3 OR 4.
C                               BDA(J) = DU(A,YJ)/DX+ALPHA*U(A,YJ);
C                               J=1,2,...,N+1
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDA IS A
C                          DUMMY PARAMETER.
C
C ON INPUT               ALPHA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN CASE
C                          OF A MIXED BOUNDARY CONDITION AT X=A (SEE
C                          ARGUMENT BDA).  IF MBDCND ' 3,4 THEN ALPHA IS
C                          A DUMMY PARAMETER.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF DU(B,Y)/DX+
C                          BETA*U(B,Y) AT X=B.  WHEN MBDCND=2 OR 3
C                               BDB(J) = DU(B,YJ)/DX+BETA*U(B,YJ);
C                               J=1,2,...,N+1
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDB IS A
C                          DUMMY PARAMETER.
C
C                        BETA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN CASE
C                          OF A MIXED BOUNDARY CONDITION AT X=B (SEE
C                          ARGUMENT BDB).  IF MBDCND'2,3 THEN BETA IS A
C                          DUMMY PARAMETER.
C
C                        C,D
C                          THE RANGE OF THE Y-INDEPENDENT VARIABLE;
C                          I.E., Y IS GREATER THAN OR EQUAL TO C AND
C                          LESS THAN OR EQUAL TO D.  C MUST BE LESS THAN
C                          D.
C
C                        N
C                          THE NUMBER OF PANELS INTO WHICH THE INTERVAL
C                          [C,D] IS SUBDIVIDED.  HENCE, THERE WILL BE
C                          N+1 GRID POINTS IN THE Y-DIRECTION GIVEN BY
C                          YJ=C+(J-1)*DLY FOR J=1,2,...,N+1 WHERE
C                          DLY=(D-C)/N IS THE PANEL WIDTH.  IN ADDITION,
C                          N MUST BE GREATER THAN 4.
C
C                        NBDCND
C                          INDICATES THE TYPES OF BOUNDARY CONDITIONS AT
C                          Y=C AND Y=D
C                          = 0 IF THE SOLUTION IS PERIODIC IN Y,
C                              I.E., U(X,Y+D-C)=U(X,Y) FOR ALL X,Y
C                          = 1 IF THE SOLUTION IS SPECIFIED AT Y=C
C                              AND Y = D, I.E., U(X,C)  AND U(X,D)
C                              ARE SPECIFIED FOR ALL X
C                          = 2 IF THE SOLUTION IS SPECIFIED AT Y=C
C                              AND THE BOUNDARY CONDITION IS MIXED
C                              AT Y=D, I.E., U(X,C) AND DU(X,D)/DY
C                              ARE SPECIFIED FOR ALL X
C                          = 3 IF THE BOUNDARY CONDITIONS ARE MIXED
C                              AT Y=C AND Y=D I.E.,
C                              DU(X,C)/DY AND DU(X,D)/DY ARE
C                              SPECIFIED FOR ALL X
C                          = 4 IF THE BOUNDARY CONDITION IS MIXED
C                              AT Y=C AND THE SOLUTION IS SPECIFIED
C                              AT Y=D, I.E. DU(X,C)/DY AND U(X,D)
C                              ARE SPECIFIED FOR ALL X
C
C                        BDC
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUE DU(X,C)/DY
C                          AT Y=C.  WHEN NBDCND=3 OR 4
C                            BDC(I) = DU(XI,C)/DY
C                             I=1,2,...,M+1.
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDC IS A
C                          DUMMY PARAMETER.
C
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                           SPECIFIED THE VALUE OF DU(X,D)/DY
C                           AT Y=D.  WHEN NBDCND=2 OR 3
C                             BDD(I)=DU(XI,D)/DY
C                            I=1,2,...,M+1.
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDD IS A
C                          DUMMY PARAMETER.
C
C
C                        COFX
C                          A USER-SUPPLIED SUBPROGRAM WITH
C                          PARAMETERS X, AFUN, BFUN, CFUN WHICH
C                          RETURNS THE VALUES OF THE X-DEPENDENT
C                          COEFFICIENTS AF(X), BF(X), CF(X) IN
C                          THE ELLIPTIC EQUATION AT X.
C                        IF BOUNDARY CONDITIONS IN THE X DIRECTION
C                        ARE PERIODIC THEN THE COEFFICIENTS
C                        MUST SATISFY AF(X)=C1,BF(X)=0,CF(X)=C2 FOR
C                        ALL X.  HERE C1.GT.0 AND C2 ARE CONSTANTS.
C
C                        NOTE THAT COFX MUST BE DECLARED EXTERNAL
C                        IN THE CALLING ROUTINE.
C
C                        GRHS
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE RIGHT-HAND SIDE OF THE ELLIPTIC
C                          EQUATION; I.E., GRHS(I,J)=G(XI,YI), FOR
C                          I=2,...,M; J=2,...,N.  AT THE BOUNDARIES,
C                          GRHS IS DEFINED BY
C
C                          MBDCND   GRHS(1,J)   GRHS(M+1,J)
C                          ------   ---------   -----------
C                            0      G(A,YJ)     G(B,YJ)
C                            1         *           *
C                            2         *        G(B,YJ)  J=1,2,...,N+1
C                            3      G(A,YJ)     G(B,YJ)
C                            4      G(A,YJ)        *
C
C                          NBDCND   GRHS(I,1)   GRHS(I,N+1)
C                          ------   ---------   -----------
C                            0      G(XI,C)     G(XI,D)
C                            1         *           *
C                            2         *        G(XI,D)  I=1,2,...,M+1
C                            3      G(XI,C)     G(XI,D)
C                            4      G(XI,C)        *
C
C                          WHERE * MEANS THESE QUANTITES ARE NOT USED.
C                          GRHS SHOULD BE DIMENSIONED IDMN BY AT LEAST
C                          N+1 IN THE CALLING ROUTINE.
C
C                        USOL
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE SOLUTION ALONG THE BOUNDARIES.
C                          AT THE BOUNDARIES, USOL IS DEFINED BY
C
C                          MBDCND   USOL(1,J)   USOL(M+1,J)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(A,YJ)     U(B,YJ)
C                            2      U(A,YJ)        *     J=1,2,...,N+1
C                            3         *           *
C                            4         *        U(B,YJ)
C
C                          NBDCND   USOL(I,1)   USOL(I,N+1)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(XI,C)     U(XI,D)
C                            2      U(XI,C)        *     I=1,2,...,M+1
C                            3         *           *
C                            4         *        U(XI,D)
C
C                          WHERE * MEANS THE QUANTITES ARE NOT USED IN
C                          THE SOLUTION.
C
C                          IF IORDER=2, THE USER MAY EQUIVALENCE GRHS
C                          AND USOL TO SAVE SPACE.  NOTE THAT IN THIS
C                          CASE THE TABLES SPECIFYING THE BOUNDARIES OF
C                          THE GRHS AND USOL ARRAYS DETERMINE THE
C                          BOUNDARIES UNIQUELY EXCEPT AT THE CORNERS.
C                          IF THE TABLES CALL FOR BOTH G(X,Y) AND
C                          U(X,Y) AT A CORNER THEN THE SOLUTION MUST BE
C                          CHOSEN.  FOR EXAMPLE, IF MBDCND=2 AND
C                          NBDCND=4, THEN U(A,C), U(A,D), U(B,D) MUST BE
C                          CHOSEN AT THE CORNERS IN ADDITION TO G(B,C).
C
C                          IF IORDER=4, THEN THE TWO ARRAYS, USOL AND
C                          GRHS, MUST BE DISTINCT.
C
C                          USOL SHOULD BE DIMENSIONED IDMN BY AT LEAST
C                          N+1 IN THE CALLING ROUTINE.
C
C                        IDMN
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAYS
C                          GRHS AND USOL AS IT APPEARS IN THE PROGRAM
C                          CALLING SEPX4.  THIS PARAMETER IS USED TO
C                          SPECIFY THE VARIABLE DIMENSION OF GRHS AND
C                          USOL.  IDMN MUST BE AT LEAST 7 AND GREATER
C                          THAN OR EQUAL TO M+1.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED
C                        BY THE USER FOR WORK SPACE.
C                        10*N+(16+INT(LOG2(N)))*(M+1)+23 WILL SUFFICE
C                        AS A LENGTH FOR W.  THE ACTUAL LENGTH OF
C                        W IN THE CALLING ROUTINE MUST BE SET IN W(1)
C                        (SEE IERROR=11).
C ON OUTPUT              USOL
C                          CONTAINS THE APPROXIMATE SOLUTION TO THE
C                          ELLIPTIC EQUATION.  USOL(I,J) IS THE
C                          APPROXIMATION TO U(XI,YJ) FOR I=1,2...,M+1
C                          AND J=1,2,...,N+1.  THE APPROXIMATION HAS
C                          ERROR O(DLX**2+DLY**2) IF CALLED WITH
C                          IORDER=2 AND O(DLX**4+DLY**4) IF CALLED WITH
C                          IORDER=4.
C
C                        W
C                          CONTAINS INTERMEDIATE VALUES THAT MUST NOT BE
C                          DESTROYED IF SEPX4 IS CALLED AGAIN WITH
C                          INTL=1.  IN ADDITION W(1) CONTAINS THE EXACT
C                          MINIMAL LENGTH (IN FLOATING POINT) REQUIRED
C                          FOR THE WORK SPACE (SEE IERROR=11).
C
C                        PERTRB
C                        IF A COMBINATION OF PERIODIC OR DERIVATIVE
C                        BOUNDARY CONDITIONS (I.E., ALPHA=BETA=0 IF
C                        MBDCND=3) IS SPECIFIED AND IF CF(X)=0 FOR ALL X
C                        THEN A SOLUTION TO THE DISCRETIZED MATRIX
C                        EQUATION MAY NOT EXIST (REFLECTING THE NON-
C                        UNIQUENESS OF SOLUTIONS TO THE PDE).  PERTRB
C                        IS A CONSTANT CALCULATED AND SUBTRACTED FROM
C                        THE RIGHT HAND SIDE OF THE MATRIX EQUATION
C                        INSURING THE EXISTENCE OF A SOLUTION.
C                        SEPX4 COMPUTES THIS SOLUTION WHICH IS A
C                        WEIGHTED MINIMAL LEAST SQUARES SOLUTION TO
C                        THE ORIGINAL PROBLEM.  IF SINGULARITY IS
C                        NOT DETECTED PERTRB=0.0 IS RETURNED BY
C                        SEPX4.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS OR FAILURE TO FIND A SOLUTION
C                          = 0 NO ERROR
C                          = 1 IF A GREATER THAN B OR C GREATER THAN D
C                          = 2 IF MBDCND LESS THAN 0 OR MBDCND GREATER
C                              THAN 4
C                          = 3 IF NBDCND LESS THAN 0 OR NBDCND GREATER
C                              THAN 4
C                          = 4 IF ATTEMPT TO FIND A SOLUTION FAILS.
C                              (THE LINEAR SYSTEM GENERATED IS NOT
C                              DIAGONALLY DOMINANT.)
C                          = 5 IF IDMN IS TOO SMALL (SEE DISCUSSION OF
C                              IDMN)
C                          = 6 IF M IS TOO SMALL OR TOO LARGE (SEE
C                              DISCUSSION OF M)
C                          = 7 IF N IS TOO SMALL (SEE DISCUSSION OF N)
C                          = 8 IF IORDER IS NOT 2 OR 4
C                          = 9 IF INTL IS NOT 0 OR 1
C                          = 10 IF AFUN IS LESS THAN OR EQUAL TO ZERO
C                          FOR SOME INTERIOR MESH POINT XI
C                               SOME INTERIOR MESH POINT (XI,YJ)
C                          = 11 IF THE WORK SPACE LENGTH INPUT IN W(1)
C                               IS LESS THAN THE EXACT MINIMAL WORK
C                               SPACE LENGTH REQUIRED OUTPUT IN W(1).
C                        = 12 IF MBDCND=0 AND AF(X)=CF(X)=CONSTANT
C                             OR BF(X)=0 FOR ALL X IS NOT TRUE.
C
C
C SPECIAL CONDITIONS     NONE
C
C COMMON BLOCKS          SPL4
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       NONE
C FILES
C
C SPECIALIST             JOHN C. ADAMS, NCAR, BOULDER, COLORADO  80307
C
C LANGUAGE               FORTRAN
C
C
C  ENTRY POINTS          SEPX4,SPELI4,CHKPR4,CHKSN4,ORTHO4,MINSO4,TRIS4,
C                        DEFE4,DX4,DY4
C
C HISTORY                SEPX4 WAS DEVELOPED BY MODIFYING THE ULIB
C                        ROUTINE SEPELI DURING OCTOBER 1978.
C                        IT SHOULD BE USED INSTEAD OF SEPELI WHENEVER
C                        POSSIBLE.  THE INCREASE IN SPEED IS AT LEAST
C                        A FACTOR OF THREE.
C
C ALGORITHM              SEPX4 AUTOMATICALLY DISCRETIZES THE SEPARABLE
C                        ELLIPTIC EQUATION WHICH IS THEN SOLVED BY A
C                        GENERALIZED CYCLIC REDUCTION ALGORITHM IN THE
C                        SUBROUTINE POIS.  THE FOURTH ORDER SOLUTION
C                        IS OBTAINED USING THE TECHNIQUE OF
C                        DEFFERRED CORRECTIONS REFERENCED BELOW.
C
C
C REFERENCES             KELLER, H.B., NUMERICAL METHODS FOR TWO-POINT
C                          BOUNDARY-VALUE PROBLEMS, BLAISDEL (1968),
C                          WALTHAM, MASS.
C
C                        SWARZTRAUBER, P., AND R. SWEET (1975):
C                          EFFICIENT FORTRAN SUBPROGRAMS FOR THE
C                          SOLUTION OF ELLIPTIC PARTIAL DIFFERENTIAL
C                          EQUATIONS.  NCAR TECHNICAL NOTE
C                          NCAR-TN/IA-109, PP. 135-137.
C
C
C
C
      DIMENSION       GRHS(IDMN,1)           ,USOL(IDMN,1)
      DIMENSION       BDA(1)     ,BDB(1)     ,BDC(1)     ,BDD(1)     ,
     1                W(1)
      EXTERNAL COFX
C
C     CHECK INPUT PARAMETERS
C
      CALL CHKPR4(IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,IDMN,IERROR)
      IF (IERROR .NE. 0) RETURN
C
C     COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT
C
      L = N+1
      IF (NBDCND .EQ. 0) L = N
      K = M+1
      L = N+1
C     ESTIMATE LOG BASE 2 OF N
      LOG2N=INT(ALOG(FLOAT(N+1))/ALOG(2.0)+0.5)
      LENGTH=4*(N+1)+(10+LOG2N)*(M+1)
      IERROR = 11
      LINPUT = INT(W(1)+0.5)
      LOUTPT = LENGTH+6*(K+L)+1
      W(1) = FLOAT(LOUTPT)
      IF (LOUTPT .GT. LINPUT) RETURN
      IERROR = 0
C
C     SET WORK SPACE INDICES
C
      I1 = LENGTH+2
      I2 = I1+L
      I3 = I2+L
      I4 = I3+L
      I5 = I4+L
      I6 = I5+L
      I7 = I6+L
      I8 = I7+K
      I9 = I8+K
      I10 = I9+K
      I11 = I10+K
      I12 = I11+K
      I13 = 2
      CALL SPELI4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1NBDCND,BDC,BDD,COFX,W(I1),W(I2),W(I3),
     2             W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11),
     3             W(I12),GRHS,USOL,IDMN,W(I13),PERTRB,IERROR)
      RETURN
      END