! This test program have to be run by mpiexec.exe.
program test_mpifft
    use mpifft
    use mpi
    implicit none

    integer :: nx, ny, nz
    integer :: npx, npy, npz

    integer(kind(MPI_COMM_WORLD)) :: comm
    integer :: myrank
    integer :: psize
    integer :: ierr

    type(t_MPIFFTW3_Factory) :: fft_factory
    type(t_Block) :: local_block
    type(t_Block) :: global_block
    type(t_MPI_FFTExecutor3d), pointer :: fft, fft2

    double precision, allocatable :: original(:, :, :)
    double precision, allocatable :: forwarded(:, :, :)
    double precision, allocatable :: backwarded(:, :, :)

    integer :: ix, iy, iz
    double precision :: diff

    double precision :: stime
    double precision :: etime

    comm = MPI_COMM_WORLD

    call MPI_Init(ierr)
    call MPI_Comm_rank(comm, myrank, ierr)
    call MPI_Comm_size(comm, psize, ierr)

    nx = 128
    ny = 64
    nz = 32

    npx = 2
    npy = 2
    npz = 1

    global_block = new_block([1, 1, 1], [nx, ny, nz])
    ! local_block settings.
    if (npx*npy*npz < myrank + 1) then
        local_block = new_Block(global_block%start(:) - 1, global_block%start(:) - 2)
    else
        block
            integer :: ip
            integer :: ipx, ipy, ipz
            integer :: start(3), end(3)

            ip = myrank

            ! Divide a sequence of numbers from 0 to nx-1 (= 0, 1, 2, ..., nx-1) into npx pieces (similarly for y and z).
            ipx = mod(ip, npx)
            ipy = mod(int(ip/npx), npy)
            ipz = int(ip/(npx*npy))

            start(:) = [int(nx/npx)*ipx, int(ny/npy)*ipy, int(nz/npz)*ipz]
            end(:) = [nx/npx*(ipx + 1) - 1, &
                      ny/npy*(ipy + 1) - 1, &
                      nz/npz*(ipz + 1) - 1]

            if (ipx == npx - 1) then
                end(1) = nx - 1
            end if
            if (ipy == npy - 1) then
                end(2) = ny - 1
            end if
            if (ipz == npz - 1) then
                end(3) = nz - 1
            end if

            ! Shift by global_block offset.
            local_block = new_Block(start(:) + global_block%start(:), end(:) + global_block%start(:))
        end block
    end if

    allocate (original(local_block%start(1):local_block%end(1), &
                       local_block%start(2):local_block%end(2), &
                       local_block%start(3):local_block%end(3)))
    allocate (forwarded(local_block%start(1):local_block%end(1), &
                        local_block%start(2):local_block%end(2), &
                        local_block%start(3):local_block%end(3)))
    allocate (backwarded(local_block%start(1):local_block%end(1), &
                         local_block%start(2):local_block%end(2), &
                         local_block%start(3):local_block%end(3)))

    forwarded(:, :, :) = 0.0d0
    backwarded(:, :, :) = 0.0d0

    do concurrent(ix=local_block%start(1):local_block%end(1), &
                  iy=local_block%start(2):local_block%end(2), &
                  iz=local_block%start(3):local_block%end(3))
        original(ix, iy, iz) = sin((2d0*3.14d0*ix)/nx)*sin((1.2d0*2d0*3.14d0*iy)/ny)*sin((-0.6d0*2d0*3.14d0*iz)/nz)
    end do

    fft_factory = new_MPIFFTW3_Factory(local_block, global_block, myrank, psize, comm)
    fft = fft_factory%create([BoundaryType_Periodic, BoundaryType_Dirichlet, BoundaryType_Neumann])

    call fft%forward(original(:, :, :), forwarded(:, :, :))
    call fft%backward(forwarded(:, :, :), backwarded(:, :, :))

    diff = sum(abs(backwarded(:, :, :) - original(:, :, :)))/sum(abs(original))
    print *, "Diff =", diff, sum(abs(backwarded(:, :, :) - original(:, :, :))), sum(abs(original)), myrank

    call MPI_Finalize(ierr)

end program


!-----------------------------------------------------------------------------
!
! SMEAN
!
! The subroutine SMEAN calculates the mean catchment slope based on
! maximum (theoretical) values obtained from facet analysis.
!
!-----------------------------------------------------------------------------

subroutine smean()

use mpar
use mbbio

implicit none

integer(kind=ISP) i,j,i_basin,jr,l
integer(kind=ISP) ii,jj,ii_basin
integer(kind=ISP) i_basin_chiusura
integer(kind=ISP) n_o_quota
real(kind=REP) quota_ciijj,quota_max
real(kind=REP) e(9)
real(kind=REP) e0,e1,e2,e1_fmax,e2_fmax,emin,s_max,r_max,s_max_facet,r
real(kind=REP) n_s_max,min_s_max,max_s_max,sum_s_max

! open the binary file qoi

open(16,file='qoi',access='direct',status='unknown',form='unformatted',recl=4)

! identify the outlet cell (the lowest catchment cell)

read(16,rec=N_celle+1) i_basin_chiusura

! write(6,*) 'i_basin_chiusura = ',i_basin_chiusura

n_s_max=+0.0D+00
min_s_max=+1.0D+10
max_s_max=-1.0D+10
sum_s_max=0.0D+00

do n_o_quota=1,N_celle

   read(16,rec=n_o_quota+1) i_basin
   ! if drainage direction are set up, there are not altered
   if (dtm_p_outflow_1(i_basin).ne.0.or.dtm_p_outflow_2(i_basin).ne.0) cycle
   if (i_basin.eq.i_basin_chiusura) cycle ! features are assigned apart
   jr=mod(i_basin,M)
   if (jr.ne.0) then
      j=jr
      i=(i_basin-j)/M+1
   else
      j=M
      i=i_basin/M
   end if

   l=0
   do ii=i-1,i+1
      do jj=j-1,j+1
         l=l+1
         e(l)=0.0_REP
         if (ii.eq.0.or.ii.eq.N+1) cycle
         if (jj.eq.0.or.jj.eq.M+1) cycle
         ii_basin=(ii-1)*M+jj
         quota_ciijj=dtm_quota(ii_basin)
         if (quota_ciijj < 0.0_REP) cycle
         e(l)=quota_ciijj
      end do
   end do

   e0=e(5)
   s_max=0.0_REP
!
! triangle 021
!
   e1=e(2)
   e2=e(1)
   if (e1*e2.ne.0.0_REP) then
      call facet(e0,e1,e2,r,s_max_facet)
      if (s_max_facet.gt.s_max) s_max=s_max_facet
   end if
!
! triangle 023
!
   e1=e(2)
   e2=e(3)
   if (e1*e2.ne.0.0_REP) then
      call facet(e0,e1,e2,r,s_max_facet)
      if (s_max_facet.gt.s_max) s_max=s_max_facet
   end if
!
! triangle 063
!
   e1=e(6)
   e2=e(3)
   if (e1*e2.ne.0.0_REP) then
      call facet(e0,e1,e2,r,s_max_facet)
      if (s_max_facet.gt.s_max) s_max=s_max_facet
   end if
!
! triangle 069
!
   e1=e(6)
   e2=e(9)
   if (e1*e2.ne.0.0_REP) then
      call facet(e0,e1,e2,r,s_max_facet)
      if (s_max_facet.gt.s_max) s_max=s_max_facet
   end if
!
! triangle 089
!
   e1=e(8)
   e2=e(9)
   if (e1*e2.ne.0.0_REP) then
      call facet(e0,e1,e2,r,s_max_facet)
      if (s_max_facet.gt.s_max) s_max=s_max_facet
   end if
!
! triangle 087
!
   e1=e(8)
   e2=e(7)
   if (e1*e2.ne.0.0_REP) then
      call facet(e0,e1,e2,r,s_max_facet)
      if (s_max_facet.gt.s_max) s_max=s_max_facet
   end if
!
! triangle 047
!
   e1=e(4)
   e2=e(7)
   if (e1*e2.ne.0.0_REP) then
      call facet(e0,e1,e2,r,s_max_facet)
      if (s_max_facet.gt.s_max) s_max=s_max_facet
   end if
!
! triangle 041
!
   e1=e(4)
   e2=e(1)
   if (e1*e2.ne.0.0_REP) then
      call facet(e0,e1,e2,r,s_max_facet)
      if (s_max_facet.gt.s_max) s_max=s_max_facet
   end if

   if (s_max.ge.0.0_REP) then
      n_s_max=n_s_max+1.0
      if (s_max.lt.min_s_max) min_s_max=s_max
      if (s_max.gt.max_s_max) max_s_max=s_max
      sum_s_max=sum_s_max+s_max
   else if (s_max.eq.0.0_REP) then
      write(6,*) 's_max = 0 at i_basin =',i_basin
      n_s_max=n_s_max+1.0
      if (s_max.lt.min_s_max) min_s_max=s_max
      if (s_max.gt.max_s_max) max_s_max=s_max
      sum_s_max=sum_s_max+s_max
   else ! if (s_max.lt.0.0_REP) then
      write(6,*) 's_max < 0 at i_basin =',i_basin
      stop
   end if

end do

mean_s_max=sum_s_max/n_s_max

write(6,'(1x,a,f12.9,a,f12.9,a,f12.9,a)') &
'mean (min,max) facet slope = ',mean_s_max,' (',min_s_max,',',max_s_max,')'

close(16)

return
end subroutine smean


!
! ---------------------------------------------------------------------
!
!  Fortran version of the user function based on shared memory
!  this routine is called only by MPI process 0 in the computation
!  but uses threads to run the loops in parallel.

!
!  Input Parameter:
!  x - global array containing input values
!
!  Output Parameters:
!  f - global array containing output values
!  ierr - error code
!
!  Notes:
!  This routine uses standard Fortran-style computations over a 2-dim array.
!
#include <petsc/finclude/petsc.h>
subroutine ApplicationFunctionFortran(lambda,mx,my,x,f,ierr)
    use petscsnes
    implicit none

    integer  ierr,mx,my

    !  Input/output variables:
    PetscScalar   x(mx,my),f(mx,my),lambda

    !  Local variables:
    PetscScalar   two,one,hx,hy,hxdhy,hydhx,sc
    PetscScalar   u,uxx,uyy
    integer  i,j

    hx     = 1.0 / PetscIntToReal(mx-1)
    hy     = 1.0 / PetscIntToReal(my-1)
    sc     = hx * hy * lambda
    hxdhy  = hx / hy
    hydhx  = hy / hx

    !  Compute function over the entire grid

!    do j = 1, my
!        do i = 1, mx
!            if (i .eq. 1 .or. j .eq. 1 .or. i .eq. mx .or. j .eq. my) then
!                f(i,j) = x(i,j)
!            else
!                u = x(i,j)
!                uxx = hydhx * (2.0 * u - x(i-1,j) - x(i+1,j))
!                uyy = hxdhy * (2.0 * u - x(i,j-1) - x(i,j+1))
!                f(i,j) = uxx + uyy - sc * exp(u)
!            endif
!        end do
!    end do

!    do j = 1, my
!        do i = 1, mx
!            if (i .eq. 1 .or. j .eq. 1 .or. i .eq. mx .or. j .eq. my) then
!                f(i,j) = x(i,j)
!            endif
!        end do
!    end do
    f(1, :) = x(1, :)
    f(mx,:) = x(mx,:)
    f(:, 1) = x(:, 1)
    f(:,my) = x(:,my)
    f(2:mx-1,2:my-1) = hydhx * (2.0 * x(2:mx-1,2:my-1) - x(1:mx-2,2:my-1) - x(3:mx,2:my-1)) &
                     + hxdhy * (2.0 * x(2:mx-1,2:my-1) - x(2:mx-1,1:my-2) - x(2:mx-1,3:my)) &
                     - sc * exp(x(2:mx-1,2:my-1))

    return
end

subroutine InitialGuessFortran(mx, my, lambda, x)
    use petscsnes
    implicit none

    integer  mx, my

    !  Input/output variables:
    real*8   x(mx,my), lambda

    !  Local variables:
    real*8   temp, temp1, hx, hy
    integer  i,j

    hx     = 1.0 / dble(mx - 1)
    hy     = 1.0 / dble(my - 1)

    temp1 = lambda / (lambda + 1.0)

    do j = 1, my
        temp = dble(min(j - 1, my - j) * hy)
        do i = 1, mx
            if (i .eq. 1 .or. j .eq. 1 .or. i .eq. mx .or. j .eq. my) then
                x(i,j) = 0.0
            else
                x(i,j) = temp1 * sqrt(min(min(i - 1, mx - i) * hx, temp))
            endif
        end do
    end do

    return
end


c     program DRSWCOMP
c>> 1994-10-19 DRSWCOMP Krogh  Changes to use M77CON
c>> 1987-12-09 DRSWCOMP Lawson  Initial Code.
c--S replaces "?": DR?WCOMP, ?WSET, ?VECP, ?WSQRT, ?WLOG, ?WPRO1, ?WEXP,
c--&               ?WDIF, ?WCOMP
c     Demo driver for the SWCOMP package.  Derivative arithmetic.
c     ------------------------------------------------------------------
      integer N, NDIM, NMAX
      parameter(NMAX = 3, NDIM = NMAX+1)
      real             T(NDIM), X1(NDIM), Z1(NDIM), X2(NDIM), Z2(NDIM)
      real             DIFF(NDIM), ONE, TWO
      parameter(ONE = 1.0E0, TWO = 2.0E0)
