!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine ground_state
  use global_variables
  implicit none
  complex(8),allocatable :: za(:,:),zv(:,:)
  real(8) :: ar(Nx,Nx),ai(Nx,Nx),vr(Nx,Nx),vi(Nx,Nx)
  real(8) :: e(Nx)
  integer :: ix,jx,jx2,ik,ib
  real(8) :: ce,ve,s
!LAPACK ==
  integer :: lwork
  complex(8),allocatable :: work_lp(:)
  real(8),allocatable :: rwork(:),w(:)
  integer :: info

  lwork=6*Nx**2
  allocate(work_lp(lwork),rwork(3*Nx-2),w(Nx))
!LAPACK ==

  if(myrank == 0)write(*,"(A)")"!Start Electronic ground state calculation"
  Acx = 0d0
  allocate(za(Nx,Nx),zv(Nx,Nx))

  do ik=1,NK
    za=0d0
    do ix=1,Nx
      do jx=ix-2,ix+2
        jx2=jx
        if(jx<=0)jx2=Nx+jx
        if(jx>Nx)jx2=jx-Nx
        za(ix,jx2)=-0.5d0*(L_coef(jx-ix)+zI*2d0*Kx(ik)*G_coef(jx-ix))
      end do
      za(ix,ix)=za(ix,ix)+0.5d0*kx(ik)**2+Veff(ix)
    end do

    Call zheev('V', 'U', Nx, za, Nx, w, work_lp, lwork, rwork, info)

    do ib=1,NB
      s=sum(abs(za(:,ib))**2)*H
      zpsi_GS(:,ib,ik)=za(:,ib)/sqrt(s)
    end do

    do ib=1,NB
      spe(ib,ik)=w(ib)
    end do

  end do

  if(myrank == 0)then
    open(10,file=trim(filename)//'_gswf.out')
    do ix=1,Nx
      write(10,'(100e26.16E3)')Lx(ix),abs(zpsi_GS(ix,1,1))**2,abs(zpsi_GS(ix,1,Nk/2))**2 &
        ,abs(zpsi_GS(ix,2,1))**2,abs(zpsi_GS(ix,2,Nk/2))**2
    end do
    close(10)

    open(10,file=trim(filename)//'_band_map.out')
    do ik=1,NK
      write(10,'(100e26.16E3)')kx(ik),(spe(ib,ik),ib=1,NB)
    end do
    write(10,'(100e26.16E3)')-kx(1),(spe(ib,1),ib=1,NB)
    close(10)

    open(10,file=trim(filename)//'_pot.out')
    do ix=1,Nx
      write(10,'(100e26.16E3)')Lx(ix),Veff(ix)
    end do
    close(10)

    write(*,*)'Band gap       =',spe(2,NK)-spe(1,NK),(spe(2,NK)-spe(1,NK))*Ry*2d0

    write(*,"(A,2x,e26.16e3)")'Total energy =',2d0*sum(spe(1,:))/dble(NK)+E_ii
    write(*,"(A,2x,e26.16e3)")'Electronic energy =',2d0*sum(spe(1,:))/dble(NK)
    write(*,"(A,2x,e26.16e3)")'Ion-Ionc energy =',E_ii
    write(*,"(A,2x,e26.16e3)")'Band-gap (eV)=',2d0*Ry*(spe(2,1) - spe(1,1))

    write(*,"(A)")"!End Electronic ground state calculation"
  end if

  return
end subroutine ground_state
!-------10--------20--------30--------40--------50--------60--------70--------80--------90


c
       subroutine lfmm3d_ndiv(nd,eps,nsource,source,ifcharge,
     $    charge,ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,
     $    targ,ifpghtarg,pottarg,gradtarg,hesstarg,ndiv,idivflag,
     $    ifnear,timeinfo,ier)
c
c        Laplace FMM in R^{3}: evaluate all pairwise particle
c        interactions (ignoring self-interactions) and interactions
c        with targs.
c
c        We use (1/r) for the Green's function, without the
c        1/(4 \pi) scaling.
c
c
c        Input parameters:
c
c   nd:   number of densities
c
c   eps:  requested precision
c
c   nsource in: integer
c                number of sources
c
c   source  in: double precision (3,nsource)
c                source(k,j) is the kth component of the jth
c                source locations
c
c   ifcharge  in: integer
c             charge computation flag
c              ifcharge = 1   =>  include charge contribution
c                                     otherwise do not
c
c   charge    in: double precision (nsource)
c              charge strengths
c
c   ifdipole   in: integer
c              dipole computation flag
c              ifdipole = 1   =>  include dipole contribution
c                                     otherwise do not
c
c
c   dipvec   in: double precision (3,nsource)
c              dipole orientation vectors
c   iper    in: integer
c             flag for periodic implmentations. Currently unused
c   ifpgh   in: integer
c              flag for evaluating potential/gradient at the sources
c              ifpgh = 1, only potential is evaluated
c              ifpgh = 2, potential and gradients are evaluated
c
c   ntarg  in: integer
c                 number of targs
c
c   targ  in: double precision (3,ntarg)
c               targ(k,j) is the kth component of the jth
c               targ location
c
c   ifpghtarg   in: integer
c              flag for evaluating potential/gradient at the targs
c              ifpghtarg = 1, only potential is evaluated
c              ifpghtarg = 2, potential and gradient are evaluated
c
c
c     OUTPUT parameters:
c
c
c   pot:    out: double precision(nd,nsource)
c               potential at the source locations
c
c   grad:   out: double precision(nd,3,nsource)
c               gradient at the source locations
c
c   hess    out: double precision(nd,6,nsource)
c               hessian at the source locations
c                 (currently not supported)
c
c   pottarg:    out: double precision(nd,ntarg)
c               potential at the targ locations
c
c   gradtarg:   out: double precision(nd,3,ntarg)
c               gradient at the targ locations
c
c   hesstarg    out: double precision(nd,6,ntarg)
c                hessian at the target locations - currently not
c                supported
c   ier         out: integer
c                error flag
c                ier = 0, for successful execution
c                ier = 4, if failed to allocate workspace
c                      for multipole and local expansions
c                ier = 8, if failed to allocate workspace
c                      for plane wave expansions
c

       implicit none

       integer nd
       integer ier,iper

       double precision eps

       integer ifcharge,ifdipole
       integer ifpgh,ifpghtarg

       integer ntarg,nsource

       double precision source(3,*),targ(3,*)
       double precision charge(nd,*)
       double precision dipvec(nd,3,*)

       double precision pot(nd,*),grad(nd,3,*),hess(nd,6,*)
       double precision pottarg(nd,*),gradtarg(nd,3,*),hesstarg(nd,6,*)

       double precision timeinfo(6)

c
cc       tree variables
c
       integer idivflag,ndiv,nboxes,nlevels
       integer nlmax
       integer *8 ipointer(8),ltree
       integer ifunif,nlmin
       integer, allocatable :: itree(:)
       integer, allocatable :: isrcse(:,:),itargse(:,:),isrc(:)
       integer, allocatable :: itarg(:)
       integer, allocatable :: iexpcse(:,:)
       integer iexpc
       double precision, allocatable :: treecenters(:,:),boxsize(:)
       double precision b0,b0inv,b0inv2,b0inv3

c
cc       temporary sorted arrays
c
       double precision, allocatable :: sourcesort(:,:),targsort(:,:)
       double precision, allocatable :: radsrc(:)
       double precision, allocatable :: chargesort(:,:)
       double precision, allocatable :: dipvecsort(:,:,:)

       double precision, allocatable :: potsort(:,:),gradsort(:,:,:)
       double precision, allocatable :: hesssort(:,:,:)
       double precision, allocatable :: pottargsort(:,:)
       double precision, allocatable :: gradtargsort(:,:,:)
       double precision, allocatable :: hesstargsort(:,:,:)
c
cc        temporary fmm arrays
c
       integer, allocatable :: nterms(:)
       integer *8, allocatable :: iaddr(:,:)
       double precision, allocatable :: scales(:)
       double precision, allocatable :: rmlexp(:)

       integer lmptemp,nmax
       integer *8 lmptot
       double precision, allocatable :: mptemp(:),mptemp2(:)

c
cc       temporary variables not main fmm routine but
c        not used in particle code
       double precision expc(3),scjsort(1),radexp
       double complex texpssort(100)
       double precision expcsort(3)
       integer ntj,nexpc,nadd,ifnear

c
cc         other temporary variables
c
        integer i,iert,ifprint,ilev,idim
        double precision time1,time2,omp_get_wtime,second

c
c
c     ifprint is an internal information printing flag.
c     Suppressed if ifprint=0.
c     Prints timing breakdown and other things if ifprint=1.
c
      ifprint=0

       nexpc = 0
       nadd = 0
       ntj = 0

c
cc      set tree flags
c
       nlmax = 51
       nlevels = 0
       nboxes = 0
       ltree = 0
       nlmin = 0
       ifunif = 0
       iper = 0

c
cc     memory management code for contructing level restricted tree
      call pts_tree_mem(source,nsource,targ,ntarg,idivflag,ndiv,
     1  nlmin,nlmax,iper,ifunif,nlevels,nboxes,ltree)

        if(ifprint.ge.1) print *, ltree/1.0d9

        allocate(itree(ltree))
        allocate(boxsize(0:nlevels))
        allocate(treecenters(3,nboxes))

c       Call tree code
      call pts_tree_build(source,nsource,targ,ntarg,idivflag,ndiv,
     1  nlmin,nlmax,iper,ifunif,nlevels,nboxes,ltree,itree,ipointer,
     2  treecenters,boxsize)

      allocate(isrcse(2,nboxes),itargse(2,nboxes),iexpcse(2,nboxes))
      allocate(isrc(nsource),itarg(ntarg))

      call pts_tree_sort(nsource,source,itree,ltree,nboxes,nlevels,
     1   ipointer,treecenters,isrc,isrcse)

      call pts_tree_sort(ntarg,targ,itree,ltree,nboxes,nlevels,
     1   ipointer,treecenters,itarg,itargse)

      call pts_tree_sort(nexpc,expc,itree,ltree,nboxes,nlevels,
     1   ipointer,treecenters,iexpc,iexpcse)

c
c   End of tree build
c

c
c  Set rescaling parameters
c
      b0 = boxsize(0)
      b0inv = 1.0d0/b0
      b0inv2 = b0inv**2
      b0inv3 = b0inv2*b0inv

c     Allocate sorted source and targ arrays

      allocate(sourcesort(3,nsource))
      allocate(targsort(3,ntarg))
      if(ifcharge.eq.1) allocate(chargesort(nd,nsource))

      if(ifdipole.eq.1) then
         allocate(dipvecsort(nd,3,nsource))
      endif

      if(ifpgh.eq.1) then
        allocate(potsort(nd,nsource),gradsort(nd,3,1),hesssort(nd,6,1))
      else if(ifpgh.eq.2) then
        allocate(potsort(nd,nsource),gradsort(nd,3,nsource),
     1       hesssort(nd,6,1))
      else if(ifpgh.eq.3) then
        allocate(potsort(nd,nsource),gradsort(nd,3,nsource),
     1       hesssort(nd,6,nsource))
      else
        allocate(potsort(nd,1),gradsort(nd,3,1),hesssort(nd,6,1))
      endif

      if(ifpghtarg.eq.1) then
        allocate(pottargsort(nd,ntarg),gradtargsort(nd,3,1),
     1      hesstargsort(nd,6,1))
      else if(ifpghtarg.eq.2) then
        allocate(pottargsort(nd,ntarg),gradtargsort(nd,3,ntarg),
     1        hesstargsort(nd,6,1))
      else if(ifpghtarg.eq.3) then
        allocate(pottargsort(nd,ntarg),gradtargsort(nd,3,ntarg),
     1        hesstargsort(nd,6,ntarg))
      else
        allocate(pottargsort(nd,1),gradtargsort(nd,3,1),
     1     hesstargsort(nd,6,1))
      endif

c
cc      initialize potential and gradient at source
c       locations
c
      if(ifpgh.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)
        do i=1,nsource
          do idim=1,nd
            potsort(idim,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifpgh.eq.2) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)

        do i=1,nsource
          do idim=1,nd
            potsort(idim,i) = 0
            gradsort(idim,1,i) = 0
            gradsort(idim,2,i) = 0
            gradsort(idim,3,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifpgh.eq.3) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)
        do i=1,nsource
          do idim=1,nd
            potsort(idim,i) = 0
            gradsort(idim,1,i) = 0
            gradsort(idim,2,i) = 0
            gradsort(idim,3,i) = 0
            hesssort(idim,1,i) = 0
            hesssort(idim,2,i) = 0
            hesssort(idim,3,i) = 0
            hesssort(idim,4,i) = 0
            hesssort(idim,5,i) = 0
            hesssort(idim,6,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

c
cc       initialize potential and gradient  at targ
c        locations
c
      if(ifpghtarg.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)
        do i=1,ntarg
          do idim=1,nd
            pottargsort(idim,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifpghtarg.eq.2) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)
        do i=1,ntarg
          do idim=1,nd
            pottargsort(idim,i) = 0
            gradtargsort(idim,1,i) = 0
            gradtargsort(idim,2,i) = 0
            gradtargsort(idim,3,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifpghtarg.eq.3) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)
        do i=1,ntarg
          do idim=1,nd
            pottargsort(idim,i) = 0
            gradtargsort(idim,1,i) = 0
            gradtargsort(idim,2,i) = 0
            gradtargsort(idim,3,i) = 0
            hesstargsort(idim,1,i) = 0
            hesstargsort(idim,2,i) = 0
            hesstargsort(idim,3,i) = 0
            hesstargsort(idim,4,i) = 0
            hesstargsort(idim,5,i) = 0
            hesstargsort(idim,6,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      allocate(nterms(0:nlevels))

c     Compute length of expansions at each level
      nmax = 0
      do i=0,nlevels
         call l3dterms(eps,nterms(i))
         if(nterms(i).gt.nmax) nmax = nterms(i)
      enddo
c
c     Multipole and local expansions will be held in workspace
c     in locations pointed to by array iaddr(2,nboxes).
c
c     iaddr is pointer to iaddr array, itself contained in workspace.
c     imptemp is pointer for single expansion (dimensioned by nmax)
c
c       ... allocate iaddr and temporary arrays
c

      allocate(iaddr(2,nboxes))
      lmptemp = (nmax+1)*(2*nmax+1)*2*nd
      allocate(mptemp(lmptemp),mptemp2(lmptemp))

c
cc     reorder sources
c
      call dreorderf(3,nsource,source,sourcesort,isrc)

c
c       rescale sources to be contained in unit box
c
      call drescale(3*nsource,sourcesort,b0inv)

      if(ifcharge.eq.1) then
        call dreorderf(nd,nsource,charge,chargesort,
     1                     isrc)
        call drescale(nd*nsource,chargesort,b0inv)
      endif

      if(ifdipole.eq.1) then
         call dreorderf(3*nd,nsource,dipvec,dipvecsort,
     1       isrc)
         call drescale(3*nd*nsource,dipvecsort,b0inv2)
      endif

c
cc      reorder and rescale targs
c
      call dreorderf(3,ntarg,targ,targsort,itarg)
      call drescale(3*ntarg,targsort,b0inv)

c
c        update tree centers and boxsize
c
      call drescale(3*nboxes,treecenters,b0inv)
      call drescale(nlevels+1,boxsize,b0inv)

c
c     allocate memory need by multipole, local expansions at all
c     levels
c     irmlexp is pointer for workspace need by various fmm routines,
c
      call mpalloc(nd,itree(ipointer(1)),iaddr,nlevels,lmptot,nterms)
      if(ifprint.ge. 1) print *, "lmptot =",lmptot/1.0d9

      allocate(rmlexp(lmptot),stat=ier)
      ier = 0
      if(ier.ne.0) then
         print *, "Cannot allocate mpole expansion workspace"
         print *, "lmptot=", lmptot
         ier = 4
         return
      endif

c     Memory allocation is complete.
c     scaling factor for multipole and local expansions at all levels
c
      allocate(scales(0:nlevels))
      do ilev = 0,nlevels
        scales(ilev) = boxsize(ilev)
      enddo

c     Call main fmm routine

      call cpu_time(time1)
C$      time1=omp_get_wtime()
      call lfmm3dmain(nd,eps,
     $   nsource,sourcesort,
     $   ifcharge,chargesort,
     $   ifdipole,dipvecsort,
     $   ntarg,targsort,nexpc,expcsort,
     $   iaddr,rmlexp,lmptot,mptemp,mptemp2,lmptemp,
     $   itree,ltree,ipointer,ndiv,nlevels,
     $   nboxes,iper,boxsize,treecenters,isrcse,itargse,iexpcse,
     $   scales,itree(ipointer(1)),nterms,
     $   ifpgh,potsort,gradsort,hesssort,
     $   ifpghtarg,pottargsort,gradtargsort,hesstargsort,ntj,
     $   texpssort,scjsort,ifnear,timeinfo,ier)

      call cpu_time(time2)
C$        time2=omp_get_wtime()
      if( ifprint .eq. 1 ) call prin2('time in fmm main=*',
     1   time2-time1,1)

      if(ifpgh.ge.1) then
        call dreorderi(nd,nsource,potsort,pot,isrc)
      endif
      if(ifpgh.ge.2) then
        call dreorderi(3*nd,nsource,gradsort,grad,isrc)
        call drescale(nd*3*nsource,grad,b0inv)
      endif

      if(ifpgh.ge.3) then
        call dreorderi(6*nd,nsource,hesssort,hess,isrc)
        call drescale(nd*6*nsource,hess,b0inv2)
      endif

      if(ifpghtarg.ge.1) then
        call dreorderi(nd,ntarg,pottargsort,pottarg,itarg)
      endif

      if(ifpghtarg.ge.2) then
        call dreorderi(3*nd,ntarg,gradtargsort,gradtarg,itarg)
        call drescale(nd*3*ntarg,gradtarg,b0inv)
      endif

      if(ifpghtarg.ge.3) then
        call dreorderi(6*nd,ntarg,hesstargsort,hesstarg,itarg)
        call drescale(nd*6*ntarg,hesstarg,b0inv2)
      endif

      return
      end

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


Real Function fmassd(dmass)
  Save
  am0 = 1.232
  fmassd = am0*width(dmass)/((dmass**2-am0**2)**2+am0**2*width(dmass)**2)
  Return
End Function fmassd


module mod_random
! module for pseudo random numbers
 implicit none
 private
 public init_random_seed, randint, r4_uniform
 contains
 subroutine init_random_seed( )
  use iso_fortran_env, only: int64
  implicit none
  integer, allocatable :: seed(:)
  integer              :: i, n, un, istat, dt(8), pid
  integer(int64)       :: t
  call random_seed(size = n)
  allocate(seed(n))
  ! First try if the OS provides a random number generator
  open(newunit=un, file="/dev/urandom", access="stream", &
       form="unformatted", action="read", status="old", iostat=istat)
  if (istat == 0) then
     read(un) seed
     close(un)
  else
     ! Fallback to XOR:ing the current time and pid. The PID is
     ! useful in case one launches multiple instances of the same
     ! program in parallel.
     call system_clock(t)
     if (t == 0) then
        call date_and_time(values=dt)
        t = (dt(1) - 1970) * 365_int64 * 24 * 60 * 60 * 1000 &
             + dt(2) * 31_int64 * 24 * 60 * 60 * 1000 &
             + dt(3) * 24_int64 * 60 * 60 * 1000 &
             + dt(5) * 60 * 60 * 1000 &
             + dt(6) * 60 * 1000 + dt(7) * 1000 &
             + dt(8)
     end if
     pid = getpid()
     t = ieor(t, int(pid, kind(t)))
     do i = 1, n
        seed(i) = lcg(t)
     end do
  end if
  call random_seed(put=seed)
 contains
  ! This simple PRNG might not be good enough for real work, but is
  ! sufficient for seeding a better PRNG.
  function lcg(s)
    integer :: lcg
    integer(int64) :: s
    if (s == 0) then
       s = 104729
    else
       s = mod(s, 4294967296_int64)
    end if
    s = mod(s * 279470273_int64, 4294967291_int64)
    lcg = int(mod(s, int(huge(0), int64)), kind(0))
  end function lcg
 end subroutine init_random_seed
 integer function randint(i,j)
  integer,intent(in)    :: i,j
  real                  :: r
  call random_number(r)
  randint = i + floor((j+1-i)*r)
 end function randint
!
 real function r4_uniform(x,y)
  implicit none
  real,intent(in)       :: x,y
  real                  :: r
  call random_number(r)
  r4_uniform=(r*(y-x))+x
  return
 end function r4_uniform
end module mod_random

program cosa
 use mod_random
 implicit none
 integer :: i
 real    :: r1, r2
 call init_random_seed()
 r1 = r4_uniform(0.0,1.0)
 r2 = r4_uniform(0.0,1.0)
 write(6,*) r1,r2
 do i=1,1000000
  r2=r1
  r1 = r4_uniform(0.0,1.0)
  write(6,*) r1,r2
 end do
end program cosa


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c ... file shallow.f
c
c     program shallow solves the nonlinear shallow-water equations
c     on the sphere using spherepack software.
c
c ... required spherepack files
c
c     vtses.f, dives.f, vrtes.f, grades.f, sphcom.f, hrfft.f,
c     vhaes.f,vhses.f,shaes.f,shses.f
c

      program shallow
c
c     the nonlinear shallow-water equations on the sphere are
c     solved using a spectral method based on the spherical
c     vector harmonics. the method is described in the paper:
c
c [1] p. n. swarztrauber, spectral transform methods for solving
c     the shallow-water equations on the sphere, p.n. swarztrauber,
c     monthly weather review, vol. 124, no. 4, april 1996, pp. 730-744.
c
c     this program implements test case 3 (steady nonlinear rotated flow)
c     in the paper:
c
c [2] d.l. williamson, j.b. drake, j.j. hack, r. jakob, and
c     p.n. swarztrauber, j. comp. phys., a standard test set
c     for numerical approximations to the shallow-water
c     equations in spherical geometry, j. comp. phys.,
c     vol. 102, no. 1, sept. 1992, pp. 211-224.
c
c definitions:
c
c
c     nlat          number of latitudes including poles
c     nlon          number of distinct longitudes
c     mmode         max wave number
c     omega         rotation rate of earth in radians per second
c     aa            radius of earth in meters
c     pzero         mean height of geopotential
c     uzero         maximum velocity
c     alpha         tilt angle of the rotated grid
c     ncycle        cycle number
c     time          model time in seconds
c     dt            time step
c     lambda        longitude
c     theta         colatitude
c
c   the first dimension of the following two dimensional arrays
c   corresponds to the latitude index with values i=1,...,nlat
c   where i=1 is the north pole and i=nlat is the south pole.
c   the second dimension is longitude with values j=1,...,nlon
c   where j=1 corresponds to zero longitude and j=nlon corresponds
c   to 2pi minus 2pi/nlon.
c
c     u(i,j)       east longitudinal velocity component at t=time
c     v(i,j)       latitudinal velocity component at t=time
c     p(i,j)       +pzero = geopotential at t=time
c
c     unew(i,j)    east longitudinal velocity component at t=time+dt
c     vnew(i,j)    latitudinal velocity component at t=time+dt
c     pnew(i,j)    +pzero = geopotential at t=time+dt
c
c     uold(i,j)    east longitudinal velocity component at t=time-dt
c     vold(i,j)    latitudinal velocity component at t=time-dt
c     pold(i,j)    +pzero = geopotential at t=time-dt
c
c     divg(i,j)    divergence (d/dtheta (cos(theta) v)
c                                          + du/dlambda)/cos(theta)
c     vort(i,j)    vorticity  (d/dtheta (cos(theta) u)
c                                          - dv/dlambda)/cos(theta)
c
c     ut(i,j)      latitudinal derivative of longitudinal
c                  velocity component
c     vt(i,j)      latitudinal derivative of latitudinal
c                  velocity component
c
c     dudt(i,j)    time derivative of longitudinal velocity component
c     dvdt(i,j)    time derivative of latitudinal  velocity component
c     dpdt(i,j)    time derivative of geopotential
c
c     gpdl(i,j)    first component of the gradient of p(i,j)
c                  the longitudinal derivative of the geopotential
c                  divided by the cosine of the latitude
c
c     gpdt(i,j)    second component of the gradient of p(i,j)
c                  the latitudinal derivative of the geopotential
c
c     uxact(i,j)   the "exact" longitudinal veloctiy component
c     vxact(i,j)   the "exact" latitudinal  veloctiy component
c     uxact(i,j)   the "exact" geopotential
c
c     f(i,j)       the coriolis force on rotated grid
c
c   the following two dimensional arrays are nonzero in the triangle
c   n=1,...,nlat and m less than or equal to n.
c
c     a(m,n),b(m,n)    spectral coefficients of the geopotential
c
c     br(m,n),bi(m,n)  spectral coefficients of the velocity
c     cr(m,n),ci(m,n)  vector [u(i,j),v(i,j)]
c
c
c     phlt(i)      the coefficients in the cosine series
c                  representation of the unrotated geopotential
c
      parameter (idp=73,jdp=144,mdab=73,ndab=73)
      parameter(lldwork = 2*(idp+1))
c
      dimension u(idp,jdp),v(idp,jdp),p(idp,jdp),f(idp,jdp),
     1          unew(idp,jdp),vnew(idp,jdp),pnew(idp,jdp),
     2          uold(idp,jdp),vold(idp,jdp),pold(idp,jdp),
     3          uxact(idp,jdp),vxact(idp,jdp),pxact(idp,jdp),
     4          divg(idp,jdp),vort(idp,jdp),ut(idp,jdp),
     5          vt(idp,jdp),dudt(idp,jdp),dvdt(idp,jdp),
     6          dpdt(idp,jdp),gpdt(idp,jdp),gpdl(idp,jdp),
     7          a(mdab,ndab),b(mdab,ndab),br(mdab,ndab),
     8          bi(mdab,ndab),cr(mdab,ndab),ci(mdab,ndab),
     9          phlt(361)
c
c   the following work arrays are initialized and subsequently
c   used repeatedly by spherepack routines.
c
      dimension wsha(70928),wshs(70928),wvha(141647),wvhs(141647),
     1          wvts(141647),work(40000)
      double precision dwork(lldwork)
c
      real lambda,lhat

      lwsha = 70928
      lwshs = 70928
      lwvha = 141647
      lwvhs = 141647
      lwvts = 141647
      lwork = 40000
      ldwork = lldwork
      pi = 4.*atan(1.)
      hpi = pi/2.
      dtr = pi/180.
      aa = 6.37122e6
      omega = 7.292e-5
      fzero = omega+omega
      uzero = 40.
      pzero = 2.94e4
      alphad = 60.
      alpha = dtr*alphad
c
      itmax = 720
      mprint = 72
      mmode = 42
      nlat = 65
      nlon = 128
      dt = 600.
      tdt = dt+dt
c
c     initialize spherepack routines
c
      call shaesi(nlat,nlon,wsha,lwsha,work,lwork,dwork,lwork,ierror)
      if(ierror .ne. 0) write(*,55) ierror
   55 format(' error' i4 ' in shaesi')
      call shsesi(nlat,nlon,wshs,lwshs,work,lwork,dwork,ldwork,ierror)
      if(ierror .ne. 0) write(*,56) ierror
   56 format(' error' i4 ' in shsesi')
      call vhaesi(nlat,nlon,wvha,lwvha,work,lwork,dwork,ldwork,ierror)
      if(ierror .ne. 0) write(*,57) ierror
   57 format(' error' i4 ' in vhaesi')
      call vhsesi(nlat,nlon,wvhs,lwvhs,work,lwork,dwork,ldwork,ierror)
      if(ierror .ne. 0) write(*,58) ierror
   58 format(' error' i4 ' in vhsesi')
      call vtsesi(nlat,nlon,wvts,lwvts,work,lwork,dwork,ldwork,ierror)
      if(ierror .ne. 0) write(*,59) ierror
   59 format(' error' i4 ' in vtsesi')
c
c
c     compute the derivative of the unrotated geopotential
c             p as a function of latitude
c
      nl = 91
      nlm1 = nl-1
      nlm2 = nl-2
      cfn = 1./nlm1
      dlath = pi/nlm1
      do 10 i=1,nlm2
      theta = i*dlath
      sth = sin(theta)
      cth = cos(theta)
      uhat = ui(uzero,hpi-theta)
      phlt(i) = cfn*cth*uhat*(uhat/sth+aa*fzero)
   10 continue
c
c     compute sine transform of the derivative of the geopotential
c     for the purpose of computing the geopotential by integration
c     see equation (3.9) in reference [1] above
c
      call sine(nlm2,phlt,work)
c
c     compute the cosine coefficients of the unrotated geopotential
c     by the formal integration of the sine series representation
c
      do 12 i=1,nlm2
      phlt(i) = -phlt(i)/i
   12 continue
c
c     phlt(i) contains the coefficients in the cosine series
c     representation of the unrotated geopotential that are used
c     below to compute the geopotential on the rotated grid.
c
c     compute the initial values of  east longitudinal
c     and latitudinal velocities u and v as well as the
c     geopotential p and coriolis f on the rotated grid.
c
      ca = cos(alpha)
      sa = sin(alpha)
      dtheta = pi/(nlat-1)
      dlam = (pi+pi)/nlon
      do 50 j=1,nlon
      lambda = (j-1)*dlam
      cl = cos(lambda)
      sl = sin(lambda)
      do 50 i=1,nlat
c
c     lambda is longitude, theta is colatitude, and pi/2-theta is
c     latitude on the rotated grid. lhat and that are longitude
c     and colatitude on the unrotated grid. see text starting at
c     equation (3.10)
c
      theta = (i-1)*dtheta
      st = cos(theta)
      ct = sin(theta)
      sth = ca*st+sa*ct*cl
      cthclh = ca*ct*cl-sa*st
      cthslh = ct*sl
      lhat = atanxy(cthclh,cthslh)
      clh = cos(lhat)
      slh = sin(lhat)
      cth = clh*cthclh+slh*cthslh
      that = atanxy(sth,cth)
      uhat = ui(uzero,hpi-that)
      pxact(i,j) = cosine(that,nlm2,phlt)
      uxact(i,j) = uhat*(ca*sl*slh+cl*clh)
      vxact(i,j) = uhat*(ca*cl*slh*st-clh*sl*st+sa*slh*ct)
      f(i,j) = fzero*sth
   50 continue
c
      vmax = 0.
      pmax = 0.
      v2max = 0.
      p2max = 0.
      do 54 j=1,nlon
      do 54 i=1,nlat
      v2max = v2max+uxact(i,j)**2+vxact(i,j)**2
      p2max = p2max+pxact(i,j)**2
      vmax = amax1(abs(uxact(i,j)),abs(vxact(i,j)),vmax)
      pmax = amax1(abs(pxact(i,j)),pmax)
 54   continue
c
c     initialize first time step
c
      do 60 j=1,nlon
      do 60 i=1,nlat
      u(i,j) = uxact(i,j)
      v(i,j) = vxact(i,j)
      p(i,j) = pxact(i,j)
   60 continue
c
      isym = 0
      nt = 1
      time = 0.
      ctime = 0.
      ncycle = 0
c
c     start of the time loop
c
c   begin step 1, section 3
c
c     analyze the velocity components (u,v)
c
   90 call vhaesgo(nlat,nlon,isym,nt,u,v,idp,jdp,br,bi,cr,ci,
     1           mdab,ndab,wvha,lwvha,work,lwork,ierror)
      if(ierror .ne. 0) write(*,91) ierror
   91 format(' error' i4 ' in vhaes')
c
c     truncate spectrum to eliminate aliasing of the
c     product terms in the shallow-water equations
c
      call trunc(nlat,mmode,mdab,br,bi)
      call trunc(nlat,mmode,mdab,cr,ci)
c
c     resynthesize the velocity components
c
      call vhsesgo(nlat,nlon,isym,nt,u,v,idp,jdp,br,bi,cr,ci,
     1           mdab,ndab,wvhs,lwvhs,work,lwork,ierror)
      if(ierror .ne. 0) write(*,92) ierror
   92 format(' error' i4 ' in vhses')
c
c   begin step 2, section 3
c
c     analyze geopotential p
c
      call shaes(nlat,nlon,isym,nt,p,idp,jdp,a,b,mdab,ndab,
     1                    wsha,lwsha,work,lwork,ierror)
      if(ierror .ne. 0) write(*,93) ierror
   93 format(' error' i4 ' in shaes')
c
c     truncate spectrum to eliminate aliasing of the
c     product terms in the shallow-water equations
c
      call trunc(nlat,mmode,mdab,a,b)
c
c     resynthesize the geopotential p
c
      call shses(nlat,nlon,isym,nt,p,idp,jdp,a,b,mdab,ndab,
     1                    wshs,lwshs,work,lwork,ierror)
      if(ierror .ne. 0) write(*,94) ierror
   94 format(' error' i4 ' in shses')
c
c
c   begin step 3, section 3
c
c     compute the vorticity of the velocity (u,v)
c
      call vrtes(nlat,nlon,isym,nt,vort,idp,jdp,cr,ci,mdab,ndab,
     1                 wshs,lwshs,work,lwork,ierror)
      if(ierror .ne. 0) write(*,95) ierror
   95 format(' error' i4 ' in vrtes')
c
c     compute the divergence of the velocity (u,v)
c
      call dives(nlat,nlon,isym,nt,divg,idp,jdp,br,bi,mdab,ndab,
     1           wshs,lwshs,work,lwork,ierror)
      if(ierror .ne. 0) write(*,96) ierror
   96 format(' error' i4 ' in dives')
c
c   begin step 4, section 3
c
c     compute the derivative of the velocity (u,v) with
c     respect to colatitude theta.
c
      call vtsesgo(nlat,nlon,isym,nt,ut,vt,idp,jdp,br,bi,cr,ci,
     1           mdab,ndab,wvts,lwvts,work,lwork,ierror)
      if(ierror .ne. 0) write(*,97) ierror
   97 format(' error' i4 ' in vtsesgo')
c
c   begin step 5, section 3
c
c     compute the gradient of the geopotential p
c
      call gradesgo(nlat,nlon,isym,nt,gpdl,gpdt,idp,jdp,a,b,mdab,ndab,
     1wvhs,lwvhs,work,lwork,ierror)
      if(ierror .ne. 0) write(*,98) ierror
   98 format(' error' i4 ' in grades')
c
c     compute the time derivatives of the velocity (u,v)
c     and the geopotential p using the shallow-water
c     equations (2.8), (2.9), and (2.10), section 3.
c
      do 200 j=1,nlon
      do 200 i=1,nlat
      dudt(i,j) = (u(i,j)*(vt(i,j)-divg(i,j))-v(i,j)*ut(i,j)
     1            -gpdl(i,j))/aa+f(i,j)*v(i,j)
      dvdt(i,j) = -(u(i,j)*(vort(i,j)+ut(i,j))+v(i,j)*vt(i,j)
     1            +gpdt(i,j))/aa-f(i,j)*u(i,j)
      dpdt(i,j) = -((p(i,j)+pzero)*divg(i,j)+v(i,j)*gpdt(i,j)
     1             +u(i,j)*gpdl(i,j))/aa
  200 continue
c
      if(mod(ncycle,mprint) .ne. 0) go to 370
      htime = time/3600.
      write(*,390) ncycle,htime,dt,nlat,nlon,mmode,omega,pzero,
     1             uzero,alphad
  390 format(//' steady nonlinear rotated flow, test case 3'/
     1         ' cycle number              ' i10
     2         ' model time in  hours      ' f10.2/
     3         ' time step in seconds      ' f10.0
     4         ' number of latitudes       ' i10/
     5         ' number of longitudes      ' i10
     6         ' max wave number           ' i10/
     7         ' rotation rate        ' 1pe15.6
     8         ' mean height          ' 1pe15.6/
     9         ' maximum velocity     ' 1pe15.6
     1         ' tilt angle                ' f10.2)
      dvgm = 0.
      dvmax = 0.
      dpmax = 0.
      evmax = 0.0
      epmax = 0.0
      do 217 j=1,nlon
      do 217 i=1,nlat
      dvgm = amax1(dvgm,abs(divg(i,j)))
      dvmax = dvmax+(u(i,j)-uxact(i,j))**2+(v(i,j)-vxact(i,j))**2
      dpmax = dpmax+(p(i,j)-pxact(i,j))**2
      evmax = amax1(evmax,abs(v(i,j)-vxact(i,j)),abs(u(i,j)-uxact(i,j)))
      epmax = amax1(epmax,abs(p(i,j)-pxact(i,j)))
  217 continue
      dvmax = sqrt(dvmax/v2max)
      dpmax = sqrt(dpmax/p2max)
      evmax = evmax/vmax
      epmax = epmax/pmax
      write(*,391) evmax,epmax,dvmax,dpmax,dvgm
  391 format(' max error in velocity' 1pe15.6
     +       ' max error in geopot. ' 1pe15.6/
     +       ' l2 error in velocity ' 1pe15.6
     +       ' l2 error in geopot.  ' 1pe15.6/
     +       ' maximum divergence   ' 1pe15.6)
c
c     set values at time = -dt to values at time = 0.
c
  370 if(ncycle .gt. 0) go to 206
      do 205 j=1,nlon
      do 205 i=1,nlat
      uold(i,j) = u(i,j)
      vold(i,j) = v(i,j)
      pold(i,j) = p(i,j)
  205 continue
c
c     compute values at next time level using leap frog
c     time differencing
c
  206 do 210 j=1,nlon
      do 210 i=1,nlat
      unew(i,j) = uold(i,j)+tdt*dudt(i,j)
      vnew(i,j) = vold(i,j)+tdt*dvdt(i,j)
      pnew(i,j) = pold(i,j)+tdt*dpdt(i,j)
  210 continue
c
c     update values to next time level
c
      do 300 j=1,nlon
      do 300 i=1,nlat
      uold(i,j) = u(i,j)
      vold(i,j) = v(i,j)
      pold(i,j) = p(i,j)
      u(i,j) = unew(i,j)
      v(i,j) = vnew(i,j)
      p(i,j) = pnew(i,j)
  300 continue
      ncycle = ncycle+1
      time = time+dt
      if(ncycle .le. itmax) go to 90
      end

      subroutine vtsesgo(nlat,nlon,ityp,nt,ut,vt,idvw,jdvw,br,bi,cr,ci,
     1           mdab,ndab,wvts,lwvts,work,lwork,ierror)
c
c     vtsesgo computes the latitudinal derivatives of the
c     velocity components using subroutine vtses which
c     assumes the velocity components are given in terms
c     of mathematical coordinates
c
      dimension ut(idvw,jdvw,1),vt(idvw,jdvw,1),br(mdab,ndab,1),
     1          bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1),
     2          work(*),wvts(*)
      call vtses(nlat,nlon,ityp,nt,vt,ut,idvw,jdvw,br,bi,cr,ci,
     1           mdab,ndab,wvts,lwvts,work,lwork,ierror)
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	    ut(i,j,k) = -ut(i,j,k)
	  end do
	end do
      end do
      return
      end
