!======================================================================================================
! July 2017: G.K.Stephens (Grant.Stephens@jhuapl.edu)
! This program demonstrates how to setup and evaluate the Tsyganenko and Sitnov [2007] (TS07D)
! empirical geomagnetic field model and how to setup and evaluate the IGRF-12 model included
! in Tsyganenko's GEOPACK package.
!
! This July 2017 update incorporates an upgraded version of the Bessel function evaluator,
! provided by Jay Albert, which significantly speeds up the model. We thank Jay Albert for these
! contributions.
!
! Additionally, the model subroutine was updated to be a double precision subroutine.
! To indicate the update, the subroutine was renamed from EXTMODEL to TS07D_JULY_2017.
!
! To compile this code with GFortran, use:
! gfortran ts07d_geopack_example_july2017update.for -o ts07d_geopack_example_july2017update
! and to run: ./ts07d_geopack_example_july2017update
!======================================================================================================
Program   TS07D
implicit none

!     Inputs to the model
INTEGER   IOPT
REAL*8  PARMOD(10), XGSM,YGSM,ZGSM

!     Input parameters that will be passed through the common block
INTEGER    NTOT
PARAMETER (NTOT=101)
REAL*8 PDYN,PARAMS(NTOT),TSS,TSO,TSE
COMMON /PARAM/ PARAMS
COMMON /INPUT/  PDYN
COMMON /TSS/ TSS(80,5)
COMMON /TSO/ TSO(80,5,4)
COMMON /TSE/ TSE(80,5,4)

!     Set up the Geopack common block
REAL*8 AAA,BBB,PSI ! the dipole tilt
COMMON /GEOPACK1/ AAA(15),PSI,BBB(18)

!     Output parameters for TS07D and IGRF models
REAL*8 BXGSM,BYGSM,BZGSM, HXGSM,HYGSM,HZGSM

!     STATICDIR is the directory that contains the static shielding coefficients
CHARACTER(1024) :: STATICDIR
!    VARIABLEDIR is the directory where the variable coefficient directories will be
CHARACTER(1024) :: VARIABLEDIR

!     The meta data included in the .par file
REAL*8 COEFF_Q, COEFF_B_RMS,TILT
INTEGER M_INX,N_INX

CHARACTER(1024) :: FILENAME

character(16) :: argv
integer :: ierr

REAL*8 VXGSE,VYGSE,VZGSE,PI
INTEGER KK,IREAD,KREAD
INTEGER IYEAR,IDAY,IHOUR,MIN,ISEC

staticdir = "@ts07d_static_dir@"  !'./ts07d_tail_par/'
variabledir = "@ts07d_variable_dir@" ! './ts07_coeff/'

!     The following reads the static coefficients that are used for the Equatorial Field
!     shielding fields. These only need to be loaded once as they are common for all times.
      DO 1001 IREAD=1,5
        WRITE(filename,'(A,A,I0,A)') TRIM(STATICDIR),'/tailamebhr',IREAD,'.par'
      OPEN (UNIT=1,FILE=FILENAME)
      READ (1,200) (TSS(KK,IREAD),KK=1,80)
 200  FORMAT(G17.10)
 1001 CLOSE(1)

      DO 1002 IREAD=1,5
        DO 1003 KREAD=1,4
        WRITE(filename,'(A,A,I0,I0,A)') TRIM(STATICDIR),'/tailamhr_o_',IREAD,KREAD,'.par'
      OPEN (UNIT=1,FILE=FILENAME)
      READ (1,200) (TSO(KK,IREAD,KREAD),KK=1,80)
 1003   CONTINUE
 1002 CLOSE(1)

      DO 1004 IREAD=1,5
        DO 1005 KREAD=1,4
        WRITE(filename,'(A,A,I0,I0,A)') TRIM(STATICDIR),'/tailamhr_e_',IREAD,KREAD,'.par'
      OPEN (UNIT=1,FILE=FILENAME)
      READ (1,200) (TSE(KK,IREAD,KREAD),KK=1,80)
 1005   CONTINUE
 1004 CLOSE(1)

!     Now, initialize the TS07D and IGRF models for the supplied date and time. If multiple times
!     are wanted, the following must be recalled for the new date and time.

!     The date and time is specified by the year, day of year (1-366), hour (0-23), minute (0-59),
!     and the second (0-59), note that the second field is not used for accessing the variable
!     parameter and coefficients file.
IYEAR = 2015
IDAY = 75
IHOUR = 12
MIN = 35
ISEC = 0

!     Use the date and time fields to construct the variable parameter and coefficients file.
!     Or, if preferred, you could hardcode the path as:
!     filename = '/Users/username/Downloads/2015_075/2015_075_12_35.par'
WRITE(filename,'(A,I0.4,A,I0.3,A,I0.4,A,I0.3,A,I0.2,A,I0.2,A)') &
      TRIM(VARIABLEDIR), IYEAR,'_',IDAY,'/',IYEAR,'_',IDAY,'_',IHOUR,'_',MIN,'.par'

!     Now read variable parameter and coefficients file, the variable parameters and coefficients
!     are stored in the array PARAMS. Additionaly, the dynamic pressure and the dipole tilt angle
!     are stored in PDYN and TILT respectively. All of these are variable or time-dependent values.
!     The other values stored in the file are not currently being used.
OPEN (UNIT=1,FILE=filename,action='read') ! open the filed
READ (1,100) (PARAMS(IREAD),IREAD=1,NTOT) ! read the variable coefficients and parameters
READ (1,101) COEFF_Q ! the Q factor, related to chi squared, a measure of the goodness of fit
READ (1,101) COEFF_B_RMS
READ (1,102) M_INX ! the number of azimuthal expansions in the equatorial field module (M=4)
READ (1,102) N_INX ! the number of radial expansions in the equatorial field module (N=5)
READ (1,101) PDYN ! the dynamic pressure for this time
READ (1,101) TILT ! the dipole tilt for this time
 100  FORMAT(G15.6)
 101  FORMAT(7x,G15.6)
 102  FORMAT(7x,I15)
CLOSE(1)

!     To get the IGRF model in GSM coordinates, set the solar wind velocity vector to the following
VXGSE=-400.d0
VYGSE=   0.d0
VZGSE=   0.d0
!     initializes the Geopack package for the supplied date and time
call RECALC_08 (IYEAR,IDAY,IHOUR,MIN,ISEC,VXGSE,VYGSE,VZGSE)

!     Now the TS07D and the IGRF model can be evaluated

!     or just code in the values, e.g. XGSM = 5.0d0, units are in Earth radii (1 RE=6371.2 KM).
if (command_argument_count() /= 3) error stop '  Enter S/C position: XGSM,YGSM,ZGSM '
call get_command_argument(1, argv)
read(argv, '(F9.3)', iostat=ierr) xgsm
call get_command_argument(2, argv)
read(argv, '(F9.3)', iostat=ierr) ygsm
call get_command_argument(3, argv)
read(argv, '(F9.3)', iostat=ierr) zgsm

if (ierr/=0) error stop '  Enter S/C position: XGSM,YGSM,ZGSM '

!     Evaluate the IGRF model in GSM coordinates
CALL IGRF_GSW_08 (XGSM,YGSM,ZGSM,HXGSM,HYGSM,HZGSM)

IOPT = 0 ! the whole external magnetic field model (almost always what you want)
!     Now evaluate the TS07D model, note that we have two variables holding the dipole tilt,
!     PSI which comes from Geopack and TILT which comes from the variables file, which
!     ultimately also was computed using Geopack. So use either one.
CALL TS07D_JULY_2017 (IOPT,PARMOD,PSI,XGSM,YGSM,ZGSM, BXGSM,BYGSM,BZGSM)

PRINT *,'     Main field (nT):'
PRINT '(3A10)','HXGSM','HYGSM','HZGSM'
print '(3F10.3,/)',HXGSM,HYGSM,HZGSM
PRINT *,'   External field (nT):'
PRINT '(3A10)','BXGSM','BYGSM','BZGSM'
print '(3F10.3,/)', BXGSM,BYGSM,BZGSM

PI = 4*ATAN(1.)
PRINT '(A, F10.2)', 'Geodipole tilt (degrees):', PSI*180/PI

END program


c=======================================================================
c
c     Linear Algebra - Level 3 BLAS Routines Interfaces
c
c-----------------------------------------------------------------------
c
c  (A)
c        ACMI    : matrix sorted by index-columns
c        ALMI    : matrix sorted by index-rows
c  (O)
c        OMCDMCT : C(n,n) <- M(n,n)*D(n)*M'(n,n)
c        OMCTQMC : C(n,n) <- M'(n,n)*Q(n,n)*M(n,n)
c        OMDMT   : C(n,n) <- M(n,m)*D(m)*M'(n,m)
c        OVTMCV  : alpha  <- V(n)'*M(n,n)*V(n)
c  (P)
c        PM      : matrix product, C(m,n) <- A(m,k)*B(k,n)
c        PMC     : matrix product, C(n,n) <- A(n,n)*B(n,n)
c        PMDV    : matrix product, C(n,n) <- A(n,n)*diag(D(n))
c        PMMT    : matrix product, C(m,n) <- A(m,k)*B'(n,k)
c        PMRM    : matrix product, C(n,n) <- A(n,m)*A'(n,m)
c        PMS     : matrix product, C(n,n) <- A(n*(n+1)/2)*B(n*(n+1)/2), A, B symmetric matrices
c        PMS2    : matrix product, C(n*(n+1)/2) <- A(n*(n+1)/2)*A(n*(n+1)/2), A, C symmetric
c        PMTM    : matrix product, C(n,m) <- A'(k,n)*B(k,m)
c        PRMM    : matrix product, C(m,m) <- A'(n,m)*A(n,m)
c  (R)
c        RM      : matrix transpose M'(m,n) <- M(n,m)
c
c=======================================================================
c
c     subroutine ACMI
c
c     Matrix sorted by index-columns
c
c-----------------------------------------------------------------------
      SUBROUTINE ACMI ( n, m, A, ind, C )
c-----------------------------------------------------------------------
c
c     INPUT
c       n   : number of rows                                     integer
c       m   : number of columns                                  integer
c       A   : input matrix (n*m)                                  double
c       ind : indices of columns to sort (m)                     integer
c
c     OUTPUT
c       C   : sorted matrix (n*m)                                 double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, m, ind(*), i, j
      DOUBLE PRECISION A(n,*), C(n,*)
      DO j = 1,m
         DO i = 1,n
            C(i,j) = A(i,ind(j))
         ENDDO
      ENDDO
      RETURN
      END
c
c=======================================================================
c
c     subroutine ALMI
c
c     Matrix sorted by index-rows
c
c-----------------------------------------------------------------------
      SUBROUTINE ALMI ( n, m, A, ind, C )
c-----------------------------------------------------------------------
c
c     INPUT
c       n   : number of rows                                     integer
c       m   : number of columns                                  integer
c       A   : input matrix (n*m)                                  double
c       ind : indices of rows to sort (n)                        integer
c
c     OUTPUT
c       C   : sorted matrix (n*m)                                 double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, m, ind(*), i, j
      DOUBLE PRECISION A(n,*), C(m,*)
      DO j = 1,m
         DO i = 1,n
            C(i,j) = A(ind(i),j)
         ENDDO
      ENDDO
      RETURN
      END
c
c=======================================================================
c
c     subroutine OMCDMCT
c
c     C(n,n) <- M(n,n)*D(n)*M(n,n)', D vector n of diagonal matrix
c
c-----------------------------------------------------------------------
      SUBROUTINE OMCDMCT ( n, M, D, mwork, C )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : size of the matrix                              integer
c       M      : input square matrix M (n*n)                      double
c       D      : vector of the diagonal matrix D (n)              double
c
c     WORKSPACE
c       mwork  : matrix (n*n)                                     double
c
c     OUTPUT
c       C      : output matrix (n*n)                              double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
      INTEGER n
      DOUBLE PRECISION D(*), M(n,*), mwork(n,*), C(n,*)
c
      INTEGER i, j
      DOUBLE PRECISION alpha, beta
      PARAMETER ( alpha = 1.D0, beta = 0.D0)
c
c-----------------------------------------------------------------------
c
c     mat(n,n) = M(n,n)*D(n) (D : diagonal matrix )
      DO j = 1,n
         DO i = 1,n
            mwork(i,j) = M(i,j)*D(j)
         ENDDO
      ENDDO
c
c     DGEMM  performs one of the matrix-matrix operations
c     out -> (M*Q)*M'
      CALL DGEMM ('N', 'T', n, n, n, alpha, mwork, n, M, n, beta, C, n)
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine OMCTQMC
c
c     C(n,n) <- M'(n,n)*Q(n,n)*M(n,n)
c
c-----------------------------------------------------------------------
      SUBROUTINE OMCTQMC ( n, M, Q, mwork, C )
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
      INTEGER n
      DOUBLE PRECISION Q(*), M(n,*), mwork(n,*), C(n,*)
      DOUBLE PRECISION alpha, beta
      PARAMETER ( alpha = 1.D0, beta = 0.D0)