c     ------------------------------------------------------------------
      print*,'DRSWCOMP..  Demo driver for the SWCOMP package.'
      N = NMAX
c                                      Set T = 2.0
      call SWSET(N, TWO, ONE, T)
      call SVECP(T,N+1,'0 T =')
c                                      Compute Z1 = log(sqrt(T))
      call SWSQRT(N, T, X1)
      call SWLOG(N, X1, Z1)
      call SVECP(Z1,N+1,'0 Z1 = log(sqrt(T)) =')
c
c                                      Compute Z2 = exp(2.0 * Z1)
      call SWPRO1(N, TWO, Z1, X2)
      call SWEXP(N, X2, Z2)
      call SVECP(Z2,N+1,'0 Z2 = exp(2.0 * Z1) =')
c
c                                      Diff = Z2 - T
      call SWDIF(N, Z2, T, DIFF)
      call SVECP(DIFF,N+1,'0 DIFF = Z2 - T =')
      stop
      end


      SUBROUTINE cumfnc(f,dfn,dfd,pnonc,cum,ccum,status)
C**********************************************************************
C
C               F -NON- -C-ENTRAL F DISTRIBUTION
C
C
C
C                              Function
C
C
C     COMPUTES NONCENTRAL F DISTRIBUTION WITH DFN AND DFD
C     DEGREES OF FREEDOM AND NONCENTRALITY PARAMETER PNONC
C
C
C                              Arguments
C
C
C     X --> UPPER LIMIT OF INTEGRATION OF NONCENTRAL F IN EQUATION
C
C     DFN --> DEGREES OF FREEDOM OF NUMERATOR
C
C     DFD -->  DEGREES OF FREEDOM OF DENOMINATOR
C
C     PNONC --> NONCENTRALITY PARAMETER.
C
C     CUM <-- CUMULATIVE NONCENTRAL F DISTRIBUTION
C
C     CCUM <-- COMPLIMENT OF CUMMULATIVE
C
C
C                              Method
C
C
C     USES FORMULA 26.6.20 OF REFERENCE FOR INFINITE SERIES.
C     SERIES IS CALCULATED BACKWARD AND FORWARD FROM J = LAMBDA/2
C     (THIS IS THE TERM WITH THE LARGEST POISSON WEIGHT) UNTIL
C     THE CONVERGENCE CRITERION IS MET.
C
C     FOR SPEED, THE INCOMPLETE BETA FUNCTIONS ARE EVALUATED
C     BY FORMULA 26.5.16.
C
C
C               REFERENCE
C
C
C     HANDBOOD OF MATHEMATICAL FUNCTIONS
C     EDITED BY MILTON ABRAMOWITZ AND IRENE A. STEGUN
C     NATIONAL BUREAU OF STANDARDS APPLIED MATEMATICS SERIES - 55
C     MARCH 1965
C     P 947, EQUATIONS 26.6.17, 26.6.18
C
C
C                              Note
C
C
C     THE SUM CONTINUES UNTIL A SUCCEEDING TERM IS LESS THAN EPS
C     TIMES THE SUM (OR THE SUM IS LESS THAN 1.0E-20).  EPS IS
C     SET TO 1.0E-4 IN A DATA STATEMENT WHICH CAN BE CHANGED.
C
C**********************************************************************

C     .. Scalar Arguments ..
      DOUBLE PRECISION dfd,dfn,pnonc,f,cum,ccum
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION dsum,dummy,prod,xx,yy
      DOUBLE PRECISION adn,aup,b,betdn,betup,centwt,dnterm,eps,sum,
     +                 upterm,xmult,xnonc,x,abstol
      INTEGER i,icent,ierr,status
C     ..
C     .. External Functions ..
      DOUBLE PRECISION alngam
      EXTERNAL alngam
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC log,dble,exp
C     ..
C     .. Statement Functions ..
      LOGICAL qsmall
C     ..
C     .. External Subroutines ..
      EXTERNAL bratio,cumf
C     ..
C     .. Parameters ..
      DOUBLE PRECISION half
      PARAMETER (half=0.5D0)
      DOUBLE PRECISION done
      PARAMETER (done=1.0D0)
C     ..
C     .. Data statements ..
      DATA eps/1.0D-4/
      DATA abstol/1.0D-300/
C     ..
C     .. Statement Function definitions ..
      qsmall(x) = .NOT. (sum .GE. abstol .AND. x .GE. eps*sum)
C     ..
C     .. Executable Statements ..
C
      status = 0
      IF (.NOT. (f.LE.0.0D0)) GO TO 10
      cum = 0.0D0
      ccum = 1.0D0
      RETURN

   10 IF (.NOT. (pnonc.LT.1.0D-10)) GO TO 20
C
C     Handle case in which the non-centrality parameter is
C     (essentially) zero.

      CALL cumf(f,dfn,dfd,cum,ccum)
      RETURN

   20 xnonc = pnonc/2.0D0

C     Calculate the central term of the poisson weighting factor.

      icent = xnonc
      IF (.NOT.(DABS(xnonc-icent).LT.1)) THEN
         status = 1
         RETURN
      ENDIF
      IF (icent.EQ.0) icent = 1

C     Compute central weight term

      centwt = exp(-xnonc+icent*log(xnonc)-alngam(dble(icent+1)))

C     Compute central incomplete beta term
C     Assure that minimum of arg to beta and 1 - arg is computed
C          accurately.

      prod = dfn*f
      dsum = dfd + prod
      yy = dfd/dsum
      IF (yy.GT.half) THEN
          xx = prod/dsum
          yy = done - xx

      ELSE
          xx = done - yy
      END IF

      CALL bratio(dfn*half+dble(icent),dfd*half,xx,yy,betdn,dummy,ierr)
      adn = dfn/2.0D0 + dble(icent)
      aup = adn
      b = dfd/2.0D0
      betup = betdn
      sum = centwt*betdn

C     Now sum terms backward from icent until convergence or all done

      xmult = centwt
      i = icent
      dnterm = exp(alngam(adn+b)-alngam(adn+1.0D0)-alngam(b)+
     +         adn*log(xx)+b*log(yy))
   30 IF (qsmall(xmult*betdn) .OR. i.LE.0) GO TO 40
      xmult = xmult* (i/xnonc)
      i = i - 1
      adn = adn - 1
      dnterm = (adn+1)/ ((adn+b)*xx)*dnterm
      betdn = betdn + dnterm
      sum = sum + xmult*betdn
      GO TO 30

   40 i = icent + 1

C     Now sum forwards until convergence

      xmult = centwt
      IF ((aup-1+b).EQ.0) THEN
          upterm = exp(-alngam(aup)-alngam(b)+ (aup-1)*log(xx)+
     +             b*log(yy))

      ELSE
          upterm = exp(alngam(aup-1+b)-alngam(aup)-alngam(b)+
     +             (aup-1)*log(xx)+b*log(yy))
      END IF

      GO TO 60

   50 IF (qsmall(xmult*betup)) GO TO 70
   60 xmult = xmult* (xnonc/i)
      i = i + 1
      aup = aup + 1
      upterm = (aup+b-2.0D0)*xx/ (aup-1)*upterm
      betup = betup - upterm
      sum = sum + xmult*betup
      GO TO 50

   70 cum = sum

      ccum = 0.5D0 + (0.5D0-cum)
      RETURN

      END


      double complex function Fcc_qpqmgpgp(j1,j2,j3,j4,j5,j6,za,zb)
      implicit none
      integer j1,j2,j3,j4,j5,j6
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      double complex L0,Lsm1,Lsm1_2me
      double precision t

      Fcc_qpqmgpgp=
     .((Lsm1(-s(j1,j4),-t(j1,j2,j4),-s(j1,j2),-t(j1,j2,j4))+
     .Lsm1_2me(t(j1,j3,j4),t(j1,j2,j4),s(j1,j4),s(j5,j6)))*za(j2,j5)**2)
     ./
     .(za(j1,j4)*za(j2,j3)*za(j3,j4)*za(j5,j6))-
     .(Lsm1(-s(j1,j2),-t(j1,j2,j3),-s(j2,j3),-t(j1,j2,j3))*za(j2,j5)*
     .(za(j1,j5)*za(j2,j3)-za(j1,j2)*za(j3,j5)))/
     .(za(j1,j3)*za(j1,j4)*za(j2,j3)*za(j3,j4)*za(j5,j6))+
     .(Lsm1_2me(t(j1,j2,j3),t(j2,j3,j4),s(j2,j3),s(j5,j6))*za(j2,j5)*
     .(-(za(j1,j5)*za(j2,j4))+za(j1,j2)*za(j4,j5)))/
     .(za(j1,j4)**2*za(j2,j3)*za(j3,j4)*za(j5,j6))+
     .(Lsm1_2me(t(j1,j2,j4),t(j1,j2,j3),s(j1,j2),s(j5,j6))*za(j2,j5)*
     .(za(j2,j4)*za(j3,j5)+za(j2,j3)*za(j4,j5)))/
     .(za(j1,j4)*za(j2,j3)*za(j3,j4)**2*za(j5,j6))-
     .(2d0*L0(-t(j2,j3,j4),-s(j5,j6))*za(j1,j5)*za(j2,j5)*
     .(-(za(j2,j3)*zb(j1,j3))-za(j2,j4)*zb(j1,j4)))/
     .(s(j5,j6)*za(j1,j4)*za(j2,j3)*za(j3,j4)*za(j5,j6))-
     .(2d0*L0(-t(j2,j3,j4),-s(j2,j3))*za(j2,j5)*za(j4,j5)*zb(j3,j4))/
     .(s(j2,j3)*za(j1,j4)*za(j3,j4)*za(j5,j6))

      return
      end


res = DOT_PRODUCT(MATMUL(sensitivities,matcovar),sensitivities)


! =============================================================================
!                       Straka ("Cold bubble") test case
!
!   This module sets up a cold bubble as described in Straka et al (1993).
!
!   Straka, J.M., Wilhelmson, R.B., Wicker, L.J., Anderson, J.R. and
!   Droegemeier, K.K. (1993), Numerical solutions of a non-linear density
!   current: A benchmark solution and comparisons. Int. J. Numer. Meth. Fluids,
!   17: 1-22. https://doi.org/10.1002/fld.1650170103
!
! =============================================================================

module straka_2d
    use constants
    use netcdf_writer
    use physics, only : write_physical_quantities, &
                        theta_0, gravity
    implicit none

    private

    type flow_type
        double precision :: dtheta_max = 15.0d0               ![K] max. pot. temp. perturbation
        double precision :: center(2) = (/zero, 3000.0d0/)    ![m] sphere center (x, z)
        double precision :: radii(2)  = (/4000.0d0, 2000.d0/) ![m] ellipse radii (x, z)
    end type flow_type

    integer :: buo_id

    type(flow_type) :: straka_flow

    public :: straka_init, straka_flow

    contains

        subroutine straka_init(ncid, dimids, nx, nz, origin, dx)
            integer,          intent(inout) :: ncid
            integer,          intent(in)    :: dimids(:)
            integer,          intent(in)    :: nx, nz
            double precision, intent(in)    :: origin(2)
            double precision, intent(in)    :: dx(2)
            double precision                :: pos(2)
            double precision                :: xc, xr, zc, zr, L
            double precision                :: dtheta, dtheta_max
            double precision                :: buoyg(0:nz, 0:nx-1)
            integer                         :: i, j

            call define_netcdf_dataset(ncid=ncid,                           &
                                       name='buoyancy',                     &
                                       long_name='buoyancy',                &
                                       std_name='',                         &
                                       unit='m/s^2',                        &
                                       dtype=NF90_DOUBLE,                   &
                                       dimids=dimids,                       &
                                       varid=buo_id)

            call close_definition(ncid)

            ! in metres
            xc = straka_flow%center(1)
            xr = straka_flow%radii(1)
            zc = straka_flow%center(2)
            zr = straka_flow%radii(2)

            dtheta_max = -f12 * straka_flow%dtheta_max

            do j = 0, nz
                do i = 0, nx - 1
                    pos = origin + dx * dble((/i, j/))

                    L = ((pos(1) - xc) / xr) ** 2 &
                      + ((pos(2) - zc) / zr) ** 2

                    L = dsqrt(L)

                    ! potential temperature perturbation
                    dtheta = zero

                    if (L <= one) then
                        dtheta = dtheta_max * (dcos(pi * L) + one)
                    endif

                    ! MPIC paper:
                    ! liquid-water buoyancy is defined by b = g * (theta − theta_0) / theta_0
                    ! (dtheta = theta - theta_0)
                    buoyg(j, i) = gravity * dtheta / theta_0
                enddo
            enddo

            call write_netcdf_dataset(ncid, buo_id, buoyg)

            call write_physical_quantities(ncid)

        end subroutine straka_init
end module


!====================================================================
!
! MODULE: PlanckFunc
!
!   SUBROUTINE: Calc_PlanckTempToRad()
!   SUBROUTINE: Calc_PlanckRadToTemp()
!
!
! Created by Y.Tahara in Aug,02
! Modified by Y.Tahara in Oct,02 to make consistent with OPTRAN
!
!====================================================================

