C *******************************************************************
C
C       FLUX DISTRIBUTION IN CYLINDRICAL RECEIVER CAVITY
C       BY CONTOUR ERROR METHOD
C       Code written by PRADEEP BHANDARI, Jet Propulsion Laboratory
C
C *******************************************************************
C
      DIMENSION ARALP(100),ZMIN(100),ZMAX(100),
     * FZ(100),ALP(100),Z2(100),Z3(100)
      REAL L,MU
       CHARACTER B*12
      COMMON PI,GS,NZCY,NZ,NAL,REFCONC,FOCAL,ALPMAX,BETA,
     *       DCY,DAP,L,RCY,ALPHA,G,P,CONANG,
     *       MU,KCRIT
C
      PI=3.141593
C
C   SOLAR CONSTANT NORMALIZED
      GS=1.0
C
C ----------------------------------------------------------
C ****** INPUT PARAMETERS ********
C
       WRITE (6,1500)
 1500 FORMAT (1X,' WELCOME TO THE SIMPLIFIED PROGRAM TO CALCULATE')
       WRITE (6,1510)
 1510 FORMAT (1X,' THE SOLAR FLUX DISTRIBUTION ON THE SIDE WALL OF')
       WRITE (6,1520)
 1520 FORMAT (1X,' CYLINDRICAL RECEIVER CAVITIES')
       WRITE (6,1560)
 1560 FORMAT (/1X,'NAME OF FILE FOR STORING OUTPUT: ENTER "*:*.OUT"?  ')
      READ (5,1565) B
 1565 FORMAT(A12)
      OPEN (1,FILE=B)
      WRITE (6,1600)
 1600 FORMAT(/1X,'ENTER ALL DIMENSIONS IN THE SAME UNITS,')
      WRITE (6,1601)
 1601 FORMAT(1X,'EXCEPT AS PROMPTED')
      WRITE (6,1602)
 1602 FORMAT(//1X,'ENTER DIMENSIONS OF RECEIVER CAVITY: ')
 1605 WRITE (6,1610)
 1610 FORMAT (1X,'CAVITY DIAMETER, CAVITY HEIGHT ?     ')
      READ (5,*,ERR=1605) DCY,L
 1620 WRITE (6,1630)
 1630 FORMAT (1X,'APERTURE DIAMETER ?   ')
      READ (5,*,ERR=1620) DAP
      WRITE (6,5000)
 5000 FORMAT(//1X,'ENTER CONCENTRATOR DATA :    ')
 5005 WRITE (6,5010)
 5010 FORMAT (1X,'FOCAL LENGTH, RIM ANGLE (DEGREES) ?    ')
      READ (5,*,ERR=5005) FOCAL,ALPMAX
 5020 WRITE (6,5025)
 5025 FORMAT (1X,'CONCENTRATOR REFLECTIVITY ( <= 1.0 ) ?    ')
      READ (5,*,ERR=5020) REFCONC
 5030 WRITE (6,5035)
 5035 FORMAT (1X,'CONCENTRATOR SLOPE ERROR ( MILLI RADIANS ) ?    ')
      READ (5,*,ERR=5030) SERR
C
      WRITE (1,3300) DCY
 3300 FORMAT(/1X,'CAVITY DIAMETER = ',F7.2)
      WRITE (1,3305) L
 3305 FORMAT(/1X,'CAVITY HEIGHT = ',F7.2)
      WRITE (1,3310) DAP
 3310 FORMAT(/1X,'APERTURE DIAMETER = ',F7.2)
      WRITE (1,3315) FOCAL
 3315 FORMAT(/1X,'FOCAL LENGTH OF CONCENTRATOR = ',F7.2)
      WRITE (1,3320) ALPMAX
 3320 FORMAT(/1X,'CONC. RIM ANGLE = ',F7.2,' degrees')
      WRITE (1,3325) REFCONC
 3325 FORMAT(/1X,'CONC. REFLECTIVITY = ',F7.2)
      WRITE (1,3330) SERR
 3330 FORMAT(/1X,'CONC. SLOPE ERROR = ',F7.2,' milliradians'///)
C
C ----------------------------------------------------------
C ****** NUMERICAL PARAMETERS *************************************
C
C   NO. OF CYL. SEGMENTS FOR FLUX CALCS.
      NZCY = 40
C
C   NO. OF SEGMENTS FOR BEAM AREA CALCS.
      NZ = 60
C
C   NO. OF ANGLE SEGMENTS ON CONCENTRATOR
      NAL = 60
C
C ___________________________________________________________________
C
C  ARRAYS FOR ZMIN,ZMAX & AREA OF BEAM ON CYLIN. FOR VARIOUS ALPHAS
C
      RCY = DCY/2.0
      RAP = DAP/2.0
      ALPMAX = ALPMAX*PI/180.0
      BETA = 16.0/60.0*PI/180.0 + 2*SERR/1000
      DELAL = ALPMAX/NAL
      DELMIN = FOCAL*BETA
      DELMAX = 2*FOCAL*BETA/COS(ALPMAX)/(1+COS(ALPMAX))
      KOUNT = 0
      KCRIT = 0
C     NO SPILLOVER
      IF (DELMAX.LE.RAP) THEN
      KOUNT=1
      KCRIT=1
      END IF
C     FULL RANGE SPILLOVER
      IF (DELMIN.GE.RAP) THEN
      KOUNT=2
      KCRIT=2
      END IF
      ALP(1) = DELAL/2.0
C
      DO 100 I=2,NAL
      ALP(I)=ALP(I-1)+DELAL
 100  CONTINUE
      KHI = 0
      KLOW = 0
      DO 200 I=1,NAL
      ALPHA = ALP(I)
      CONANG = BETA
      KCRIT = 1
      G = L + 2.0*FOCAL*COS(ALPHA)/(1.0+COS(ALPHA))
      P = (G-L)*TAN(ALPHA)
C
      IF (KOUNT.EQ.1) GO TO 1000
      MU = ATAN(RAP/2/FOCAL*(1+COS(ALPHA)))
      EPS = MU*COS(ALPHA)
      DELTA = 2*FOCAL*BETA/(1+COS(ALPHA))
      DELMAJ = DELTA/COS(ALPHA)
      IF (DELMAJ.GT.RAP) KCRIT = 2
 1000 CALL ZMINMAX(ZA,ZB)
      ZMIN(I)=ZA
      ZMAX(I)=ZB
      IF (ZMIN(I).GE.L) GO TO 200
      IF (ZMAX(I).LE.0.0) GO TO 200
C     NO SPILLOVER
      IF (KOUNT.EQ.1) GO TO 1020
C     FULL RANGE SPILLOVER
      IF (KOUNT.EQ.2) GO TO 1020
C     PARTIAL SPILLOVER
      DZ = (ZMAX(I)-ZMIN(I))/NZ
      Z = ZMIN(I)
      IF (DELMAJ.LE.RAP) THEN
      KCRIT = 1
      GO TO 1020
      END IF
      IF (DELTA.GE.RAP) THEN
      KCRIT = 2
      GO TO 1020
      END IF
 1100 KCRIT = 1
      Z = Z+DZ
      CALL ROOT(Z,ZMIN(I),ZMAX(I),X1)
      KCRIT = 2
      CALL ROOT(Z,ZMIN(I),ZMAX(I),X2)
      IF (X1.GT.X2) GO TO 1100
      Z2(I) = Z
      Z = ZMAX(I)
 1200 KCRIT = 1
      Z = Z-DZ
      CALL ROOT(Z,ZMIN(I),ZMAX(I),X1)
      KCRIT = 2
      CALL ROOT(Z,ZMIN(I),ZMAX(I),X2)
      IF (X1.GT.X2) GO TO 1200
      Z3(I) = Z
      KCRIT = 2
      CALL SIMPS(ZMIN(I),Z2(I),AA)
      KCRIT = 1
      CALL SIMPS(Z2(I),Z3(I),AB)
      KCRIT = 2
      CALL SIMPS(Z3(I),ZMAX(I),AC)
      ARALP(I) = AA+AB+AC
      GO TO 200
 1020 CALL SIMPS(ZMIN(I),ZMAX(I),ARALP(I))
 200  CONTINUE
C
C ********************************************************************
C
C     FLUX VARIATION WITH DISTANCE FROM FOCAL PLANE
C
      ZFP = 0.0
      Z = L
      DZ = L/NZCY
      WRITE (6,600)
      WRITE (1,600)
 600  FORMAT(//1X,'DISTANCE FROM',10X,'SIDEWALL FLUX')
      WRITE (6,605)
      WRITE (1,605)
 605  FORMAT(1X,'FOCAL PLANE',10X,'(SOLAR CONSTANTS)'//)
      DO 300 I=1,NZCY+1
      FLZ=0.0
      DO 400 J=1,NAL
      IF (ZMAX(J).LE.Z) GO TO 400
      IF (ZMIN(J).GE.Z) GO TO 400
      ALPHA = ALP(J)
      G = L+2.0*FOCAL*COS(ALPHA)/(1.0+COS(ALPHA))
      P = (G-L)*TAN(ALPHA)
      ZMN = ZMIN(J)
      ZMX = ZMAX(J)
C     NO SPILLOVER
      IF (KOUNT.EQ.1) THEN
      KCRIT = 1
      FRAC = 1.0
      GO TO 3000
      END IF
C     FULL RANGE SPILLOVER
      IF (KOUNT.EQ.2) THEN
      KCRIT = 2
      FRAC = ((RAP/2/FOCAL/BETA*(1+COS(ALPHA)))**2)*COS(ALPHA)
      GO TO 3000
      END IF
C     PARTIAL SPILLOVER
      KCRIT = 1
      E1 = 2*FOCAL*BETA/(1+COS(ALPHA))
      E2 = E1/COS(ALPHA)
      IF (E1.GE.RAP) THEN
      KCRIT = 2
      FRAC = ((RAP/2/FOCAL/BETA*(1+COS(ALPHA)))**2)*COS(ALPHA)
      GO TO 3000
      END IF
      IF (E2.LE.RAP) THEN
      FRAC = 1.0
      GO TO 3000
      END IF
      YSTR = SQRT(RAP**2-E1**2)/SIN(ALPHA)
      XSTR = SQRT(RAP**2-YSTR**2)
      BRAC1 = YSTR*XSTR+(RAP**2)*ASIN(YSTR/RAP)
      BRAC2 = YSTR*SQRT(E2**2-YSTR**2)+(E2**2)*ASIN(YSTR/E2)
      AFP = PI*RAP**2-2*BRAC1+2*COS(ALPHA)*BRAC2
      FRAC = AFP/PI/E1/E2
      IF (Z.LT.Z2(J)) THEN
      KCRIT = 2
      ZMN = ZMIN(J)
      ZMX = Z2(J)
      GO TO 3000
      END IF
      IF (Z.GT.Z3(J)) THEN
      KCRIT = 2
      ZMN = Z3(J)
      ZMX = ZMAX(J)
      GO TO 3000
      END IF
      ZMN = Z2(J)
      ZMX = Z3(J)
 3000 CALL ROOT(Z,ZMN,ZMX,X)
      Y = SQRT(RCY**2-X**2)
      TERM1 = ATAN(ABS(X/Y))*SIN(ALPHA)/(1.0+COS(ALPHA))**2/ARALP(J)
 4000 FLZ = FLZ+TERM1*DELAL*8.0*GS*REFCONC*FRAC*FOCAL**2
      FZ(I) = FLZ
 400  CONTINUE
      WRITE (6,650) ZFP,FZ(I)
      WRITE (1,650) ZFP,FZ(I)
 650  FORMAT (6X,F6.4,10X,F10.4/)
 500  Z = Z-DZ
 510  ZFP = ZFP + DZ
 300  CONTINUE
      END
C
C --------------------------------------------------------------------
C
C     SIMPSON'S RULE FOR INTEGRATION
C
      SUBROUTINE SIMPS(ZA,ZB,AREA)
      REAL L,MU
      COMMON PI,GS,NZCY,NZ,NAL,REFCONC,FOCAL,ALPMAX,BETA,
     *       DCY,DAP,L,RCY,ALPHA,G,P,CONANG,
     *       MU,KCRIT
      DELZ = (ZB-ZA)/NZ
C
C     COMPUTE SUMODD
C
      SUMODD = 0.0
      Z = ZA+DELZ
      DO 100 I=2,NZ,2
      CALL ROOT(Z,ZA,ZB,X)
      Y=SQRT(RCY**2-X**2)
      ARC=RCY*2.0*ATAN(ABS(X/Y))
      SUMODD = SUMODD+ARC
 300  Z = Z+2.0*DELZ
 100  CONTINUE
C
C     COMPUTE SUMEVE
C
      SUMEVE = 0.0
      Z = ZA+2.0*DELZ
      DO 200 I = 2,NZ-2,2
      CALL ROOT(Z,ZA,ZB,X)
      Y=SQRT(RCY**2-X**2)
      ARC=RCY*2.0*ATAN(ABS(X/Y))
      SUMEVE = SUMEVE+ARC
 400  Z = Z+2.0*DELZ
 200  CONTINUE
C
      CALL ROOT(ZA,ZA,ZB,X)
      Y=SQRT(RCY**2-X**2)
      ARCA=RCY*2.0*ATAN(ABS(X/Y))
C
      CALL ROOT(ZB,ZA,ZB,X)
      Y=SQRT(RCY**2-X**2)
      ARCB=RCY*2.0*ATAN(ABS(X/Y))
C
C     COMPUTE AREA
C
      AREA = DELZ/3.0*(ARCA+4.0*SUMODD+2.0*SUMEVE+ARCB)
      RETURN
      END
C
C --------------------------------------------------------------------
C
C     ZMIN AND ZMAX CALCULATIONS
C
      SUBROUTINE ZMINMAX(ZA,ZB)
      REAL L,MU
      COMMON PI,GS,NZCY,NZ,NAL,REFCONC,FOCAL,ALPMAX,BETA,
     *       DCY,DAP,L,RCY,ALPHA,G,P,CONANG,
     *       MU,KCRIT
      TERM1 = (G-L+RCY/TAN(ALPHA))*SIN(CONANG)
      TERM2 = SIN(ALPHA+CONANG)*COS(ALPHA)
      ZB = TERM1/TERM2+L-RCY/TAN(ALPHA)
      ZA = L-RCY/TAN(ALPHA)-TERM1/SIN(ALPHA-CONANG)/COS(ALPHA)
      IF (KCRIT.EQ.2) THEN
      ZB = G-(RCY+P)*(G-L)/(P+DAP/2)
      ZA = G-(RCY+P)*(G-L)/(P-DAP/2)
      END IF
      RETURN
      END
C
C --------------------------------------------------------------------
C
C     ROOTS OF EQUATION
C
      SUBROUTINE ROOT(Z,ZA,ZB,XA)
      REAL L,MU
      COMMON PI,GS,NZCY,NZ,NAL,REFCONC,FOCAL,ALPMAX,BETA,
     *       DCY,DAP,L,RCY,ALPHA,G,P,CONANG,
     *       MU,KCRIT
C
      NROOT = 50
      XA = 0.0
      DXA = (RCY+P)/(DAP/2+P)*DAP/2/NROOT
      FUNX = 0.0
      FUNXP = 0.0
      XP = 0.0
      RATIO = 1.0
      DO 1500 I=1,NROOT+1
 110  TERM1 = (SQRT(RCY**2-XA**2)+P)
      TERM2 = ((Z-G)*SIN(ALPHA)+TERM1*COS(ALPHA))**2
      IF (KCRIT.EQ.2) TERM2 = TERM2/(COS(ALPHA))**2
      TERM3 = (Z-G)*COS(ALPHA)-TERM1*SIN(ALPHA)
      TERM4 = (TERM3*TAN(BETA))**2
      IF (KCRIT.EQ.2) TERM4 = (TERM3*TAN(MU))**2
      FUNX  = TERM2-TERM4+XA**2
      IF (I.EQ.1) GO TO 2000
      RATIO = FUNX/FUNXP
 2000 IF (ABS(FUNX).LE.1.0E-3) GO TO 1600
      IF (RATIO.LT.0.0) THEN
      XA    = (XA+XP)/2.0
      GO TO 1600
      END IF
      FUNXP = FUNX
      XP = XA
      XA = XA+DXA
1500  CONTINUE
1600  RETURN
      END


! File VersionID:
!   $Id: functions.for 175 2009-08-27 10:22:16Z kroes006 $
! ----------------------------------------------------------------------
      real*8 function hcomean(swkmean,kup,klow,dzup,dzlow)
! ----------------------------------------------------------------------
!     UpDate             : 20090630
!     Purpose            : calc. mean hydraulic conductivity
!     Subroutines called : -
!     Functions called   : -
!     File usage         : -
! ----------------------------------------------------------------------
      implicit none
      integer swkmean
      real*8  kup,klow,dzup,dzlow, a1, a2

!     unweighted arithmic mean
      if(swkmean.eq.1)then
         hcomean = 0.5d0 * (kup + klow)
!     weighted arithmic mean
      else if(swkmean.eq.2)then
         hcomean = (dzup * kup + dzlow * klow) / (dzup + dzlow)
!     unweighted geometric mean
      else if(swkmean.eq.3)then
         hcomean = dsqrt( kup * klow)
!     weighted geometric mean
      else if(swkmean.eq.4)then
         a1 = dzup / (dzup + dzlow)
         a2 = 1.0d0 - a1
         hcomean =  (kup ** a1) * (klow ** a2)
      end if
      return
      end
!-----------------------------------------------------------------------
      real*8 function watcon (node,head,cofg,swsophy,numtab,sptab)
! ----------------------------------------------------------------------
!     UpDate             : 20090630
!     Date               : 20060208
!     Purpose            : calc. water content from pressure head HEAD
!     Subroutines called : -
!     Functions called   : -
!     File usage         : -
! ----------------------------------------------------------------------
      implicit none
      include 'arrays.fi'
! --- global
      integer swsophy,numtab(macp),node
      real*8  sptab(5,macp,matab),head,cofg(12)
! --- local
      integer i
      real*8  h_crit, h_enpr, help, m, n, s_enpr
      real*8  h105, h095, theta105, C105, a, b, c, d, term1, term2
      real*8  term3, alphah, alfamg, thetar, thetas, moiscap
      real*8  xtab(matab), ytab(matab), ztab(matab)
! ----------------------------------------------------------------------

      if(swsophy.eq.1)then
         if(head.ge.-1.0d-9)then
            watcon = sptab(2,node,numtab(node))
         else
            do i=1,numtab(node)
               xtab(i) = sptab(1,node,i)
               ytab(i) = sptab(2,node,i)
               ztab(i) = sptab(4,node,i)
            end do
            call EvalTabulatedFunction(0,numtab(node),xtab,ytab,ztab,
     &                                            head,watcon,moiscap)
         end if
         return
      end if

      h_crit = -1.0d-2
      thetar = cofg(1)
      thetas = cofg(2)
      alfamg = cofg(4)
      n = cofg(6)
      m = cofg(7)
      h_enpr = cofg(9)

      if(h_enpr .gt. h_crit)then

         if (head.ge.0.0d0) then
! ---   saturated moisture content
            watcon = thetas
         else if(head .gt. h_crit)then
            help    = (abs(alfamg*h_crit))** n
            help    = (1.0d0 + help) ** m
            help    = thetar + (thetas-thetar)/help
            watcon = help + (thetas-help)/(-h_crit)*(head-h_crit)
            watcon = min(watcon,thetas)
         else
! ---   first compute |alpha * h| ** n
            help = (abs(alfamg*head)) ** n

! ---   add 1 and raise to the power m
             help = (1.0d0 + help) ** m

! ---   now compute theta
             watcon = thetar+(thetas-thetar)/help
         end if
      else

         h105 = 1.05d0 * h_enpr
         h095 = 0.95d0 * h_enpr

         if (head .ge. h095) then
! ---   saturated moisture content
            watcon = thetas
         else if(head.lt.h095 .and. head.gt.h105)then

            s_enpr = (1.0d0 + (abs(alfamg*h_enpr)) ** n ) ** m
            alphah = abs (alfamg*h105)
            theta105 = thetar+(thetas-thetar)/
     &                  ((1.0d0 + alphah ** n ) ** m) * s_enpr
            term1 = alphah ** (n -1.0d0)
            term2 = term1 * alphah
            term2 = (1.0d0 + term2) ** (m + 1.0d0)
            term2 = (thetas-thetar) / term2
            C105  = abs(-1.0d0 * n * m * alfamg*term2*term1)*s_enpr

            term3 = (h095 - h105)**3
            a = (C105*h095 - C105*h105 + 2*theta105 - 2*thetas)/term3
            b = (C105*(h105**2 + h095*h105 -2*h095**2 ) -
     &          3*(h095 + h105)*(theta105 - thetas))/term3
            c = (h095*(C105*(h095 - h105)*(h095 + 2*h105) +
     &          6*h105*(theta105 - thetas)))/term3
            d = thetas - a * h095**3 - b * h095**2 - c * h095

            watcon = ((a * head + b ) * head + c) * head + d

         else
! ---   first compute |alpha * h| ** n
            help = (abs(alfamg*head)) ** n

! ---   add 1 and raise to the power m
            help = (1.0d0 + help) ** m

! --- For modified VanGenuchten model:
!     - S_enpr: relative saturation at Entry Pressure h_enpr
            s_enpr = (1.0d0 + (abs(alfamg*h_enpr)) ** n ) ** m

! ---   now compute theta
            watcon = thetar+(thetas-thetar)/help * s_enpr
         end if
      end if

      return
      end

! ----------------------------------------------------------------------
      real*8 function moiscap (node,head,cofg,dt,swsophy,numtab,sptab)
! ----------------------------------------------------------------------
!     UpDate             : 20090630
!     Date               : 20060208
!     Purpose            : calculate the differential moisture
!                          capacity (as a function of pressure head)
!     Subroutines called : -
!     Functions called   : watcon
!     File usage         : -
! ----------------------------------------------------------------------
      implicit none
      include 'arrays.fi'
! --- global
      integer swsophy,numtab(macp),node
      real*8  head,cofg(12),dt,sptab(5,macp,matab)
! --- local
      integer i
      real*8  h_crit,h_enpr,m,n,alphah,s_enpr,watcon
      real*8  alfamg,thetar,thetas
      real*8  h105, h095, theta105, C105, a, b, c, term1, term2, term3
      real*8  xtab(matab), ytab(matab), ztab(matab), dummy
! ----------------------------------------------------------------------

      if(swsophy.eq.1)then
         if(head.ge.-1.0d-9)then
            moiscap = 1.0d-08
         else
            do i=1,numtab(node)
               xtab(i) = sptab(1,node,i)
               ytab(i) = sptab(2,node,i)
               ztab(i) = sptab(4,node,i)
            end do
            call EvalTabulatedFunction(0,numtab(node),xtab,ytab,ztab,
     &                                               head,dummy,moiscap)
         end if
         return
      end if

      h_crit = -1.0d-2
      thetar = cofg(1)
      thetas = cofg(2)
      alfamg = cofg(4)
      n      = cofg(6)
      m      = cofg(7)
      h_enpr = cofg(9)

      if(h_enpr .gt. h_crit)then

         if (head.ge. 0.0d0) then

            moiscap = dt * 1.0d-7

         else if(head .gt. h_crit)then

            term1 = watcon(node,h_crit,cofg,swsophy,numtab,sptab)
            moiscap = (thetas-term1) / (-h_crit)
         else

! ---   use analytical evaluation of capacity
            alphah = abs (alfamg*head)

! ---   compute |alpha * h| to the power n-1
            term1 = alphah ** (n -1.0d0)

! ---   compute |alpha*h| to the power n
            term2 = term1 * alphah

! ---   add one and raise to the power m+1
            term2 = (1.0d0 + term2) ** (m + 1.0d0)

! ---   divide theta-s minus theta-r by term2
            term2 = (thetas-thetar) / term2

! ---   calculate the differential moisture capacity
            moiscap = abs(-1.0d0 * n * m * alfamg * term2 * term1)
         end if
      else

         h105 = 1.05d0 * h_enpr
         h095 = 0.95d0 * h_enpr

         if (head .ge. h095) then
! ---   saturated moisture content
            moiscap = dt * 1.0d-7

         else if(head.lt.h095 .and. head.gt.h105)then

            s_enpr = (1.0d0 + (abs(alfamg*h_enpr)) ** n ) ** m
            alphah = abs (alfamg*h105)
            theta105 = thetar+(thetas-thetar)/
     &                  ((1.0d0 + alphah ** n ) ** m) * s_enpr
            term1 = alphah ** (n -1.0d0)
            term2 = term1 * alphah
            term2 = (1.0d0 + term2) ** (m + 1.0d0)
            term2 = (thetas-thetar) / term2
            C105  = abs(-1.0d0 * n * m * alfamg*term2*term1)*s_enpr

            term3 = (h095 - h105)**3
            a = (C105*h095 - C105*h105 + 2*theta105 - 2*thetas)/term3
            b = (C105*(h105**2 + h095*h105 -2*h095**2 ) -
     &          3*(h095 + h105)*(theta105 - thetas))/term3
            c = (h095*(C105*(h095 - h105)*(h095 + 2*h105) +
     &          6*h105*(theta105 - thetas)))/term3

            moiscap = ( 3.0d0 * a * head  + 2.0d0 * b ) * head + c
            moiscap = max(moiscap, 1.0d-09)

         else

            alphah = abs (alfamg*head)
            term1 = alphah ** (n -1.0d0)
            term2 = term1 * alphah
            term2 = (1.0d0 + term2) ** (m + 1.0d0)
            term2 = (thetas-thetar) / term2

! --- For modified VanGenuchten model:
!     - S_enpr: relative saturation at Entry Pressure h_enpr
            s_enpr = (1.0d0 + (abs(alfamg*h_enpr)) ** n ) ** m

            moiscap = abs(-1.0d0 * n * m * alfamg*term2*term1) * s_enpr

         end if

      end if

      if (head.gt.-1.0d0.and.moiscap.lt.(dt * 1.0d-7))
     &                       moiscap = dt * 1.0d-7

      return
      end

      function dhconduc (node,theta,dimocap,cofg,swfrost,rfcp,
     &                   swsophy,numtab,sptab)
! ----------------------------------------------------------------------
!     Update             : 20090630
!     Date               : 2005
!     Purpose            : calculate derivative of hydraulic conductivity (as a
!                          function of THETA)
!     Subroutines called : TTutil
!     Functions called   : -
!     File usage         : -
! ----------------------------------------------------------------------
      implicit none
      include 'arrays.fi'
! --- global
      integer swfrost,swsophy,numtab(macp),node
      real*8  sptab(5,macp,matab),dhconduc,cofg(12),dimocap,theta,rfcp
! --- local
      integer i
      real*8  term0,term1,term2,term3,term4,relsat
      real*8  m,n,ksatfit,lambda,h_enpr,s_enpr,thetar,thetas,alfamg
      real*8  xtab(matab), ytab(matab), ztab(matab), hconduc
      character*200 messag
! ----------------------------------------------------------------------

      if(swsophy.eq.1)then
         if(theta.ge.sptab(2,node,numtab(node))-1.0d-9)then
            dhconduc = 1.0d+08
         else
            do i=1,numtab(node)
               xtab(i) = sptab(2,node,i)
               ytab(i) = sptab(3,node,i)
               ztab(i) = sptab(5,node,i)
            end do
            call EvalTabulatedFunction(0,numtab(node),xtab,ytab,ztab,
     &                                           theta,hconduc,dhconduc)
         end if
         return
      end if

      thetar = cofg(1)
      thetas = cofg(2)
      alfamg = cofg(4)
      ksatfit = cofg(3)
      lambda = cofg(5)
      n = cofg(6)
      m = cofg(7)
      h_enpr = cofg(9)

! --- For modified VanGenuchten model:
!     - S_enpr: relative saturation at Entry Pressure h_enpr
      s_enpr = (abs(alfamg*h_enpr)) ** n
      s_enpr = (1.0d0 + s_enpr) ** (-m)

      relsat = (theta-thetar)/(thetas-thetar)

      if(cofg(10).gt.0.0d0 .and. relsat.gt.cofg(11))then
         messag = 'Linear interpoltion option for examined ksat not '
     &   //'yet implemented for implicit hydraulic conductivity '
     &   //'(swKimpl=1) in iteration scheme'
         call fatalerr ('dhconduc',messag)
      end if

      if (relsat.lt.0.001d0) then
         dhconduc = 0.0d0
      else if(relsat.gt.s_enpr) then
         dhconduc = 1.0d-12
      else
         dhconduc = dimocap / (thetas-thetar)
         term0    = (s_enpr*relsat)**(1.0d0/m)
         term1    = 1.0d0 - term0
         term2    = (2.0d0+lambda)*term0 - lambda
         term3    = term1 ** (m-1.0d0)
         term4    = 1.d0 - (1.d0 - s_enpr**(1.d0/m)) ** m
         dhconduc = dhconduc * ksatfit * relsat ** (lambda-1.0d0)
         dhconduc = dhconduc * (1.0d0 - term1 ** m)
         dhconduc = dhconduc * (lambda + term2 * term3)
         dhconduc = dhconduc / (term4**2.d0)
      endif

! --- in case of frost conditions
      if (swfrost.eq.1)then
         dhconduc = dhconduc * rfcp
      endif

      return
      end

      real*8 function hconduc (node,theta,cofg,swfrost,rfcp,
     &                         swsophy,numtab,sptab)
! ----------------------------------------------------------------------
!     Update             : 20090630
!     Date               : 19990929
!     Purpose            : calculate hydraulic conductivity (as a
!                          function of THETA)
!     Subroutines called : -
!     Functions called   : -
!     File usage         : -
! ----------------------------------------------------------------------
      implicit none
      include 'arrays.fi'
! --- global
      integer swfrost,swsophy,numtab(macp),node
      real*8  sptab(5,macp,matab),theta,cofg(12),rfcp
! --- local
      integer i
      real*8  term1,relsat,hconode_vsmall,m,ksatfit,lambda
      real*8  relsatm,relsat1,alfamg,thetar,thetas
      real*8  h_enpr,n,term2,h_crit,thetam,relsatthr,ksatthr,ksatexm
      real*8  xtab(matab), ytab(matab), ztab(matab), dhconduc
      logical flksatexm
      data    hconode_vsmall  /1.0d-10/
! ----------------------------------------------------------------------

      if(swsophy.eq.1)then
         if(theta.ge.sptab(2,node,numtab(node))-1.0d-9)then
            hconduc = sptab(3,node,numtab(node))
         else
            do i=1,numtab(node)
               xtab(i) = sptab(2,node,i)
               ytab(i) = sptab(3,node,i)
               ztab(i) = sptab(5,node,i)
            end do
            call EvalTabulatedFunction(0,numtab(node),xtab,ytab,ztab,
     &                                           theta,hconduc,dhconduc)
         end if
         return
      end if

      thetar = cofg(1)
      thetas = cofg(2)
      alfamg = cofg(4)
      ksatfit = cofg(3)
      lambda = cofg(5)
      m = cofg(7)
      n = cofg(6)
      h_enpr = cofg(9)

      h_crit = -1.0d-2

      if(cofg(10).gt.0.0d0)then
        flksatexm = .true.
        ksatexm   = cofg(10)
        relsatthr = cofg(11)
        ksatthr   = cofg(12)
      else
        flksatexm = .false.
      end if

      relsat = (theta-thetar)/(thetas-thetar)

      if(flksatexm .and. relsat.gt.relsatthr)then

         term1   = (relsat-relsatthr)/(1.0d0-relsatthr)
         hconduc = term1 * ksatexm + (1.0d0-term1) * ksatthr

      else
        if(h_enpr .gt. h_crit)then

           if (relsat.lt.0.001d0) then
              hconduc = hconode_vsmall
           else if(relsat.gt.(1.0d0-1.0d-6))then
              hconduc = ksatfit
           else

              term1   = ( 1.0d0-relsat**(1.0d0/m) ) ** m
              hconduc = ksatfit*(relsat**lambda)*
     &                            (1.0d0-term1)*(1.0d0-term1)

           endif

        else
! --- For modified VanGenuchten model:

! ---   now compute thetam
           thetam = thetar+(thetas-thetar) *
     *            ((1.0d0 + (abs(alfamg*h_enpr)) ** n ) ** m)

           if (relsat.lt.0.001d0) then
              hconduc = hconode_vsmall
           else
              if (theta .ge. thetam) then
                 hconduc = ksatfit
              else
                 relsatm = (theta-thetar)/(thetam-thetar)
                 relsat1 = (thetas - thetar)/(thetam-thetar)
                 term1   = ( 1.0d0 - (relsatm)** (1.0d0/m) ) ** m
                 term2   = ( 1.0d0 - (relsat1)** (1.0d0/m) ) ** m
                 hconduc = ksatfit*(relsat**lambda) *
     &                 ((1.0d0-term1)/(1.0d0-term2)) ** 2.d0
              end if
           end if
        end if
        hconduc = min(hconduc,ksatfit)
      end if

! --- in case of frost conditions
      if (swfrost.eq.1)then
         hconduc = hconduc * rfcp + hconode_vsmall * (1.0d0 - rfcp)
      endif

      return
      end

! ----------------------------------------------------------------------
      real*8 function afgen(table,iltab,x)
! ----------------------------------------------------------------------
!     source             : kees rappoldt, 1/86
!     purpose            : linear interpolation in table table with
!                          length iltab for a given value of the
!                          independent variable x.
! ----------------------------------------------------------------------
      implicit none

      integer i,iltab
      real*8  table(iltab),slope,x
! ----------------------------------------------------------------------
      if (table(1).ge.x)  goto 40
      do 10 i = 3,iltab-1,2
        if (table(i).ge.x) goto 30
        if (table(i).lt.table(i-2)) goto 20
 10   continue
! --- table fully filled, argument larger then last x in table
      afgen = table(iltab)
      return
! --- table partly filled, argument larger then last x in table
 20   afgen = table(i-1)
      return
! --- argument between first and last x in table, interpolation
 30   slope = (table(i+1)-table(i-1))/(table(i)-table(i-2))
      afgen = table(i-1) + (x-table(i-2))*slope
      return
! --- argument less or equal to first x in table
 40   afgen = table(2)
      return
      end

! ----------------------------------------------------------------------
      real*8 function prhead (node,disnod,cofgen,wcon,h,
     &                        swsophy,numtab,sptab)
! ----------------------------------------------------------------------
!     update             : 20090630
!     date               : 19990912
!     purpose            : calculate pressure head at nodal
!                          point node from water content
!     description of coefficient for van Genuchten relation
!        cofgen(1,node) = ores
!        cofgen(2,node) = osat
!        cofgen(3,node) = ksatfit
!        cofgen(4,node) = alfa
!        cofgen(5,node) = lexp
!        cofgen(6,node) = npar
!        cofgen(7,node) = 1.d0 - (1.d0 / npar)
!        cofgen(8,node) = dummy
!        cofgen(9,node) = h_enpr
!        cofgen(10,node)= ksatexm
! ----------------------------------------------------------------------
      implicit none
      include 'arrays.fi'
! --- global
      integer node,swsophy,numtab(macp)
      real*8  disnod,wcon,h(macp),cofgen(12,macp),sptab(5,macp,matab)
! --- local
      integer i
      real*8  alfamg,thetar,thetas,h_enpr,s_enpr,npar,mpar
      real*8  xtab(matab), ytab(matab), ztab(matab)
      real*8  help,dummy, prh
! ----------------------------------------------------------------------

      if(swsophy.eq.1)then
         if (sptab(2,node,numtab(node))-wcon.lt.1.0d-6) then

! --- saturated pressure head
            if (node.eq.1) then
              prhead = disnod
            else
              prhead = h(node-1) + disnod
            endif
            prhead = dmax1(prhead,0.0d0)
         else
! --- unsaturated pressure head
            do i=1,numtab(node)
               xtab(i) = sptab(1,node,i)
               ytab(i) = sptab(2,node,i)
               ztab(i) = sptab(4,node,i)
            end do
            call EvalTabulatedFunction(1,numtab(node),xtab,ytab,ztab,
     &                                               wcon,prh,dummy)
            prhead = prh
         end if
         return
      end if

      thetar = cofgen(1,node)
      thetas = cofgen(2,node)
      alfamg = cofgen(4,node)
      npar   = cofgen(6,node)
      mpar   = cofgen(7,node)
      h_enpr = cofgen(9,node)

      if (thetas-wcon.lt.1.0d-6) then

! --- saturated pressure head
        if (node.eq.1) then
          prhead = disnod
        else
          prhead = h(node-1) + disnod
        endif
        prhead = dmax1(prhead,h_enpr)
      else
        if (wcon-thetar.lt.1.0d-6) then
          prhead = -1.0d12
        else

! --- For modified VanGenuchten model:
!     - S_enpr: relative saturation at Entry Pressure h_enpr
          s_enpr = (abs(alfamg*h_enpr)) ** npar
          s_enpr = (1.0d0 + s_enpr) ** (-mpar)

! ---     first calculate the inverse of the sorptivity
          help = (thetas - thetar) / (wcon - thetar) / s_enpr
! ---     raise to the power 1/m
          help = help ** (1.0d0 / mpar)
! ---     subtract one and raise to the power 1/n
          help = (help - 1.0d0) ** (1.0d0 / npar)
! ---     divide by alpha.
          prhead = -1.0d0 * abs(help/alfamg)
        endif
      endif

      return
      end

! ----------------------------------------------------------------------
      integer function stepnr(array,length,x)
! ----------------------------------------------------------------------
! --- find stepnumber
! ----------------------------------------------------------------------
      implicit none

      integer i,length
      real*8  x,array(length)
! ----------------------------------------------------------------------
      if (array(1).ge.x) goto 30

      do 10 i = 2,length
        if (array(i).gt.x)          goto 20
        if (array(i).lt.array(i-1)) goto 20
10    continue
! --- array fully filled, argument larger than last x in array
      stepnr = length
      return
! --- array partly filled, argument larger than last x in array or
! --- argument between first and last x in table
20    stepnr = i-1
      return
! --- argument less or equal to first x in array
30    stepnr = 1
      return
      end

! ----------------------------------------------------------------------
      real*8 function WLEVST (swstor,sttab)
! ----------------------------------------------------------------------
!     Date               : 23/08/99
!     Purpose            : calculate surface water level from
!                          surface water storage, using table
!     Subroutines called : -
!     Functions called   : -
!     File usage         : -
!     Differences SWAP/SWAPS: None
! ----------------------------------------------------------------------
      implicit none
! --- global
      real*8  swstor, sttab(22,2)
! --- local
      integer i
      real*8  dswst
      character*80 messag

! ----------------------------------------------------------------------
      if (swstor .lt. sttab(22,2)) then
        messag = 'Surface water storage below bottom of table'
        call fatalerr ('Wlevst',messag)
      endif
      if (swstor .gt. sttab(1,2)) then
        messag = 'Surface water storage above top of table'
        call fatalerr ('Wlevst',messag)
      endif
      i = 0
 100  i = i+1
      if (.not.(swstor.ge.sttab(i+1,2).and.
     &          swstor.le.sttab(i,2))) goto 100
      dswst = (swstor - sttab(i+1,2)) / (sttab(i,2) - sttab(i+1,2))
      wlevst = sttab(i+1,1) + dswst * (sttab(i,1) - sttab(i+1,1))

      return
      end

! ----------------------------------------------------------------------
      real*8 function swstLEV (wlev,sttab)
!-----------------------------------------------------------------------
!     Date               : 23/08/99
!     Purpose            : calculate surface water storage from
!                          surface water level
!     Subroutines called : -
!     Functions called   : -
!     File usage         : -
!     Differences SWAP/SWAPS: None
! ----------------------------------------------------------------------
      IMPLICIT NONE

      INTEGER i

      real*8  wlev, sttab(22,2),dwl
      CHARACTER messag*200
! ----------------------------------------------------------------------

      if (wlev .lt. sttab(22,1)) then
        messag = 'Surface water storage below bottom of table'
        call fatalerr ('swstlev',messag)
      endif
      if (wlev .gt. sttab(1,1)) then
        messag = 'Surface water storage above top of table'
        call fatalerr ('swstlev',messag)
      endif

      i = 0
 100  i = i+1
      if (.not.(wlev.ge.sttab(i+1,1).and.wlev.le.sttab(i,1))) goto 100
      dwl = (wlev - sttab(i+1,1)) / (sttab(i,1) - sttab(i+1,1))
      swstlev = sttab(i+1,2) + dwl * (sttab(i,2) - sttab(i+1,2))

      return
      end

! ----------------------------------------------------------------------
      real*8 function qhtab (wlev,imper,hqhtab,qqhtab)
!-----------------------------------------------------------------------
!     date               : 23/08/99
!     purpose            : calculate surface water discharge from
!                          surface water level, using table
! ----------------------------------------------------------------------
      implicit none
      include 'arrays.fi'

      integer imper,itab

      real*8  wlev,hqhtab(mamp,mamte),qqhtab(mamp,mamte),dwl
! ----------------------------------------------------------------------

      itab = 2
      do while (wlev.lt.hqhtab(imper,itab))
        itab = itab+1
      enddo
      dwl = (wlev-hqhtab(imper,itab))/
     &       (hqhtab(imper,itab-1)-hqhtab(imper,itab))
      qhtab = qqhtab(imper,itab) + dwl *
     &        (qqhtab(imper,itab-1)-qqhtab(imper,itab))

      return
      end

      real*8 function runoff(swdra,pond,pondmx,rsro,rsroexp,wls,
     &                       swst,sttab,dt)
      implicit none
      integer swdra
      real*8 pond,pondmx,rsro,rsroexp,wls,swst,sttab(22,2),dt,inun_max,
     &       swstlev

      runoff = 0.0
      if (pond-pondmx.gt.0.0d0 .and. swdra.ne.2) then
         if(rsro.lt.1.0d-3)then
            runoff = pond-pondmx
         else
            runoff = dt/rsro* (pond-pondmx)**rsroexp
         end if
      else if (swdra.eq.2) then
         if(pond.gt.pondmx .and. pond.gt.wls)then
            runoff = dt/rsro* (pond-max(pondmx,wls))**rsroexp
         else if(pond.lt.wls)then
            inun_max = swst - swstlev(pond,sttab)
            runoff = -min(inun_max,wls-max(pond,pondmx))
         end if
      end if
      return
      end


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of lamm in forward (tangent) mode:
!   variations   of useful results: lamm
!   with respect to varying inputs: tlocal solid
! 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 temperature dependent thermal conductivity
!>    @param[in,out] solid thermal conductivity at reference temperature given in input file [W / (m K)]
!>    @param[in,out] tlocal temperature at this sample index [degree Celsius]
!>    @param[in,out] tref reference temperature [degree Celsius]
!>    @param[in] ismpl local sample index
!>    @return thermal conductivity [W / (m K)]
!>    @details
!>    calculate temperature dependent thermal conductivity of the stony matrix\n
!>    (zoth & haenel, 1988)\n
DOUBLE PRECISION FUNCTION g_LAMM(solid, g_solid, tlocal, g_tlocal&
& , tref, ismpl, lamm)
  IMPLICIT NONE
  INTEGER :: ismpl
  DOUBLE PRECISION :: solid, tlocal, tref, tlimit
  DOUBLE PRECISION :: g_solid, g_tlocal
  DOUBLE PRECISION :: cddz, cddz0, cgt0, wgt, cgt
  DOUBLE PRECISION :: g_cddz, g_cgt0, g_wgt, g_cgt
  PARAMETER (tlimit=800.d0)
  DOUBLE PRECISION :: lamm
  IF (tlocal .GT. tlimit) THEN
    g_lamm = -(770.0d0*g_tlocal/(tlocal+350.0d0)**2)
    lamm = 770.0d0/(350.0d0+tlocal) + 0.7d0
  ELSE
    g_cddz = -(770.0d0*g_tlocal/(tlocal+350.0d0)**2)
    cddz = 770.0d0/(350.0d0+tlocal) + 0.7d0
    cddz0 = 770.0d0/(350.0d0+tref) + 0.7d0
    g_cgt0 = g_solid/cddz0
    cgt0 = solid/cddz0
    g_wgt = g_tlocal/(tlimit-tref)
    wgt = (tlocal-tref)/(tlimit-tref)
    g_cgt = (1.0-wgt)*g_cgt0 - (cgt0-1.0d0)*g_wgt
    cgt = cgt0 - (cgt0-1.0d0)*wgt
    g_lamm = cddz*g_cgt + cgt*g_cddz
    lamm = cgt*cddz
  END IF
  RETURN
END FUNCTION g_LAMM


*DECK RGAUSS
      FUNCTION RGAUSS (XMEAN, SD)
C***BEGIN PROLOGUE  RGAUSS
C***PURPOSE  Generate a normally distributed (Gaussian) random number.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  L6A14
C***TYPE      SINGLE PRECISION (RGAUSS-S)
C***KEYWORDS  FNLIB, GAUSSIAN, NORMAL, RANDOM NUMBER, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Generate a normally distributed random number, i.e., generate random
C numbers with a Gaussian distribution.  These random numbers are not
C exceptionally good -- especially in the tails of the distribution,
C but this implementation is simple and suitable for most applications.
C See R. W. Hamming, Numerical Methods for Scientists and Engineers,
C McGraw-Hill, 1962, pages 34 and 389.
C
C             Input Arguments --
C XMEAN  the mean of the Guassian distribution.
C SD     the standard deviation of the Guassian function
C          EXP (-1/2 * (X-XMEAN)**2 / SD**2)
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RAND
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   910819  Added EXTERNAL statement for RAND due to problem on IBM
C           RS 6000.  (WRB)
C***END PROLOGUE  RGAUSS
      EXTERNAL RAND
C***FIRST EXECUTABLE STATEMENT  RGAUSS
      RGAUSS = -6.0
      DO 10 I=1,12
        RGAUSS = RGAUSS + RAND(0.0)
 10   CONTINUE
C
      RGAUSS = XMEAN + SD*RGAUSS
C
      RETURN
      END


SUBROUTINE YLM(V,LMAX,Y)
  INTEGER            LMAX
  DOUBLE PRECISION   V(3)
  COMPLEX*16         Y(*)
  !     ..................................................................
  ! 1.     PROGRAM UNIT 'YLM'
  !           Calculates spherical harmonics
  !           FORTRAN 77 SUBROUTINE
  !
  ! 2.     PURPOSE
  !           The spherical harmonics (Condon and Shortley convention)
  !             Y(0,0),Y(1,-1),Y(1,0),Y(1,1),Y(2,-2) ... Y(LMAX,LMAX)
  !           for vector V (given in Cartesian coordinates)
  !           are calculated. In the Condon Shortley convention the
  !           spherical harmonics are defined as
  !                             +------+
  !                        m    |   1     m              im(Phi)
  !           Y(l,m) = (-1)  -+ | -----  P (cos(Theta)) e
  !                            \| 2(Pi)   l
  !                  m
  !           where P (cos(Theta)) is the normalized Associated Legendre
  !                  l
  !           function. Thus,
  !                                          m      *
  !                            Y(l,-m) = (-1) Y(l,m)
  !
  !
  ! 3.     USAGE
  !           DOUBLE PRECISION V(3), Y(5*5)
  !           V(1) = ...
  !           V(2) = ...
  !           V(3) = ...
  !           CALL YLM(V,4,Y)
  !
  !        ARGUMENT-DESCRIPTION
  !           V      - DOUBLE PRECISION vector, dimension 3        (input)
  !                    Must be given in Cartesian coordinates.
  !                    Conversion of V to polar coordinates gives the
  !                    angles Theta and Phi necessary for the calculation
  !                    of the spherical harmonics.
  !           LMAX   - INTEGER value                               (input)
  !                    upper bound of L for which spherical harmonics
  !                    will be calculated
  !                    constraint:
  !                       LMAX .GE. 0 (not checked)
  !           Y      - COMPLEX*16 array, dimension (LMAX+1)**2    (output)
  !                    contains the calculated spherical harmonics
  !                    Y(1)                   for L .EQ. 0 (M = 0)
  !                    Y(2), ..., Y(4)        for L .EQ. 1 (M = -1, 0, 1)
  !                    ...
  !                    Y(LMAX*LMAX+1), ..., Y((LMAX+1)*(LMAX+1))
  !                                           for L .EQ. LMAX
  !                                              (M = -L,...,L)
  !                    constraint:
  !                       Dimension of Y .GE. (LMAX+1)**2 (not checked)
  !
  ! 4.     METHOD
  !           The basic algorithm used to calculate the spherical
  !           harmonics for vector V is as follows:
  !
  !           Y(0,0)
  !           Y(1,0)
  !           Y(1,1)
  !           Y(1,-1) = -Y(1,1)
  !           DO L = 2, LMAX
  !              Y(L,L)   = f(Y(L-1,L-1)) ... Formula 1
  !              Y(L,L-1) = f(Y(L-1,L-1)) ... Formula 2
  !              DO M = L-2, 0, -1
  !                 Y(L,M) = f(Y(L-1,M),Y(L-2,M)) ... Formula 2
  !                 Y(L,-M)= (-1)**M*Y(L,M)
  !              ENDDO
  !           ENDDO
  !
  !           In the following the necessary recursion formulas and
  !           starting values are given:
  !
  !        Start:
  !                        +------+
  !                        |   1
  !           Y(0,0) =  -+ | -----
  !                       \| 4(Pi)
  !
  !                                   +------+
  !                                   |   3
  !           Y(1,0) =  cos(Theta) -+ | -----
  !                                  \| 4(Pi)
  !
  !                                     +------+
  !                                     |   3    i(Phi)
  !           Y(1,1) =  - sin(Theta) -+ | ----- e
  !                                    \| 8(Pi)
  !
  !        Formula 1:
  !
  !           Y(l,l) =
  !                           +--------+
  !                           | (2l+1)   i(Phi)
  !            -sin(Theta) -+ | ------  e       Y(l-1,l-1)
  !                          \|   2l
  !
  !        Formula 2:
  !                                  +---------------+
  !                                  |  (2l-1)(2l+1)
  !           Y(l,m) = cos(Theta) -+ | -------------- Y(l-1,m)  -
  !                                 \|   (l-m)(l+m)
  !
  !                                    +--------------------+
  !                                    |(l-1+m)(l-1-m)(2l+1)
  !                              -  -+ |-------------------- Y(l-2,m)
  !                                   \|  (2l-3)(l-m)(l+m)
  !
  !        Formula 3: (not used in the algorithm because of the division
  !                    by sin(Theta) which may be zero)
  !
  !                                    +--------------+
  !                      cos(Theta)    |  4(m+1)(m+1)   -i(Phi)
  !           Y(l,m) = - ---------- -+ | ------------  e       Y(l,m+1) -
  !                      sin(Theta)   \| (l+m+1)(l-m)
  !
  !                                    +--------------+
  !                                    |(l-m-1)(l+m+2)  -2i(Phi)
  !                              -  -+ |-------------- e        Y(l,m+2)
  !                                   \| (l-m)(l+m+1)
  !
  !     ..................................................................
  INTEGER            I2L, I4L2, INDEX, INDEX2, L, M, MSIGN
  DOUBLE PRECISION   A, B, C, AB, ABC, ABMAX, ABCMAX
  DOUBLE PRECISION   D4LL1C, D2L13, PI
  DOUBLE PRECISION   COSTH, SINTH, COSPH, SINPH
  DOUBLE PRECISION   TEMP1, TEMP2, TEMP3
  DOUBLE PRECISION   YLLR, YLL1R, YL1L1R, YLMR
  DOUBLE PRECISION   YLLI, YLL1I, YL1L1I, YLMI
  !
  PI = (4.0D+0)*ATAN(1.0D+0)
  !
  !        Y(0,0)
  !
  YLLR = 1.0D+0/SQRT(4.0D+0*PI)
  YLLI = 0.0D+0
  Y(1) = DCMPLX(YLLR,YLLI)
  !
  !        continue only if spherical harmonics for (L .GT. 0) are desired
  !
  IF (LMAX .LE. 0) RETURN
  !
  !        calculate sin(Phi), cos(Phi), sin(Theta), cos(Theta)
  !        Theta, Phi ... polar angles of vector V
  !
  ABMAX  = MAX(ABS(V(1)),ABS(V(2)))
  IF (ABMAX .GT. 0.0D+0) THEN
     A = V(1)/ABMAX
     B = V(2)/ABMAX
     AB = SQRT(A*A+B*B)
     COSPH = A/AB
     SINPH = B/AB
  ELSE
     COSPH = 1.0D+0
     SINPH = 0.0D+0
  ENDIF
  ABCMAX = MAX(ABMAX,ABS(V(3)))
  IF (ABCMAX .GT. 0.0D+0) THEN
     A = V(1)/ABCMAX
     B = V(2)/ABCMAX
     C = V(3)/ABCMAX
     AB = A*A + B*B
     ABC = SQRT(AB + C*C)
     COSTH = C/ABC
     SINTH = SQRT(AB)/ABC
  ELSE
     COSTH = 1.0D+0
     SINTH = 0.0D+0
  ENDIF
  !
  !        Y(1,0)
  !
  Y(3) = DCMPLX(SQRT(3.0D+0)*YLLR*COSTH,0.0D+0)
  !
  !        Y(1,1) ( = -DCONJG(Y(1,-1)))
  !
  TEMP1 = -SQRT(1.5D+0)*YLLR*SINTH
  Y(4) = DCMPLX(TEMP1*COSPH,TEMP1*SINPH)
  Y(2) = -DCONJG(Y(4))
  !
  DO L = 2, LMAX
     INDEX  = L*L+1
     INDEX2 = INDEX + 2*L
     MSIGN  = 1 - 2*MOD(L,2)
     !
     !        YLL = Y(L,L) = f(Y(L-1,L-1)) ... Formula 1
     !
     YL1L1R = DBLE(Y(INDEX-1))
     YL1L1I = DIMAG(Y(INDEX-1))
     TEMP1 = -SQRT(DBLE(2*L+1)/DBLE(2*L))*SINTH
     YLLR = TEMP1*(COSPH*YL1L1R - SINPH*YL1L1I)
     YLLI = TEMP1*(COSPH*YL1L1I + SINPH*YL1L1R)
     Y(INDEX2) = DCMPLX(YLLR,YLLI)
     Y(INDEX)  = MSIGN*DCONJG(Y(INDEX2))
     INDEX2 = INDEX2 - 1
     INDEX  = INDEX  + 1
     !
     !        YLL1 = Y(L,L-1) = f(Y(L-1,L-1)) ... Formula 2
     !               (the coefficient for Y(L-2,L-1) in Formula 2 is zero)
     !
     TEMP2 = SQRT(DBLE(2*L+1))*COSTH
     YLL1R = TEMP2*YL1L1R
     YLL1I = TEMP2*YL1L1I
     Y(INDEX2) = DCMPLX(YLL1R,YLL1I)
     Y(INDEX)  = -MSIGN*DCONJG(Y(INDEX2))
     INDEX2 = INDEX2 - 1
     INDEX  = INDEX  + 1
     !
     I4L2 = INDEX2 - 4*L + 2
     I2L  = INDEX2 - 2*L
     D4LL1C = COSTH*SQRT(DBLE(4*L*L-1))
     D2L13  = -SQRT(DBLE(2*L+1)/DBLE(2*L-3))
     !
     DO M = L - 2, 0, -1
        !        YLM = Y(L,M) = f(Y(L-2,M),Y(L-1,M)) ... Formula 2
        TEMP1 = 1.0D+0/SQRT(DBLE((L+M)*(L-M)))
        TEMP2 = D4LL1C*TEMP1
        TEMP3 = D2L13*SQRT(DBLE((L+M-1)*(L-M-1)))*TEMP1
        YLMR = TEMP2*DBLE(Y(I2L))  + TEMP3*DBLE(Y(I4L2))
        YLMI = TEMP2*DIMAG(Y(I2L)) + TEMP3*DIMAG(Y(I4L2))
        Y(INDEX2) = DCMPLX(YLMR,YLMI)
        Y(INDEX)  = MSIGN*DCONJG(Y(INDEX2))
        !
        MSIGN  = -MSIGN
        INDEX2 = INDEX2 - 1
        INDEX  = INDEX  + 1
        I4L2   = I4L2   - 1
        I2L    = I2L    - 1
     ENDDO
  ENDDO
  RETURN
  !        End of 'YLM'
END SUBROUTINE YLM


c
c     Laplace interactions
c
c     real-valued charge, dipstr, pot, grad, hess
c     real-valued dipvec
c
c**********************************************************************
      subroutine r2d_directcp(nd,sources,ns,charge,
     $           targ,nt,pot,thresh)
cf2py  intent(in) nd
cf2py  intent(in) ns,sources,charge,targ,nt,thresh
cf2py  intent(out) pot
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     pot(ii,i)  = \sum_j log(|targ(*,i)-source(*,j)|)*charge(ii,j)
c
c     The potential is not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ(2,nt)    :   location of the targets
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)   (real *8)      : potential is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt),xdiff,ydiff,rr,r
      real *8 thresh,rtmp,thresh2
      real *8 pot(nd,nt)
      real *8 charge(nd,ns)

      thresh2 = thresh*thresh
c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            rr=xdiff*xdiff+ydiff*ydiff
            if(rr.le.thresh2) goto 1000

            rtmp = log(rr)/2
            do ii=1,nd
               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
            enddo
 1000       continue
         enddo
      enddo
      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine r2d_directcg(nd,sources,ns,charge,targ,nt,pot,
     1             grad,thresh)
cf2py  intent(in) nd
cf2py  intent(in) ns,sources,charge,targ,nt,thresh
cf2py  intent(out) pot,grad
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT and gradients GRAD
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c
c     pot(ii,i)  = \sum_j log(|targ(*,i)-source(*,j)|)*charge(ii,j)
c
c     grad(ii,1:2,i)  = \nabla pot(ii,i)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ(2,nt)    :   location of the targets
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (real *8)      : potential is incremented
c     grad(nd,2,nt)  (real *8)      : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh,rtmp,thresh2
      real *8 pot(nd,nt),grad(nd,2,nt)
      real *8 dx,dy
      real *8 charge(nd,ns)

      thresh2 = thresh*thresh
c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            rr=xdiff*xdiff+ydiff*ydiff
            if(rr.lt.thresh2) goto 1000
            rtmp = log(rr)/2
            dx = xdiff/rr
            dy = ydiff/rr
c
            do ii = 1,nd
               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
               grad(ii,1,j) = grad(ii,1,j) + dx*charge(ii,i)
               grad(ii,2,j) = grad(ii,2,j) + dy*charge(ii,i)
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c
c
c
c
c
c
c**********************************************************************
      subroutine r2d_directch(nd,sources,ns,charge,targ,nt,
     1           pot,grad,hess,thresh)
cf2py  intent(in) nd
cf2py  intent(in) ns,sources,charge,targ,nt,thresh
cf2py  intent(out) pot,grad,hess
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT, gradients GRAD
c     and Hessians at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c
c     pot(ii,i)  = \sum_j log(|targ(*,i)-source(*,j)|)*charge(ii,j)
c
c     grad  = d/dz(pot)
c     hess = d^2/dz^2(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ(2,nt)    :   location of the targets
c     thresh        :   threshold for computing potential,gradient,and
c                       hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (real *8)      : potential is incremented
c     grad(nd,2,nt)  (real *8)      : gradient is incremented
c     hess(nd,3,nt)  (real *8)      : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh,thresh2
      real *8 pot(nd,nt),grad(nd,2,nt),hess(nd,3,nt)
      real *8 rtmp, xdiff2, ydiff2
      real *8 rr2, dx, dy, dxx, dxy, dyy
      real *8 charge(nd,ns)

      thresh2 = thresh*thresh

c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            xdiff2 = xdiff*xdiff
            ydiff2 = ydiff*ydiff
            rr=xdiff2+ydiff2
            rr2 = rr*rr
            if(rr.lt.thresh2) goto 1000
            rtmp = log(rr)/2
            dx = xdiff/rr
            dy = ydiff/rr
            dxx = (rr - 2*xdiff2)/rr2
            dxy = -2*xdiff*ydiff/rr2
            dyy = (rr - 2*ydiff2)/rr2

c
            do ii = 1,nd
               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
               grad(ii,1,j) = grad(ii,1,j) + dx*charge(ii,i)
               grad(ii,2,j) = grad(ii,2,j) + dy*charge(ii,i)
               hess(ii,1,j) = hess(ii,1,j) + dxx*charge(ii,i)
               hess(ii,2,j) = hess(ii,2,j) + dxy*charge(ii,i)
               hess(ii,3,j) = hess(ii,3,j) + dyy*charge(ii,i)
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine r2d_directdp(nd,sources,ns,dipstr,dipvec,
     $           targ,nt,pot,thresh)
cf2py  intent(in) nd
cf2py  intent(in) ns,sources,dipstr,dipvec,targ,nt,thresh
cf2py  intent(out) pot
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     pot(ii,i)  = \sum_j dipstr(ii,j)* dipstr(ii,:,j) \cdot
c                               \nabla_src \log |targ(:,i)-sources(:,j)|
c
c     The potential is not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   dipole strengths
c     dipvec(nd,2,ns) :   dipole orientations
c     targ(2,nt)    :   location of the targets
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)   (real *8)      : potential is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt),xdiff,ydiff,rr,r
      real *8 thresh,thresh2,p1,p2
      real *8 pot(nd,nt)
      real *8 dipstr(nd,ns)
      real *8 dipvec(nd,2,ns)
c
      thresh2 = thresh*thresh

      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            rr = xdiff*xdiff + ydiff*ydiff
            if(rr.le.thresh2) goto 1000

            p1 = -xdiff/rr
            p2 = -ydiff/rr

            do ii=1,nd
               pot(ii,j) = pot(ii,j) + dipstr(ii,i)*(dipvec(ii,1,i)*p1
     1              + dipvec(ii,2,i)*p2)
            enddo
 1000       continue
         enddo
      enddo
      return
      end
c
c
c
c
c
c
c**********************************************************************
      subroutine r2d_directdg(nd,sources,ns,dipstr,dipvec,
     1     targ,nt,pot,grad,thresh)
cf2py  intent(in) nd
cf2py  intent(in) ns,sources,dipstr,dipvec,targ,nt,thresh
cf2py  intent(out) pot,grad
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT and gradients GRAD
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     pot(ii,i)  = \sum_j dipstr(ii,j)* dipstr(ii,:,j) \cdot
c                               \nabla_src \log |targ(:,i)-sources(:,j)|
c
c     grad  = \nabla(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   charge strengths
c     dipvec(nd,2,ns) :   dipole orientations
c     targ(2,nt)    :   location of the targets
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (real *8)    : potential is incremented
c     grad(nd,2,nt)  (real *8)      : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh,rtmp
      real *8 pot(nd,nt),grad(nd,2,nt)
      real *8 dipstr(nd,ns),d1,d2
      real *8 dx1,dx2,dy1,dy2
      real *8 dipvec(nd,2,ns)
      real *8 xdiff2,ydiff2,p1,p2,thresh2,rr2
c
      thresh2 = thresh*thresh

      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            xdiff2 = xdiff*xdiff
            ydiff2 = ydiff*ydiff
            rr = xdiff2 + ydiff2
            if(rr.le.thresh2) goto 1000

            rr2 = rr*rr

            p1 = -xdiff/rr
            p2 = -ydiff/rr

            dx1 = -(rr-2*xdiff2)/rr2
            dx2 = 2*xdiff*ydiff/rr2
            dy1 = dx2
            dy2 = -(rr-2*ydiff2)/rr2

c
            do ii = 1,nd
               d1 = dipstr(ii,i)*dipvec(ii,1,i)
               d2 = dipstr(ii,i)*dipvec(ii,2,i)
               pot(ii,j) = pot(ii,j) + d1*p1 + d2*p2
               grad(ii,1,j) = grad(ii,1,j) + d1*dx1 + d2*dx2
               grad(ii,2,j) = grad(ii,2,j) + d1*dy1 + d2*dy2
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c
c
c
c
c
c
c**********************************************************************
      subroutine r2d_directdh(nd,sources,ns,dipstr,dipvec,targ,nt,
     1           pot,grad,hess,thresh)
cf2py  intent(in) nd
cf2py  intent(in) ns,sources,dipstr,dipvec,targ,nt,thresh
cf2py  intent(out) pot,grad,hess
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT, gradients GRAD
c     and Hessians at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     pot(ii,i)  = \sum_j dipstr(ii,j)* dipstr(ii,:,j) \cdot
c                               \nabla_src \log |targ(:,i)-sources(:,j)|
c
c     grad  = \nabla (pot)
c     hess = \nabla \nabla (pot) (dxx,dxy,dyy)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   charge strengths
c     dipvec(nd,2,ns) :   dipole orientations
c     targ(2,nt)    :   location of the targets
c     thresh        :   threshold for computing potential,gradient,and
c                       hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (real *8)      : potential is incremented
c     grad(nd,2,nt)  (real *8)      : gradient is incremented
c     hess(nd,3,nt)  (real *8)      : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh
      real *8 pot(nd,nt),grad(nd,2,nt),hess(nd,3,nt)
      real *8 rtmp
      real *8 dipstr(nd,ns),d1,d2
      real *8 dipvec(nd,2,ns),dx1,dx2,dy1,dy2
      real *8 xdiff2,ydiff2,p1,p2,dxx1,dxx2,dxy1,dxy2,dyy1,dyy2
      real *8 rr2,rr3,thresh2

c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            xdiff2 = xdiff*xdiff
            ydiff2 = ydiff*ydiff
            rr = xdiff2 + ydiff2
            if(rr.le.thresh2) goto 1000

            rr2 = rr*rr
            rr3 = rr2*rr

            p1 = -xdiff/rr
            p2 = -ydiff/rr

            dx1 = -(rr-2*xdiff2)/rr2
            dx2 = 2*xdiff*ydiff/rr2
            dy1 = dx2
            dy2 = -(rr-2*ydiff2)/rr2

            dxx1 = -2*xdiff*(xdiff2-3*ydiff2)/rr3
            dxx2 = 2*ydiff*(ydiff2-3*xdiff2)/rr3
            dxy1 = dxx2
            dxy2 = -dxx1
            dyy1 = dxy2
            dyy2 = -dxx2

c
            do ii = 1,nd
               d1 = dipstr(ii,i)*dipvec(ii,1,i)
               d2 = dipstr(ii,i)*dipvec(ii,2,i)
               pot(ii,j) = pot(ii,j) + d1*p1 + d2*p2
               grad(ii,1,j) = grad(ii,1,j) + d1*dx1 + d2*dx2
               grad(ii,2,j) = grad(ii,2,j) + d1*dy1 + d2*dy2
               hess(ii,1,j) = hess(ii,1,j) + d1*dxx1 + d2*dxx2
               hess(ii,2,j) = hess(ii,2,j) + d1*dxy1 + d2*dxy2
               hess(ii,3,j) = hess(ii,3,j) + d1*dyy1 + d2*dyy2
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine r2d_directcdp(nd,sources,ns,charge,
     $           dipstr,dipvec,targ,nt,pot,thresh)
cf2py  intent(in) nd
cf2py  intent(in) ns,sources,charge,dipstr,dipvec,targ,nt,thresh
cf2py  intent(out) pot
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     pot(ii,i)  = \sum_j log(|z_{j}|)*charge(ii,j)+
c                   dipstr(ii,j)* dipstr(ii,:,j) \cdot
c                      \nabla_src \log |targ(:,i)-sources(:,j)|
c
c     The potential is not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr(nd,ns) :   dipole strengths
c     dipvec(nd,2,ns) :   dipole orientations
c     targ(2,nt)    :   location of the targets
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)   (real *8)      : potential is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt),xdiff,ydiff,rr,r
      real *8 thresh,rtmp,thresh2
      real *8 pot(nd,nt)
      real *8 dipvec(nd,2,ns)
      real *8 charge(nd,ns),dipstr(nd,ns)
      real *8 xdiff2,ydiff2,p1,p2

      thresh2 = thresh*thresh
c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            rr=xdiff*xdiff+ydiff*ydiff
            if(rr.le.thresh2) goto 1000

            rtmp = log(rr)/2.0d0

            p1 = -xdiff/rr
            p2 = -ydiff/rr

            do ii=1,nd
               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
               pot(ii,j) = pot(ii,j) + dipstr(ii,i)*(dipvec(ii,1,i)*p1
     1              + dipvec(ii,2,i)*p2)
            enddo
 1000       continue
         enddo
      enddo
      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine r2d_directcdg(nd,sources,ns,charge,dipstr,dipvec,
     1     targ,nt,pot,grad,thresh)
cf2py  intent(in) nd
cf2py  intent(in) ns,sources,charge,dipstr,dipvec,targ,nt,thresh
cf2py  intent(out) pot,grad
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT and gradients GRAD
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     pot(ii,i)  = \sum_j log(|z_{j}|)*charge(ii,j)+
c                   dipstr(ii,j)* dipstr(ii,:,j) \cdot
c                      \nabla_src \log |targ(:,i)-sources(:,j)|
c
c     grad  = \nabla(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr(nd,ns) :   dipole strengths
c     dipvec(nd,2,ns) :   dipole orientations
c     targ(2,nt)    :   location of the targets
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (real *8)      : potential is incremented
c     grad(nd,2,nt)  (real *8)      : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh,rtmp,thresh2
      real *8 pot(nd,nt),grad(nd,2,nt)
      real *8 charge(nd,ns),dipstr(nd,ns)
      real *8 d1,d2
      real *8 dipvec(nd,2,ns)
      real *8 xdiff2,ydiff2,p1,p2,dxx1,dxx2,dxy1,dxy2,dyy1,dyy2
      real *8 rr2,rr3,dx,dy,dx1,dx2,dy1,dy2

      thresh2 = thresh*thresh
c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            xdiff2 = xdiff*xdiff
            ydiff2 = ydiff*ydiff
            rr = xdiff2 + ydiff2
            if(rr.lt.thresh2) goto 1000
            rtmp = log(rr)/2

            rr2 = rr*rr

            dx = xdiff/rr
            dy = ydiff/rr

            p1 = -dx
            p2 = -dy

            dx1 = -(rr-2*xdiff2)/rr2
            dx2 = 2*xdiff*ydiff/rr2
            dy1 = dx2
            dy2 = -(rr-2*ydiff2)/rr2

c
            do ii = 1,nd
               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
               grad(ii,1,j) = grad(ii,1,j) + dx*charge(ii,i)
               grad(ii,2,j) = grad(ii,2,j) + dy*charge(ii,i)

               d1 = dipstr(ii,i)*dipvec(ii,1,i)
               d2 = dipstr(ii,i)*dipvec(ii,2,i)

               pot(ii,j) = pot(ii,j) + d1*p1 + d2*p2
               grad(ii,1,j) = grad(ii,1,j) + d1*dx1 + d2*dx2
               grad(ii,2,j) = grad(ii,2,j) + d1*dy1 + d2*dy2
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c
c
c
c
c
c
c**********************************************************************
      subroutine r2d_directcdh(nd,sources,ns,charge,dipstr,dipvec,
     1     targ,nt,pot,grad,hess,thresh)
cf2py  intent(in) nd
cf2py  intent(in) ns,sources,charge,dipstr,dipvec,targ,nt,thresh
cf2py  intent(out) pot,grad,hess
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT, gradients GRAD
c     and Hessians at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c
c     pot(ii,i)  = \sum_j log(|z_{j}|)*charge(ii,j)+
c                   dipstr(ii,j)* dipstr(ii,:,j) \cdot
c                      \nabla_src \log |targ(:,i)-sources(:,j)|
c
c     grad  = \nabla(pot)
c     hess = \nabla\nabla (pot)    (dxx,dxy,dyy)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr(nd,ns) :   dipole strengths
c     targ(2,nt)    :   location of the targets
c     thresh        :   threshold for computing potential,gradient,and
c                       hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (real *8)      : potential is incremented
c     grad(nd,2,nt)  (real *8)      : gradient is incremented
c     hess(nd,3,nt)  (real *8)      : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh,thresh2
      real *8 pot(nd,nt),grad(nd,2,nt),hess(nd,3,nt)
      real *8 rtmp
      real *8 charge(nd,ns),dipstr(nd,ns),d1,d2
      real *8 dipvec(nd,2,ns),dx1,dx2,dy1,dy2
      real *8 xdiff2,ydiff2,p1,p2,dxx1,dxx2,dxy1,dxy2,dyy1,dyy2
      real *8 rr2,rr3,dxx,dxy,dyy,dx,dy

      thresh2 = thresh*thresh

c
      do j = 1,nt
      do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            xdiff2 = xdiff*xdiff
            ydiff2 = ydiff*ydiff
            rr = xdiff2 + ydiff2
            if(rr.lt.thresh2) goto 1000
            rtmp = log(rr)/2

            rr2 = rr*rr
            rr3 = rr2*rr

            dx = xdiff/rr
            dy = ydiff/rr
            dxx = (rr - 2*xdiff2)/rr2
            dxy = -2*xdiff*ydiff/rr2
            dyy = (rr - 2*ydiff2)/rr2

            p1 = -dx
            p2 = -dy

            dx1 = -dxx
            dx2 = -dxy
            dy1 = dx2
            dy2 = -dyy

            dxx1 = -2*xdiff*(xdiff2-3*ydiff2)/rr3
            dxx2 = 2*ydiff*(ydiff2-3*xdiff2)/rr3
            dxy1 = dxx2
            dxy2 = -dxx1
            dyy1 = dxy2
            dyy2 = -dxx2

            do ii = 1,nd

               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
               grad(ii,1,j) = grad(ii,1,j) + dx*charge(ii,i)
               grad(ii,2,j) = grad(ii,2,j) + dy*charge(ii,i)
               hess(ii,1,j) = hess(ii,1,j) + dxx*charge(ii,i)
               hess(ii,2,j) = hess(ii,2,j) + dxy*charge(ii,i)
               hess(ii,3,j) = hess(ii,3,j) + dyy*charge(ii,i)

               d1 = dipstr(ii,i)*dipvec(ii,1,i)
               d2 = dipstr(ii,i)*dipvec(ii,2,i)

               pot(ii,j) = pot(ii,j) + d1*p1 + d2*p2
               grad(ii,1,j) = grad(ii,1,j) + d1*dx1 + d2*dx2
               grad(ii,2,j) = grad(ii,2,j) + d1*dy1 + d2*dy2
               hess(ii,1,j) = hess(ii,1,j) + d1*dxx1 + d2*dxx2
               hess(ii,2,j) = hess(ii,2,j) + d1*dxy1 + d2*dxy2
               hess(ii,3,j) = hess(ii,3,j) + d1*dyy1 + d2*dyy2
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c


      SUBROUTINE CNTAB2(NN,NI,NJ,H,HX,HY,HYGX,HXGY,UYGX,UXGY,UXY)
      PARAMETER (MAXI=100,MAXJ=100,TINY=1.E-30)
      DIMENSION NN(NI,NJ),SUMI(MAXI),SUMJ(MAXJ)
      SUM=0
      DO 12 I=1,NI
        SUMI(I)=0.0
        DO 11 J=1,NJ
          SUMI(I)=SUMI(I)+NN(I,J)
          SUM=SUM+NN(I,J)
11      CONTINUE
12    CONTINUE
      DO 14 J=1,NJ
        SUMJ(J)=0.
        DO 13 I=1,NI
          SUMJ(J)=SUMJ(J)+NN(I,J)
13      CONTINUE
14    CONTINUE
      HX=0.
      DO 15 I=1,NI
        IF(SUMI(I).NE.0.)THEN
          P=SUMI(I)/SUM
          HX=HX-P*ALOG(P)
        ENDIF
15    CONTINUE
      HY=0.
      DO 16 J=1,NJ
        IF(SUMJ(J).NE.0.)THEN
          P=SUMJ(J)/SUM
          HY=HY-P*ALOG(P)
        ENDIF
16    CONTINUE
      H=0.
      DO 18 I=1,NI
        DO 17 J=1,NJ
          IF(NN(I,J).NE.0)THEN
            P=NN(I,J)/SUM
            H=H-P*ALOG(P)
          ENDIF
17      CONTINUE
18    CONTINUE
      HYGX=H-HX
      HXGY=H-HY
      UYGX=(HY-HYGX)/(HY+TINY)
      UXGY=(HX-HXGY)/(HX+TINY)
      UXY=2.*(HX+HY-H)/(HX+HY+TINY)
      RETURN
      END


*DECK CHIEV
      SUBROUTINE CHIEV (A, LDA, N, E, V, LDV, WORK, JOB, INFO)
C***BEGIN PROLOGUE  CHIEV
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a complex Hermitian matrix.
C***LIBRARY   SLATEC
C***CATEGORY  D4A3
C***TYPE      COMPLEX (SSIEV-S, CHIEV-C)
C***KEYWORDS  COMPLEX HERMITIAN, EIGENVALUES, EIGENVECTORS, MATRIX,
C             SYMMETRIC
C***AUTHOR  Kahaner, D. K., (NBS)
C           Moler, C. B., (U. of New Mexico)
C           Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     David Kahaner, Cleve Moler, G. W. Stewart,
C       N.B.S.         U.N.M.      N.B.S./U.MD.
C
C     Abstract
C      CHIEV computes the eigenvalues and, optionally,
C      the eigenvectors of a complex Hermitian matrix.
C
C     Call Sequence Parameters-
C       (the values of parameters marked with * (star) will be changed
C         by CHIEV.)
C
C        A*      COMPLEX(LDA,N)
C                complex Hermitian input matrix.
C                Only the upper triangle of A need be
C                filled in.  Elements on diagonal must be real.
C
C        LDA     INTEGER
C                set by the user to
C                the leading dimension of the complex array A.
C
C        N       INTEGER
C                set by the user to
C                the order of the matrices A and V, and
C                the number of elements in E.
C
C        E*      REAL(N)
C                on return from CHIEV E contains the eigenvalues of A.
C                See also INFO below.
C
C        V*      COMPLEX(LDV,N)
C                on return from CHIEV if the user has set JOB
C                = 0        V is not referenced.
C                = nonzero  the N eigenvectors of A are stored in the
C                first N columns of V.  See also INFO below.
C
C        LDV     INTEGER
C                set by the user to
C                the leading dimension of the array V if JOB is also
C                set nonzero.  In that case N must be .LE. LDV.
C                If JOB is set to zero LDV is not referenced.
C
C        WORK*   REAL(4N)
C                temporary storage vector.  Contents changed by CHIEV.
C
C        JOB     INTEGER
C                set by the user to
C                = 0        eigenvalues only to be calculated by CHIEV.
C                           Neither V nor LDV are referenced.
C                = nonzero  eigenvalues and vectors to be calculated.
C                           In this case A and V must be distinct arrays
C                           also if LDA .GT. LDV CHIEV changes all the
C                           elements of A thru column N.  If LDA < LDV
C                           CHIEV changes all the elements of V through
C                           column N.  If LDA = LDV only A(I,J) and V(I,
C                           J) for I,J = 1,...,N are changed by CHIEV.
C
C        INFO*   INTEGER
C                on return from CHIEV the value of INFO is
C                = 0  normal return, calculation successful.
C                = K  if the eigenvalue iteration fails to converge,
C                     eigenvalues (and eigenvectors if requested)
C                     1 through K-1 are correct.
C
C      Error Messages
C           No. 1  recoverable  N is greater than LDA
C           No. 2  recoverable  N is less than one.
C           No. 3  recoverable  JOB is nonzero and N is greater than LDV
C           No. 4  warning      LDA > LDV,  elements of A other than the
C                               N by N input elements have been changed
C           No. 5  warning      LDA < LDV,  elements of V other than the
C                               N by N output elements have been changed
C           No. 6  recoverable  nonreal element on diagonal of A.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  HTRIBK, HTRIDI, IMTQL2, SCOPY, SCOPYM, TQLRAT,
C                    XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800808  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  CHIEV
      INTEGER I,INFO,J,JOB,K,L,LDA,LDV,M,MDIM,N
      REAL A(*),E(*),WORK(*),V(*)
C***FIRST EXECUTABLE STATEMENT  CHIEV
      IF (N .GT. LDA) CALL XERMSG ('SLATEC', 'CHIEV', 'N .GT. LDA.', 1,
     +   1)
      IF(N .GT. LDA) RETURN
      IF (N .LT. 1) CALL XERMSG ('SLATEC', 'CHIEV', 'N .LT. 1', 2, 1)
      IF(N .LT. 1) RETURN
      IF(N .EQ. 1 .AND. JOB .EQ. 0) GO TO 35
      MDIM = 2 * LDA
      IF(JOB .EQ. 0) GO TO 5
      IF (N .GT. LDV) CALL XERMSG ('SLATEC', 'CHIEV',
     +   'JOB .NE. 0 AND N .GT. LDV.', 3, 1)
      IF(N .GT. LDV) RETURN
      IF(N .EQ. 1) GO TO 35
C
C       REARRANGE A IF NECESSARY WHEN LDA.GT.LDV AND JOB .NE.0
C
      MDIM = MIN(MDIM,2 * LDV)
      IF (LDA .LT. LDV) CALL XERMSG ('SLATEC', 'CHIEV',
     +   'LDA.LT.LDV,  ELEMENTS OF V OTHER THAN THE N BY N OUTPUT ' //
     +   'ELEMENTS HAVE BEEN CHANGED.', 5, 0)
      IF(LDA.LE.LDV) GO TO 5
      CALL XERMSG ('SLATEC', 'CHIEV',
     +   'LDA.GT.LDV, ELEMENTS OF A OTHER THAN THE N BY N INPUT ' //
     +   'ELEMENTS HAVE BEEN CHANGED.', 4, 0)
      L = N - 1
      DO 4 J=1,L
         M = 1+J*2*LDV
         K = 1+J*2*LDA
         CALL SCOPY(2*N,A(K),1,A(M),1)
    4 CONTINUE
    5 CONTINUE
C
C     FILL IN LOWER TRIANGLE OF A, COLUMN BY COLUMN.
C
      DO 6 J = 1,N
       K = (J-1)*(MDIM+2)+1
       IF (A(K+1) .NE. 0.0) CALL XERMSG ('SLATEC', 'CHIEV',
     +    'NONREAL ELEMENT ON DIAGONAL OF A', 6, 1)
      IF(A(K+1) .NE.0.0) RETURN
       CALL SCOPY(N-J+1,A(K),MDIM,A(K),2)
       CALL SCOPYM(N-J+1,A(K+1),MDIM,A(K+1),2)
    6 CONTINUE
C
C     SEPARATE REAL AND IMAGINARY PARTS
C
      DO 10 J = 1, N
       K = (J-1) * MDIM +1
       L = K + N
       CALL SCOPY(N,A(K+1),2,WORK(1),1)
       CALL SCOPY(N,A(K),2,A(K),1)
       CALL SCOPY(N,WORK(1),1,A(L),1)
   10 CONTINUE
C
C    REDUCE A TO TRIDIAGONAL MATRIX.
C
      CALL HTRIDI(MDIM,N,A(1),A(N+1),E,WORK(1),WORK(N+1),
     1            WORK(2*N+1))
      IF(JOB .NE. 0) GOTO 15
C
C     EIGENVALUES ONLY.
C
      CALL TQLRAT(N,E,WORK(N+1),INFO)
      RETURN
C
C     EIGENVALUES AND EIGENVECTORS.
C
   15 DO 17 J = 1,N
       K = (J-1) * MDIM + 1
       M = K + N - 1
       DO 16 I = K,M
   16   V(I) = 0.
       I = K + J - 1
       V(I) = 1.
   17 CONTINUE
      CALL IMTQL2(MDIM,N,E,WORK(1),V,INFO)
      IF(INFO .NE. 0) RETURN
      CALL HTRIBK(MDIM,N,A(1),A(N+1),WORK(2*N+1),N,V(1),V(N+1))
C
C    CONVERT EIGENVECTORS TO COMPLEX STORAGE.
C
      DO 20 J = 1,N
       K = (J-1) * MDIM + 1
       I = (J-1) * 2 * LDV + 1
       L = K + N
       CALL SCOPY(N,V(K),1,WORK(1),1)
       CALL SCOPY(N,V(L),1,V(I+1),2)
       CALL SCOPY(N,WORK(1),1,V(I),2)
   20 CONTINUE
      RETURN
C
C     TAKE CARE OF N=1 CASE.
C
   35 IF (A(2) .NE. 0.) CALL XERMSG ('SLATEC', 'CHIEV',
     +   'NONREAL ELEMENT ON DIAGONAL OF A', 6, 1)
      IF(A(2) .NE. 0.) RETURN
      E(1) = A(1)
      INFO = 0
      IF(JOB .EQ. 0) RETURN
      V(1) = A(1)
      V(2) = 0.
      RETURN
      END