#include "scalar.fpp"

!=====================================================================!
! Module that contains common procedures for any time-dependent
! physical system subject to governing equations of n-th order
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module dynamic_physics_interface

  use physics_interface, only : physics

  implicit none

  private

  public :: dynamics

  type, abstract, extends(physics) :: dynamics

     type(integer) :: differential_order ! order of the differential equation

   contains

     ! Defined procedures
     procedure :: get_differential_order
     procedure :: set_differential_order

     ! Default finite difference jacobian implementation
     procedure :: add_jacobian => add_jacobian_fd

     ! Deferred procedure to subtypes
     procedure(initial_condition_interface), deferred :: get_initial_condition

  end type dynamics

  ! Interfaces to deferred procedures
  interface

     !----------------------------------------------------------------!
     ! Supplying the initial condition to march in time
     !----------------------------------------------------------------!

     pure subroutine initial_condition_interface(this, U, X)

       import :: dynamics

       class(dynamics), intent(in)  :: this
       type(scalar)   , intent(inout) :: U(:,:)
       type(scalar)   , intent(in)    :: X(:,:)

     end subroutine initial_condition_interface

  end interface

contains

  !===================================================================!
  ! Returns the highest order of time derivative in the physics
  !===================================================================!

  pure type(integer) function get_differential_order(this)

    class(dynamics), intent(in) :: this

    get_differential_order = this % differential_order

  end function get_differential_order

  !===================================================================!
  ! Sets the highest order of time derivative in the physics
  !===================================================================!

  pure subroutine set_differential_order(this, order)

    class(dynamics), intent(inout) :: this
    type(integer), intent(in)      :: order

    this % differential_order = order

  end subroutine set_differential_order

  !===================================================================!
  ! Jacobian assembly at each time step.
  !===================================================================!

  pure subroutine add_jacobian_fd(this, jacobian, coeff, U, X)

    class(dynamics) , intent(inout) :: this
    type(scalar)    , intent(inout) :: jacobian(:,:)
    type(scalar)    , intent(in)    :: coeff(:)
    type(scalar)    , intent(in)    :: U(:,:)
    type(scalar)    , intent(in)    :: X(:,:)

    type(integer)             :: nvars, dorder
    type(integer)             :: n, m
    type(scalar), allocatable :: R(:), Rtmp(:), Utmp(:,:)
    real(8)     , parameter   ::  dh = 1.0d-8

    nvars = this % get_num_state_vars()
    dorder = this % get_differential_order()

    ! Make a copy of state variables
    allocate(Utmp, source=U)

    ! Allocate space for residual perturbations
    allocate(R(nvars))
    allocate(Rtmp(nvars))

    ! Make a residual call with original variables
    R = 0.0d0
    call this % add_residual(R, U, X)

    diff_order: do n = 1, dorder + 1

       loop_vars: do m = 1, nvars

          ! Perturb the m-th variable of n-th order
          Utmp(n,m) = Utmp(n,m) + dh

          ! Make a residual call with the perturbed variable
          rtmp = 0.0d0
          call this % add_residual(Rtmp, Utmp, X)

          ! Unperturb (restore) the m-th variable of n-th order
          Utmp(n+1,m) = U(n+1,m)

          ! Approximate the jacobian with respect to the m-th variable
          jacobian(:,m) = jacobian(:,m) + coeff(n)*(Rtmp-R)/dh

       end do loop_vars

    end do diff_order

    ! Freeup memory
    deallocate(R, Rtmp)

  end subroutine add_jacobian_fd

end module dynamic_physics_interface


!! GLWH Dec 2020
!! <summary>This program reads in a POSCAR file and finds the
!! number of operations in the spacegroup.</summary>
PROGRAM symdriver
use num_types

use symmetry
implicit none

real(dp) LV(3,3)
integer nAt, nPG, i, nTypes, status, iTypes, idx
character(len=128) filename, dummy, line1, line2
real(dp), allocatable    :: d(:,:)
real(dp), allocatable    :: rots(:,:,:), shifts(:,:)
integer, allocatable     :: aTyp(:)

call getarg(1,filename)
if (filename=="") then; filename = "POSCAR"; endif

open(33,file=filename,status="old")
read(33,*) dummy !Skip title line
read(33,*) dummy !Skip lattice parameter
read(33,*) (LV(i,:),i=1,3)
! Count the number of atoms and types
read(33,'(A)') line1
line1 = trim(adjustl(line1))
line2 = line1
nTypes = 0; nAt = 0
do
  read(line1,*,iostat=status) i
  if (status/=0) exit
  nTypes = nTypes + 1
  nAt = nAt + i
  line1 = adjustl(line1(index(line1," "):))
  print*,line1
enddo
write(*,'(i3," types found")') nTypes
write(*,'(i3," atoms found")') nAt
allocate(d(nAt,3),aTyp(nAt))
! Read in the number of atoms *of each type*
idx = 1; aTyp = 0
do i = 1, nTypes
    read(line2,*,iostat=status) iTypes
    if (status/=0) exit
    aTyp(idx:idx+iTypes-1) = i ! should be i
    idx = idx + iTypes
    line2 = adjustl(line2(index(line2," "):))
enddo
read(33,*) !skip cart/direct line
do i = 1, nAt
    read(33,*) d(:,i)
    write(*,'(3(f8.4,1x))') d(:,i)
enddo
call get_spacegroup(LV, aTyp, d, rots, shifts, .true.)
close(33)

nPG=size(rots,3)
print*,"shape(rots)",shape(rots)
print*,"Number of rotations:",nPG
!print*,rots(:,:,1)
!print*,rots(:,:,2)

END PROGRAM symdriver


      subroutine getvcoul(ntype,Ealpha,icoul)
***************************************************
cc     Written by Lin-Wang Wang, March 30, 2001.
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

******************************************
****** This program calculate the modified v(r) for a cluster of slab.
****** For icoul=1, it does not have periodicity at all three directions.
****** For icoul=11, it does not have periodicity at the first n1 direction
****** For icoul=12, it does not have periodicity at the second n2 direction
****** For icoul=13, it does not have periodicity at the third n3 direction
************************************************
******  For icoul=1, it takes the periodic v'(r), then subtract \sum'_R 1/(r-R),
******  sum' means R not equal 0 (the original one). So what left v(r)=v'(r)-\sum'_R 1/(r-R)
******  should be similar to 1/r, but the values are smoothed near r=0 from the Fourier
******  space representation.
******  To do \sum'_R 1/(r-R), we have used the Ewald's method. Basically,
******  \sum'_R 1/(r-R)= \sum'_R (1/(r-R)-G(r-R)/(r-R))+ \sum_R G(r-R)/(r-R) -G(r)/r
******  here G(r-R)/(r-R) denotes the potential due to a spherical Gaussian charge at R.
*****   The first term is sum over real space \sum'_R, the second term \sum_R G(r-R)/(r-R)
*****   is calculated in Fourier space, and the last term G(r)/r is calculated in real space.
*******************************************
*****   For icoul=11,12,13, first, take v(r) from the icoul=1 calculation, then
*****   v_sl(r)=v(r)+\sum'_Rp 1/(r-Rp).   Here Rp are the periodic points in the
*****   two dimensional plane. \sum' means Rp.ne.0.    Again, the above sum is done using
*****   Ewald like technique. The details follow the formula in:
*****   D.M. Heyes, M. Barber, J.H.R. Clarke, J. Chem. Soc. Faraday Trans. 2: 73, 1485(1977).
***********************************************

       use fft_data
       use load_data
       use data

      implicit double precision (a-h,o-z)
      include 'param.escan_real'
      include "mpif.h"

      real*8 zatom(mtype),dv_corr(0:mtype)
      integer, allocatable, dimension(:) :: ncount_tmp

      real*8, allocatable, dimension(:)  :: workr_nL2

      real*8 qi2(mnq),vq(mnq,mtype),rhoq(mnq,mtype)
      real*8 vqT(mnq,mtype),rhocq(mnq,mtype)
      real*8 Ealpha(mtype)
      real*8 AL2D(3,2),ALI2D(3,2)

      character*20 file_tmp

      common /comVrho/qi2,vq,rhoq,vqT,rhocq
      common /comzatom/zatom

cccccccccccccccccccccccccccccccccccccccccccccccccc
       allocate(workr_nL2(mr_nL2))
       vins2=1.d0/vol2
       ng2_nL2=ngtotnod2L2(inode)
       pi=4*datan(1.d0)

       vcoul_nL2=0.d0
       do 100  itype=0,ntype      ! itype=0, plain coulomb, 4pi/q**2

       do 10 i=1,ng2_nL2

      q=dsqrt(gkx2_nL2(i)**2+gky2_nL2(i)**2+gkz2_nL2(i)**2)