module PlanckFunc

  !--- modules

  use type_kinds, only : fp_kind
  use ParametersGenCoef

  !--- implicit

  implicit none

  !--- public & private

  Private

  Public  Calc_PlanckTempToRad
  Public  Calc_PlanckRadToTemp

 contains

  !====================================================================
  !
  ! SUBROUTINE: Calc_PlanckTempToRad()
  !
  !   Calc_PlanckTempToRad() calculates an radiance of a specified
  !   channel from black body using the Planck Law.
  !
  !====================================================================

  function Calc_PlanckTempToRad( channel, temperature ) result( radiance )

    !--- interface

    integer      ,intent(in) :: channel         ! ch seq #
    real(fp_kind),intent(in) :: temperature     ! temperature (K)
    real(fp_kind)            :: radiance        ! radiance

    !--- local variables

    real(fp_kind) :: effective_temperature

    !--- apply the polychromaticity correction
    !--- to obtain an effective temperature

    effective_temperature = SpcCoeff%band_c1( channel ) &
                                + ( SpcCoeff%band_c2( channel ) * temperature )

    !--- calculate the Planck radiance

    radiance =                  SpcCoeff%planck_c1( channel )  / &
    !          ----------------------------------------------------------------------
               ( EXP( SpcCoeff%planck_c2( channel ) / effective_temperature ) - ONE )

  end function Calc_PlanckTempToRad

  !====================================================================
  !
  ! SUBROUTINE: Calc_PlanckRadToTemp()
  !
  !   Calc_PlanckRadToTemp() calculates a black body surface
  !   temperature from its emissivity of a specified channel
  !   using the Planck Law.
  !
  !====================================================================

  function Calc_PlanckRadToTemp( channel, radiance ) result( temperature )

    !--- interface

    integer      ,intent(in) :: channel         ! ch seq #
    real(fp_kind),intent(in) :: radiance        ! radiance
    real(fp_kind)            :: temperature     ! temperature (K)

    !--- local variables

    real(fp_kind) :: effective_temperature

    !--- calculate the effective temperature

    effective_temperature =              SpcCoeff%planck_c2( channel )  / &
    !                       ---------------------------------------------------------
                            LOG( ( SpcCoeff%planck_c1( channel ) / radiance ) + ONE )

    !--- apply the polychromatic correction to
    !--- obtain the true temperature

    temperature = ( effective_temperature - SpcCoeff%band_c1( channel ) ) / &
    !             ---------------------------------------------------------
                                SpcCoeff%band_c2( channel )

  end function Calc_PlanckRadToTemp

end module PlanckFunc


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

! Fortran implementation of ACORN random number generator of order less
! than or equal to 12 (higher orders can be obtained by increasing the
! parameter value MAXORD).

! NOTES: 1. The variable idum is a dummy variable. The common block
!           IACO is used to transfer data into the function.

!        2. Before the first call to ACORN the common block IACO must
!           be initialised by the user, as follows. The values of
!           variables in the common block must not subsequently be
!           changed by the user.

!             KORDEI - order of generator required ( must be =< MAXORD)

!             MAXINT - modulus for generator, must be chosen small
!                      enough that 2*MAXINT does not overflow

!             ixv(1) - seed for random number generator
!                      require 0 < ixv(1) < MAXINT

!             (ixv(I+1),I=1,KORDEI)
!                    - KORDEI initial values for generator
!                      require 0 =< ixv(I+1) < MAXINT

!        3. After initialisation, each call to ACORN generates a single
!           random number between 0 and 1.

!        4. An example of suitable values for parameters is

!             KORDEI   = 10
!             MAXINT   = 2**30
!             ixv(1)   = an odd integer in the (approximate) range
!                        (0.001 * MAXINT) to (0.999 * MAXINT)
!             ixv(I+1) = 0, I=1,KORDEI

! Author: R.S.Wikramaratna,                           Date: October 1990
!-----------------------------------------------------------------------
double precision function acorni(idum)
    implicit double precision (a-h,o-z)
    parameter (KORDEI=12,MAXOP1=KORDEI+1,MAXINT=2**30)
    common/iaco/ ixv(MAXOP1)
    do i=1,KORDEI
        ixv(i+1)=(ixv(i+1)+ixv(i))
        if(ixv(i+1) >= MAXINT) ixv(i+1)=ixv(i+1)-MAXINT
    end do
    acorni=dble(ixv(KORDEI+1))/MAXINT
    return
end function


 module KS
   implicit none
   save
   integer,          parameter :: Nx = 512
   double precision, parameter :: dt = 1d0/16d0
   double precision, parameter :: T  = 200d0
   double precision, parameter :: pi = 3.14159265358979323846d0
   double precision, parameter :: Lx = (pi/16d0)*Nx
 end module KS

 subroutine ksintegrate(Nt, u)
   use KS
   implicit none
   integer,          intent(in)    :: Nt
   double complex,   intent(inout) :: u(0:Nx-1)
   double precision :: dt2, dt32, Nx_inv
   double precision :: A(0:Nx-1), B(0:Nx-1), L(0:Nx-1), kx(0:Nx-1)
   double complex   :: alpha(0:Nx-1), G(0:Nx-1), Nn(0:Nx-1), Nn1(0:Nx-1)
   double complex, save :: u_(0:Nx-1), uu(0:Nx-1)
   double complex, save :: us(0:Nx-1), uus(0:Nx-1)
   logical, save :: planned=.false.
   integer*8, save :: plan_u2us, plan_us2u, plan_uu2uus
   integer :: n, fftw_patient=32, fftw_estimate=64, fftw_forward=-1, fftw_backward=1

   if(.not.planned) then
      call dfftw_plan_dft_1d(plan_u2us, Nx, u_, us, fftw_forward, fftw_estimate)
      call dfftw_plan_dft_1d(plan_us2u, Nx, us, u_, fftw_backward, fftw_estimate)
      call dfftw_plan_dft_1d(plan_uu2uus, Nx, uu, uus, fftw_forward, fftw_estimate)
      planned = .true.
   end if

   do n = 0, Nx/2-1
      kx(n) = n
   end do
   kx(Nx/2) = 0d0
   do n = Nx/2+1, Nx-1
      kx(n) = -Nx + n;
   end do
   alpha = (2d0*pi/Lx)*kx
   L = alpha**2 - alpha**4
   G = -0.5d0*dcmplx(0d0,1d0)*alpha

   Nx_inv = 1d0/Nx
   dt2  = dt/2d0
   dt32 = 3d0*dt/2d0
   A = 1d0 + dt2*L
   B = 1d0/(1d0 - dt2*L)

   uu = u*u
   call dfftw_execute(plan_uu2uus)
   Nn  = G*uus
   Nn1 = Nn

   u_ = u
   call dfftw_execute(plan_u2us)

   do n = 1, Nt
      Nn1 = Nn
      call dfftw_execute(plan_us2u)
      u_ = u_ * Nx_inv
      uu = u_*u_
      call dfftw_execute(plan_uu2uus)
      Nn = G*uus
      us = B * (A*us + dt32*Nn - dt2*Nn1)
   end do

   call dfftw_execute(plan_us2u)
   u = u_ * Nx_inv

 end subroutine ksintegrate


! ###########################################################
! #                                                         #
! #                    THE LIDORT FAMILY                    #
! #                                                         #
! #      (LInearized Discrete Ordinate Radiative Transfer)  #
! #       --         -        -        -         -          #
! #                                                         #
! ###########################################################

! ###########################################################
! #                                                         #
! #  Author :      Robert. J. D. Spurr                      #
! #                                                         #
! #  Address :     RT Solutions, Inc.                       #
! #                9 Channing Street                        #
! #                Cambridge, MA 02138, USA                 #
! #                                                         #
! #  Tel:          (617) 492 1183                           #
! #  Email :        rtsolutions@verizon.net                 #
! #                                                         #
! ###########################################################

! ###########################################################
! #                                                         #
! #     FIRST-ORDER SCALAR MODEL (EXACT SINGLE SCATTERING)  #
! #                                                         #
! #  This Version :   1.3 F90                               #
! #  Release Date :   March 2013                            #
! #                                                         #
! #   Version 1.1,  13 February 2012, First Code            #
! #   Version 1.2,  01 June     2012, Modularization        #
! #   Version 1.3a, 29 October  2012, Multiple geometries   #
! #   Version 1.3b, 24 January  2013, BRDF/SL Supplements   #
! #                                                         #
! ###########################################################

! ##########################################################
! #                                                        #
! #   This Version of FIRST_ORDER comes with a GNU-style   #
! #   license. Please read the license carefully.          #
! #                                                        #
! ##########################################################

module FO_ScalarSS_spherfuncs_m

!  Legendre polynomials

!   Extension to multiple geometries, 29 October 2012   (Version 1.3)

public

contains

SUBROUTINE FO_ScalarSS_spherfuncs ( STARTER, MAXMOMS, MAXGEOMS, NMOMS, NGEOMS, DF1, DF2, COSSCAT, SS_PLEG )

   implicit none

!  parameter argument

   integer, parameter :: fpk = selected_real_kind(15)

!  I/O

   LOGICAL  , intent(inout) :: STARTER
   INTEGER  , intent(in)    :: MAXMOMS,  NMOMS
   INTEGER  , intent(in)    :: MAXGEOMS, NGEOMS
   REAL(fpk), intent(in)    :: COSSCAT(MAXGEOMS)
   REAL(fpk), intent(out)   :: SS_PLEG(0:MAXMOMS,MAXGEOMS)
   REAL(fpk), intent(inout) :: DF1(MAXMOMS)
   REAL(fpk), intent(inout) :: DF2(MAXMOMS)

!  Local

   integer  :: L, V ; real(fpk) :: MU

!  Help arrays

   IF ( STARTER ) THEN
      DF1(1) = 0.0d0 ; DF2(1) = 0.0d0
      DO L = 2, NMOMS
        DF1(L) = DBLE(2*L-1) / DBLE(L)
        DF2(L) = DBLE(L-1)   / DBLE(L)
      ENDDO
      STARTER = .false.
   ENDIF

!  Legendre

   DO V = 1, NGEOMS
     MU = COSSCAT(V)
     SS_PLEG(0,V) = 1.0d0
     SS_PLEG(1,V) = MU
     DO L = 2, NMOMS
        SS_PLEG(L,V) = DF1(L) * SS_PLEG(L-1,V) * MU - DF2(L) * SS_PLEG(L-2,V)
     ENDDO
   ENDDO

!  Finish

   RETURN
END SUBROUTINE FO_ScalarSS_spherfuncs

!  Finish

end module FO_ScalarSS_spherfuncs_m


      real*8 function interp2 (a1, a2, av, t1, t2)
!***********************************************************************
! $Id: interp2.f,v 1.1 2006/05/17 15:23:22 zvd Exp $
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!
! PURPOSE
!
! To calculate particle time delay using type curves.
!
!**********************************************************************
!
! Initial implementation: 05-MAY-99, Programmer: Zora Dash
!     for FEHM Version 2.10 [10086-STN-2.10-00]
!
!**********************************************************************
! Return the interpolated time value

      real*8 a1, a2, av, t1, t2, adj

      adj = (dlog10 (av) - dlog10 (a1)) / (dlog10 (a2) - dlog10 (a1))
      interp2 = t1 + adj * (t2 - t1)
      return
      end


      program shbcg
      implicit none
c
c     This program performs the following tasks:
c     (1) It constructs a simple symmetric eigenvalue problem by
c     reading a matrix stored in Boeing-Harwell format.  The matrix
c     is read by one processor and distributed to all processors in
c     the group.  If the matrix is RSA type, it is expanded before
c     distribution, if it is RUA type, the symmetric part of the matrix
c     is used.
c     (2) It calls LANDR once using MEMSIZE memory as workspace to
c     compute as much eigenvalues as possible using shift-and-invert
c     scheme.  Eigenvectors are not computed, Lanczos vectors are
c     stored only to perform reorthogonalization.
c     (3) The invert operator is solved using preconditioned CG from
c     SPARSKIT. The matrix-vector multiplication routine from PSPARSLIB
c     is used.
c     *** NOTE that the matrix (A - delta I) must be symmetric ***
c     *** positive definite!                                   ***
c     Dynamic memory allocation is used through-out the preprocessing
c     stages.
c
      include 'mpif.h'
c
c     the arrays for the distrubited MATVEC (amxdis) is stored in
c     the following header file
c
      include 'shbcg.h'
c     .. Parameters ..
      integer            memsize
      parameter          (memsize = 2000000)
      double precision   one
      parameter          (one = 1.0D0)
c     ..
c     .. Local Scalars ..
      character*128      delstr, hbfile
      integer            i, ierr, iou, j, maxlan, maxnloc, maxnzloc,
     &                   mpicom, neig, nloc, nw
      double precision   condm, endl, endr, kappa, lanso_time,
     &                   setup_time
c     ..
c     .. Local Arrays ..
      integer            ord(*)
      double precision   bnd(*), ritz(*), wrk(*)
      pointer            (pwrk, wrk), (pord,ord), (pritz, ritz),
     &                   (pbnd, bnd)
c     ..
c     .. External Functions ..
      integer            iargc
      external           iargc