c
      function ui(amp,thetad)
c
c     computes the initial unrotated longitudinal velocity
c     see section 3.3.
c
      pi=4.*atan(1.)
      thetab=-pi/6.
      thetae= pi/2.
      xe=3.e-1
      x =xe*(thetad-thetab)/(thetae-thetab)
      ui = 0.
      if(x.le.0. .or. x.ge.xe) return
      ui=amp*exp(-1./x-1./(xe-x)+4./xe)
      return
      end
c
      function atanxy(x,y)
      atanxy = 0.
      if(x.eq.0. .and. y.eq.0.) return
      atanxy = atan2(y,x)
      return
      end
      subroutine sine(n,x,w)
c
c     computes the sine transform
c
      dimension x(n),w(n)
      arg = 4.*atan(1.)/(n+1)
      do 10 j=1,n
      w(j) = 0.
      do 10 i=1,n
      w(j) = w(j)+x(i)*sin(i*j*arg)
   10 continue
      do 15 i=1,n
      x(i) = 2.*w(i)
   15 continue
      return
      end
c
      function cosine(theta,n,cf)
c
c     computes the cosine transform
c
      dimension cf(n)
      cosine = 0.
      do 10 i=1,n
      cosine = cosine+cf(i)*cos(i*theta)
   10 continue
      return
      end