ccccccc vq(iq),qi2(iq) not defined for 0.5*q**2 > Ecut2L

      if(0.5*q**2.ge.Ecut2L) goto 10

      iq=1+q*(mnq-1.d0)/qi2(mnq)

      x=(q-qi2(iq))/(qi2(iq+1)-qi2(iq))    ! assuming equal distance grid

      f1=1-x-0.5d0*x*(1-x)
      f2=x+x*(1-x)
      f3=-0.5d0*x*(1-x)       ! using quadratic interpolation based on vq*q**2

      amask=1.d0
      if(0.5d0*q**2.gt.Ecut2L*0.9d0) then
      x=(0.5d0*q**2-Ecut2L*0.9d0)/(0.1d0*Ecut2L)
      amask=(dcos(x*pi)+1.d0)/2.d0              ! provide a smooth cutoff around Ecut2L, so the real space v(r) should be smooth, approach to 1/r at large distance
      endif

      if(itype.ge.1) then
      y=vq(iq,itype)*qi2(iq)**2*f1+vq(iq+1,itype)*qi2(iq+1)**2*f2+
     &   vq(iq+2,itype)*qi2(iq+2)**2*f3
      else
      y=4*pi       ! itype=0, v(q)=4pi/q**2
      endif

      if(q.lt.1.D-6) then
      y=0.d0       ! v(q=0)=0, the constant to be settled later.
      else
      y=y/q**2
      endif

      y=y*amask

      i2=i*2

      vcoul_nL2(i2-1,itype)=vcoul_nL2(i2-1,itype)+y*vins2
      vcoul_nL2(i2,itype)=vcoul_nL2(i2,itype)+0.d0          ! it is real in G space, sph. symmetric

 10   continue

      call d3fft_real2L2(vcoul_nL2(1,itype),workr_nL2,-1,0)
      vcoul_nL2(:,itype) = workr_nL2(:)      ! this is v(r) with the atom at the origin

100   continue

***************************************************
***  The vcoul_nL2 obtained above is the results of periodic images by the AL2 box.
***  Now, for icoul=1, we want to get ride of this periodicity, by subtract out all the
***  1/r potentials from all the image charges. The sum of all these image charges are
***  calculated from Ewald sum method.

ccccccccccccccccccccccccccccccccccccccccccccccccccc
ccccccccccccccccccccccccccccccccccccccccccccccccccc

      d1=1.d0/dsqrt(ALI2(1,1)**2+ALI2(2,1)**2+ALI2(3,1)**2)
      d2=1.d0/dsqrt(ALI2(1,2)**2+ALI2(2,2)**2+ALI2(3,2)**2)
      d3=1.d0/dsqrt(ALI2(1,3)**2+ALI2(2,3)**2+ALI2(3,3)**2)

      d1q=1.d0/dsqrt(AL2(1,1)**2+AL2(2,1)**2+AL2(3,1)**2)
      d2q=1.d0/dsqrt(AL2(1,2)**2+AL2(2,2)**2+AL2(3,2)**2)
      d3q=1.d0/dsqrt(AL2(1,3)**2+AL2(2,3)**2+AL2(3,3)**2)

ccccc This beta balances the real and G space calculations.
ccccc The computational time in both real and G space are O(N^2).
ccccc In both real and G space, the calc. propto ~ 1000*natom**2

      beta=1.2*pi**0.5*
     &     (d1q*d2q*d3q/(d1*d2*d3))**0.16666666

ccccc this beta is to make nc1*nc2*nc3=nq1*nq2*nq3

c      cut=5.5d0     !  exp(-cut**2)
      cut=5.0d0     !  exp(-cut**2)

      cut_gkk=4*(cut*beta)**2/(2*pi)**2
      cut_rr=(cut/beta)**2
      fac_gkk=(2*pi)**2/(4*beta**2)

      nc1=dsqrt(cut_rr)/d1+0.25
      nc2=dsqrt(cut_rr)/d2+0.25
      nc3=dsqrt(cut_rr)/d3+0.25

      nq1=dsqrt(cut_gkk)/d1q
      nq2=dsqrt(cut_gkk)/d2q
      nq3=dsqrt(cut_gkk)/d3q

      dv=pi/beta**2/vol2

      if(inode_tot.eq.1) then
      write(6,*) "nc1,2,3, nq1,2,3,beta:",
     &  nc1,nc2,nc3,nq1,nq2,nq3,beta
      endif

ccccccccccccccccccccccccccccccccccccccccccccccccccc
ccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 2000 ii=1,nr_nL2
      jj=ii+(inode-1)*nr_nL2
      i1=(jj-1)/(n2L2*n3L2)+1
      j1=(jj-1-(i1-1)*n2L2*n3L2)/n3L2+1
      k1=jj-(i1-1)*n2L2*n3L2-(j1-1)*n3L2

      if(i1.le.n1L2/2+1) then
      idx1=i1-1
      else
      idx1=i1-n1L2-1
      endif

      if(j1.le.n2L2/2+1) then
      idx2=j1-1
      else
      idx2=j1-n2L2-1
      endif

      if(k1.le.n3L2/2+1) then
      idx3=k1-1
      else
      idx3=k1-n3L2-1
      endif

      x0=AL2(1,1)*idx1/n1L2+AL2(1,2)*idx2/n2L2+
     &     AL2(1,3)*idx3/n3L2
      y0=AL2(2,1)*idx1/n1L2+AL2(2,2)*idx2/n2L2+
     &     AL2(2,3)*idx3/n3L2
      z0=AL2(3,1)*idx1/n1L2+AL2(3,2)*idx2/n2L2+
     &     AL2(3,3)*idx3/n3L2

      sr=0.d0
      do 200 i=-nc1,nc1     ! this is the real space summation, rho(r)=gauss(r-R)-delta(r-R)
      do 200 j=-nc2,nc2
      do 200 k=-nc3,nc3
      x=x0+AL2(1,1)*i+AL2(1,2)*j+AL2(1,3)*k
      y=y0+AL2(2,1)*i+AL2(2,2)*j+AL2(2,3)*k
      z=z0+AL2(3,1)*i+AL2(3,2)*j+AL2(3,3)*k
      rr=x**2+y**2+z**2
      if((i.ne.0.or.j.ne.0.or.k.ne.0).and.rr.gt.cut_rr) goto 200

      r=dsqrt(rr)

      if(i.eq.0.and.j.eq.0.and.k.eq.0) then
***  special treatment for i,j,k=0, the point itself,not the images
***  for this point, only add the potential from gauss(r) [(erfc(beta*r)-1)/r], not the delta(r-R)
       if(r.lt.1.D-6) r=1.D-6
       if(rr.gt.cut_rr) then
       sr=sr-1.d0/r
       else
       sr=sr+(erfc(beta*r)-1.d0)/r
       endif
      else
**** for all the other image points, add the potential from gauss(r-R)-delta(r-R) [erfc(beta*r)/r]
      sr=sr+erfc(beta*r)/r
      endif

200   continue

      sr=sr-dv    ! the important constant, to correct the v(q=0)=0 overall shifting

      sq=0.d0
      do 300 i=0,nq1     ! this is q space summation, subtract out the lattice gauss(r-R) potential
      do 300 j=-nq2,nq2
      do 300 k=-nq3,nq3
cccc the summation over nq1,nq2,nq3 is done for each grid points, so no FFT etc. (It actually
cccc can be done by FFT !)

      if(i.eq.0.and.j.lt.0) goto 300
      if(i.eq.0.and.j.eq.0.and.k.lt.0) goto 300
      if(i.eq.0.and.j.eq.0.and.k.eq.0) goto 300

      gkx=ALI2(1,1)*i+ALI2(1,2)*j+ALI2(1,3)*k
      gky=ALI2(2,1)*i+ALI2(2,2)*j+ALI2(2,3)*k
      gkz=ALI2(3,1)*i+ALI2(3,2)*j+ALI2(3,3)*k

      gkk=gkx**2+gky**2+gkz**2        ! gkk,gkx,gky,gkz missing 2*pi

      if(gkk.gt.cut_gkk) goto 300

      ph=(x0*gkx+y0*gky+z0*gkz)*2*pi

      sq=sq+dexp(-gkk*fac_gkk)*dcos(ph)/gkk

300   continue

      sq=sq*4*pi/vol2*2.d0/(2*pi)**2

      vcoul_nL2(ii,0)=vcoul_nL2(ii,0)-sr-sq

      do itype=1,ntype
      vcoul_nL2(ii,itype)=vcoul_nL2(ii,itype)+
     &                    zatom(itype)*(sr+sq)
      enddo

2000  continue

ccccccccccc  after this dv_corr, the vcoul_nL2(ii,0) is like 1/r (no shift)
ccccccccccc                      the vcoul_nL2(ii,itype) is like v_loc(r,itype) (no shift)
ccccccccccc                      There is no need for the original Ealpha

       dv_corr(0)=0.d0
       do itype=1,ntype
       dv_corr(itype)=Ealpha(itype)/vol2
       enddo

       do itype=0,ntype
       vcoul_nL2(:,itype)=vcoul_nL2(:,itype)+dv_corr(itype)
       enddo

       if(icoul.eq.1) then
