!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !MODULE: m_gritas_grids --- GRITAS dimension and grid parameters
!
! !INTERFACE:

      MODULE m_gritas_grids

! !USES:

      Implicit none

! !DESCRIPTION:
!
!  Defines dimensions and other relevant parameters.
!
! !DEFINED PARAMETERS:

!     Grid dimension
!     --------------
      integer, save ::     im                        ! no. zonal      gridpoints
      integer, save ::     jm                        ! no. meridional gridpoints
      integer, save ::     km                        ! max.   no. vertical levels
      integer, save ::     nlevs                     ! actual no. vertical levels

!     Longitudinal grid
!     -----------------
      real, parameter         :: LonMin = -180.      ! = lambda(1)
      real, save              :: dLon                ! mesh size (deg)
      real, allocatable, save :: glon(:)             ! zonal gridpoints

!     real, parameter :: dLon = 360. / im    ! mesh size (deg)

!     Latitudinal grid
!     ----------------
      real, parameter         :: LatMin = -90.       ! = phi(1)
      real, save              :: dLat                ! mesh size (deg)
      real, allocatable, save :: glat(:)             ! neridional gridpoints

!     Vertical grid
!     -------------
      real, allocatable, save :: plevs(:)            ! vertical levels in hPa

!     Missing value
!     -------------
      real, parameter :: AMISS = 1.0E15

! !REVISION HISTORY:
!
!  05sep97   da Silva   Original code.
!  09Jun06   Todling    Converted to module.
!
!EOP
!-------------------------------------------------------------------------

      character(len=*), parameter :: myname = 'm_Gritas_Grids'

      interface grids_init  ; module procedure init_        ; end interface
      interface grids_clean ; module procedure clean_       ; end interface
      interface GrITAS_Pint ; module procedure GrITAS_Pint_ ; end interface
      interface GrITAS_Norm ; module procedure GrITAS_Norm_ ; end interface
      interface GrITAS_Accum; module procedure GrITAS_Accum_; end interface

      CONTAINS

      subroutine init_ (im_def,jm_def,km_def,stat)

      implicit none
      integer, intent(in)  :: im_def
      integer, intent(in)  :: jm_def
      integer, intent(in)  :: km_def
      integer, intent(out) :: stat

      integer  i, j, ier

      stat = 0

      im = im_def
      jm = jm_def
      km = km_def

      allocate ( glon(im), glat(jm), plevs(km), stat=ier )
         if(ier/=0) then
            stat = 1
            return
         endif

      dLon = 360. / im
      dLat = 180. / ( jm - 1 )

!     Create horizontal grids for GFIO's sake
!     ---------------------------------------
      do i = 1, im
         glon(i) = LonMin + (i-1) * dLon
      end do
      do j = 1, jm
         glat(j) = LatMin + (j-1) * dLat
      end do

      end subroutine init_

      subroutine clean_(stat)
      implicit none
      integer, intent(out) :: stat
      integer ier
      stat = 0
      deallocate ( glon, glat, plevs, stat=ier )
         if(ier/=0) then
            stat = 1
            return
         endif
      end subroutine clean_

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !ROUTINE:  GrITAS_Pint_ --- Set pressure Intervals for gridding
!
! !INTERFACE:
!
      subroutine GrITAS_Pint_ ( p1, p2 )

! !INPUT PARAMETERS:

! !OUTPUT PARAMETERS:
!
      real       p1(nlevs), p2(nlevs)   ! pressure intervals for gridding
!
! !DESCRIPTION: Determine the pressure level ranges for binning
!               off-mandatory level data. Observations with pressure
!               p1(k) <= p < p2(k) will be gridded at level plevs(k).
!               The binnings are log-pressure linear.
!
! !REVISION HISTORY:
!
!  03Sep97  da Silva   Initial code.
!  17Oct97  G. P. Lou  Modification.
!  25Mar98  da Silva   Removed tighning of vertical level interval
!                      introduced by G. P. Lou.
!  24Jun04  Todling    Changed handling of 1-level case.
!
!EOP
!-------------------------------------------------------------------------

      character(len=*), parameter :: myname_ = myname//'GrITAS_Pint_'

      integer i, j, k

!     Check number of levels
!     ----------------------
      if ( nlevs .le. 0 ) call gritas_perror
     &   ( 'Pint: must have at least 1 vertical levels' )

!     Special single level case
!     -------------------------
      if ( nlevs .eq. 1 ) then
           p1(1) = plevs(1)
           p2(1) = plevs(1)
           print *, '       p1         p        p2'
           print 100, p1(1), plevs(1), p2(1)
           print *
           return
      end if

!     Check monotonicity
!     ------------------
      do k = 1, nlevs-1
         if ( plevs(k) .le. plevs(k+1) ) call gritas_perror
     &      ('Pint: pressure levels do not decrease monotonically')
      end do

      if ( plevs(nlevs) .eq. 0. ) call gritas_perror
     &   ( 'Pint: cannot handle 0 hPa' )

      k = 1
      p1(1) = 2000.
      p2(1) = exp ( 0.5 * ( log(plevs(k+1)) + log(plevs(k)) ) )

      do k = 2, nlevs-1
         p1(k) = exp ( 0.5 * ( log(plevs(k-1)) + log(plevs(k)) ) )
         p2(k) = exp ( 0.5 * ( log(plevs(k+1)) + log(plevs(k)) ) )
      end do

      k = nlevs
      p1(k) = exp ( 0.5 * ( log(plevs(k-1)) + log(plevs(k)) ) )
      p2(k) = 0.

!     Echo parameters
!     ---------------
      print *, '       p1         p        p2'
      do k = 1, nlevs
         print 100, p1(k), plevs(k), p2(k)
      end do
 100  format(1x,3F10.1)

      print *

      end subroutine GrITAS_Pint_

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !ROUTINE: GrITAS_Accum_ --- Accumulate O-F on del grids
!
! !INTERFACE:
!
      subroutine GrITAS_Accum_ ( lat, lon, lev, kx, kt, del, nobs, nr,
     &                           kxkt_table, p1, p2,
     &                           ob_flag,
     &                           l2d, bias_2d, rtms_2d, xcov_2d, nobs_2d,
     &                           l3d, bias_3d, rtms_3d, xcov_3d, nobs_3d )

! !USES:
!

      use m_odsmeta, only : KTMAX
      use m_odsmeta, only : KXMAX
      implicit NONE
!
! !INPUT PARAMETERS:
!

      integer, intent(in) ::       nobs          ! actual number of observations
      integer, intent(in) ::       nr            ! number of distinct residual series
      real,    intent(in) ::       lat(nobs)     ! latitude (degrees)
      real,    intent(in) ::       lon(nobs)     ! longitude (degrees)
      real,    intent(in) ::       lev(nobs)     ! level (hPa)
      real,    intent(in) ::       del(nobs,nr)  ! residual
      integer, intent(in) ::       kx(nobs)      ! data source index
      integer, intent(in) ::       kt(nobs)      ! data type   index

      integer, intent(in) ::        kxkt_table(KXMAX,KTMAX)  ! kx-kt table

      real,    intent(in) ::           p1(nlevs)
      real,    intent(in) ::           p2(nlevs)     ! pressure intervals for gridding

      integer,    intent(in) ::         l2d          ! actual number of 2d grids
      integer,    intent(in) ::         l3d          ! actual number of 3d grids

!
! !INPUT/OUTPUT PARAMETERS:
!
      integer,    intent(inout) :: ob_flag(nobs)     ! On input, ob is rejected if
                                                     !    ob_flag is other than 0
                                                     ! On output, ob_flag = 0 if ob
                                                     !    was used to accumulate the
                                                     !    bias/RMS
                                                     ! Surface (2D) grids:
      real, intent(inout) ::  bias_2d(im,jm,l2d,nr)    !   time means
      real, intent(inout) ::  rtms_2d(im,jm,l2d,nr)    !   root time mean square
      real, intent(inout) ::  xcov_2d(im,jm,l2d)       !   x (co)variance
      real, intent(inout) ::  nobs_2d(im,jm,l2d)       !   number of obs per grid box

                                                     ! Upper-air (3D) grids:
      real, intent(inout) ::  bias_3d(im,jm,km,l3d,nr) !  time means
      real, intent(inout) ::  rtms_3d(im,jm,km,l3d,nr) !   root time mean square
      real, intent(inout) ::  xcov_3d(im,jm,km,l3d)    !   root time mean square
      real, intent(inout) ::  nobs_3d(im,jm,km,l3d)    !   number of obs per grid box