c
      subroutine trunc(nm,ms,id,a,b)
c
c     truncates spectral coefficients so that aliasing
c     does not occur when computing the spectral representations
c     of the product terms.
c
      dimension a(id,1),b(id,1)
      mp = ms+2
      do 10 n=mp,nm
      do 10 m=1,n
      a(m,n) = 0.
      b(m,n) = 0.
   10 continue
      return
      end

      subroutine vhaesgo(nlat,nlon,ityp,nt,u,v,iduv,jduv,
     +br,bi,cr,ci,mdab,ndab,wsav,lwsav,work,lwork,ierror)
      dimension u(iduv,jduv,*),v(iduv,jduv,*),br(mdab,ndab,*),
     +          bi(mdab,ndab,*),cr(mdab,ndab,*),ci(mdab,ndab,*),
     2          work(1),wsav(1)
c
c     vhaesgo computes the vector harmonic analysis of (u,v) using vhaes which
c     assumes the velocity components are given in mathematical coordinates
c
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	    v(i,j,k) = -v(i,j,k)
	  end do
	end do
      end do
      call vhaes(nlat,nlon,ityp,nt,v,u,iduv,jduv,
     +br,bi,cr,ci,mdab,ndab,wsav,lwsav,work,lwork,ierror)
c
c     restore v
c
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	    v(i,j,k) = -v(i,j,k)
	  end do
	end do
      end do
      if (ierror.ne.0) return
      return
      end

      subroutine vhsesgo(nlat,nlon,ityp,nt,u,v,iduv,jduv,
     +br,bi,cr,ci,mdab,ndab,wsav,lwsav,work,lwork,ierror)
      dimension u(iduv,jduv,*),v(iduv,jduv,*),br(mdab,ndab,*),
     +          bi(mdab,ndab,*),cr(mdab,ndab,*),ci(mdab,ndab,*),
     2          work(1),wsav(1)