cccccccccc  provide a buffer cutoff surface. Actually not really needed.
cccccccccc  But maybe it is a good idea to keep the symmetric of the potential
       do ii=1,nr_nL2
       jj=ii+(inode-1)*nr_nL2
       i1=(jj-1)/(n2L2*n3L2)+1
       j1=(jj-1-(i1-1)*n2L2*n3L2)/n3L2+1
       k1=jj-(i1-1)*n2L2*n3L2-(j1-1)*n3L2

      amask1=1.d0
      if(mod(n1L2,2).eq.0.and.i1.eq.n1L2/2+1) amask1=0.d0
      amask2=1.d0
      if(mod(n2L2,2).eq.0.and.j1.eq.n2L2/2+1) amask2=0.d0
      amask3=1.d0
      if(mod(n3L2,2).eq.0.and.k1.eq.n3L2/2+1) amask3=0.d0

      amask=amask1*amask2*amask3

ccccccc not really necessary for the symmetry

cc      do itype=0,ntype
cc      vcoul_nL2(ii,itype)=vcoul_nL2(ii,itype)*amask
cc      enddo
      enddo

      goto 4000  ! don't do the following, which is for slab calculation
      endif
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
****  Now, we need to add back the sum of 2D image potentials !
****  This again, it done by a Ewald like summation.
****  First, get the two 2D lattice vectors:

      if(icoul.eq.11) then
      AL2D(:,1)=AL2(:,2)
      AL2D(:,2)=AL2(:,3)
      endif
      if(icoul.eq.12) then
      AL2D(:,1)=AL2(:,1)
      AL2D(:,2)=AL2(:,3)
      endif
      if(icoul.eq.13) then
      AL2D(:,1)=AL2(:,1)
      AL2D(:,2)=AL2(:,2)
      endif

cccccccccccccccccccccccccccccccccccccc
      d1q_2D=1.d0/dsqrt(AL2D(1,1)**2+AL2D(2,1)**2+AL2D(3,1)**2)
      d2q_2D=1.d0/dsqrt(AL2D(1,2)**2+AL2D(2,2)**2+AL2D(3,2)**2)

      dcosth=AL2D(1,1)*AL2D(1,2)+AL2D(2,1)*AL2D(2,2)+
     &         AL2D(3,1)*AL2D(3,2)
      dcosth=dcosth*d1q_2D*d2q_2D
      ALI2D(:,1)=AL2D(:,1)-AL2D(:,2)*d2q_2D/d1q_2D*dcosth
      ALI2D(:,2)=AL2D(:,2)-AL2D(:,1)*d1q_2D/d2q_2D*dcosth

      S_plane=dsqrt(ALI2D(1,1)**2+ALI2D(2,1)**2+ALI2D(3,1)**2)/d2q_2D

      sum1=ALI2D(1,1)*AL2D(1,1)+ALI2D(2,1)*AL2D(2,1)+
     &         ALI2D(3,1)*AL2D(3,1)
      sum2=ALI2D(1,2)*AL2D(1,2)+ALI2D(2,2)*AL2D(2,2)+
     &         ALI2D(3,2)*AL2D(3,2)
      ALI2D(:,1)=ALI2D(:,1)/sum1    ! ALI2D is the reciprocal of AL2D, on the same plane
      ALI2D(:,2)=ALI2D(:,2)/sum2

      d1_2D=1.d0/dsqrt(ALI2D(1,1)**2+ALI2D(2,1)**2+ALI2D(3,1)**2)
      d2_2D=1.d0/dsqrt(ALI2D(1,2)**2+ALI2D(2,2)**2+ALI2D(3,2)**2)

      nc1_2D=dsqrt(cut_rr)/d1_2D+0.25   ! need to look at more carefully
      nc2_2D=dsqrt(cut_rr)/d2_2D+0.25   ! need to look at more carefully

      nq1_2D=dsqrt(cut_gkk)/d1q_2D
      nq2_2D=dsqrt(cut_gkk)/d2q_2D
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      if(inode_tot.eq.1) then
      write(6,*) "d1,2_2D",d1_2D,d2_2D
      write(6,*) "nc1,2_2D",nc1_2D,nc2_2D
      write(6,*) "nq1,2_2D",nq1_2D,nq2_2D
      write(6,*) "AL2D",AL2D(1,1),AL2D(2,1),AL2D(3,1)
      write(6,*) "AL2D",AL2D(1,2),AL2D(2,2),AL2D(3,2)
      write(6,*) "ALI2D",ALI2D(1,1),ALI2D(2,1),ALI2D(3,1)
      write(6,*) "ALI2D",ALI2D(1,2),ALI2D(2,2),ALI2D(3,2)
      endif

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      do 2009 ii=1,nr_nL2
      jj=ii+(inode-1)*nr_nL2
      i1=(jj-1)/(n2L2*n3L2)+1
      j1=(jj-1-(i1-1)*n2L2*n3L2)/n3L2+1
      k1=jj-(i1-1)*n2L2*n3L2-(j1-1)*n3L2

      if(i1.le.n1L2/2+1) then
      idx1=i1-1
      else
      idx1=i1-n1L2-1
      endif

      if(j1.le.n2L2/2+1) then
      idx2=j1-1
      else
      idx2=j1-n2L2-1
      endif

      if(k1.le.n3L2/2+1) then
      idx3=k1-1
      else
      idx3=k1-n3L2-1
      endif

      x0=AL2(1,1)*idx1/n1L2+AL2(1,2)*idx2/n2L2+
     &     AL2(1,3)*idx3/n3L2
      y0=AL2(2,1)*idx1/n1L2+AL2(2,2)*idx2/n2L2+
     &     AL2(2,3)*idx3/n3L2
      z0=AL2(3,1)*idx1/n1L2+AL2(3,2)*idx2/n2L2+
     &     AL2(3,3)*idx3/n3L2

      x11=ALI2D(1,1)*x0+ALI2D(2,1)*y0+ALI2D(3,1)*z0
      x22=ALI2D(1,2)*x0+ALI2D(2,2)*y0+ALI2D(3,2)*z0

      dz_x0=x0-AL2D(1,1)*x11-AL2D(1,2)*x22
      dz_y0=y0-AL2D(2,1)*x11-AL2D(2,2)*x22
      dz_z0=z0-AL2D(3,1)*x11-AL2D(3,2)*x22

      dz=dsqrt(dz_x0**2+dz_y0**2+dz_z0**2)

      sr=0.d0
      do 209 i=-nc1_2D,nc1_2D     ! this is the real space summation, rho(r)=gauss(r-R)-delta(r-R)
      do 209 j=-nc2_2D,nc2_2D
      x=x0+AL2D(1,1)*i+AL2D(1,2)*j
      y=y0+AL2D(2,1)*i+AL2D(2,2)*j
      z=z0+AL2D(3,1)*i+AL2D(3,2)*j
      rr=x**2+y**2+z**2
      if((i.ne.0.or.j.ne.0).and.rr.gt.cut_rr) goto 209

      r=dsqrt(rr)

      if(i.eq.0.and.j.eq.0) then
***  special treatment for i,j=0, the point itself,not the images
***  for this point, only add the potential from gauss(r) [(erfc(beta*r)-1)/r], not the delta(r-R)
       if(r.lt.1.D-6) r=1.D-6
       if(rr.gt.cut_rr) then
       sr=sr-1.d0/r
       else
       sr=sr+(erfc(beta*r)-1.d0)/r
       endif
      else
**** for all the other image points, add the potential from gauss(r-R)-delta(r-R) [erfc(beta*r)/r]
      sr=sr+erfc(beta*r)/r
      endif

209   continue

cccccc not so sure about the zero point
ccc    sr=sr-dv    ! the important constant, to correct the v(q=0)=0 overall shifting

      sq=0.d0
      do 309 i=0,nq1_2D     ! this is q space summation, subtract out the lattice gauss(r-R) potential
      do 309 j=-nq2_2D,nq2_2D
cccc the summation over nq1,nq2,nq3 is done for each grid points, so no FFT etc. (It actually
cccc can be done by FFT !)

      if(i.eq.0.and.j.lt.0) goto 309       ! only half space need to be summed
      if(i.eq.0.and.j.eq.0) goto 309

      gkx=ALI2D(1,1)*i+ALI2D(1,2)*j
      gky=ALI2D(2,1)*i+ALI2D(2,2)*j
      gkz=ALI2D(3,1)*i+ALI2D(3,2)*j

      gkk=gkx**2+gky**2+gkz**2        ! gkk,gkx,gky,gkz missing 2*pi

      if(gkk.gt.cut_gkk) goto 309       ! this same criterion is okay for 2D q sum

      gk=dsqrt(gkk)*2*pi

      ph=(x0*gkx+y0*gky+z0*gkz)*2*pi

