module blas_z1
  use blas_kinds, only : ik, dp
  implicit none
  private :: ik, dp

  interface
    subroutine zaxpy(n, za, zx, incx, zy, incy)
      import :: ik, dp
      integer(ik) :: n
      complex(dp) :: za
      complex(dp) :: zx(*)
      integer(ik) :: incx
      complex(dp) :: zy(*)
      integer(ik) :: incy
    end subroutine zaxpy
  end interface
  interface
    subroutine zcopy(n, zx, incx, zy, incy)
      import :: ik, dp
      integer(ik) :: n
      complex(dp) :: zx(*)
      integer(ik) :: incx
      complex(dp) :: zy(*)
      integer(ik) :: incy
    end subroutine zcopy
  end interface
  interface
    function zdotc(n, zx, incx, zy, incy)
      import :: ik, dp
      integer(ik) :: n
      complex(dp) :: zx(*)
      integer(ik) :: incx
      complex(dp) :: zy(*)
      integer(ik) :: incy
      complex(dp) :: zdotc
    end function zdotc
  end interface
  interface
    function zdotu(n, zx, incx, zy, incy)
      import :: ik, dp
      integer(ik) :: n
      complex(dp) :: zx(*)
      integer(ik) :: incx
      complex(dp) :: zy(*)
      integer(ik) :: incy
      complex(dp) :: zdotu
    end function zdotu
  end interface
  interface
    subroutine zdrot(n, zx, incx, zy, incy, c, s)
      import :: ik, dp
      integer(ik) :: n
      complex(dp) :: zx(*)
      integer(ik) :: incx
      complex(dp) :: zy(*)
      integer(ik) :: incy
      real(dp) :: c
      real(dp) :: s
    end subroutine zdrot
  end interface
  interface
    subroutine zdscal(n, da, zx, incx)
      import :: ik, dp
      integer(ik) :: n
      real(dp) :: da
      complex(dp) :: zx(*)
      integer(ik) :: incx
    end subroutine zdscal
  end interface
  interface
    subroutine zrotg(a, b, c, s)
      import :: ik, dp
      complex(dp) :: a
      complex(dp) :: b
      real(dp) :: c
      complex(dp) :: s
    end subroutine zrotg
  end interface
  interface
    subroutine zscal(n, za, zx, incx)
      import :: ik, dp
      integer(ik) :: n
      complex(dp) :: za
      complex(dp) :: zx(*)
      integer(ik) :: incx
    end subroutine zscal
  end interface
  interface
    subroutine zswap(n, zx, incx, zy, incy)
      import :: ik, dp
      integer(ik) :: n
      complex(dp) :: zx(*)
      integer(ik) :: incx
      complex(dp) :: zy(*)
      integer(ik) :: incy
    end subroutine zswap
  end interface
  interface
    function dzasum(n, zx, incx)
      import :: ik, dp
      integer(ik) :: n
      complex(dp) :: zx(*)
      integer(ik) :: incx
      real(dp) :: dzasum
    end function dzasum
  end interface
  interface
    function dznrm2(n, x, incx)
      import :: ik, dp
      integer(ik) :: n
      complex(dp) :: x(*)
      integer(ik) :: incx
      real(dp) :: dznrm2
    end function dznrm2
  end interface
  interface
    function izamax(n, zx, incx)
      import :: ik, dp
      integer(ik) :: n
      complex(dp) :: zx(*)
      integer(ik) :: incx
      integer(ik) :: izamax
    end function izamax
  end interface
end module blas_z1


module Mod_tem_TempeGradient
   use typre
   use Mod_tem_BaseElmope
   implicit none
   private
   public SetPointersComputeTempeGradient, grtem

   integer(ip), allocatable :: kfl_IsSet

   real(rp), allocatable :: grtem(:)