c
c     vhsesgo computes a vector harmonic synthesis in (u,v) using vhses which
c     assumes the velocity components are given in mathematical coordinates
c
      call vhses(nlat,nlon,ityp,nt,v,u,iduv,jduv,
     +br,bi,cr,ci,mdab,ndab,wsav,lwsav,work,lwork,ierror)
      if (ierror.ne.0) return
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	    v(i,j,k) = -v(i,j,k)
	  end do
	end do
      end do
      return
      end

      subroutine gradesgo(nlat,nlon,isym,nt,u,v,iduv,jduv,a,b,
     +mdab,ndab,wsav,lwsav,work,lwork,ierror)
      dimension u(iduv,jduv,nt),v(iduv,jduv,nt)
      dimension a(mdab,ndab,nt),b(mdab,ndab,nt)
      dimension wsav(lwsav),work(lwork)
c
c     gradesgo computes the gradient in (u,v) using grades which assumes
c     the velocity components are given in mathematical coordinates
c
      call grades(nlat,nlon,isym,nt,v,u,iduv,jduv,a,b,
     +mdab,ndab,wsav,lwsav,work,lwork,ierror)
      if (ierror .ne.0) return
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	    v(i,j,k) = -v(i,j,k)
	  end do
	end do
      end do
      return
      end