cccccc the Fortran erfc(x) is good for -infity < x < 10.d0
cccccc! make sure dexp(dz*gk) not overflow, erfc(y) not be zero
      y=dz*beta+gk/beta/2
      if(y.lt.9.5) then
      sq=sq+dcos(ph)/gk*(
     &  dexp(dz*gk)*erfc(dz*beta+gk/beta/2)+dexp(-dz*gk)*
     &  erfc(-dz*beta+gk/beta/2))
      else
      f22=1.d0     ! f22=exp(y**2)*erfc(y)
      term_iter=1.d0
      do m_iter=1,10    ! serial expansion for exp(y**2)*erfc(y).
      term_iter=-term_iter*(2*m_iter-1)/(2*y**2)
      f22=f22+term_iter
      enddo
      f22=f22/y/dsqrt(pi)
      sq=sq+dcos(ph)/gk*(f22*dexp(-(dz*beta)**2-(gk/beta/2)**2)
     &  +dexp(-dz*gk)*erfc(-dz*beta+gk/beta/2))
      endif

309   continue

      sq=sq*pi/S_plane*2    ! fact of 2 because  i=0,nq1_2D, only sum half of the sphere
ccccc THIS GAUSSIAN PART LOOKS TOO SMALL !!!   IS THIS REALLY CORRECT ! fact of 10000 !

      sq=sq-2*pi/S_plane/beta*(dexp(-(dz*beta)**2)/dsqrt(pi)+
     &   dz*beta*erf(dz*beta))       ! this formula is okay numerically

***** erf(-x)=-erf(x), checked

****** The constant is not added yet.

cccccccccccc opposite sign as before
      vcoul_nL2(ii,0)=vcoul_nL2(ii,0)+sr+sq

      do itype=1,ntype
      vcoul_nL2(ii,itype)=vcoul_nL2(ii,itype)-
     &                    zatom(itype)*(sr+sq)
      enddo

2009  continue

cccccccccccccccccccccccccccccccccccccccccccccc
cccccccccc  provide a buffer cutoff surface. Actually not really needed.
cccccccccc  But maybe it is a good idea to keep the symmetric of the potential
      do ii=1,nr_nL2
       jj=ii+(inode-1)*nr_nL2
       i1=(jj-1)/(n2L2*n3L2)+1
       j1=(jj-1-(i1-1)*n2L2*n3L2)/n3L2+1
       k1=jj-(i1-1)*n2L2*n3L2-(j1-1)*n3L2

      amask=1.d0
      if(icoul.eq.11.and.mod(n1L2,2).eq.0.and.i1.eq.n1L2/2+1)
     &    amask=0.d0
      if(icoul.eq.12.and.mod(n2L2,2).eq.0.and.j1.eq.n2L2/2+1)
     &    amask=0.d0
      if(icoul.eq.13.and.mod(n3L2,2).eq.0.and.k1.eq.n3L2/2+1)
     &    amask=0.d0

ccccccc  not really necessary for the symmetry
c      do itype=0,ntype
c      vcoul_nL2(ii,itype)=vcoul_nL2(ii,itype)*amask
c      enddo
      enddo
ccccccccccccccccccccccccccccccccccccccccccccccccccc
ccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccc  vcoul_nL2 is like 1/r
ccccccccccccccccccccccccccccccccccccccccccccccccccc

4000  continue     ! jumping point for icoul=1

      do itype=0,ntype
      workr_nL2(:)= vcoul_nL2(:,itype)
      call d3fft_real2L2(vcoul_nL2(1,itype),workr_nL2,1,0)
      enddo

      vcoul_nL2(:,0)=vcoul_nL2(:,0)*vol2

ccccccccc  Now, vcoul_nL2 is in q space.

      deallocate(workr_nL2)

      return
      end


!---------------------------------------------------!
! 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 input_Ac
  use global_variables
  implicit none
  integer :: it
  real(8) :: tt
  real(8) :: Es,Up,alpha

  allocate(Act(-1:Nt+2),jtz(0:Nt+1),jtz_intra(0:Nt+1),jtz_inter(0:Nt+1))
  allocate(Act_pump(-1:Nt+2),Act_probe(-1:Nt+2) )

!  E0_1=5.338d-9*sqrt(Iwcm2_1)
  E0_1=E0_1_V_m*a_B*1d-10/(2d0*Ry)
  omega_1 = omega_ev_1/(2d0*Ry)
  tpulse_1 = tpulse_fs_1/0.02418d0
!  E0_2=5.338d-9*sqrt(Iwcm2_2)
  E0_2=E0_2_V_m*a_B*1d-10/(2d0*Ry)
  omega_2 = omega_ev_2/(2d0*Ry)
  tpulse_2 = tpulse_fs_2/0.02418d0
  Tdelay = Tdelay_fs/0.02418d0

!
  Es = piz_vc**2*E0_1**2/eps_g**3
  Up = E0_1**2/(4d0*mass_r*omega_1**2)
  alpha = (Es+Up)/eps_g

  write(*,"(A,2x,999e26.16e3)")"Stark shift, Es=",Es
  write(*,"(A,2x,999e26.16e3)")"Ponderomotive energy, Up=",Up
  write(*,"(A,2x,999e26.16e3)")"(Es+Up)/Eg=",(Es+Up)/eps_g
  write(*,"(A,2x,999e26.16e3)")"Es/Up=",Es/Up
  write(*,"(A,2x,999e26.16e3)")"E0_1=",E0_1
  write(*,"(A,2x,999e26.16e3)")"E0_2=",E0_2

  Act = 0d0; jtz=0d0; jtz_intra = 0d0; jtz_inter = 0d0
  Act_pump = 0d0; Act_probe = 0d0

!Pump
  select case(envelope_1)
  case("cos4cos")
    do it = 0,Nt+1
      tt = dt*dble(it)
      if(abs(tt-0.5d0*tpulse_1) < 0.5d0*tpulse_1)then
        Act_pump(it) = -(E0_1/omega_1)*cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1)**4 &
          *sin(omega_1*(tt-0.5d0*tpulse_1)+2d0*pi*CEP_2pi_1)
      end if
    end do

  case("cos2cos")
    do it = 0,Nt+1
      tt = dt*dble(it)
      if(abs(tt-0.5d0*tpulse_1) < 0.5d0*tpulse_1)then
        Act_pump(it) = -(E0_1/omega_1)*cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1)**2 &
          *sin(omega_1*(tt-0.5d0*tpulse_1) +2d0*pi*CEP_2pi_1)
      end if
    end do

  case("cos6cos")
    do it = 0,Nt+1
      tt = dt*dble(it)
      if(abs(tt-0.5d0*tpulse_1) < 0.5d0*tpulse_1)then
        Act_pump(it) = -(E0_1/omega_1)*cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1)**6 &
          *sin(omega_1*(tt-0.5d0*tpulse_1)+2d0*pi*CEP_2pi_1)
      end if
    end do

  case default
    stop "Invalid envelope_1"
  end select

!Probe
  select case(envelope_2)
  case("cos4cos")
    do it = 0,Nt+1
      tt = dt*dble(it)

      if(abs(tt-0.5d0*tpulse_1-Tdelay) < 0.5d0*tpulse_2)then
        Act_probe(it) = -(E0_2/omega_2) &
          *cos(pi*(tt-0.5d0*tpulse_1-Tdelay)/tpulse_2)**4 &
          *sin(omega_2*(tt-0.5d0*tpulse_1-Tdelay)+2d0*pi*CEP_2pi_2)
      end if
    end do

  case("cos2cos")
    do it = 0,Nt+1
      tt = dt*dble(it)

      if(abs(tt-0.5d0*tpulse_1-Tdelay) < 0.5d0*tpulse_2)then
        Act_probe(it) = -(E0_2/omega_2) &
          *cos(pi*(tt-0.5d0*tpulse_1-Tdelay)/tpulse_2)**2 &
          *sin(omega_2*(tt-0.5d0*tpulse_1-Tdelay)+2d0*pi*CEP_2pi_2)
      end if
    end do

  case("cos6cos")
    do it = 0,Nt+1
      tt = dt*dble(it)

      if(abs(tt-0.5d0*tpulse_1-Tdelay) < 0.5d0*tpulse_2)then
        Act_probe(it) =  -(E0_2/omega_2) &
          *cos(pi*(tt-0.5d0*tpulse_1-Tdelay)/tpulse_2)**6 &
          *sin(omega_2*(tt-0.5d0*tpulse_1-Tdelay)+2d0*pi*CEP_2pi_2)
      end if
    end do

  case default
    stop "Invalid envelope_2"
  end select

  Act = Act_pump + Act_probe

  if(if_pure_intraband_fields_exist)then
    call input_Ac_intra
  end if

  return

  contains
    subroutine input_Ac_intra
      use global_variables
      implicit none
      integer :: it
      real(8) :: tt, xx

      E0_static = E0_static_V_AA*a_B/ev
      T_duration_static = tpulse_1
      if(if_add_impulsive)T_duration_static=0d0

      allocate(Act_intra(-1:Nt+2))

      do it = -1, Nt+2
        tt = dt*dble(it)
        xx = tt - 0.5d0*T_duration_static
        Act_intra(it) = -E0_static*xx
      end do

    end subroutine input_Ac_intra