!
! !DESCRIPTION: Given the O-F for a given synoptic time, this routine
!               accumulates the bias and the RMS at the nearest gridpoint.
!
! !REMARKS:
!
!   1.  xrtms is redundant when nr=1, i.e., xrtms=rtms
!   2.  when nr=2, assumes residuals are from same experiment, that is,
!       no need to distinguish between nobs
!
! !REVISION HISTORY:
!
!  03Sep97  da Silva   Initial code.
!  25Mar98  da Silva   Removed "goto 10" statement; now all must be
!                      assigned a level or else a fatal error will occur
!                      (this was the original design).
!  26Mar98  da Silva   Included periodic boundary conditions in longitude.
!  14Jul99  da SIlva   Added land-surface kt's
!  28oct06  Todling    Generalized to handle cross-terms; note xrtms is
!                      redundant when nr=1, i.e., xrtms=rtms
!  28May09  Redder     Changed code to define negative value in
!                      kxkt_table as indices for surface variables.
!  07Jul09  Redder     Added parameters ob_flag
!
!EOP
!-------------------------------------------------------------------------

      character(len=*), parameter :: myname_ = myname//'GrITAS_Accum_'

      integer n, i, j, k, kk, nx, l, ir
      logical surface_var, reject_ob

      if ( nr > 2 ) call gritas_perror ('Accum: could not handle '
     &                               // 'more then 2 residuals')
      nx = max(1,nr)

!     Loop over observations
!     ----------------------
      do 10 n = 1, nobs
         reject_ob = ob_flag ( n ) .ne. 0
         if ( reject_ob  ) go to 10                    ! reject unwanted obs

         l = kxkt_table(kx(n),kt(n))
         surface_var = kxkt_table (kx(n),kt(n)) .lt. 0
         l = abs (l)

         if ( l .le. 0 ) then
            ob_flag ( n ) = 1
            go to 10                                   ! forget it
         end if

!        Horizontal gridbox: gridpoint is assumed at center of box
!        ---------------------------------------------------------
         i = 1 + nint ( (lon(n) - LonMin) / dLon )
         if ( i .eq. (im+1) ) i = 1                      ! periodic bc
         if ( i .eq.   0    ) i = im                     ! periodic bc
         j = 1 + nint ( (lat(n) - LatMin) / dLat )

         i = min(im,max(1,i))
         j = min(jm,max(1,j))

!        Surface (2D) grid
!        -----------------
         if ( surface_var )  then  ! surface variables

!             Accumulate
!             ----------
              do ir = 1, nr
                 bias_2d(i,j,l,ir) = bias_2d(i,j,l,ir) + del(n,ir)
                 rtms_2d(i,j,l,ir) = rtms_2d(i,j,l,ir) + del(n,ir)*del(n,ir)
              end do
              xcov_2d(i,j,l)       = xcov_2d(i,j,l)    + del(n,1) *del(n,nx)
              nobs_2d(i,j,l)       = nobs_2d(i,j,l)    + 1.

!        Upper-air (3D) grid
!        -------------------
         else

!             Find vertical level
!             -------------------
              do kk = 1, nlevs
                 if ( lev(n) .le. p1(kk) .AND.
     &                lev(n) .gt. p2(kk) ) then
                      k = kk
                      go to 21
                 end if
              end do

              print *, 'Accum: obs level is ', lev(n), ' hPa'
              call gritas_perror ('Accum: could not find level')

 21           continue

!             Accumulate
!             ----------
              do ir = 1, nr
                 bias_3d(i,j,k,l,ir) = bias_3d(i,j,k,l,ir) + del(n,ir)
                 rtms_3d(i,j,k,l,ir) = rtms_3d(i,j,k,l,ir) + del(n,ir)*del(n,ir)
              end do
              xcov_3d(i,j,k,l)       = xcov_3d(i,j,k,l)    + del(n,1) *del(n,nx)
              nobs_3d(i,j,k,l)       = nobs_3d(i,j,k,l)    + 1.

           end if

 10     continue

        end subroutine GrITAS_Accum_

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !ROUTINE:  GrITAS_Norm_ --- Normalize time mean statistics
!
! !INTERFACE:
!
       subroutine GrITAS_Norm_ ( nr, nrmlz,
     &                           l2d, bias_2d, rtms_2d, stdv_2d, xcov_2d, nobs_2d,
     &                           l3d, bias_3d, rtms_3d, stdv_3d, xcov_3d, nobs_3d,
     &                           ntresh )
!
! !USES:
!
      implicit NONE
!
! !INPUT PARAMETERS:
!

      integer, intent(in) ::      nr           ! number of distinct residual series
      logical, intent(in) ::      nrmlz        ! normalize or not
      integer, intent(in) ::      l2d          ! actual number of 2d grids
      integer, intent(in) ::      l3d          ! actual number of 3d grids
      integer, OPTIONAL, intent(in) :: ntresh  ! tresh hold to compute means

! !INPUT/OUTPUT PARAMETERS:
!
                                                      ! Surface (2D) grids:
      real, intent(inout) ::  bias_2d(im,jm,l2d,nr)    !   time means
      real, intent(inout) ::  rtms_2d(im,jm,l2d,nr)    !   root time mean square
      real, intent(inout) ::  xcov_2d(im,jm,l2d,nr)    !   x-(co)variance
      real, intent(inout) ::  nobs_2d(im,jm,l2d)       !   number of obs per grid box

                                                      ! Upper-air (3D) grids:
      real, intent(inout) ::  bias_3d(im,jm,km,l3d,nr) !   time means
      real, intent(inout) ::  rtms_3d(im,jm,km,l3d,nr) !   root time mean square
      real, intent(inout) ::  xcov_3d(im,jm,km,l3d,nr) !   x-(co)variance
      real, intent(inout) ::  nobs_3d(im,jm,km,l3d)    !   number of obs per grid box
!
! !OUTPUT PARAMETERS:
!
      real, intent(inout) ::  stdv_2d(im,jm,l2d,nr)    ! 2D root time mean square
      real, intent(inout) ::  stdv_3d(im,jm,km,l3d,nr) ! 3D root time mean square

!
! !DESCRIPTION:  Normalizes the time mean statistics (such as
!                dividing the accumulated O-F by the number of
!  observations), set to 'missing value' the gridboxes with no
!  data.
!
! !REVISION HISTORY:
!
!  03Sep97  da Silva   Initial code.
!  26Mar98  da Silva   Change normalization: n=1 is now OK for means.
!                      I needed this for being able to use the same
!                      code for synoptic time averages (GrISAS).
!  24Jun04  Todling    Added protection for nlev<2.
!  12oct05  da Silva   Added ntresh to impose a min number of obs
!  28Oct06  Todling    Generalized to handle cross-terms.
!
!EOP
!-------------------------------------------------------------------------

      character(len=*), parameter :: myname_ = myname//'GrITAS_Norm_'

      integer i, j, k, l, m, nx, ir
      real    tmp(nr), xtmp, n, ntresh_

      if ( nr > 2 ) call gritas_perror ('Accum: could not handle more then 2 residuals')
      nx = max(1,nr)

      ntresh_ = 0.                  ! by default no effect
      if ( present(ntresh) ) then
           ntresh_ = ntresh
      end if

!     Surface (2D) grids
!     ------------------
      m=1
      do l = 1, l2d
         do j = 1, jm
            do i = 1, im

               n = nobs_2d(i,j,l)
               if ( nrmlz ) m=n
               if ( n .gt. 0. .AND. n .ge. ntresh_ ) then
                    do ir = 1, nr
                       bias_2d(i,j,l,ir) = bias_2d(i,j,l,ir) / m                                ! mean(x)
                       tmp(ir)           = rtms_2d(i,j,l,ir) / m                                ! mean(x**2)
                       rtms_2d(i,j,l,ir) = sqrt(tmp(ir))
                       tmp(ir)           = abs(tmp(ir)  - bias_2d(i,j,l,ir) *bias_2d(i,j,l,ir)) ! mean(x'**2)
                    end do
                    xtmp             = xcov_2d(i,j,l,1) / m                                    ! <x,y>
                    xcov_2d(i,j,l,1) = xtmp                                                    ! save xRMS in slot 1
                    xtmp             = xtmp  - bias_2d(i,j,l,1) *bias_2d(i,j,l,nx)             ! <x',y'>
               else
                    do ir = 1, nr
                       bias_2d(i,j,l,ir) = AMISS
                       rtms_2d(i,j,l,ir) = AMISS
                    end do
                       xcov_2d(i,j,l,1)  = AMISS
               end if

               if ( n .gt. 1. .AND. n .ge. ntresh_ ) then
                    do ir = 1, nr
                       stdv_2d(i,j,l,ir)  = sqrt( m * tmp(ir) / (m-1) )
                    end do
                       xcov_2d(i,j,l,nx)  =       m * xtmp    / (m-1)
               else
                    do ir = 1, nr
                       stdv_2d(i,j,l,ir)  = AMISS
                    end do
                       xcov_2d(i,j,l,nx)  = AMISS
               end if

            end do
         end do
      end do

      if( nlevs<2 ) return

!     Upper-air (3D) grids
!     --------------------

      m=1
      do l = 1, l3d
         do k = 1, nlevs
            do j = 1, jm
               do i = 1, im

               n = nobs_3d(i,j,k,l)
               if ( nrmlz ) m=n
               if ( n .gt. 0. .AND. n .ge. ntresh_ ) then
                    do ir = 1, nr
                       bias_3d(i,j,k,l,ir) = bias_3d(i,j,k,l,ir) / m                        ! mean(x) and mean(y)
                       tmp(ir)             = rtms_3d(i,j,k,l,ir) / m                        ! mean(x**2) and mean(y**2)
                       rtms_3d(i,j,k,l,ir) = sqrt(tmp(ir))
                       tmp(ir)  = abs(tmp(ir)  - bias_3d(i,j,k,l,ir) *bias_3d(i,j,k,l,ir))  ! mean(x'**2) and mean(y'**2)
                    end do
                    xtmp               = xcov_3d(i,j,k,l,1) / m                             ! <x,y>
                    xcov_3d(i,j,k,l,1) = xtmp                                               ! save xRMS in slot 1
                    xtmp               = xtmp  - bias_3d(i,j,k,l,1) *bias_3d(i,j,k,l,nx)    ! <x',y'>
               else
                    do ir = 1, nr
                       bias_3d(i,j,k,l,ir) = AMISS
                       rtms_3d(i,j,k,l,ir) = AMISS
                    end do
                       xcov_3d(i,j,k,l,1)  = AMISS
               endif

               if ( n .gt. 1. .AND. n .ge. ntresh_ ) then
                    stdv_3d(i,j,k,l,1:nr)  = sqrt( m * tmp(1:nr) / (m-1) )
                    xcov_3d(i,j,k,l,nx)    =       m * xtmp      / (m-1)
               else
                    stdv_3d(i,j,k,l,1:nr) = AMISS
                    xcov_3d(i,j,k,l,nx)   = AMISS
               end if

               end do
            end do
         end do
      end do

      end subroutine GrITAS_Norm_

      end module m_gritas_grids


c=============================================================================c
        program level
c=============================================================================c
c
c  Purpose:  Given a closed body, this program generates level sets
c            In has the option of performing a least squares B-spline to
c            smooth the input data.
c
c  Author:   S. Scott Collis
c
c  Revised:  6-17-97
c
c=============================================================================c
        implicit real (a-h,o-z)

        logical IRIS
        parameter (IRIS = .false.)

        parameter (zero=0.0d0,   pt5=0.5d0,    pt25=0.25d0,     one=1.0d0,
     &             onept5=1.5d0, two=2.0d0,    twopt5=2.5d0,
     &             three=3.0d0,  BIG = 1.0e10, pi = 3.1415926535897932385d+0)

        parameter (iout=10, iin=11, ibs=12)

        parameter (mpts = 1024)
        parameter (nsd = 2)

        dimension  b(mpts,nsd), r(nsd), dr(nsd)
        dimension  bigb(mpts,nsd), bigt(mpts,nsd), bigs(mpts)
        dimension  arcl(mpts)
        dimension  x1(mpts), x2(mpts)
        dimension  rr(mpts), ss(mpts), zz(mpts), cur(mpts)
        dimension  xi(mpts), eta(mpts)
c
c.... needed for plot3d files
c
        real xx(mpts,mpts),  yy(mpts,mpts)
c
c.... B-splines data structure
c
        parameter (kmax = 8)
        dimension xknot(kmax+mpts), yknot(kmax+mpts)
        dimension s(mpts), t(mpts,nsd)
        common /bspline/ npts, t, darc, s1, s2, s, nknot, xknot, yknot,
     &                   korder, ncoef
c
c.... external functions
c
        external crvarc
c
c.... argument list parameters
c
        integer iarg, narg
        character*80  arg
        integer yflag, xflag
        logical plot3d, debug, period, sym, ellip, field
#ifndef __GFORTRAN__
        integer, external iargc
#endif
c=============================================================================c
        yflag = 0
        xflag = 0
        plot3d = .false.
        debug = .false.
        period = .false.
        sym = .false.
        ellip = .false.
        field = .false.
c
c.... parse the argument list
c
        narg = iargc()
        do iarg = 1, narg
          call getarg(iarg,arg)
          if (arg(1:2) .eq. '-y') then
            if (arg(1:3) .eq. '-y1') then               ! exponential
              yflag = 1
            else if (arg(1:3) .eq. '-y2') then          ! hyperbolic tangent
              yflag = 2
            else if (arg(1:3) .eq. '-y3') then          ! Mahesh
              yflag = 3
            else if (arg(1:3) .eq. '-y4') then          ! Algebraic
              yflag = 4
            else                                        ! uniform
              yflag = 0
            end if
          else if (arg(1:2) .eq. '-x') then
            if (arg(1:3) .eq. '-x1') then               ! exponential
              xflag = 1
            else if (arg(1:3) .eq. '-x2') then          ! hyperbolic tangent
              xflag = 2
            else if (arg(1:3) .eq. '-x3') then          ! Mahesh in xi
              xflag = 3
            else if (arg(1:3) .eq. '-x4') then          ! Mahesh in s
              xflag = 4
            else                                        ! uniform in xi
              xflag = 0
            end if
          else if (arg(1:2) .eq. '-c') then
            period = .true.
          else if (arg(1:2) .eq. '-d') then
            debug = .true.
          else if (arg(1:2) .eq. '-e') then
            ellip = .true.
          else if (arg(1:2) .eq. '-f') then
            field = .true.
          else if (arg(1:2) .eq. '-p') then
            plot3d = .true.
          else if (arg(1:2) .eq. '-s') then
            sym = .true.
          else if (arg(1:2) .eq. '-h') then
            write(*,"('Usage:  level [options]')")
            write(*,"('   -h:  this help')")
            write(*,"('   -d:  debug output')")
            write(*,"('   -e:  use the elliptic smoother')")
            write(*,"('   -f:  write field file format')")
            write(*,"('   -c:  Harwire periodicity')")
            write(*,"('   -s:  Hardwire LE symmetry')")
            write(*,"('  -x1:  exponential stretching in x')")
            write(*,"('  -x2:  hyperbolic tangent stretching in x')")
            write(*,"('  -x3:  Mahesh''s mapping in x')")
            write(*,"('  -x4:  Mahesh''s mapping in s')")
            write(*,"('  -y1:  exponential stretching in y')")
            write(*,"('  -y2:  hyperbolic tangent stretching in y')")
            write(*,"('  -y3:  Mahesh''s mapping in y')")
            write(*,"('  -y4:  Algebraic mapping in y')")
            call exit(0)
          else
            write(*,"('Argument ',i2,' ignored.')") iarg
          end if
        end do
c
c.... get grid dimensions
c
        write(*,"(/,'Enter Nx, Ny ==> ',$)")
        read(*,*) nx, ny
        if (nx .gt. mpts .or. ny .gt. mpts) then
          write(*,*) 'Increase mpts... ', mpts
          call exit(1)
        endif
c
c.... B-spline should be at least 4th order
c
        korder = 5
c       write(*,"('Enter korder ==> ',$)")
c       read(*,*) korder
        if (korder.gt.kmax) then
          write(*,"('Error: Increase kmax')")
          call exit(1)
        end if

c=============================================================================
c       A p p r o x i m a t e   t h e   B o d y
c=============================================================================
c
c.... open the input file
c
        open(iin, file='body.dat', status='unknown')
c
c.... read the boundary file
c
        read (iin, *) npts
        if (npts.gt.mpts) then
          write(*,*) 'Increase mpts in level', mpts
          call exit(1)
        end if
        do i = 1, npts
          read(iin,*) b(i,1), b(i,2)
        end do
        close(iin)
c
c.... initialize the arclength using a linear approximation
c
        arcmin = BIG
        s(1) = zero
        do i = 2, npts
           arc = sqrt((b(i,1)-b(i-1,1))**2 + (b(i,2)-b(i-1,2))**2)
           arcmin = min(arc,arcmin)
           s(i) = s(i-1) + arc
c          write (14,100) s(i), b(i,1), b(i,2)
        end do
        arctot = s(npts)
        write (*,"(/,'Linear Estimation')")
        write (*,"('Minimum arclength on body = ', 1pe20.13)") arcmin
        write (*,"('Total arclength on body   = ', 1pe20.13)") arctot
c
c.... Compute a smooth B-spine
c
        ncoef = npts
        write(*,"(/,'Least squares spline')")
        write(*,"('Npts = ',i4,'  Enter Ncoef ( <= Npts ) ==> ',$)") npts
        read(*,*) ncoef
        nknot = korder + ncoef
        call splcrv(npts, s, b(1,1), b(1,2), t(1,1), t(1,2),
     &              nknot, xknot, yknot, korder, ncoef)
c
c.... compute the total arclength of the B-splined body
c
        arctot = crvarc(npts, s, t(1,1), t(1,2), nknot, xknot, yknot,
     &                  korder, ncoef, arcl)
        write (*,"(/,'After smoothing Spline')")
        write (*,"('Total arclength on body = ', 1pe20.13)") arctot

        if (.false.) then
c
c.... Oversample the smooth spline
c.... It turns out that you don't have to oversample
c
        itime = 3
        if (itime*(npts-1)+1 .gt. mpts) then
           write(*,"('ERROR: increase mpts in level')")
           call exit(1)
        end if
        do i = 1, npts-1
           i0 = (i-1)*itime+1
           ds = (s(i+1)-s(i))/float(itime)
           do j = 0, itime-1
              sint = s(i) + float(j) * ds
              bigs(i0+j) = sint
              b(i0+j,1)  = BSDER( 0, sint, korder, xknot, ncoef, t(1,1) )
              b(i0+j,2)  = BSDER( 0, sint, korder, yknot, ncoef, t(1,2) )
           end do
        end do
        i0 = itime * (npts-1) + 1
        sint = s(npts)
        bigs(i0) = sint
        b(i0,1)  = BSDER( 0, sint, korder, xknot, ncoef, t(1,1) )
        b(i0,2)  = BSDER( 0, sint, korder, yknot, ncoef, t(1,2) )
        npts = itime * (npts-1) + 1
        do i = 1, npts
           s(i) = bigs(i)
        end do
c
c.... With the oversampled smooth data iterate to find the spline based on
c.... arclength.
c
        icnt = 0
        ncoef = npts
        nknot = korder + ncoef
 200    icnt = icnt + 1
        call splcrv(npts, s, b(1,1), b(1,2), t(1,1), t(1,2),
     &              nknot, xknot, yknot, korder, ncoef)
        arcold = arctot
        arctot = crvarc(npts, s, t(1,1), t(1,2), nknot, xknot, yknot,
     &                  korder, ncoef, arcl)
c
c.... find the max error
c
        errmax = 0.0
        do i = 2, npts
          err = abs( (arcl(i)-arcl(i-1)) - (s(i)-s(i-1)) )
          errmax = max(err,errmax)
        end do
        imax = 10
        if ( errmax .gt. 1.0e-10 .and. icnt .le. imax ) then
           write(*,*) icnt, errmax
           do i = 1, npts
              s(i) = arcl(i)
           end do
           goto 200
        end if

        write (*,"(/,'After re-Spline')")
        write (*,"('Total arclength on body = ', 1pe20.13)") arctot
        write (*,"('Converged to ', 1pe20.13)") abs(arctot-arcold)
c
c.... end of oversample
c
        end if
c
c.... write out the body as a check
c
        if (debug) then
          do i = 1, npts
            write (15,100) s(i), b(i,1), b(i,2)
          end do
        end if
c
c.... save the B-spline representation
c
        open(unit=ibs, file='bs.dat', status='unknown')
        write(ibs,40) korder, ncoef
        do i = 1, ncoef + korder
           write(ibs,50) xknot(i), yknot(i)
        end do
        do i = 1, ncoef
           write(ibs,50) t(i,1), t(i,2)
        end do
 40     format(2(i4,1x))
 50     format(2(1pe22.15,1x))
        close(ibs)

c=============================================================================
c       B o d y   T a n g e n t   D i r e c t i o n
c=============================================================================

        smin = zero
        smax = arctot
        savg = (smin + smax) * pt5
        write(*,"(/,'Smin = ',1pe13.6,' Savg = ',1pe13.6,' Smax = ',1pe13.6)")
     &        smin, savg, smax
c
c.... arbitrary mapping function or uniform mesh
c
        dxi = one / real(nx-1)
        ds = (smax-smin) / real(nx-1)
        write(*,"(/,'Uniform dS = ',1pe20.13)") ds
c
c.... Uniform arc-length
c
        if (xflag.eq.0) then
          write(*,"(/,'Uniform grid in S')")
          do i = 1, nx
            xi(i) = real(i-1) * dxi
            ss(i) = smin + real(i-1) * ds
          end do
        end if

        if (xflag.eq.1) then
           write(*,"('ERROR:  xflag = 1 is not supported')")
           call exit(1)
        end if

        if (xflag.eq.2) then
           write(*,"('ERROR:  xflag = 2 is not supported')")
           call exit(1)
        end if

        if (xflag.eq.3) then
           write(*,"('ERROR:  xflag = 3 is not supported')")
           call exit(1)
        end if
c
c.... Uniform arc-length + mapping
c
        if (xflag.eq.4) then
          write(*,"(/,'Mahesh map in S')")
          write(*,"('Enter dsmin, b, sc ==> ',$)")
          read(*,*) dsmin, rb, sc
          cm = ( two * rb * tanh(rb*sc) + real(nx-1)*dsmin/smax *
     &         log( cosh(rb*(one-sc)) / cosh(rb*(one+sc)) ) ) /
     &         ( one - real(nx-1)*dsmin/smax )
          do i = 1, nx
            xi(i)   = dble(i-1) * dxi
            ss(i)   = smax*( cm * xi(i) + log( cosh(rb*(xi(i)-sc)) /
     &                cosh(rb*(xi(i)+sc)) ) ) /
     &                (cm + log( cosh(rb*(one-sc)) / cosh(rb*(one+sc)) ) )
          end do
        end if
c
c.... spline the mapping function for the body tangent dirction
c
c       ds = two / (500-1)
c       c  = 0.3333333333333333d0
c       c1 = 4.0d0
c       c2 = 20.0d0
c       c3 = 0.0
c       do i = 1, 500
c         s1(i) = -one + (i-1) * ds
c         f = pt5 * c1 * tanh(c2*(s1(i)-c3))
c         zz(i) = c * ( s1(i) + f + 1.0 - pt5 * c1 * tanh(c2*(-1-c3))) - 1.0
c       end do
c       call spline(500, zz, s1, s2)
c       do i = 1, nx
c         xi(i) = real(i-1) * dxi
c         call speval(500, zz, s1, s2, xi(i), ss(i))
c         ss(i) = ss(i) * savg + savg
c         write(19,110) i, xi(i), ss(i)
c       end do

c=============================================================================
c       B o d y   N o r m a l   D i r e c t i o n
c=============================================================================

        deta = one / real(ny-1)
        rmin = zero
        write(*,"(/,'Enter Rmax ==> ',$)")
        read(*,*) rmax
        drr = (rmax-rmin) / real(ny-1)
        write(*,"(/,'Uniform dR = ',1pe20.13)") drr
c
c.... uniform mesh in the wall normal direction
c
        if (yflag.eq.0) then
          write(*,"(/,'Uniform grid in R')")
          do j = 1, ny
            eta(j) = real(j-1) * deta
            rr(j)  = rmin + dble(j-1) * drr
c           write(22,110) j, rr(j), eta(j)
          end do
        end if
c
c.... exponential map in the wall normal direction
c
        if (yflag.eq.1) then
          write(*,"(/,'Exponential map in R')")
          deta2 = one / real(128-1)
          dymin = 5.0d-5
          sy = 1.088d0
          c2 = log( dymin / deta2 )
          c1 = (log( sy*dymin / deta2) - c2) / deta2
          do j = 1, ny
            eta(j)  = dble(j-1) * deta
            rr(j)   = one / c1 * ( exp(c1 * eta(j) + c2) - exp(c2) )
c           write(22,110) j, rr(j), eta(j)
          end do
        end if
c
c.... Hyperbolic tangent stretching
c
        if (yflag .eq. 2) then
          write(*,"(/,'Hyperbolic stretching in R')")
          ds1 = 0.1                     ! set for R=1000 cylinder
          ds2 = 2.0
          dd  = 2.36921620400439        ! from Mathematica (grid2.ma)
c         ds1 = 0.01                    ! set for R=2400 MSE, r=26
c         ds2 = 2.5
c         dd  = 3.898620676884022
c         ds1 = 0.005                   ! set for R=2400 MSE, r=50
c         ds2 = 5.0
c         dd  = 3.898620676884022
c         ds1 = 0.0005                  ! set for R=2400 MSE, r=50
c         ds2 = 5.0
c         dd  = 5.36966703089523
          do j = 1, ny
            eta(j) = float(j-1) * deta
            rr(j) =  rmax*(0.5 + 1.0/Tanh(dd/2.0)*Tanh(dd*(-0.5 +
     &               eta(j)))/2.0)/(Sqrt(ds2/ds1) +
     &               (1.0 - Sqrt(ds2/ds1))*
     &               (0.5 + 1.0/Tanh(dd/2.0)*Tanh(dd*(-0.5 +
     &               eta(j)))/2.0))
c           write(22,110) j, rr(j), eta(j)
          end do
        end if
c
c.... Mahesh's mapping, personal communication (6-5-96)
c
        if (yflag.eq.3) then
          write(*,"(/,'Mahesh map in R')")
          write(*,"('Enter drmin, b, rc ==> ',$)")
          read(*,*) drmin, rb, rc
          cm = ( two * rb * tanh(rb*rc) + (ny-1)*drmin/rmax *
     &           log( cosh(rb*(one-rc)) / cosh(rb*(one+rc)) ) ) /
     &         ( one - (ny-1)*drmin/rmax )
          do j = 1, ny
            eta(j)  = real(j-1) * deta
            rr(j)   = rmax*( cm * eta(j) + log( cosh(rb*(eta(j)-rc)) /
     &                cosh(rb*(eta(j)+rc)) ) ) /
     &                (cm + log( cosh(rb*(one-rc)) / cosh(rb*(one+rc)) ) )
c           write(22,110) j, rr(j), eta(j)
          end do
        end if
c
c.... Algebraic stretched mesh
c
        if (yflag.eq.4) then
          write(*,"(/,'Algebraic grid in R')")
          write(*,"('Enter ri ==> ',$)")
          read(*,*) ri
          aa = rmax * ri / ( rmax - two * ri )
          bb = one + aa / rmax
          do j = 1, ny
            eta(j) = (j-1) * deta
            rr(j)   = aa * eta(j) / (bb - eta(j))
c           write(22,110) j, rr(j), eta(j)
 110        format(i5,6(1x,1pe13.6))
          end do
        end if

c=============================================================================
c       F o r m   L e v e l   S e t s
c=============================================================================
        write(*,"(/,'Discretizing boundary...')")
        do i = 1, nx
          if (i.eq.1) then
            s1 = s(1)
            sint = 0.0
            nold = 1
          else
            s1 = sint
            darc = ss(i) - ss(i-1)
            do n = nold, npts
               if ( arcl(n) .ge. ss(i) ) then
                 s2 = s(n)
                 nold = n
                 goto 11
              end if
            end do
 11         sint = gets()
          end if
          r(1)  = BSDER( 0, sint, korder, xknot, ncoef, t(1,1) )
          r(2)  = BSDER( 0, sint, korder, yknot, ncoef, t(1,2) )
          dr(1) = BSDER( 1, sint, korder, xknot, ncoef, t(1,1) )
          dr(2) = BSDER( 1, sint, korder, yknot, ncoef, t(1,2) )
          do k = 1, nsd
            bigb(i,k) = r(k)
            bigt(i,k) = dr(k)
          end do
          bigs(i) = ss(i)
        end do
c
c.... periodicity
c
        if (period) then
           write(*,"(/,'Hardwire periodicity (1,0) ==> ',$)")
           do k = 1, nsd
              bigb(nx,k) = bigb(1,k)
              bigt(nx,k) = bigt(1,k)
           end do
        end if
c
c.... symmetry
c
        if (sym) then
           write(*,"(/,'Hardwire LE symmetry (1,0) ==> ')")
           bigb(1,1) = zero
           bigb(1,2) = zero
           bigt(1,1) = zero
           bigt(1,2) = one
        end if
c
        nptsbig = nx
c
c.... exchange the curves
c
        do i = 1, nptsbig
          b(i,1) = bigb(i,1)
          b(i,2) = bigb(i,2)
          t(i,1) = bigt(i,1)
          t(i,2) = bigt(i,2)
          s(i)   = bigs(i)
        end do
        npts = nptsbig
c
c.... find the minimum arc length
c.... NB: s(:) is really the local arclength on the body now
c
        arcmin = BIG
        arcl(1) = zero
        do j = 2, npts
          arc    = s(j) - s(j-1)
          arcmin = min(arc,arcmin)
          arcl(j) = arcl(j-1) + arc
        end do
        write (*,"(/,'Discretized Body')")
        write (*,"('Minimum arclength on body = ', 1pe20.13)") arcmin
        write (*,"('Total   arclength on body = ', 1pe20.13)") arcl(npts)
c
c.... reset nx just in case
c
        nx = npts
c
c.... compute the outward normal using the spline data
c
        do i = 1, npts
          x1(i) = -t(i,2)
          x2(i) =  t(i,1)
          rx    =  sqrt(x1(i)**2 + x2(i)**2)
          x1(i) =  x1(i) / rx
          x2(i) =  x2(i) / rx
          if (i .gt. 2) then
            if ( (x2(i) .gt. zero .and. x2(i-2) .lt. zero) .or.
     &           (x1(i) .eq. -one) ) then
              write(*,"(/,'Estimate LE at',i4,3(1x,1pe13.6))")
     &           i-1, b(i-1,1), b(i-1,2), s(i-1)
            end if
          end if
        end do
c
c.... Compute a B-spline through the boundary normal vectors
c
        call BSNAK(npts, s, korder, xknot)
        call BSNAK(npts, s, korder, yknot)
        call BSINT(npts, s, x1, korder, xknot, t(1,1) )
        call BSINT(npts, s, x2, korder, yknot, t(1,2) )
c
c.... write out the body, the surface normal vector, and the curvature
c
        open(20,file='body.out')
        open(21,file='curv.out')
        do i = 1, npts
           write (20,100) b(i,1), b(i,2)
           dr(1) = BSDER( 1, s(i), korder, xknot, npts, t(1,1) )
           dr(2) = BSDER( 1, s(i), korder, yknot, npts, t(1,2) )
           cur(i) = sqrt( dr(1)**2 + dr(2)**2 )
           write (21,100) s(i), b(i,1), b(i,2), x1(i), x2(i), cur(i)
        end do
        close(20)
        close(21)
c
c.... conformal mapping
c
        call conformal( npts, s, b(1,1), b(1,2), cur )
c
c.... make the level sets
c
        do i = 1, npts
          xx(i,1) = b(i,1)
          yy(i,1) = b(i,2)
        end do

        do j = 2, ny
          dy = rr(j) - rr(j-1)
          do i = 1, npts
            b(i,1) = b(i,1) + x1(i) * dy
            b(i,2) = b(i,2) + x2(i) * dy
            xx(i,j) = b(i,1)
            yy(i,j) = b(i,2)
          end do
c
c.... output each level to a separate file
c
          if (.false.) then
            do i = 1, npts
              write (29+iy-1,*) b(i,1), b(i,2)
            end do
          end if
        end do
c
c.... try a simple elliptic smoother
c
        if (ellip) then
           write(*,"(/,'Using elliptic smoother...')")
           write(*,"('Enter eps, nmax ==> ',$)")
           read(*,*) eps, nmax
           call elliptic( nx, ny, xx, mpts, yy, mpts, eps, nmax)
        end if

c=============================================================================
c       O u t p u t   R e s u l t s
c=============================================================================
c
c.... output in Streett's format
c
        if (field) then
           open(10,file='field.mean',form='unformatted')
           write(10) nx, ny
           write(10) (((0.0, j=1, ny), i=1,nx), k=1,4)
           write(10) (s(i), i=1,nx)
           write(10) (rr(j), j=1,ny)
           write(10) (cur(i), i=1,nx)
           close(10)
        end if
c
c.... output grid
c
        nz = 1
        write(*,"(/,'Writing plot3d files for (',i4,',',i4,',',i4,')')")
     &    nx, ny, nz
c
c.... write out binary plot3d files if on the iris
c
        if (IRIS) then

        call wgrid(xx, yy, nx, ny, nz, mpts, mpts, 'grid.bin'//char(0))
        call wdata(xx, yy, nx, ny, nz, mpts, mpts, 'q.bin'//char(0))

        if (plot3d) then
c
c.... body fitted coordinates
c
        do i = 1, nx
          do j = 1, ny
            xx(i,j) = ss(i)
            yy(i,j) = rr(j)
          end do
        end do
        call wgrid(xx, yy, nx, ny, nz, mpts, mpts, 'grid1.bin'//char(0))
c
c.... computational coordinats
c
        do i = 1, nx
          do j = 1, ny
            xx(i,j) = xi(i)
            yy(i,j) = eta(j)
          end do
        end do
        call wgrid(xx, yy, nx, ny, nz, mpts, mpts, 'grid2.bin'//char(0))

        end if

        else
c
c.... write out unformatted plot3d files
c
        open(unit=iout,file='grid.dat',form='unformatted')
        write(iout) nx, ny, 1
        write(iout) (((xx(i,j), i=1,nx), j=1,ny), k = 1, nz),
     &              (((yy(i,j), i=1,nx), j=1,ny), k = 1, nz),
     &              (((    0.0, i=1,nx), j=1,ny), k = 1, nz)
        close(iout)

        if (plot3d) then

        open(unit=iout,file='q.dat',form='unformatted')
        write(iout) nx, ny, 1
        write(iout) 0.0, 0.0, 0.0, 0.0
        write(iout) (((    1.0, i=1,nx), j=1,ny), k = 1, nz),
     &              (((xx(i,j), i=1,nx), j=1,ny), k = 1, nz),
     &              (((yy(i,j), i=1,nx), j=1,ny), k = 1, nz),
     &              (((    0.0, i=1,nx), j=1,ny), k = 1, nz),
     &              (((    1.0, i=1,nx), j=1,ny), k = 1, nz)
        close(iout)
c
c.... body fitted coordinates
c
        do i = 1, nx
          do j = 1, ny
            xx(i,j) = ss(i)
            yy(i,j) = rr(j)
          end do
        end do
        open(unit=iout,file='grid1.dat',form='unformatted')
        write(iout) nx, ny, 1
        write(iout) (((xx(i,j), i=1,nx), j=1,ny), k = 1, nz),
     &              (((yy(i,j), i=1,nx), j=1,ny), k = 1, nz),
     &              (((    0.0, i=1,nx), j=1,ny), k = 1, nz)
        close(iout)
c
c.... computational coordinates
c
        do i = 1, nx
          do j = 1, ny
            xx(i,j) = xi(i)
            yy(i,j) = eta(j)
          end do
        end do
        open(unit=iout,file='grid2.dat',form='unformatted')
        write(iout) nx, ny, 1
        write(iout) (((xx(i,j), i=1,nx), j=1,ny), k = 1, nz),
     &              (((yy(i,j), i=1,nx), j=1,ny), k = 1, nz),
     &              (((    0.0, i=1,nx), j=1,ny), k = 1, nz)
        close(iout)

        endif
c
        endif
c
        call exit(0)
 100    format(8(1pe13.6,1x))
        end


C
C      **********************************************************************
C      *********************** SUBROUTINE BUCKLY  ***************************
C      **********************************************************************
C
       SUBROUTINE BUCKLY(X,Y,IND,TOL,NTOT,NVAR,NVAR1,NVAR2,NU,NC,MAX,
     +                   ALPHA,SIGMAA,ITE,ARRAY,V,BU,TEST,TEST2,
     +                   IND2,XX,Z,W,WX,T,TY,ZY,IPT,ND,NO)

C
C
C      *     THIS IS A SUBPROGRAM WHICH PERFORMS THE BUCKLEY-JAMES          *
C      *     METHOD. THIS SUBROUTINE WAS ADAPTED FROM CODE BY J. HALPERN    *
C      *     (STANFORD UNIVERSITY SCHOOL OF MEDICINE, DEPARTMENT            *
C      *        OF FAMILY, COMMUNITY AND PREVENTIVE MEDICINE.)              *
C      *                                                                    *
C      *  INPUT                                                             *
C      *         X(J,I)   : INDEPENDENT VARIABLES                           *
C      *         Y(I)     : DEPENDENT VARIABLE                              *
C      *         IND(I)   : INDICATOR OF CENSORING                          *
C      *         TOL      : TOLERANCE LEVEL                                 *
C      *         NTOT     : NUMBER OF DATA POINTS                           *
C      *         NVAR     : NUMBER OF INDEPENDENT VARIABLES                 *
C      *         NVAR1    : NUMBER OF INDEPENDENT VARIABLES PLUS ONE        *
C      *         NVAR2    : NUMBER OF INDEPENDENT VARIABLES PLUS TWO        *
C      *         NU       : NUMBER OF DETECTED POINTS                       *
C      *         NC       : NUMBER OF CENSORED POINTS                       *
C      *         MAX      : MAXIMUM ITERATION                               *
C      *                                                                    *
C      *   WORK                                                             *
C      *        ARRAY(J,J): REGRESSION MATRIX                               *
C      *          V(J)    : AVERAGE OF J-TH DETECTED INDEPENDENT VARIABLE   *
C      *          BU(J)   : VARIANCE OF J-TH DETECTED INDEPENDENT VARIABLE  *
C      *         TEST(J)  : STORE OF THE PREVIOUS STEP ESTIMATIONS OF       *
C      *                    ALPHA(J)                                        *
C      *          Z(I)    : RESIDUALS                                       *
C      *          W(I)    : KM ESTIMATOR                                    *
C      *          WX(I)   : WEIGHT                                          *
C      *                                                                    *
C      *  OUTPUT                                                            *
C      *       ALPHA(J)   : REGRESSION COEFFICIENTS                         *
C      *       SIGMAA(J)  : ERROR                                           *
C      *       ITE        : ITERATION NUMBER                                *
C      *                                                                    *
C      *    SUBROUTINES                                                     *
C      *                    BJSORT, REGRES                                  *
C
C
C
       IMPLICIT REAL*8 (A-H,O-Z), INTEGER(I-N)

       DIMENSION X(NVAR,NTOT),Y(NTOT),IND(NTOT),ALPHA(NVAR2)
       DIMENSION SIGMAA(NVAR1),ARRAY(NVAR,NVAR),V(NVAR),BU(NVAR)
       DIMENSION TEST(NVAR1),TEST2(NVAR1),IND2(NTOT),XX(NVAR,NTOT)
       DIMENSION Z(NTOT),W(NTOT),WX(NTOT),T(NTOT),TY(NTOT),ZY(NTOT)
       DIMENSION IPT(NTOT),ND(NTOT),NO(NTOT)
C
C      *               INITIALIZATION                                       *
C
       ITE=0
       DO 343 J=1,NVAR
          V(J) =0.0
          BU(J)=0.0
  343  CONTINUE

       DO 392 IN=1,NVAR1
          TEST(IN)=0.0
          TEST2(IN) =0.0
  392  CONTINUE
C
C      *       CALCULATE SOME VALUES FOR THE STANDARD DEVIATION             *
C
       DO 5 I=1,NTOT
          IF(IND(I).EQ.0) THEN
             DO 63 J=1,NVAR
                V(J)=V(J)+X(J,I)
   63        CONTINUE
          ENDIF
    5  CONTINUE

       DO 68 J=1,NVAR
          V(J)=V(J)/REAL(NU)
   68  CONTINUE

       DO 51 I=1,NTOT
          IF(IND(I).EQ.0) THEN
             DO 53 J=1,NVAR
                BU(J)=BU(J)+(X(J,I)-V(J))**2
   53        CONTINUE
       ENDIF
   51  CONTINUE
C
C      *      REGRES : SUBPROGRAM FOR LINEAR REGRESSION WITHOUT             *
C      *               CONSIDERING CENSORING STATUS                         *
C
       CALL REGRES(X,Y,NTOT,NVAR,ALPHA,SIGMAA,ARRAY)
C
C      *              GET RESIDUALS Z(I)                                    *
C
C      *       START ITERATION : 2000 LOOP.                                 *
C
C
 2000  DO 31 I=1,NTOT
          T(I)=-400.0
          IND2(I)=IND(I)
C
          ZS=0.0
          DO 61 J=1,NVAR
             JJ=J+1
             ZS=ZS+ALPHA(JJ)*X(J,I)
             XX(J,I)=X(J,I)
   61     CONTINUE
          Z(I) =Y(I)-ZS
          TY(I)=Y(I)
   31  CONTINUE
C
C      *            SORTING .... INCREASING ORDER                           *
C
       CALL BJSORT(IND2,XX,TY,Z,NVAR,NTOT)
C
       DO 311 I=1,NTOT
          ZY(I)=Z(I)
  311  CONTINUE
C
C      *       THE LARGEST RESIDUAL MUST BE UNCENSORED.                     *
C
       IND2(NTOT)=0
C
C      *      ESTIMATE  VALUES FOR CENSORED DATA                            *
C      *                                                                    *
C      *    TY(I)=YY(I)*DEL+((ALPHA*X+SUM(WXX(K)*Z(K))/(1-W(I)))*(1-DEL)    *
C      *     WHERE                                                          *
C      *          TY   : ESTIMATED DEPENDENT VALUE                          *
C      *          DEL  : IF THE DATA IS UNCENSORED :DEL=1.0                 *
C      *                 IF THE DATA IS CENSORED  :DEL=0.0                  *
C      *          SUM  : SUM OVER UNCENSORED DATA Z(K)<Z(I)                 *
C      *          WX   : WEIGHT ... W(I-1)-W(I)                             *
C      *          W    : KAPLAN-MEIER PRODUCT LIMIT ESTIMATOR               *
C
C
       K=0
       DO 21 I=1,NTOT
          IF((IND2(I).NE.0).OR.(K.NE.0)) THEN
             IF(IND2(I).NE.0) THEN
                IPT(I)=K
                GOTO 21
             ENDIF
             IF((IND2(I).EQ.0).AND.(ZY(I).EQ.T(K))) THEN
                ND(K)=ND(K)+1
                IPT(I)=K
                GOTO 21
             ENDIF
          ENDIF
          ND(K+1)=1
          T(K+1)=ZY(I)
          IPT(I)=K+1
          K=K+1
   21  CONTINUE
C
       NI=K
       DO 28 I=1,NI
          NO(I)=0
          IDZ=0
   28  CONTINUE
C
       DO 29 I=1,NTOT
C
C      *      IF THE FIRST POINT IS A CENSORED VALUE, DROP THE POINT.       *
C      *      PT RUNS FROM 1 TO NU.                                         *
C
          IF(IPT(I).EQ.0) IDZ=IDZ+1
          IF(IPT(I).GT.0) NO(IPT(I))=NO(IPT(I))+1
   29  CONTINUE

       DENOM=REAL(NTOT-IDZ)
       W(1)=1.0-ND(1)/DENOM
       WJ=NTOT-NO(1)-IDZ
C
       DO 30 I=2,NI
          W(I)=W(I-1)*(1.0-ND(I)/WJ)
          WJ=WJ-NO(I)
   30  CONTINUE

       WX(1)=1.0-W(1)
C
       DO 41 I=2,NI
          WX(I)=W(I-1)-W(I)
   41  CONTINUE
C
       DO 83 I=1,NI
          WX(I)=WX(I)/REAL(ND(I))
   83  CONTINUE
C
       Z(NTOT)=0.0
       DO 36 JJ=2,NTOT
          I=NTOT-JJ+1
          Z(I)=Z(I+1)
          IF((ZY(I+1).GT.ZY(I)).AND.(IND2(I+1).EQ.0))
     +                           Z(I)=Z(I+1)+WX(IPT(I+1))*ZY(I+1)
   36  CONTINUE
C
       III=NTOT-1
       DO 32 I=1,III
          IF(IPT(I).GT.0) Z(I)=Z(I)/W(IPT(I))
          IF(IND2(I).NE.0) THEN
             ZS=0.0
             DO 62 J=1,NVAR
                JJ=J+1
                ZS=ZS+ALPHA(JJ)*XX(J,I)
   62        CONTINUE
             TY(I)=Z(I)+ZS
          ENDIF
   32  CONTINUE
C
       CALL REGRES(XX,TY,NTOT,NVAR,ALPHA,SIGMAA,ARRAY)
       ITE=ITE+1
C
C       *        TEST FOR CONVERGENCE                                       *
C       *     TEST(I) CONTAINS A PREVIOUS VALUE OF ALPHA(I).                *
C       *     IF NUMBER OF ITERATION EXCEEDS MAXITS, THE PROGRAM STOPS      *
C       *     TO CONTINUE ITERATION, EVEN IF TOLERANCE IS LARGER THAN       *
C       *     THE ASSIGNED VALUE. SINCE THE FINAL VALUES ARE OFTEN          *
C       *     TRAPPED IN OSCILLATION, THE PROGRAM TAKES AVERAGE OF THE      *
C       *     LAST TWO VALUES FOR THE FINAL OUTPUT.                         *
C
       IF(ITE.LE.MAX) THEN

          SUM=0.0
          DO 154 K=1,NVAR1
             SUM=SUM+(ALPHA(K)-TEST2(K))**2
             TEST2(K)=TEST(K)
             TEST(K)=ALPHA(K)
  154     CONTINUE
C
C       *  IF THE DIFFERENCE IS LARGER THAN THE TOLERANCE, REPEAT ITERATION *
C
  234     IF(DSQRT(SUM).GT.TOL) GOTO 2000
       ENDIF
C
C       *  THE CONVERSION IS OBTAINED OR THE ITERATION REACHED THE MAX.     *
C
       DO 270 K=1,NVAR1
          ALPHA(K)=(ALPHA(K)+TEST2(K))/2.0
  270  CONTINUE
C
C      *             CALCULATION OF VARIANCE ETC.                           *
C
       STD=0.0
       EM =0.0
       K=NTOT
       DO 35 I=1,NTOT
          IF(IND(I).EQ.0) THEN

             ZS=0.0
             DO 84 J=1,NVAR
                JJ=J+1
                ZS=ZS+ALPHA(JJ)*X(J,I)
   84        CONTINUE

             Z(I)=Y(I)-ZS
             EM=EM+Z(I)
          ENDIF
   35  CONTINUE

       EM=EM/REAL(NU)
       DO 37 I = 1,NTOT
          IF(IND(I) .EQ. 0) THEN
             EM2 = Z(I) - EM
             STD = STD+EM2*EM2
          ENDIF
   37  CONTINUE

       STD=STD/FLOAT(NU-NVAR1)

       DO 76 I=1,NVAR
          SIGMAA(I+1)=DSQRT(STD/BU(I))
   76  CONTINUE

       ALPHA(NVAR2)=DSQRT(STD)

       RETURN
       END


      REAL FUNCTION slRVLK (R2000, D2000)
*+
*     - - - - - - -
*      R V L K
*     - - - - - - -
*
*  Velocity component in a given direction due to the Sun's motion
*  with respect to an adopted kinematic Local Standard of Rest.
*
*  (single precision)
*
*  Given:
*     R2000,D2000   r    J2000.0 mean RA,Dec (radians)
*
*  Result:
*     Component of "standard" solar motion in direction R2000,D2000 (km/s)
*
*  Sign convention:
*     The result is +ve when the Sun is receding from the given point on
*     the sky.
*
*  Note:  The Local Standard of Rest used here is one of several
*         "kinematical" LSRs in common use.  A kinematical LSR is the
*         mean standard of rest of specified star catalogues or stellar
*         populations.  The Sun's motion with respect to a kinematical
*         LSR is known as the "standard" solar motion.
*
*         There is another sort of LSR, the "dynamical" LSR, which is a
*         point in the vicinity of the Sun which is in a circular orbit
*         around the Galactic centre.  The Sun's motion with respect to
*         the dynamical LSR is called the "peculiar" solar motion.  To
*         obtain a radial velocity correction with respect to the
*         dynamical LSR use the routine slRVLD.
*
*  Reference:  Delhaye (1965), in "Stars and Stellar Systems", vol 5,
*              p73.
*
*  Called:
*     slCS2C, slVDV
*
*  P.T.Wallace   Starlink   11 March 1994
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL R2000,D2000

      REAL VA(3), VB(3)

      REAL slVDV

*
*  Standard solar motion (from Methods of Experimental Physics, ed Meeks,
*  vol 12, part C, sec 6.1.5.2, p281):
*
*  20 km/s towards RA 18h Dec +30d (1900).
*
*  The solar motion is expressed here in the form of a J2000.0
*  equatorial Cartesian vector:
*
*      VA(1) = X = -SPEED*COS(RA)*COS(DEC)
*      VA(2) = Y = -SPEED*SIN(RA)*COS(DEC)
*      VA(3) = Z = -SPEED*SIN(DEC)

      DATA VA / -0.29000, +17.31726, -10.00141 /

*  Convert given J2000 RA,Dec to x,y,z
      CALL slCS2C(R2000,D2000,VB)

*  Compute dot product with solar motion vector
      slRVLK=slVDV(VA,VB)

      END


!Program Main
!REAL(8), DIMENSION(14,14) :: Sto_Coef
!DO k=1,10
! Print *, 'k=',k
!CALL Cal_Sto_Coef(15, k, Sto_Coef)
!DO j=1,14
! Write (*,'(1x,14f10.5)') (Sto_Coef(i,j),i=1,14)
!ENDDO
!ENDDO
!STOP
!END
!Subroutine Cal_Sto_Coef(Total_member, Cpl_Run_Calling_Number, Sto_Coef,year,mm,dd,hh,fhr,eps0,nr0,eps,nr)
 Subroutine Cal_Sto_Coef(Total_member, t1, t2, delt, Sto_Coef,year,mm,dd,hh,fhr,eps0,nr0,eps,nr)

! This subroutine is used to compute the stochastic coefficients
! used to combine the tendency perturbation to generate the
! stochastic forcing for each ensemble member
!-------------------------------------------------------------

 USE pran
 USE peuc
 USE prana

 implicit none
 INTEGER                                                             :: Total_member
!INTEGER                                                             :: Cpl_Run_Calling_Number
 INTEGER                 :: t,t1,t2, delt
 REAL(8), DIMENSION(Total_member - 1, Total_member - 1) :: Sto_Coef
!REAL(KIND=KIND_EVOD), DIMENSION(Total_member - 1, Total_member - 1) :: Sto_Coef
!REAL(KIND=KIND_EVOD), DIMENSION(Total_member - 1)                   :: rp

 INTEGER                 :: i0
 INTEGER                 :: n, nt
 INTEGER                 :: iseed0, iseed2
 INTEGER                 :: iseed1(1:2)
!INTEGER                 :: iseed3(1:2),iseed4(1:2)
!INTEGER                 :: year,mm,dd,hh,nth,fhr,delt,fflag
 INTEGER                 :: year,mm,dd,hh,nth,fhr,fflag
!year-Year,mm=month,dd=day,hh=hour,fhr=forecast_hour
 INTEGER                 :: i,j,k
 INTEGER                 :: ksize,nrank,r,t0,iunit,nr0,nr
 REAL(8)                 :: x,eps0,eps,g
 INTEGER                 :: yyc,mmc,ddc,hhc,fhrc,yyi,mmi,ddi,hhi

! Working arrays.
!----------------
 REAL(8), DIMENSION(Total_member-1,Total_member-1) :: a,b,c,d,e,ident,b0
!REAL(KIND=KIND_EVOD), DIMENSION(Total_member - 1, Total_member - 1) :: work1
!REAL(KIND=KIND_EVOD), DIMENSION(Total_member - 1, Total_member - 1) :: work2

!Setting the constants
!year = 2006
!mm = 08
!dd = 16
!hh = 00
!fhr = 120
 print *,'STPS',year,mm,dd,hh,fhr
 print *,'STPS',Total_member, t1, t2, delt
 print *,'STPS',eps0,nr0,eps,nr

 n = Total_member - 1
!t = Cpl_Run_Calling_Number
 ident=identity(Total_member - 1)

!Setting the seed (seed2) based on the date(yyyymmddhh)
!and generate the initial value of the Sto_Coef-Matric
 call random_seed(size=ksize)
 print *,'STPS',ksize
      CALL INITDATE(year,mm,dd,hh,fhr,yyi,mmi,ddi,hhi)

do t=t1+1,t2,1
      fhrc=delt*t
      CALL CURRDATE(yyi,mmi,ddi,hhi,fhrc,yyc,mmc,ddc,hhc)
 iseed0=yyc+mmc+ddc+hhc+1
!iseed0=year+mm+dd+hh+1
 iseed1=iseed0

#ifdef IBM
 call random_seed(generator=2)
#endif

 call random_seed(put=iseed1(1:ksize))
!call random_seed(get=iseed3(1:ksize))
 call random_number(x)
!call random_seed(get=iseed4(1:ksize))
 iseed2=iseed0+nint(x*1000)
 print *, 'STPS ISEED_A:', x,iseed0,iseed1,iseed2
!print *, 'STPS ISEED_A:', x,iseed3,iseed4
!IF (Cpl_Run_Calling_Number .eq. 1 ) THEN
!IF (t1 .eq. 1 ) THEN
!IF (t1 .eq. 0 ) THEN    !up to Em
 IF (t .eq. 1 ) THEN     !starting in En
   call plant1(iseed2)
   call ranrot(a)
   Sto_Coef = a
!  print *,a
 ENDIF

!Generating the fixed rotation matrix (b0) based on eps0 and nr0
 if (eps0.lt.0.000001.or.nr0.lt.1) then
 b0=ident
 else
 iseed2=iseed2-1*delt*1000
 print *, 'STPS ISEED_B:', iseed2
 call plant1(iseed2)
 do j=1,n; do i=1,n; call gauss(b(i,j)); enddo; enddo
!print *,b
!apply gram process to the matrix (I+epsilon*A) where A=I+(b-bT)
 b=b-transpose(b)
 c=ident+eps0*b
 call gram(c,nrank);b=c
!NOW b is R matrix if nr0=1
 do r=1,nr0-1;
   b=matmul(b,c)
 enddo
! Now b is the R matrix after nr0 times of rotation
 b0=b
 endif
!print *,b0

!do t=t1,t2,1
!do t=t1+1,t2,1
!Generate the random rotation matrix (b) based on eps and nr
 iseed2=iseed2+t*delt*1000
 print *, 'STPS ISEED_C:', iseed2
 call plant1(iseed2)
   do j=1,n; do i=1,n; call gauss(b(i,j)); enddo; enddo
!apply gram process to the matrix (I+epsilon*A) where A=I+(b-bT)
   b=b-transpose(b)
   c=ident+eps*b
   call gram(c,nrank);b=c
!NOW b is R matrix if nr=1
 do r=1,nr-1;
   b=matmul(b,c)
 enddo
! Now b is the R matrix after nr times of rotation
!print *,b

! Generate the Current matrix (b=a X b0 X b)
   a=Sto_Coef
   b=matmul(b0,b)   !b=b0 x b1, R(t)=R0(t=0) x R1(t)
   d=matmul(a,b)   !d=a x b, C(t)=C(t-1) x R
! Updating a matrix (C)
   a=d
   Sto_Coef = d
enddo  !  the loop of t=t1+1,t2,1

! Print the coefficients!
  print *, 'STPS coefficients:'
 DO j=1,n
 if (n.eq.14) then
  Write (*,'(1x,14f10.5)') (Sto_Coef(i,j),i=1,n)
 elseif (n.eq.2) then
  Write (*,'(1x,2f10.5)') (Sto_Coef(i,j),i=1,n)
 elseif (n.eq.3) then
  Write (*,'(1x,3f10.5)') (Sto_Coef(i,j),i=1,n)
 elseif (n.eq.20) then
  Write (*,'(1x,20f10.5)') (Sto_Coef(i,j),i=1,n)
 else
  print *, 'Format is not provided for n=',n
  Write (*,'(1x,20f10.5)') (Sto_Coef(i,j),i=1,n) ! RLW 20080710 add for unspecified format
 endif
 ENDDO

 END SUBROUTINE Cal_Sto_Coef

      SUBROUTINE CURRDATE(yy,mm,dd,hh,fhr,yyc,mmc,ddc,hhc)
      integer yy,mm,dd,hh,fhr,yyc,mmc,ddc,hhc
      integer ndpm(12),mdpm,fhrd,fhrh,itest
      data ndpm/31,28,31,30,31,30,31,31,30,31,30,31/

      yyc=yy
      mmc=mm
      ddc=dd
      hhc=hh

! Adgust dd and hh, while mm and yy unchanged
      fhrh=mod(fhr,24)
      fhrd=fhr/24
      hhc=hhc+fhrh
      ddc=ddc+fhrd
      if (hhc.ge.24) then
       hhc=hhc-24
       ddc=ddc+1
      endif

! Adjust mm and yy, and dd, Month by Month
      do itest=1,100
      mdpm=ndpm(mmc)
      if (mmc.eq.2.and.mod(yyc,4).eq.0) mdpm=mdpm+1
      if (mmc.eq.2.and.(mod(yyc,100).eq.0.and.mod(yyc,400).ne.0)) mdpm=mdpm-1
      if (mmc.le.12.and.ddc.le.mdpm) then
       print *, 'STPS INIT',yy,mm,dd,hh,fhr,yyc,mmc,ddc,hhc
       return
      endif
      if (ddc.gt.mdpm) then
!Month advancement
        ddc=ddc-mdpm
        mmc=mmc+1
      endif
      if (mmc.gt.12) then
!Year advancement
           mmc=1
           yyc=yyc+1
      endif
      enddo

      print *, 'Forced stop in INITDATE subrountine'
      print *, yy,mm,dd,hh,fhr,yyc,mmc,ddc,hhc
      stop
      end

      SUBROUTINE INITDATE(yy,mm,dd,hh,fhr,yyi,mmi,ddi,hhi)
      integer yy,mm,dd,hh,fhr,yyi,mmi,ddi,hhi
      integer ndpm(12),mdpm,fhrd,fhrh,itest
      data ndpm/31,28,31,30,31,30,31,31,30,31,30,31/

      yyi=yy
      mmi=mm
      ddi=dd
      hhi=hh

! Adjust dd and hh, while mm and yy unchanged
      fhrh=mod(fhr,24)
      fhrd=fhr/24
      hhi=hhi-fhrh
      ddi=ddi-fhrd
      if (hhi.lt.0) then
       hhi=hhi+24
       ddi=ddi-1
      endif

!Adjust mm and yy, and dd, Month by Month
      do itest=1,100
      if (mmi.ge.1.and.ddi.ge.1) then
       print *, 'STPS INIT',yy,mm,dd,hh,fhr,yyi,mmi,ddi,hhi
       return
      endif
      mdpm=ndpm(mmi-1)
      if (mmi.eq.1) mdpm=ndpm(12)
      if (mmi.eq.3.and.mod(yyi,4).eq.0) mdpm=mdpm+1
      if (mmi.eq.3.and.(mod(yyi,100).eq.0.and.mod(yyI,400).ne.0)) mdpm=mdpm-1
      if (ddi.lt.1) then
!Month advancement
        ddi=ddi+mdpm
        mmi=mmi-1
      endif
      if (mmi.lt.1) then
!Year advancement
           mmi=12
           yyi=yyi-1
      endif
      enddo

      print *, 'Forced stop in INITDATE subrountine'
      print *, yy,mm,dd,hh,fhr,yyi,mmi,ddi,hhi
      stop
      end


subroutine swap_real(a1, a2)

   implicit none

!  Input/Output
   real, intent(inout) :: a1(:), a2(:)

!  Locals
   integer :: lb(1), ub(1)  ! Lower and Upper bounds
   integer :: i
   real :: a

!  Get bounds
   lb = lbound(a1)
   ub = ubound(a1)

!  Swap
   do i = lb(1), ub(1)
      a = a1(i)
      a1(i) = a2(i)
      a2(i) = a
   end do

end subroutine swap_real


*DECK DEFEHL
      SUBROUTINE DEFEHL (F, NEQ, T, Y, H, YP, F1, F2, F3, F4, F5, YS,
     +   RPAR, IPAR)
C***BEGIN PROLOGUE  DEFEHL
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DERKF
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (DEFEHL-S, DFEHL-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C     Fehlberg Fourth-Fifth order Runge-Kutta Method
C **********************************************************************
C
C    DEFEHL integrates a system of NEQ first order
C    ordinary differential equations of the form
C               dU/DX = F(X,U)
C    over one step when the vector Y(*) of initial values for U(*) and
C    the vector YP(*) of initial derivatives, satisfying  YP = F(T,Y),
C    are given at the starting point X=T.
C
C    DEFEHL advances the solution over the fixed step H and returns
C    the fifth order (sixth order accurate locally) solution
C    approximation at T+H in the array YS(*).
C    F1,---,F5 are arrays of dimension NEQ which are needed
C    for internal storage.
C    The formulas have been grouped to control loss of significance.
C    DEFEHL should be called with an H not smaller than 13 units of
C    roundoff in T so that the various independent arguments can be
C    distinguished.
C
C    This subroutine has been written with all variables and statement
C    numbers entirely compatible with DERKFS. For greater efficiency,
C    the call to DEFEHL can be replaced by the module beginning with
C    line 222 and extending to the last line just before the return
C    statement.
C
C **********************************************************************
C
C***SEE ALSO  DERKF
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800501  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891009  Removed unreferenced statement label.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  DEFEHL
C
C
      DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*),
     1          YS(*),RPAR(*),IPAR(*)
C
C***FIRST EXECUTABLE STATEMENT  DEFEHL
      CH=H/4.
      DO 230 K=1,NEQ
  230   YS(K)=Y(K)+CH*YP(K)
      CALL F(T+CH,YS,F1,RPAR,IPAR)
C
      CH=3.*H/32.
      DO 240 K=1,NEQ
  240   YS(K)=Y(K)+CH*(YP(K)+3.*F1(K))
      CALL F(T+3.*H/8.,YS,F2,RPAR,IPAR)
C
      CH=H/2197.
      DO 250 K=1,NEQ
  250   YS(K)=Y(K)+CH*(1932.*YP(K)+(7296.*F2(K)-7200.*F1(K)))
      CALL F(T+12.*H/13.,YS,F3,RPAR,IPAR)
C
      CH=H/4104.
      DO 260 K=1,NEQ
  260   YS(K)=Y(K)+CH*((8341.*YP(K)-845.*F3(K))+
     1                            (29440.*F2(K)-32832.*F1(K)))
      CALL F(T+H,YS,F4,RPAR,IPAR)
C
      CH=H/20520.
      DO 270 K=1,NEQ
  270   YS(K)=Y(K)+CH*((-6080.*YP(K)+(9295.*F3(K)-5643.*F4(K)))+
     1                             (41040.*F1(K)-28352.*F2(K)))
      CALL F(T+H/2.,YS,F5,RPAR,IPAR)
C
C     COMPUTE APPROXIMATE SOLUTION AT T+H
C
      CH=H/7618050.
      DO 290 K=1,NEQ
  290   YS(K)=Y(K)+CH*((902880.*YP(K)+(3855735.*F3(K)-1371249.*F4(K)))+
     1                (3953664.*F2(K)+277020.*F5(K)))
C
      RETURN
      END


      program testg1g2
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c        this subroutine tests the greens function
c        in the farkas representation for the helmholtz stokes
c        equation with the formula in the jiang-quaife-kropinski
c        paper
cccccc

      implicit real *8 (a-h,o-z)
      real *8 dtoobig, dtoosmall
      complex *16 eye
      data eye / (0.0d0,1.0d0) /
      complex *16 zk
      real *8 rr,rnsrc(2),rntarg(2),source(2),targ(2)
      complex *16 val,grad(2),hess(4),val2

      call prini(6,13)
      call prin2('Enter n*',n,0)
      read *, n

      done = 1
      pi = atan(done)*4

      zk = 1 + hkrand(0)
      source(1) = hkrand(0)
      source(2) = hkrand(0)

      targ(1) = hkrand(0) + 2.0d0
      targ(2) = hkrand(0)

      thet = 2.0d0*pi*hkrand(0)
      rnsrc(1) = cos(thet)
      rnsrc(2) = sin(thet)

      thet = 2.0d0*pi*hkrand(0)
      rntarg(1) = cos(thet)
      rntarg(2) = sin(thet)

cc      call prin2('rnsrc=*',rnsrc,2)

      call zhfark_ck1(zk,source,targ,rnsrc,pars2,val,
     1   grad,hess)

      call helmstokes_fark_g1_jiang(zk,source,targ,rnsrc,val2)

cc      call prin2('val=*',val,2)
cc      call prin2('val2=*',val2,2)

      err = abs(val-val2)
      call prin2('error kernel1=*',err,1)

      val = 0
      val2 = 0
      call zhfark_ck2(zk,source,targ,rnsrc,pars2,val,
     1   grad,hess)

      call helmstokes_fark_g2_jiang(zk,source,targ,rnsrc,val2)

cc      call prin2('val=*',val,2)
cc      call prin2('val2=*',val2,2)

      err = abs(val-val2)
      call prin2('error kernel2=*',err,1)

      stop
      end

c------------------------------------------------

      subroutine helmstokes_fark_g2_jiang(zk,src,targ,rnsrc,val)
      implicit real *8 (a-h,o-z)
      complex *16 zk,val,zk2,hanks(0:100),ima,ztmp
      data ima/(0.0d0,1.0d0)/
      real *8 src(2),targ(2),rnsrc(2)

      done = 1
      pi = atan(done)*4

cc      call prin2('src=*',src,2)

      dx = targ(1) - src(1)
      dy = targ(2) - src(2)

      rr = sqrt(dx**2 + dy**2)
      rrn = dx*rnsrc(1) + dy*rnsrc(2)

      zk2 = rr*zk

cc      call prin2('zk2=*',zk2,2)
cc      call prin2('zk=*',zk,2)

      ifexpon = 1
      call hanks104(zk2,hanks(0),5,ifexpon)

cc      call prin2('hanks=*',hanks(0),10)

      ztmp = pi*ima/2*(hanks(0)-2/zk2*hanks(1)) + 2/zk2**2
      val = -ztmp*(0.5d0-rrn**2/rr**2)/pi

      return
      end
c---------------------------------

      subroutine helmstokes_fark_g1_jiang(zk,src,targ,rnsrc,val)
      implicit real *8 (a-h,o-z)
      complex *16 zk,val,zk2,hanks(0:100),ima,ztmp,ztmp2,ztmp3
      data ima/(0.0d0,1.0d0)/
      real *8 src(2),targ(2),rnsrc(2)

      done = 1
      pi = atan(done)*4

cc      call prin2('src=*',src,2)

      dx = targ(1) - src(1)
      dy = targ(2) - src(2)

      rr = sqrt(dx**2 + dy**2)
      rrn = dx*rnsrc(1) + dy*rnsrc(2)

      zk2 = rr*zk

cc      call prin2('zk2=*',zk2,2)
cc      call prin2('zk=*',zk,2)

      ifexpon = 1
      call hanks104(zk2,hanks(0),5,ifexpon)

cc      call prin2('hanks=*',hanks(0),10)

      ztmp = pi*ima/2*(hanks(0)-2/zk2*hanks(1)) + 2/zk2**2
      ztmp2 = 3*ztmp + pi*ima/2*zk2*hanks(1) + 0.5d0
      ztmp3 = 4*ztmp + pi*ima/2*zk2*hanks(1)

cc      call prin2('ztmp=*',ztmp,2)
cc      call prin2('ztmp2=*',ztmp2,2)
cc      call prin2('ztmp3=*',ztmp3,2)
      val = -rrn/pi/rr**2*ztmp2 + rrn**3/pi/rr**4*ztmp3

      return
      end
c---------------------------------


      module MOD_PLOTT

      contains

      SUBROUTINE PLOTT (ND,R,T,MODHEAD,JOBNUM)

C***  DIRECT TRANSFER OF THE TEMPERATURE STRATIFICATION T(R) VERSUS LOG(R/R*-1)

      use MOD_ISRCHFLT
      use MOD_ISRCHFLE
      use MOD_PLOTANF
      implicit real*8(a-h,o-z)

C***  TRANSFER OF "YMAX" FROM SUBR. DECSTAR
      COMMON / COMPLOT / YMAX
      DIMENSION X(100),Y(100)
      DIMENSION R(ND),T(ND)
      CHARACTER HEAD1*60,HEAD2*60,MODHEAD*104

C***  INITIALIZATION
      KANAL=2
      OPEN (KANAL,FILE='PLOT')
C      CALL JSYMSET (2LG2,'TRANSFER')
      write (6,*) 'T-STRATIFICATION TO BE ROUTED'

C***  RADIUS RANGE:   2. > LOG(R/R*-1) > -3.5
      LMIN= ISRCHFLT(ND,R(1),1,101.)
      LMAX= ISRCHFLE(ND,R(1),1,1.000316228) - 1
      NDL=LMAX-LMIN+1
      IF (NDL .GT. 100) THEN
         write (6,*) 'T-PLOT IMPOSSIBLE'
         RETURN
         ENDIF
      DO 5 L=1,NDL
      X(L)=LOG10(R(LMAX+1-L)-1.d0)
      Y(L)=T(LMAX+1-L)/1.d3
    5 CONTINUE
C***  PLOT PARAMETER
      XMIN=-3.5
      XMAX=2.
      YMIN=0.
      IF (YMAX .EQ. 0.) YMAX=10.*(INT(Y(1)/10.)+1.d0)
      XSCALE=4.
      YSCALE=15./YMAX
      XTICK=0.5
      YTICK=10.
      XABST=1.
      YABST=10.
      HEAD1=' WR TEMPERATURE STRATIFICATION T(R) VERSUS LOG(R/R*-1) '
c      ENCODE(60,9,HEAD2) JOBNUM
      write (head2,9) jobnum
    9 FORMAT (19X,1HJ,I3)
      HEAD2(1:18)=MODHEAD(15:32)
      HEAD2(24:56)=' TEMPERATURE STRATIFICATION T(R)'
      CALL PLOTANF (KANAL,HEAD1,HEAD2
     $ ,60H      LOG (R/R* - 1)
     $ ,60H      T(R) / KK
     $ ,XSCALE,XMIN,XMAX,XTICK,XABST,.0
     $ ,YSCALE,YMIN,YMAX,YTICK,YABST,.0
     $ ,X,Y,NDL,5)

      RETURN
      END subroutine
      end module


!===================================================================================
!=================== SUBROUTINE ADAMS BASHFORTH ====================================
!===================================================================================

subroutine ab2css(Nx,Ny,Nh,alpha,nu,time,dt,omegak,omegak_new,dt_omegak_old,dt_omegak_new)
implicit none
integer ( kind = 4 ) Nx,Ny,Nh, i, j
real ( kind = 8 ) time,dt,alpha,nu,lambda
complex ( kind = 8 ) omegak(Nh,Ny),omegak_new(Nh,Ny)
complex ( kind = 8 ) dt_omegak_old(Nh,Ny)
complex ( kind = 8 ) dt_omegak_new(Nh,Ny)

do i = 1,Nh
  do j = 1,Ny
    omegak_new(i,j) = omegak(i,j) + ( (3.0d0/2.0d0)*dt_omegak_new(i,j) - (1.0d0/2.0d0)*dt_omegak_old(i,j) )*dt
  end do
end do

return

end subroutine ab2css


module solv_cap
!
! Compute electric charge distribution on flat conductor
! Version 1.51, Jul 1998, J. Bergervoet

  implicit none

  public  :: solveC, solveP, init_solve

  private :: solve, mv_prod, prod0, prod1, Preco, FourirG, Ginteg, Vprim,  &
             fourir, Fourir2D, Fourir2DX, cgstab, div_care

  integer, parameter, public :: dp = selected_real_kind(5)
!   kind=dp is the default precision (select 5 for single, 15 for double)

  real(kind=dp), private :: Pi, Mu0, c0, eps0
  logical,       private :: UseFFT, UsePreco
  real(kind=dp), private :: D1, D2
  integer,       private, save :: Ng1=0, Ng2=0
  integer,       private, pointer,     dimension(:,:)  :: Grid
  real(kind=dp), private, allocatable, dimension(:,:)  :: G

contains

  subroutine init_solve(Grid_in, GrSize1, GrSize2, UseFFT_in, UsePreco_in)
    integer, intent(in), target, dimension(:,:) :: Grid_in
    real(kind=dp), intent(in)  :: GrSize1, GrSize2
    logical,       intent(in)  :: UseFFT_in, UsePreco_in
    integer                    :: i, j

    Pi = acos(-1.0_dp)
    Mu0 = 4e-7_dp * Pi
    c0 = 299792458             ! Speed of light in m/s (def)
    eps0 = 1 / (Mu0 * c0**2)

    UseFFT = UseFFT_in
    UsePreco = UsePreco_in

    if(Ng1 /= 0 .and. allocated(G) ) then
      deallocate( G )
    end if

    Grid => Grid_in
    Ng1 = size(Grid, 1)
    Ng2 = size(Grid, 2)
    D1 = GrSize1/Ng1
    D2 = GrSize2/Ng2           ! The elements have size D1 by D2, in meters.

    allocate( G(0:Ng1,0:Ng2) ) ! who does dealloc ???

    write(unit=*, fmt=*) "Calculating G"
    do i=0,Ng1
      do j=0,Ng2
        G(i,j) = Ginteg( -D1/2,-D2/2, D1/2,D2/2, i*D1,j*D2 )
      end do
    end do

    if(UseFFT) then
      write(unit=*, fmt=*) "Transforming G"
      call FourirG(G,1)
    end if

    return
  end subroutine init_solve

  subroutine solveC(C)
    real(kind=dp), intent(out) :: C

    real(kind=dp), allocatable, dimension(:,:)  :: Y0, X

    allocate( Y0(Ng1,Ng2), X(Ng1,Ng2) )

    Y0 = Grid                      ! RHS: V=1, where metal on grid

    call solve( X, Y0 )

    C = sum(X)*D1*D2 * 4*Pi*eps0   ! Capacitance of object

    deallocate( X, Y0 )
    return
  end subroutine solveC

  subroutine solveP(P)
    real(kind=dp), intent(out) :: P

    real(kind=dp), allocatable, dimension(:,:)  :: Y0, X
    integer :: i,j

    allocate( Y0(Ng1,Ng2), X(Ng1,Ng2) )

    do i=1,Ng1
      do j=1,Ng2
        Y0(i,j) = D1 * (i-(Ng1+1)/2.0_dp) * Grid(i,j)
      end do
    end do     ! RHS for in-field E_x=1.  V = -V_in = x, where metal on grid

    call solve( X, Y0 )

    X = X - sum(X)/size(X)         ! get rid of monopole term ..
    do i=1,Ng1                     !   .. and multiply charge with x
      do j=1,Ng2
        X(i,j) = X(i,j) * D1 * (i-(Ng1+1)/2.0_dp)
      end do
    end do
    P = sum(X)*D1*D2 * 4*Pi*eps0   ! E-dipole moment in 1 V/m field

    deallocate( X, Y0 )
    return
  end subroutine solveP

  subroutine solve(X, Y)
    !
    ! Solve : Mvprod * X = Y
    !
    real(kind=dp), intent(in),  dimension(:,:)  :: Y
    real(kind=dp), intent(out), dimension(:,:)  :: X
    real(kind=dp), allocatable, dimension(:)    :: Ar1
    integer  :: iter

    allocate( Ar1(Ng1*Ng2) )

    Ar1 = reshape( Y, (/Ng1*Ng2/) )        ! put RHS in 1-dim array

    write(unit=*, fmt=*) "Starting Bi-CGSTAB, for accuracy 1e-6,   N=",Ng1*Ng2
    call cgstab( Ar1, 1e-6_dp, Ng1+Ng2+20, iter )

    X = reshape( Ar1, (/Ng1,Ng2/) )        ! put sulution in 2-dim array

    call mv_prod( Ar1, Ar1 )               ! do last check

    write(unit=*, fmt=*) iter, " iterations,   RHS_error =",  &
      maxval(abs( reshape(Ar1,(/Ng1,Ng2/)) - Y ))

    if(UsePreco) then
      call Preco(X)
    end if

    deallocate( Ar1 )
    return
  end subroutine solve

  subroutine mv_prod(X, Yp)         ! Matrix-vector product (vector = grid)
    real(kind=dp), intent(in),  dimension(:)   :: X
    real(kind=dp), intent(out), dimension(:)   :: Yp
    real(kind=dp), allocatable, dimension(:,:) :: Y

    allocate( Y(Ng1,Ng2) )

    Y = reshape(X, (/Ng1,Ng2/))    ! Put charge-vector on Grid Y

    if(UsePreco) then
      call Preco(Y)
    end if

    where (Grid==0)                ! Restrict charges to conductor sub-space.
      Y = 0                        ! This projection reduces the rank of the
    end where                      ! operator. Iterative solvers allow that.

    if(UseFFT) then
      call prod1(G, Y)
    else
      call prod0(G, Y)
    end if

    where (Grid==0)                ! Restrict potential to conductor area.
      Y = 0                        ! The RHS was also contained in this
    end where                      ! subspace, that's why it works.

    Yp = reshape(Y,(/Ng1*Ng2/))

    deallocate( Y )
    return
  end subroutine mv_prod

  subroutine prod0( G, X )
  !   Apply Green function, no Fourier tfm.:  X = G o X
    real(kind=dp), intent(in),     dimension(0:,0:)  :: G
    real(kind=dp), intent(in out), dimension(:,:)    :: X
    integer   :: i, j, ip, jp
    real(kind=dp), dimension(size(X,1),size(X,2)) :: Y

    do i=1,Ng1
      do j=1,Ng2
        Y(i,j) = 0
        do ip=1,Ng1
          do jp=1,Ng2
            Y(i,j) = Y(i,j) + G(abs(i-ip),abs(j-jp)) * X(ip,jp)
          end do
        end do
      end do
    end do
    X = Y

    return
  end subroutine prod0

  subroutine prod1(G, X)
  !   Apply Green function with Fourier tfm.:  X = G o X
    real(kind=dp), intent(in),     dimension(0:,0:)  :: G
    real(kind=dp), intent(in out), dimension(0:,0:)  :: X
    complex(kind=dp), allocatable, dimension(:,:)    :: t
    integer :: j, jg

    allocate( t(0:Ng1,0:2*Ng2-1) )

    t = 0
    t(0:Ng1-1,0:Ng2-1) = X           ! Put X in corner of larger grid

    call Fourir2DX(t, 1)             ! 2D Fourier tfm. (to k-space)

    do j=0,2*Ng2-1
      jg = min (abs(j), abs(j-2*Ng2))
      t(:,j) = t(:,j) * G(:,jg)           ! Multiply with G in k-space
    end do

    call Fourir2DX(t, -1)            ! 2D inverse Fourier tfm.

    X = t(0:Ng1-1,0:Ng2-1)           ! Retain only this part of result

    deallocate( t )
    return
  end subroutine prod1

  subroutine Preco(X)
    !
    ! Preconditioner, based on estimated eigenvalues of the operator.
    !
    real(kind=dp), intent(in out), dimension(0:,0:)  :: X
    complex(kind=dp), allocatable, dimension(:,:)    :: t
    real(kind=dp)             :: K0, D
    integer                   :: i, j, is, js

    allocate( t(0:Ng1-1,0:Ng2-1) )
    t = X
    call Fourir2D(t, 1)

    K0 = 0.15_dp       ! To give preconditioner a finite value for k=0

    do j=0,Ng2-1
      js = min(j, Ng2-j)
      do i=0,Ng1-1
        is = min(i, Ng1-i)
        D = sqrt( (K0+is**2)/(D1*Ng1)**2 + (K0+js**2)/(D2*Ng2)**2 )
        t(i,j) = t(i,j) * D
      end do
    end do

    call Fourir2D(t, -1)

    X = t(0:Ng1-1,0:Ng2-1)

    where (Grid==0)                ! Restrict charges to conductor.
      X = 0
    end where

    deallocate( t )
    return
  end subroutine Preco

  subroutine FourirG(G, K)
    !
    ! Fourier transform 2D Green function

    real(kind=dp), intent(in out), dimension(0:,0:) :: G
    integer,       intent(in)                       :: K
    complex(kind=dp), allocatable, dimension(:,:)   :: t

    allocate( t(0:2*Ng1-1,0:2*Ng2-1) )

    t(0:Ng1,0:Ng2-1)    = G(:,0:Ng2-1)      ! Fill one quadrant (one extra row)
    t(0:Ng1,Ng2:2*Ng2-1) = G(:,Ng2:1:-1)    ! This quadrant using symmetry
    t(Ng1:2*Ng1-1,:)    = t(Ng1:1:-1,:)     ! Remaining half, using symmetry

    call Fourir2D(t, K)

    G = sqrt(4.0_dp*Ng1*Ng2) * t(0:Ng1,0:Ng2)   ! Use only this part

    deallocate( t )
    return
  end subroutine FourirG

  subroutine Fourir2D(X, K)
    complex(kind=dp), intent(in out), dimension(0:,0:)  :: X
    integer,          intent(in)                        :: K
    complex(kind=dp), dimension(max(size(X,1),size(X,2))/4) :: E
    integer  :: i,j

    do i=0,size(X,1)-1
      call fourir(X(i,:), size(X,2), K, E, UseOld=min(i,1))
    end do
    do j=0,size(X,2)-1
      call fourir(X(:,j), size(X,1), K, E, UseOld=min(j,1))
    end do

    return
  end subroutine Fourir2D

  subroutine Fourir2DX(X, K)
    !
    ! Double-sized C-Fourier transform 2-dim array (tricky)

    complex(kind=dp), intent(in out), dimension(0:,0:)  :: X
    integer,          intent(in)                        :: K
    complex(kind=dp), dimension( max(Ng1,Ng2)/2 )       :: E
    complex(kind=dp), dimension( 0 : 2*max(Ng1,Ng2)-1 ) :: temp
    integer  :: i,j

    if(K==1) then
      do i=0,Ng1-1
        temp(:Ng2-1) = X(i,:Ng2-1)
        temp(Ng2:2*Ng2-1) = 0
        call fourir(temp, 2*Ng2, K, E, UseOld=min(i,1))
        X(i,:) = temp(:2*Ng2-1)
      end do
      do j=0,2*Ng2-1
        temp(:Ng1-1) = X(:Ng1-1,j)
        temp(Ng1:2*Ng1-1) = 0
        call fourir(temp, 2*Ng1, K, E, UseOld=min(j,1))
        X(:,j) = temp(:Ng1)
      end do
    else
      do i=0,Ng1
        temp(:2*Ng2-1) = X(i,:)
        call fourir(temp, 2*Ng2, K, E, UseOld=min(i,1))
        X(i,:) = temp(:2*Ng2-1)
      end do
      do j=0,Ng2-1
        temp(:Ng1) = X(:Ng1,j)
        temp(Ng1:2*Ng1-1) = conjg( temp(Ng1:1:-1) )
        call fourir(temp, 2*Ng1, K, E, UseOld=min(j,1))
        X(:,j) = temp(:Ng1)
      end do
    end if

    return
  end subroutine Fourir2DX

  subroutine cgstab(X, err,mxiter,iter, X_start)
    !
    ! Bi-conjugate gradient squared stabilized.
    ! Van der Vorst's Bi-CGSTAB, 1992 SIAM J. Sci. Stat. Comput.
    !
    ! Solves x, for A*x = y,  where A*x is computed by mv_prod()
    ! On entry, X contains Y, on exit X is the found solution.
    ! If X_start is not present, X_start=0 is used.
    !
    integer,       intent(in)     :: mxiter
    real(kind=dp), intent(in)     :: err
    real(kind=dp), intent(in out), dimension(:)       :: X
    integer,       intent(out)                        :: iter
    real(kind=dp), intent(in), optional, dimension(:) :: X_start

    real(kind=dp), allocatable, dimension(:)  :: P, R, R0, S, T, V
    real(kind=dp) :: alpha, beta, omega, rho0, rho1, rnorm, ynorm
    integer       :: i, n

    n = size(X)
    allocate( P(n), R(n), R0(n), S(n), T(n), V(n) )

    ynorm = dot_product(X,X)
    if (present(X_start)) then
      call mv_prod(X_start,R)
      R = X - R
    else
      R = X
      X = 0
    end if

    R0 = R
    P = 0
    V = 0
    rho0 = 1
    alpha = 1
    omega = 1

    iter = 0
    do i=1,mxiter
        iter = i
        rho1 = dot_product(R0,R)
        beta = (rho1/rho0)* (alpha/omega)
        P = R + beta*(P-omega*V)
        call mv_prod(P,V)
        alpha = rho1/dot_product(R0,V)
        S = R - alpha*V
        call mv_prod(S,T)
        omega = div_care( dot_product(T,S), dot_product(T,T) )
        X = X + alpha*P + omega*S
        R = S - omega*T
        rnorm = dot_product(R,R)
        write(unit=*, fmt=*) "|r|/|y| =", sqrt(rnorm/ynorm)
        if (sqrt(rnorm/ynorm) < err) then
          exit                          ! exit this loop
        end if
        rho0 = rho1
    end do

    deallocate( P, R, R0, S, T, V )
    return
  end subroutine cgstab

  function div_care(a, b)  result(q)     ! avoid divide check error !!!
    real(kind=dp), intent(in) :: a, b
    real(kind=dp)             :: q
    real(kind=dp), parameter  :: large = huge(a)

    if( abs(a)/large < abs(b)) then      ! The normal case
      q = a/b
    else if( a == 0 ) then               ! The 0/0 case, return 1
      q = 1
    else                                 ! The a/0 case, return +-large
      q = large
      if( a < 0 ) then
        q = -q
      end if
      if( b < 0 ) then
        q = -q
      end if
    end if

    return
  end function div_care

  function Ginteg(xq1,yq1, xq2,yq2, xp,yp)  result(G)
    !        /    /
    !       | dy | dx  1/|r-p| dx dy
    !      /    /
    ! Potential in point p, from rectangular charge between corners q1, q2
    !
    real(kind=dp), intent(in) :: xq1,yq1, xq2,yq2, xp,yp
    real(kind=dp)             :: G
    real(kind=dp)             :: x1,x2,y1,y2,t
    x1 = xq1-xp
    x2 = xq2-xp
    y1 = yq1-yp
    y2 = yq2-yp

    if (x1+x2 < 0) then    ! Mirror in x-axis (for accuracy of Vprim)
      t = -x1
      x1 = -x2
      x2 = t
    end if
    if (y1+y2 < 0) then    ! Mirror in y-axis
      t = -y1
      y1 = -y2
      y2 = t
    end if

    G = Vprim(x2,y2)-Vprim(x1,y2)-Vprim(x2,y1)+Vprim(x1,y1)

    return
  end function Ginteg

  function Vprim(x,y)  result(VP)
    !
    ! Twice primitivated function, for Integral_dx Integral_dy 1/r, for z=0
    !
    real(kind=dp), intent(in) :: x,y
    real(kind=dp)             :: VP
    real(kind=dp)             :: r

    r = sqrt(x**2+y**2)
    VP = y*log(x+r) + x*log(y+r)

    return
  end function Vprim

  subroutine fourir(A,ntot,kconjg, E,useold)
    !
    ! Discrete Fourier transform. A becomes fourier tfm. of A
    !   A(k) := 1/sqrt(ntot) *
    !           sum(m=0,ntot-1)  A(m) * exp(kconjg*2*pi*i*k*m/ntot)
    ! ntot should be power of 2.
    ! kconjg = +1 or -1 for four.trans. or inverse four. trans.
    ! if useold=1, E(1:ntot/4-1) will be reused. if not, it is first filled:
    !      E(m) = exp(2*pi/ntot*i*m)
    ! Derived from recursive fft; Loop is in fact recursion.
    !
    complex(kind=dp), intent(inout), dimension(0:)    :: A
!    complex(kind=dp), intent(out), dimension(0:)   :: B
    complex(kind=dp), intent(in out), dimension(:) :: E
    integer, intent(in)                            :: ntot,kconjg,useold
    integer          :: m,n,j,i,inc,j0,j1,j2,j3
    complex(kind=dp) :: h,eh,Icc
    real(kind=dp)    :: root

    Icc = kconjg*(0.0_dp,1.0_dp)
    h = 2*acos(-1.0_dp)/ntot*Icc

    if (useold==0) then
      do m=1,ntot/4-1
        E(m) = exp(m*h)
      end do
    end if

    root = sqrt(1.0_dp/ntot)
    j=0
    i=0
    inc=1

    loop : do
      if(i<inc) then          ! normal entry
        if(inc==ntot) then
          if(i>j) then
            h=A(i)*root
            A(i)=A(j)*root
            A(j)=h
          else if(i==j) then
            A(j)=A(i)*root
          end if
          j=j+1
        else
          inc=inc*2
          if(inc>ntot) then
            write(unit=*, fmt=*) "error in fourier: n=", ntot
            stop
          end if
          cycle loop             ! recursive invocation I, followed by II
        end if
      else                       ! returned from recursive invocation II
        i=i-inc
        inc=inc/2
        n=ntot/inc
        j0=j-n
        j2=j0+n/2
        h = A(j0) + A(j2)
        A(j2) = A(j0) - A(j2)
        A(j0) = h
        if(n>2) then
          j1=j0+n/4
          j3=j2+n/4
          h = A(j1) + A(j3)*Icc
          A(j3) = A(j1) - A(j3)*Icc
          A(j1) = h
          do m=1,n/4-1
            h = A(j0+m) + A(j2+m)*E(m*inc)
            A(j2+m) = A(j0+m) - A(j2+m)*E(m*inc)
            A(j0+m) = h
            eh = conjg(E(ntot/4-m*inc))
            h = A(j1+m) - A(j3+m)*eh
            A(j3+m) = A(j1+m) + A(j3+m)*eh
            A(j1+m) = h
          end do
        end if
      end if
      if(inc==1) then
        exit loop                    ! return from root-invocation
      end if
      i = i+inc/2
    end do loop                      ! return from recursive invocation

    return
  end subroutine fourir

end module solv_cap

program capacitance
!
! Disk or square, at constant potential or placed in uniform Ex field.
!
! Version 1.5, Aug 1998, J. Bergervoet
!
  use solv_cap
  implicit none

  real(kind=dp)     :: GrSize1, GrSize2, C, P
  logical           :: DoCircle, UseFFT, UsePreco
  integer           :: Ng1, Ng2, i, j , ios
  character(len=20) :: Name
  integer, allocatable, dimension(:,:)  :: Grid

  write(unit=*,fmt=*) "Give: N_x, N_y, GridSize_X, GridSize_Y, DoCircle, UseFFT, UsePreco"
  write(unit=*,fmt=*)
  write(unit=*,fmt=*) "  N_x and N_y give the grid division in x and y-directions and"
  write(unit=*,fmt=*) "  should be powers of 2, DoCircle and UseFFT are T or F (true"
  write(unit=*,fmt=*) "  or false). If DoCircle=T, the case of an ellipse is computed"
  write(unit=*,fmt=*) "  (circle: C = 8*eps0*R, P = 16/3*eps0*R^3), else that of the"
  write(unit=*,fmt=*) "  completely filled grid. UseFFT is for increased speed."
  ng1 = 512 ; ng2 = 512 ; GrSize1 = 1.0 ; GrSize2 = 1.0
  DoCircle = .TRUE. ; UseFFT = .TRUE. ; UsePreco = .TRUE.
  open(11,file='capacita.in',status='old',iostat=ios)
  if ( ios.eq.0 ) read(unit=11,fmt=*) Ng1,Ng2, GrSize1, GrSize2, DoCircle, UseFFT, UsePreco

  allocate( Grid(Ng1,Ng2) )
  Grid = 1                   ! fill entire grid with metal
  Name = "rectangle"

  if (DoCircle) then         ! leave only metal in inscribed circle
    Name = "disk"
    do j=1,Ng2
      do i=1,Ng1
        if( ((2*i-Ng1-1.0_dp)/Ng1)**2 + ((2*j-Ng2-1.0_dp)/Ng2)**2 > 1 ) then
          Grid(i,j)=0
        end if
      end do
    end do
  end if

  call init_solve(Grid, GrSize1, GrSize2, UseFFT, UsePreco)

  call solveC(C)
  write(unit=*,fmt=*) "C_", trim(Name), "[pF] =", C * 1e12_dp

  call solveP(P)
  write(unit=*,fmt=*) "P_", trim(Name), "[pF.m^2] =", P * 1e12_dp

  deallocate( Grid )
  stop

end program capacitance


*DECK DLSI
      SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS,
     +   IP)
C***BEGIN PROLOGUE  DLSI
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DLSEI
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (LSI-S, DLSI-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     This is a companion subprogram to DLSEI.  The documentation for
C     DLSEI has complete usage instructions.
C
C     Solve..
C              AX = B,  A  MA by N  (least squares equations)
C     subject to..
C
C              GX.GE.H, G  MG by N  (inequality constraints)
C
C     Input..
C
C      W(*,*) contains  (A B) in rows 1,...,MA+MG, cols 1,...,N+1.
C                       (G H)
C
C     MDW,MA,MG,N
C              contain (resp) var. dimension of W(*,*),
C              and matrix dimensions.
C
C     PRGOPT(*),
C              Program option vector.
C
C     OUTPUT..
C
C      X(*),RNORM
C
C              Solution vector(unless MODE=2), length of AX-B.
C
C      MODE
C              =0   Inequality constraints are compatible.
C              =2   Inequality constraints contradictory.
C
C      WS(*),
C              Working storage of dimension K+N+(MG+2)*(N+7),
C              where K=MAX(MA+MG,N).
C      IP(MG+2*N+1)
C              Integer working storage
C
C***ROUTINES CALLED  D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI,
C                    DLPDP, DSCAL, DSWAP
C***REVISION HISTORY  (YYMMDD)
C   790701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890618  Completely restructured and extensively revised (WRB & RWC)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   900604  DP version created from SP version.  (RWC)
C   920422  Changed CALL to DHFTI to include variable MA.  (WRB)
C***END PROLOGUE  DLSI
      INTEGER IP(*), MA, MDW, MG, MODE, N
      DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*)
C
      EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP,
     *   DSCAL, DSWAP
      DOUBLE PRECISION D1MACH, DASUM, DDOT
C
      DOUBLE PRECISION ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM
      INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1,
     *   MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1
      LOGICAL COV, FIRST, SCLCOV
C
      SAVE DRELPR, FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  DLSI
C
C     Set the nominal tolerance used in the code.
C
      IF (FIRST) DRELPR = D1MACH(4)
      FIRST = .FALSE.
      TOL = SQRT(DRELPR)
C
      MODE = 0
      RNORM = 0.D0
      M = MA + MG
      NP1 = N + 1
      KRANK = 0
      IF (N.LE.0 .OR. M.LE.0) GO TO 370
C
C     To process option vector.
C
      COV = .FALSE.
      SCLCOV = .TRUE.
      LAST = 1
      LINK = PRGOPT(1)
C
  100 IF (LINK.GT.1) THEN
         KEY = PRGOPT(LAST+1)
         IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.D0
         IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.D0
         IF (KEY.EQ.5) TOL = MAX(DRELPR,PRGOPT(LAST+2))
         NEXT = PRGOPT(LINK)
         LAST = LINK
         LINK = NEXT
         GO TO 100
      ENDIF
C
C     Compute matrix norm of least squares equations.
C
      ANORM = 0.D0
      DO 110 J = 1,N
         ANORM = MAX(ANORM,DASUM(MA,W(1,J),1))
  110 CONTINUE
C
C     Set tolerance for DHFTI( ) rank test.
C
      TAU = TOL*ANORM
C
C     Compute Householder orthogonal decomposition of matrix.
C
      CALL DCOPY (N, 0.D0, 0, WS, 1)
      CALL DCOPY (MA, W(1, NP1), 1, WS, 1)
      K = MAX(M,N)
      MINMAN = MIN(MA,N)
      N1 = K + 1
      N2 = N1 + N
      CALL DHFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, RNORM, WS(N2),
     +           WS(N1), IP)
      FAC = 1.D0
      GAM = MA - KRANK
      IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM
C
C     Reduce to DLPDP and solve.
C
      MAP1 = MA + 1
C
C     Compute inequality rt-hand side for DLPDP.
C
      IF (MA.LT.M) THEN
         IF (MINMAN.GT.0) THEN
            DO 120 I = MAP1,M
               W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1)
  120       CONTINUE
C
C           Apply permutations to col. of inequality constraint matrix.
C
            DO 130 I = 1,MINMAN
               CALL DSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1)
  130       CONTINUE
C
C           Apply Householder transformations to constraint matrix.
C
            IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN
               DO 140 I = KRANK,1,-1
                  CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1),
     +                      W(MAP1,1), MDW, 1, MG)
  140          CONTINUE
            ENDIF
C
C           Compute permuted inequality constraint matrix times r-inv.
C
            DO 160 I = MAP1,M
               DO 150 J = 1,KRANK
                  W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J)
  150          CONTINUE
  160       CONTINUE
         ENDIF
