module spherepack

    use, intrinsic :: ISO_Fortran_env, only: &
        stderr => ERROR_UNIT, &
        stdout => OUTPUT_UNIT

    use spherepack_precision, only: &
        wp, & ! working precision
        ip, & ! integer precision
        HALF_PI, &
        PI, &
        TWO_PI

    use divergence_routines, only: &
        divec, dives, divgc, divgs, &
        idivec, idives, idivgc, idivgs

    use gaussian_latitudes_and_weights_routines, only: &
        compute_gaussian_latitudes_and_weights

    use coordinate_transfer_routines, only: &
        geo2maths, math2geos, geo2mathv, math2geov

    use grid_transfer_routines, only: &
        trssph, sshifte, sshifti, initialize_sshifte, &
        trvsph, vshifte, vshifti, initialize_vshifte

    use gradient_routines, only: &
        gradec, grades, gradgc, gradgs, &
        igradec, igrades, igradgc, igradgs

    use module_idvtec, only: &
        idvtec

    use module_idvtes, only: &
        idvtes

    use module_idvtgc, only: &
        idvtgc

    use module_idvtgs, only: &
        idvtgs

    use icosahedral_geodesic_routines, only: &
        ihgeod

    use module_isfvpec, only: &
        isfvpec

    use module_isfvpes, only: &
        isfvpes

    use module_isfvpgc, only: &
        isfvpgc

    use module_isfvpgs, only: &
        isfvpgs

    use module_sfvpec, only: &
        sfvpec

    use module_sfvpes, only: &
        sfvpes

    use module_sfvpgc, only: &
        sfvpgc

    use module_sfvpgs, only: &
        sfvpgs

    use scalar_analysis_routines, only: &
        initialize_shaec, shaec, shaeci, &
        initialize_shaes, shaes, shaesi, &
        initialize_shagc, shagc, shagci, &
        initialize_shags, shags, shagsi

    use scalar_projection_routines, only: &
        shpe, shpei, &
        shpg, shpgi

    use scalar_synthesis_routines, only: &
        initialize_shsec, shsec, shseci, &
        initialize_shses, shses, shsesi, &
        initialize_shsgc, shsgc, shsgci, &
        initialize_shsgs, shsgs, shsgsi

    use scalar_laplacian_routines, only: &
        slapec, slapes, slapgc, slapgs, &
        islapec, islapes, islapgc, islapgs

    use vector_analysis_routines, only: &
        initialize_vhaec, vhaec, vhaeci, &
        initialize_vhaes, vhaes, vhaesi, &
        initialize_vhagc, vhagc, vhagci, &
        initialize_vhags, vhags, vhagsi

    use vector_synthesis_routines, only: &
        initialize_vhsec, vhsec, vhseci, &
        initialize_vhses, vhses, vhsesi, &
        initialize_vhsgc, vhsgc, vhsgci, &
        initialize_vhsgs, vhsgs, vhsgsi

    !    use module_visequ, only: &
    !        visequ
    !
    !    use module_visgau, only: &
    !        visgau
    !
    !    use module_visgeo, only: &
    !        visgeo

    use vector_laplacian_routines, only: &
        vlapec, vlapes, vlapgc, vlapgs, &
        ivlapec, ivlapes, ivlapgc, ivlapgs

    use vorticity_routines, only: &
        vrtec, vrtes, vrtgc, vrtgs, &
        ivrtec, ivrtes, ivrtgc, ivrtgs

    use colatitudinal_derivative_routines, only: &
        vtsec, vtseci, initialize_vtsec, &
        vtses, vtsesi, initialize_vtses, &
        vtsgc, vtsgci, initialize_vtsgc, &
        vtsgs, vtsgsi, initialize_vtsgs

    use type_FastFourierTransform, only: &
        FastFourierTransform

    use type_RealPeriodicFastFourierTransform, only: &
        RealPeriodicFastFourierTransform, &
        hrffti, hrfftf, hrfftb

    use type_AssociatedLegendrePolynomialGenerator, only: &
        AssociatedLegendrePolynomialGenerator, &
        alfk, lfp, lfpt, lfim, lfin

    use type_Vector3D, only: &
        Vector3D, &
        Vector3DPointer, &
        assignment(=), &
        operator(*)

    use type_Sphere, only: &
        Sphere

    use type_GaussianGrid, only:&
        GaussianGrid

    use type_GaussianSphere, only: &
        GaussianSphere

    use type_RegularGrid, only: &
        RegularGrid

    use type_RegularSphere, only: &
        RegularSphere

    use type_SpherepackUtility, only: &
        SpherepackUtility

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private

    ! Constants
    public :: wp, ip
    public :: HALF_PI, PI, TWO_PI

    ! Derived data types
    public :: FastFourierTransform
    public :: RealPeriodicFastFourierTransform
    public :: AssociatedLegendrePolynomialGenerator
    public :: GaussianGrid
    public :: GaussianSphere
    public :: RegularGrid
    public :: RegularSphere
    public :: Sphere
    public :: Vector3D
    public :: Vector3DPointer
    public :: assignment(=)
    public :: operator(*)

    ! Colatitude derivative
    public :: vtsec, vtseci, initialize_vtsec
    public :: vtses, vtsesi, initialize_vtses
    public :: vtsgc, vtsgci, initialize_vtsgc
    public :: vtsgs, vtsgsi, initialize_vtsgs

    ! Gradient
    public :: gradec, grades, gradgc, gradgs

    ! Inverse gradient
    public :: igradec, igrades, igradgc, igradgs

    ! Divergence
    public :: divec, dives, divgc, divgs

    ! Inverse divergence
    public :: idivec, idives, idivgc, idivgs

    ! Vorticity
    public :: vrtec, vrtes, vrtgc, vrtgs

    ! Inverse vorticity
    public :: ivrtec, ivrtes, ivrtgc, ivrtgs

    ! Gaussian wts & pts
    public :: compute_gaussian_latitudes_and_weights

    ! Geo/math coordinate transfers
    public :: geo2maths, math2geos, geo2mathv, math2geov

    ! Multiple ffts
    public :: hrffti, hrfftf, hrfftb

    public :: idvtec, idvtes, idvtgc, idvtgs

    public :: ihgeod
    public :: isfvpec, isfvpes, isfvpgc, isfvpgs
    public :: islapec, islapes, islapgc, islapgs
    public :: ivlapec, ivlapes, ivlapgc, ivlapgs

    public :: sfvpec, sfvpes, sfvpgc, sfvpgs

    ! Scalar analysis routines
    public :: shagc, shagci, initialize_shaec
    public :: shaes, shaesi, initialize_shaes
    public :: shaec, shaeci, initialize_shagc
    public :: shags, shagsi, initialize_shags

    ! Scalar synthesis routines
    public :: shsgc, shsgci, initialize_shsec
    public :: shses, shsesi, initialize_shses
    public :: shsec, shseci, initialize_shsgc
    public :: shsgs, shsgsi, initialize_shsgs

    ! Vector analysis routines
    public :: vhagc, vhagci, initialize_vhaec
    public :: vhaes, vhaesi, initialize_vhaes
    public :: vhaec, vhaeci, initialize_vhagc
    public :: vhags, vhagsi, initialize_vhags

    ! Vector synthesis routines
    public :: vhsgc, vhsgci, initialize_vhsec
    public :: vhses, vhsesi, initialize_vhses
    public :: vhsec, vhseci, initialize_vhsgc
    public :: vhsgs, vhsgsi, initialize_vhsgs

    public :: shpe, shpei
    public :: shpg, shpgi

    public :: slapec, slapes, slapgc, slapgs
    public :: vlapec, vlapes, vlapgc, vlapgs

    ! Grid transfer routines
    public :: trssph, sshifte, sshifti, initialize_sshifte
    public :: trvsph, vshifte, vshifti, initialize_vshifte

    public :: alfk, lfp, lfpt, lfim, lfin

    ! Temporary solution for testing
    public :: vecout, iout, name, vout, check_error

    interface vecout
        module procedure vecout_array
        module procedure vecout_scalar
    end interface vecout

    interface vout
        module procedure vout_array
        module procedure vout_scalar
    end interface vout

contains

    subroutine vecout_array(vec, nam, vec_size)

        ! Dummy arguments
        real(wp),         intent(in) ::vec(vec_size)
        character(len=*), intent(in) :: nam
        integer(ip),      intent(in) :: vec_size

        ! Local variables
        integer(ip) :: i

        write (stdout, 109) nam, (vec(i), i=1, vec_size)
109     format(1h a4, /(1h 8e11.4))

    end subroutine vecout_array

    subroutine vecout_scalar(vec, nam, vec_size)

        ! Dummy arguments
        real(wp),         intent(in) :: vec
        integer(ip),      intent(in) :: vec_size
        character(len=*), intent(in) ::  nam

        write (stdout, '(a, 8e11.4)') nam, vec

    end subroutine vecout_scalar

    subroutine vout_scalar(var, nam)

        ! Dummy arguments
        real(wp),         intent(in) :: var
        character(len=*), intent(in) :: nam

        write (stdout, '(a, e12.5)') nam, var

    end subroutine vout_scalar

    subroutine vout_array(var, nam)

        ! Dummy arguments
        real(wp),         intent(in) :: var(:)
        character(len=*), intent(in) :: nam

        write (stdout, *) nam, var

    end subroutine vout_array

    subroutine iout(ivar, nam)

        ! Dummy arguments
        integer(ip),      intent(in) :: ivar
        character(len=*), intent(in) :: nam

        write (stdout, '(a, i5)') nam, ivar

    end subroutine iout

    subroutine name(routine_name)

        ! Dummy arguments
        character(len=*), intent(in) :: routine_name

        write (stdout, '(a)') routine_name

    end subroutine name

    subroutine check_error(ierror)

        ! Dummy arguments
        integer(ip), intent(in) :: ierror

        if (ierror /= 0) write (stderr, '(a, i5)') '   ierror', ierror

    end subroutine check_error

end module spherepack


subroutine ProjectionTest
   use typre
   use Mod_Element
   use Mod_Memor
   use def_domain
   use Mod_Postpr
   use def_master
   implicit none

   integer(ip) :: ndime,npoin,nelem,ipoin,idime,igaus,ielem
   real(rp), allocatable :: array(:,:)

   real(rp) :: gpcod(3), gpval,dvol

   type(MemoryMan) :: Memor
   class(FiniteElement), pointer :: e => NULL()

   call Mesh%GetNdime(ndime)
   call Mesh%GetNpoin(npoin)
   call Mesh%GetNelem(nelem)

   call Mesh%ElementAlloc(e,Memor,'DefaultRule','nsm_EnditeElmope')

   allocate(array(3,npoin))

   do iiter = 1,3

      array = 0.0_rp

      elements: do ielem = 1,nelem
         !Load Element
         call Mesh%ElementLoad(ielem,e)

         !Cartesian derivatives and Jacobian at center of gravity
         call e%elmdcg

         !Element length at center of gravity
         call e%elmlen

         !Gauss Point Loop
         gauss_points : do igaus=1,e%pgaus
            e%igaus = igaus

            dvol = e%weigp(e%igaus)*e%detjm

            call e%interpg(e%ndime,e%elcod,gpcod)

            gpval = 12*sin(gpcod(1))*cos(gpcod(2))

            array(1,e%lnods(1:e%pnode)) = array(1,e%lnods(1:e%pnode)) + gpval*dvol*e%shape(1:e%pnode,e%igaus)
            array(2,e%lnods(1:e%pnode)) = array(2,e%lnods(1:e%pnode)) + 5*gpval*dvol*e%shape(1:e%pnode,e%igaus)
            array(3,e%lnods(1:e%pnode)) = array(3,e%lnods(1:e%pnode)) + 12*gpval*dvol*e%shape(1:e%pnode,e%igaus)

         enddo gauss_points

      enddo elements
      !enddo

      call Mesh%Project(3,array)

      !call Mesh%Smooth(1,array)

   enddo

   call FilePostpr%postpr(array,'array',1_ip,2.0_rp,Mesh)

   stop