c     ..
c     .. External Subroutines ..
      external           dmalloc, dmfree, genprec, hbread1,
     &                   plandr2, psp_setup
c     ..
c     .. Statement Functions ..
      integer            ncells
c     ..
c     .. Statement Function definitions ..
      ncells(nloc, i) = 5*nloc + 4*i + 1 + max(nloc, i+1)
c     ..
c     .. Executable Statements ..
c
c.... A few constants
c
      verbose = 3
      locfact = 2
      kjac = 5
      iou = 17
      amxtype = 29
      ptrn = 1
      kappa = 1.0D-8
      delta = 0.0D0
      lusize = 0
c
      paloc = 0
      pjaloc = 0
      pialoc = 0
      pix = 0
      pord = 0
      pqq = 0
      pwrk = 0
      pritz = 0
      pbnd = 0
      palu = 0
      pjlu = 0
      pju = 0
      kmvcnt = 0
      mmvcnt = 0
      nreorth = 0
      kmvtime = 0
      mmvtime = 0
      reorthtime = 0
c
c
c     start MPI
c
      call mpi_init(ierr)
      if (ierr.ne.mpi_success)stop 'FAILED TO INIT MPI'
      mpicom = mpi_comm_world
      call mpi_comm_size(mpicom, totprocs, ierr)
      call mpi_comm_rank(mpicom, myproc, ierr)
      if (totprocs.gt.max_procs) then
         print *, 'Increase MAX_PROCS in file shbcg.h and PSPARSLIB.'
         call mpi_abort(mpicom, ierr)
      endif
      if (myproc.eq.0)print *, 'SHBCG'
c
c     the file name can be given as a command line argument
c
      if (iargc().gt.0) then
         call getarg(1, hbfile)
         if (iargc().gt.1) then
            call getarg(2, delstr)
            read (delstr, FMT = *, iostat = ierr)delta
            if (ierr.ne.0) then
               if (myproc.eq.0)print *,
     &             'The second argument must be a number.'
               delta = 0.0D0
            endif
         else
            delta = 0.0D0
         endif
         if (iargc().gt.2) then
            call getarg(3, delstr)
            read (delstr, FMT = *, iostat = ierr)kjac
            if (ierr.ne.0) then
               if (myproc.eq.0)print *,
     &             'The third argument must be a number.'
               kjac = 5
            endif
         else
            kjac = 5
         endif
      else
         print *, 'USAGE: shbcg hbfilename delta kjac'
         stop
      endif
c
c     read the given file and distribute the matrix
c
      setup_time = mpi_wtime()
      call hbread1(hbfile, 0, myproc, totprocs, nloc, split, paloc,
     &             pjaloc, pialoc, maxnzloc, maxnloc, iou, mpicom, ierr,
     &             verbose)
      if (ierr.ne.0) then
         print *, 'HBREAD failed with error code ', ierr
         call mpi_abort(mpicom, ierr)
      endif
c
c     prepare the matrix for distributed matrix-vector multiplication
c
      call psp_setup(maxnloc, maxnzloc, nloc, myproc, totprocs, split,
     &               aloc, jaloc, ialoc, pord, nbnd, nproc, proc, pix,
     &               ipr, mpicom, ierr)
      if (ierr.ne.0) then
         print *, 'PSP_SETUP failed with error code ', ierr
         call mpi_abort(mpicom, ierr)
      endif
      if (verbose.gt.15) then
         write (10+myproc, *) 'Local components on PE', myproc
         call dump(1, nloc, .true., aloc, jaloc, ialoc, 10+myproc)
         write (10+myproc, *) 'External edges:'
         call dump(nloc+1, nloc+nloc-nbnd+1, .true., aloc, jaloc, ialoc,
     &        10+myproc)
      endif
c
c     generate preconditioner for CG
c
      call genprec(nloc, ierr)
      if (ierr.ne.0) then
         print *, 'GENPREC returns error ', ierr
         print *, '        NO preconditioning will be used.'
         if (palu.ne.0) call dmfree(palu)
         if (pjlu.ne.0) call dmfree(pjlu)
         if (pju.ne.0) call dmfree(pju)
         palu = 0
         pjlu = 0
         pju = 0
         locfact = -1
      endif
c
c     the workspace for LANSO is allocated to fill up to
c     the maximum memory size available
c
      i = 4*maxnzloc + 10*maxnloc + 8*nloc + lusize
      if (totprocs.gt.1 .and. pix.ne.0) then
         i = i + 3*(nloc+max(ipr(nproc+1),ipr(nproc+2)))
      endif
      endl = dble(memsize-i) / dble(nloc+5)
      endl = max(2.0D1, endl)
      if (mpi_real8.eq.0) then
         call mpi_allreduce(endl, endr, 1, mpi_double_precision,
     &                      mpi_min, mpicom, ierr)
      else
         call mpi_allreduce(endl, endr, 1, mpi_real8, mpi_min, mpicom,
     &                      ierr)
      endif
      if (ierr.ne.mpi_success) then
         print *, 'SHBCG: failed to compute MAXLAN.'
         call mpi_abort(mpicom, ierr)
      endif
      maxlan = min(int(endr), split(totprocs+1)-1)
      nw = ncells(nloc, maxlan)
      call dmalloc(pqq, nloc*(maxlan+2), 8)
      call dmalloc(pwrk, nw, 8)
      call dmalloc(pritz, maxlan, 8)
      call dmalloc(pbnd, maxlan, 8)
      endl = -1.0D-30
      endr = 1.0D-30
      condm = one
      if (myproc.eq.0 .and. verbose.gt.0) then
         write(*, FMT = '(/A$)')'SHBCG: '
         print *, 'NPROCS = ', totprocs, '      MAXLAN = ', maxlan,
     &      '    Shift = ', delta, '    Kjac = ', kjac
         if (verbose.gt.10) then
            print *, 'Matrix distribution:', split(1),
     &         ('--', split(i), i = 2, totprocs+1)
         endif
      endif
      if (pqq.eq.0 .or. pwrk.eq.0 .or. pritz.eq.0 .or. pbnd.eq.0) then
         print *, 'SHBCG failed to allocate workspace on PE', myproc
         call MPI_abort(mpicom, ierr)
      endif
c
c     the initial guess for the eigenvector is always [1,1,...,1]^T
c
      do 10 i = 1, nloc
         wrk(i) = one
 10   continue
      lanso_time = mpi_wtime()
      setup_time = lanso_time - setup_time
c
c     main loop to compute the smallest eigenvalue
c
      j = 0
      call plandr2(nloc, maxlan, 5, 1, condm, kappa, j, neig, ritz, bnd,
     &             wrk, nw, ierr, verbose, mpicom)
      if (ierr.ne.0) then
         print *, 'LANDR2 returned with error code = ', ierr
         if (j.le.0)call mpi_abort(mpi_comm_world, ierr)
      endif
c
      lanso_time = mpi_wtime() - lanso_time
      call dmfree(pwrk)
      call dmfree(pqq)
      if (mpi_real8.eq.0) then
         call mpi_reduce(setup_time, endl, 1, mpi_double_precision,
     &                   mpi_sum, 0, mpicom, ierr)
         call mpi_reduce(lanso_time, endr, 1, mpi_double_precision,
     &                   mpi_sum, 0, mpicom, ierr)
      else
         call mpi_reduce(setup_time, endl, 1, mpi_real8, mpi_sum, 0,
     &                   mpicom, ierr)
         call mpi_reduce(lanso_time, endr, 1, mpi_real8, mpi_sum, 0,
     &                   mpicom, ierr)
      endif
      condm = max(abs(ritz(1)), abs(ritz(j)))
      call dsort2a(j, ritz, bnd)
c
      if (myproc.eq.0) then
         setup_time = endl / totprocs
         lanso_time = endr / totprocs
         print *, 'LANCZOS STEPS = ', j, '    NEIG = ',
     &      neig, '    || OP || = ', condm
         print *, 'Setup time = ', setup_time, 'sec'
         print *, 'LANSO time = ', lanso_time, 'sec'
         print *, 'MATVEC = ', kmvcnt, mmvcnt, '  time ', kmvtime,
     &      mmvtime
         print *, 'N reorth = ', nreorth, '  time ', reorthtime
         if (verbose.gt.3) then
            condm = condm*kappa
            write(*, FMT = 9999)
            write(*, FMT = 9989)1, delta+one/ritz(1), bnd(1)
            do 20 i = 2, j - 1
               if (bnd(i).lt.condm)write(*, FMT = 9989)i,
     &              delta+one/ritz(i), bnd(i)
 20         continue
            write(*, FMT = 9989)j, delta+one/ritz(j), bnd(j)
         endif
      endif
 9999 format(1X, '   INDEX       Lambda(LANSO)       ErrorBound')
 9989 format(1X, I8, G25.17, 2X, 1P, E10.2)
c
      call mpi_finalize(ierr)
c     end of program shbcg
      end
c-----------------------------------------------------------------------
c     modified from store.f 3.3 (BNP) 3/16/89
c
      subroutine store(n, isw, j, s)
      implicit none
      INCLUDE 'shbcg.h'
c     .. Parameters ..
      integer            maxll
      parameter          (maxll = 2)
      integer            storq, retrq, storp, retrp
      parameter          (storq = 1, retrq = 2, storp = 3, retrp = 4)
c     ..
c     .. Scalar Arguments ..
      integer            isw, j, n
c     ..
c     .. Array Arguments ..
      double precision   s(n)
c     ..
c     .. External Subroutines ..
      external           dcopy
c     ..
c     .. Executable Statements ..
c
      if (isw.eq.storq) then
         call dcopy(n, s, 1, qq((j+maxll-1)*n+1), 1)
      else if (isw.eq.retrq) then
         call dcopy(n, qq((j+maxll-1)*n+1), 1, s, 1)
      else if (isw.eq.storp) then
         if (j.gt.maxll)stop 'STORE: (STORP) J.GT.MAXLL'
         call dcopy(n, s, 1, qq((j-1)*n+1), 1)
      else if (isw.eq.retrp) then
         if (j.gt.maxll)stop 'STORE: (RETRP) J.GT.MAXLL'
         call dcopy(n, qq((j-1)*n+1), 1, s, 1)
      endif
      return
      end