c=======================================================================
c
c     subroutine QL
c
c     Quadratic solver (vectorized version)
c
c     MINIMIZE        .5*X'*Q*X + P'*X
c     SUBJECT TO      A(I)*X   =  B(I)    ,  I=1,...,nceg
c                     A(J)*X  <=  B(J)    ,  J=1,...,ncineg
c                     Cinf  <=  X  <=  Csup
c
c-----------------------------------------------------------------------
      SUBROUTINE ql ( N, Q, P, nceg, ncineg, A, B, Cinf, Csup,
     &                iwork, dwork,
     &                lagr, wopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       N      : number of variables                             integer
c       Q      : quadratic matrix (N*N)                           double
c       P      : linear part vector (N)                           double
c       A      : matrix of constraints (N*(nceg+ncineg))          double
c       B      : vector of constraints (nceg+ncineg)              double
c       Cinf   : lower bounds vector (N)                          double
c       Csup   : upper bounds vector (N)                          double
c       nceg   : number of equality constraints                  integer
c       ncineg : number of inequality constraints                integer
c
c     WORKSPACE
c       iwork  : N                                               integer
c       dwork  : (3*N*N)/2 + 10*N + 2*(nceg + ncineg + 1)
c                 + 2*N*(nceg + ncineg)                           double
c
c     OUTPUT
c       lagr   : Lagrange multipliers (2*N+ncineg+nceg)           double
c       wopt   : optimal solution vector (N)                      double
c       info   : diagnostic argument                             integer
c
c-------------------------------------------------------------------------------
c     USED FUNCTION
c
c     From rne/optim/ directory:
c     ql0001.f
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER N, nceg, ncineg, info
      DOUBLE PRECISION Q(N,*), wopt(*), P(*), lagr(*),
     &                 Cinf(*), Csup(*), A(N,*), B(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER M, ME, MMAX,NMAX, MNN, IOUT, IFAIL, IPRINT, LWAR, LIWAR,
     &        pd1, pd2, pdwork
      DOUBLE PRECISION EPS, ONE
      PARAMETER (ONE = -1.E0)
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
      M    = nceg + ncineg    ! total number of constraints
      ME   = nceg             ! number of equality constraints
      MMAX = M                ! row dimension of A (constraint matrix)
      NMAX = N                ! row dimension of Q (quadratic part)
      MNN  = M + N + N        ! dimension of Lagrange multipliers
      IOUT   = 1              ! desired output
      IPRINT = 1              ! output control (=0 no output)
      EPS =  2.2204e-16       ! termination accuracy
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pd1 = 1
c     pd1 : temporary constraint matrix (N*M)
      pd2  = pd1 + ( N*M )
c     pd2 :  temporary constraint matrix (N*M)
      pdwork = pd2 + ( N*M )
c
c     Total size of dwork array = (3/2)*N*N + 10*N
c                               + 2*(nceg + ncineg + 1)
c                               + 2*N*(nceg + ncineg)
c
      LWAR   = (3*NMAX*NMAX)/2 + 10*NMAX + 2*(MMAX + 1)
      LIWAR  = N
c----------------------------------------------------------------------------
c
c     Cholesky decomposition internally computed
      iwork(1)=1
c
c     transform matrix constraint A -> -A'
      CALL RM ( N, M, A, dwork(pd1) )
      CALL PMX ( M, N, dwork(pd1), ONE, dwork(pd2) )
c
c     QL Solver
c
c     MINIMIZE        .5*X'*C*X + D'*X
c     SUBJECT TO      A(J)*X  +  B(J)   =  0 ,  J=1,...,ME
c                     A(J)*X  +  B(J)  >=  0 ,  J=ME+1,...,M
c                     XL  <=  X  <=  XU
c
      CALL ql0001(M, ME, MMAX, N, NMAX, MNN,
     &            Q, P, dwork(pd2), B, Cinf, Csup,
     &            wopt, lagr, IOUT, IFAIL, IPRINT,
     &            dwork(pdwork), LWAR, iwork, LIWAR, EPS)
c
c     error management
      IF (IFAIL .EQ. 0)  info = 0     ! optimality conditions satisfied
      IF (IFAIL .EQ. 1)  info =  1007 ! max. nb. iterations exceeded
      IF (IFAIL .EQ. 2)  info = -1008 ! accuracy insufficient
      IF (IFAIL .EQ. 3)  info = -1    ! division by zero
      IF (IFAIL .EQ. 5)  info = -1009 ! lenght of work. array too short
      IF (IFAIL .GT. 10) info = -1010 ! inconsistent constraints
c
      RETURN
      END


!==========================================================================
elemental subroutine gsw_t_freezing_first_derivatives (sa, p, &
                            saturation_fraction, tfreezing_sa, tfreezing_p)
!==========================================================================
!
!  Calculates the frist derivatives of the in-situ temperature at which
!  seawater freezes with respect to Absolute Salinity SA and pressure P (in
!  Pa).  These expressions come from differentiating the expression that
!  defines the freezing temperature, namely the equality between the
!  chemical potentials of water in seawater and in ice.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!  saturation_fraction = the saturation fraction of dissolved air in
!                        seawater
!
!  tfreezing_SA = the derivative of the in-situ freezing temperature
!                 (ITS-90) with respect to Absolute Salinity at fixed
!                 pressure                     [ K/(g/kg) ] i.e. [ K kg/g ]
!
!  tfreezing_P  = the derivative of the in-situ freezing temperature
!                 (ITS-90) with respect to pressure (in Pa) at fixed
!                 Absolute Salinity                                [ K/Pa ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_t_deriv_chem_potential_water_t_exact
use gsw_mod_toolbox, only : gsw_specvol_ice, gsw_dilution_coefficient_t_exact
use gsw_mod_toolbox, only : gsw_entropy_ice, gsw_t_freezing_exact, gsw_gibbs
use gsw_mod_toolbox, only : gsw_specvol_t_exact

use gsw_mod_teos10_constants, only : gsw_sso

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p, saturation_fraction
real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p

real (r8) :: rec_denom, tf

real (r8), parameter :: g_per_kg = 1000.0_r8

tf = gsw_t_freezing_exact(sa,p,saturation_fraction)
rec_denom = 1.0_r8/(g_per_kg*gsw_t_deriv_chem_potential_water_t_exact(sa,tf,p) &
                  + gsw_entropy_ice(tf,p))

if (present(tfreezing_sa)) tfreezing_sa = &
               gsw_dilution_coefficient_t_exact(sa,tf,p)*rec_denom &
               + saturation_fraction*(1e-3_r8)/(2.0_r8*gsw_sso)

if (present(tfreezing_p)) tfreezing_p = &
               -(gsw_specvol_t_exact(sa,tf,p) - sa*gsw_gibbs(1,0,1,sa,tf,p) &
               - gsw_specvol_ice(tf,p))*rec_denom

return
end subroutine

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


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_boxdim
CONTAINS
   SUBROUTINE boxdim( &
      bmat, &
      arltv1, arltv2, arltv3)
!*********************************************************************
!      This subroutine determines the maximum number L, M and N
!      nrgvl, nrgvm, nrgvn, of reciprocal lattice vectors G(L,M,N)
!      along the directions G(1), G(2), G(3), respectively, for which

!                     | G(L,M,N) | <= GMAX.

!      This equation defines a "sphere" and the nrgvl,m,n define
!      the DIMension of the BOX in which the sphere is placed.

!      In reality the G(i)'s, do not form a carteasian coordinate
!      system. Therefore the "sphere" is not a sphere, but an
!      ellipsoid. For this ellipsoid the largest L, M and N component
!      is determined as arltv1, arltv2, arltv3 to construct the boxes and

!                    nrgvl  = int( gmax/arltv1 ) + 1
!                    nrgvm  = int( gmax/arltv2 ) + 1
!                    nrgvn  = int( gmax/arltv3 ) + 1

!      G(i,xyz) is stored in bmat(i,xyz)

!      routine by s.bluegel from carpar-program

!                         S. Bl"ugel, IFF, 13. Nov. 97
!               tested by S. Heinze , IFF,
!*********************************************************************
      USE m_juDFT
! SE m_constants

!     .. Parameters ..
      IMPLICIT NONE

!     .. Scalar Arguments ..
      REAL, INTENT(OUT) :: arltv1, arltv2, arltv3
!     ..
!     .. Array Arguments ..
      REAL, INTENT(IN)  :: bmat(3, 3)
!     ..
!     .. Local Scalars ..
      INTEGER :: ixyz, j, k
      REAL ::    denom, eps, one, zero
!     ..
!     .. Local Arrays ..
      REAL :: det(3, 3), rr(3, 3)
!     ..
      DATA one, eps, zero/1.0, 1e-10, 0.0/

!--->  build up quadratic form for ellipsoid

      DO j = 1, 3
         DO k = 1, 3
            rr(k, j) = zero
            DO ixyz = 1, 3
               rr(k, j) = rr(k, j) + bmat(k, ixyz)*bmat(j, ixyz)
            ENDDO
         ENDDO
      ENDDO

!---> build determinants for Cramer's rule

      det(1, 1) = rr(2, 2)*rr(3, 3) - rr(3, 2)*rr(2, 3)
      det(1, 2) = rr(2, 1)*rr(3, 3) - rr(3, 1)*rr(2, 3)
      det(1, 3) = rr(2, 1)*rr(3, 2) - rr(3, 1)*rr(2, 2)
      det(2, 1) = rr(1, 2)*rr(3, 3) - rr(3, 2)*rr(1, 3)
      det(2, 2) = rr(1, 1)*rr(3, 3) - rr(3, 1)*rr(1, 3)
      det(2, 3) = rr(1, 1)*rr(3, 2) - rr(3, 1)*rr(1, 2)
      det(3, 1) = rr(1, 2)*rr(2, 3) - rr(2, 2)*rr(1, 3)
      det(3, 2) = rr(1, 1)*rr(2, 3) - rr(2, 1)*rr(1, 3)
      det(3, 3) = rr(1, 1)*rr(2, 2) - rr(2, 1)*rr(1, 2)

!---> check on the zeros of some determinants

      DO j = 1, 3
         IF (det(j, j) < eps) THEN
            CALL juDFT_error(" oxdim: determinant. Problem with det(" &
                             //int2str(j) // ","//int2str(j) // ")", calledby="boxdim")
         END IF
      ENDDO

!---> scale determinants

      DO k = 1, 3
         denom = one/det(k, k)
         DO j = 1, 3
            det(k, j) = denom*det(k, j)
         ENDDO
         det(k, k) = one/denom
      ENDDO

!---> calculate the maximum l, m, n components of the ellipsoid

      arltv1 = sqrt(rr(1, 1) + rr(2, 2)*det(1, 2)*det(1, 2) &
                    + rr(3, 3)*det(1, 3)*det(1, 3) &
                    - (rr(1, 2) + rr(1, 2))*det(1, 2) &
                    + (rr(1, 3) + rr(1, 3))*det(1, 3) &
                    - (rr(2, 3) + rr(2, 3))*det(1, 2)*det(1, 3))
      arltv2 = sqrt(rr(2, 2) + rr(1, 1)*det(2, 1)*det(2, 1) &
                    + rr(3, 3)*det(2, 3)*det(2, 3) &
                    - (rr(1, 2) + rr(1, 2))*det(2, 1) &
                    + (rr(1, 3) + rr(1, 3))*det(2, 1)*det(2, 3) &
                    - (rr(2, 3) + rr(2, 3))*det(2, 3))
      arltv3 = sqrt(rr(3, 3) + rr(1, 1)*det(3, 1)*det(3, 1) &
                    + rr(2, 2)*det(3, 2)*det(3, 2) &
                    - (rr(1, 2) + rr(1, 2))*det(3, 1)*det(3, 2) &
                    + (rr(1, 3) + rr(1, 3))*det(3, 1) &
                    - (rr(2, 3) + rr(2, 3))*det(3, 2))

      RETURN
   end SUBROUTINE boxdim
end module m_boxdim


	SUBROUTINE SCUDDER(V,CURDENS)
C
C	CALCULATES PHOTOEMISSION IN AMP/ M**2 ACCORDING TO SCUDDER,CAO
C		AND MOZER
C
C	DATA AA,TPHI1,CC,TPHI2/ 405., 1.45, 1.75, 8.4/  ! joint prob
C	DATA AA,TPHI1,CC,TPHI2/ 154., 1.45, 1.75, 8.4/  !error corrected
	DATA AA,TPHI1,CC,TPHI2/ 152., 1.70, 0.86, 9.5/  ! april 2000
C	DATA AA,TPHI1,CC,TPHI2/ 102., 1.46, 1.37, 8.42/  ! joint prob*
C
	CURDENS = 1.E-6*(AA*EXP(-V/TPHI1) + CC*EXP(-V/TPHI2))  !genuine
C	CURDENS = 1.E-7*(AA*EXP(-V/TPHI1) + CC*EXP(-V/TPHI2))  ! fake
	RETURN
	END


*     MB03LF EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER            NIN, NOUT
      PARAMETER          ( NIN = 5, NOUT = 6 )
      INTEGER            NMAX
      PARAMETER          ( NMAX = 50 )
      INTEGER            LDB, LDFG, LDQ, LDU, LDWORK, LDZ, LIWORK
      PARAMETER          ( LDB = NMAX/2, LDFG = NMAX/2, LDQ = 2*NMAX,
     $                     LDU = NMAX,   LDZ  = NMAX,
     $                     LDWORK = 10*NMAX*NMAX +
     $                              MAX( NMAX*NMAX +
     $                                   MAX( NMAX/2 + 252, 432 ),
     $                                   MAX( 8*NMAX +  48, 171 ) ),
     $                     LIWORK = MAX( NMAX + 18, NMAX/2 + 48,
     $                                   5*NMAX/2 + 1 ) )
*
*     .. Local Scalars ..
      CHARACTER          COMPQ, COMPU, ORTH
      INTEGER            I, INFO, IWARN, J, M, N, NEIG
*
*     .. Local Arrays ..
      LOGICAL            BWORK( NMAX/2 )
      INTEGER            IWORK( LIWORK )
      DOUBLE PRECISION   ALPHAI( NMAX/2 ),  ALPHAR( NMAX/2 ),
     $                   B( LDB, NMAX/2 ),    BETA( NMAX/2 ),
     $                   DWORK( LDWORK ), FG( LDFG, NMAX/2+1 ),
     $                   Q( LDQ, 2*NMAX ),  U( LDU, 2*NMAX ),
     $                   Z( LDZ, NMAX )
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*
*     .. External Subroutines ..
      EXTERNAL           MB03LF
*
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MOD
*
*     .. Executable Statements ..
*
      WRITE( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ( NIN, FMT = * )
      READ( NIN, FMT = * ) COMPQ, COMPU, ORTH, N
      IF( N.LT.0 .OR. N.GT.NMAX .OR. MOD( N, 2 ).NE.0 ) THEN
         WRITE( NOUT, FMT = 99998 ) N
      ELSE
         M = N/2
         READ( NIN, FMT = * ) ( (  Z( I, J ), J = 1, N   ), I = 1, N )
         READ( NIN, FMT = * ) ( (  B( I, J ), J = 1, M   ), I = 1, M )
         READ( NIN, FMT = * ) ( ( FG( I, J ), J = 1, M+1 ), I = 1, M )
*        Compute the eigenvalues and orthogonal bases of the right
*        deflating subspace and companion subspace of a real
*        skew-Hamiltonian/Hamiltonian pencil, corresponding to the
*        eigenvalues with strictly negative real part.
         CALL MB03LF( COMPQ, COMPU, ORTH, N, Z, LDZ, B, LDB, FG, LDFG,
     $                NEIG, Q, LDQ, U, LDU, ALPHAR, ALPHAI, BETA, IWORK,
     $                LIWORK, DWORK, LDWORK, BWORK, IWARN, INFO )
*
         IF( INFO.NE.0 ) THEN
            WRITE( NOUT, FMT = 99997 ) INFO
         ELSE
            WRITE( NOUT, FMT = 99996 )
            DO 10 I = 1, N
               WRITE( NOUT, FMT = 99995 ) ( Z( I, J ), J = 1, N )
   10       CONTINUE
            WRITE( NOUT, FMT = 99994 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, M )
            WRITE( NOUT, FMT = 99993 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, M )
            WRITE( NOUT, FMT = 99992 )
            WRITE( NOUT, FMT = 99995 ) (   BETA( I ), I = 1, M )
            IF( LSAME( COMPQ, 'C' ) .AND. NEIG.GT.0 ) THEN
               WRITE( NOUT, FMT = 99991 )
               DO 20 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( Q( I, J ), J = 1, NEIG )
   20          CONTINUE
            END IF
            IF( LSAME( COMPU, 'C' ) .AND. NEIG.GT.0 ) THEN
               WRITE( NOUT, FMT = 99990 )
               DO 30 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( U( I, J ), J = 1, NEIG )
   30          CONTINUE
            END IF
            IF( LSAME( COMPQ, 'C' ) .OR. LSAME( COMPU, 'C' ) )
     $         WRITE( NOUT, FMT = 99989 ) NEIG
         END IF
      END IF
      STOP
*
99999 FORMAT ( 'MB03LF EXAMPLE PROGRAM RESULTS', 1X )
99998 FORMAT ( 'N is out of range.', /, 'N = ', I5 )
99997 FORMAT ( 'INFO on exit from MB03LF = ', I2 )
99996 FORMAT (/'The matrix Z on exit is ' )
99995 FORMAT ( 50( 1X, F8.4 ) )
99994 FORMAT (/'The vector ALPHAR is ' )
99993 FORMAT (/'The vector ALPHAI is ' )
99992 FORMAT (/'The vector BETA is ' )
99991 FORMAT (/'The deflating subspace corresponding to the ',
     $         'eigenvalues with negative real part is ' )
99990 FORMAT (/'The companion subspace corresponding to the ',
     $         'eigenvalues with negative real part is ' )
99989 FORMAT (/'The number of eigenvalues in the initial pencil with ',
     $         'negative real part is ', I2 )
      END


      DOUBLE PRECISION FUNCTION SCALE(NN,PT,ETA,INFIN,SMALNO,BASE)      SCAL4160
C RETURNS A SCALE FACTOR TO MULTIPLY THE COEFFICIENTS OF THE
C POLYNOMIAL. THE SCALING IS DONE TO AVOID OVERFLOW AND TO AVOID
C UNDETECTED UNDERFLOW INTERFERING WITH THE CONVERGENCE
C CRITERION.  THE FACTOR IS A POWER OF THE BASE.
C PT - MODULUS OF COEFFICIENTS OF P
C ETA,INFIN,SMALNO,BASE - CONSTANTS DESCRIBING THE
C FLOATING POINT ARITHMETIC.
      DOUBLE PRECISION PT(NN),ETA,INFIN,SMALNO,BASE,HI,LO,
     *    MAX,MIN,X,SC,DSQURT,DLOG
C FIND LARGEST AND SMALLEST MODULI OF COEFFICIENTS.
      HI = DSQRT(INFIN)
      LO = SMALNO/ETA
      MAX = 0.0D0
      MIN = INFIN
      DO 10 I = 1,NN
          X = PT(I)
          IF (X .GT. MAX) MAX = X
          IF (X .NE. 0.0D0 .AND. X.LT.MIN) MIN = X
   10 CONTINUE
C SCALE ONLY IF THERE ARE VERY LARGE OR VERY SMALL COMPONENTS.
      SCALE = 1.0D0
      IF (MIN .GE. LO .AND. MAX .LE. HI) RETURN
      X = LO/MIN
      IF (X .GT. 1.0D0) GO TO 20
          SC = 1.0D0/(DSQRT(MAX)*DSQRT(MIN))
          GO TO 30
   20 SC = X
      IF (INFIN/SC .GT. MAX) SC = 1.0D0
   30 L = DLOG(SC)/DLOG(BASE) + .500
      SCALE = BASE**L
      RETURN
      END


subroutine SHSCouplingMatrix(kij, galpha, lmax, nmax, exitstatus)
!------------------------------------------------------------------------------
!
!   SHSCouplingMatrix returns the spherical harmonic coupling matrix that
!   relates the expectation of the function expressed in a subset of the best-
!   localized Slepian functions to the expectation of the global power spectrum
!   (assumed to be stationary). The Slepian functions are determined by a call
!   to either (1) `SHReturnTapers` and then `SHRotateTapers`, or
!   (2) `SHReturnTapersMap`. Each row of galpha contains the (lmax+1)**2
!   spherical harmonic coefficients of a Slepian function that can be unpacked
!   using `SHVectorToCilm`. The Slepian functions must be normalized to have
!   unit power (that is the sum of the coefficients squared is 1).
!
!   The relationship between the global and localized power spectra is given by
!
!       < S_{\tilde{f}}(l) > = \sum_{l'=0}^lmax K_{ll'} S_{f}(l')
!
!   where S_{\tilde{f}} is the expectation of the power spectrum at degree l of
!   the function expressed in Slepian functions, S_{f}(l') is the expectation
!   of the global power spectrum, and < ... > is the expectation operator.
!   The coupling matrix is given explicitly by
!
!   K_{ij} = \frac{1}{2l'+1} Sum_{m=-l}^l Sum_{m'=-l'}^l'
!            ( Sum_{alpha=1}^nmax g_{l'm'}(alpha) g_{lm}(alpha) )**2
!
!   Calling Parameters
!
!       IN
!           galpha  Matrix of dimension ( (LMAX+1)**2, nmax) containing the
!                   spherical harmonic coefficients of the Slepian functions.
!                   Each column corresponds to a Slepian function ordered from
!                   best to worst concentrated.
!           lmax    Maximum spherical harmonic degree of the Slepian functions.
!           nmax    Maximum number of Slepian coefficients used to construct
!                   the function.
!
!       OUT
!           kij     Spherical harmonic coupling matrix of dimension
!                   ((LMAX+1)**2, nmax).
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(out) :: kij(:,:)
    real(dp), intent(in) :: galpha(:,:)
    integer, intent(in) :: lmax, nmax
    integer, intent(out), optional :: exitstatus
    integer :: l, lp, m, mp, alpha, ind, indp
    real(dp) :: temp

    if (present(exitstatus)) exitstatus = 0

    if (size(kij(:,1)) < (lmax+1) .or. size(kij(1,:)) < (lmax+1)) then
        print*, "Error --- SHSCouplingMatrix"
        print*, "KIJ must be dimensioned as (LMAX+1, LMAX+1)."
        print*, "LMAX = ", lmax
        print*, "Dimension of KIJ = ", size(kij(:,1)), size(kij(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(galpha(:,1)) < (lmax+1)**2 .or. &
            size(galpha(1,:)) < nmax) then
        print*, "Error --- SHSCouplingMatrix"
        print*, "GALPHA must be dimensioned as ( (LMAX+1)**2, NMAX )."
        print*, "LMAX = ", lmax
        print*, "NMAX = ", nmax
        print*, "Input array is dimensioned as ", size(galpha(:,1)), &
                size(galpha(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    kij = 0.0_dp

    ! Calculate k(l, lp) * (2lp +1 ), which is symmetric
    do l = 0, lmax
        do lp = l, lmax, 1
            do m = -l, l, 1

                if (m >= 0) then
                    ind = l**2+m+1
                else
                    ind = l**2+l+abs(m)+1
                end if

                do mp = -lp, lp, 1

                    if (mp >= 0) then
                        indp = lp**2+mp+1
                    else
                        indp = lp**2+lp+abs(mp)+1
                    end if

                    temp = 0.0_dp
                    do alpha = 1, nmax, 1

                       temp = temp + galpha(indp, alpha) * galpha(ind, alpha)

                    end do

                    kij(l+1, lp+1) = kij(l+1, lp+1) + temp**2

                end do

            end do

        end do

    end do

    ! Fill lower half of matrix
    do l = 1, lmax, 1

        do lp = 0, l-1, 1

            kij(l+1, lp+1) = kij(lp+1, l+1)

        end do

    end do

    ! Multiply by 1/(2lp+1)
    do lp = 0, lmax

        kij(1:lmax+1, lp+1) = kij(1:lmax+1, lp+1) / dble(2*lp+1)

    end do

end subroutine SHSCouplingMatrix


!
! Copyright (c) 2006-2007      University of Houston. All rights reserved.
! $COPYRIGHT$
!
! Additional copyrights may follow
!
! $HEADER$
!
         subroutine System_Matmul_blocking ( vekt, erg_vekt, ierror )

!....Diese Routine fuehrt eine Matrix-Vektor Multiplikation aus.

         USE globale_daten
         USE matrix

         implicit none

         double precision, dimension(0:n1+1, 0:n2+1, 0:n3+1, nc ):: vekt
         double precision, dimension(dmiu:dmio, dmju:dmjo, dmku:dmko, nc)::erg_vekt

!...Hilfsgroessen und Laufvariablen

         integer :: i, j, k
         integer :: oben, ierror

!...Multiplikation mit d1

         do k = dmku, dmko
            do j = dmju, dmjo
               do i = dmiu, dmio
                  erg_vekt(i,j,k,1) = rm000(i,j,k,1,1)*vekt(i,j,k,1)
               end do
            end do
         end do

!...Multiplikation mit d2

         do k = dmku, dmko
            do j = dmju, dmjo
               do i = 1, dmio
                  erg_vekt(i,j,k,1) = erg_vekt(i,j,k,1) + &
                      rmb00(i,j,k,1,1) * vekt(i-1,j,k,1)
               end do
            end do
         end do

!        write (*,*) mytid, ' :::: After rmb00 multiplication'

!...Multiplikation mit d3

         if ( rand_ab ) then
            oben = dmio -1
         else
            oben = dmio
         end if

         do k = dmku, dmko
            do j = dmju, dmjo
               do i = dmiu, oben
                  erg_vekt(i,j,k,1) = erg_vekt(i,j,k,1) + &
                      rmf00(i,j,k,1,1)*vekt(i+1,j,k,1)
               end do
            end do
         end do

!         write (*,*) mytid, ' :::: After rmf00 multiplication'
!...Multiplikation mit d4

         do k = dmku, dmko
            do j = 1, dmjo
               do i = dmiu, dmio
                  erg_vekt(i,j,k,1) = erg_vekt(i,j,k,1) + &
                      rm0b0(i,j,k,1,1)*vekt(i,j-1,k,1)
               end do
            end do
         end do

!         write (*,*) mytid, ' :::: After rm0b0 multiplication'
!...Multiplikation mit d5

         if ( rand_zu ) then
            oben = dmjo -1
         else
            oben = dmjo
         end if

         do k = dmku, dmko
            do j = dmju, oben
               do i = dmiu, dmio
                  erg_vekt(i,j,k,1) = erg_vekt(i,j,k,1) +  &
                      rm0f0(i,j,k,1,1)*vekt(i,j+1,k,1)
               end do
            end do
         end do

!         write (*,*) mytid, ' :::: After rm0f0 multiplication'

!...Multiplikation mit d6

         do k = 1, dmko
            do j = dmju, dmjo
               do i = dmiu, dmio
                  erg_vekt(i,j,k,1) = erg_vekt(i,j,k,1) + &
                      rm00b(i,j,k,1,1)*vekt(i,j,k-1,1)
               end do
            end do
         end do

!...Multiplikation mit d7

         if ( rand_symo ) then
            oben = dmko -1
         else
            oben = dmko
         end if

         do k = dmku, oben
            do j = dmju, dmjo
               do i = dmiu, dmio
                  erg_vekt(i,j,k,1) = erg_vekt(i,j,k,1) +  &
                      rm00f(i,j,k,1,1)*vekt(i,j,k+1,1)
               end do
            end do
         end do

         ierror = 0

         return
         end


c     # ------------------------------------------------------------
c     # Streamfunction, velocity components and derivatives
c     #
c     # Stream function depends on these global variables
c     #         example (0=incompressible; 1=compressible)
c     #         mapping (0=annulus; 1=twisted annulus)
c     # ------------------------------------------------------------

      subroutine annulus_center_velocity(x,y,t,vel)
      implicit none

      double precision x, y, vel(3), t

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision revs_per_s, vcart(2), amp, freq,cart_speed
      common /stream_comm/ revs_per_s, vcart, amp, freq, cart_speed

      double precision beta, theta(2)
      common /annulus_comm/ beta, theta

      integer example
      common /example_comm/ example

      double precision t1(3), t2(3), u(2)
c      double precision t1_norm2, t2_norm2
      double precision vc(3), annulus_dot
c      double precision t1_dot_vcart, t2_dot_vcart
      double precision xp,yp,zp, ravg, xc, d, tfinal, A
      double precision r, th, w, nc, vcr(2)

      integer k

      A = amp
      tfinal = 0.25

c     # Set non-zeros derivs only
      if (example .eq. 0) then
c         # Rigid body rotation
          u(1) = revs_per_s
          u(2) = 0
          call annulus_covariant_basis(x, y, t1,t2)
          do k = 1,3
            vel(k) = u(1)*t1(k) + u(2)*t2(k)
          end do
      else
          if (example .eq. 1) then
              vc(1) = vcart(1)
              vc(2) = vcart(2)
              vc(3) = 0
          elseif (example .eq. 2) then
              A = amp
              tfinal = 0.25
              vc(1) = cart_speed
              vc(2) = pi2*A*cos(freq*pi2*t/tfinal)/tfinal;
          elseif (example .eq. 3) then
              A = amp
              tfinal = 0.25
              vc(1) = cart_speed*pi*sin(pi*t/tfinal)/2.d0
              vc(2) = 0
         elseif (example .eq. 4) then
              A = amp
              tfinal = 0.25
              vc(1) = pi2*A*cos(freq*pi2*t/tfinal)/tfinal
c              vc(2) = cart_speed*pi*sin(pi*t/tfinal)/2.d0
              vc(2) = cart_speed
         elseif (example .eq. 5) then
             r = beta + (1-beta)*y
             th = theta(1) + (theta(2)-theta(1))*x
             w = amp
             vc(1) = -(1-w)*pi2*r*sin(pi2*th)
             vc(2) = (1+w)*pi2*r*cos(pi2*th)
             nc = sqrt(vc(1)**2 + vc(2)**2)

             vc(1) = -vc(1)/nc
             vc(2) = -vc(2)/nc
         endif
         vc(3) = 0

         do k = 1,3
            vel(k) = vc(k)
        end do

      endif
      end

      subroutine annulus_covariant_basis(x,y,t1,t2)
      implicit none

      double precision x,y,t1(3),t2(3)
      double precision theta, thetax, r, ry

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision beta, theta_vec(2)
      common /annulus_comm/ beta, theta_vec

c      r = beta + (1-beta)*yc
c      xp = r*cos(2*pi*xc)
c      yp = r*sin(2*pi*xc)

      theta = pi2*(theta_vec(1) + (theta_vec(2)-theta_vec(1))*x)
      thetax = pi2*(theta_vec(2)-theta_vec(1))

      r = beta + (1-beta)*y
      ry = 1-beta

      t1(1) = -thetax*r*sin(theta)
      t1(2) = thetax*r*cos(theta)
      t1(3) = 0

      t2(1) = ry*cos(theta)
      t2(2) = ry*sin(theta)
      t2(3) = 0

      end

      double precision function annulus_dot(u,v)
      implicit none

      double precision u(3),v(3)

      annulus_dot = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)

      end


!*****************************************************************************************
!>
!  Just an example using the lambert module.

    program lambert_test_2

    use fortran_astrodynamics_toolkit

    implicit none

    real(wp),dimension(3)               :: r1         !! first cartesian position [km]
    real(wp),dimension(3)               :: r2         !! second cartesian position [km]
    real(wp)                            :: tof        !! time of flight [sec]
    real(wp)                            :: mu         !! gravity parameter [km^3/s^2]
    logical                             :: long_way   !! when true, do "long way" (>pi) transfers
    integer                             :: multi_revs !! maximum number of multi-rev solutions to compute
    real(wp),dimension(:,:),allocatable :: v1         !! vector containing 3d arrays with the cartesian components of the velocities at r1
    real(wp),dimension(:,:),allocatable :: v2         !! vector containing 3d arrays with the cartesian components of the velocities at r2
    logical                             :: status_ok  !! true if everything is OK

    integer                 :: i,j,n,nsol,iunit_short,iunit_long
    real(wp),dimension(6)   :: rv,els ![al, q, ei, bom, om, tau]
    real(wp),dimension(20)  :: alpha
    real(wp)                :: err

    open(newunit=iunit_short,file='test2_short.csv',status='REPLACE')
    open(newunit=iunit_long, file='test2_long.csv', status='REPLACE')

    r1 = [20.0d3, 20.0d3, zero]  ! initial position
    r2 = [-20.0d3, 10.0d3, zero] ! final position
    mu = 398600.0_wp             ! earth
    multi_revs = 5               ! try up to 5 revs
    n = 2*day2sec                ! 2 days

    do i=5000,n,30  !transfer time loop [sec]

        tof = dble(i)    !sec

        !long way solutions:
        nsol = 0
        long_way=.true.
        call solve_lambert_gooding(r1,r2,tof,mu,long_way,multi_revs,v1,v2,status_ok)
        !call solve_lambert_izzo(r1,r2,tof,mu,long_way,multi_revs,v1,v2,status_ok)
        if (.not. status_ok) write(*,*) 'error!!'
        do j=1,size(v1,2)
            nsol = nsol + 1
            call pv3els (mu, [r1,v1(:,j)], els)  !convert transfer orbit state to orb elements
            alpha(nsol) = els(1)

            !verify solution:
            call propagate(mu, [r1,v1(:,j)], tof, rv)
            err = norm2(rv(1:3)-r2)
            if (err>1.0e-8_wp) write(*,*) 'Error:',err

        end do
        write(iunit_short,'(I3,A,1X,F10.0,A,1X,*(F20.6,1X,1H,))') nsol, ',',tof, ',',alpha(1:nsol)

        !short way solutions:
        nsol = 0
        long_way=.false.
        call solve_lambert_gooding(r1,r2,tof,mu,long_way,multi_revs,v1,v2,status_ok)
        !call solve_lambert_izzo(r1,r2,tof,mu,long_way,multi_revs,v1,v2,status_ok)
        if (.not. status_ok) write(*,*) 'error!!'
        do j=1,size(v1,2)
            nsol = nsol + 1
            call pv3els (mu, [r1,v1(:,j)], els)  !convert transfer orbit state to orb elements
            alpha(nsol) = els(1)

            !verify solution:
            call propagate(mu, [r1,v1(:,j)], tof, rv)
            err = norm2(rv(1:3)-r2)
            if (err>1.0e-8_wp) write(*,*) 'Error:',err

        end do
        write(iunit_long,'(I3,A,1X,F10.0,A,1X,*(F20.6,1X,1H,))') nsol, ',',tof, ',',alpha(1:nsol)

    end do

    close(iunit_short)
    close(iunit_long)

    end program lambert_test_2
!*****************************************************************************************