end subroutine


**==gamma.spg  processed by SPAG 4.50J  at 14:50 on 30 Jun 1995
      FUNCTION RS_GAMMA(A,X)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL A , fn , fn1 , fn2 , RS_GAMMA , X
      INTEGER in , mn , n , nn
C*** End of declarations inserted by SPAG
      DOUBLE PRECISION can1 , can2 , cbn1 , cbn2 , an , bn , can , cbn
C     EXP(-X) * X ** A   TAKEN OUTSIDE
      can2 = 1.
      can1 = 0.
      cbn2 = 0.
      cbn1 = 1.
      an = 1.
      bn = X
      n = 1
      can = bn*can1 + an*can2
      cbn = bn*cbn1 + an*cbn2
      fn1 = SNGL(can/cbn)
      DO 100 n = 2 , 1000
         IF ( can.GT.1.E30 ) THEN
            can1 = can1*1.E-30
            can = can*1.E-30
            cbn1 = cbn1*1.E-30
            cbn = cbn*1.E-30
         ENDIF
         in = n
         can2 = can1
         cbn2 = cbn1
         can1 = can
         cbn1 = cbn
         mn = MOD(n,2)
         bn = mn*X + (1.-mn)
         nn = n/2
         an = nn - (1.-mn)*A
         can = bn*can1 + an*can2
         cbn = bn*cbn1 + an*cbn2
         fn = SNGL(can/cbn)
         IF ( ABS((fn-fn1)/fn1).LE..0001 .AND. n.GE.20 ) GOTO 200
         fn2 = fn1
         fn1 = fn
 100  CONTINUE
      RS_GAMMA = (fn+fn2)/2.
      RETURN
 200  RS_GAMMA = fn
      RETURN
      END


*DECK BESK0
      FUNCTION BESK0 (X)
C***BEGIN PROLOGUE  BESK0
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            third kind of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK0-S, DBESK0-D)
C***KEYWORDS  FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK0(X) calculates the modified (hyperbolic) Bessel function
C of the third kind of order zero for real argument X .GT. 0.0.
C
C Series for BK0        on the interval  0.          to  4.00000D+00
C                                        with weighted error   3.57E-19
C                                         log weighted error  18.45
C                               significant figures required  17.99
C                                    decimal places required  18.97
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI0, BESK0E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESK0
      DIMENSION BK0CS(11)
      LOGICAL FIRST
      SAVE BK0CS, NTK0, XSML, XMAX, FIRST
      DATA BK0CS( 1) /   -.0353273932 3390276872E0 /
      DATA BK0CS( 2) /    .3442898999 246284869E0 /
      DATA BK0CS( 3) /    .0359799365 1536150163E0 /
      DATA BK0CS( 4) /    .0012646154 1144692592E0 /
      DATA BK0CS( 5) /    .0000228621 2103119451E0 /
      DATA BK0CS( 6) /    .0000002534 7910790261E0 /
      DATA BK0CS( 7) /    .0000000019 0451637722E0 /
      DATA BK0CS( 8) /    .0000000000 1034969525E0 /
      DATA BK0CS( 9) /    .0000000000 0004259816E0 /
      DATA BK0CS(10) /    .0000000000 0000013744E0 /
      DATA BK0CS(11) /    .0000000000 0000000035E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK0
      IF (FIRST) THEN
         NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3))
         XSML = SQRT (4.0*R1MACH(3))
         XMAXT = -LOG(R1MACH(1))
         XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5) - 0.01
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK0',
     +   'X IS ZERO OR NEGATIVE', 2, 2)
      IF (X.GT.2.) GO TO 20
C
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK0 = -LOG(0.5*X)*BESI0(X) - .25 + CSEVL (.5*Y-1., BK0CS, NTK0)
      RETURN
C
 20   BESK0 = 0.
      IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESK0',
     +   'X SO BIG K0 UNDERFLOWS', 1, 1)
      IF (X.GT.XMAX) RETURN
C
      BESK0 = EXP(-X) * BESK0E(X)
C
      RETURN
      END


      SUBROUTINE PCC_SIN(NR,ICORE,AC,BC,CC,R,CDC)

ccccccccccccccccccccccccccccccccccccccccccc
cccccc   Replace the original full core charge CDC/r inside r(icore),
cccccc   with a form ac*sin(bc*r), match the original charge at r(icore)
cccccc   for its value and slop.  The purpose is to generate a smoother
cccccc   core charge to be used in plane wave calculation
cccccc
cccccc   Lin-Wang Wang, Feb. 28, 2001
cccccc    Actually, it should be called: PCC_SIN(xxxx)
cccccc
cccccc
ccccccccc  This subroutine  returns a pseudo core  of
ccccccccc  cdc(r)=ac*r*sin(bc*r)   inside r(icore)
ccccccccc  instead of the original
ccccccccc  cdc(r)=r^2 * exp(ac+bc*r^2+cc*r^4)  inside r(icore)
ccccccccc
ccccccccc  This new pseudo-core is softer than
ccccccccc  the original exp. core, and uses smaller Ecut in
ccccccccc  PEtot calculation. For PEtot calculation, we suggest
ccccccccc  this pseudo-core for "pe" calculation (for no GGA pseudopotential).
ccccccccc  Lin-Wang Wang, Feb. 28, 2001

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (NN = 5)

      DIMENSION R(NR),CDC(NR),
     .          DR_K(-NN:NN),DDR_K(-NN:NN),
     .          CDC_SCA(ICORE-NN:ICORE+NN)

            tpfive=2.5d0
            pi=4*datan(1.d0)

cccccccccccccccccccccccccccccccccccccccccccc

            cdcp = (cdc(icore+1)-cdc(icore))/(r(icore+1)-r(icore))
            tanb = cdc(icore)/(r(icore)*cdcp-cdc(icore))
            rbold = tpfive
            do 500 i = 1, 50
               rbnew = pi + datan(tanb*rbold)
               if (abs(rbnew-rbold) .lt. .00001D0) then
                  bc = rbnew/r(icore)
                  ac = cdc(icore)/(r(icore)*sin(rbnew))
                  do 490 j = 1, icore
                     cdc(j) = ac*r(j)*sin(bc*r(j))
  490             continue
           write(*,*) "r(icore),ac,bc", r(icore), ac, bc
           write(*,*) "**************"
           write(*,*) "**** USING sin(bc*r) for core charge ***"
           write(*,*) "**************"
c
                  go to 530
c
               else
                  rbold = rbnew
               end if
  500       continue
            write(*,*) "SHOULD NEVER BE HERE, fail to find core charge"
            Write(*,*) "inside PCC_EXP.f, stop"
            stop

  530       continue
            cc=1.d0

           return
           end


subroutine bc_third_stage(k,k_t)

use definiciones
implicit none

integer(4)::iter,i,j,k,k_t
real(8)::a_top,b_top,c_top,a_bot,b_bot,c_bot
real(8)::a_left,b_left,c_left,a_right,b_right,c_right

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Calculo de velocidades y aplicacion de condiciones de
!contorno
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!----------------------------------------
!Condiciones de contorno para la vorticidad
!---------------------------------------

do j=1,nz_i+1
i=1
!omega_new(i,j)=(psi_new(i+2,j)*(x(i+1)-x(i))**3-psi_new(i+1,j)*(x(i+2)-x(i))**3)/&
!(0.5d0*((x(i+2)-x(i))**3*(x(i+1)-x(i))**2-(x(i+1)-x(i))**3*(x(i+2)-x(i))**2))
!omega_aprox_2(i,j)=-2.0d0*psi_new(i+1,j)*(h_x**2)/delta_x**2
!omega_aprox_2(i,j)=(psi_new(i+2,j)-8.0d0*psi_new(i+1,j))/(2.0d0*delta_x**2)
omega_new(i,j)=(psi_new(i+2,j)-8.0d0*psi_new(i+1,j))/(2.0d0*delta_x**2)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
i=nx_i+1
!omega_new(i,j)=(psi_new(i-2,j)*(x(i)-x(i-1))**3-psi_new(i-1,j)*(x(i)-x(i-2))**3)/&
!(0.5d0*((x(i)-x(i-2))**3*(x(i)-x(i-1))**2-(x(i)-x(i-1))**3*(x(i)-x(i-2))**2))
!omega_aprox_2(i,j)=-2.0d0*psi_new(i-1,j)*(h_x**2)/delta_x**2
!omega_aprox_2(i,j)=(psi_new(i-2,j)-8.0d0*psi_new(i-1,j))/(2.0d0*delta_x**2)
omega_new(i,j)=(psi_new(i-2,j)-8.0d0*psi_new(i-1,j))/(2.0d0*delta_x**2)
end do

do i=1,nx_i+1
j=1
!omega_new(i,j)=(psi_new(i,j+2)*(z(j+1)-z(j))**3-psi_new(i,j+1)*(z(j+2)-z(j))**3)/&
!(0.5d0*((z(j+2)-z(j))**3*(z(j+1)-z(j))**2-(z(j+1)-z(j))**3*(z(j+2)-z(j))**2))
!omega_aprox_2(i,j)=-2.0d0*psi_new(i,j+1)*(h_z**2)/delta_z**2
!omega_aprox_2(i,j)=(psi_new(i,j+2)-8.0d0*psi_new(i,j+1))/(2.0d0*delta_z**2)
omega_new(i,j)=(psi_new(i,j+2)-8.0d0*psi_new(i,j+1))/(2.0d0*delta_z**2)
j=nz_i+1
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!omega_new(i,j)=(psi_new(i,j-2)*(z(j)-z(j-1))**3-psi_new(i,j-1)*(z(j)-z(j-2))**3)/&
!(0.5d0*((z(j)-z(j-2))**3*(z(j)-z(j-1))**2-(z(j)-z(j-1))**3*(z(j)-z(j-2))**2))
!omega_aprox_2(i,j)=-2.0d0*psi_new(i,j-1)*(h_z**2)/delta_z**2
!omega_aprox_2(i,j)=(psi_new(i,j-2)-8.0d0*psi_new(i,j-1))/(2.0d0*delta_z**2)
omega_new(i,j)=(psi_new(i,j-2)-8.0d0*psi_new(i,j-1)-6.0d0*delta_z)/(2.0d0*delta_z**2)
end do
do j=1,nz_i
i=1
!u_aprox_2(i,j)=0.0d0
!w_aprox_2(i,j)=0.0d0
u_new(i,j)=0.0d0
w_new(i,j)=0.0d0
i=nx_i+1
!u_aprox_2(i,j)=0.0d0
!w_aprox_2(i,j)=0.0d0
u_new(i,j)=0.0d0
w_new(i,j)=0.0d0
end do
do i=1,nx_i+1
j=1
!u_aprox_2(i,j)=0.0d0
!w_aprox_2(i,j)=0.0d0
u_new(i,j)=0.0d0
w_new(i,j)=0.0d0
j=nz_i+1
!u_aprox_2(i,j)=0.0d0
!w_aprox_2(i,j)=0.0d0
u_new(i,j)=1.0d0
w_new(i,j)=0.0d0
end do

!--------------------------------------
!Velocidad en el interior del dominio
!--------------------------------------

do i=2,nx_i
do j=2,nz_i
!u_aprox_2(i,j)=(psi_new(i,j+1)-psi_new(i,j-1))/(2.0d0*delta_z)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!w_aprox_2(i,j)=-(psi_new(i+1,j)-psi_new(i-1,j))/(2.0d0*delta_x)
u_new(i,j)=(psi_new(i,j+1)-psi_new(i,j-1))/(2.0d0*delta_z)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
w_new(i,j)=-(psi_new(i+1,j)-psi_new(i-1,j))/(2.0d0*delta_x)
end do
end do

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Fin condiciones de contorno
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end subroutine bc_third_stage