end subroutine input_Ac
!--------------------------------------------------------------------------------


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... file shaec.f
c
c     this file contains code and documentation for subroutines
c     shaec and shaeci
c
c ... files which must be loaded with shaec.f
c
c     sphcom.f, hrfft.f
c
c     subroutine shaec(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    +                 wshaec,lshaec,work,lwork,ierror)
c
c     subroutine shaec performs the spherical harmonic analysis
c     on the array g and stores the result in the arrays a and b.
c     the analysis is performed on an equally spaced grid.  the
c     associated legendre functions are recomputed rather than stored
c     as they are in subroutine shaes.  the analysis is described
c     below at output parameters a,b.
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     isym   = 0  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the analysis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the analysis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of analyses.  in the program that calls shaec,
c            the arrays g,a and b can be three dimensional in which
c            case multiple analyses will be performed.  the third
c            index is the analysis index which assumes the values
c            k=1,...,nt.  for a single analysis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that the arrays g,a and b
c            have only two dimensions.
c
c     g      a two or three dimensional array (see input parameter
c            nt) that contains the discrete function to be analyzed.
c            g(i,j) contains the value of the function at the colatitude
c            point theta(i) = (i-1)*pi/(nlat-1) and longitude point
c            phi(j) = (j-1)*2*pi/nlon. the index ranges are defined
c            above at the input parameter isym.
c
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shaec.  if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg
c            must be at least nlat/2 if nlat is even or at least
c            (nlat+1)/2 if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shaec.  jdg must be at least nlon.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shaec. mdab must be at least
c            min0(nlat,(nlon+2)/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays a and b as it appears
c            in the program that calls shaec. ndab must be at least nlat
c
c     wshaec an array which must be initialized by subroutine shaeci.
c            once initialized, wshaec can be used repeatedly by shaec
c            as long as nlon and nlat remain unchanged.  wshaec must
c            not be altered between calls of shaec.
c
c     lshaec the dimension of the array wshaec as it appears in the
c            program that calls shaec. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshaec must be at least
c
c            2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shaec. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if isym is zero then lwork must be at least
c
c                    nlat*(nt*nlon+max0(3*l2,nlon))
c
c            if isym is not zero then lwork must be at least
c
c                    l2*(nt*nlon+max0(3*nlat,nlon))
c
c     **************************************************************
c
c     output parameters
c
c     a,b    both a,b are two or three dimensional arrays (see input
c            parameter nt) that contain the spherical harmonic
c            coefficients in the representation of g(i,j) given in the
c            discription of subroutine shsec. for isym=0, a(m,n) and
c            b(m,n) are given by the equations listed below. symmetric
c            versions are used when isym is greater than zero.
c
c
c
c     definitions
c
c     1. the normalized associated legendre functions
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta)
c
c     2. the normalized z functions for m even
c
c     zbar(m,n,theta) = 2/(nlat-1) times the sum from k=0 to k=nlat-1 of
c                       the integral from tau = 0 to tau = pi of
c                       cos(k*theta)*cos(k*tau)*pbar(m,n,tau)*sin(tau)
c                       (first and last terms in this sum are divided
c                       by 2)
c
c     3. the normalized z functions for m odd
c
c     zbar(m,n,theta) = 2/(nlat-1) times the sum from k=0 to k=nlat-1 of
c                       of the integral from tau = 0 to tau = pi of
c                       sin(k*theta)*sin(k*tau)*pbar(m,n,tau)*sin(tau)
c
c     4. the fourier transform of g(i,j).
c
c     c(m,i)          = 2/nlon times the sum from j=1 to j=nlon
c                       of g(i,j)*cos((m-1)*(j-1)*2*pi/nlon)
c                       (the first and last terms in this sum
c                       are divided by 2)
c
c     s(m,i)          = 2/nlon times the sum from j=2 to j=nlon
c                       of g(i,j)*sin((m-1)*(j-1)*2*pi/nlon)
c
c     5. the maximum (plus one) longitudinal wave number
c
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c
c     then for m=0,...,mmax-1 and n=m,...,nlat-1 the arrays a,b
c     are given by
c
c     a(m+1,n+1)      = the sum from i=1 to i=nlat of
c                       c(m+1,i)*zbar(m,n,theta(i))
c                       (first and last terms in this sum are
c                       divided by 2)
c
c     b(m+1,n+1)      = the sum from i=1 to i=nlat of
c                       s(m+1,i)*zbar(m,n,theta(i))
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lshaec
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c     subroutine shaeci(nlat,nlon,wshaec,lshaec,dwork,ldwork,ierror)
c
c     subroutine shaeci initializes the array wshaec which can then
c     be used repeatedly by subroutine shaec.
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     lshaec the dimension of the array wshaec as it appears in the
c            program that calls shaeci. the array wshaec is an output
c            parameter which is described below. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshaec must be at least
c
c            2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
c
C*PL*ERROR* Comment line too long
c     dwork  a double precision dwork array that does not have to be saved.
c
c     ldwork the dimension of the array dwork as it appears in the
c            program that calls shaeci.  ldwork  must be at least
c            nlat+1.
c
c
c     output parameters
c
c     wshaec an array which is initialized for use by subroutine shaec.
c            once initialized, wshaec can be used repeatedly by shaec
c            as long as nlon and nlat remain unchanged.  wshaec must
c            not be altered between calls of shaec.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshaec
c            = 4  error in the specification of ldwork
c
c
c *******************************************************************
      SUBROUTINE DSHAEC(NLAT,NLON,ISYM,NT,G,IDG,JDG,A,B,MDAB,NDAB,
     +                  WSHAEC,LSHAEC,WORK,LWORK,IERROR)
      DOUBLE PRECISION G
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WSHAEC
      DOUBLE PRECISION WORK
      DIMENSION G(IDG,JDG,*),A(MDAB,NDAB,*),B(MDAB,NDAB,*),WSHAEC(*),
     +          WORK(*)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IF ((ISYM.EQ.0.AND.IDG.LT.NLAT) .OR.
     +    (ISYM.NE.0.AND.IDG.LT. (NLAT+1)/2)) RETURN
      IERROR = 6
      IF (JDG.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT,NLON/2+1)
      IF (MDAB.LT.MMAX) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
      IMID = (NLAT+1)/2
      LZZ1 = 2*NLAT*IMID
      LABC = 3* ((MMAX-2)* (NLAT+NLAT-MMAX-1))/2
      IF (LSHAEC.LT.LZZ1+LABC+NLON+15) RETURN
      IERROR = 10
      LS = NLAT
      IF (ISYM.GT.0) LS = IMID
      NLN = NT*LS*NLON
      IF (LWORK.LT.NLN+MAX0(LS*NLON,3*NLAT*IMID)) RETURN
      IERROR = 0
      IST = 0
      IF (ISYM.EQ.0) IST = IMID
      IW1 = LZZ1 + LABC + 1
      CALL DSHAEC1(NLAT,ISYM,NT,G,IDG,JDG,A,B,MDAB,NDAB,IMID,LS,NLON,
     +            WORK,WORK(IST+1),WORK(NLN+1),WORK(NLN+1),WSHAEC,
     +            WSHAEC(IW1))
      RETURN
      END
      SUBROUTINE DSHAEC1(NLAT,ISYM,NT,G,IDGS,JDGS,A,B,MDAB,NDAB,IMID,
     +                   IDG,JDG,GE,GO,WORK,ZB,WZFIN,WHRFFT)
      DOUBLE PRECISION G
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION GE
      DOUBLE PRECISION GO
      DOUBLE PRECISION WORK
      DOUBLE PRECISION ZB
      DOUBLE PRECISION WZFIN
      DOUBLE PRECISION WHRFFT
      DOUBLE PRECISION TSN
      DOUBLE PRECISION FSN