contains

   !----------------------------------------------------------------------------
   !Setting Pointers
   subroutine SetPointersComputeTempeGradient(itask)
      implicit none
      integer(ip) :: itask

      integer(ip) :: kfl_nonlinear

      select case (itask)

      case(0)
         allocate(kfl_IsSet)
         call a%Memor%allocObj(0,'kfl_IsSet','InitProcedurePointer',1)
         kfl_IsSet = -1

      case(1)
         if (kfl_IsSet == -1) then
            kfl_IsSet = 1

            call ConcatenateProcedures(ProcHook%Initializations,Allocations)
            call ConcatenateProcedures(ProcHook%Interpolates,InterpolateGrtem)
            call ConcatenateProcedures(ProcHook%Finalizations,Deallocations)
         endif

      case(100)
         deallocate(kfl_IsSet)
         call a%Memor%deallocObj(0,'kfl_IsSet','InitProcedurePointer',1)

      end select

   end subroutine

   !--------------------------------------------------------------------
   !Temperature Gradient interpolation
   subroutine Allocations
      implicit none

      integer(ip) :: ndime

      call a%Mesh%GetNdime(ndime)
      call a%Memor%alloc(ndime,grtem,'grtem','tem_TempeGradient')
   end subroutine

   subroutine InterpolateGrtem
      implicit none

      call e%gradient(1,eltem,grtem)    !Temperature gradient
   end subroutine

   subroutine DeAllocations
      implicit none

      integer(ip) :: ndime

      call a%Mesh%GetNdime(ndime)
      call a%Memor%dealloc(ndime,grtem,'grtem','tem_TempeGradient')
   end subroutine

end module


      SUBROUTINE TAUTOG	(IERROR)
C
C LATEST REVISION	 FEBRUARY 1985
C
C PURPOSE		 TO PROVIDE A SIMPLE DEMONSTRATION OF
C			 AUTOGRAPH AND TO TEST AUTOGRAPH ON A
C			 SIMPLE	PROBLEM
C
C USAGE			 CALL TAUTOG (IERROR)
C
C ARGUMENTS
C
C ON OUTPUT		 IERROR
C			   AN ERROR PARAMETER
C			   = 0,	IF THE TEST IS SUCCESSFUL,
C			   = 1,	OTHERWISE
C
C I/O			 IF THE	TEST IS	SUCCESSFUL, THE	MESSAGE
C
C			   AUTOGRAPH TEST SUCCESSFUL  .	. .  SEE PLOT
C			   TO VERIFY PERFORMANCE
C
C			 IS WRITTEN ON UNIT 6.
C
C			 IN ADDITION, FOUR (4) LABELLED	FRAMES
C			 CONTAINING THE	TWO-DIMENSIONAL	PLOTS ARE
C			 PRODUCED ON THE MACHINE GRAPHICS DEVICE.
C			 TO DETERMINE IF THE TEST WAS SUCCESSFUL,
C			 IT IS NECESSARY TO EXAMINE THESE PLOTS.
C
C PRECISION		 SINGLE
C
C REQUIRED LIBRARY	 AUTOGRAPH
C FILES
C
C LANGUAGE		 FORTRAN
C
C HISTORY		 ORIGINALLY WRITTEN IN APRIL, 1979 AND
C			 CONVERTED TO FORTRAN 77 AND GKS IN FEBRUARY
C			 1985.
C
C ALGORITHM		 TAUTOG	COMPUTES DATA FOR AUTOGRAPH SUBROUTINES
C
C			   EZY,	EZXY, EZMY, AND	EZMXY,
C
C			 AND CALLS EACH	OF THESE ROUTINES TO PRODUCE
C			 ONE PLOT EACH.
C
C			 ON THREE OF THE PLOTS,	TAUTOG USES THE
C			 AUTOGRAPH CONTROL PARAMETER ROUTINES
C			 AGSETF, AGSETI, AND AGSETP TO SPECIFY
C			 Y-AXIS	LABELS OR INTRODUCE LOG	SCALING.
C
C PORTABILITY		 FORTRAN 77
C
      REAL	      X(21)	 ,Y1D(21)    ,Y2D(21,5)