SUBROUTINE d_com
!======================================
! d^2 COM
!======================================
! Finds the squared distance of the Centre of Mass for a bimetallic cluster.
! Calculates the derivatives.
! Use the d_com light version to speed up calculation for taxing simulations.
!======================================
   USE PARACLUSTER
   USE CLUSTER
   USE POTENTIAL
   USE ENFORCE
   USE DISTANCE
   USE META

   IMPLICIT NONE

   integer :: i
   REAL(8) :: cxa, cya, cza, cxb, cyb, czb
   REAL(8) :: d_com_x, d_com_y, d_com_z

   if (ipas.eq.1) write(*,*) 'd_com> first calculation of d_com'

   cxa = 0.d0
   cya = 0.d0
   cza = 0.d0
   cxb = 0.d0
   cyb = 0.d0
   czb = 0.d0
   DO i = 1, natom
      IF(itype(i).EQ.1) THEN
         cxa = cxa + u(i) +x(i)
         cya = cya + v(i) +y(i)
         cza = cza + w(i) +z(i)
      ELSE
         cxb = cxb + u(i) +x(i)
         cyb = cyb + v(i) +y(i)
         czb = czb + w(i) +z(i)
      ENDIF
   ENDDO
   cxa = cxa/natoma
   cya = cya/natoma
   cza = cza/natoma
   cxb = cxb/natomb
   cyb = cyb/natomb
   czb = czb/natomb

   d_com_x = cxa - cxb
   d_com_y = cya - cyb
   d_com_z = cza - czb

   d_com_cv = d_com_x*d_com_x +d_com_y*d_com_y +d_com_z*d_com_z

   ! Derivatives
   d_com_dcv_dx = 2.d0 *d_com_x
   d_com_dcv_dy = 2.d0 *d_com_y
   d_com_dcv_dz = 2.d0 *d_com_z
   DO i = 1, natom
      IF(itype(i).EQ.1) THEN
         d_com_dcv_dx(i) = d_com_dcv_dx(i) /natoma
         d_com_dcv_dy(i) = d_com_dcv_dy(i) /natoma
         d_com_dcv_dz(i) = d_com_dcv_dz(i) /natoma
      ELSE
         d_com_dcv_dx(i) = -d_com_dcv_dx(i) /natomb
         d_com_dcv_dy(i) = -d_com_dcv_dy(i) /natomb
         d_com_dcv_dz(i) = -d_com_dcv_dz(i) /natomb
      ENDIF
   ENDDO

END SUBROUTINE d_com


C	WRITTEN BY: THEODORE E. FESSLER, NASA TM X-3572, AUGUST 1977
C	REWRITTEN BY: LT. MARK D. KLEM & MARGARET P. PROCTOR, JANUARY 1986
C
C	THE ORIGINAL PROGRAM WAS WRITTEN IN SFTRAN, BUT THIS PROGRAM IS
C	REWRITTEN IN STANDARD FORTRAN 77 TO RUN PRIMARILY ON PERSONAL
C	COMPUTERS AND CAN ALSO RUN ON MAINFRAMES. MUCH OF THE OLD CODE WAS
C	COMMENTED OUT BUT LEFT INTACT FOR DOCUMENTATION AND REFERENCE
C	PURPOSES.
C
      SUBROUTINE NTRP (A,X,N0,IA,OUT,IGOTO,F,FF,VALUE)
C     SUBROUTINE NTRP (A,X,N0,IA,OUT)
C.....DOUBLE 3-POINT INTERPOLATION ROUTINES FOR SUBPROGRAM FLUID.

C.....CALLING ARGUMENTS:
C       A = TABLE OF INDEPENDENT-VARIABLE VALUES,
C       X = ENTRY VALUE OF INDEPENDENT VARIABLE,
C       N0 (OR N1/N2) = LENGTH OF A TABLE,
C       IA = CURRENT INDEX VALUE ASSOCIATED WITH A TABLE.
C       OUT = 0,1 IF X IS INSIDE/NOT INSIDE LIMITS OF A.

      REAL A(*),C(4,3),C0(4),C1(4),C2(4)
      INTEGER I1(3),I2(3),NN(3),OUT
      LOGICAL NEW12
      REAL F(40)
      REAL FF(27,30),CC(16)
      EQUIVALENCE (C0,C(1,1)), (C1,C(1,2)), (C2,C(1,3)), (L1,I1(1)),
     *            (L2,I2(1)),  (M1,I1(2)),  (M2,I2(2)),  (MM1,I1(3)),
     *            (MM2,I2(3)), (NI,NN(2)),  (NJ,NN(3))

      LIMIT(IMIN,I,IMAX)=MAX0(IMIN,MIN0(I,IMAX))

	IF (IGOTO.LE.3) THEN
		IF (IGOTO.EQ.1) THEN
C.....ENTER HERE TO CALCULATE COEFFICIENTS FOR GNTRP.
            K=1
            NA=N0
C     RETURN

		ELSE IF (IGOTO.EQ.2) THEN
C     ENTRY NTRP1 (A,X,N1,IA,OUT)
C.....ENTER HERE TO CALCULATE FIRST COEFFICIENTS FOR GGNTRP.
            K=2
C           NA=N1
		   NA=N0
            NEW12=.TRUE.
C     RETURN

		ELSE IF (IGOTO.EQ.3) THEN
C     ENTRY NTRP2 (A,X,N2,IA,OUT)
C.....ENTER HERE TO CALCULATE SECOND COEFFICIENTS FOR GGNTRP.
            K=3
C           NA=N2
		   NA=N0
            NEW12=.TRUE.
		ENDIF
C     PROCEDURE (CALCULATE COEFFICIENTS FOR ONE DIMENSION)
C     PROCEDURE (CALCULATE INDEX VALUES)
         L=LIMIT(1,NA,3)
         M=NA-2
C     PROCEDURE (TABLE LOOK-UP)
         IF (X.LT.A(1)) THEN
            OUT=1
            IA=1
         ELSE
            IF (X.GT.A(NA)) THEN
               OUT=1
               IA=NA
            ELSE
               OUT=0
               IA=LIMIT(1,IA,NA)
               IF (X.LT.A(IA)) THEN
C                 DO UNTIL (X.GE.A(IA))
  10              CONTINUE
                     IA=IA-1
                  IF (X.LT.A(IA)) GO TO 10
C                 ENDDO
               ELSE
C                 DO WHILE (X.GT.A(IA+1))
  20              CONTINUE
                  IF (X.GT.A(IA+1)) THEN
                     IA=IA+1
                     GO TO 20
                  ENDIF
C                 ENDDO
               ENDIF
            ENDIF
         ENDIF
         IF (IA.GE.2 .AND. IA.LE.M) L=4
         I=LIMIT(1,IA-1,M)
         I1(K)=I
         I2(K)=I+L-1
         NN(K)=L
C     PROCEDURE (CALCULATE AIJ VALUES)
         IF (L.GT.1) THEN
            IF (L.GT.2) THEN
               IF (L.GT.3) THEN
                  A44=A(I+3)
                  A14=A(I)-A44
                  A24=A(I+1)-A44
                  A34=A(I+2)-A44
                  A44=X-A44
               ENDIF
               A33=A(I+2)
               A13=A(I)-A33
               A23=A(I+1)-A33
               A33=X-A33
            ENDIF
            A22=A(I+1)
            A12=A(I)-A22
            A22=X-A22
         ENDIF
         A11=X-A(I)
C     PROCEDURE (CALCULATE COEFFICIENTS)
C     DO CASE (L,4)
		IF (L.EQ.1) THEN
C     CASE 1
            C(1,K)=1.0
		ELSE IF (L.EQ.2) THEN
C     CASE 2
            C(1,K)=+A22/A12
            C(2,K)=-A11/A12
		ELSE IF (L.EQ.3) THEN
C     CASE 3
            C(1,K)=+A22/A12*A33/A13
            C(2,K)=-A11/A12*A33/A23
            C(3,K)=+A11/A13*A22/A23
		ELSE IF (L.EQ.4) THEN
C     CASE 4
            P1=A22/A23*A33
            C(1,K)=+P1/A12*A33/A13
            C(4,K)=-P1/A34*A22/A24
            P2=A33/A23*A11/A23
            P3=A22/A23*A44/A23
            C(2,K)=-A33*(P2/A12+P3/A24)
            C(3,K)=+A22*(P3/A34+P2/A13)
         ENDIF
         RETURN

      ELSE IF (IGOTO.EQ.4) THEN
C     ENTRY GNTRP (F,VALUE)
C.....EVALUATION OF FUNCTION IN ONE VARIABLE.

C.....ARGUMENT F IS THE TABLE OF DEPENDENT-VARIABLE VALUES.

         VALUE=0.0
         K=0
         DO 30 I=L1,L2
            K=K+1
            VALUE=VALUE+C0(K)*F(I)
  30     CONTINUE
         RETURN

      ELSE IF (IGOTO.EQ.5) THEN
C     ENTRY GGNTRP (FF,VALUE)
C.....ENTRY FOR EVALUATION OF FUNCTIONS IN TWO VARIABLES.

C.....ARGUMENT FF IS THE (2-D) TABLE OF DEPENDENT-VARIABLE VALUES.

         IF (NEW12) THEN
            IJ=0
            DO 50 I=1,NI
               DO 40 J=1,NJ
                  IJ=IJ+1
                  CC(IJ)=C1(I)*C2(J)
  40           CONTINUE
  50        CONTINUE
            NEW12=.FALSE.
         ENDIF
         VALUE=0.0
         IJ=0
         DO 70 I=M1,M2
            DO 60 J=MM1,MM2
               IJ=IJ+1
               VALUE=VALUE+CC(IJ)*FF(I,J)
  60        CONTINUE
  70     CONTINUE
         RETURN
      ENDIF
      END


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Student: Rodrigo Amaral Coutinho Bartolomeu RA:209688
! Supervisor: Dr. Luís Fernando Mercier Franco
! Universidade Estadual de Campinas -UNICAMP
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