C
C        Solve the reduced problem with DLPDP algorithm,
C        the least projected distance problem.
C
         CALL DLPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X,
     +             XNORM, MDLPDP, WS(N2), IP(N+1))
C
C        Compute solution in original coordinates.
C
         IF (MDLPDP.EQ.1) THEN
            DO 170 I = KRANK,1,-1
               X(I) = (X(I)-DDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I)
  170       CONTINUE
C
C           Apply Householder transformation to solution vector.
C
            IF (KRANK.LT.N) THEN
               DO 180 I = 1,KRANK
                  CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1),
     +                      X, 1, 1, 1)
  180          CONTINUE
            ENDIF
C
C           Repermute variables to their input order.
C
            IF (MINMAN.GT.0) THEN
               DO 190 I = MINMAN,1,-1
                  CALL DSWAP (1, X(I), 1, X(IP(I)), 1)
  190          CONTINUE
C
C              Variables are now in original coordinates.
C              Add solution of unconstrained problem.
C
               DO 200 I = 1,N
                  X(I) = X(I) + WS(I)
  200          CONTINUE
C
C              Compute the residual vector norm.
C
               RNORM = SQRT(RNORM**2+XNORM**2)
            ENDIF
         ELSE
            MODE = 2
         ENDIF
      ELSE
         CALL DCOPY (N, WS, 1, X, 1)
      ENDIF