c     DGEMM  performs one of the matrix-matrix operations
c     out -> M'Q
      CALL DGEMM ('T', 'N', n, n, n, alpha, M, n, Q, n, beta, mwork, n)
c     out -> (M'Q)*M
      CALL DGEMM ('N', 'N', n, n, n, alpha, mwork, n, M, n, beta, C, n)

      RETURN
      END
c
c=======================================================================
c
c     subroutine OMDMT
c
c     C(n,n) <- A(n,m)*D(m)*A'(n,m), D vector m of diagonal matrix
c
c-----------------------------------------------------------------------
      SUBROUTINE OMDMT ( n, m, A, D, mwork, C )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : size 1 of the matrix A (number of rows)         integer
c       m      : size 2 of the matrix A (number of columns)      integer
c       A      : input square matrix A (n*m)                      double
c       D      : vector of the diagonal matrix D (m)              double
c
c     WORKSPACE
c       mwork  : matrix (n*m)                                     double
c
c     OUTPUT
c       C      : output square matrix (n*n)                       double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
      INTEGER n, m
      DOUBLE PRECISION D(*), A(n,*), mwork(n,*), C(n,*)
c
      INTEGER i, j
      DOUBLE PRECISION alpha, beta
      PARAMETER ( alpha = 1.D0, beta = 0.D0)
c
c-----------------------------------------------------------------------
c
c     mat = A*D ( A=matin, D=diag : diagonal matrix )
c
      DO j = 1,m
         DO i = 1,n
            mwork(i,j) = A(i,j)*D(j)
         ENDDO
      ENDDO
c
c     DGEMM  performs one of the matrix-matrix operations
c     out -> (A*D)*A'
      CALL DGEMM ('N', 'T', n, n, m, alpha, mwork, n, A, n, beta, C, n)
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine OVTMCV
c
c     a (scalar) = V'(n)*M(n,n)*V(n) = (M'(n,n)*V(n))'*V(n)
c
c-----------------------------------------------------------------------
      SUBROUTINE OVTMCV ( n, M, V, a )
c-----------------------------------------------------------------------
c
c     INPUT
c       n   : size of the matrix and vector                      integer
c       M   : matrix as vector (n*n)                              double
c       V   : vector (n)                                          double
c
c     OUTPUT
c       a   : V'*M*V                                              double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n
      DOUBLE PRECISION a, M(n,*), V(*)
c
c     local variables
      INTEGER i,j
      DOUBLE PRECISION sum
c
c-----------------------------------------------------------------------
c
      a = 0.0
      DO i = 1,n
         sum = 0.0
         DO j = 1,n
            sum = sum + M(i,j)*V(j)
         ENDDO
         a = a + V(i)*sum
      ENDDO
      RETURN
      END
c
c=======================================================================
c
c     subroutine PM
c
c     General matrix product: C(m,n) <-  A(m,k)*B(k,n)
c
c-----------------------------------------------------------------------
      SUBROUTINE PM ( m, k, n, A, B, C )
c-----------------------------------------------------------------------
c
c     INPUT
c       m : size 1 of the matrix 1 (number of rows)              integer
c       k : size 2 of the matrix 1 (number of columns)           integer
c           = size 1 of the matrix 2
c       n : size 2 of the matrix 2 (number of columns)           integer
c       A : matrix as vector(m*k)                                 double
c       B : matrix as vector(k*n)                                 double
c
c     OUTPUT
c       C : A*B matrix as vector(m*n)                             double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, m, k
      DOUBLE PRECISION A(m,*), B(k,*), C(m,*)
      DOUBLE PRECISION alpha, beta
      PARAMETER (alpha = 1.D0, beta = 0.D0)
c
c     C = A*B
      CALL DGEMM ('N', 'N', m, n, k, alpha, A, m, B, k, beta, C, m)
      RETURN
      END
c
c=======================================================================
c
c     subroutine PMC
c
c     matrix product, C(n,n) <-  A(n,n)*B(n,n)
c
c-----------------------------------------------------------------------
      SUBROUTINE PMC ( n, A, B, C )
c-----------------------------------------------------------------------
c
c     INPUT
c       n : size of matrix                                       integer
c       A : matrix as vector(n*n)                                 double
c       B : matrix as vector(n*n)                                 double
c
c     OUTPUT
c       C : A*B matrix as vector(n*n)                             double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n
      DOUBLE PRECISION A(n,*), B(n,*), C(n,*)
c
      CALL PM ( n, n, n, A, B, C )
      RETURN
      END
c=======================================================================
c
c     subroutine PMDV
c
c     matrix product, C(n,n) <- A(n,n)*diag(D(n))
c
c-----------------------------------------------------------------------
      SUBROUTINE PMDV(n, D, A, dwork, C)