PROGRAM diff
    !~~ Variable declaration ~~!
    implicit none
    character(4)   :: dummy             ! Dummy character to store atoms names
    integer*8 :: i,j,k                  ! i, j and k counters
    integer*8 :: n_particles            ! Number of particles in the system
    integer*8 :: tmax                   ! Maximum time and origin time limit
    integer*8 :: omax                   ! Origin for multiple origins
    integer*8 :: omax_cut               ! Origin for multiple origins
    integer*8 :: t,o                    ! t and o counters
    real*8 :: dt                        ! dt between samples
    real*8 :: B,R2,A                    ! Variables for linear regression
    real*8 :: dif                       ! Self-diffusion coefficient (m²/s)
    real*8 :: sig                       ! Stantard deviation
    real*8,dimension(:),allocatable   :: time       ! Time array
    real*8,dimension(:),allocatable   :: msd        ! MSD array
    real*8,dimension(:),allocatable   :: msc        ! msc array
    real*8,dimension(:),allocatable   :: msc_cut    ! msc_cut array
    real*8,dimension(:),allocatable   :: time_cut   ! time_cut array
    real*8,dimension(:,:),allocatable :: rx,ry,rz   ! Position arrays

    !~~ Time related inputs ~~!
    tmax    = 5000  ! Simulation time outputs
    dt      = 10.d0 ! dt btween outputs
    omax    = int(dble(tmax)/2.d0) ! Setting limit for tiem origins

    !~~ Memory allocation ~~!
    allocate(rx(1000,tmax),ry(1000,tmax),rz(1000,tmax))
    allocate(time(omax),msd(omax),msc(omax))
    allocate(time_cut((int(omax*0.6d0))),msc_cut((int(omax*0.6d0))))

    !~~ Opening the .xyz file ~~!
    open(unit=101,status="old",file="traj.xyz")

    !~~ Reading positions of each time frame ~~!
    do t=1,tmax
        !print*,'Step = ',t
        write(*,'(A7,I6)')'Step = ',t
        read(101,*)n_particles
        !read(101,*)dummy
        do i=1,n_particles
            read(101,*)dummy,rx(i,t),ry(i,t),rz(i,t)
        end do
    end do
    close(101)
    write(*,*)''

    !~~ Opening the msd file ~~!
    open(unit=102,file="msd_f.dat")
    open(unit=103,file="msd_cut_f.dat")

    !~~ Emptying the arrays of msd and msc~~!
    do o=1,omax
        msd(o) = 0.d0
        msc(o) = 0.d0
    end do

    print*,"Calculation the MSD with multiple time origins..."
    !~~ Calculating the MSD correlation with multiple t=0 ~~!
    do o=1,omax
        if(mod(o,100) == 0)then
            write(*,'(F6.2)')dble(dble(o)/dble(omax)*100.0)
        end if

        time(o) = dble(o)*dt
        do t=1,omax
            do k=1,n_particles
                msd(o) = msd(o) + (rx(k,t+o)-rx(k,t))**2 + (ry(k,t+o)-ry(k,t))**2 + (rz(k,t+o)-rz(k,t))**2
            end do
        end do
        msc(o) = msd(o)/dble(n_particles)/dble(omax)/3.d0
        write(102,*)time(o),msc(o)
    end do
    close(102)

    do t=int(1+0.2d0*omax),int(0.8d0*omax)
        msc_cut(int(t-0.2d0*omax))  = msc(t)
        time_cut(int(t-0.2d0*omax)) = time(t)
        write(103,*)time_cut(int(t-0.2d0*omax)),msc_cut(int(t-0.2d0*omax))
    end do
    close(103)
    !~~ Using linear regression to calculate the slope of the msc and correcting the unit to m²/s ~~!
    call linreg(time,msc,A,B,R2,omax)
    dif = B/2.d0/1.d5 !Conversion to m2/s ps -> 1D6
    sig = dif*sqrt(1.d0/R2-1.d0)/sqrt(1.d0*(omax-1))
    write(*,*) ' D =',dif,' +/-',sig,' m2/s'

    omax_cut = int(0.6d0*omax)-1
    call linreg(time_cut,msc_cut,A,B,R2,omax_cut)
    dif = B/2.d0/1.d5 !Conversion to m2/s
    sig = dif*sqrt(1.d0/R2-1.d0)/sqrt(1.d0*(omax_cut-1))
    write(*,*) ' D =',dif,' +/-',sig,' m2/s'

    !~~ Deallocating memory ~~!
    deallocate(rx,ry,rz)
    deallocate(time,msd,msc,time_cut,msc_cut)

    end program diff

    subroutine linreg(DX,DY,DA,DB,DR2,DN)
    implicit none
    integer*8 :: l,DN
    real*8 :: SX,SY,SXX,SXY,SYY,R,NN
    real*8,intent(out) :: DX(DN),DY(DN)
    real*8,intent(out) :: DB,DR2,DA

    SX  = 0.0
    SY  = 0.0
    SXX = 0.0
    SXY = 0.0
    SYY = 0.0

    do l=1,DN
        SX  = SX + DX(l);
        SY  = SY + DY(l);
        SXX = SXX + DX(l)*DX(l);
        SXY = SXY + DX(l)*DY(l);
        SYY = SYY + DY(l)*DY(l);
    end do
    NN  = (1.d0*DN)
    DB   = (NN*SXY-SX*SY)/(NN*SXX-SX*SX);
    DA   = (SY-DB*SX)/NN;
    R   = (NN*SXY-SX*SY)/sqrt((NN*SXX-SX*SX)*(NN*SYY-SY*SY));
    DR2  = R*R;

    end subroutine linreg


      INTEGER FUNCTION GCCONVEX (NPTS, QLAT, QLON)
C
C  This function determines if the spherical polygon
C  (QLAT(I),QLON(I)),I=1,NPTS) is convex.  One is returned
C  if so, zero otherwise.  The input polygon must have at
C  least three points and be closed.
C
      DOUBLE PRECISION GCDANGLE,QLAT(NPTS),QLON(NPTS)
C
C  Find the initial direction.
C
      IDIR = SIGN(1.D0,GCDANGLE(QLAT(1),QLON(1),QLAT(2),QLON(2),
     +            QLAT(3),QLON(3)))
      DO 10 I=2,NPTS
        ISGN = SIGN(1.D0,GCDANGLE(QLAT(I),QLON(I),
     +                       QLAT(MOD(I+1,NPTS)),QLON(MOD(I+1,NPTS)),
     +                       QLAT(MOD(I+2,NPTS)),QLON(MOD(I+2,NPTS))))
        IF (ISGN .NE. IDIR) THEN
          GCCONVEX = 0
          RETURN
        ENDIF
   10 CONTINUE
      GCCONVEX = 1
      RETURN
C
      END
      INTEGER FUNCTION GCINOUT (PLAT, PLON, QLAT, QLON, NPTS, WORK)
C
C  This function determines if the coordinate (PLAT,PLON) is
C  inside or outside of the spherical patch
C  (QLAT(I),QLON(I)),I=1,NPTS).  Zero is returned if
C  in, non-zero otherwise.  WORK is a work array
C  dimensioned for 4*NPTS.  A point on the boundary is
C  considered to be inside.
C
      DOUBLE PRECISION PLAT, PLON, QLAT(NPTS), QLON(NPTS), WORK(4,NPTS)
      DOUBLE PRECISION P(4), D2R
      DATA D2R/0.017453292519943D0/
      INTEGER GCONARC
C

C
C  Check that the input polygon is closed.
C
      IF (QLAT(NPTS).NE.QLAT(1) .OR. QLON(NPTS).NE.QLON(1)) THEN
        WRITE(6,500)
  500   FORMAT('GCINOUT: The input spherical polygon must be closed.')

        GCINOUT = -1
        RETURN
      ENDIF
C
      DO 10 I=1,NPTS
        WORK(1,I) = DCOS(D2R*QLAT(I))
        WORK(2,I) = DSIN(D2R*QLAT(I))
        WORK(3,I) = DCOS(D2R*QLON(I))
        WORK(4,I) = DSIN(D2R*QLON(I))
   10 CONTINUE
      P(1) = DCOS(D2R*PLAT)
      P(2) = DSIN(D2R*PLAT)
      P(3) = DCOS(D2R*PLON)
      P(4) = DSIN(D2R*PLON)

C
C  Return if inside (may still be on boundary).
C
C
      GCINOUT = ICAPDP(P,WORK,NPTS)
      IF (GCINOUT .EQ. 0) THEN
        RETURN
      ENDIF
C
C  Check if on boundary.
C
      DO 20 I=1,NPTS-1
        IF (GCONARC(PLAT,PLON,QLAT(I),QLON(I),QLAT(I+1),QLON(I+1),
     +               1.D-10) .EQ. 1) THEN
          GCINOUT = 0
          RETURN
        ENDIF
   20 CONTINUE
C
C  Default return flags outside.
C
      GCINOUT = 1
      RETURN
      END
      DOUBLE PRECISION FUNCTION GCDIST(LAT1,LON1,LAT2,LON2)
C
C  Computes the shortest (undirected) angular distance between the points
C  on the globe (LAT1,LON1) and (LAT2,LON2).
C
      DOUBLE PRECISION AT(4), BT(4), D2R, XADGCDP
      DOUBLE PRECISION LAT1,LON1,LAT2,LON2
      DATA D2R/0.017453292519943D0/
C
      AT(1) = COS(D2R*LAT1)
      AT(2) = SIN(D2R*LAT1)
      AT(3) = COS(D2R*LON1)
      AT(4) = SIN(D2R*LON1)
C
      BT(1) = COS(D2R*LAT2)
      BT(2) = SIN(D2R*LAT2)
      BT(3) = COS(D2R*LON2)
      BT(4) = SIN(D2R*LON2)
C
      GCDIST = XADGCDP(AT,BT)
C
      RETURN
      END
      INTEGER FUNCTION GCONARC(PLAT,PLON,LAT1,LON1,LAT2,LON2,TOL)
C
C  Determines whether (PLAT,PLON) lies on the arc of the
C  great circle formed by (LAT1,LON1) and (LAT2,LON2) within
C  a tolerance of TOL.  The arc is taken to be the shorter of
C  the two possible arcs between (LAT1,LON1) and (LAT2,LON2).
C  Return 1 if on arc, 0 otherwise.
C
      DOUBLE PRECISION PLAT,PLON,LAT1,LON1,LAT2,LON2,TOL
      DOUBLE PRECISION ADIST,BDIST,CDIST,GCPNT2GC,GCDIST
      ADIST = GCPNT2GC(LAT1,LON1,LAT2,LON2,PLAT,PLON)
      IF (ABS(ADIST) .LE. TOL) THEN
        BDIST = ABS(GCDIST(PLAT,PLON,LAT1,LON1)) +
     +          ABS(GCDIST(PLAT,PLON,LAT2,LON2))
        CDIST = ABS(GCDIST(LAT1,LON1,LAT2,LON2))
        IF (ABS(BDIST - CDIST) .LE. TOL) THEN
          GCONARC = 1
        ELSE
          GCONARC = 0
        ENDIF
      ELSE
        GCONARC = 0
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION GCCONVERT(ANGLE,TYPE)
C
C  Converts an angle (in degrees) along a great circle on the earth
C  as per:
C
C  TYPE -- A string indicating the units you want to convert
C          to. Legal values are:
C
C          "radians"
C          "meters"
C          "kilometers"
C          "feet"
C          "miles"
C
      DOUBLE PRECISION ANGLE
      CHARACTER*(*) TYPE
      DOUBLE PRECISION D2R
      DATA D2R/0.017453292519943D0/
C
C  Since the radius of the earth is not a precise number, the
C  following conversion ratios need not be double precision.
C
      DOUBLE PRECISION R2M, M2F
      DATA R2M,M2F/6371220.,3.2808/
C
      IF (TYPE(1:2).EQ.'ra' .OR. TYPE(1:2).EQ.'RA') THEN
        GCCONVERT = D2R*ANGLE
      ELSE IF (TYPE(1:2).EQ.'me' .OR. TYPE(1:2).EQ.'ME') THEN
        GCCONVERT = D2R*ANGLE*R2M
      ELSE IF (TYPE(1:2).EQ.'ki' .OR. TYPE(1:2).EQ.'KI') THEN
        GCCONVERT = D2R*ANGLE*R2M/1000.
      ELSE IF (TYPE(1:2).EQ.'fe' .OR. TYPE(1:2).EQ.'FE') THEN
        GCCONVERT = D2R*ANGLE*R2M*M2F
      ELSE IF (TYPE(1:2).EQ.'mi' .OR. TYPE(1:2).EQ.'MI') THEN
        GCCONVERT = D2R*ANGLE*R2M*M2F/5280.
      ELSE
        PRINT *,'GCCONVERT: unrecognized conversion type'
      ENDIF
C
      RETURN
      END
      SUBROUTINE GCINTERP(LAT1, LON1, LAT2, LON2, NPTS, OLAT, OLON)
C
C  Interpolates NPTS points along a great circle from (LAT1,LON1) to
C  (LAT2,LON2) and returns them in the OLAT and OLON arrays.  The
C  beginning and ending points are included in the result, so, for
C  example, if NPTS=2, then only the end points are returned.
C
      DOUBLE PRECISION LAT1, LON1, LAT2, LON2, OLAT(NPTS), OLON(NPTS)
      DOUBLE PRECISION NLAT1, NLON1, NLAT2, NLON2, NORMANG
      DOUBLE PRECISION D2R,R2D
      DATA D2R,R2D/0.017453292519943D0,57.2957795130823D0/
C
      NLAT1 = R2D*NORMANG(D2R*LAT1)
      NLON1 = R2D*NORMANG(D2R*LON1)
      NLAT2 = R2D*NORMANG(D2R*LAT2)
      NLON2 = R2D*NORMANG(D2R*LON2)
C
      OLAT(1)    = NLAT1
      OLON(1)    = NLON1
      OLAT(NPTS) = NLAT2
      OLON(NPTS) = NLON2
      IF (NPTS .EQ. 2) THEN
        RETURN
      ENDIF
      CALL DMAPGCI (LAT1,LON1,LAT2,LON2,NPTS-2,OLAT(2),OLON(2))
      RETURN
      END
      DOUBLE PRECISION FUNCTION GCQAREA(LAT1, LON1, LAT2, LON2,
     +                                  LAT3, LON3, LAT4, LON4,
     +                                  IER)