C
C     Compute covariance matrix based on the orthogonal decomposition
C     from DHFTI( ).
C
      IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370
      KRM1 = KRANK - 1
      KRP1 = KRANK + 1
C
C     Copy diagonal terms to working array.
C
      CALL DCOPY (KRANK, W, MDW+1, WS(N2), 1)
C
C     Reciprocate diagonal terms.
C
      DO 210 J = 1,KRANK
         W(J,J) = 1.D0/W(J,J)
  210 CONTINUE
C
C     Invert the upper triangular QR factor on itself.
C
      IF (KRANK.GT.1) THEN
         DO 230 I = 1,KRM1
            DO 220 J = I+1,KRANK
               W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J)
  220       CONTINUE
  230    CONTINUE
      ENDIF
C
C     Compute the inverted factor times its transpose.
C
      DO 250 I = 1,KRANK
         DO 240 J = I,KRANK
            W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW)
  240    CONTINUE
  250 CONTINUE
C
C     Zero out lower trapezoidal part.
C     Copy upper triangular to lower triangular part.
C
      IF (KRANK.LT.N) THEN
         DO 260 J = 1,KRANK
            CALL DCOPY (J, W(1,J), 1, W(J,1), MDW)
  260    CONTINUE
C
         DO 270 I = KRP1,N
            CALL DCOPY (I, 0.D0, 0, W(I,1), MDW)
  270    CONTINUE