c-----------------------------------------------------------------------
c
c     INPUT
c       n     : matrix size                                      integer
c       D     : vector (n)                                        double
c       A     : matrix (n*n)                                      double
c
c     WORKSPACE
c       dwork : n*n                                               double
c
c     OUTPUT
c       C     : matrix (n*n)                                      double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n
      DOUBLE PRECISION D(*), A(*), C(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     transforming a vector in a diagonalized matrix
      CALL CVMD ( n, D, dwork(1))
c
c     B(n,n) <- A(n,n)*D(n,n)
      CALL PMC(n, A, dwork(1), C)
      RETURN
      END
c
c=======================================================================
c
c     subroutine PMMT
c
c     matrix product, C(n,m) = A(n,k)*B'(m,k)
c
c-----------------------------------------------------------------------
      SUBROUTINE PMMT ( n, k, m, A, B, C )
c-----------------------------------------------------------------------
c
c     INPUT
c       n : size 1 of the matrix 1 (number of rows)              integer
c       k : size 2 of the matrix 1 (number of columns)           integer
c       m : size 1 of the matrix 2 (number of rows)              integer
c       A : matrix as vector(n*k)                                 double
c       B : matrix as vector(m*k)                                 double
c
c     OUTPUT
c       C : A*B' matrix as vector(n*m)                            double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, m, k
      DOUBLE PRECISION A(n,*), B(m,*), C(n,*)
      DOUBLE PRECISION alpha, beta
      PARAMETER (alpha = 1.D0, beta = 0.D0)
c
c     C(m,n) = A(m,k)*B'(n,k)
      CALL DGEMM ('N', 'T', n, m, k, alpha, A, n, B, m, beta, C, n)
      RETURN
      END
c
c=======================================================================
c
c     subroutine PMRM
c
c     matrix product, C(n,n) <- A(n,m)*A'(n,m)
c
c-----------------------------------------------------------------------
      SUBROUTINE PMRM ( n, m, A, C )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : size 1 of the matrix 1 (number of rows)         integer
c       m      : size 2 of the matrix 1 (number of columns)      integer
c       A      : matrix (n*m)                                     double
c
c     OUTPUT
c       C  : matrix (n*n)                                         double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
      INTEGER n, m
      DOUBLE PRECISION A(n,*), C(n,*)
      DOUBLE PRECISION alpha, beta
      PARAMETER ( alpha = 1.D0, beta = 0.D0)
c
c     C(n,n) = A(n,m)*A(n,m)'
      CALL DGEMM ('N', 'T', n, n, m, alpha, A, m, A, m, beta, C, n)
      RETURN
      END
c
c=======================================================================
c
c     subroutine PMS
c
c     matrix product, C(n,n) <- A(n*(n+1)/2)*B(n*(n+1)/2), A, B symmetric matrices
c
c-----------------------------------------------------------------------
      SUBROUTINE PMS ( n, A, B, C )
c-----------------------------------------------------------------------
c
c     INPUT
c       n : matrix size                                          integer
c       A : symmetric matrix (n*(n+1)/2)                          double
c       B : symmetric matrix (n*(n+1)/2)                          double
c
c     OUTPUT
c       C : matrix (n*n)                                          double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, i, j, k, iv1, iv2, im, jm, incv1, incv2
      DOUBLE PRECISION sum, A(*), B(*), C(n,*)
      im = 1
      DO i = 1,n
         jm = 1
         DO j = 1,n
            sum = 0.0
            incv1 = 2*i - 1
            incv2 = 2*j - 1
            DO k = 1,n
               iv1 = im
               IF (k .LE. i) THEN
                  iv1 = iv1 + k - 1
               ELSE
                  iv1 = iv1 + incv1
                  incv1 = incv1 + k
               ENDIF
               iv2 = jm
               IF (k .LE. j) THEN
                  iv2 = iv2 + k - 1
               ELSE
                  iv2 = iv2 + incv2
                  incv2 = incv2 + k
               ENDIF
               sum  = sum + A(iv1) * B(iv2)
            ENDDO
            C(i,j) = sum
            jm = jm + j
         ENDDO
         im = im + i
      ENDDO
      RETURN
      END
c
c=======================================================================
c
c     subroutine PMS2
c
c     matrix product, C(n*(n+1)/2) <- A(n*(n+1)/2)*A(n*(n+1)/2)
c     A and C symmetric
c
c-----------------------------------------------------------------------
      SUBROUTINE PMS2 ( n, A, C )
c-----------------------------------------------------------------------
c
c     INPUT
c       n : matrix size                                          integer
c       A : symmetric matrix (n*(n+1)/2)                          double
c     OUTPUT
c       C : symmetric matrix (n*(n+1)/2)                          double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, i, j, k, k2, iv1, iv2, im, jm, incv1, incv2
      DOUBLE PRECISION sum, A(*), C(*)
      k2 = 1
      im = 1
      DO i = 1,n
         jm = 1
         DO j = 1,i
            sum = 0.0
            incv1 = 2*i - 1
            incv2 = 2*j - 1
            DO k = 1,n
               iv1 = im
               IF (k .LE. i) THEN
                  iv1 = iv1 + k - 1
               ELSE
                  iv1 = iv1 + incv1
                  incv1 = incv1 + k
               ENDIF
               iv2 = jm
               IF (k .LE. j) THEN
                  iv2 = iv2 + k - 1
               ELSE
                  iv2 = iv2 + incv2
                  incv2 = incv2 + k
               ENDIF
               sum  = sum + A(iv1) * A(iv2)
            ENDDO
            C(k2) = sum
            k2 = k2 + 1
            jm = jm + j
         ENDDO
         im = im + i
      ENDDO
      RETURN
      END
c
c=======================================================================
c
c     subroutine PMTM
c
c     matrix product, C(n,m) <- A'(k,n)*B(k,m)
c
c-----------------------------------------------------------------------
      SUBROUTINE PMTM ( k, n, m, A, B, C )
c-----------------------------------------------------------------------
c
c     INPUT
c       k : size 1 of the matrix 1 (number of rows)              integer
c       n : size 2 of the matrix 1 (number of columns)           integer
c       m : size 2 of the matrix 2 (number of columns)           integer
c       A : matrix as vector(k*n)                                 double
c       B : matrix as vector(k*m)                                 double
c
c     OUTPUT
c       C  : A'*B, matrix as vector(n*m)                          double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER k, n, m
      DOUBLE PRECISION A(k,*), B(k,*), C(n,*)
      DOUBLE PRECISION alpha, beta
      PARAMETER (alpha = 1.D0, beta = 0.D0)
c
c     C(n,m) = A'(k,n)*B(k,m)
      CALL DGEMM ('T', 'N', n, m, k, alpha, A, k, B, k, beta, C, n)
      RETURN
      END
c
c=======================================================================
c
c     subroutine PRMM
c
c     matrix product, C(m,m) <- A'(n,m)*A(n,m)
c
c-----------------------------------------------------------------------
      SUBROUTINE PRMM ( n, m, A, C )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : size 1 of the matrix 1 (number of rows)    integer
c            m      : size 2 of the matrix 1 (number of columns) integer
c                     = size 2 of the matrix 2
c            A      : matrix (n*m)                                double
c
c     OUTPUT
c            C  : A'*A matrix (m*m)                               double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, m
      DOUBLE PRECISION A(n,*), C(m,*)
      DOUBLE PRECISION alpha, beta
      PARAMETER ( alpha = 1.D0, beta = 0.D0)
c
c     C(m,m) = A'(n,m)*A(n,m)
      CALL DGEMM ('T', 'N', m, m, n, alpha, A, n, A, n, beta, C, m)
      RETURN
      END
c
c=======================================================================
c
c     subroutine RM
c
c     matrix transpose, A'(m*n) <- A(n,m)
c
c-----------------------------------------------------------------------
      SUBROUTINE RM ( n, m, A, tA )
c-----------------------------------------------------------------------
c
c     INPUT
c       n   : number of rows                                     integer
c       m  : number of columns                                   integer
c       A  : matrix (n*m)                                         double
c
c     OUTPUT
c       tA : transpose matrix (m*n)                               double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, m, i, j
      DOUBLE PRECISION A(n,*), tA(m,*)
      DO j = 1,m
         DO i = 1,n
            tA(j,i) = A(i,j)
         ENDDO
      ENDDO
      RETURN
      END


c
c	transformation matrix t4=<-mu,Y>
c
c	iverse = 1 forward transform
c	       =-1 inverse transform
c
	subroutine t4 (itime,x_in,x_out,iverse)
	real x_in(3),x_out(3),mu,q_c(3)
	integer*4 itime(2),iverse
c
	call get_q_c(itime,q_c)
c
	mu=-atan(q_c(1)/sqrt(q_c(2)*q_c(2)+q_c(3)*q_c(3)))
	call rotate_y(iverse*mu,x_in,x_out)
c
	return
	end


program atomic
use iso_fortran_env
implicit none

integer :: me,np,res
integer(atomic_int_kind) :: atom[*]

me = this_image()
np = num_images()

call atomic_define(atom[1],0)

sync all

call ATOMIC_ADD (atom[1], me)

sync all

if(me == 1) then
  call atomic_ref(res,atom[1])
  if(res /= (np*(np+1))/2) then
    write(*,*) 'res',res
    error stop "Atomic ref failed"
  endif
  write(*,*) 'OK'
endif

sync all

if (me == 1) then
   write(*,*) "Test passed"
end if

end program


subroutine p2R(parameters)
    use nrtype;use dimensions
    implicit none
    real(SP),dimension(parameters_to_est),intent(inout)::parameters

    parameters=(/log(parameters(1)-1.0_sp), & !RRA consumption
                 log(parameters(2)), & !av money transfer at floor h=1
                 parameters(3), & !shifter h=2
                 parameters(4), & !shifter h=3
                 parameters(5), & !shifter h=4
                 log(parameters(6)), & !beq curvature
                 log(parameters(7)-1.0_sp),& !RRA LTC
                 parameters(8), & !bequest intensity (F=1)
                 parameters(9), & !bequest intensity (F=2)
                 log(parameters(10)/(1.0_sp-parameters(10))), & !share from CES
                 log(1.0_sp-parameters(11))/) !subtitution parameter

end subroutine

subroutine R2p(parameters,parameters_n)
    use nrtype;use dimensions; use structural_p2; use structural_p1
    implicit none
    real(SP),dimension(parameters_to_est),intent(in)::parameters
    real(SP),dimension(parameters_to_est),intent(out)::parameters_n
    integer::h_l,f_l
    real(SP)::mu_av,l_fc,c

    !Tranform parameters from the real line
    parameters_n(1)=exp(parameters(1))+1.0_sp !RRA consumption
    parameters_n(2)=exp(parameters(2)) !av money transfer at floor h=1
    parameters_n(3:5)=parameters(3:5) !shifter h=2,3,4
    parameters_n(6)=exp(parameters(6))  !beq curvature
    parameters_n(7)=exp(parameters(7))+1.0_sp !RRA LTC
    parameters_n(8:9)=parameters(8:9)  !bequest intensity
    parameters_n(10)=1.0_sp/(1.0_sp+exp(-parameters(10))) !share parameter
    parameters_n(11)=1.0_sp-exp(parameters(11))!share parameter

    !Set parameters
    sigma=parameters_n(1)
    x_bar(1)=parameters_n(2)
    alpha_mu(1:3)=parameters_n(3:5)
    delta(1:f_t)=parameters_n(6)
    nu=parameters_n(7)
    lambda(1:f_t)=exp(parameters_n(8:9))
    share_p=parameters_n(10)
    subs_p=parameters_n(11)

    sigma_beq=sigma
    beta=0.95_sp
    omega=1.0_sp
    kappa_h=0.0_sp
    delta_h=1.0_sp

    !Utility at the floor when healthy
    do h_l=1,1
        call solve_intratemporal(p_fc,x_bar(h_l),h_l,0.0_sp,u_bar_no_f(h_l),l_fc,c)
    end do
    u_bar_no_f=u_bar_no_f(1)

end subroutine


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!> @brief calculate the thermal conductivity kf of fluid [W/(m*K)]
!> @param[in] i cell index, direction I0
!> @param[in] j cell index, direction J0
!> @param[in] k cell index, direction K0
!> @param[in] ismpl local sample index
!> @return  thermal conductivity                lamf[W/(m*K)]
!> @details
!> calculate the thermal conductivity kf in W/(m*K) of saline water,
!> given temperature in degC, and salinity in mass fraction (g/g)of
!> NaCl. Thermal conductivity of freshwater, kfw is calculated using
!> the Phillips (1981) formulation (page8). \n \n
!>
!>      C = S./(1 + S)*1.d2;C2=C.*C;    % C=salinity in mol/kg \n\n
!>    kf = kfw.*(1.d0 - (2.3434d-3 - 7.924d-6*T + 3.924d-8*T2).*C ... \n
!>                         + (1.06d-5 - 2.d-8*T - 1.2d-10*T2).*C2) \n\n
!> Source:\n\n
!>
!> Phillips, S., Igbene, A., Fair, J., Ozbek, H., & Tavana, M.,
!> Technical databook for geothermal energy utilization (1981).
!> http://dx.doi.org/10.2172/6301274 \n\n
!>
!> Range of validity:  20 to 330degC and up to 4 molal NaCl\n\n
!> input:\n
!> pressure                             p [MPa]\n
!> temperature                          t in [C]\n
!> salinity                              s in [mol/L]\n
      double precision function lamf(i,j,k,ismpl)
        use arrays
        use mod_flow
        IMPLICIT NONE

        ! Location indices
        integer, intent (in) :: i
        integer, intent (in) :: j
        integer, intent (in) :: k

        ! Sample index
        integer :: ismpl

        ! Local Temperature (degC)
        double precision :: t

        ! Local Pressure (MPa)
        double precision :: p

        ! Local salinity [mol/kg / mol/L]
        double precision :: s

        ! Monomials of temperature
        double precision :: t2, t3, t4

        ! Salinity from Phillips1981 [-]
        double precision :: sr

        ! Monomial of salinity from Phillips1981 [-]
        double precision :: sr2

        ! Factor for thermal conductivity, Phillips1981 (2)
        double precision :: lamfac

        ! Pure water thermal conductivity [W/(m*K)]
        double precision, external :: lamw

        ! Local pressure [MPa]
        p = pres(i,j,k,ismpl)*pa_conv1

        ! Local temperature [degC]
        t = temp(i,j,k,ismpl)

        ! Local salinity [mol/L / mol/kg]
        s = tsal(i,j,k,ismpl)

        if (s<=0.0d0) then

          ! Pure water conductivity
          lamf = lamw(p,t)

        else

          ! Salinity according to Phillips (1981) between (2) and (3)
          sr =5844.3d0*s/(1.0d3+58.443d0*s)

          ! Monomials in salinity and temperature
          sr2 = sr*sr
          t2 = t*t
          t3 = t2*t
          t4 = t3*t

          ! Factor lamf/lamw from Phillips1981, eq (2)
          lamfac = 1.0d0 - (2.3434d-3 - 7.924d-6*t + 3.924d-8*t2) * sr + &
              (1.06d-5 - 2.0d-8*t + 1.2d-10*t2) * sr2

          ! Thermal conductivity of fluid
          lamf = lamfac*lamw(p,t)

        end if

        return

      end function lamf


      subroutine runY_000000i(k,l,i1,Xtwiddle,Gtwiddle,Shat7zzzz,N0)
      implicit none
C---  Expression for D000000i obtained from 5.50, following the comment after
C     5.50 on how to add adding additional "00" pairs
C---  (similar to Eq. 5.56b but with "0000" added)
      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 Shat7zzzz(np,z2max,-2:0)

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

      do ep=-2,0

      Dv(dzzzzzzi(i1)+N0,ep)=
     . (-2d0*Gtwiddle(k,i1)*Dv(dzzzzzzi(l)+N0,ep)
     . +Gtwiddle(k,1)*Shat7zzzz(1,z2(l,i1),ep)
     . +Gtwiddle(k,2)*Shat7zzzz(2,z2(l,i1),ep)
     . +Gtwiddle(k,3)*Shat7zzzz(3,z2(l,i1),ep)
     . +Xtwiddle(0,k)*Dv(dzzzzii(z2(l,i1))+N0,ep)
     . -Xtwiddle(0,0)*Dv(dzzzziii(z3(k,l,i1))+N0,ep)
     . )/(2d0*Gtwiddle(k,l))

      enddo

      return
      end


	PROGRAM EMCOPL
C	SOLVES COLD PLASMA DISPERSION EQUATION, NOT ELECTROSTATIC
C	IN STIX'S NOTATION ER IS R,EL IS L,EP IS P,EPERP IS S
C	EPSL IS A
C
C	used to make constant w contours in the k plane
C	this routine makes a file for031.dat, to be plotted by mongo
C	after running this program, exit, and :
C
C	mongo
C	printer 6                           omit to plot on crt
C	set gy1 500                                "
C	set gx2 2700                                "
C	set gy2 2700                                "
C	set lx2 2900                                "
C	set ly2 2900                                "
C	input kplane.plt
C	hardcopy                                    "
C	end
C
	COMPLEX CNU,DN,FN,BN,EPSL,EN2P
	COMPLEX EN2M,XKP,XKM,ERN,ELN,EPN
	COMPLEX ER,EL,EP,EPERP,EPERPN,LAMBDA,ZPL,SQL
 	REAL NU
C
	DIMENSION XTABLE(100,10),ZTABLE(100,10)
	DIMENSION WP(10),WC(10),NU(10),A(10),DENS(10),WP2(10)
	DATA NC /3/
C	DATA NU /1.E-5,1.E-7,8*0./
	DATA NU /10*0./
	DATA A /1.,16.,8*1./
	DATA DENS /1.,.05,.95,7*1./
	DATA WCYCL /.4/
	DATA TWOPI /6.28318531/
	DATA RSH /13.5/
	DATA ALT /400./
	DATA FP /3.6E6/
	DATA COSTK /1./
C	W,WC,WP2 ARE RATIO TO PLASMA FREQ. OF COMP. 1
C
	PRINT 701, ALT,FP,NU(1),NU(2)
 701	FORMAT('0ALT=',F8.1,' KM, FP=',E10.3,' HZ, E,I COLL F',2E10.3)
	PRINT 703, COSTK,(A(N),N=2,NC)
 703	FORMAT(' COS THETA ='F7.4,3X,'ION AT.WTS.',10F5.1)
	PRINT 704,(DENS(N),N=2,NC)
 704	FORMAT(20X,'ION REL.DENS.',10F5.3)
	PRINT 702
 702	FORMAT('0')
  	A(1) = -1./1836.
	DO 11 N = 1,NC
	WP2(N) = DENS(N)/1836./ABS(A(N))
	WC(N) = WCYCL/1836./A(N)
 11	CONTINUE
	W = 1.25E-7
	DO 1 NIT = 1,9
	W=NIT*WCYCL/10.
	FHZ = FP*W
C
	NCOS = 45
C     CALCULATE EPSILON AND MINIMUM COS FOR WHISTLER MODE
      ER = 1.
      EL = 1.
      EP = 1.
      EMAG = 1.
      DO 20 N = 1,NC
C     REPLACE M BY M*(1. - I*NU/W)
      CNU = CMPLX(0.,NU(N))/FP/TWOPI
      ER = ER - WP2(N)/W/(W-CNU+WC(N))
      EL = EL - WP2(N)/W/(W-CNU-WC(N))
      EP = EP - WP2(N)/W/(W-CNU)
      EMAG = AMAX1(EMAG,CABS(ER),CABS(EL),CABS(EP))
 20   CONTINUE
      EPERP = .5*(ER + EL)
	COSMIN2 = 1./(1. - EP/EPERP)
	COSMIN = SQRT(AMAX1(COSMIN2,0.))
	DELCOS = (1. - COSMIN)/(NCOS-1)
	DO 2 ICOS = 1,NCOS
	COSTK = 1. - (ICOS-1)*DELCOS
C
C     CALCULATE EPSILON
      ER = 1.
      EL = 1.
      EP = 1.
      EMAG = 1.
      DO 10 N = 1,NC
C     REPLACE M BY M*(1. - I*NU/W)
      CNU = CMPLX(0.,NU(N))/FP/TWOPI
      ER = ER - WP2(N)/W/(W-CNU+WC(N))
      EL = EL - WP2(N)/W/(W-CNU-WC(N))
      EP = EP - WP2(N)/W/(W-CNU)
      EMAG = AMAX1(EMAG,CABS(ER),CABS(EL),CABS(EP))
 10   CONTINUE
	ERN = ER/EMAG
	ELN = EL/EMAG
	EPN = EP/EMAG
      EPERPN = .5*(ERN + ELN)
      EPERP = .5*(ER + EL)
	DN = .5*(ERN - ELN)
	SINTK2 = 1. - COSTK**2
	FN = CSQRT(((ERN*ELN-EPN*EPERPN)*SINTK2)**2
     1    + 4.*(EPN*DN*COSTK)**2)
	BN = ERN*ELN*SINTK2 + EPN*EPERPN*(1. + COSTK**2)
	EPSL = EPERP*SINTK2 + EP*COSTK**2
	EN2P = .5*EMAG**2*(BN + FN)/EPSL
	XKP = W*CSQRT(EN2P)
	EN2M = .5*EMAG*(BN - FN)/(EPSL/EMAG)
	XKM = W*CSQRT(EN2M)
C	PRINT 700,FHZ,EP,EPERP,ER,EL,EMAG
C	PRINT 700,FHZ,EPN,EPERPN,ERN,ELN
C	PRINT 700,FHZ,EN2P,XKP,EN2M,XKM
	SINTK = SQRT(AMAX1(SINTK2,0.))
	XKK = XKP
	XX2M = EN2M
	IF(XX2M.GT.0.) XKK = XKM
	XK = XKK*SINTK
	ZK = XKK*COSTK
	ZTABLE(ICOS,NIT) = ZK
	XTABLE(ICOS,NIT) = XK
 2	CONTINUE
 1	CONTINUE
	DO 3 I = 1,ICOS
	WRITE (31,2103) (XTABLE(I,NIT),ZTABLE(I,NIT),NIT=1,9)
 2103	FORMAT(18F7.4)
  3	CONTINUE
C     PRINT 100,W,X(1),EPSR,EPS0,EP
  100 FORMAT(' COPLAS' 8E12.4)
  700 FORMAT(' 'F12.4,4(E13.4,E12.4),E12.4)
C      RETURN
	STOP
      END


c    This file contains basic subroutines for forming and
c    evaluating multipole expansions for Stokes flow
c    in 2D
c
c-----------------------------------------------------------------
c     Expansion formation subroutines
c
c     bh2dformmpc_vec: creates multipole expansion (outgoing) due to
c                     a collection of charge sources
c     bh2dformmpd_vec: creates multipole expansion (outgoing) due to
c                     a collection of dipole sources
c     bh2dformmpcd_vec: creates multipole expansion (outgoing) due to
c                     a collection of charge and dipole sources
c     bh2dformta_vec: creates local expansion (incoming) due to
c                     a collection of charge sources
c     bh2dformtad_vec: creates multipole expansion (incoming) due to
c                     a collection of dipole sources
c     bh2dformtacd_vec: creates multipole expansion (incoming) due to
c                     a collection of charge and dipole sources
c
c------------------------------------------------------------------
c     Multipole and local translation operators
c
c     bh2dmpmp_vec: Converts multipole expansion to a multipole expansion
c     bh2dmploc_vec: Converts multipole expansion to local expansion
c     bh2dlocloc_vec: converts local expansion to local expansion
c
c---------------------------------------------------------------------
c     Evaluation subroutines
c
c     bh2dmpevalp_vec: Computes the complex velocity due to a
c                      multipole expansion at a collection of targets
c     bh2dmpevalg_vec: Computes the complex velocity and its gradients
c                      due to a multipole expansion at a collection
c                      of targets
c     bh2dtaevalp_vec: Computes the complex velocity due to a
c                      local expansion at a collection of targets
c     bh2dtaevalg_vec: Computes the complex velocity and its gradients
c                      due to a local expansion at a collection
c                      of targets
c----------------------------------------------------------------------
c     Utility subroutines
c
c     bh2dzero_vec: utility to intialize multipole/local coefficients to
c                   zero
c
c*********************************************************************
c
c
c
c
c
c

      subroutine bh2dmpevalp(nd,rscale,center,mpole,nterms,
     1                     ztarg,ntarg,vel)
c********************************************************************
c     This subroutine evaluates the multipole expansion about
c     the "center" due to the multipole expansion
c     at the target ztarg
c
c     The multipole expansion has 5 set of coefficients
c     vel = \sum mpole(1,k)/z^k + \sum mpole(2,k)/z_bar^k +
c            k                k
c
c         z \sum mpole(3,k)/z_bar^k + Re(mp4(0) log(z) + \sum mpole(4,k)/z^k)
c              k                                       k
c
c          + i Re(mp5(0) log(z) + \sum mpole(5,k)/z^k)
c                                  k
c      z = (ztarg - center)/rscale
c
c      grada = gradient(analytic comoponent of vel)
c
c      gradaa = gradient(all but analytic component of vel)
c             = gradient(anti analytic + z times anti analytic
c                         component of vel)
c     NOTE: The subroutine will work if nterms<1000, as 1000, is
c     a hardwired number for computing zpow in the computation
c----------------------------------------------------------------------
c      INPUT parameters
c      rscale        : scaling parameter
c      center        : expansion center
c      mpole         : coeffs for multipole expansions
c      mpole(1,:)    : coeffs for multipole expansion - laurent
c      mpole(2,:)    : coeffs for multipole expansion - antilaurent
c      mpole(3,:)    : coeffs for multipole expansion - z antilaurent
c      mpole(4,:)    : coeffs for multipole expansion - logsource1
c      mpole(5,:)    : coeffs for multipole expansion - logsource2
c      nterms        : Number of terms in multipole expansion
c      ztarg         : target location
c      ntarg         : number of targets
c---------------------------------------------------------------------
c     OUTPUT
c     vel - Complex velocity
c*********************************************************************

      implicit real *8 (a-h,o-z)
      integer nterms,ifgrada,ifgradaa,nmax
      real *8 rscale,center(2),ztarg(2,ntarg)
      complex *16 zc,zt,zdis,eye
      complex *16 mpole(nd,5,0:nterms)
      complex *16 vel(nd,ntarg)
      complex *16 ztemp,ztemp1
      complex *16 zdisinv,zpow(1:1000)

      nmax = nterms+3
      rinv=1.0d0/rscale
      zc = dcmplx(center(1),center(2))
      eye = dcmplx(0.0d0,1.0d0)
      do k=1,ntarg
        zt = dcmplx(ztarg(1,k),ztarg(2,k))
        zdis = zt - zc
        zdisinv = 1.0d0/zdis
        ztemp = rscale*zdisinv
        zpow(1)=ztemp
        do i=2,nmax
          zpow(i)=zpow(i-1)*ztemp
        enddo
        do idim=1,nd
          vel(idim,k) = vel(idim,k)+
     1        (mpole(idim,4,0)+eye*mpole(idim,5,0))*log(cdabs(zdis))
        enddo

        do i=1,nterms
          do idim=1,nd
            vel(idim,k) = vel(idim,k) +
     1        mpole(idim,1,i)*zpow(i) + mpole(idim,2,i)*dconjg(zpow(i))
            vel(idim,k) = vel(idim,k) +
     1        mpole(idim,3,i)*dconjg(zpow(i))*zdis
            vel(idim,k) = vel(idim,k) +
     1        dreal(mpole(idim,4,i)*zpow(i))+
     2         eye*dreal(mpole(idim,5,i)*zpow(i))
          enddo
        enddo
      enddo

      return
      end
c
c
c
c
c
c

      subroutine bh2dmpevalg(nd,rscale,center,mpole,nterms,
     1                     ztarg,ntarg,vel,grad)
c********************************************************************
c     This subroutine evaluates the multipole expansion about
c     the "center" due to the multipole expansion
c     at the target ztarg
c
c     The multipole expansion has 5 set of coefficients
c     vel = \sum mpole(1,k)/z^k + \sum mpole(2,k)/z_bar^k +
c            k                k
c
c         z \sum mpole(3,k)/z_bar^k + Re(mp4(0) log(z) + \sum mpole(4,k)/z^k)
c              k                                       k
c
c          + i Re(mp5(0) log(z) + \sum mpole(5,k)/z^k)
c                                  k
c      z = (ztarg - center)/rscale
c
c      grada = gradient(analytic comoponent of vel)
c
c      gradaa = gradient(all but analytic component of vel)
c             = gradient(anti analytic + z times anti analytic
c                         component of vel)
c     NOTE: The subroutine will work if nterms<1000, as 1000, is
c     a hardwired number for computing zpow in the computation
c----------------------------------------------------------------------
c      INPUT parameters
c      rscale        : scaling parameter
c      center        : expansion center
c      mpole         : coeffs for multipole expansions
c      mpole(1,:)    : coeffs for multipole expansion - laurent
c      mpole(2,:)    : coeffs for multipole expansion - antilaurent
c      mpole(3,:)    : coeffs for multipole expansion - z antilaurent
c      mpole(4,:)    : coeffs for multipole expansion - logsource1
c      mpole(5,:)    : coeffs for multipole expansion - logsource2
c      nterms        : Number of terms in multipole expansion
c      ztarg         : target location
c      ntarg         : number of targets
c---------------------------------------------------------------------
c     OUTPUT
c     vel - Complex velocity
c     grad(1:2) - gradient of analytic component  (d/dz and d/dzbar)
c*********************************************************************

      implicit real *8 (a-h,o-z)
      integer nterms,ifgrada,ifgradaa,nmax
      real *8 rscale,center(2),ztarg(2,ntarg)
      complex *16 zc,zt,zdis,eye
      complex *16 mpole(nd,5,0:nterms)
      complex *16 vel(nd,ntarg),grad(nd,2,ntarg)
      complex *16 ztemp,ztemp1
      complex *16 zdisinv,zpow(1:1000)

      nmax = nterms+3
      rinv=1.0d0/rscale
      zc = dcmplx(center(1),center(2))
      eye = dcmplx(0.0d0,1.0d0)
      do k=1,ntarg
        zt = dcmplx(ztarg(1,k),ztarg(2,k))
        zdis = zt - zc
        zdisinv = 1.0d0/zdis
        ztemp = rscale*zdisinv
        zpow(1)=ztemp
        do i=2,nmax
          zpow(i)=zpow(i-1)*ztemp
        enddo
        do idim=1,nd
          vel(idim,k) = vel(idim,k)+
     1        (mpole(idim,4,0)+eye*mpole(idim,5,0))*log(cdabs(zdis))
          grad(idim,1,k) = grad(idim,1,k) +
     1        0.5d0*(mpole(idim,4,0)+eye*mpole(idim,5,0))*zpow(1)*rinv
          grad(idim,2,k)= grad(idim,2,k) +
     1       0.5d0*(mpole(idim,4,0)+eye*mpole(idim,5,0))*
     2       dconjg(zpow(1))*rinv
        enddo

        do i=1,nterms
          do idim=1,nd
            vel(idim,k) = vel(idim,k) +
     1        mpole(idim,1,i)*zpow(i) + mpole(idim,2,i)*dconjg(zpow(i))
            vel(idim,k) = vel(idim,k) +
     1        mpole(idim,3,i)*dconjg(zpow(i))*zdis
            vel(idim,k) = vel(idim,k) +
     1        dreal(mpole(idim,4,i)*zpow(i))+
     2         eye*dreal(mpole(idim,5,i)*zpow(i))
            grad(idim,1,k) = grad(idim,1,k) -
     1         mpole(idim,1,i)*zpow(i+1)*i*rinv
            grad(idim,1,k) = grad(idim,1,k) -
     1         0.5*mpole(idim,4,i)*i*zpow(i+1)*rinv
            grad(idim,1,k) = grad(idim,1,k) -
     1         eye*0.5*mpole(idim,5,i)*i*zpow(i+1)*rinv
            grad(idim,2,k) = grad(idim,2,k) -
     1         mpole(idim,2,i)*dconjg(zpow(i+1))*i*rinv
            grad(idim,2,k) = grad(idim,2,k) -
     1         zdis*mpole(idim,3,i)*dconjg(zpow(i+1))*i*rinv
            grad(idim,2,k) = grad(idim,2,k) -
     1         dconjg(0.5*mpole(idim,4,i)*i*zpow(i+1))*rinv
            grad(idim,2,k) = grad(idim,2,k) +
     1         dconjg(eye*0.5*mpole(idim,5,i)*i*zpow(i+1))*rinv
          enddo
        enddo
      enddo

      return
      end
c
c
c
c
c
c
c********************************************************************
      subroutine bh2dtaevalp(nd,rscale,center,mpole,nterms,
     1                      ztarg,ntarg,vel)
c********************************************************************
c     This subroutine evaluates the multipole expansion about
c     the "center" due to the local expansion
c     at the target ztarg
c
c     The multipole expansion has 5 set of coefficients
c     vel = \sum mpole(1,k) z^k + \sum mpole(2,k) z_bar^k +
c            k                k
c
c         z \sum mpole(3,k) z_bar^k + Re(\sum mpole(4,k) z^k)
c              k                       k
c
c          + i Re( \sum mpole(5,k) z^k)
c                    k
c      z = (ztarg - center)/rscale
c     NOTE: The subroutine will work if nterms<1000, as 1000, is
c     a hardwired number for computing zpow in the computation
c----------------------------------------------------------------------
c      INPUT parameters
c      rscale        : scaling parameter
c      center        : expansion center
c      mpole         : coeffs for local expansion
c      mpole(1,:)    : coeffs for multipole expansion - taylor
c      mpole(2,:)    : coeffs for multipole expansion - antitaylor
c      mpole(3,:)    : coeffs for multipole expansion - z antitaylor
c      mpole(4,:)    : coeffs for multipole expansion - logsource1
c      mpole(5,:)    : coeffs for multipole expansion - logsource2
c      nterms        : Number of terms in multipole expansion
c      ztarg         : target location
c      ntarg         : number of targets
c---------------------------------------------------------------------
c     OUTPUT
c     vel - Complex velocity
c*********************************************************************

      implicit real *8 (a-h,o-z)
      integer nterms,ifgrada,ifgradaa
      real *8 rscale,center(2),ztarg(2,ntarg)
      complex *16 zc,zt,zdis,eye
      complex *16 mpole(nd,5,0:nterms)
      complex *16 vel(nd,ntarg)
      complex *16 ztemp,ztemp1,zpow(0:1000)

      rinv=1.0d0/rscale
      zc = dcmplx(center(1),center(2))
      eye = dcmplx(0.0d0,1.0d0)

      do k=1,ntarg
        zt = dcmplx(ztarg(1,k),ztarg(2,k))
        zdis = zt - zc
        ztemp1 = zdis*rinv
        zpow(0)=1.0d0
        do i=1,nterms
          zpow(i)=zpow(i-1)*ztemp1
        enddo

        do i=0,nterms
          do idim=1,nd
            vel(idim,k) = vel(idim,k) + mpole(idim,1,i)*zpow(i) +
     1          mpole(idim,2,i)*dconjg(zpow(i))
            vel(idim,k) = vel(idim,k) +
     1          mpole(idim,3,i)*dconjg(zpow(i))*zdis
            vel(idim,k) = vel(idim,k) +
     1          dreal(mpole(idim,4,i)*zpow(i)) +
     2          eye*dreal(mpole(idim,5,i)*zpow(i))
          enddo
        enddo
      enddo

      return
      end

c
c
c
c
c********************************************************************
      subroutine bh2dtaevalg(nd,rscale,center,mpole,nterms,
     1                      ztarg,ntarg,vel,grad)
c********************************************************************
c     This subroutine evaluates the multipole expansion about
c     the "center" due to the local expansion
c     at the target ztarg
c
c     The multipole expansion has 5 set of coefficients
c     vel = \sum mpole(1,k) z^k + \sum mpole(2,k) z_bar^k +
c            k                k
c
c         z \sum mpole(3,k) z_bar^k + Re(\sum mpole(4,k) z^k)
c              k                       k
c
c          + i Re( \sum mpole(5,k) z^k)
c                    k
c      z = (ztarg - center)/rscale
c     NOTE: The subroutine will work if nterms<1000, as 1000, is
c     a hardwired number for computing zpow in the computation
c----------------------------------------------------------------------
c      INPUT parameters
c      rscale        : scaling parameter
c      center        : expansion center
c      mpole         : coeffs for local expansion
c      mpole(1,:)    : coeffs for multipole expansion - taylor
c      mpole(2,:)    : coeffs for multipole expansion - antitaylor
c      mpole(3,:)    : coeffs for multipole expansion - z antitaylor
c      mpole(4,:)    : coeffs for multipole expansion - logsource1
c      mpole(5,:)    : coeffs for multipole expansion - logsource2
c      nterms        : Number of terms in multipole expansion
c      ztarg         : target location
c      ntarg         : number of targets
c---------------------------------------------------------------------
c     OUTPUT
c     vel - Complex velocity
c     grad - gradient (d/dz, d/dzbar)
c*********************************************************************

      implicit real *8 (a-h,o-z)
      integer nterms,ifgrada,ifgradaa
      real *8 rscale,center(2),ztarg(2,ntarg)
      complex *16 zc,zt,zdis,eye
      complex *16 mpole(nd,5,0:nterms)
      complex *16 vel(nd,ntarg),grad(nd,2,ntarg)
      complex *16 ztemp,ztemp1,zpow(0:1000)

      rinv=1.0d0/rscale
      zc = dcmplx(center(1),center(2))
      eye = dcmplx(0.0d0,1.0d0)

      do k=1,ntarg
        zt = dcmplx(ztarg(1,k),ztarg(2,k))
        zdis = zt - zc
        ztemp1 = zdis*rinv
        zpow(0)=1.0d0
        do i=1,nterms
          zpow(i)=zpow(i-1)*ztemp1
        enddo

        do i=0,nterms
          do idim=1,nd
            vel(idim,k) = vel(idim,k) + mpole(idim,1,i)*zpow(i) +
     1          mpole(idim,2,i)*dconjg(zpow(i))
            vel(idim,k) = vel(idim,k) +
     1          mpole(idim,3,i)*dconjg(zpow(i))*zdis
            vel(idim,k) = vel(idim,k) +
     1          dreal(mpole(idim,4,i)*zpow(i)) +
     2          eye*dreal(mpole(idim,5,i)*zpow(i))
          enddo
        enddo
        do i=1,nterms
          do idim=1,nd
            grad(idim,1,k) = grad(idim,1,k) +
     1         mpole(idim,1,i)*zpow(i-1)*i*rinv
            grad(idim,1,k) = grad(idim,1,k) +
     1         0.5*mpole(idim,4,i)*i*zpow(i-1)*rinv
            grad(idim,1,k) = grad(idim,1,k) +
     1         eye*0.5*mpole(idim,5,i)*i*zpow(i-1)*rinv
            grad(idim,2,k) = grad(idim,2,k) +
     1          mpole(idim,2,i)*dconjg(zpow(i-1))*i*rinv
            grad(idim,2,k) = grad(idim,2,k) +
     1          mpole(idim,3,i)*dconjg(zpow(i-1))*i*zdis*rinv
            grad(idim,2,k) = grad(idim,2,k) +
     1         dconjg(0.5*mpole(idim,4,i)*i*zpow(i-1))*rinv
            grad(idim,2,k) = grad(idim,2,k) -
     1         dconjg(eye*0.5*mpole(idim,5,i)*i*zpow(i-1))*rinv
          enddo
        enddo
      enddo

      return
      end

c*******************************************************************
c     EXPANSION FORMATION
c*******************************************************************
      subroutine bh2dformmpd(nd,rscale,sources,ns,dip,
     1           center,nterms,mpole)
c*****************************************************************
c     This subroutine computes the multipole expansion about
c     the "center" due to ns sources located at sources(2,*)
c
c      The complex velocity at zt = xt + i yt
c      due to a charge a complex charge c1 at zs = xs+i ys is given by
c
c
c      vel = 2*c1 log|zt-zs| + c1_bar (zt-zs)/(zt_bar - zs_bar)
c
c      The complex velocity due to a dipole with complex parameters
c      c2,c3 is given by
c
c
c      vel = c2/(zt-zs) - c2_bar (zt-zs)/(zt_bar-zs_bar)^2 +
c             c3/(zt_bar - zs_bar)
c
c     The multipole expansion has 5 set of coefficients
c     vel = \sum mpole(1,k)/z^k + \sum mpole(2,k)/z_bar^k +
c            k                      k
c
c         z \sum mpole(3,k)/z_bar^k + Re(mpole(4,0) log(z) + \sum mpole(4,k)/z^k)
c              k                                               k
c
c          + i Re(mpole(5,0) log(z) + \sum mpole(5,k)/z^k)
c                                       k
c------------------------------------------------------------------
c     INPUT parameters
c      nd            : number of densities
c      rscale        : scaling parameter
c      sources(2,ns) : coordinates of sources
c      dip(2,ns)    : dipole parameters (corresponding to c2,c3 above)
c      ns           : number of sources
c      center(2)    : expansion center
c      nterms       : Order of multipole expansion
c------------------------------------------------------------------
c      OUTPUT
c      mpole         : coeffs for multipole expansion
c      mpole(1,:)    : coeffs for multipole expansion - laurent
c      mpole(2,:)    : coeffs for multipole expansion - antilaurent
c      mpole(3,:)    : coeffs for multipole expansion - z antilaurent
c      mpole(4,:)    : coeffs for multipole expansion - logsource1
c      mpole(5,:)    : coeffs for multipole expansion - logsource2
c-----------------------------------------------------------------

      implicit real *8 (a-h,o-z)
      integer ns,nterms
      complex *16 mpole(nd,5,0:nterms)
      complex *16 dip(nd,2,ns)
      real *8 sources(2,ns),center(2),rscale
      complex *16 zc,z1,z2,zs,zdis,ztemp,zdisc,ztempc
      complex *16 ztempc2
      complex *16 zt1,zt2,zt3

      ier = 0
      zc = dcmplx(center(1),center(2))
      rinv=1.0d0/rscale

      do i=1,ns
         zs=dcmplx(sources(1,i),sources(2,i))
         zdis = (zs-zc)/rscale
         ztemp= zs-zc
         zdisc=dconjg(zdis)

         if(abs(zdis).le.1.0d-16) then
            do idim=1,nd
                mpole(idim,1,1) = mpole(idim,1,1) + dip(idim,1,i)*rinv
                mpole(idim,2,1) = mpole(idim,2,1) + dip(idim,2,i)*rinv
                mpole(idim,3,2) = mpole(idim,3,2) -
     1              dconjg(dip(idim,1,i))*rinv**2
            enddo
         endif

         if(abs(zdis).gt.1.0d-16) then
            ztempc=1.0d0/dconjg(ztemp)
            ztempc2=ztempc*ztempc
            do j=1,nterms
               do idim=1,nd
                  zt2 = dip(idim,2,i)*ztempc
                  zt3 = dconjg(dip(idim,1,i))*ztempc2
c           Expansion corresponding to d1/z-zs
                  mpole(idim,1,j)=mpole(idim,1,j)+
     1               dip(idim,1,i)*zdis/ztemp
c           Expansion corresponding to d2/(z_bar - zs_bar)
                  mpole(idim,2,j)=mpole(idim,2,j)+zt2*zdisc
c           Expansion corresponding to -d1_bar(z-zs)/(z_bar - zs_bar)^2
                  mpole(idim,2,j)=mpole(idim,2,j)+zt3*(j-1)*zdisc*ztemp
                  mpole(idim,3,j)=mpole(idim,3,j)-zt3*(j-1)*zdisc
               enddo
               zdis=zdis*ztemp*rinv
               zdisc=zdisc/ztempc*rinv
            enddo
         endif
      enddo

      return
      end
c
c
c
c
c
      subroutine bh2dformmpc(nd,rscale,sources,ns,c1,
     1           center,nterms,mpole)
c*****************************************************************
c     This subroutine computes the multipole expansion about
c     the "center" due to ns sources located at sources(2,*)
c
c      The complex velocity at zt = xt + i yt
c      due to a charge a complex charge c1 at zs = xs+i ys is given by
c
c
c      vel = 2*c1 log|zt-zs| + c1_bar (zt-zs)/(zt_bar - zs_bar)
c
c      The complex velocity due to a dipole with complex parameters
c      c2,c3 is given by
c
c
c      vel = c2/(zt-zs) - c2_bar (zt-zs)/(zt_bar-zs_bar)^2 +
c             c3/(zt_bar - zs_bar)
c
c     The multipole expansion has 5 set of coefficients
c     vel = \sum mpole(1,k)/z^k + \sum mpole(2,k)/z_bar^k +
c            k                      k
c
c         z \sum mpole(3,k)/z_bar^k + Re(mpole(4,0) log(z) + \sum mpole(4,k)/z^k)
c              k                                               k
c
c          + i Re(mpole(5,0) log(z) + \sum mpole(5,k)/z^k)
c                                       k
c------------------------------------------------------------------
c     INPUT parameters
c      nd            : number of densities
c      rscale        : scaling parameter
c      sources(2,ns) : coordinates of sources
c      c1           : charge strength
c      ns           : number of sources
c      center(2)    : expansion center
c      nterms       : Order of multipole expansion
c------------------------------------------------------------------
c      OUTPUT
c      mpole         : coeffs for multipole expansion
c      mpole(1,:)    : coeffs for multipole expansion - laurent
c      mpole(2,:)    : coeffs for multipole expansion - antilaurent
c      mpole(3,:)    : coeffs for multipole expansion - z antilaurent
c      mpole(4,:)    : coeffs for multipole expansion - logsource1
c      mpole(5,:)    : coeffs for multipole expansion - logsource2
c-----------------------------------------------------------------

      implicit real *8 (a-h,o-z)
      integer ns,nterms
      complex *16 mpole(nd,5,0:nterms)
      complex *16 c1(nd,ns)
      real *8 sources(2,ns),center(2),rscale
      complex *16 zc,z1,z2,zs,zdis,ztemp,zdisc,ztempc
      complex *16 ztempc2
      complex *16 zt1,zt2,zt3

      ier = 0
      zc = dcmplx(center(1),center(2))
      rinv=1.0d0/rscale

      do i=1,ns
         zs=dcmplx(sources(1,i),sources(2,i))
         zdis = (zs-zc)/rscale
         ztemp= zs-zc
         zdisc=dconjg(zdis)

         if(abs(zdis).le.1.0d-16) then
            do idim=1,nd
                mpole(idim,4,0) = mpole(idim,4,0) + real(2*c1(idim,i))
                mpole(idim,5,0) = mpole(idim,5,0) + imag(2*c1(idim,i))
c       Expansion corresponding to c1_bar z-zs/(z_bar - zs_bar)
                mpole(idim,3,1) = mpole(idim,3,1) +
     1             dconjg(c1(idim,i))*rinv
            enddo
         endif

         if(abs(zdis).gt.1.0d-16) then
            ztempc=1.0d0/dconjg(ztemp)
            ztempc2=ztempc*ztempc
            do idim=1,nd
               mpole(idim,4,0)=mpole(idim,4,0)+dreal(2*c1(idim,i))
               mpole(idim,5,0)=mpole(idim,5,0)+dimag(2*c1(idim,i))
            enddo
            do j=1,nterms
               do idim=1,nd
                  zt1 = dconjg(c1(idim,i))*ztempc
c          Expansion corresponding to 2 c1 log |z-zs|
                 mpole(idim,4,j)=mpole(idim,4,j)-
     1               dreal(2*c1(idim,i))*zdis/j
                 mpole(idim,5,j)=mpole(idim,5,j)-
     1               dimag(2*c1(idim,i))*zdis/j
c          Expansion corresponding to c1_bar z-zs/(z_bar - zs_bar)
                 mpole(idim,2,j)=mpole(idim,2,j)-zt1*zdisc*ztemp
                 mpole(idim,3,j)=mpole(idim,3,j)+zt1*zdisc
               enddo

               zdis=zdis*ztemp*rinv
               zdisc=zdisc/ztempc*rinv
            enddo
         endif
      enddo

      return
      end
c
c
c
c
c
c********************************************************************
      subroutine bh2dformmpcd(nd,rscale,sources,ns,c1,dip,
     1           center,nterms,mpole)
c*****************************************************************
c     This subroutine computes the multipole expansion about
c     the "center" due to ns sources located at sources(2,*)
c
c      The complex velocity at zt = xt + i yt
c      due to a charge a complex charge c1 at zs = xs+i ys is given by
c
c
c      vel = 2*c1 log|zt-zs| + c1_bar (zt-zs)/(zt_bar - zs_bar)
c
c      The complex velocity due to a dipole with complex parameters
c      c2,c3 is given by
c
c
c      vel = c2/(zt-zs) - c2_bar (zt-zs)/(zt_bar-zs_bar)^2 +
c             c3/(zt_bar - zs_bar)
c
c     The multipole expansion has 5 set of coefficients
c     vel = \sum mpole(1,k)/z^k + \sum mpole(2,k)/z_bar^k +
c            k                      k
c
c         z \sum mpole(3,k)/z_bar^k + Re(mpole(4,0) log(z) + \sum mpole(4,k)/z^k)
c              k                                               k
c
c          + i Re(mpole(5,0) log(z) + \sum mpole(5,k)/z^k)
c                                       k
c------------------------------------------------------------------
c     INPUT parameters
c      nd            : number of densities
c      rscale        : scaling parameter
c      sources(2,ns) : coordinates of sources
c      c1           : charge strength
c      dip(2,ns)    : dipole parameters (corresponding to c2,c3 above)
c      ns           : number of sources
c      center(2)    : expansion center
c      nterms       : Order of multipole expansion
c------------------------------------------------------------------
c      OUTPUT
c      mpole         : coeffs for multipole expansion
c      mpole(1,:)    : coeffs for multipole expansion - laurent
c      mpole(2,:)    : coeffs for multipole expansion - antilaurent
c      mpole(3,:)    : coeffs for multipole expansion - z antilaurent
c      mpole(4,:)    : coeffs for multipole expansion - logsource1
c      mpole(5,:)    : coeffs for multipole expansion - logsource2
c-----------------------------------------------------------------

      implicit real *8 (a-h,o-z)
      integer ns,nterms
      complex *16 mpole(nd,5,0:nterms)
      complex *16 c1(nd,ns),dip(nd,2,ns)
      real *8 sources(2,ns),center(2),rscale
      complex *16 zc,z1,z2,zs,zdis,ztemp,zdisc,ztempc
      complex *16 ztempc2
      complex *16 zt1,zt2,zt3

      ier = 0
      zc = dcmplx(center(1),center(2))
      rinv=1.0d0/rscale

      do i=1,ns
         zs=dcmplx(sources(1,i),sources(2,i))
         zdis = (zs-zc)/rscale
         ztemp= zs-zc
         zdisc=dconjg(zdis)

         if(abs(zdis).le.1.0d-16) then
            do idim=1,nd
                mpole(idim,4,0) = mpole(idim,4,0) + real(2*c1(idim,i))
                mpole(idim,5,0) = mpole(idim,5,0) + imag(2*c1(idim,i))
c       Expansion corresponding to c1_bar z-zs/(z_bar - zs_bar)
                mpole(idim,3,1) = mpole(idim,3,1) +
     1             dconjg(c1(idim,i))*rinv
                mpole(idim,1,1) = mpole(idim,1,1) + dip(idim,1,i)*rinv
                mpole(idim,2,1) = mpole(idim,2,1) + dip(idim,2,i)*rinv
                mpole(idim,3,2) = mpole(idim,3,2) -
     1              dconjg(dip(idim,1,i))*rinv**2
            enddo
         endif

         if(abs(zdis).gt.1.0d-16) then
            ztempc=1.0d0/dconjg(ztemp)
            ztempc2=ztempc*ztempc
            do idim=1,nd
               mpole(idim,4,0)=mpole(idim,4,0)+dreal(2*c1(idim,i))
               mpole(idim,5,0)=mpole(idim,5,0)+dimag(2*c1(idim,i))
            enddo
            do j=1,nterms
               do idim=1,nd
                  zt1 = dconjg(c1(idim,i))*ztempc
c          Expansion corresponding to 2 c1 log |z-zs|
                 mpole(idim,4,j)=mpole(idim,4,j)-
     1               dreal(2*c1(idim,i))*zdis/j
                 mpole(idim,5,j)=mpole(idim,5,j)-
     1               dimag(2*c1(idim,i))*zdis/j
c          Expansion corresponding to c1_bar z-zs/(z_bar - zs_bar)
                 mpole(idim,2,j)=mpole(idim,2,j)-zt1*zdisc*ztemp
                 mpole(idim,3,j)=mpole(idim,3,j)+zt1*zdisc
               enddo

               do idim=1,nd
                  zt2 = dip(idim,2,i)*ztempc
                  zt3 = dconjg(dip(idim,1,i))*ztempc2
c           Expansion corresponding to d1/z-zs
                  mpole(idim,1,j)=mpole(idim,1,j)+
     1               dip(idim,1,i)*zdis/ztemp
c           Expansion corresponding to d2/(z_bar - zs_bar)
                  mpole(idim,2,j)=mpole(idim,2,j)+zt2*zdisc
c           Expansion corresponding to -d1_bar(z-zs)/(z_bar - zs_bar)^2
                  mpole(idim,2,j)=mpole(idim,2,j)+zt3*(j-1)*zdisc*ztemp
                  mpole(idim,3,j)=mpole(idim,3,j)-zt3*(j-1)*zdisc
               enddo
               zdis=zdis*ztemp*rinv
               zdisc=zdisc/ztempc*rinv
            enddo
         endif
      enddo

      return
      end
c
c
c
c
c
c
c********************************************************************
      subroutine bh2dformtac(nd,rscale,sources,ns,c1,
     1       center,nterms,mpole)
c*****************************************************************
c     This subroutine computes the local expansion about
c     the "center" due to ns sources located at sources(2,*)
c
c      The complex velocity at zt = xt + i yt
c      due to a charge a complex charge c1 at zs = xs+i ys is given by
c
c
c      vel = 2*c1 log|zt-zs| + c1_bar (zt-zs)/(zt_bar - zs_bar)
c
c      The complex velocity due to a dipole with complex parameters
c      c2,c3 is given by
c
c
c      vel = c2/(zt-zs) - c2_bar (zt-zs)/(zt_bar-zs_bar)^2 +
c             c3/(zt_bar - zs_bar)
c
c     The multipole expansion has 5 set of coefficients
c     vel = \sum mp1(k) z^k + \sum mp2(k) z_bar^k +
c            k                k
c
c         z \sum mp3(k) z_bar^k + Re(mp4(0) log(z) + \sum mp4(k) z^k)
c              k                                       k
c
c          + i Re(mp5(0) log(z) + \sum mp5(k) z^k)
c                                  k
c------------------------------------------------------------------
c     INPUT parameters
c
c      rscale        : scaling parameter
c      sources(2,ns) : coordinates of sources
c      c1           : charge strength
c      ns            : number of sources
c      center(2)     : expansion center
c      nterms        : Order of multipole expansion
c------------------------------------------------------------------
c      OUTPUT
c      mpole         : coeffs for local expansion
c      mpole(1,:)    : coeffs for multipole expansion - laurent
c      mpole(2,:)    : coeffs for multipole expansion - antilaurent
c      mpole(3,:)    : coeffs for multipole expansion - z antilaurent
c      mpole(4,:)    : coeffs for multipole expansion - logsource1
c      mpole(5,:)    : coeffs for multipole expansion - logsource2
c-----------------------------------------------------------------

      implicit real *8 (a-h,o-z)
      integer ns,nterms
      complex *16 mpole(nd,5,0:nterms)
      complex *16 c1(nd,ns)
      real *8 sources(2,ns),center(2),rscale
      complex *16 zc,z1,z2,zs,zdis,ztemp,zdisc,ztempc

      zc = dcmplx(center(1),center(2))

      do i=1,ns
         zs=dcmplx(sources(1,i),sources(2,i))
         zdis = 1.0d0
         ztemp= 1.0d0/(zs-zc)
         zdisc=dconjg(zdis)
         ztempc=dconjg(ztemp)
         do j=0,nterms
            do idim=1,nd
              if(j.eq.0) then
                 mpole(idim,4,j)=mpole(idim,4,j) +
     1               dreal(2*c1(idim,i))*log(cdabs(1.0d0/ztemp))
                 mpole(idim,5,j)=mpole(idim,5,j) +
     1               dimag(2*c1(idim,i))*log(cdabs(1.0d0/ztemp))
              else
                mpole(idim,4,j)=mpole(idim,4,j) -
     1              dreal(2*c1(idim,i))*zdis/j
                mpole(idim,5,j)=mpole(idim,5,j) -
     1              dimag(2*c1(idim,i))*zdis/j
              endif
              mpole(idim,2,j)=mpole(idim,2,j) +
     1            dconjg(c1(idim,i))*zdisc*ztempc/ztemp
              mpole(idim,3,j)=mpole(idim,3,j) -
     1           dconjg(c1(idim,i))*zdisc*ztempc

            enddo
            zdis=zdis*ztemp*rscale
            zdisc=zdisc*ztempc*rscale
         enddo
      enddo

      return
      end

c
c
c
c
c********************************************************************
      subroutine bh2dformtad(nd,rscale,sources,ns,d1,d2,
     1       center,nterms,mpole)
c*****************************************************************
c     This subroutine computes the local expansion about
c     the "center" due to ns sources located at sources(2,*)
c
c      The complex velocity at zt = xt + i yt
c      due to a charge a complex charge c1 at zs = xs+i ys is given by
c
c
c      vel = 2*c1 log|zt-zs| + c1_bar (zt-zs)/(zt_bar - zs_bar)
c
c      The complex velocity due to a dipole with complex parameters
c      c2,c3 is given by
c
c
c      vel = c2/(zt-zs) - c2_bar (zt-zs)/(zt_bar-zs_bar)^2 +
c             c3/(zt_bar - zs_bar)
c
c     The multipole expansion has 5 set of coefficients
c     vel = \sum mp1(k) z^k + \sum mp2(k) z_bar^k +
c            k                k
c
c         z \sum mp3(k) z_bar^k + Re(mp4(0) log(z) + \sum mp4(k) z^k)
c              k                                       k
c
c          + i Re(mp5(0) log(z) + \sum mp5(k) z^k)
c                                  k
c------------------------------------------------------------------
c     INPUT parameters
c
c      rscale        : scaling parameter
c      sources(2,ns) : coordinates of sources
c      dip(2,ns)    : dipole parameters (corresponding to c2,c3 above)
c      ns            : number of sources
c      center(2)     : expansion center
c      nterms        : Order of multipole expansion
c------------------------------------------------------------------
c      OUTPUT
c      mpole         : coeffs for local expansion
c      mpole(1,:)    : coeffs for multipole expansion - laurent
c      mpole(2,:)    : coeffs for multipole expansion - antilaurent
c      mpole(3,:)    : coeffs for multipole expansion - z antilaurent
c      mpole(4,:)    : coeffs for multipole expansion - logsource1
c      mpole(5,:)    : coeffs for multipole expansion - logsource2
c-----------------------------------------------------------------

      implicit real *8 (a-h,o-z)
      integer ns,nterms
      complex *16 mpole(nd,5,0:nterms)
      complex *16 dip(nd,2,ns)
      real *8 sources(2,ns),center(2),rscale
      complex *16 zc,z1,z2,zs,zdis,ztemp,zdisc,ztempc

      zc = dcmplx(center(1),center(2))

      do i=1,ns
         zs=dcmplx(sources(1,i),sources(2,i))
         zdis = 1.0d0
         ztemp= 1.0d0/(zs-zc)
         zdisc=dconjg(zdis)
         ztempc=dconjg(ztemp)
         do j=0,nterms
            do idim=1,nd
              mpole(idim,1,j)=mpole(idim,1,j)-dip(idim,1,i)*zdis*ztemp
              mpole(idim,2,j)=mpole(idim,2,j)-dip(idim,2,i)*zdisc*ztempc
              mpole(idim,2,j)=mpole(idim,2,j)+
     1             dconjg(dip(idim,1,i))*(j+1)*zdisc*ztempc*ztempc/ztemp
              mpole(idim,3,j)=mpole(idim,3,j) -
     1            dconjg(dip(idim,1,i))*(j+1)*zdisc*ztempc*ztempc

            enddo
            zdis=zdis*ztemp*rscale
            zdisc=zdisc*ztempc*rscale
         enddo
      enddo

      return
      end

c
c
c
c
c********************************************************************
      subroutine bh2dformtacd(nd,rscale,sources,ns,c1,dip,
     1       center,nterms,mpole)
c*****************************************************************
c     This subroutine computes the local expansion about
c     the "center" due to ns sources located at sources(2,*)
c
c      The complex velocity at zt = xt + i yt
c      due to a charge a complex charge c1 at zs = xs+i ys is given by
c
c
c      vel = 2*c1 log|zt-zs| + c1_bar (zt-zs)/(zt_bar - zs_bar)
c
c      The complex velocity due to a dipole with complex parameters
c      c2,c3 is given by
c
c
c      vel = c2/(zt-zs) - c2_bar (zt-zs)/(zt_bar-zs_bar)^2 +
c             c3/(zt_bar - zs_bar)
c
c     The multipole expansion has 5 set of coefficients
c     vel = \sum mp1(k) z^k + \sum mp2(k) z_bar^k +
c            k                k
c
c         z \sum mp3(k) z_bar^k + Re(mp4(0) log(z) + \sum mp4(k) z^k)
c              k                                       k
c
c          + i Re(mp5(0) log(z) + \sum mp5(k) z^k)
c                                  k
c------------------------------------------------------------------
c     INPUT parameters
c
c      rscale        : scaling parameter
c      sources(2,ns) : coordinates of sources
c      c1           : charge strength
c      d1           : dipole parameter 1 (corresponding to c2)
c      d2           : dipole parameter 2 (corresponding to c3)
c      ns            : number of sources
c      center(2)     : expansion center
c      nterms        : Order of multipole expansion
c------------------------------------------------------------------
c      OUTPUT
c      mpole         : coeffs for local expansion
c      mpole(1,:)    : coeffs for multipole expansion - laurent
c      mpole(2,:)    : coeffs for multipole expansion - antilaurent
c      mpole(3,:)    : coeffs for multipole expansion - z antilaurent
c      mpole(4,:)    : coeffs for multipole expansion - logsource1
c      mpole(5,:)    : coeffs for multipole expansion - logsource2
c-----------------------------------------------------------------

      implicit real *8 (a-h,o-z)
      integer ns,nterms
      complex *16 mpole(nd,5,0:nterms)
      complex *16 c1(nd,ns),dip(nd,2,ns)
      real *8 sources(2,ns),center(2),rscale
      complex *16 zc,z1,z2,zs,zdis,ztemp,zdisc,ztempc

      zc = dcmplx(center(1),center(2))

      do i=1,ns
         zs=dcmplx(sources(1,i),sources(2,i))
         zdis = 1.0d0
         ztemp= 1.0d0/(zs-zc)
         zdisc=dconjg(zdis)
         ztempc=dconjg(ztemp)
         do j=0,nterms
            do idim=1,nd
              if(j.eq.0) then
                 mpole(idim,4,j)=mpole(idim,4,j) +
     1               dreal(2*c1(idim,i))*log(cdabs(1.0d0/ztemp))
                 mpole(idim,5,j)=mpole(idim,5,j) +
     1               dimag(2*c1(idim,i))*log(cdabs(1.0d0/ztemp))
              else
                mpole(idim,4,j)=mpole(idim,4,j) -
     1              dreal(2*c1(idim,i))*zdis/j
                mpole(idim,5,j)=mpole(idim,5,j) -
     1              dimag(2*c1(idim,i))*zdis/j
              endif
              mpole(idim,2,j)=mpole(idim,2,j) +
     1            dconjg(c1(idim,i))*zdisc*ztempc/ztemp
              mpole(idim,3,j)=mpole(idim,3,j) -
     1           dconjg(c1(idim,i))*zdisc*ztempc

              mpole(idim,1,j)=mpole(idim,1,j)-dip(idim,1,i)*zdis*ztemp
              mpole(idim,2,j)=mpole(idim,2,j)-dip(idim,2,i)*zdisc*ztempc
              mpole(idim,2,j)=mpole(idim,2,j)+
     1             dconjg(dip(idim,1,i))*(j+1)*zdisc*ztempc*ztempc/ztemp
              mpole(idim,3,j)=mpole(idim,3,j) -
     1            dconjg(dip(idim,1,i))*(j+1)*zdisc*ztempc*ztempc

            enddo
            zdis=zdis*ztemp*rscale
            zdisc=zdisc*ztempc*rscale
         enddo
      enddo

      return
      end

c********************************************************************
c     TRANSLATION OPERATORS
c*******************************************************************

      subroutine bh2dlocloc(nd,rscale1,c1,hexp,nterms1,
     1       rscale2,c2,jexp,nterms2,carray,ldc)
c******************************************************************
c     Converts local expansion to local expansion
c     Given original expansions and precomputed binomial coefficients
c
c     Given local expansion in the following form
c     vel = \sum h1(k) z1^k + \sum h2(k) z1_bar^k +
c            k                k
c
c     z1 \sum h3(k) z1_bar^k + Re(h4(0) log(z1) + \sum h4(k) z1^k)
c              k                                       k
c
c          + i Re(h5(0) log(z1) + \sum h5(k) z1^k)
c     z1 = z-c1
c
c     NOTE: The subroutine will work if nterms<1000, as 1000, is
c     a hardwired number for computing zpow in the computation

c-----------------------------------------------------------------
c     INPUT
c     rscale1 : scaling parameter for original expansion
c     c1      : center of original local expansion
c     hexp    : coefficients of original taylor expansion
c     hexp(1,:) : coefficients of original taylor expansion
c     hexp(2,:) : coefficients of original antitaylor expansion
c     hexp(3,:) : coefficients of original z1 (antitaylor expansion)
c     hexp(4,:) : coefficients of original real part logsource1
c     hexp(5,:) : coefficients of original imag part logsource2
c     nterms1 : number of terms in original expansion
c     rscale2 : scaling parameter for shifted expansion
c     c2      : center of new local expansion
c     nterms2 : number of terms of the shifted expansion
c     carray  : Precomputed binomial coefficients
c     ldc     : size of carray
c-----------------------------------------------------------------
c     OUTPUT
c     jexp    : coefficients of shifted taylor expansion
c     jexp(1,:) : coefficients of shifted taylor expansion
c     jexp(2,:) : coefficients of shifted antitaylor expansion
c     jexp(3,:) : coefficients of shifted z1 (antitaylor expansion)
c     jexp(4,:) : coefficients of shifted real part logsource1
c     jexp(5,:) : coefficients of shifted imag part logsource2
c---------------------------------------------------------------
      implicit real *8 (a-h,o-z)
      integer nterms1,nterms2,ldc
      complex *16 hexp(nd,5,0:nterms1),jexp(nd,5,0:nterms2)
      complex *16 h1a(nd,0:nterms1),h2a(nd,0:nterms1),h3a(nd,0:nterms1)
      complex *16 h4a(nd,0:nterms1),h5a(nd,0:nterms1)
      complex *16 j1(nd,0:nterms2),j2(nd,0:nterms2),j3(nd,0:nterms2)
      complex *16 j4(nd,0:nterms2),j5(nd,0:nterms2)
      complex *16 zc1,zc2,zpow1(0:1000),zpow2(0:1000),zdis,zdisinv
      real *8 carray(0:ldc,0:ldc),rscale1,rscale2,c1(2),c2(2)

      zc1 = dcmplx(c1(1),c1(2))
      zc2 = dcmplx(c2(1),c2(2))
      zdis = zc2-zc1
      zdisinv = 1.0d0/zdis
      zpow1(0)=1.0d0
      zpow2(0)=1.0d0
      rinv1 = 1.0d0/rscale1

      do i=0,nterms2
        do idim=1,nd
          j1(idim,i) = 0
          j2(idim,i) = 0
          j3(idim,i) = 0
          j4(idim,i) = 0
          j5(idim,i) = 0
        enddo
      enddo
      do i=1,max(nterms1,nterms2)
           zpow1(i)=zpow1(i-1)*zdis*rinv1
           zpow2(i)=zpow2(i-1)*rscale2*zdisinv
      enddo

      do i=0,nterms1
        do idim=1,nd
          h1a(idim,i)=hexp(idim,1,i)*zpow1(i)
          h2a(idim,i)=(hexp(idim,2,i)+
     1        hexp(idim,3,i)*zdis)*dconjg(zpow1(i))
          h3a(idim,i)=hexp(idim,3,i)*dconjg(zpow1(i))
          h4a(idim,i)=hexp(idim,4,i)*zpow1(i)
          h5a(idim,i)=hexp(idim,5,i)*zpow1(i)
        enddo
      enddo

      do i=0,nterms2
         do j=i,nterms1
           do idim=1,nd
             j1(idim,i)=j1(idim,i)+h1a(idim,j)*carray(j,i)
             j2(idim,i)=j2(idim,i)+h2a(idim,j)*carray(j,i)
             j3(idim,i)=j3(idim,i)+h3a(idim,j)*carray(j,i)
             j4(idim,i)=j4(idim,i)+h4a(idim,j)*carray(j,i)
             j5(idim,i)=j5(idim,i)+h5a(idim,j)*carray(j,i)
           enddo
        enddo
        do idim=1,nd
          j1(idim,i)=j1(idim,i)*zpow2(i)
          j2(idim,i)=j2(idim,i)*dconjg(zpow2(i))
          j3(idim,i)=j3(idim,i)*dconjg(zpow2(i))
          j4(idim,i)=j4(idim,i)*zpow2(i)
          j5(idim,i)=j5(idim,i)*zpow2(i)
          jexp(idim,1,i) = jexp(idim,1,i) + j1(idim,i)
          jexp(idim,2,i) = jexp(idim,2,i) + j2(idim,i)
          jexp(idim,3,i) = jexp(idim,3,i) + j3(idim,i)
          jexp(idim,4,i) = jexp(idim,4,i) + j4(idim,i)
          jexp(idim,5,i) = jexp(idim,5,i) + j5(idim,i)
        enddo
      enddo

      return
      end
c******************************************************************
      subroutine bh2dmpmp(nd,rscale1,c1,hexp,nterms1,
     1       rscale2,c2,jexp,nterms2,carray,ldc)
c******************************************************************
c     Converts multipole expansion to multipole expansion
c     Given original expansions and precomputed binomial coefficients
c
c     Given multipole expansion in the following form
c     vel = \sum h1(k) /z1^k + \sum h2(k) /z1_bar^k +
c            k                k
c
c     z1 \sum h3(k) /z1_bar^k + Re(h4(0) log(z1) + \sum h4(k) /z1^k)
c              k                                       k
c
c          + i Re(h5(0) log(z1) + \sum h5(k) /z1^k)
c     z1 = z-c1
c
c     NOTE: The subroutine will work if nterms<1000, as 1000, is
c     a hardwired number for computing zpow in the computation

c-----------------------------------------------------------------
c     INPUT
c     nd      : number of densities
c     rscale1 : scaling parameter of original multipole expansion
c     c1      : center of original mutlipole expansion
c     hexp    : coefficients of original multipole expansion
c     hexp(1,:) : coefficients of original laurent expansion
c     hexp(2,:) : coefficients of original antilaurent expansion
c     hexp(3,:) : coefficients of original z1 *antilaurent expansion
c     hexp(4,:) : coefficients of original real part logsource1
c     hexp(5,:) : coefficients of original imag part logsource2
c     nterms1 : number of terms in original expansion
c     rscale2 : scaling parameter of shifted multipole expansion
c     c2      : center of new multipole expansion
c     nterms2 : number of terms of the shifted expansion
c     carray  : precomputed binomial coefficieints array
c-----------------------------------------------------------------
c     OUTPUT
c     jexp    : coefficients of shifted multipole expansion
c     jexp(1,:) : coefficients of shifted laurent expansion
c     jexp(2,:) : coefficients of shifted antilaurent expansion
c     jexp(3,:) : coefficients of shifted z1 *antilaurent expansion
c     jexp(4,:) : coefficients of shifted real part logsource1
c     jexp(5,:) : coefficients of shifted imag part logsource2
c---------------------------------------------------------------
      implicit real *8 (a-h,o-z)
      integer nterms1,nterms2,ldc
      complex *16 hexp(nd,5,0:nterms1),jexp(nd,5,0:nterms2)
      complex *16 h1a(nd,0:nterms1),h2a(nd,0:nterms1),h3a(nd,0:nterms1)
      complex *16 h4a(nd,0:nterms1),h5a(nd,0:nterms1)
      complex *16 j1(nd,0:nterms2),j2(nd,0:nterms2),j3(nd,0:nterms2)
      complex *16 j4(nd,0:nterms2),j5(nd,0:nterms2)
      complex *16 zc1,zc2,zpow1(0:1000),zdis,zdisinv
      complex *16 zpow2(0:1000)
      real *8 carray(0:ldc,0:ldc)
      real *8 rscale1,rscale2,c1(2),c2(2),rinv2

      nmax=max(nterms1,nterms2)

      zc1 = dcmplx(c1(1),c1(2))
      zc2 = dcmplx(c2(1),c2(2))
      zdis = zc1-zc2
      zdisinv = 1.0d0/zdis
      rinv2 = 1.0d0/rscale2
      zpow1(0)=1.0d0
      zpow2(0)=1.0d0
      do i=1,nmax
           zpow1(i)=zpow1(i-1)*zdisinv*rscale1
           zpow2(i)=zpow2(i-1)*zdis*rinv2
      enddo

      do i=0,nterms2
        do idim=1,nd
         j1(idim,i)=0.0d0
         j2(idim,i)=0.0d0
         j3(idim,i)=0.0d0
         j4(idim,i)=0.0d0
         j5(idim,i)=0.0d0
       enddo
      enddo

c     Handling the log term in the expansion
      do idim=1,nd
        jexp(idim,4,0)=jexp(idim,4,0) + hexp(idim,4,0)
        jexp(idim,5,0)=jexp(idim,5,0) + hexp(idim,5,0)
      enddo
      do i=1,nterms2
        do idim=1,nd
          j4(idim,i)=j4(idim,i)-hexp(idim,4,0)/i
          j5(idim,i)=j5(idim,i)-hexp(idim,5,0)/i
        enddo
      enddo

      do i=1,min(nterms2,nterms1)
        do idim=1,nd
          h1a(idim,i)=hexp(idim,1,i)*zpow1(i)
          h2a(idim,i)=(hexp(idim,2,i)-
     1        hexp(idim,3,i)*zdis)*dconjg(zpow1(i))
          h3a(idim,i)=hexp(idim,3,i)*dconjg(zpow1(i))
          h4a(idim,i)=hexp(idim,4,i)*zpow1(i)
          h5a(idim,i)=hexp(idim,5,i)*zpow1(i)
        enddo
      enddo

      do i=1,nterms2
         do j=1,min(i,nterms1)
           do idim=1,nd
             j1(idim,i)=j1(idim,i)+h1a(idim,j)*carray(i-1,j-1)
             j2(idim,i)=j2(idim,i)+h2a(idim,j)*carray(i-1,j-1)
             j3(idim,i)=j3(idim,i)+h3a(idim,j)*carray(i-1,j-1)
             j4(idim,i)=j4(idim,i)+h4a(idim,j)*carray(i-1,j-1)
             j5(idim,i)=j5(idim,i)+h5a(idim,j)*carray(i-1,j-1)
           enddo
        enddo
        do idim=1,nd
          j1(idim,i)=j1(idim,i)*zpow2(i)
          j2(idim,i)=j2(idim,i)*dconjg(zpow2(i))
          j3(idim,i)=j3(idim,i)*dconjg(zpow2(i))
          j4(idim,i)=j4(idim,i)*zpow2(i)
          j5(idim,i)=j5(idim,i)*zpow2(i)
          jexp(idim,1,i) = jexp(idim,1,i) + j1(idim,i)
          jexp(idim,2,i) = jexp(idim,2,i) + j2(idim,i)
          jexp(idim,3,i) = jexp(idim,3,i) + j3(idim,i)
          jexp(idim,4,i) = jexp(idim,4,i) + j4(idim,i)
          jexp(idim,5,i) = jexp(idim,5,i) + j5(idim,i)
        enddo
      enddo

      return
      end
c*******************************************************************
      subroutine bh2dmploc(nd,rscale1,c1,hexp,nterms1,
     1       rscale2,c2,jexp,nterms2,carray,ldc)
c******************************************************************
c     Converts multipole expansion to local expansion
c     Given original expansions and precomputed binomial coeffients
c
c     Given multipole expansion in the following form
c     vel = \sum h1(k) /z1^k + \sum h2(k) /z1_bar^k +
c            k                k
c
c     z1 \sum h3(k) /z1_bar^k + Re(h4(0) log(z1) + \sum h4(k) /z1^k)
c              k                                       k
c
c          + i Re(h5(0) log(z1) + \sum h5(k) /z1^k)
c     z1 = z-c1
c
c     NOTE: The subroutine will work if nterms<1000, as 1000, is
c     a hardwired number for computing zpow in the computation

c-----------------------------------------------------------------
c     INPUT
c     nd      : number of densities
c     rscale1 : scaling parameter of original multipole expansion
c     c1      : center of original mutlipole expansion
c     hexp    : coefficients of original multipole expansion
c     hexp(1,:) : coefficients of original laurent expansion
c     hexp(2,:) : coefficients of original antilaurent expansion
c     hexp(3,:) : coefficients of original z1 *antilaurent expansion
c     hexp(4,:) : coefficients of original real part logsource1
c     hexp(5,:) : coefficients of original imag part logsource2
c     nterms1 : number of terms of original expansion
c     rscale2 : scaling parameter of shifted local expansion
c     c2      : center of new local expansion
c     nterms2 : number of terms of the shifted expansion
c-----------------------------------------------------------------
c     OUTPUT
c     jexp    : coefficients of shifted taylor expansion
c     jexp(1,:) : coefficients of shifted taylor expansion
c     jexp(2,:) : coefficients of shifted antaylor expansion
c     jexp(3,:) : coefficients of shifted z1 *antitaylor expansion
c     jexp(4,:) : coefficients of shifted real part logsource1
c     jexp(5,:) : coefficients of shifted imag part logsource2
c---------------------------------------------------------------
      implicit real *8 (a-h,o-z)
      integer nterms1,nterms2,ldc
      complex *16 hexp(nd,5,0:nterms1),jexp(nd,5,0:nterms2)
      complex *16 h1a(nd,0:nterms1),h2a(nd,0:nterms1),h3a(nd,0:nterms1)
      complex *16 h4a(nd,0:nterms1),h5a(nd,0:nterms1)
      complex *16 j1(nd,0:nterms2),j2(nd,0:nterms2),j3(nd,0:nterms2)
      complex *16 j4(nd,0:nterms2),j5(nd,0:nterms2)
      complex *16 zc1,zc2,zdis,zdis1
      complex *16 zpow1(0:1000)
      complex *16 zzz,zzz1
      complex *16 zpow2(0:1000)
      real *8 carray(0:ldc,0:ldc)
      real *8 rscale1,rscale2,c1(2),c2(2)

      nmax=nterms1+nterms2

      zc1 = dcmplx(c1(1),c1(2))
      zc2 = dcmplx(c2(1),c2(2))
      zdis = 1/(zc1-zc2)
      zdis1 = (zc1-zc2)
      zpow1(0)=1.0d0
      zpow2(0)=1.0d0
      do i=1,nmax
           zpow1(i)=-zpow1(i-1)*zdis*rscale1
           zpow2(i)=zpow2(i-1)*zdis*rscale2
      enddo

      do i=0,nterms2
        do idim=1,nd
         j1(idim,i)=0.0d0
         j2(idim,i)=0.0d0
         j3(idim,i)=0.0d0
         j4(idim,i)=0.0d0
         j5(idim,i)=0.0d0
        enddo
      enddo

c     Handling the log term in the expansion
      do idim=1,nd
        j4(idim,0)=hexp(idim,4,0)*log(cdabs(zdis1))
        j5(idim,0)=hexp(idim,5,0)*log(cdabs(zdis1))
      enddo
      do i=1,nterms2
        do idim=1,nd
          j4(idim,i)=j4(idim,i)-hexp(idim,4,0)/i
          j5(idim,i)=j5(idim,i)-hexp(idim,5,0)/i
        enddo
      enddo
c
      do i=1,nterms1
        do idim=1,nd
          h1a(idim,i)=hexp(idim,1,i)*zpow1(i)
          h2a(idim,i)=(hexp(idim,2,i)-
     1        hexp(idim,3,i)*zdis1)*dconjg(zpow1(i))
          h3a(idim,i)=hexp(idim,3,i)*dconjg(zpow1(i))
          h4a(idim,i)=hexp(idim,4,i)*zpow1(i)
          h5a(idim,i)=hexp(idim,5,i)*zpow1(i)
        enddo
      enddo
      do i=0,nterms2
         do j=1,nterms1
           do idim=1,nd
             j1(idim,i)=j1(idim,i)+h1a(idim,j)*carray(i+j-1,i)
             j2(idim,i)=j2(idim,i)+h2a(idim,j)*carray(i+j-1,i)
             j3(idim,i)=j3(idim,i)+h3a(idim,j)*carray(i+j-1,i)
             j4(idim,i)=j4(idim,i)+h4a(idim,j)*carray(i+j-1,i)
             j5(idim,i)=j5(idim,i)+h5a(idim,j)*carray(i+j-1,i)
           enddo
        enddo
        do idim=1,nd
          j1(idim,i)=j1(idim,i)*zpow2(i)
          j2(idim,i)=j2(idim,i)*dconjg(zpow2(i))
          j3(idim,i)=j3(idim,i)*dconjg(zpow2(i))
          j4(idim,i)=j4(idim,i)*zpow2(i)
          j5(idim,i)=j5(idim,i)*zpow2(i)
          jexp(idim,1,i) = jexp(idim,1,i) + j1(idim,i)
          jexp(idim,2,i) = jexp(idim,2,i) + j2(idim,i)
          jexp(idim,3,i) = jexp(idim,3,i) + j3(idim,i)
          jexp(idim,4,i) = jexp(idim,4,i) + j4(idim,i)
          jexp(idim,5,i) = jexp(idim,5,i) + j5(idim,i)
        enddo
      enddo

      return
      end
c*******************************************************************

      subroutine bh2dmpzero(nd,mpole,nterms)
      implicit real *8 (a-h,o-z)
      complex *16 mpole(nd,5,0:nterms)

      do i=0,nterms
        do j=1,5
          do idim=1,nd
            mpole(idim,j,i) = 0
          enddo
        enddo
      enddo

      return
      end