C
C  Finds the area of a convex quadrilateral patch on a sphere whose
C  vertices are given in degrees as lat/lon pairs.
C
      DOUBLE PRECISION GCTAREA
      DOUBLE PRECISION LAT1, LON1, LAT2, LON2, LAT3, LON3, LAT4, LON4
      DOUBLE PRECISION GC1, GC2
      INTEGER IER, IER1, IER2
C
      GC1 = ABS(GCTAREA(LAT1, LON1, LAT2, LON2, LAT3, LON3, IER1))
      GC2 = ABS(GCTAREA(LAT1, LON1, LAT3, LON3, LAT4, LON4, IER2))
      IF(IER1.EQ.0.and.IER2.EQ.0) THEN
        GCQAREA = GC1 + GC2
        IER = 0
      ELSE
        GCQAREA = 1.D30
        IER = 1
      END IF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GCTAREA(LAT1, LON1, LAT2, LON2,
     +                                  LAT3, LON3, IER)
C
C  Finds the area of a spherical triangle by finding the three
C  spherical angles and subtracting off PI.
C
      DOUBLE PRECISION LAT1, LON1, LAT2, LON2, LAT3, LON3
      DOUBLE PRECISION GCDANGLE,ALPHA,BETA,GAMMA,PI
      DOUBLE PRECISION D2R
      INTEGER IER
      DATA D2R/0.017453292519943D0/
C
      PI = 2.D0*DASIN(1.D0)
C
      IF (.NOT. ( ((LAT1.EQ.LAT2).AND.(LON1.EQ.LON2)) .OR.
     +            ((LAT1.EQ.LAT3).AND.(LON1.EQ.LON3)) .OR.
     +            ((LAT2.EQ.LAT3).AND.(LON2.EQ.LON3)) )) THEN
        ALPHA  = ABS(D2R*GCDANGLE(LAT1, LON1, LAT2, LON2, LAT3, LON3))
        BETA   = ABS(D2R*GCDANGLE(LAT2, LON2, LAT3, LON3, LAT1, LON1))
        GAMMA  = ABS(D2R*GCDANGLE(LAT3, LON3, LAT1, LON1, LAT2, LON2))
        GCTAREA = ALPHA+BETA+GAMMA - PI
        IER = 0
      ELSE
        WRITE(6,500)
  500   FORMAT('GCTAREA: The three input points must be distinct.')
        GCTAREA = 1.D30
        IER = 1
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GCPNT2GC(LAT1, LON1, LAT2, LON2,
     +                                    LAT3, LON3)
C
C  Distance from a point (LAT3,LON3) to a great circle defined by the
C  arc from (LAT1,LON1) to (LAT2,LON2).
C
      DOUBLE PRECISION LAT1, LON1, LAT2, LON2, LAT3, LON3
      DOUBLE PRECISION AT(4), BT(4), CT(4), D2R, XDPGCDP
      DATA D2R/0.017453292519943D0/
C
      AT(1) = COS(D2R*LAT1)
      AT(2) = SIN(D2R*LAT1)
      AT(3) = COS(D2R*LON1)
      AT(4) = SIN(D2R*LON1)
C
      BT(1) = COS(D2R*LAT2)
      BT(2) = SIN(D2R*LAT2)
      BT(3) = COS(D2R*LON2)
      BT(4) = SIN(D2R*LON2)
C
      CT(1) = COS(D2R*LAT3)
      CT(2) = SIN(D2R*LAT3)
      CT(3) = COS(D2R*LON3)
      CT(4) = SIN(D2R*LON3)
C
      GCPNT2GC = XDPGCDP (AT,BT,CT)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION XDPGCDP (AQDP,BQDP,CQDP)
C
C (XDPGCDP = Distance of Point from Great Circle, Double Precision)
C
C Author: David Kennison
C
        DOUBLE PRECISION AQDP(4),BQDP(4),CQDP(4)
C
C This function, given points A, B, and C on the globe, returns the
C directed distance, in degrees of arc, from the great circle through
C A and B to the point C, positive if the point C is in the hemisphere
C to the "left" of the great circle and negative otherwise.
C
C All variables with names of the form XQDP are four-element arrays
C containing the cosine and sine of the latitude and the cosine and
C sine of the longitude, in that order, of the point X.  Describing
C the point positions in this way makes this routine execute faster
C than if the latitudes and longitudes themselves are used.
C
        DOUBLE PRECISION RTOD
        DOUBLE PRECISION XCB2,YCB2,ZCB2
        DOUBLE PRECISION      YCB3,ZCB3
        DOUBLE PRECISION XCC2,YCC2,ZCC2
        DOUBLE PRECISION      YCC3,ZCC3
        DOUBLE PRECISION DNOM
C
        DOUBLE PRECISION XADGCDP
C
C Define a multiplicative constant to convert from radians to degrees.
C
        DATA RTOD / 57.2957795130823D0 /
C
C Get XYZ coordinates for B, rotate them by -ALON about the Z axis (which
C would put A on the prime meridian), and then rotate them by ALAT about
C the Y axis (which would put A on the equator).
C
        XCB2=BQDP(1)*BQDP(3)*AQDP(3)+BQDP(1)*BQDP(4)*AQDP(4)
        YCB2=BQDP(1)*BQDP(4)*AQDP(3)-BQDP(1)*BQDP(3)*AQDP(4)
        ZCB2=BQDP(2)
C
        YCB3=YCB2
        ZCB3=ZCB2*AQDP(1)-XCB2*AQDP(2)
C
C Do the same for C.
C
        XCC2=CQDP(1)*CQDP(3)*AQDP(3)+CQDP(1)*CQDP(4)*AQDP(4)
        YCC2=CQDP(1)*CQDP(4)*AQDP(3)-CQDP(1)*CQDP(3)*AQDP(4)
        ZCC2=CQDP(2)
C
        YCC3=YCC2
        ZCC3=ZCC2*AQDP(1)-XCC2*AQDP(2)
C
C Rotate C about the X axis by the angle ALPH required to put B on the
C equator.
C
C The following code returns the distance from A to C (in the degenerate
C case when A and B are the same point as well).
C
        IF (YCB3.NE.0.D0 .OR. ZCB3.NE.0.D0) THEN
          DNOM   = SQRT(YCB3*YCB3+ZCB3*ZCB3)
          XDPGCDP = RTOD*ASIN((ZCC3*YCB3-YCC3*ZCB3)/DNOM)
        ELSE
          XDPGCDP = XADGCDP(AQDP,CQDP)
        END IF
C
        RETURN
      END
      DOUBLE PRECISION FUNCTION XADGCDP (AQDP,BQDP)
C
C (XADGCDP = Angle in Degrees along Great Circle, Double Precision)
C
        DOUBLE PRECISION AQDP(4),BQDP(4)
C
C This function returns the shortest great circle distance, in degrees,
C between two points, A and B, on the surface of the globe.
C
C All variables with names of the form XQDP are four-element arrays
C containing the cosine and sine of the latitude and the cosine and
C sine of the longitude, in that order, of the point X.  Describing
C the point positions in this way makes this routine execute faster
C than if the latitudes and longitudes themselves are used.
C
        DOUBLE PRECISION RDTT
C
C Define a multiplicative constant to convert from radians to degrees
C and multiply by two.
C
        DATA RDTT / 114.5915590261646D0 /
C
        XADGCDP=RDTT*
     +         ASIN(SQRT((AQDP(1)*AQDP(3)-BQDP(1)*BQDP(3))**2+
     +                   (AQDP(1)*AQDP(4)-BQDP(1)*BQDP(4))**2+
     +                   (AQDP(2)        -BQDP(2)        )**2)/2.D0)
C
        RETURN
C
      END
      SUBROUTINE LATLON2CART(LAT,LON,X,Y,Z)
C
C  Converts a (lat,lon) coordinate to Cartesian coordinates on the
C  unit sphere.
C
      DOUBLE PRECISION LAT,LON,X,Y,Z,RLAT,RLON,NORMANG,PI,D2R
      DATA D2R/0.017453292519943D0/
C
      IF (LAT .GT. 90.D0 .OR. LAT .LT. -90.D0) THEN
        WRITE (6,500) LAT
  500   FORMAT('LATLON2CART: Latitude value out of range',F20.15)
        X = 1.D20
        Y = 1.D20
        Z = 1.D20
        RETURN
      ENDIF
C
      RLON = NORMANG(D2R*LON)
      RLAT = D2R*(90.D0 - LAT)
      PI = 2.D0*DASIN(1.D0)
      X = DSIN(RLAT)*DCOS(RLON)
      Y = DSIN(RLAT)*DSIN(RLON)
      Z = DCOS(RLAT)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION NORMANG(ANGLE)
C
C  Adjusts the input ANGLE (in radians) by adding or subtracting
C  enough multiples of 2*PI so that the result lies in the range
C  [-PI,PI)
C
      DOUBLE PRECISION ANGLE, PI, RVAL
      INTEGER I
C
      PI = 2.D0*DASIN(1.D0)
C
      RVAL = ANGLE
      DO 10 I=1,50
        IF (RVAL .LT. -PI) THEN
          RVAL = RVAL+2.D0*PI
        ELSE
          GO TO 30
        ENDIF
   10 CONTINUE
   30 CONTINUE
      DO 20 I=1,50
        IF (RVAL .GE. PI) THEN
          RVAL = RVAL-2.D0*PI
        ELSE
          GO TO 40
        ENDIF
   20 CONTINUE
   40 CONTINUE
C
      NORMANG = RVAL
      RETURN
      END
      DOUBLE PRECISION FUNCTION GCAANGLE(LAT1, LON1, LAT2, LON2,
     +                                   LAT3, LON3, LAT4, LON4)
C
C  Find the (acute) angle between two great circles given two arcs
C  defining the circles - one circle containing the arc between
C  (lat1, lon1) and (lat2,lon2) and the other containing the arc
C  between (lat3, lon3) and (lat4,lon4).
C
      DOUBLE PRECISION LAT1,LON1,LAT2,LON2,LAT3,LON3,LAT4,LON4
      DOUBLE PRECISION PTS1(3,3),PTS2(3,3),ANGPLANES
C
C  Get Cartesian coordinates for all four points.
C
      CALL LATLON2CART(LAT1,LON1,PTS1(1,1),PTS1(1,2),PTS1(1,3))
      CALL LATLON2CART(LAT2,LON2,PTS1(2,1),PTS1(2,2),PTS1(2,3))
      PTS1(3,1) = 0.D0
      PTS1(3,2) = 0.D0
      PTS1(3,3) = 0.D0
C
      CALL LATLON2CART(LAT3,LON3,PTS2(1,1),PTS2(1,2),PTS2(1,3))
      CALL LATLON2CART(LAT4,LON4,PTS2(2,1),PTS2(2,2),PTS2(2,3))
      PTS2(3,1) = 0.D0
      PTS2(3,2) = 0.D0
      PTS2(3,3) = 0.D0
C
      GCAANGLE = ANGPLANES (PTS1, PTS2)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION GCDANGLE(LAT1, LON1, LAT2, LON2,
     +                                    LAT3, LON3)
C
C  Find the directed angle in degrees between two great circles that
C  intersect in a given point.  Given three points on the globe
C  A = (LAT1,LON1), B = (LAT2,LON2), and C = (LAT3,LON3) this function
C  finds the angle between the great circles that contain the arcs
C  AB and AC.  The returned angle is positive if C is in the hemisphere
C  to the "left" of the great circle through A and B, negative otherwise.
C
      DOUBLE PRECISION D2R,XABGCDP,LAT1,LON1,LAT2,LON2,LAT3,LON3
      PARAMETER (D2R=0.017453292519943D0)
C
      DOUBLE PRECISION PT1(4),PT2(4),PT3(4)
C
      PT1(1) = DCOS(D2R*LAT1)
      PT1(2) = DSIN(D2R*LAT1)
      PT1(3) = DCOS(D2R*LON1)
      PT1(4) = DSIN(D2R*LON1)