c
c     whrfft must have at least nlon+15 locations
c     wzfin must have 2*l*(nlat+1)/2 + ((l-3)*l+2)/2 locations
c     zb must have 3*l*(nlat+1)/2 locations
c     work must have ls*nlon locations
c
      DIMENSION G(IDGS,JDGS,1),A(MDAB,NDAB,1),B(MDAB,NDAB,1),
     +          GE(IDG,JDG,1),GO(IDG,JDG,1),ZB(IMID,NLAT,3),WZFIN(1),
     +          WHRFFT(1),WORK(1)

      LS = IDG
      NLON = JDG
      MMAX = MIN0(NLAT,NLON/2+1)
      MDO = MMAX
      IF (MDO+MDO-1.GT.NLON) MDO = MMAX - 1
      NLP1 = NLAT + 1
      TSN = 2.D0/NLON
      FSN = 4.D0/NLON
      MODL = MOD(NLAT,2)
      IMM1 = IMID
      IF (MODL.NE.0) IMM1 = IMID - 1
      IF (ISYM.NE.0) GO TO 15
      DO 5 K = 1,NT
          DO 5 I = 1,IMM1
              DO 5 J = 1,NLON
                  GE(I,J,K) = TSN* (G(I,J,K)+G(NLP1-I,J,K))
                  GO(I,J,K) = TSN* (G(I,J,K)-G(NLP1-I,J,K))
    5 CONTINUE
      GO TO 30
   15 DO 20 K = 1,NT
          DO 20 I = 1,IMM1
              DO 20 J = 1,NLON
                  GE(I,J,K) = FSN*G(I,J,K)
   20 CONTINUE
      IF (ISYM.EQ.1) GO TO 27
   30 IF (MODL.EQ.0) GO TO 27
      DO 25 K = 1,NT
          DO 25 J = 1,NLON
              GE(IMID,J,K) = TSN*G(IMID,J,K)
   25 CONTINUE
   27 DO 35 K = 1,NT
          CALL DHRFFTF(LS,NLON,GE(1,1,K),LS,WHRFFT,WORK)
          IF (MOD(NLON,2).NE.0) GO TO 35
          DO 36 I = 1,LS
              GE(I,NLON,K) = .5D0*GE(I,NLON,K)
   36     CONTINUE
   35 CONTINUE
      DO 40 K = 1,NT
          DO 40 MP1 = 1,MMAX
              DO 40 NP1 = MP1,NLAT
                  A(MP1,NP1,K) = 0.D0
                  B(MP1,NP1,K) = 0.D0
   40 CONTINUE
      IF (ISYM.EQ.1) GO TO 145
      CALL DZFIN(2,NLAT,NLON,0,ZB,I3,WZFIN)
      DO 110 K = 1,NT
          DO 110 I = 1,IMID
              DO 110 NP1 = 1,NLAT,2
                  A(1,NP1,K) = A(1,NP1,K) + ZB(I,NP1,I3)*GE(I,1,K)
  110 CONTINUE
      NDO = NLAT
      IF (MOD(NLAT,2).EQ.0) NDO = NLAT - 1
      DO 120 MP1 = 2,MDO
          M = MP1 - 1
          CALL DZFIN(2,NLAT,NLON,M,ZB,I3,WZFIN)
          DO 120 K = 1,NT
              DO 120 I = 1,IMID
                  DO 120 NP1 = MP1,NDO,2
                      A(MP1,NP1,K) = A(MP1,NP1,K) +
     +                               ZB(I,NP1,I3)*GE(I,2*MP1-2,K)
                      B(MP1,NP1,K) = B(MP1,NP1,K) +
     +                               ZB(I,NP1,I3)*GE(I,2*MP1-1,K)
  120 CONTINUE
      IF (MDO.EQ.MMAX .OR. MMAX.GT.NDO) GO TO 135
      CALL DZFIN(2,NLAT,NLON,MDO,ZB,I3,WZFIN)
      DO 130 K = 1,NT
          DO 130 I = 1,IMID
              DO 130 NP1 = MMAX,NDO,2
                  A(MMAX,NP1,K) = A(MMAX,NP1,K) +
     +                            ZB(I,NP1,I3)*GE(I,2*MMAX-2,K)
  130 CONTINUE
  135 IF (ISYM.EQ.2) RETURN
  145 CALL DZFIN(1,NLAT,NLON,0,ZB,I3,WZFIN)
      DO 150 K = 1,NT
          DO 150 I = 1,IMM1
              DO 150 NP1 = 2,NLAT,2
                  A(1,NP1,K) = A(1,NP1,K) + ZB(I,NP1,I3)*GO(I,1,K)
  150 CONTINUE
      NDO = NLAT
      IF (MOD(NLAT,2).NE.0) NDO = NLAT - 1
      DO 160 MP1 = 2,MDO
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DZFIN(1,NLAT,NLON,M,ZB,I3,WZFIN)
          DO 160 K = 1,NT
              DO 160 I = 1,IMM1
                  DO 160 NP1 = MP2,NDO,2
                      A(MP1,NP1,K) = A(MP1,NP1,K) +
     +                               ZB(I,NP1,I3)*GO(I,2*MP1-2,K)
                      B(MP1,NP1,K) = B(MP1,NP1,K) +
     +                               ZB(I,NP1,I3)*GO(I,2*MP1-1,K)
  160 CONTINUE
      MP2 = MMAX + 1
      IF (MDO.EQ.MMAX .OR. MP2.GT.NDO) RETURN
      CALL DZFIN(1,NLAT,NLON,MDO,ZB,I3,WZFIN)
      DO 170 K = 1,NT
          DO 170 I = 1,IMM1
              DO 170 NP1 = MP2,NDO,2
                  A(MMAX,NP1,K) = A(MMAX,NP1,K) +
     +                            ZB(I,NP1,I3)*GO(I,2*MMAX-2,K)
  170 CONTINUE
      RETURN
      END

      SUBROUTINE DSHAECI(NLAT,NLON,WSHAEC,LSHAEC,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WSHAEC
      DIMENSION WSHAEC(LSHAEC)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IMID = (NLAT+1)/2
      MMAX = MIN0(NLAT,NLON/2+1)
      LZZ1 = 2*NLAT*IMID
      LABC = 3* ((MMAX-2)* (NLAT+NLAT-MMAX-1))/2
      IF (LSHAEC.LT.LZZ1+LABC+NLON+15) RETURN
      IERROR = 4
      IF (LDWORK.LT.NLAT+1) RETURN
      IERROR = 0
      CALL DZFINIT(NLAT,NLON,WSHAEC,DWORK)
      IW1 = LZZ1 + LABC + 1
      CALL DHRFFTI(NLON,WSHAEC(IW1))
      RETURN
      END


*> \brief \b DLASR applies a sequence of plane rotations to a general rectangular matrix.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
*       .. Scalar Arguments ..
*       CHARACTER          DIRECT, PIVOT, SIDE
*       INTEGER            LDA, M, N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   A( LDA, * ), C( * ), S( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLASR applies a sequence of plane rotations to a real matrix A,
*> from either the left or the right.
*>
*> When SIDE = 'L', the transformation takes the form
*>
*>    A := P*A
*>
*> and when SIDE = 'R', the transformation takes the form
*>
*>    A := A*P**T
*>
*> where P is an orthogonal matrix consisting of a sequence of z plane
*> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
*> and P**T is the transpose of P.
*>
*> When DIRECT = 'F' (Forward sequence), then
*>
*>    P = P(z-1) * ... * P(2) * P(1)
*>
*> and when DIRECT = 'B' (Backward sequence), then
*>
*>    P = P(1) * P(2) * ... * P(z-1)
*>
*> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
*>
*>    R(k) = (  c(k)  s(k) )
*>         = ( -s(k)  c(k) ).
*>
*> When PIVOT = 'V' (Variable pivot), the rotation is performed
*> for the plane (k,k+1), i.e., P(k) has the form
*>
*>    P(k) = (  1                                            )
*>           (       ...                                     )
*>           (              1                                )
*>           (                   c(k)  s(k)                  )
*>           (                  -s(k)  c(k)                  )
*>           (                                1              )
*>           (                                     ...       )
*>           (                                            1  )
*>
*> where R(k) appears as a rank-2 modification to the identity matrix in
*> rows and columns k and k+1.
*>
*> When PIVOT = 'T' (Top pivot), the rotation is performed for the
*> plane (1,k+1), so P(k) has the form
*>
*>    P(k) = (  c(k)                    s(k)                 )
*>           (         1                                     )
*>           (              ...                              )
*>           (                     1                         )
*>           ( -s(k)                    c(k)                 )
*>           (                                 1             )
*>           (                                      ...      )
*>           (                                             1 )
*>
*> where R(k) appears in rows and columns 1 and k+1.
*>
*> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
*> performed for the plane (k,z), giving P(k) the form
*>
*>    P(k) = ( 1                                             )
*>           (      ...                                      )
*>           (             1                                 )
*>           (                  c(k)                    s(k) )
*>           (                         1                     )
*>           (                              ...              )
*>           (                                     1         )
*>           (                 -s(k)                    c(k) )
*>
*> where R(k) appears in rows and columns k and z.  The rotations are
*> performed without ever forming P(k) explicitly.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] SIDE
*> \verbatim
*>          SIDE is CHARACTER*1
*>          Specifies whether the plane rotation matrix P is applied to
*>          A on the left or the right.
*>          = 'L':  Left, compute A := P*A
*>          = 'R':  Right, compute A:= A*P**T
*> \endverbatim
*>
*> \param[in] PIVOT
*> \verbatim
*>          PIVOT is CHARACTER*1
*>          Specifies the plane for which P(k) is a plane rotation
*>          matrix.
*>          = 'V':  Variable pivot, the plane (k,k+1)
*>          = 'T':  Top pivot, the plane (1,k+1)
*>          = 'B':  Bottom pivot, the plane (k,z)
*> \endverbatim
*>
*> \param[in] DIRECT
*> \verbatim
*>          DIRECT is CHARACTER*1
*>          Specifies whether P is a forward or backward sequence of
*>          plane rotations.
*>          = 'F':  Forward, P = P(z-1)*...*P(2)*P(1)
*>          = 'B':  Backward, P = P(1)*P(2)*...*P(z-1)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  If m <= 1, an immediate
*>          return is effected.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  If n <= 1, an
*>          immediate return is effected.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*>          C is DOUBLE PRECISION array, dimension
*>                  (M-1) if SIDE = 'L'
*>                  (N-1) if SIDE = 'R'
*>          The cosines c(k) of the plane rotations.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*>          S is DOUBLE PRECISION array, dimension
*>                  (M-1) if SIDE = 'L'
*>                  (N-1) if SIDE = 'R'
*>          The sines s(k) of the plane rotations.  The 2-by-2 plane
*>          rotation part of the matrix P(k), R(k), has the form
*>          R(k) = (  c(k)  s(k) )
*>                 ( -s(k)  c(k) ).
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          The M-by-N matrix A.  On exit, A is overwritten by P*A if
*>          SIDE = 'L' or by A*P**T if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup OTHERauxiliary
*
*  =====================================================================
      SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, PIVOT, SIDE
      INTEGER            LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( * ), S( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, J
      DOUBLE PRECISION   CTEMP, STEMP, TEMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
         INFO = 1
      ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
     $         'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
         INFO = 2
      ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
     $          THEN
         INFO = 3
      ELSE IF( M.LT.0 ) THEN
         INFO = 4
      ELSE IF( N.LT.0 ) THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASR ', INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
     $   RETURN
      IF( LSAME( SIDE, 'L' ) ) THEN
*
*        Form  P * A
*
         IF( LSAME( PIVOT, 'V' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 20 J = 1, M - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 10 I = 1, N
                        TEMP = A( J+1, I )
                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
   10                CONTINUE
                  END IF
   20          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 40 J = M - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 30 I = 1, N
                        TEMP = A( J+1, I )
                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
   30                CONTINUE
                  END IF
   40          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 60 J = 2, M
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 50 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
   50                CONTINUE
                  END IF
   60          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 80 J = M, 2, -1
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 70 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
   70                CONTINUE
                  END IF
   80          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 100 J = 1, M - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 90 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
   90                CONTINUE
                  END IF
  100          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 120 J = M - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 110 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
  110                CONTINUE
                  END IF
  120          CONTINUE
            END IF
         END IF
      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
*        Form A * P**T
*
         IF( LSAME( PIVOT, 'V' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 140 J = 1, N - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 130 I = 1, M
                        TEMP = A( I, J+1 )
                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
  130                CONTINUE
                  END IF
  140          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 160 J = N - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 150 I = 1, M
                        TEMP = A( I, J+1 )
                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
  150                CONTINUE
                  END IF
  160          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 180 J = 2, N
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 170 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
  170                CONTINUE
                  END IF
  180          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 200 J = N, 2, -1
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 190 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
  190                CONTINUE
                  END IF
  200          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 220 J = 1, N - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 210 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
  210                CONTINUE
                  END IF
  220          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 240 J = N - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 230 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
  230                CONTINUE
                  END IF
  240          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DLASR
*
      END


*+TO_ECLIP
        subroutine TO_ECLIP( ra, dec, jd, lambda, beta )

        implicit none

        double precision fox, fifteen
        parameter( fox = 2.415020d+06 )
        parameter( fifteen = 1.5d+01 )

        double precision ra, dec, jd, lambda, beta

*       Description:
*         Converts celestial coordinates (ra, dec), ra in decimal hours
*         and dec in decimal degrees, to ecliptic coordinates (lambda, beta)
*         for time = jd (unmodified Julian date)
*
*       Parameters/Arguments:
*         fox          (p) : JD at the beginning of the 20th century
*         fifteen      (p) : 15.0, in double precision
*         ra, dec      (i) : Celestial coordinates
*         jd           (i) : Time in unmodified Julian date
*         lambda, beta (o) : Ecliptic coordinates
*
*       Dependencies:
*         Duffet-Smith routine EQECL_DS below.
*
*       Origin:
*         KM's wrapper routine for DS library routine
*
*       Author:
*         Koji Mukai, 1993 Feb 08, First official release
*-TO_ECLIP

        double precision rad, djd

        djd = jd - fox
        rad = ra * fifteen
        call EQECL_DS( djd, rad, dec, +1, lambda, beta )

        end

*+FM_ECLIP
        subroutine FM_ECLIP( lambda, beta, jd, ra, dec )

        implicit none

        double precision fox, fifteen
        parameter( fox = 2.415020d+06 )
        parameter( fifteen = 1.5d+01 )

        double precision lambda, beta, jd, ra, dec

*       Description:
*         Reverse of TO_ECLIP above
*
*       Parameters/Arguments:
*         fox          (p) : JD at the beginning of the 20th century
*         fifteen      (p) : 15.0, in double precision
*         lambda, beta (i) : Ecliptic coordinates
*         jd           (i) : Time in unmodified Julian date
*         ra, dec      (o) : Celestial coordinates
*
*       Dependencies:
*         Duffet-Smith routine EQECL_DS below.
*
*       Origin:
*         KM's wrapper routine for DS library routine
*
*       Author:
*         Koji Mukai, 1993 Feb 08, First official release
*         Koji Mukai, 1993 Mar 16, ra and rad mix-up fixed.
*-TO_ECLIP

        double precision rad, djd

        djd = jd - fox
        call EQECL_DS( djd, lambda, beta, -1, rad, dec )
        ra = rad / fifteen

        end

*+EQECL_DS
        subroutine EQECL_DS( djd, x, y, switch, p, q )

        implicit none

        double precision deg2rad
        parameter( deg2rad = 1.74532925199433d-02 )
*                          = pi / 180, converts from degrees to radians

        double precision d_psi, d_eps, rcp, rsp, height
        common / astro1 / d_psi, d_eps, rcp, rsp, height

        double precision djd, x, y, p, q
        integer switch

*       Description:
*         Bottom level routine for Celestial/Ecliptic conversion
*
*       Common Block Variables/Arguments:
*         d_psi, d_eps    (c) : nutation parameters
*         rcp, rsp        (c) : Something to do with horizontal parallax
*         height          (c) : Obervatory altitude
*         djd             (i) : JD since beginning of 20th century
*         x, y            (i) : Input coordinates
*         switch          (i) : +1 for celestial to ecliptic, -1 for reverse
*         p, q            (o) : Output coorddinates
*
*       Dependencies:
*         SET_NUTATE, another D-S routine
*
*       Origin:
*         Duffet-Smith p.59
*
*       Author
*         Koji Mukai, 1993 Feb 08, first official release
*-EQECL_DS

        double precision t, c, eps, eps1, s_eps, c_eps
        double precision sy, cy, sx, cx, sq, a, ty

        call SET_NUTATE( djd )

*       from subroutine OBLIQ, p.51
        t = djd / 3.6525d+04
        c = ( ( ( -1.81d-03 * t ) + 5.9d-03 ) * t + 4.6845d+01 ) * t
	eps = 2.345229444d+01 - ( c / 3.6d+03 )
*       end of OBLIQ

        eps1 = eps + d_eps
        s_eps = sin( eps1 * deg2rad )
        c_eps = cos( eps1 * deg2rad )

        cy = cos( y * deg2rad )
        sy = sin( y * deg2rad )

        if( abs( cy ) .lt. 1.0d-20 ) cy = 1.0d-20
        ty = sy / cy
        cx = cos( x * deg2rad )
        sx = sin( x * deg2rad )
        sq = ( sy * c_eps ) - ( cy * s_eps * sx * switch )
        q = atan( sq / ( sqrt( 1.0d+00 - sq * sq ) + 1.0d-20 ) )
     &                                                         / deg2rad
        a = ( sx * c_eps ) + ( ty * s_eps * switch )
        p = atan( a / cx ) / deg2rad
        if( cx .lt. 0.0d+00 ) p = p + 1.8d+02
	if( p .gt. 3.6d+02 ) p = P - 3.6d+02
	if( p .lt. 0.0d+00 ) p = p + 3.6d+02

        end


      subroutine  elips	(x0,y0,a,b,alpha,theto,thetf)
C...subroutine	 elips	  01/09/78
      common /gftab/irdb(5),rdb(17)
      if((abs(a)+abs(b)).eq.0) go to 20
      alp=alpha*0.01745
      theo= theto*0.01745
      thef= thetf*0.01745
      d=a*b/sqrt((a*sin(theo))**2+(b*cos(theo))**2)
      xc = x0 -	d * cos(theo + alp)
      yc = y0 -	d * sin(theo + alp)
      bsq = b*b
      absq= a*a-bsq
      ab = a*b
      call move(x0,y0,0)
      fctr=rdb(17)/rdb(1)
      dthe=(0.1/(abs(a)+abs(b)))*fctr
      n	=(thef - theo)/dthe
      if(n) 6,5,7
   5  n	= -1
   6  n	= -n
      dthe = -dthe
   7  then = theo + dthe
      do 10 i=1,n
      st =sin(then)
      d	= ab/sqrt(absq*st*st+bsq)
      xf= xc+d*cos(then+alp)
      yf= yc+d*sin(then+alp)
      call move(xf,yf,1)
   10 then = then + dthe
      st= sin(thef)
      d= ab/sqrt(absq*st*st+bsq)
      xf= xc+d*cos(thef+alp)
      yf= yc+d*sin(thef+alp)
      call move(xf,yf,1)
   20 return
      end


      subroutine runY_00i(k,l,i1,Xtwiddle,Gtwiddle,Shat3,N0)
      implicit none
C---  Expression for Eq. 5.56b
C---  Calculates D00i1
C---  Requires D00l
C---  Small terms of order Xtwiddle(0,k)*Dli1,Xtwiddle(0,0)*Dkli1
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,i1,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat3(np,z2max,-2:0)

      if ((i1 .eq. l) .or. (i1 .eq. 0)) then
      return
      endif

      do ep=-2,0

      Dv(dzzi(i1)+N0,ep)=
     . (-2*Gtwiddle(k,i1)*Dv(dzzi(l)+N0,ep)
     . +Gtwiddle(k,1)*Shat3(1,z2(l,i1),ep)
     . +Gtwiddle(k,2)*Shat3(2,z2(l,i1),ep)
     . +Gtwiddle(k,3)*Shat3(3,z2(l,i1),ep)
     . +Xtwiddle(0,k)*Dv(dii(z2(l,i1))+N0,ep)
     . -Xtwiddle(0,0)*Dv(diii(z3(k,l,i1))+N0,ep))/(2*Gtwiddle(k,l))

      enddo

      return
      end


program CubicGLLTest

#include "LpmConfig.h"

use NumberKindsModule
use UtilitiesModule
use CubicGLLModule
use LoggerModule
use SphereGeomModule
use PlaneGeomModule

implicit none

real(kreal), dimension(3,4) :: planeVerts, sphereVerts
real(kreal), dimension(3) :: elXy
real(kreal), dimension(2) :: rcrd, dvec

character(len=56) :: logkey = "CubicGLLTest:"
character(len=MAX_STRING_LENGTH) :: logstring
integer(kint) :: i
real(kreal) :: xi, eta
type(Logger) :: exeLog

testPass = .TRUE.

call New(exeLog, DEBUG_LOGGING_LEVEL)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey), " start:")

planeVerts = dzero
planeVerts(1:2,1) = [4.0_kreal, 3.0_kreal]
planeVerts(1:2,2) = [2.0_kreal, 2.0_kreal]
planeVerts(1:2,3) = [5.0_kreal, 1.0_kreal]
planeVerts(1:2,4) = [8.0_kreal, 3.0_kreal]

elXy = bilinearMap(planeVerts, -one, one)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "bilinearMap(-1,1) |error| = ", &
    sqrt(sum( (elxy-planeVerts(:,1))*(elxy-planeVerts(:,1)))))
if ( sqrt(sum( (elxy-planeVerts(:,1))*(elxy-planeVerts(:,1)))) > ZERO_TOL ) then
    write(logstring,'(2(A,G18.8),A)') "bilinearMap(-1,1) = (", elXy(1), ", ", elXy(1), "); correct solution is (4,3)"
    call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logkey)//" ", logstring)
    testPass = .FALSE.
endif

elXy = bilinearMap(planeVerts, -one, -one)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "bilinearMap(-1,-1) |error| = ", &
    sqrt(sum( (elxy-planeVerts(:,2))*(elxy-planeVerts(:,2)))))
if ( sqrt(sum( (elxy-planeVerts(:,2))*(elxy-planeVerts(:,2)))) > ZERO_TOL ) then
    write(logstring,'(2(A,G18.8),A)') "bilinearMap(-1,-1) = (", elXy(1), ", ", elXy(1), "); correct solution is (2,2)"
    call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logkey)//" ", logstring)
    testPass = .FALSE.