C
C X CONTAINS THE ABSCISSA VALUES FOR THE PLOTS PRODUCED	BY EZXY	AND
C EZMXY,  Y1D CONTAINS THE ORDINATE VALUES FOR THE PLOTS PRODUCED BY
C EZXY AND EZY,	 AND Y2D CONTAINS THE ORDINATE VALUES FOR THE PLOTS
C PRODUCED BY EZMY AND EZMXY.
C
C
C
C
C FILL Y1D ARRAY FOR ENTRY EZY
C
      DO  10 I=1,21
	 Y1D(I)	= EXP(-.1*FLOAT(I))*COS(FLOAT(I)*.5)
   10 CONTINUE
C
C     ENTRY EZY	PLOTS THE CONTENTS OF Y1D AS A FUNCTION	OF THE INTEGERS
C     THE TITLE	FOR THIS PLOT IS
C
C	DEMONSTRATING EZY ENTRY	OF AUTOGRAPH
C
      CALL EZY (Y1D(1),21,'DEMONSTRATING EZY ENTRY OF AUTOGRAPH$')
C

C
C
C
C FILL X AND Y1D ARRAYS	FOR ENTRY EZXY
C
      DO  20 I=1,21
	 X(I) =	FLOAT(I-1)*.314
	 Y1D(I)	= X(I)+COS(X(I))*2.0
   20 CONTINUE
C
C     SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL
C	  X+COS(X)*2
C
      CALL AGSETC('LABEL/NAME.','L')
      CALL AGSETI('LINE/NUMBER.',100)
      CALL AGSETC('LINE/TEXT.','X+COS(X)*2$')
C
C     ENTRY EZXY PLOTS CONTENTS	OF X-ARRAY VS. Y1D-ARRAY
C     THE TITLE	FOR THIS PLOT IS
C
C	DEMONSTRATING EZXY ENTRY OF AUTOGRAPH
C
      CALL EZXY	(X,Y1D,21,'DEMONSTRATING EZXY ENTRY IN AUTOGRAPH$')
C
C
C
C
C FILL Y2D ARRAY FOR ENTRY EZMY
C
      DO  40 I=1,21
	 T = .5*FLOAT(I-1)
	 DO  30	J=1,5
	    Y2D(I,J) = EXP(-.5*T)*COS(T)/FLOAT(J)
   30	 CONTINUE
   40 CONTINUE
C
C     SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL
C	  EXP(-X/2)*COS(X)*SCALE
C
      CALL AGSETC('LABEL/NAME.','L')
      CALL AGSETI('LINE/NUMBER.',100)
      CALL AGSETC('LINE/TEXT.','EXP(-X/2)*COS(X)*SCALE$')
C
C     SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE
C     ALPHABETIC SET OF	DASHED LINE PATTERNS IS	TO BE USED.
C
      CALL AGSETI('DASH/SELECTOR.',-1)
C
C     SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE
C     GRAPH DRAWN IS TO	BE LOGARITHMIC IN THE X-AXIS.
C
      CALL AGSETI('X/LOGARITHMIC.',1)
C
C     ENTRY EZMY PLOTS MULTIPLE	ARRAYS AS A FUNCTION OF	THE INTEGERS
C     THE TITLE	FOR THIS PLOT IS
C
C	DEMONSTRATING EZMY ENTRY OF AUTOGRAPH
C
      CALL EZMY	(Y2D,21,5,10,'DEMONSTRATING EZMY ENTRY OF AUTOGRAPH$')
C
C
C
C
C FILL Y2D ARRAY FOR EZMXY
C
      DO  60 I=1,21
	 DO  50	J=1,5
	    Y2D(I,J) = X(I)**J+COS(X(I))
   50	 CONTINUE
   60 CONTINUE
C
C     SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL
C	  X**J+COS(X)
C
      CALL AGSETC('LABEL/NAME.','L')
      CALL AGSETI('LINE/NUMBER.',100)
      CALL AGSETC('LINE/TEXT.','X**J+COS(X)$')
C
C     SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE
C     ALPHABETIC SET OF	DASHED LINE PATTERNS IS	TO BE USED.
C
      CALL AGSETI('DASH/SELECTOR.',-1)