C
      PT2(1) = DCOS(D2R*LAT2)
      PT2(2) = DSIN(D2R*LAT2)
      PT2(3) = DCOS(D2R*LON2)
      PT2(4) = DSIN(D2R*LON2)
C
      PT3(1) = DCOS(D2R*LAT3)
      PT3(2) = DSIN(D2R*LAT3)
      PT3(3) = DCOS(D2R*LON3)
      PT3(4) = DSIN(D2R*LON3)
C
      GCDANGLE = XABGCDP(PT1,PT2,PT3)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION ANGPLANES (PTS1, PTS2)
C
C  Finds the angle between two planes, one plane determined
C  by the three points in three space by PTS1 and the second
C  by the three points in in PTS2.
C
      DOUBLE PRECISION PTS1(3,3), PTS2(3,3), CF1(4), CF2(4)
      DOUBLE PRECISION DOTP,PNORM,THETA,TMP
C
      DOUBLE PRECISION R2D
      DATA R2D / 57.2957795130823D0 /
C
C  Get the coefficients for the equations of the planes.
C
      CALL EQNPLANE(PTS1,CF1)
      CALL EQNPLANE(PTS2,CF2)
C
C  Calculate the cosine of the angle using:
C
C     COS(THETA) = (norm_vct(pts1) dot norm_vct(pts2))/
C                   (norm(pts1) * norm(pts2))
C
      DOTP = 0.D0
      DO 10 I=1,3
        DOTP = DOTP + CF1(I)*CF2(I)
   10 CONTINUE
      PNORM = (DSQRT(CF1(1)*CF1(1) + CF1(2)*CF1(2) + CF1(3)*CF1(3))) *
     +        (DSQRT(CF2(1)*CF2(1) + CF2(2)*CF2(2) + CF2(3)*CF2(3)))
      IF (PNORM .EQ. 0.D0) THEN
        WRITE(6,500)
  500   FORMAT('EQPLANE: Input points must be distinct.')
      ENDIF
      THETA = DOTP/PNORM
      TMP = R2D*DACOS(THETA)
      IF (TMP .GT. 90.D0) TMP = 180.D0-TMP
      ANGPLANES = TMP
C
      RETURN
      END
      SUBROUTINE EQNPLANE(PNT, COEF)
C
C  Finds the coefficients of the equation of a plane:
C
C    A*X + B*Y + C*Z = D
C
C  given three points in three-space in array PNT.
C  The four coefficients are returned in the COEF array.
C
      DOUBLE PRECISION PNT(3,3), COEF(4)
      DOUBLE PRECISION X1, X2, X3, Y1, Y2, Y3, Z1, Z2, Z3
C
      X1 = PNT(1,1)
      X2 = PNT(2,1)
      X3 = PNT(3,1)
      Y1 = PNT(1,2)
      Y2 = PNT(2,2)
      Y3 = PNT(3,2)
      Z1 = PNT(1,3)
      Z2 = PNT(2,3)
      Z3 = PNT(3,3)
C
      COEF(1) =  (Y1*(Z2-Z3) - Z1*(Y2-Y3) + (Y2*Z3 - Z2*Y3))
      COEF(2) = -(X1*(Z2-Z3) - Z1*(X2-X3) + (X2*Z3 - Z2*X3))
      COEF(3) =  (X1*(Y2-Y3) - Y1*(X2-X3) + (X2*Y3 - Y2*X3))
      COEF(4) =  X1*(Y2*Z3 - Z2*Y3) - Y1*(X2*Z3 - Z2*X3) +
     +             Z1*(X2*Y3 - X3*Y2)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION XABGCDP (AQDP,BQDP,CQDP)
C
C (XABGCDP = Angle Between Great Circles, Double Precision)
C
        DOUBLE PRECISION AQDP(4),BQDP(4),CQDP(4)
C
C This function, given information about the points A, B, and C on the
C sphere, returns the angle, in degrees, from the great circle through
C A and B to the great circle through A and C, positive if the point C
C is in the hemisphere to the "left" of the great circle through A and
C B, negative otherwise.
C
C All variables with names of the form XQDP are four-element arrays
C containing the cosine and sine of the latitude and the cosine and
C sine of the longitude, in that order, of the point X.  Describing
C the point positions in this way makes this routine execute faster
C than if the latitudes and longitudes themselves are used.
C
C Code that is commented out either produces unneeded results or is
C superseded by code that executes faster.
C
        DOUBLE PRECISION RTOD
C       DOUBLE PRECISION XCB1,YCB1,ZCB1
        DOUBLE PRECISION XCB2,YCB2,ZCB2
        DOUBLE PRECISION      YCB3,ZCB3
C       DOUBLE PRECISION XCC1,YCC1,ZCC1
        DOUBLE PRECISION XCC2,YCC2,ZCC2
        DOUBLE PRECISION      YCC3,ZCC3
        DOUBLE PRECISION      YCC4,ZCC4
        DOUBLE PRECISION DNOM,CANG,SANG
C
C Define a multiplicative constant to convert from radians to degrees.
C
        DATA RTOD / 57.2957795130823D0 /
C
C Get XYZ coordinates for B, rotate them by -ALON about the Z axis (which
C would put A on the prime meridian), and then rotate them by ALAT about
C the Y axis (which would put A on the equator).
C
C       XCB1=BQDP(1)*BQDP(3)
C       YCB1=BQDP(1)*BQDP(4)
C       ZCB1=BQDP(2)
C
C       XCB2=XCB1*AQDP(3)+YCB1*AQDP(4)
C       YCB2=YCB1*AQDP(3)-XCB1*AQDP(4)
C       ZCB2=ZCB1
C
        XCB2=BQDP(1)*BQDP(3)*AQDP(3)+BQDP(1)*BQDP(4)*AQDP(4)
        YCB2=BQDP(1)*BQDP(4)*AQDP(3)-BQDP(1)*BQDP(3)*AQDP(4)
        ZCB2=BQDP(2)
C
C       XCB3=XCB2*AQDP(1)+ZCB2*AQDP(2)
        YCB3=YCB2
        ZCB3=ZCB2*AQDP(1)-XCB2*AQDP(2)
C
C Do the same for the point C.
C
C       XCC1=CQDP(1)*CQDP(3)
C       YCC1=CQDP(1)*CQDP(4)
C       ZCC1=CQDP(2)
C
C       XCC2=XCC1*AQDP(3)+YCC1*AQDP(4)
C       YCC2=YCC1*AQDP(3)-XCC1*AQDP(4)
C       ZCC2=ZCC1
C
        XCC2=CQDP(1)*CQDP(3)*AQDP(3)+CQDP(1)*CQDP(4)*AQDP(4)
        YCC2=CQDP(1)*CQDP(4)*AQDP(3)-CQDP(1)*CQDP(3)*AQDP(4)
        ZCC2=CQDP(2)
C
C       XCC3=XCC2*AQDP(1)+ZCC2*AQDP(2)
        YCC3=YCC2
        ZCC3=ZCC2*AQDP(1)-XCC2*AQDP(2)
C
C Now, rotate C about the X axis by an amount which would put B on the
C equator.
C
        IF (YCB3.NE.0D0.OR.ZCB3.NE.0.D0) THEN
          DNOM=SQRT(YCB3*YCB3+ZCB3*ZCB3)
          CANG=YCB3/DNOM
          SANG=ZCB3/DNOM
        ELSE
          CANG=1.D0
          SANG=0.D0
        END IF
C
C       XCC4=XCC3
        YCC4=YCC3*CANG+ZCC3*SANG
        ZCC4=ZCC3*CANG-YCC3*SANG
C
C The angle between the great circles is now easily computed.
C
        IF (YCC4.NE.0.D0.OR.ZCC4.NE.0.D0) THEN
          XABGCDP=RTOD*DATAN2(ZCC4,YCC4)
        ELSE
          XABGCDP=0.D0
        END IF
C
C Done.
C
        RETURN
C
      END
      FUNCTION ICAPDP(PQDP,QQDP,NPIQ)
C
C (ICAPDP = Integer Check Along Polygon, Double Precision)
C
        DOUBLE PRECISION PQDP(4),QQDP(4,NPIQ)
C
C The value of this function is zero if and only if the point P is
C inside the smaller of the two portions of the sphere formed by the
C boundary Q, which is the edge of a "polygon" defined by the points
C (QQSP(I)), for I from 1 to NPIQ.  (The edge of the polygon is formed
C of shortest great circle routes from point to point.)  The first and
C last points of Q should be identical.
C
C All variables with names of the form XQSP are four-element arrays
C containing the cosine and sine of the latitude and the cosine and
C sine of the longitude, in that order, of the point X.  Describing
C the point positions in this way makes this routine execute faster
C than if the latitudes and longitudes themselves are used.
C
        DOUBLE PRECISION ADST,ACAPDP,XADGCDP
C
C If the total angle swept out by a vector tangent to the sphere at the
C point P and pointing in the direction of the shortest great circle
C route to a point tracing Q is near zero, then both the point P and its
C antipodal point P' are in the same area, which must therefore be the
C larger of the two areas created by Q.
C
        IF (ABS(ACAPDP(PQDP,QQDP,NPIQ)).LT.180.D0) THEN
          ICAPDP=1
          RETURN
        END IF
C
C Otherwise, P is in one of the two areas and P' is in the other, so
C we perform a somewhat heuristic test to see if P is in the smaller
C of the two areas: we compute the average distance from P to Q and
C see if it is less than 90 degrees or more than 90 degrees.
C
        ADST=0.D0
C
C Sum over all distinct points of Q:
C
        DO 101 I=1,NPIQ-1
          ADST=ADST+XADGCDP(PQDP,QQDP(1,I))
  101   CONTINUE
C
C Set the function value.
C
        ADST=ADST/DBLE(NPIQ-1)
C
        IF (ADST.LT.90.D0) THEN
          ICAPDP=0
        ELSE
          ICAPDP=1
        END IF
C
        RETURN
      END
      DOUBLE PRECISION FUNCTION ACAPDP (PQDP,QQDP,NPIQ)
C
C (ACAPDP = Angular Change Along Polyline, Double Precision)
C
        DOUBLE PRECISION PQDP(4),QQDP(4,NPIQ)
C
C The value of this function is the total angle swept out by a vector
C tangent to the sphere at the point P and pointing in the direction of
C the shortest great circle route to a point tracing Q, a "polyline"
C defined by the points (QQDP(I)), for I from 1 to NPIQ.  (The edge of
C the polyline is formed of shortest great circle routes from point to
C point.)
C
C If the first and last points of Q are the same, the polyline becomes
C a closed polygon dividing the surface of the sphere into two areas -
C one to the left, and one to the right, of Q.  Let P' denote the point
C opposite P on the sphere.  Note that P' = (-PLAT,PLON+180).  In theory
C (ignoring computational inaccuracies), the function can only have
C three possible values: +360, if P is to the left of Q and P' is to
C the right of Q; -360, if P is to the right of Q and P' is to the
C left of Q; and zero, if both P and P' are on the same side of Q (left
C or right, but we don't know which).
C
C All variables with names of the form XQDP are four-element arrays
C containing the cosine and sine of the latitude and the cosine and
C sine of the longitude, in that order, of the point X.  Describing
C the point positions in this way makes this routine execute faster
C than if the latitudes and longitudes themselves are used.
C
        DOUBLE PRECISION ANCH,XABGCDP
C
        ANCH=0.D0
C
C Trace the edge:
C
        DO 101 I=1,NPIQ-1
          ANCH=ANCH+XABGCDP(PQDP,QQDP(1,I),QQDP(1,I+1))
  101   CONTINUE
C
C Set the function value.
C
        ACAPDP=ANCH
C
        RETURN
C
      END
      INTEGER FUNCTION GCCWISE(RLAT,RLON,NPTS)