endif

elXy = bilinearMap(planeVerts, one, -one)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "bilinearMap(1,-1) |error| = ", &
    sqrt(sum( (elxy-planeVerts(:,3))*(elxy-planeVerts(:,3)))))
if ( sqrt(sum( (elxy-planeVerts(:,3))*(elxy-planeVerts(:,3)))) > ZERO_TOL ) then
    write(logstring,'(2(A,G18.8),A)') "bilinearMap(1,-1) = (", elXy(1), ", ", elXy(1), "); correct solution is (5,1)"
    call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logkey)//" ", logstring)
    testPass = .FALSE.
endif

elXy = bilinearMap(planeVerts, one, one)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "bilinearMap(1,1) |error| = ", &
    sqrt(sum( (elxy-planeVerts(:,4))*(elxy-planeVerts(:,4)))))
if ( sqrt(sum( (elxy-planeVerts(:,4))*(elxy-planeVerts(:,4)))) > ZERO_TOL ) then
    write(logstring,'(2(A,G18.8),A)') "bilinearMap(1,1) = (", elXy(1), ", ", elXy(1), "); correct solution is (8,3)"
    call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logkey)//" error: ", logstring)
    testPass = .FALSE.
endif

elxy = [19.0_kreal, 9.0_kreal, dzero] * 0.25_kreal
rcrd = invertBilinear(planeVerts, elXy)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "invertBilinear(19/4,9/4) |error| = ", sqrt(sum(rcrd*rcrd)))
if (sqrt(sum(rcrd*rcrd)) > ZERO_TOL) then
    write(logstring,'(A,2G15.8,A)') 'invertBilinear([19/4,9/4,0]) = (', rcrd, "); correct solution is (0,0)"
    call LogMessage(exeLog,ERROR_LOGGING_LEVEL,trim(logkey)//" error: ", logstring)
    testPass = .FALSE.
endif

call RANDOM_SEED()
do i=1, 100
    call RANDOM_NUMBER(xi)
    call RANDOM_NUMBER(eta)
    xi = 2.0_kreal * xi - one
    eta = 2.0_kreal * eta - one
    elXy = bilinearMap(planeVerts, xi, eta)
    rcrd = invertBilinear(planeVerts, elXy)
    dvec(1) = rcrd(1) - xi
    dvec(2) = rcrd(2) - eta
    if (sqrt(sum(dvec*dvec)) > ZERO_TOL) then
        write(logstring,'(2(A,G15.8),2(A,2G15.8),a)') 'invertBilinear([', xi, ',',eta,  ']) = (', rcrd, &
               '); correct solution is (', xi, eta, ')'
        call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey)// " error: ", logstring)
        testPass = .FALSE.
    endif