C
C     SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE GRAPH
C     IS TO BE LINEAR IN THE X-AXIS AND	LOGARITHMIC IN THE Y-AXIS.
C
      CALL AGSETI('X/LOGARITHMIC.',0)
      CALL AGSETI('Y/LOGARITHMIC.',1)
C
C     ENTRY EZMXY PLOTS	MULTIPLE ARRAYS	AS A FUNCTION OF A SINGLE
C		  X ARRAY (OR MANY X ARRAYS)
C     THE TITLE	FOR THIS PLOT IS
C
C	DEMONSTRATING EZMXY ENTRY OF AUTOGRAPH
C
      CALL EZMXY (X,Y2D,21,5,21,
     +		  'DEMONSTRATING EZMXY ENTRY OF AUTOGRAPH$')
C
      IERROR = 0
c     WRITE (6,1001)
C
      RETURN
C
c1001 FORMAT ('	 AUTOGRAPH TEST	SUCCESSFUL',24X,
c    1	      'SEE PLOT	TO VERIFY PERFORMANCE')
C
      END


      subroutine runCY_0000ll(k,l,Xtwiddle,Gtwiddle,Shat6zz,N0)
      implicit none
C---  Expression for extension of Eq. 5.60a
C---  Calculates C00llll
C---  Small terms of order Xtwiddle(0,k)*Ciiiii,Xtwiddle(0,0)*Ciiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat6zz(np,z3max,-2:0)

      do ep=-2,0
      Cv(czzzzii(z2(l,l))+N0,ep)=
     . (Gtwiddle(k,1)*Shat6zz(1,z3(l,l,l),ep)
     . +Gtwiddle(k,2)*Shat6zz(2,z3(l,l,l),ep)
     . +Xtwiddle(k,0)*Cv(czziii(z3(l,l,l))+N0,ep)
     . -Xtwiddle(0,0)*Cv(czziiii(z4(k,l,l,l))+N0,ep))
     . /(6d0*Gtwiddle(k,l))
      enddo

      return
      end


      subroutine qk15i(f,boun,inf,a,b,result,abserr,resabs,resasc)
c***begin prologue  qk15i
c***date written   800101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a3a2,h2a4a2
c***keywords  15-point transformed gauss-kronrod rules
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  the original (infinite integration range is mapped
c            onto the interval (0,1) and (a,b) is a part of (0,1).
c            it is the purpose to compute
c            i = integral of transformed integrand over (a,b),
c            j = integral of abs(transformed integrand) over (a,b).
c***description
c
c           integration rule
c           standard fortran subroutine
c           real version
c
c           parameters
c            on entry
c              f      - real
c                       fuction subprogram defining the integrand
c                       function f(x). the actual name for f needs to be
c                       declared e x t e r n a l in the calling program.
c
c              boun   - real
c                       finite bound of original integration
c                       range (set to zero if inf = +2)
c
c              inf    - integer
c                       if inf = -1, the original interval is
c                                   (-infinity,bound),
c                       if inf = +1, the original interval is
c                                   (bound,+infinity),
c                       if inf = +2, the original interval is
c                                   (-infinity,+infinity) and
c                       the integral is computed as the sum of two
c                       integrals, one over (-infinity,0) and one over
c                       (0,+infinity).
c
c              a      - real
c                       lower limit for integration over subrange
c                       of (0,1)
c
c              b      - real
c                       upper limit for integration over subrange
c                       of (0,1)
c
c            on return
c              result - real
c                       approximation to the integral i
c                       result is computed by applying the 15-point
c                       kronrod rule(resk) obtained by optimal addition
c                       of abscissae to the 7-point gauss rule(resg).
c
c              abserr - real
c                       estimate of the modulus of the absolute error,
c                       which should equal or exceed abs(i-result)
c
c              resabs - real
c                       approximation to the integral j
c
c              resasc - real
c                       approximation to the integral of
c                       abs((transformed integrand)-i/(b-a)) over (a,b)
c
c***references  (none)
c***routines called  r1mach
c***end prologue  qk15i
c
      real a,absc,absc1,absc2,abserr,b,boun,centr,
     *  dinf,r1mach,epmach,f,fc,fsum,fval1,fval2,fv1,
     *  fv2,hlgth,resabs,resasc,resg,resk,reskh,result,tabsc1,tabsc2,
     *  uflow,wg,wgk,xgk
      integer inf,j,min0
      external f
c
      dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8)