C
C  Given NPTS pairs of (RLAT,RLON) values, this function
C  returns 1 if they are entered in counterclockwise order
C  and 0 if in clockwise order.
C
      DOUBLE PRECISION RLAT(NPTS),RLON(NPTS)
      DOUBLE PRECISION AREA, X, Y, XP, YP
C
C  Check that the input polygon is closed.
C
      IF (RLAT(NPTS).NE.RLAT(1) .OR. RLON(NPTS).NE.RLON(1)) THEN
        WRITE(6,500)
  500   FORMAT('GCINOUT: The input spherical polygon must be closed.')
        GCCWISE = -1
        RETURN
      ENDIF
C
      X = 0.D0
      Y = 0.D0
      AREA = 0.D0
C
C  Project the points onto a plane touching the globe at
C  (RLAT(1),RLON(1)) and use the algebraic sign of
C  the area computation formula.  Since (RLAT(1),RLON(1)) is
C  projected onto Cartesian coordinate (0,0), the initial X and
C  Y values are 0., as specified above.
C
      DO 10 I=1,NPTS-1
        CALL GPROJ(RLAT(1),RLON(1),RLAT(I+1),RLON(I+1),XP,YP)
        AREA = AREA + X*YP - XP*Y
        X = XP
        Y = YP
   10 CONTINUE
C
      IF (AREA .LE. 0.D0) THEN
        GCCWISE = 0
      ELSE
        GCCWISE = 1
      ENDIF
C
      RETURN
      END
      SUBROUTINE GPROJ(PHI0, LAMBDA0, PHI, LAMBDA, X, Y)
C
C  Find the projection onto the plane tangent to the globe at
C  (PHI0,LAMBDA0) of the point on the globe (PHI,LAMBDA).
C  The projected point is returned in Cartesian coordinate
C  (X,Y).
C
      DOUBLE PRECISION PHI0, LAMBDA0, PHI, LAMBDA, X, Y
      DOUBLE PRECISION SIN0, COS0, SINP, COSP, SIND, COSD, DENOM
      DOUBLE PRECISION D2R
      PARAMETER (D2R = 0.017453292519943D0)
C
      SIN0 = SIN(D2R*PHI0)
      COS0 = COS(D2R*PHI0)
      SINP = SIN(D2R*PHI)
      COSP = COS(D2R*PHI)
      SIND = SIN(D2R*(LAMBDA-LAMBDA0))
      COSD = COS(D2R*(LAMBDA-LAMBDA0))
      DENOM = SIN0*SINP + COS0*COSP*COSD
      X = (COSP*SIND)/DENOM
      Y = (COS0*SINP - SIN0*COSP*COSD)/DENOM
C
      RETURN
      END


      module fem_libs
      use fem_geometry
      use material_behavior
      use linearsolvers
      implicit none
      real*8,allocatable:: elcrds(:,:) !the geometries of nodes of the element
      contains
!     ================================================================
!                 forming the global martixes and vetors
!     ================================================================
      subroutine glbmatrcs(glu,glk,glq)
      implicit none
!     ================================================================
!                          input variables
!     ================================================================
      real*8,intent(in)::glu(:) ! the dof vector, current time
!     ================================================================
!                          output variables
!     ================================================================
      real*8,intent(out)::glq(:) ! residual vector
      real*8,intent(out)::glk(:,:) ! the global stiffness matrix
!     ================================================================
!                          trivial variables
!     ================================================================
      real*8,allocatable:: elq(:),elk(:,:) !the force and coeffi
      real*8,allocatable:: elu(:) ! degrees of freedom vector in current time

!     ================================================================
!                      time variables
!     ================================================================
!      real*8::time(2),dtime
!      integer::ntime,itime  !time
!     ================================================================
!                      history variables
!     ================================================================
      integer::igauss,elneq
!     ================================================================
!      integer::i,j,ni,l,li,nn,n,neq,
      integer::inpe,iglobal,idof,jdof
      integer::inode,jnode
      integer::noelem
!     =========================element global node and dof map
      integer,allocatable::el_nod_vec(:) !el_nod_vec(npe)
      integer,allocatable::el_dof_vec(:)  !el_dof_vec(npe*ndf)
!     ================================================================

      elneq=npe*ndf;
      allocate(elk(elneq,elneq),elq(elneq),elu(elneq))
!     ================================================================
      elu=0.0d0;elq=0.0d0;elk=0.0d0;
      igauss=0

!     starting the element

      allocate(el_nod_vec(npe),el_dof_vec(elneq))

      do noelem=1,nem
      el_nod_vec=nod(noelem,:)
      elcrds=transpose(coords(el_nod_vec,:))
!      call printMatrix(elcrds,'elcrds');

      do inpe=1,npe
      iglobal=nod(noelem,inpe)
      idof=inpe*ndf
      do jdof=0,ndf-1
      el_dof_vec(idof-ndf+1+jdof)=(iglobal*ndf-ndf+1+jdof)

      enddo !j=1,ndf
      enddo !inpe=1,npe

!     call printVector_int(el_dof_vec,'el_dof_vec')
      elu=glu(el_dof_vec)
!      write(1,*)noelem;
!      write(1,999)(elu(idof),idof=1,elneq);
!     ===============================================================
!     finding the center point of element
!     ===============================================================

!     ===============================================================
!     forming the coefficitne matrix and source vector for each element
!     ===============================================================
      call elmatrcs_1d(elu,elk,elq)
!     ===============================================================
!     assembling the global source vector and coefficient matrix
!     ===============================================================
!      write(3,*)noelem;
!      write(3,*)(elq(iglobal),iglobal=1,elneq);
      glq(el_dof_vec)=glq(el_dof_vec)+elq
      glk(el_dof_vec,el_dof_vec)=glk(el_dof_vec,el_dof_vec)+elk

!     call printMatrix(elk,'elk');

     enddo ! noelem=1,nem
!    write(3,*);write(3,*)(glq(iglobal),iglobal=1,neq);
999 FORMAT (11(:,1X,F8.5) )
     endsubroutine glbmatrcs

!     ===============================================================
!                       the element coefficient matrix
!     ===============================================================
      subroutine elmatrcs_1d(elu,elk,elq)
!     ================================================================
!     element  calculations based on  linear and quadratic rectangular
!     relements with isoparametric  formulation.
!     ================================================================
      implicit none
!     ================================================================
!                          input variables
!     ================================================================
      real*8,intent(in):: elu(:) !dof vector
!     ================================================================
!                          otput variables
!     ================================================================
      real*8,intent(out):: elq(:) !element source vector
      real*8,intent(out):: elk(:,:) !the element coefficient matrix
!     ================================================================
      integer::ni,nj,nk,i,j,ii,jj,k,li,lj
      integer::inode,jnode
!     ================================================================
      real*8:: elu_tense(npe,ndf) !dof current time
      real*8:: elp_tense(npe,ndf) !dof current time
      real*8::coord(dimen) !the global coordinate of each node
      real*8::xi(dimen)! transformed coordinates
      real*8::sf(npe),gdsf(dimen,npe),ur(ndf,dimen)
      real*8::k_coef(ndf,ndf) ! the auxilary matrix for cuefficitne matr
      real*8::res_vect(ndf)
      real*8::cnst,det
      real*8::der(dimen) !electric displacement
      real*8::sigma(dimen,dimen) !stress
!     ================================================================
      real*8:: gauspt(5,5),gauswt(5,5) ! gauss points and gauss weights
!     ================================================================
       data gauspt/5*0.0d0, -0.57735027d0, 0.57735027d0, 3*0.0d0,            &
       -0.77459667d0, 0.0d0, 0.77459667d0, 2*0.0d0, -0.86113631d0,           &
       -0.33998104d0, 0.33998104d0, 0.86113631d0, 0.0d0, -0.90617984d0,      &
       -0.53846931d0,0.0d0,0.53846931d0,0.90617984d0/
!
      data gauswt/2.0d0, 4*0.0d0, 2*1.0d0, 3*0.0d0, 0.55555555d0,        &
        0.88888888d0, 0.55555555d0, 2*0.0d0, 0.34785485d0,               &
      2*0.65214515d0, 0.34785485d0, 0.0d0, 0.23692688d0,                 &
        0.47862867d0, 0.56888888d0, 0.47862867d0, 0.23692688d0/
!     ===============================================================
      elq=0.0d0
      elk=0.0d0

!     ===============================================================

    do i=1,npe
    elu_tense(i,:)=elu(1+(i-1)*ndf:i*ndf)
    enddo !i=1,npe

    do 200 ni = 1,ipdf
    xi(1) = gauspt(ni,ipdf)

      call shapefuncs_1d(xi,det,sf,gdsf)
      cnst = det*gauswt(ni,ipdf)
      coord=0
    do i=1,npe
    coord(:)=coord(:)+elcrds(i,:)*sf(i)
    enddo !i=1,npe
!    write(1,*)'coord=',coord
!     ===============================================================
!                       post process
!     ===============================================================

    ur=transpose(matmul(gdsf,elu_tense))
    call material_properties()
    call stress_elect_displacement(ur,der,sigma)

!     ===============================================================
!                       filling the elemt matrixes
!     ===============================================================
    ii=1
      do 180 inode=1,npe
!     inode,jnode : are the node iterator
      call residual(inode,gdsf,ur,der,sigma,res_vect)
      do 162 li=1,ndf
!     li, lj : are the degree of freedom iterator
 162  elq(ii+li-1)=elq(ii+li-1)+res_vect(li)*cnst
      jj=1
      do 160 jnode=1,npe
      call  k_gen(inode,jnode,gdsf,sf,ur,k_coef)
      do 161 li=1,ndf
      do 161 lj=1,ndf
161   elk(ii+li-1,jj+lj-1)=elk(ii+li-1,jj+lj-1)+k_coef(li,lj)*cnst

!     ii,jj: define the location of information in the element matrix

  160 jj = ndf*jnode+1
  180 ii = ndf*inode+1

  200 continue
!write(1,*)'elq=',elq

      endsubroutine elmatrcs_1d

!     ===============================================================
!                       THE SHAPE FUNCTION SUBROUTINE
!     ===============================================================
      subroutine shapefuncs_1d(xi,det,sf,gdsf)
      real*8::det ! the jacobian determinant
      real*8,intent(out) ::sf(:),gdsf(:,:) ! shape function sf(npe),gdsf(dimen,npe)

      real*8::dsf(dimen,npe) ! the differentiatian of shape function
      real*8::gj(dimen,dimen)! global jacobian matrix
      real*8::gjinv(dimen,dimen) ! inverse of global jacobian matrix
      real*8::xnode(20,3) ! coordinate of nodes in refrence
      real*8::xp(dimen),xi(dimen) !locad coordinate in element
      integer::i
!     ================================================================
      data xnode/                                         &
     -1,1,1,-1,-1,1,1,-1,0,1,0,-1,-1,1,1,-1,0,1,0,-1,   &
     -1,-1,1,1,-1,-1,1,1,-1,0,1,0,-1,-1,1,1,-1,0,1,0,   &
     -1,-1,-1,-1,1,1,1,1,-1,-1,-1,-1,0,0,0,0,1,1,1,1/
!     ================================================================
      do 10 i=1,npe
      xp(1:dimen)=xnode(i,1:dimen)
      sf(i)=0.5*(1+xi(1)*xnode(i,1))
      dsf(1,i)=0.5*(xnode(i,1))
10    continue

!     ===================================================================
!         compute the jacobian matrix [gj] and its inverse [gjinv]
!     ===================================================================
      gj=matmul(dsf,transpose(elcrds))
      det=dabs(gj(1,1))
      gjinv=1/gj(1,1)
      gdsf=matmul(gjinv,dsf)
      end subroutine shapefuncs_1d

!     ===============================================================
!                       residula vector subroutine
!     ===============================================================
      subroutine residual(inode,gdsf,ur,der,sigma,res_vect)
!     ================================================================
      implicit none
!     ================================================================
!                          input variables
!     ================================================================
      integer,intent(in):: inode !node number
      real*8,intent(in)::gdsf(dimen,npe) !  the shape functions
      real*8,intent(in),dimension(ndf,dimen):: ur
      real*8,intent(in),dimension(dimen)::der ! electric displacement tensor
      real*8,intent(in),dimension(dimen,dimen)::sigma !stress tensor