C
C        Apply right side transformations to lower triangle.
C
         N3 = N2 + KRP1
         DO 330 I = 1,KRANK
            L = N1 + I
            K = N2 + I
            RB = WS(L-1)*WS(K-1)
C
C           If RB.GE.0.D0, transformation can be regarded as zero.
C
            IF (RB.LT.0.D0) THEN
               RB = 1.D0/RB
C
C              Store unscaled rank one Householder update in work array.
C
               CALL DCOPY (N, 0.D0, 0, WS(N3), 1)
               L = N1 + I
               K = N3 + I
               WS(K-1) = WS(L-1)
C
               DO 280 J = KRP1,N
                  WS(N3+J-1) = W(I,J)
  280          CONTINUE
C
               DO 290 J = 1,N
                  WS(J) = RB*(DDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+
     +                    DDOT(N-J+1,W(J,J),1,WS(N3+J-1),1))
  290          CONTINUE
C
               L = N3 + I
               GAM = 0.5D0*RB*DDOT(N-I+1,WS(L-1),1,WS(I),1)
               CALL DAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1)
               DO 320 J = I,N
                  DO 300 L = 1,I-1
                     W(J,L) = W(J,L) + WS(N3+J-1)*WS(L)
  300             CONTINUE
C
                  DO 310 L = I,J
                     W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1)
  310             CONTINUE
  320          CONTINUE
            ENDIF
  330    CONTINUE
C
C        Copy lower triangle to upper triangle to symmetrize the
C        covariance matrix.
C
         DO 340 I = 1,N
            CALL DCOPY (I, W(I,1), MDW, W(1,I), 1)
  340    CONTINUE
      ENDIF
C
C     Repermute rows and columns.
C
      DO 350 I = MINMAN,1,-1
         K = IP(I)
         IF (I.NE.K) THEN
            CALL DSWAP (1, W(I,I), 1, W(K,K), 1)
            CALL DSWAP (I-1, W(1,I), 1, W(1,K), 1)
            CALL DSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1)
            CALL DSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW)
         ENDIF
  350 CONTINUE
C
C     Put in normalized residual sum of squares scale factor
C     and symmetrize the resulting covariance matrix.
C
      DO 360 J = 1,N
         CALL DSCAL (J, FAC, W(1,J), 1)
         CALL DCOPY (J, W(1,J), 1, W(J,1), MDW)
  360 CONTINUE
C
  370 IP(1) = KRANK
      IP(2) = N + MAX(M,N) + (MG+2)*(N+7)
      RETURN
      END