enddo
if (testPass) call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey)//" result: ", "PASSED")

end program


      subroutine tridig (u,n,a,b,c,d,kode,ier)
C...subroutine     tridig    01/09/73
C...subroutine     tridig    01/09/78
      dimension u(n),a(n),b(n),c(n),d(n)
      ier=0
      al=0.
      bt=0.
      gm=1.
      n1=n-1
      if (b(1).ne.0.) goto 2
      ier=1
      return
   2  do 5 i=1,n1
      s=a(i)*al+b(i)
      if(s.eq.0.) goto 4
      s1=1./s
      al=-c(i)*s1
      bt=(d(i)-a(i)*bt)*s1
      gm=-a(i)*gm*s1
      a(i)=al
      b(i)=bt
   5  c(i)=gm
      if (kode.eq.1) goto 8
      u(n)=(d(n)-a(n)*bt)/(a(n)*al+b(n))
      do 7 i=1,n1
    7 u(n-i)=a(n-i)*u(n-i+1)+b(n-i)
      return
   8  t=1.
      v=0.
      do 9 i=1,n1
      t=a(n-i)*t+c(n-i)
      v=a(n-i)*v+b(n-i)
      a(n-i)=t
   9  b(n-i)=v
      u(n)=(d(n)-c(n)*b(2)-a(n)*b(n-1))/(b(n)+c(n)*a(2)+a(n)*a(n-1))
      do 10 i=1,n1
  10  u(n-i)=a(n-i)*u(n)+b(n-i)
      return
   4  ier=2
      return
      end