!     ================================================================
!                          output variables
!     ================================================================
      real*8,intent(out)::res_vect(ndf) !the coefficient matri
!     ================================================================
      integer::i,j,k,l,m,n,p,s,t
      integer::del(dimen,dimen),eye(ndf,ndf)
!     ================================================================
!     deformmation and strain tensors
!     ================================================================
      real*8,dimension(dimen,dimen)::udsp_t,udsp_p,udsp_b
!     ===========================shape function tensors
      real*8::bepsilon(dimen,dimen,ndf),belec(dimen,ndf)
!     ================================================================
      del = 0.0; do i = 1,dimen; del(i,i) = 1;enddo
      eye = 0.0; do i = 1,ndf; eye(i,i) = 1;enddo
!!     ================================================================
!!            c     shape function tensor
!!     ================================================================
      belec=0.0d0;
      bepsilon=0.0d0;
!

      belec(:,dimen+1) = -gdsf(:,inode)
      do 10 k=1,ndf
      do 10 i=1,dimen
      do 10 j=1,dimen
      bepsilon(i,j,k)= 0.5d0*gdsf(j,inode)*eye(k,i)  &
                     + 0.5d0*gdsf(i,inode)*eye(k,j)
      do 10 m=1,dimen
      bepsilon(i,j,k)=bepsilon(i,j,k)                       &
                   + 0.5d0*gdsf(i,inode)*eye(k,m)*ur(m,j)   &
                   + 0.5d0*gdsf(j,inode)*eye(k,m)*ur(m,i)
 10   continue
!write(1,*)'gdsf=',gdsf

!     ================================================================
      res_vect=0.0d0

      do 40 k=1,ndf
      do 40 i=1,dimen
      res_vect(k)=res_vect(k)-der(i)*belec(i,k)
      do 40 j=1,dimen
40    res_vect(k)=res_vect(k)+sigma(i,j)*bepsilon(i,j,k)

!write(1,*)'belec=',belec
!write(1,*)'bepsilon=',bepsilon

!write(1,*)'sigma=',sigma(1,1)
!write(1,*)'der=',der(1)
      endsubroutine residual

!     ===============================================================
!                       coefficient matrix subroutine
!     ===============================================================
      subroutine  k_gen(inode,jnode,gdsf,sf,ur,k_coef)
!     ================================================================
      implicit none
!     ================================================================
!                          input variables
!     ================================================================
      integer,intent(in)::inode,jnode !node number iterators
      real*8,intent(in)::sf(:),gdsf(:,:) !  the shape functions
      real*8,intent(in)::ur(:,:)! displacement
!     ================================================================
!                          output variables
!     ================================================================
      real*8,intent(out)::k_coef(:,:) !the coefficient matrix
!     ================================================================
      integer::i,j,k,l,m,n,p,s,t
      integer,save::counter
      integer::del(dimen,dimen),eye(ndf,ndf)
      real*8::dsgr(dimen,dimen)

!     electric field variables
!     ================================================================
      real*8,dimension(dimen)::der,elr_t,elr_p,elr_b
      real*8,dimension(dimen)::d_elr_t,d_elr_p,d_elr_b
!     ===========================shape function tensors
      real*8::bepsiloni(dimen,dimen,ndf),beleci(dimen,ndf)
      real*8::bepsilonj(dimen,dimen,ndf),belecj(dimen,ndf)
!!     ================================================================
      counter=counter+1
      del = 0.0; do i = 1,dimen; del(i,i) = 1;enddo
      eye = 0.0; do i = 1,ndf;   eye(i,i) = 1;enddo
!!     ================================================================
!!            c     material properties
!!     ================================================================
      ctenst=ctens;

      beleci=0.0d0;
      belecj=0.0d0;
      bepsiloni=0.0d0;
      bepsilonj=0.0d0;

      beleci(:,dimen+1) = -gdsf(:, inode)
      belecj(:,dimen+1) = -gdsf(:, jnode)

      do 10 k=1,ndf
      do 10 i=1,dimen
      do 10 j=1,dimen

      bepsilonj(i,j,k)= 0.5*gdsf(j,jnode)*eye(k,i)+0.5*gdsf(i,jnode)*eye(k,j)

      bepsiloni(i,j,k)= 0.5*gdsf(j,inode)*eye(k,i)+0.5*gdsf(i,inode)*eye(k,j)

      do 10 m=1,dimen

      bepsilonj(i,j,k)=bepsilonj(i,j,k)                   &
                   + 0.5*gdsf(i,jnode)*eye(k,m)*ur(m,j)   &
                   + 0.5*gdsf(j,jnode)*eye(k,m)*ur(m,i)
      bepsiloni(i,j,k)=bepsiloni(i,j,k)                   &
                   + 0.5*gdsf(i,inode)*eye(k,m)*ur(m,j)   &
                   + 0.5*gdsf(j,inode)*eye(k,m)*ur(m,i)

 10   continue
!       write(*,*)ktense
!!     ===========================componenst of tangent matrixe
      k_coef=0.0d0;
!!     ===========================the tangent matrix
      do 40 k=1,ndf;
      do 40 l=1,ndf;

      do 40 i=1,dimen;
      do 40 j=1,dimen;

      k_coef(k,l)=k_coef(k,l)-beleci(i,l)*ktense(i,j)*belecj(j,k)

      do 40 m=1,dimen;

      k_coef(k,l)=k_coef(k,l)-epz_t(m,i,j)*beleci(m,l)*bepsilonj(i,j,k)
      k_coef(k,l)=k_coef(k,l)-epz_t(m,i,j)*belecj(m,k)*bepsiloni(i,j,l)

      do 40 n=1,dimen;

40    k_coef(k,l)=k_coef(k,l)+ctenst(i,j,m,n)*bepsilonj(i,j,k)*bepsiloni(m,n,l)

      endsubroutine k_gen

   !     ===============================================================
!                  the boundary condition subroutine
!     ===============================================================
     subroutine symmetric_primary_bounday(glk,glr)
     implicit none
!     ================================================================
!                          input variables
!     ================================================================
      real*8,intent(inout) :: glk(:,:),glr(:)! global coefficient
      integer::i !integer counters
      real*8,allocatable::gls(:)
!     ================================================================
!     ================================================================
!                          primary variables
!     for u(i)=alpha, it puts k(i,j)=1 and f(i)=alpha
!     ================================================================
      allocate(gls(size(glr)));
        gls=0.0d0
        gls(bnd_no_pr_vec)=vspv
        glr=glr-matmul(glk,gls)

        glk(bnd_no_pr_vec,:)=0.0d0;
        glk(:,bnd_no_pr_vec)=0.0d0;

        do i=1,nspv;
        glk(bnd_no_pr_vec(i),bnd_no_pr_vec(i))=1.0d0; enddo
        glr(bnd_no_pr_vec)=vspv

    endsubroutine symmetric_primary_bounday

subroutine result_printer_1D(iter,glu)
      real*8,INTENT(IN)::glu(:);
      integer::iter;
!     ================================================================
!                          trivial variables
!     ================================================================
      integer::i,j,pdf,k;
      integer::curved_node;
      integer,parameter::gnuplot=5
      integer,save::counter
      character(len=5)::str,x1
      character(len=20) :: fmt,filename ! format descriptor
      fmt = '(i4.4)' ! an integer of width 5 with zeros at the left

!       write(*,*)dimen

      curved_node=nnm
      counter=counter+1

      i=1
      write(x1,fmt)i
      filename='1d_afc'//trim(x1)//'.csv'
!
      open (out,file='out_1d_data_outpu.txt')
      open (gnuplot,file='gnu_out_put.gnu')
!
      write(out,910);write(out,*)'time',time
      write(out,910);write(out,910);write(out,670);write(out,910)
      do i=1,nnm
      pdf=(i-1)*ndf
      write(out,950)i,(coords(i,j),j=1,dimen),(glu(pdf+k),k=1,ndf)
      enddo
      if(counter.eq.1)then
      open (csv,file=filename)
      write(csv,672)
      endif
      pdf=(curved_node-1)*ndf
      write(csv,951)iter,time(2),glu(pdf+1)
      write(gnuplot,*)glu(pdf+2),time(2),glu(pdf+1)

!     ===============================================================
!                              formats
!     ===============================================================
910   format (2x,80('_'),/)
670   format(5x,'node     x-coord. u-solut.')
950   format(5x,i5,10e14.5)
951   format(5x,i5,' , ',10(e14.5,' , '))
672   format(5x,'itr, time[sec],u[m],  elec_pot[v]')

end subroutine result_printer_1D

      end module fem_libs


      DOUBLE PRECISION FUNCTION DDILOG(X)

      DOUBLE PRECISION X,Y,T,S,A,PI3,PI6,ZERO,ONE,HALF,MALF,MONE,MTWO
      DOUBLE PRECISION C(0:18),H,ALFA,B0,B1,B2

      DATA ZERO /0.0D0/, ONE /1.0D0/
      DATA HALF /0.5D0/, MALF /-0.5D0/, MONE /-1.0D0/, MTWO /-2.0D0/
      DATA PI3 /3.28986 81336 96453D0/, PI6 /1.64493 40668 48226D0/

      DATA C( 0) / 0.42996 69356 08137 0D0/
      DATA C( 1) / 0.40975 98753 30771 1D0/
      DATA C( 2) /-0.01858 84366 50146 0D0/
      DATA C( 3) / 0.00145 75108 40622 7D0/
      DATA C( 4) /-0.00014 30418 44423 4D0/
      DATA C( 5) / 0.00001 58841 55418 8D0/
      DATA C( 6) /-0.00000 19078 49593 9D0/
      DATA C( 7) / 0.00000 02419 51808 5D0/
      DATA C( 8) /-0.00000 00319 33412 7D0/
      DATA C( 9) / 0.00000 00043 45450 6D0/
      DATA C(10) /-0.00000 00006 05784 8D0/
      DATA C(11) / 0.00000 00000 86121 0D0/
      DATA C(12) /-0.00000 00000 12443 3D0/
      DATA C(13) / 0.00000 00000 01822 6D0/
      DATA C(14) /-0.00000 00000 00270 1D0/
      DATA C(15) / 0.00000 00000 00040 4D0/
      DATA C(16) /-0.00000 00000 00006 1D0/
      DATA C(17) / 0.00000 00000 00000 9D0/
      DATA C(18) /-0.00000 00000 00000 1D0/

      IF(X .EQ. ONE) THEN
       DDILOG=PI6
       RETURN
      ELSE IF(X .EQ. MONE) THEN
       DDILOG=MALF*PI6
       RETURN
      END IF
      T=-X
      IF(T .LE. MTWO) THEN
       Y=MONE/(ONE+T)
       S=ONE
       A=-PI3+HALF*(LOG(-T)**2-LOG(ONE+ONE/T)**2)
      ELSE IF(T .LT. MONE) THEN
       Y=MONE-T
       S=MONE
       A=LOG(-T)
       A=-PI6+A*(A+LOG(ONE+ONE/T))
      ELSE IF(T .LE. MALF) THEN
       Y=(MONE-T)/T
       S=ONE
       A=LOG(-T)
       A=-PI6+A*(MALF*A+LOG(ONE+T))
      ELSE IF(T .LT. ZERO) THEN
       Y=-T/(ONE+T)
       S=MONE
       A=HALF*LOG(ONE+T)**2
      ELSE IF(T .LE. ONE) THEN
       Y=T
       S=ONE
       A=ZERO
      ELSE
       Y=ONE/T
       S=MONE
       A=PI6+HALF*LOG(T)**2
      END IF

      H=Y+Y-ONE
      ALFA=H+H
      B1=ZERO
      B2=ZERO
      DO 1 I = 18,0,-1
      B0=C(I)+ALFA*B1-B2
      B2=B1
    1 B1=B0
      DDILOG=-(S*(B0-H*B2)+A)
      RETURN
      END