c
c           the abscissae and weights are supplied for the interval
c           (-1,1).  because of symmetry only the positive abscissae and
c           their corresponding weights are given.
c
c           xgk    - abscissae of the 15-point kronrod rule
c                    xgk(2), xgk(4), ... abscissae of the 7-point
c                    gauss rule
c                    xgk(1), xgk(3), ...  abscissae which are optimally
c                    added to the 7-point gauss rule
c
c           wgk    - weights of the 15-point kronrod rule
c
c           wg     - weights of the 7-point gauss rule, corresponding
c                    to the abscissae xgk(2), xgk(4), ...
c                    wg(1), wg(3), ... are set to zero.
c
      data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7),
     *  xgk(8)/
     *     0.9914553711208126e+00,     0.9491079123427585e+00,
     *     0.8648644233597691e+00,     0.7415311855993944e+00,
     *     0.5860872354676911e+00,     0.4058451513773972e+00,
     *     0.2077849550078985e+00,     0.0000000000000000e+00/
c
      data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7),
     *  wgk(8)/
     *     0.2293532201052922e-01,     0.6309209262997855e-01,
     *     0.1047900103222502e+00,     0.1406532597155259e+00,
     *     0.1690047266392679e+00,     0.1903505780647854e+00,
     *     0.2044329400752989e+00,     0.2094821410847278e+00/
c
      data wg(1),wg(2),wg(3),wg(4),wg(5),wg(6),wg(7),wg(8)/
     *     0.0000000000000000e+00,     0.1294849661688697e+00,
     *     0.0000000000000000e+00,     0.2797053914892767e+00,
     *     0.0000000000000000e+00,     0.3818300505051189e+00,
     *     0.0000000000000000e+00,     0.4179591836734694e+00/
c
c
c           list of major variables
c           -----------------------
c
c           centr  - mid point of the interval
c           hlgth  - half-length of the interval
c           absc*  - abscissa
c           tabsc* - transformed abscissa
c           fval*  - function value
c           resg   - result of the 7-point gauss formula
c           resk   - result of the 15-point kronrod formula
c           reskh  - approximation to the mean value of the transformed
c                    integrand over (a,b), i.e. to i/(b-a)
c
c           machine dependent constants
c           ---------------------------
c
c           epmach is the largest relative spacing.
c           uflow is the smallest positive magnitude.
c
c***first executable statement  qk15i
      epmach = r1mach(4)
      uflow = r1mach(1)
      dinf = min0(1,inf)
c
      centr = 0.5e+00*(a+b)
      hlgth = 0.5e+00*(b-a)
      tabsc1 = boun+dinf*(0.1e+01-centr)/centr
      fval1 = f(tabsc1)
      if(inf.eq.2) fval1 = fval1+f(-tabsc1)
      fc = (fval1/centr)/centr