c-----------------------------------------------------------------------
c @(#)shbpurge.f        0.01 (KW) 6/3/97; from purge.f 3.16 5/11/89
c
      subroutine ppurge(n, ll, j, r, q, ra, qa, wrk, eta, oldeta,
     &                  msglvl, mpicom)
      implicit none
      include 'mpif.h'
      include 'shbcg.h'
c
c.... This routine examines ETA to decide whether
c.... re-orthogonalization should be performed.
c.... NOTE: this routine uses up to two classic Gram-schmidt process
c.... to restore orthogonality.  If WRK is not large enough, it uses
c.... ETA and OLDETA as workspace.
c
c.... N      (local) dimension of the eigenproblem
c.... LL     no. of initial Lanczos vectors in local orthog.
c.... J      current Lanczos step
c.... R      the residual vector to become the next Lanczos vector
c.... Q      the current Lanczos vector
c.... RA     the product of the mass matrix and r
c.... QA     the product of the mass matrix and q
c.... WRK    a temporary vector to hold the previous Lanczos vectors
c.... ETA    orthogonality between r and previous Lanczos vectors
c.... OLDETA orthogonality between q and previous Lanczos vectors
c.... MPICOM MPI Communicator
c
c.... BLAS routines:    DAXPY,DDOTMPI,IDAMAX
c.... subroutines:      DAXPY, DGEMV
c.... user-supplied:    OPM
c
c     .. Parameters ..
      double precision   zero, one
      parameter          (zero = 0.0D0, one = 1.0D0)
c     ..
c     .. Scalar Arguments ..
      integer            j, ll, mpicom, msglvl, n
c     ..
c     .. Array Arguments ..
      double precision   eta(j), oldeta(j), q(n), qa(n), r(n), ra(n),
     &                   wrk(n)
c     ..
c     .. Scalars in Common ..
      double precision   anorm, eps, eps1, eps34, epsn, rceps1, reps,
     &                   rnm, tol
c     ..
c     .. Local Scalars ..
      integer            i, k, loop, my_id
      double precision   reps1, t, tmptime, tq, tr
c     ..
c     .. External Functions ..
      integer            idamax
      double precision   ddotmpi
      external           idamax, ddotmpi
c     ..
c     .. External Subroutines ..
      external           daxpy, dgemv, opm
c     ..
c     .. Common blocks ..
      common             / rdata / rnm, anorm, tol, eps, eps1, rceps1,
     &                   epsn, reps, eps34
c     ..
c     .. Executable Statements ..
c
      if (j.le.ll+1)return
      my_id = -1
      k = idamax(j-(ll+1), eta(ll+1), 1) + ll
c
      if (abs(eta(k)).gt.reps) then
         if (msglvl.gt.10) then
            call mpi_comm_rank(mpicom, my_id, i)
            if (my_id.eq.0)print *, 'PPURGE: Omega(', k, j + 1, ') = ',
     &          abs(eta(k))
         endif
c     subpurge - tracking
         tmptime = mpi_wtime()
c
         reps1 = eps1 / reps
         do 40 loop = 1, 2
            if (rnm.gt.tol) then
               nreorth = nreorth + 1
               if (my_id.eq.0 .and. msglvl.gt.10) then
                  print *, 'PPURGE: purging Q_', j, ' and R_', j,
     &               ' LOOP #', loop
               endif
c
c....       Bring in a Lanczos vector t and orthogonalize both r and q
c....       against it
c
               tq = 0.0D0
               tr = 0.0D0
c
c     try to put the two part sums into WRK if possible, otherwise
c     use eta and old eta as workspace
c
               if (n.ge.4*(j-1)) then
                  call dgemv('T', n, j-1, one, qq(1+n+n), n, qa, 1,
     &                       zero, wrk(j+j-1), 1)
                  call dgemv('T', n, j-1, one, qq(1+n+n), n, ra, 1,
     &                       zero, wrk(3*j-2), 1)
                  if (mpi_real8.eq.0) then
                     call mpi_allreduce(wrk(j+j-1), wrk, j+j-2,
     &                                  mpi_double_precision, mpi_sum,
     &                                  mpicom, i)
                  else
                     call mpi_allreduce(wrk(j+j-1), wrk, j+j-2,
     &                                  mpi_real8, mpi_sum, mpicom, i)
                  endif
                  if (i.ne.mpi_success)call mpi_abort(mpi_comm_world, i)
                  call dgemv('N', n, j-1, -one, qq(1+n+n), n, wrk, 1,
     &                       one, q, 1)
                  call dgemv('N', n, j-1, -one, qq(1+n+n), n, wrk(j), 1,
     &                       one, r, 1)
                  do 10 i = 1, j - 1
                     tq = tq + abs(wrk(i))
                     tr = tr + abs(wrk(j-1+i))
 10               continue
               else
                  call dgemv('T', n, j-1, one, qq(1+n+n), n, qa, 1,
     &                       zero, eta, 1)
                  if (mpi_real8.eq.0) then
                     call mpi_allreduce(eta, oldeta, j-1,
     &                                  mpi_double_precision, mpi_sum,
     &                                  mpicom, i)
                  else
                     call mpi_allreduce(eta, oldeta, j-1, mpi_real8,
     &                                  mpi_sum, mpicom, i)
                  endif
                  if (i.ne.mpi_success)call mpi_abort(mpi_comm_world, i)
                  call dgemv('N', n, j-1, -one, qq(1+n+n), n, oldeta, 1,
     &                       one, q, 1)
                  do 20 i = 1, j - 1
                     tq = tq + abs(oldeta(i))
 20               continue
                  call dgemv('T', n, j-1, one, qq(1+n+n), n, ra, 1,
     &                       zero, eta, 1)
                  if (mpi_real8.eq.0) then
                     call mpi_allreduce(eta, oldeta, j-1,
     &                                  mpi_double_precision, mpi_sum,
     &                                  mpicom, i)
                  else
                     call mpi_allreduce(eta, oldeta, j-1, mpi_real8,
     &                                  mpi_sum, mpicom, i)
                  endif
                  if (i.ne.mpi_success)call mpi_abort(mpi_comm_world, i)
                  call dgemv('N', n, j-1, -one, qq(1+n+n), n, oldeta, 1,
     &                       one, r, 1)
                  do 30 i = 1, j - 1
                     tr = tr + abs(oldeta(i))
 30               continue
               endif
               call opm(n, q, qa, mpicom)
c
c....          restore local orthogonality
c
               t = -ddotmpi(n, r, 1, qa, 1, mpicom)
               tr = tr + abs(t)
               call daxpy(n, t, q, 1, r, 1)
c
               call opm(n, r, ra, mpicom)
               rnm = sqrt(ddotmpi(n,ra,1,r,1,mpicom))
               if (tq.le.reps1 .and. tr.le.reps1*rnm) go to 50
            endif
 40      continue
 50      do 60 i = 1, j
            eta(i) = eps1
            oldeta(i) = eps1
 60      continue
c     subpurge tracking
         reorthtime = reorthtime + mpi_wtime() - tmptime
c
      endif
      return
      end
c-----------------------------------------------------------------------
      subroutine genprec(nloc, ierr)
      implicit none
      include 'shbcg.h'
c     .. Scalar Arguments ..
      integer            ierr, nloc
c     ..
c     .. Local Scalars ..
      integer            i, ii, j, knz
c     ..
c     .. Local Arrays ..
      integer            iwk(*)
      pointer            (piwk, iwk)
c     ..
c     .. External Subroutines ..
      external           csort, dmalloc, dmfree, ilu0, slu_fact
c     ..
c     .. Executable Statements ..
      ierr = 0
c
c     call SuperLU
c
      if (locfact.gt.1) then
         locfact = 2
         call slu_fact(nloc, aloc, jaloc, ialoc, ierr)
         if (ierr.gt.0) then
            lusize = ierr
            ierr = 0
            go to 40
         else
            print *, 'GENPREC: SuperLU failed on PE', myproc,
     &         ' Use ILU0 as local factorization.'
            locfact = 1
         endif
      endif
c
c     generate ilu0
c
      if (locfact.eq.0) then
         knz = nloc+1
      else
         knz = ialoc(nloc+1) - ialoc(1) + nloc
      endif
      call dmalloc(palu, knz, 8)
      call dmalloc(pjlu, knz, 1)
      call dmalloc(pju, nloc, 1)
      if (palu.eq.0 .or. pjlu.eq.0 .or. pju.eq.0) then
         print *, 'GENPREC failed to allocate space for LU on PE',
     &        myproc
         stop
      endif
      lusize= knz + knz + nloc
c
      if (locfact.eq.0) then
         locfact = 0
         j = nloc+2
         do 20 i = 1, nloc
            alu(i) = 0.0D0
            jlu(i) = j
            ju(i) = j
            do 10 ii = ialoc(i), ialoc(i+1)-1
               if (jaloc(ii).eq.i .and. aloc(ii).ne.0.0D0)
     &              alu(i) = 1.0D0/aloc(ii)
 10         continue
 20      continue
         i = nloc + 1
         alu(i) = 0.0D0
         jlu(i) = j
      else
         locfact = 1
         call dmalloc(piwk, nloc, 1)
         if (piwk.eq.0) then
            print *, 'GENPREC failed to allocate workspace for ILU0',
     &           ' on PE', myproc
            stop
         endif
         call ilu0(nloc, aloc, jaloc, ialoc, alu, jlu, ju, iwk, ierr)
         call dmfree(piwk)
         if (ierr.ne.0) then
            print *, 'ILU0 encountered zero pivot at step ', ierr
            call dmfree(palu)
            call dmfree(pjlu)
            call dmfree(pju)
            lusize = 0
         endif
      endif
c
 9999 format(1X, 'Local factorization: ', A, ' on PE', I3)
 40   if (verbose.gt.2) then
         if (locfact.eq.0) then
            print 9999, 'diagonal', myproc
         else if (locfact.eq.1) then
            print 9999, 'ILU0', myproc
         else if (locfact.eq.2) then
            print 9999, '(Super)LU', myproc
         else
            print 9999, 'Unknown', myproc
         endif
      endif
c
      return
c     end subroutine genprec
      end
c-----------------------------------------------------------------------
C @(#) modified from dsort2.f	3.2 (BNP) 12/9/88
C
      SUBROUTINE DSORT2A(N,ARRAY1,ARRAY2)
      INTEGER N
      REAL*8 ARRAY1(0:N-1),ARRAY2(0:N-1)
C
C.... Sort array1 and array2 in decreasing order for array1's magnitude
C
      INTEGER IGAP,I,J
      REAL*8 TEMP
C
      IGAP = N/2
 10   IF (IGAP.GT.0) THEN
        DO 200 I = IGAP,N-1
          J = I-IGAP
 50       IF (abs(ARRAY1(J)).LT.abs(ARRAY1(J+IGAP))) THEN
              TEMP = ARRAY1(J)
              ARRAY1(J) = ARRAY1(J+IGAP)
              ARRAY1(J+IGAP) = TEMP
              TEMP = ARRAY2(J)
              ARRAY2(J) = ARRAY2(J+IGAP)
              ARRAY2(J+IGAP) = TEMP
          ELSE
            GO TO 200
          ENDIF
          IF (J.GE.IGAP) THEN
             J = J-IGAP
             GO TO 50
          ENDIF
 200    CONTINUE
      ELSE
        RETURN
      ENDIF
      IGAP = IGAP/2
      GO TO 10
      END
c-----------------------------------------------------------------------
      double precision    function distdot(n, x, ix, y, iy)
c     distdot is required by CG from SPARSKIT
      include 'mpif.h'
c     .. Scalar Arguments ..
      integer            ix, iy, n
c     ..
c     .. Array Arguments ..
      double precision   x(*), y(*)
c     ..
c     .. Local Scalars ..
      integer            ierr
c     ..
c     .. Local Arrays ..
      double precision   tmp(2)
c     ..
c     .. External Functions ..
      double precision   ddot
      external           ddot
c     ..
c     .. Executable Statements ..
      tmp(2) = ddot(n, x, ix, y, iy)
      if (mpi_real8.gt.0) then
         call mpi_allreduce(tmp(2), tmp(1), 1, mpi_real8, mpi_sum,
     &                      mpi_comm_world, ierr)
      else
         call mpi_allreduce(tmp(2), tmp(1), 1, mpi_double_precision,
     &                      mpi_sum, mpi_comm_world, ierr)
      endif
      if (ierr.ne.mpi_success) then
         call mpi_abort(mpi_comm_world, ierr)
      endif
      distdot = tmp(1)
      return
c     end distdot
      end
c-----------------------------------------------------------------------
      subroutine opm(n, x, y, mpicom)
      implicit none
      include 'mpif.h'
      include 'shbcg.h'
c     .. Scalar Arguments ..
      integer            mpicom, n
c     ..
c     .. Array Arguments ..
      double precision   x(n), y(n)
c     ..
c     .. Local Scalars ..
      integer            i
      double precision   tmptime
c     ..
c     .. Executable Statements ..
      mmvcnt = mmvcnt + 1
      tmptime = mpi_wtime()
      do 10 i = 1, n
         y(i) = x(i)
 10   continue
      mmvtime = mmvtime + mpi_wtime() - tmptime
      return
c     end subroutine opm
      end
c-----------------------------------------------------------------------
      subroutine op(n, p, q, r, mpicom)
      implicit none
      include 'mpif.h'
      include 'shbcg.h'
c     .. Scalar Arguments ..
      integer            mpicom, n
c     ..
c     .. Array Arguments ..
      double precision   p(n), q(n), r(n)
c     ..
c     .. Local Scalars ..
      integer            i, ii, j, length
      double precision   flops, tmptime, res
c     ..
c     .. Local Arrays ..
      integer            ipar(16)
      double precision   fpar(16), itwrk(*), xtmp(*), ytmp(*)
      pointer            (pxtmp, xtmp), (pytmp, ytmp), (pitwrk, itwrk)
c     ..
c     .. External Subroutines ..
      double precision   ddot
      external           amux, amxdis, cg, daxpy, dcopy, dmalloc,
     &                   lusol, ddot
c     ..
c     .. Save statement ..
      save               pitwrk, pxtmp, pytmp, length, flops
c     ..
c     .. Data statements ..
      data               pitwrk, pxtmp, pytmp, length, flops
     &                   / 4*0, 0.0D0 /
c     ..
c     .. Executable Statements ..
c
c     this routine performs the following solve
c     (A - delta I) r = q
c     always use zero as initial guess
c
      tmptime = mpi_wtime()
c
c     allocte enough temporary workspace for amxdis and CG
c
      if (pitwrk.eq.0) then
         call dmalloc(pitwrk, 5*n, 8)
         if (pitwrk.eq.0) then
            print *, 'OP failed to allocate workspace for CG on PE',
     &           myproc
            call MPI_abort(mpicom, i)
         endif
      endif
      if (totprocs.gt.1 .and. pxtmp.eq.0) then
         length = n + max(ipr(nproc+1), ipr(nproc+2))
         call dmalloc(pxtmp, length, 8)
         call dmalloc(pytmp, length, 8)
         if (pxtmp.eq.0 .or. pytmp.eq.0) then
            print *, 'OP failed to allocate workspace for AMXDIS on PE',
     &           myproc
            call MPI_abort(mpicom, i)
         endif
      endif
c
      ipar(1) = 0
      if ((locfact.eq.2 .or. (palu.ne.0 .and. pjlu.ne.0 .and. pju.ne.0))
     &     .and. kjac.gt.0) then
         ipar(2) = 2
         call MPI_Allreduce(ipar(2), ipar(3), 1, mpi_integer, mpi_sum,
     &        mpicom, i)
         if (ipar(3).ne.2*totprocs) then
            ipar(2) = 0
            locfact = -1
            if (palu.ne.0) then
               call dmfree(palu)
               call dmfree(pjlu)
               call dmfree(pju)
               lusize=0
            endif
         endif
      else
         ipar(2) = 0
      endif
      ipar(3) = 0
      ipar(4) = 5*n
      ipar(5) = 10
      ipar(6) = 100
      ipar(16) = 0
      fpar(1) = 1.0D-8
      fpar(2) = 0.0D0
      fpar(11) = 0.0D0
      do 30 i = 1, n
         r(i) = 0.0D0
 30   continue
 10   call cg(n, q, r, ipar, fpar, itwrk)
      if (ipar(1).eq.1) then
         if (totprocs.gt.1) then
            call dcopy(n, itwrk(ipar(8)), 1, xtmp, 1)
            call amxdis(n, nbnd, xtmp, ytmp, aloc, jaloc, ialoc, nproc,
     &                  proc, ix, ipr, amxtype, length, ptrn)
            if (delta.ne.0.0D0) then
               ipar(8) = ipar(8) - 1
               ipar(9) = ipar(9) - 1
c$DIR unroll=16
               do 20 i = 1, n
                  itwrk(ipar(9)+i) = ytmp(i) - delta*itwrk(ipar(8)+i)
 20            continue
               ipar(8) = ipar(8) + 1
               ipar(9) = ipar(9) + 1
            else
               call dcopy(n, ytmp, 1, itwrk(ipar(9)), 1)
            endif
            if (xtmp(length+1).ne.0 .or. ytmp(length+1).ne.0) then
               print *, 'Guard elements of xtmp and ytmp are:',
     &            xtmp(length+1), ytmp(length+1)
            endif
         else
            call amux(n, itwrk(ipar(8)), itwrk(ipar(9)), aloc, jaloc,
     &                ialoc)
            if (delta.ne.0.0D0) call daxpy(n, -delta,
     &           itwrk(ipar(8)), 1, itwrk(ipar(9)), 1)
         endif
         fpar(11) = fpar(11) + ialoc(n+1) + ialoc(n+1)
         kmvcnt = kmvcnt + 1
         if (ipar(7).eq.ipar(6)-1) then
            if (fpar(5).gt.fpar(4) .and. fpar(5).lt.fpar(3)) then
               ipar(6) = min(ipar(6)+ipar(6), split(totprocs+1))
            endif
            if (verbose.gt.3 .and. myproc.eq.0) then
               print 9999, ipar(7), fpar(5), fpar(5)/fpar(3)
            endif
         endif
         go to 10
      else if (ipar(1).eq.3 .or. ipar(1).eq.5) then
         if (locfact.gt.1) then
            call dcopy(n, itwrk(ipar(8)), 1, itwrk(ipar(9)), 1)
            call SLU_SOLVE(n, 1, n, itwrk(ipar(9)), fpar(11))
         else
            call lusol(n, itwrk(ipar(8)), itwrk(ipar(9)), alu, jlu, ju)
            fpar(11) = fpar(11) + jlu(n+1) + jlu(n+1)
         endif
         if (kjac.le.1 .or. nbnd.gt.n) go to 10
         j = 1
 100     call dcopy(n, itwrk(ipar(9)), 1, xtmp, 1)
         call msg_bdx_sendi(n, xtmp, ytmp, nproc, proc, ix, ipr, ptrn,
     &        i)
         if (i.ne.mpi_success)call mpi_abort(mpi_comm_world, i)
c
c     check the convergence so far to see whether it is necessary to
c     increase kjac
c
         if (j+1.eq.kjac) then
            call amux(n, xtmp, ytmp, aloc, jaloc, ialoc)
            call amux1(n-nbnd+1, xtmp, ytmp(nbnd), aloc, jaloc,
     &           ialoc(n+1))
            ipar(8) = ipar(8) - 1
            do 40 i = 1, n
               ytmp(i) = ytmp(i) - itwrk(ipar(8)+i) - delta*xtmp(i)
 40         continue
            ipar(8) = ipar(8) + 1
            fpar(15) = ddot(n, itwrk(ipar(8)), 1, itwrk(ipar(8)), 1)
            fpar(16) = ddot(n, ytmp, 1, ytmp, 1)
            call mpi_allreduce(fpar(15), ytmp, 2, mpi_real8, mpi_sum,
     &           mpicom, i)
            if (ytmp(2).lt.ytmp(1)) then
               i = kjac
               if (ytmp(1).gt.0.0D0 .and. ytmp(2).gt.1D-2*ytmp(1)
     &              .and. ipar(16).eq.0) then
                  kjac = 1+int(j*log(1D-2)/log(ytmp(2)/ytmp(1)))
                  kjac = min(100, kjac)
               endif
               if (myproc.eq.0 .and. i.ne.kjac .and. verbose.gt.1) then
                  print *, 'OP: modified KJAC from ', i, ' to ', kjac
               endif
            else
               ipar(16) = ipar(16) - 1
               if (verbose.gt.2 .and. myproc.eq.0) then
                  print 9989, sqrt(ytmp(1)), j, sqrt(ytmp(2)), ipar(7)
               endif
               if (ipar(16).le.nint(-0.8*ipar(7)) .and.
     &              ipar(16).lt.-5) then
                  if (verbose.gt.0 .and. myproc.eq.0) then
                     print *, 'OP: restart CG without preconditioning.'
                  endif
                  ipar(1) = 0
                  ipar(2) = 0
                  goto 10
               endif
            endif
         endif
 9989    format(1X, 'Block-Jacobi failing: res_0', 1PE12.3,
     &        ', res_', I3.3, 1PE12.3, ', CG step', I8)
         do 70 i = 1, n
            res = itwrk(ipar(8)+i-1)
            if (i.ge.nbnd) then
               do 60 ii = ialoc(n+i-nbnd+1), ialoc(n+i-nbnd+2)-1
                  res = res - aloc(ii)*xtmp(jaloc(ii))
 60            continue
            endif
            itwrk(ipar(9)+i-1) = res
 70      continue
         fpar(11) = fpar(11) + 2*(ialoc(n+n-nbnd+2)-ialoc(n+1))
         if (locfact.gt.1) then
            call SLU_SOLVE(n, 1, n, itwrk(ipar(9)), fpar(11))
         else
            call lusol(n, itwrk(ipar(9)), itwrk(ipar(9)), alu, jlu, ju)
            fpar(11) = fpar(11) + jlu(n+1) + jlu(n+1)
         endif
         j = j + 1
         if (j.lt.kjac) then
            goto 100
         else
            goto 10
         endif
      else if (ipar(1).ne.0 .and. myproc.eq.0) then
         print *, 'OP: iterative method returned with error code',
     &      ipar(1)
      endif
c
 9999 format(1X, 'CG: MATVEC', I6, '   res=', 1PE10.2,
     &     '   reduction=', 1PE10.2)
      if (verbose.gt.1 .and. myproc.eq.0) then
         print 9999, ipar(7), fpar(5), fpar(5)/fpar(3)
      endif
      if (ipar(1).lt.-1 .or. fpar(5).gt.fpar(3)) then
         if (myproc.eq.0) then
            print *, 'NOTE that OP is using CG as the solver.'
            print *, 'The matrix (A - delta I) must be SPD!'
         endif
         call mpi_abort(mpicom, ipar(1))
      endif
c
      kmvtime = kmvtime + mpi_wtime() - tmptime
      flops = flops + fpar(11)
      if (ipar(16).lt.-ipar(7)/2) then
         if (verbose.gt.1 .and. myproc.eq.0) then
            print *, 'Block-Jacobi has faild ', -ipar(16), ' out of ',
     &           ipar(7), ' times.'
            print *, 'It will be disabled.'
         endif
         kjac = -1
      else if (ipar(16).le.0) then
         kjac = min(kjac+kjac, 100)
      endif
      return
c     end subroutine op
      end


!*==zggev3.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  ZGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm)
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGGEV3 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
!                          VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBVL, JOBVR
!       INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   RWORK( * )
!       COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
!      $                   BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
!      $                   WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZGGEV3 computes for a pair of N-by-N complex nonsymmetric matrices
!> (A,B), the generalized eigenvalues, and optionally, the left and/or
!> right generalized eigenvectors.
!>
!> A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!> singular. It is usually represented as the pair (alpha,beta), as
!> there is a reasonable interpretation for beta=0, and even for both
!> being zero.
!>
!> The right generalized eigenvector v(j) corresponding to the
!> generalized eigenvalue lambda(j) of (A,B) satisfies
!>
!>              A * v(j) = lambda(j) * B * v(j).
!>
!> The left generalized eigenvector u(j) corresponding to the
!> generalized eigenvalues lambda(j) of (A,B) satisfies
!>
!>              u(j)**H * A = lambda(j) * u(j)**H * B
!>
!> where u(j)**H is the conjugate-transpose of u(j).
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBVL
!> \verbatim
!>          JOBVL is CHARACTER*1
!>          = 'N':  do not compute the left generalized eigenvectors;
!>          = 'V':  compute the left generalized eigenvectors.
!> \endverbatim
!>
!> \param[in] JOBVR
!> \verbatim
!>          JOBVR is CHARACTER*1
!>          = 'N':  do not compute the right generalized eigenvectors;
!>          = 'V':  compute the right generalized eigenvectors.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrices A, B, VL, and VR.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          On entry, the matrix A in the pair (A,B).
!>          On exit, A has been overwritten.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX*16 array, dimension (LDB, N)
!>          On entry, the matrix B in the pair (A,B).
!>          On exit, B has been overwritten.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] ALPHA
!> \verbatim
!>          ALPHA is COMPLEX*16 array, dimension (N)
!> \endverbatim
!>
!> \param[out] BETA
!> \verbatim
!>          BETA is COMPLEX*16 array, dimension (N)
!>          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
!>          generalized eigenvalues.
!>
!>          Note: the quotients ALPHA(j)/BETA(j) may easily over- or
!>          underflow, and BETA(j) may even be zero.  Thus, the user
!>          should avoid naively computing the ratio alpha/beta.
!>          However, ALPHA will be always less than and usually
!>          comparable with norm(A) in magnitude, and BETA always less
!>          than and usually comparable with norm(B).
!> \endverbatim
!>
!> \param[out] VL
!> \verbatim
!>          VL is COMPLEX*16 array, dimension (LDVL,N)
!>          If JOBVL = 'V', the left generalized eigenvectors u(j) are
!>          stored one after another in the columns of VL, in the same
!>          order as their eigenvalues.
!>          Each eigenvector is scaled so the largest component has
!>          abs(real part) + abs(imag. part) = 1.
!>          Not referenced if JOBVL = 'N'.
!> \endverbatim
!>
!> \param[in] LDVL
!> \verbatim
!>          LDVL is INTEGER
!>          The leading dimension of the matrix VL. LDVL >= 1, and
!>          if JOBVL = 'V', LDVL >= N.
!> \endverbatim
!>
!> \param[out] VR
!> \verbatim
!>          VR is COMPLEX*16 array, dimension (LDVR,N)
!>          If JOBVR = 'V', the right generalized eigenvectors v(j) are
!>          stored one after another in the columns of VR, in the same
!>          order as their eigenvalues.
!>          Each eigenvector is scaled so the largest component has
!>          abs(real part) + abs(imag. part) = 1.
!>          Not referenced if JOBVR = 'N'.
!> \endverbatim
!>
!> \param[in] LDVR
!> \verbatim
!>          LDVR is INTEGER
!>          The leading dimension of the matrix VR. LDVR >= 1, and
!>          if JOBVR = 'V', LDVR >= N.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is DOUBLE PRECISION array, dimension (8*N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          =1,...,N:
!>                The QZ iteration failed.  No eigenvectors have been
!>                calculated, but ALPHA(j) and BETA(j) should be
!>                correct for j=INFO+1,...,N.
!>          > N:  =N+1: other then QZ iteration failed in DHGEQZ,
!>                =N+2: error return from DTGEVC.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date January 2015
!
!> \ingroup complex16GEeigen
!
!  =====================================================================
      SUBROUTINE ZGGEV3(Jobvl,Jobvr,N,A,Lda,B,Ldb,Alpha,Beta,Vl,Ldvl,Vr,&
     &                  Ldvr,Work,Lwork,Rwork,Info)
      IMPLICIT NONE
!*--ZGGEV3220
!
!  -- LAPACK driver routine (version 3.6.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     January 2015
!
!     .. Scalar Arguments ..
      CHARACTER Jobvl , Jobvr
      INTEGER Info , Lda , Ldb , Ldvl , Ldvr , Lwork , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION Rwork(*)
      COMPLEX*16 A(Lda,*) , Alpha(*) , B(Ldb,*) , Beta(*) , Vl(Ldvl,*) ,&
     &           Vr(Ldvr,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
      COMPLEX*16 CZERO , CONE
      PARAMETER (CZERO=(0.0D0,0.0D0),CONE=(1.0D0,0.0D0))
!     ..
!     .. Local Scalars ..
      LOGICAL ilascl , ilbscl , ilv , ilvl , ilvr , lquery
      CHARACTER chtemp
      INTEGER icols , ierr , ihi , ijobvl , ijobvr , ileft , ilo , in , &
     &        iright , irows , irwrk , itau , iwrk , jc , jr , lwkopt
      DOUBLE PRECISION anrm , anrmto , bignum , bnrm , bnrmto , eps ,   &
     &                 smlnum , temp
      COMPLEX*16 x
!     ..
!     .. Local Arrays ..
      LOGICAL ldumma(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL DLABAD , XERBLA , ZGEQRF , ZGGBAK , ZGGBAL , ZGGHD3 ,    &
     &         ZHGEQZ , ZLACPY , ZLASCL , ZLASET , ZTGEVC , ZUNGQR ,    &
     &         ZUNMQR
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      DOUBLE PRECISION DLAMCH , ZLANGE
      EXTERNAL LSAME , DLAMCH , ZLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , DIMAG , MAX , SQRT
!     ..
!     .. Statement Functions ..
      DOUBLE PRECISION ABS1
!     ..
!     .. Statement Function definitions ..
      ABS1(x) = ABS(DBLE(x)) + ABS(DIMAG(x))
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF ( LSAME(Jobvl,'N') ) THEN
         ijobvl = 1
         ilvl = .FALSE.
      ELSEIF ( LSAME(Jobvl,'V') ) THEN
         ijobvl = 2
         ilvl = .TRUE.
      ELSE
         ijobvl = -1
         ilvl = .FALSE.
      ENDIF
!
      IF ( LSAME(Jobvr,'N') ) THEN
         ijobvr = 1
         ilvr = .FALSE.
      ELSEIF ( LSAME(Jobvr,'V') ) THEN
         ijobvr = 2
         ilvr = .TRUE.
      ELSE
         ijobvr = -1
         ilvr = .FALSE.
      ENDIF
      ilv = ilvl .OR. ilvr
!
!     Test the input arguments
!
      Info = 0
      lquery = (Lwork==-1)
      IF ( ijobvl<=0 ) THEN
         Info = -1
      ELSEIF ( ijobvr<=0 ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldvl<1 .OR. (ilvl .AND. Ldvl<N) ) THEN
         Info = -11
      ELSEIF ( Ldvr<1 .OR. (ilvr .AND. Ldvr<N) ) THEN
         Info = -13
      ELSEIF ( Lwork<MAX(1,2*N) .AND. .NOT.lquery ) THEN
         Info = -15
      ENDIF
!
!     Compute workspace
!
      IF ( Info==0 ) THEN
         CALL ZGEQRF(N,N,B,Ldb,Work,Work,-1,ierr)
         lwkopt = MAX(1,N+INT(Work(1)))
         CALL ZUNMQR('L','C',N,N,N,B,Ldb,Work,A,Lda,Work,-1,ierr)
         lwkopt = MAX(lwkopt,N+INT(Work(1)))
         IF ( ilvl ) THEN
            CALL ZUNGQR(N,N,N,Vl,Ldvl,Work,Work,-1,ierr)
            lwkopt = MAX(lwkopt,N+INT(Work(1)))
         ENDIF
         IF ( ilv ) THEN
            CALL ZGGHD3(Jobvl,Jobvr,N,1,N,A,Lda,B,Ldb,Vl,Ldvl,Vr,Ldvr,  &
     &                  Work,-1,ierr)
            lwkopt = MAX(lwkopt,N+INT(Work(1)))
            CALL ZHGEQZ('S',Jobvl,Jobvr,N,1,N,A,Lda,B,Ldb,Alpha,Beta,Vl,&
     &                  Ldvl,Vr,Ldvr,Work,-1,Rwork,ierr)
            lwkopt = MAX(lwkopt,N+INT(Work(1)))
         ELSE
            CALL ZGGHD3(Jobvl,Jobvr,N,1,N,A,Lda,B,Ldb,Vl,Ldvl,Vr,Ldvr,  &
     &                  Work,-1,ierr)
            lwkopt = MAX(lwkopt,N+INT(Work(1)))
            CALL ZHGEQZ('E',Jobvl,Jobvr,N,1,N,A,Lda,B,Ldb,Alpha,Beta,Vl,&
     &                  Ldvl,Vr,Ldvr,Work,-1,Rwork,ierr)
            lwkopt = MAX(lwkopt,N+INT(Work(1)))
         ENDIF
         Work(1) = DCMPLX(lwkopt)
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGGEV3 ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Get machine constants
!
      eps = DLAMCH('E')*DLAMCH('B')
      smlnum = DLAMCH('S')
      bignum = ONE/smlnum
      CALL DLABAD(smlnum,bignum)
      smlnum = SQRT(smlnum)/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = ZLANGE('M',N,N,A,Lda,Rwork)
      ilascl = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         anrmto = smlnum
         ilascl = .TRUE.
      ELSEIF ( anrm>bignum ) THEN
         anrmto = bignum
         ilascl = .TRUE.
      ENDIF
      IF ( ilascl ) CALL ZLASCL('G',0,0,anrm,anrmto,N,N,A,Lda,ierr)
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      bnrm = ZLANGE('M',N,N,B,Ldb,Rwork)
      ilbscl = .FALSE.
      IF ( bnrm>ZERO .AND. bnrm<smlnum ) THEN
         bnrmto = smlnum
         ilbscl = .TRUE.
      ELSEIF ( bnrm>bignum ) THEN
         bnrmto = bignum
         ilbscl = .TRUE.
      ENDIF
      IF ( ilbscl ) CALL ZLASCL('G',0,0,bnrm,bnrmto,N,N,B,Ldb,ierr)
!
!     Permute the matrices A, B to isolate eigenvalues if possible
!
      ileft = 1
      iright = N + 1
      irwrk = iright + N
      CALL ZGGBAL('P',N,A,Lda,B,Ldb,ilo,ihi,Rwork(ileft),Rwork(iright), &
     &            Rwork(irwrk),ierr)
!
!     Reduce B to triangular form (QR decomposition of B)
!
      irows = ihi + 1 - ilo
      IF ( ilv ) THEN
         icols = N + 1 - ilo
      ELSE
         icols = irows
      ENDIF
      itau = 1
      iwrk = itau + irows
      CALL ZGEQRF(irows,icols,B(ilo,ilo),Ldb,Work(itau),Work(iwrk),     &
     &            Lwork+1-iwrk,ierr)
!
!     Apply the orthogonal transformation to matrix A
!
      CALL ZUNMQR('L','C',irows,icols,irows,B(ilo,ilo),Ldb,Work(itau),  &
     &            A(ilo,ilo),Lda,Work(iwrk),Lwork+1-iwrk,ierr)
!
!     Initialize VL
!
      IF ( ilvl ) THEN
         CALL ZLASET('Full',N,N,CZERO,CONE,Vl,Ldvl)
         IF ( irows>1 ) CALL ZLACPY('L',irows-1,irows-1,B(ilo+1,ilo),   &
     &                              Ldb,Vl(ilo+1,ilo),Ldvl)
         CALL ZUNGQR(irows,irows,irows,Vl(ilo,ilo),Ldvl,Work(itau),     &
     &               Work(iwrk),Lwork+1-iwrk,ierr)
      ENDIF
!
!     Initialize VR
!
      IF ( ilvr ) CALL ZLASET('Full',N,N,CZERO,CONE,Vr,Ldvr)
!
!     Reduce to generalized Hessenberg form
!
      IF ( ilv ) THEN
!
!        Eigenvectors requested -- work on whole matrix.
!
         CALL ZGGHD3(Jobvl,Jobvr,N,ilo,ihi,A,Lda,B,Ldb,Vl,Ldvl,Vr,Ldvr, &
     &               Work(iwrk),Lwork+1-iwrk,ierr)
      ELSE
         CALL ZGGHD3('N','N',irows,1,irows,A(ilo,ilo),Lda,B(ilo,ilo),   &
     &               Ldb,Vl,Ldvl,Vr,Ldvr,Work(iwrk),Lwork+1-iwrk,ierr)
      ENDIF
!
!     Perform QZ algorithm (Compute eigenvalues, and optionally, the
!     Schur form and Schur vectors)
!
      iwrk = itau
      IF ( ilv ) THEN
         chtemp = 'S'
      ELSE
         chtemp = 'E'
      ENDIF
      CALL ZHGEQZ(chtemp,Jobvl,Jobvr,N,ilo,ihi,A,Lda,B,Ldb,Alpha,Beta,  &
     &            Vl,Ldvl,Vr,Ldvr,Work(iwrk),Lwork+1-iwrk,Rwork(irwrk), &
     &            ierr)
      IF ( ierr/=0 ) THEN
         IF ( ierr>0 .AND. ierr<=N ) THEN
            Info = ierr
         ELSEIF ( ierr>N .AND. ierr<=2*N ) THEN
            Info = ierr - N
         ELSE
            Info = N + 1
         ENDIF
         GOTO 100
      ENDIF
!
!     Compute Eigenvectors
!
      IF ( ilv ) THEN
         IF ( .NOT.(ilvl) ) THEN
            chtemp = 'R'
         ELSEIF ( ilvr ) THEN
            chtemp = 'B'
         ELSE
            chtemp = 'L'
         ENDIF
!
         CALL ZTGEVC(chtemp,'B',ldumma,N,A,Lda,B,Ldb,Vl,Ldvl,Vr,Ldvr,N, &
     &               in,Work(iwrk),Rwork(irwrk),ierr)
         IF ( ierr/=0 ) THEN
            Info = N + 2
            GOTO 100
         ENDIF
!
!        Undo balancing on VL and VR and normalization
!
         IF ( ilvl ) THEN
            CALL ZGGBAK('P','L',N,ilo,ihi,Rwork(ileft),Rwork(iright),N, &
     &                  Vl,Ldvl,ierr)
            DO jc = 1 , N
               temp = ZERO
               DO jr = 1 , N
                  temp = MAX(temp,ABS1(Vl(jr,jc)))
               ENDDO
               IF ( temp>=smlnum ) THEN
                  temp = ONE/temp
                  DO jr = 1 , N
                     Vl(jr,jc) = Vl(jr,jc)*temp
                  ENDDO
               ENDIF
            ENDDO
         ENDIF
         IF ( ilvr ) THEN
            CALL ZGGBAK('P','R',N,ilo,ihi,Rwork(ileft),Rwork(iright),N, &
     &                  Vr,Ldvr,ierr)
            DO jc = 1 , N
               temp = ZERO
               DO jr = 1 , N
                  temp = MAX(temp,ABS1(Vr(jr,jc)))
               ENDDO
               IF ( temp>=smlnum ) THEN
                  temp = ONE/temp
                  DO jr = 1 , N
                     Vr(jr,jc) = Vr(jr,jc)*temp
                  ENDDO
               ENDIF
            ENDDO
         ENDIF
      ENDIF
!
!     Undo scaling if necessary
!
!
 100  IF ( ilascl ) CALL ZLASCL('G',0,0,anrmto,anrm,N,1,Alpha,N,ierr)
!
      IF ( ilbscl ) CALL ZLASCL('G',0,0,bnrmto,bnrm,N,1,Beta,N,ierr)
!
      Work(1) = DCMPLX(lwkopt)
!
!     End of ZGGEV3
!
      END SUBROUTINE ZGGEV3


C
C $Id: dmapgci.f,v 1.3 2008-07-27 03:40:25 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE DMAPGCI(ALAT,ALON,BLAT,BLON,NOPI,RLTI,RLNI)
      IMPLICIT NONE
      DOUBLE PRECISION ALAT,ALON,BLAT,BLON,RLTI,RLNI
      DOUBLE PRECISION UCPD,VCPD,WCPD,UCPF,VCPF,UCPQ,VCPQ,WCPQ
      DOUBLE PRECISION UCPP,VCPP,WCPP,UCPO,VCPO,WCPO,UCPH,VCPH,WCPH
      DOUBLE PRECISION BETA,GAMA,UCPG,VCPG,WCPG,RTOD,WCPF,ALPH,CALP,SALP
      DOUBLE PRECISION WCPA,UCPB,VCPB,WCPB,CBLN,SBLN,UCPA,VCPA,SALN,
     +                 CBLT,SBLT
      DOUBLE PRECISION CALT,DTOR,SALT,CALN
      INTEGER IOPI,NOPI,ICFELL
C
      DIMENSION RLTI(*),RLNI(*)
C
C This routine, given the latitudes and longitudes of two points A and
C B on the surface of the globe, interpolates NOPI points along the
C great circle route joining A to B and returns the latitudes and
C longitudes of the interpolated points in the arrays RLTI and RLNI.
C
C Rotations about a given axis are used extensively below.  Assume a
C right-handed system with U, V, and W axes.  Rotating by an angle "a"
C about the U axis maps the point (u,v,w) into the point (u',v',w'),
C where
C
C       u' = u
C       v' = v cos(a) - w sin(a)
C       w' = w cos(a) + v sin(a)
C
C A positive value of "a" represents rotation in the direction from the
C V axis to the W axis.
C
C Similarly, rotating by an angle "a" about the V axis maps the point
C (u,v,w) into the point (u',v',w'), where
C
C       u' = u cos(a) + w sin(a)
C       v' = v
C       w' = w cos(a) - u sin(a)
C
C A positive value of "a" represents rotation in the direction from the
C W axis to the U axis.
C
C Rotating by an angle "a" about the W axis maps the point (u,v,w) into
C the point (u',v',w'), where
C
C       u' = u cos(a) - v sin(a)
C       v' = v cos(a) + u sin(a)
C       w' = w
C
C A positive value of "a" represents rotation in the direction from the
C U axis to the V axis.
C
C
C Define the constants used to convert from degrees to radians and
C vice-versa.
C
      DATA DTOR/.017453292519943D0/
      DATA RTOD/57.2957795130823D0/
C
C Check for an uncleared prior error.
C
      IF (ICFELL('MAPGCI - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Compute the U, V, and W coordinates (on a unit sphere) of the points
C A and B.
C
      CALT = COS(ALAT*DTOR)
      SALT = SIN(ALAT*DTOR)
      CALN = COS(ALON*DTOR)
      SALN = SIN(ALON*DTOR)
C
      CBLT = COS(BLAT*DTOR)
      SBLT = SIN(BLAT*DTOR)
      CBLN = COS(BLON*DTOR)
      SBLN = SIN(BLON*DTOR)
C
      UCPA = CALT*CALN
      VCPA = CALT*SALN
      WCPA = SALT
C
      UCPB = CBLT*CBLN
      VCPB = CBLT*SBLN
      WCPB = SBLT
C
C Rotating the points about the W axis by the angle -ALON carries point
C A into point C, in the UW plane.  It carries point B into point D.
C
C       CDLN=COS((BLON-ALON)*DTOR)
C       SDLN=SIN((BLON-ALON)*DTOR)
C
C       UCPC=CALT
C       VCPC=0.
C       WCPC=SALT
C
      UCPD = UCPB*CALN + VCPB*SALN
      VCPD = VCPB*CALN - UCPB*SALN
      WCPD = WCPB
C
C       UCPD=CBLT*CDLN
C       VCPD=CBLT*SDLN
C       WCPD=SBLT
C
C Rotating the points about the V axis by the angle ALAT carries point
C C into point E, on the U axis.  It carries point D into point F.
C
C       UCPE=1.
C       VCPE=0.
C       WCPE=0.
C
      UCPF = UCPD*CALT + WCPD*SALT
      VCPF = VCPD
      WCPF = WCPD*CALT - UCPD*SALT
C
C       UCPF=CALT*CBLT*CDLN-SALT*SBLT
C       VCPF=CBLT*SDLN
C       WCPF=CALT*SBLT+SALT*CBLT*CDLN
C
C Rotating the points about the U axis by the angle -ATAN(WCPF/VCPF)
C leaves the position of point E unchanged, but carries point F into
C point G, in the UV plane.
C
      IF (WCPF.NE.0.D0 .OR. VCPF.NE.0.D0) THEN
          ALPH = ATAN2(WCPF,VCPF)
      ELSE
          ALPH = 0.D0
      END IF
C
      CALP = COS(ALPH)
      SALP = SIN(ALPH)
C
      UCPG = UCPF
      VCPG = VCPF*CALP + WCPF*SALP
      WCPG = WCPF*CALP - VCPF*SALP
C
C       UCPG=CALT*CBLT*CDLN-SALT*SBLT
C       VCPG=CBLT*SDLN*CALP-CALT*SBLT*SALP-SALT*CBLT*CDLN*SALP
C       WCPG=CALT*SBLT*CALP+SALT*CBLT*CDLN*CALP+CBLT*SDLN*SALP
C
C The angle from E to G (which is the same as the angle from A to B)
C may now be computed easily.
C
      IF (VCPG.NE.0.D0 .OR. UCPG.NE.0.D0) THEN
          BETA = ATAN2(VCPG,UCPG)
      ELSE
          BETA = 0.D0
      END IF
C
C Interpolate points between the points E and G and map them back to
C the great circle route between A and B.
C
      DO 101 IOPI = 1,NOPI
          GAMA = (DBLE(IOPI)/DBLE(NOPI+1))*BETA
          UCPH = COS(GAMA)
          VCPH = SIN(GAMA)
          WCPH = 0.D0
          UCPO = UCPH
          VCPO = VCPH*CALP - WCPH*SALP
          WCPO = WCPH*CALP + VCPH*SALP
          UCPP = UCPO*CALT - WCPO*SALT
          VCPP = VCPO
          WCPP = WCPO*CALT + UCPO*SALT
          UCPQ = UCPP*CALN - VCPP*SALN
          VCPQ = VCPP*CALN + UCPP*SALN
          WCPQ = WCPP
          RLTI(IOPI) = RTOD*ATAN2(WCPQ,SQRT(UCPQ*UCPQ+VCPQ*VCPQ))
          IF (VCPQ.NE.0.D0 .OR. UCPQ.NE.0.D0) THEN
              RLNI(IOPI) = RTOD*ATAN2(VCPQ,UCPQ)
          ELSE
              RLNI(IOPI) = 0.D0
          END IF
  101 CONTINUE
C
C Done.
C
      RETURN
C
      END

      DOUBLE PRECISION FUNCTION DGCDIST(RLAT1,RLON1,RLAT2,RLON2,IU)
      IMPLICIT NONE
c
c calculate the great circle distance between two points
c
c usage: dist = gcdist (rlat1,rlon1,rlat2,rlon2,iu)
c
c nomenclature :
c .   rlat1,rlon1 - latitude and longtitude of the first point
c .   rlat2,rlon2 - latitude and longtitude of the second point
c .   iu          - code for the type units gcdist is to return
c .               = 1 : gcdist returned in radians
c .               = 2 : gcdist returned in degrees
c .               = 3 : gcdist returned in meters
c .               = 4 : gcdist returned in kilometers
c .               = 5 : gcdist returned in *not used*
c
c input
      INTEGER IU
c input types
      DOUBLE PRECISION RLAT1,RLON1,RLAT2,RLON2

c local stuff
      DOUBLE PRECISION UNITS(5),RAD,DLONR,RLAT1R,RLAT2R
      DATA UNITS/1.0D0,57.29577995691645D0,6371220.D0,6371.2200D0,0.D0/
c change as required
      DATA RAD/0.01745329238474369D0/

c special test if RLAT1=RLAT2 and RLON1=RLON2
      IF(RLAT1.EQ.RLAT2.AND.RLON1.EQ.RLON2) THEN
         DGCDIST = 0.D0
         RETURN
      END IF
      RLAT1R = RLAT1*RAD
      RLAT2R = RLAT2*RAD
      DLONR = DMIN1(ABS(RLON1-RLON2),ABS(360.D0-RLON1+RLON2),
     +        ABS(360.D0-RLON2+RLON1))*RAD

      DGCDIST = ACOS(SIN(RLAT1R)*SIN(RLAT2R)+
     +          COS(RLAT1R)*COS(RLAT2R)*COS(DLONR))*UNITS(IU)

      RETURN
      END


module bspline

  use precision
  type surfType
     ! Holds the data for a B-spline surface
     integer(kind=intType) :: ku, kv, nCtlu, nCtlv
     real(kind=realType), dimension(:), allocatable :: tu, tv
     real(kind=realType), dimension(:, :, :), allocatable :: coef
  end type surfType

  type(surfType), dimension(:), allocatable :: surfs

contains

  subroutine evalSurface(surf, u, v, n, pts)
    ! Simplified routine for evaluating points on the surface.
    use precision
    implicit none

    ! Input/Output
    type(surfType), intent(in) :: surf
    integer(kind=intType), intent(in):: n
    real(kind=realType), intent(in), dimension(n) :: u, v
    real(kind=realType), intent(out), dimension(3, n) :: pts
    ! Working
    integer(kind=intType) :: ileftu, ileftv, istartu, istartv, ii, i, j, idim
    real(kind=realType) :: basisu(surf%ku)
    real(kind=realType) :: basisv(surf%kv)

    do ii=1, n
       ! U
       call findSpan(u(ii), surf%ku, surf%tu, surf%nctlu, ileftu)
       call basis(surf%tu, surf%nctlu, surf%ku, u(ii), ileftu, basisu)
       istartu = ileftu-surf%ku

       ! V
       call findSpan(v(ii), surf%kv, surf%tv, surf%nctlv, ileftv)
       call basis(surf%tv, surf%nctlv, surf%kv, v(ii), ileftv, basisv)
       istartv = ileftv-surf%kv
       pts(:, ii) = 0.0_8
       do i=1, surf%ku
          do j=1, surf%kv
             do idim=1, 3
                pts(idim, ii) = pts(idim, ii) + &
                     basisu(i)*basisv(j)*surf%coef(idim, istartv+j, istartu+i)
             end do
          end do
       end do
    end do

  end subroutine evalSurface

  subroutine findSpan(u, k, t, nctl, ind)

    !***DESCRIPTION
    !
    !     Written by Gaetan Kenway. Adapted from "The NURBS BooK" Algorithm A2.1
    !
    !     Abstract: Determine the knot span index

    !     Description of Arguments
    !     Input:
    !     u       - Real, parametric location we are looking for
    !     k       - Integer, order of B-spline
    !     t       - Real, size(nctl + k), knot vector
    !
    !     Ouput:
    !     ind     - Integer, knot span index

    use precision
    implicit none

    ! Input
    integer(kind=intType), intent(in) :: k, nctl
    real(kind=realType), intent(in) :: u, t(nctl+k)
    ! Output
    integer(kind=intType), intent(out) :: ind

    ! Working
    integer(kind=intType) :: low, mid, high

    if (u >= t(nctl+1)) then
       ind = nctl
    else if (u < t(k)) then
       ind = k
    else
       low = k
       high = nctl+1

       ! Do a binary search
       mid = (low+high)/2
       do while ( (u < t(mid) .or. u >= t(mid+1)))
          if (u < t(mid)) then
             high = mid
          else
             low = mid
          end if

          mid = (low+high)/2
       end do

       ind = mid
    end if
  end subroutine findSpan

  subroutine basis(t, nctl, k, u, ind, B)

    !***DESCRIPTION
    !
    !     Written by Gaetan Kenway
    !
    !     Abstract: basis evaluates the standard b-spline basis
    !               functions at a location x for knot vector t. Adapted
    !               from The NURBS Book, algoritm A2.2

    !     Description of Arguments
    !     Input
    !     t       - Real, Vector of knots. Size (nctl + k)
    !     nctl    - Integer, number of knots
    !     k       - Integer, order of B-spline
    !     u       - Real, location for evaluation of basis
    !     ind     - Integer, position in knot vector such that t(ind) <= x
    !
    !     Ouput
    !     B       - Real, Vector, The k basis vector values
    use precision
    implicit none

    ! Input
    integer(kind=intType), intent(in)  :: nctl, k, ind
    real(kind=realType), intent(in)  :: t(nctl+k), u

    ! Output
    real(kind=realType), intent(out) :: B(0:k-1)

    ! Working
    real(kind=realType) :: left(0:k-1), right(0:k-1), temp, saved
    integer(kind=intType) :: j, r, p

    ! To be consistent with algorithm in The NURBS Book we will use
    ! 0.0_8-based ordering here
    B(0) = 1.0_8
    p = k-1

    do j=1,p
       left(j)  = u - t(ind+1-j)
       right(j) = t(ind+j) - u
       saved = 0.0_8

       do r=0,j-1
          temp = B(r)/(right(r+1)+left(j-r))
          B(r) = saved+right(r+1)*temp
          saved = left(j-r)*temp
       end do

       B(j) = saved
    end do

  end subroutine basis
end module bspline


      subroutine DOTPRODUCT(
     &           dotprodout
     &           ,afab
     &           ,iafablo0
     &           ,iafabhi0
     &           ,nafabcomp
     &           ,bfab
     &           ,ibfablo0
     &           ,ibfabhi0
     &           ,nbfabcomp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,startcomp
     &           ,endcomp
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 dotprodout
      integer nafabcomp
      integer iafablo0
      integer iafabhi0
      REAL*8 afab(
     &           iafablo0:iafabhi0,
     &           0:nafabcomp-1)
      integer nbfabcomp
      integer ibfablo0
      integer ibfabhi0
      REAL*8 bfab(
     &           ibfablo0:ibfabhi0,
     &           0:nbfabcomp-1)
      integer iregionlo0
      integer iregionhi0
      integer startcomp
      integer endcomp
      integer i0
      integer nv
      dotprodout = 0
      do nv=startcomp,endcomp,1
      do i0 = iregionlo0,iregionhi0
         dotprodout = dotprodout +
     &        afab(i0,nv)*
     &        bfab(i0,nv)
      enddo
      enddo
      return
      end


	FUNCTION PR_LTMP  ( thta, thte, pres )
C************************************************************************
C* PR_LTMP								*
C*									*
C* This function computes the temperature of a parcel lifted (or sunk)	*
C* adiabatically to a given pressure.					*
C*									*
C* REAL PR_LTMP  ( THTA, THTE, PRES )					*
C*									*
C* Input parameters:							*
C*	THTA		REAL	Potential temperature in Kelvin		*
C*	THTE		REAL	Equivalent potential temp in Kelvin	*
C*	PRES		REAL	Lifted pressure				*
C*									*
C* Output parameters:							*
C*	PR_LTMP		REAL	Lifted temperature in Celsius		*
C**									*
C* Log:									*
C* J. Nielsen/SUNYA	 8/90						*
C* T. Lee/GSC		 8/97	Computed temperature in Celsius		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	PR_LTMP = RMISSD
	IF  ( ERMISS (thta) .or. ERMISS (thte) .or. ERMISS (pres) )
     +	      RETURN
C
C*	Compute parcel temperatures on moist and dry adiabats.
C
	guess = 0.
	tmpe  = PR_TMST  ( thte, pres, guess )
	tmpd  = PR_TMPK  ( pres, thta )
	IF  ( ERMISS (tmpe) .or. ERMISS (tmpd) )  RETURN
C
C*	The correct parcel temperature is the warmer of the
C*	temperature on the dry adiabat and the temperature on the
C*	moist adiabat.
C
	IF  ( tmpe .gt. tmpd )  THEN
	    PR_LTMP = PR_TMKC (tmpe)
	  ELSE
	    PR_LTMP = PR_TMKC (tmpd)
	END IF
C*
	RETURN
	END