c
c           compute the 15-point kronrod approximation to
c           the integral, and estimate the error.
c
      resg = wg(8)*fc
      resk = wgk(8)*fc
      resabs = abs(resk)
      do 10 j=1,7
        absc = hlgth*xgk(j)
        absc1 = centr-absc
        absc2 = centr+absc
        tabsc1 = boun+dinf*(0.1e+01-absc1)/absc1
        tabsc2 = boun+dinf*(0.1e+01-absc2)/absc2
        fval1 = f(tabsc1)
        fval2 = f(tabsc2)
        if(inf.eq.2) fval1 = fval1+f(-tabsc1)
        if(inf.eq.2) fval2 = fval2+f(-tabsc2)
        fval1 = (fval1/absc1)/absc1
        fval2 = (fval2/absc2)/absc2
        fv1(j) = fval1
        fv2(j) = fval2
        fsum = fval1+fval2
        resg = resg+wg(j)*fsum
        resk = resk+wgk(j)*fsum
        resabs = resabs+wgk(j)*(abs(fval1)+abs(fval2))
   10 continue
      reskh = resk*0.5e+00
      resasc = wgk(8)*abs(fc-reskh)
      do 20 j=1,7
        resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh))
   20 continue
      result = resk*hlgth
      resasc = resasc*hlgth
      resabs = resabs*hlgth
      abserr = abs((resk-resg)*hlgth)
      if(resasc.ne.0.0e+00.and.abserr.ne.0.e0) abserr = resasc*
     * amin1(0.1e+01,(0.2e+03*abserr/resasc)**1.5e+00)
      if(resabs.gt.uflow/(0.5e+02*epmach)) abserr = amax1
     * ((epmach*0.5e+02)*resabs,abserr)
      return
      end


!
! Copyright (C) 2007 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!----------------------------------------------------------------------------
SUBROUTINE g2_kin ( ik )
  !----------------------------------------------------------------------------
  !
  ! ... Calculation of kinetic energy - includes the case of the modified
  ! ... kinetic energy functional for variable-cell calculations
  !
  USE kinds,                ONLY : DP
  USE cell_base,            ONLY : tpiba2
  USE klist,                ONLY : xk
  USE gvect,                ONLY : g
  USE wvfct,                ONLY : g2kin, igk, npw, ecfixed, qcutz, q2sigma
  !
  IMPLICIT NONE
  !
  INTEGER, INTENT (IN) :: ik
  !
  ! ... local variables
  !
  INTEGER :: ig
  REAL(DP), EXTERNAL :: qe_erf
  !
  !
  g2kin(1:npw) = ( ( xk(1,ik) + g(1,igk(1:npw)) )**2 + &
                   ( xk(2,ik) + g(2,igk(1:npw)) )**2 + &
                   ( xk(3,ik) + g(3,igk(1:npw)) )**2 ) * tpiba2
  !
  IF ( qcutz > 0.D0 ) THEN
     !
     DO ig = 1, npw
        !
        g2kin(ig) = g2kin(ig) + qcutz * &
             ( 1.D0 + qe_erf( ( g2kin(ig) - ecfixed ) / q2sigma ) )
        !
     END DO
     !
  END IF
  !
  RETURN
  !
END SUBROUTINE g2_kin


C
C $Id: mddasp.f,v 1.2 2008-07-27 00:17:09 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      REAL FUNCTION MDDASP (GEOG)
C
        REAL GEOG(2)
C
        REAL DTOR,RTOD
C
        REAL ALAT,ALON,CALT,SALT,CALN,SALN
        REAL BLAT,BLON,CBLT,SBLT,CBLN,SBLN
C
        REAL XCOA,YCOA,ZCOA
        REAL XCOB,YCOB,ZCOB
C
        REAL DIST
C
        DATA DTOR /  .017453292519943E0 /
        DATA RTOD /  57.2957795130823E0 /
C
        DATA ALAT /  1.11701072128000E0 /
        DATA ALON / -2.65290046304000E0 /
C
        BLAT=GEOG(2)
        BLON=GEOG(1)

        CALT=COS(ALAT)
        SALT=SIN(ALAT)
        CALN=COS(ALON)
        SALN=SIN(ALON)
C
        CBLT=COS(BLAT)
        SBLT=SIN(BLAT)
        CBLN=COS(BLON)
        SBLN=SIN(BLON)
C
        XCOA=CALT*CALN
        YCOA=CALT*SALN
        ZCOA=SALT
C
        XCOB=CBLT*CBLN
        YCOB=CBLT*SBLN
        ZCOB=SBLT
C
        DIST=SQRT((XCOA-XCOB)**2+(YCOA-YCOB)**2+(ZCOA-ZCOB)**2)
C
        MDDASP=2.E0*RTOD*ASIN(DIST/2.E0)
C
        RETURN
C
      END