      subroutine amtx(n,factor,diag)
************************************************************************
*
*   AMTX -- Local MFE mass matrix A(y).
*
*     If DIAG=1 only the diagonal blocks are loaded.
*
************************************************************************
      include "parameters.h"

      integer nepn,x,y
      parameter(nepn=npde+2,x=npde+1,y=npde+2)

      double precision wpde
      common /mfe020/ wpde(npde)

      double precision a00,a10,a20,a01,a11,a21,a02,a12,a22
      common /loc013/
     +       a00(65,nepn,nepn),a10(65,nepn,nepn),a20(65,nepn,nepn),
     +       a01(65,nepn,nepn),a11(65,nepn,nepn),a21(65,nepn,nepn),
     +       a02(65,nepn,nepn),a12(65,nepn,nepn),a22(65,nepn,nepn)

      double precision a,n1,n2,n3
      common /loc020/ a(65,npde)
      common /loc021/ n1(65,npde),n2(65,npde),n3(65,npde)

      integer n,diag,j,k,k1,k2
      double precision factor,c,term

*     Zero the basic block initially.
      do 10 k2=1,nepn
      do 10 k1=1,nepn
      do 10 j=1,n
   10 a00(j,k1,k2) = 0.

*     Load the nonzero elements.
      do 20 k=1,npde
      c = factor*wpde(k)/6.
      do 20 j=1,n
       a00(j,k,k) = ((c*a(j,k))*n3(j,k))*n3(j,k)
       a00(j,k,x) = ((c*a(j,k))*n3(j,k))*n1(j,k)
       a00(j,x,k) = a00(j,k,x)
       a00(j,k,y) = ((c*a(j,k))*n3(j,k))*n2(j,k)
       a00(j,y,k) = a00(j,k,y)
       a00(j,x,x) = a00(j,x,x) + ((c*a(j,k))*n1(j,k))*n1(j,k)
       a00(j,x,y) = a00(j,x,y) + ((c*a(j,k))*n1(j,k))*n2(j,k)
       a00(j,y,y) = a00(j,y,y) + ((c*a(j,k))*n2(j,k))*n2(j,k)
   20 continue

      do 21 j=1,n
   21 a00(j,y,x) = a00(j,x,y)
*     -----------------------
*      Copy the basic block.
*     -----------------------
      do 30 k1=1,nepn
      do 30 k2=1,nepn
      do 30 j=1,n
       term = a00(j,k1,k2)
       a11(j,k1,k2) = term
       a22(j,k1,k2) = term

       if(diag .eq. 1) go to 30

       a01(j,k1,k2) = .5*term
       a02(j,k1,k2) = .5*term
       a12(j,k1,k2) = .5*term
   30 continue

      return
      end


SUBROUTINE flint_cur()
! **********************************************************************
! Modules
! **********************************************************************
  USE neo_precision
  USE neo_units
  USE neo_exchange
  USE neo_output
  USE partpa_cur
  USE neo_rk4dcur
! **********************************************************************
! Local definitions
! **********************************************************************
  IMPLICIT NONE
! **********************************************************************
  INTEGER                                          ::  i,n,j1,nfl
  REAL(kind=dp), DIMENSION(:), ALLOCATABLE, TARGET ::  y
  REAL(kind=dp), DIMENSION(:), ALLOCATABLE         ::  y_s
  REAL(kind=dp), DIMENSION(:), ALLOCATABLE         ::  t

  REAL(kind=dp)                                    ::  theta0, phi0
  REAL(kind=dp)                                    ::  theta, phi
  REAL(kind=dp)                                    ::  hphi
  REAL(kind=dp)                                    ::  tmin, tmax, ht

  REAL(kind=dp),               POINTER             ::  p_theta, p_bm2
  REAL(kind=dp),               POINTER             ::  p_bm2gv
  REAL(kind=dp),               POINTER             ::  p_lamps
  REAL(kind=dp),               POINTER             ::  p_lamb1n, p_lamb1d
  REAL(kind=dp),               POINTER             ::  p_lamb2n, p_lamb2d
  REAL(kind=dp), DIMENSION(:), POINTER             ::  p_l, p_k1, p_k
! **********************************************************************
! Allocation
! **********************************************************************
  ndim_cur = npq_cur + 3 * npart_cur
  ALLOCATE( t(npart_cur) )
  ALLOCATE( y_part(npart_cur) )
  ALLOCATE( yfac(npart_cur) )
  ALLOCATE( sqyfac(npart_cur) )
  ALLOCATE( y(ndim_cur) )
  ALLOCATE( y_s(ndim_cur) )
  ALLOCATE( k_fac1(npart_cur) )
  ALLOCATE( k_fac2(npart_cur) )
! **********************************************************************
! Pointer
! **********************************************************************
  p_theta  => y(1)
  p_bm2    => y(2)
  p_bm2gv  => y(3)
  p_lamps  => y(4)
  p_lamb1n => y(5)
  p_lamb1d => y(6)
  p_lamb2n => y(7)
  p_lamb2d => y(8)
  p_l      => y(npq_cur+1:npq_cur+npart_cur)
  p_k1     => y(npq_cur+npart_cur+1:npq_cur+2*npart_cur)
  p_k      => y(npq_cur+2*npart_cur+1:npq_cur+3*npart_cur)
! **********************************************************************
! Initial settings
! **********************************************************************
  ierr   = 0
  hphi   = twopi/(nstep_per*nper)
  bmod0  = bmref
!
  theta0 = theta_bmax
  phi0   = phi_bmax
! **********************************************************************
! Definition of t-values for particles
! **********************************************************************
  tmin = 1.0e-3_dp
  tmax = 1
  ht = (tmax-tmin)/(npart_cur-1)
  DO i=1,npart_cur
     t(i)=tmin+ht*(i-1)
  ENDDO
  y_part = ONE - t**alpha_cur
!!$  PRINT *, 'hphi, ht ',hphi, ht
!!$  PRINT *, 'bmod0 ', bmod0
!!$  PRINT *, 'ndim_cur ', ndim_cur
!!$  PRINT *, 'theta0 ', theta0
!!$  PRINT *, 'phi0 ', phi0
!!$  PAUSE
!!$  PRINT *, 't ',t
!!$  PAUSE
!!$  PRINT *, 'y_part ',y_part
!!$  PAUSE
! **********************************************************************
  IF (write_cur_inte == 1) THEN
     OPEN(unit=w_u8,file='current.dat',status='replace',form='formatted')
  ENDIF
! **********************************************************************
  phi     = phi0
  y       = 0
  p_theta = theta0
! **********************************************************************
! Integration steps (Summation)
! **********************************************************************
! ATTENTION JUST FOR TEST
  hit_rat = 0
  nintfp  = 10000
! ATTENTION JUST FOR TEST
  IF (hit_rat .EQ. 0) THEN
     DO n=1,nintfp
        DO j1=1,nstep_per
           CALL RK4D_CUR(phi,y,hphi)
        END DO
        IF (write_cur_inte == 1) THEN
           CALL calccur(n,t,ht,y)
        ENDIF
     END DO
     IF (write_cur_inte == 0) THEN
        CALL calccur(n,t,ht,y)
     END IF
  ELSE
    y_s = 0
    DO nfl = 0, nfl_rat
       phi     = phi0
       y       = 0
       theta   = theta0 + nfl * delta_theta_rat
       p_theta = theta
       DO n=1,nfp_rat
          DO j1=1,nstep_per
             CALL RK4D_CUR(phi,y,hphi)
          END DO
          IF (write_cur_inte == 1) THEN
             CALL calccur(nfl*nfp_rat+n,t,ht,y)
          ENDIF
       END DO
       y_s = y_s + y
    END DO
    y = y_s
    CALL calccur(nfl*nfp_rat+n+1,t,ht,y)
  END IF
! **********************************************************************
  lambda_b   = lambda_b   / avnabpsi
  lambda_b1  = lambda_b1  / avnabpsi
  lambda_b2  = lambda_b2  / avnabpsi
  lambda_ps1 = lambda_ps1 / avnabpsi
  lambda_ps2 = lambda_ps2 / avnabpsi
! **********************************************************************
  IF (write_cur_inte == 1) THEN
     CLOSE(unit=w_u8)
  ENDIF
! **********************************************************************
! Deallocation
! **********************************************************************
  DEALLOCATE( t )
  DEALLOCATE( y_part )
  DEALLOCATE( yfac )
  DEALLOCATE( sqyfac )
  DEALLOCATE( y )
  DEALLOCATE( y_s )
  DEALLOCATE( k_fac1 )
  DEALLOCATE( k_fac2 )
!
  RETURN
END SUBROUTINE flint_cur


C------Subroutine WINDAT.
C
C	This routine takes the raw input spectrum in INDATA, fits a 5th order
C	polynomial to it to remove low wave-number shapes, and applies a
C	cosine bell window to the ends of the spectrum over a range at either
C	end that is HAN * NBIN long.
C
C	Originally due to Paul Schechter, 197?.
C	Possible modifications by Brad Whitmore and Eliot Malumuth, 1978-1982.
C	Modified by Gerard Kriss 1983 to let NBIN be a free parameter.
C	Modified by Gerard Kriss 1987 to pass data as explicit parameters
C		rather than in a catch-all COMMON block in the course of
C		modifications for using this routine in IRAF.
C
      SUBROUTINE WINDAT(INDATA,OUTDAT,NBIN,ISHIFT,IORD,HAN,AVE)
      REAL INDATA(1),X(64),Y(64),B(11),OUTDAT(1)
      REAL POLY
C   GENERATE SIZE DEPENDENT PARAMETERS.
        NB2=NBIN/2
        NB64=NBIN/64
      NUM=NBIN-IABS(ISHIFT)
      IL=MAX0(-ISHIFT,0)+1
      IR=IL+NUM-1
      DO 10 I=1,64
        X(I)=(I-32.5)/32
        Y(I)=INDATA(NB64*(I-1)+1)/NB64
        DO 10 J=2,NB64
          Y(I)=Y(I)+INDATA(NB64*(I-1)+J)/NB64
10        CONTINUE
      CALL EARLIN(X,Y,64,B,-IORD)
      II=IABS(ISHIFT)
      DO 20 I=1,II
        OUTDAT(I)=0.
        OUTDAT((NBIN+1)-I)=0.
20      CONTINUE
      AVE=B(1)+B(3)/3
      DO 30 I=IL,IR
        Z=(I-NB2-0.5)/NB2
        OUTDAT(I)=(INDATA(I) - POLY(IORD,B,Z)) / AVE
30    CONTINUE
      IHAN=HAN*NUM
      T1=3.14159265/IHAN
      DO 40 I=1,IHAN
        FACT=(1-COS(T1*I))/2
        OUTDAT((IR+1)-I)=FACT*OUTDAT((IR+1)-I)
        OUTDAT((IL-1)+I)=FACT*OUTDAT((IL-1)+I)
40      CONTINUE
      RETURN
      END


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Assignes material properties node by node for non linear elasticity.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] vcase value case for non linear block
!> @param[in] R_el  reduction factor
!> @param[in] nn  polynomial degree
!> @param[in] cs_nnz length of cs
!> @param[in] cs connectivity vector
!> @param[in] ielem  element index
!> @param[in] nf number of functions
!> @param[in] func_type function type
!> @param[in] func_indx indices for the data
!> @param[in] func_data(*)  data for the calculation (depending on type)
!> @param[in] t_stress  time
!> @param[in] tag_func labels for functions
!> @param[in] yon is the node nonlinear elastic yes (1) or not (0)?
!> @param[in] nnod_loc  number of local nodes
!> @param[in] vs_tria  vs values for each node
!> @param[out] rho_el material density
!> @param[out] lambda_el Lame coefficient lambda
!> @param[out] mu_el Lame coefficient mu
!> @param[out] gamma_el damping coefficient gamma

      subroutine MAKE_ELTENSOR_FOR_CASES_NLE(vcase,R_el,&
                                 nn,rho_el,lambda_el,mu_el,gamma_el,&
                                 cs_nnz,cs,ielem,&
                                 func_type,func_indx,func_data,nfdata,&
                                 nf,t_stress,tag_func,yon,tcase,&
                                 nnod_loc,vs_tria)

      implicit none

      integer*4 :: vcase
      integer*4 :: nn
      integer*4 :: p,q,r
      integer*4 :: is,in,ielem
      integer*4 :: cs_nnz
      integer*4 :: nf,fn,nfdata,tcase,nnod_loc

      integer*4, dimension(nf) :: tag_func
      integer*4, dimension(nf) :: func_type
      integer*4, dimension(nf +1) :: func_indx
      integer*4, dimension(0:cs_nnz) :: cs

      integer*4, dimension(nn,nn,nn) :: yon

      real*8 :: VS,VP
      real*8 :: Vratio
      real*8 :: t_stress
      real*8 :: get_func_value
      real*8 :: reduction_factor

      real*8, dimension(nfdata) :: func_data
      real*8, dimension(nnod_loc) :: vs_tria

      real*8, dimension(nn,nn,nn) :: rho_el,lambda_el,mu_el,gamma_el
      real*8, dimension(nn,nn,nn) :: R_el

      do r = 1,nn
         do q = 1,nn
            do p = 1,nn

               is = nn*nn*(r -1) +nn*(q -1) +p
               in = cs(cs(ielem -1) +is)

                if (yon(p,q,r).eq.1) then

                    VS = dsqrt( mu_el(p,q,r) / rho_el(p,q,r) )
                    VP = dsqrt( (lambda_el(p,q,r) + 2*mu_el(p,q,r) ) / rho_el(p,q,r) )
                    Vratio = VP/VS

                    !-------------------------------------------------------------------
                    !
                    if(tcase .ne. 16) then
                      do fn = 1,nf
                         if (vcase .eq. tag_func(fn)) then
                             if (func_type(fn) .eq. 60 ) then

                                reduction_factor = get_func_value(nf,func_type,func_indx,func_data, nfdata, &
                                                               fn,R_el(p,q,r))

                                mu_el(p,q,r) = mu_el(p,q,r) *  reduction_factor
                                VS = dsqrt(mu_el(p,q,r)/rho_el(p,q,r))
                                VP = VS * Vratio
                                lambda_el(p,q,r)= rho_el(p,q,r)*(VP**2)-2*mu_el(p,q,r)

                             endif
                         endif
                       enddo

                     elseif (tcase .eq. 16) then

                       do fn = 1,nf
                         if (vcase .eq. tag_func(fn)) then
                             if (func_type(fn) .eq. 60 .and. vs_tria(in) .lt. 325.d0) then

                               reduction_factor = get_func_value(nf,func_type,func_indx,func_data, nfdata, &
                                                                 fn,R_el(p,q,r))

                               mu_el(p,q,r) = mu_el(p,q,r) *  reduction_factor
                               VS = dsqrt(mu_el(p,q,r)/rho_el(p,q,r))
                               VP = VS * Vratio
                               lambda_el(p,q,r)= rho_el(p,q,r)*(VP**2)-2*mu_el(p,q,r)

                             elseif (func_type(fn) .eq. 62 .and. vs_tria(in) .lt. 450.d0) then

                               reduction_factor = get_func_value(nf,func_type,func_indx,func_data, nfdata, &
                                                                 fn,R_el(p,q,r))

                               mu_el(p,q,r) = mu_el(p,q,r) *  reduction_factor
                               VS = dsqrt(mu_el(p,q,r)/rho_el(p,q,r))
                               VP = VS * Vratio
                               lambda_el(p,q,r)= rho_el(p,q,r)*(VP**2)-2*mu_el(p,q,r)

                             endif

                          endif
                        enddo

                     endif!tcase = 16

                        !
                        !-------------------------------------------------------------------

                endif !if (yon(i,j,k).eq.1) then

            enddo
         enddo
      enddo

      return

      end subroutine MAKE_ELTENSOR_FOR_CASES_NLE


program test

  use precision
  use globals
  use operators
  type(wave_fn) :: y, y2
  y%in_basis%alpha=cmplx(0)
  y%in_basis%n=20
  allocate(y%co_eff(0:y%in_basis%n))
  y%co_eff=cmplx(0)
  y%co_eff(2)=cmplx(1,1)
  y%co_eff=y%co_eff/normalisation(y)
  write(*,'(f15.7,f15.7)') y%co_eff
  write(*,*) '=========='
  y2=.ad.y
  write(*,'(f15.7,f15.7)') y2%co_eff
end program test


      subroutine cov_data2data(x1,y1,z1,x2,y2,z2,ddcov)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c     Returns the covariance between to data points
c     *********************************************
c
c     INPUT VARIABLES:
c
c     index        index of data point considered
c     x1,y1,z1     location of first data point
c     x2,y2,z2     location of second data point
c
c     OUTPUT VARIABLES:
c
c     ddcov       data to data covarianc
c
c     ORIGINAL : Thomas Mejer nsen                       DATE: October 2004
c
c     TODO : Use either lookup table in RAM or a lookup table on disk
c
c-----------------------------------------------------------------------
      use geostat_allocate
	  include 'visim.inc'
      real ddcov
      integer i,j,k,ivol_temp,index
      integer ix1,iy1,iz1,ix2,iy2,iz2
      real x1,y1,z1,x2,y2,z2
      real cov

      if (x1.eq.0) then
         write(*,*) 'Initializing data2data covar lookup table'
         k=0
         do i=1,(nx*ny*nz)
            do j=1,(nx*ny*nz)
               cd2d(i,j)=UNEST
            enddo
         enddo

         write(*,*) 'Initializing data2data covar lookup table'
         ddcov=0
         return
      endif

c     ALL YOU NEED IS TO CALCULATE THE INDEXES
      index1=1
      index2=1

      index1 = ix1 + (iy1-1)*nx + (iz1-1)*nxy
      index1 = ix1 + (iy1-1)*nx + (iz1-1)*nxy

      if (cd2d(index1,index2).eq.UNEST) then

c         write(*,*) 'Initialize value'
c     CALCULATE THE VALUE

c         write (*,*) 'x1,y1,z1=',x1,y1,z1,x2,y2,z2
         call cova3(x1,y1,z1,
     +        x2,y2,z2,1,nst,MAXNST,c0,it,
     +        cc,aa,1,MAXROT,rotmat,cmax,cov)

         ddcov=dble(cov)
c     put the value inthe lookup table
c     comment this line out to disable the look table
c     in this case the cd2d variable should be removed from the visim.inc file.
         cd2d(index1,index2)=ddcov;
      else
         ddcov=cd2d(index1,index2);

      end if

      return

      end


                    program frmodel
*
*     estimates values of galactocentric distance rc(kpc), velocity
*     vt(km/sec) perpendicular to the line of sight and the proper
*     motion gpm (mas/year) of a Galactic disk object of given celestial
*     coordinates with given estimated distance to the object or by
*     estimating the distance from the LSR radial velocity vr(km/sec).
*     A simple flat circular rotation model of the Galaxy is assumed
*     with given values of the galactic center distance R0(kpc) and
*     rotation velocity V0(km/sec) at the solar circle.
*     Then parallax ellipse and movement of the object due to the
*     Solar Motion are estimated.
*
      implicit real * 8 (a - h, o - z)
*
      character*70 argm
      character raline * 70, decline * 70
      character ans * 1, asign * 1
      character arh * 3, arm * 3, add * 3, adm * 3
*
      dimension rd(2), vt(2), gpm(2)
*
      narg = iargc()
      if (narg.eq.4) then
      call getarg(1,argm)
      read(argm,'(A70)') raline
      print *, 'raline = ', raline
      call getarg(2,argm)
      read(argm,'(A70)') decline
      print *, 'decline = ', decline
      call getarg(3,argm)
      read(argm,'(A1)') ans
      print *, ans
      call getarg(4,argm)
      read(argm,'(e50.0)') rde
      print *, 'dist(kpc) = ', rde
      endif

*
C standard GR
C        data R0, V0 /8.5d0, 220.0d0/
C  M.R. (2009) GR
C      data R0, V0 /8.4d0, 254.0d0/
C  B.A. (2011) GR (to use with the Schoenrich et al. (2010) solar motion)
C      data R0, V0 /8.3d0, 239.0d0/
C  M.R. (2014) B1 solution (to use with the Schoenrich et al. (2010) solar motion)
      data R0, V0 /8.33d0, 243.0d0/
C
      data pi /3.141592654d0/
      data zero /0.0d0/
      data nseg /24/
*
      open (11, file = 'galrot.dat')
      open (12, file = 'solmot.dat')
      open (13, file = 'paralx.dat')
      open (14, file = 'galsol.dat')
      open (15, file = 'combmt.dat')
      open (16, file = 'frmodel.gp')
*
      rad = pi / 180.0d0
*
      write (*, *) 'Galactic Rotation, Solar Motion  and Parallax'
      write (*, *)
      call inqradc(raline,decline,rh, rm, rs, isign, dd, dm,
     + ds, ras, dec)
*
C      write (*, *) 'Do you have an estimated distance to the source?'
C     read (*, *) ans
*
      if (ans .ne. 'y' .and. ans .ne. 'Y') then
        write (*, *) 'Enter LSR velocity in km/sec : '
        read (*, *) vr
*
        call flatrot(rh, rm, rs, isign, dd, dm, ds, vr, gl, glat,
     +       rc, pa, rd(1), vt(1), gpm(1), rd(2), vt(2), gpm(2),
     +       istat)
*
        sgl = sin(rad * gl)
*
        v1 = V0 * (1.0d0 - abs(sgl))
        v2 = V0 * abs(sgl)
        v3 = 0.0d0
*
        if (istat .eq. 1) then
          write (*, *) 'Warning : Galactic latitude of your source ',
     +          'seems too large to apply the flat rotation model.'
          write (*, *)
        else if (istat .eq. 2) then
          write (*, *) 'Sorry, the flat rotation model is inadequate ',
     +                 'for your source.'
          write (*, *) 'The model assumes LSR velocity range '
*
          if (gl .ge.   0.0d0 .and. gl .lt.  90.0d0) then
            write (*, *) '    from ', -v2, ' km / sec'
            write (*, *) '    to   ',  v1, ' km / sec'
          else if (gl .ge.  90.0d0 .and. gl .lt. 180.0d0) then
            write (*, *) '    from ', -v2, ' km / sec'
            write (*, *) '    to   ',  v3, ' km / sec'
          else if (gl .ge. 180.0d0 .and. gl .lt. 270.0d0) then
            write (*, *) '    from ',  v3, ' km / sec'
            write (*, *) '    to   ',  v2, ' km / sec'
          else if (gl .ge. 270.0d0 .and. gl .lt. 360.0d0) then
            write (*, *) '    from ', -v1, ' km / sec'
            write (*, *) '    to   ',  v2, ' km / sec'
          endif
*
          write (*, *) 'at this galactic longitude : ', gl
          stop
        endif
*
        write (*, '('' Galactic longitude and latitude = '', 2F7.2,
     +              '' degrees'')') gl, glat
        write (*, '('' Position angle of the Galactic parallel = '',
     +              F7.2, '' degrees'')') pa
        write (*, '('' Estimated distance from the G.C. = '',
     +              F7.2, '' kpc'')') rc
*
        if (rc .gt. R0) then
          ndis = 1
          write (*, '('' Estimated distance from the Sun = '',
     +                 F7.2, '' kpc'')') rd(1)
          write (*, '('' Transversal velocity = '', F7.2, '' km/s'')')
     +           vt(1)
          write (*, '('' PM due to GR         = '', F7.2, '' mas/y'')')
     +           gpm(1)
        else
          ndis = 2
          write (*, '('' Estimated distance from the Sun = '',
     +                 F7.2, ''   or '', F7.2, '' kpc'')') rd(1), rd(2)
          write (*, '('' Transversal velocity = '', F7.2, ''   or '',
     +                F7.2, '' km/s'')') vt(1), vt(2)
          write (*, '('' PM due to GR         = '', F7.2, ''   or '',
     +                F7.2, '' mas/y'')') gpm(1), gpm(2)
        endif
*
      else
*       *** estimated distance given
        ndis = 1
        call eqtogalp(rh, rm, rs, isign, dd, dm, dc, gl, glat, pa)
*
C        write (*, *) 'Enter distance in kpc : '
C       read (*, *) rde
*
        rgl = rad * gl
        sgl = sin(rgl)
        cgl = cos(rgl)
*
        rc = sqrt(rde * rde - 2.0d0 * R0 * rde * cgl + R0 * R0)
*       *** distance of the object from the Galactic center ***

        write (*, *) 'Galactic longitude and latitude = ',
     +               gl, ', ', glat
        write (*, *) 'Position angle of the galactic plane = ', pa
*
        if (glat .gt. 5.0d0) then
          write (*, *)
          write (*, *) 'WARNING : the galactic latitude might be too ',
     +                 'large for the flat rotation model!'
          write (*, *)
        endif
*
        vr = V0 * sgl * (R0 - rc) /rc
        rd(1) = rde
        vt(1) = - V0 * ((R0 - rc) * cgl - rde) / rc
        gpm(1) = 0.2108 * vt(1) / rde
*
        write (*, *)
        write (*, '('' Distance from the Galactic center = '',
     +               F7.2, '' kpc'')') rc
        write (*, '('' Estimated LSR velocity = '', F7.2, '' km/s'')')
     +           vr
        write (*, '('' Transversal velocity   = '', F7.2, '' km/s'')')
     +           vt(1)
        write (*, '('' PM due to GR           = '', F7.2, '' mas/y'')')
     +           gpm(1)
      endif
*
      dsl = 360.0d0 / nseg
*
      rpa = rad * pa
*
*     Position angle 'pa' of the Galactic parallel (direction of
*     increasing galactic longitude) at the source is measured
*     eastward from the north, while 'vt' and 'pm' are taken
*     positive if the source moves towards direction of decreasing
*     galactic longitude.
*
      do 200 i = 1, ndis
        agpm = -gpm(i) * sin(rpa)
        dgpm = -gpm(i) * cos(rpa)
*
        write (*, *) 'PM due to GR in RA and Dec = ', agpm,
     +               '  ', dgpm, '  mas/y'
*
        write (11, '(4F10.3)') zero, zero, agpm, dgpm
        write (11, *)
*
C        print *, 'writing galrot.dat'
C        pause

        dagpm = agpm / nseg
        ddgpm = dgpm / nseg
*
        call solmot(ras, dec, rd(i), spm, aspm, dspm)
*
        write (*, *) 'Solar motion effect in RA and Dec = ', aspm,
     +               '  ', dspm, '  mas/y'
*
        write (12, '(4F10.3)') zero, zero, aspm, dspm
        write (12, *)
*
C        print *, 'writing solmot.dat'
C       pause
*
        acpm = agpm + aspm
        dcpm = dgpm + dspm
*
        write (14, '(4F10.3)') zero, zero, acpm, dcpm
        write (14, *)
*
        dacpm = acpm / nseg
        ddcpm = dcpm / nseg
*
        apmmt = 0.0d0
        dpmmt = 0.0d0
*
*       do 100 j = 1, 2 * nseg + 1
* Calculate the apparent motion for 20 (rather than 2) years
         do 100 j = 1, 20 * nseg + 1

          slong = dsl * (j - 1)
          apmmt = dacpm * (j - 1)
          dpmmt = ddcpm * (j - 1)
*
          call parallax(ras, dec, rd(i), slong, cdra, ddec)
*
          if (j .eq. 1) then
            pdra = cdra
            pdec = ddec
          endif
*
          rdra = cdra - pdra
          rdec = ddec - pdec
          write (13, '(2F10.3)') rdra, rdec
          write (15, '(2F10.3)') (apmmt + rdra), dpmmt + rdec
 100    continue
*
 200  continue
*
      close (11)
      close (12)
      close (13)
      close (14)
      close (15)
*
      if (dec .lt. 0.0d0) then
        asign = '-'
      else
        asign = '+'
      endif
*
      irh = rh
      irm = rm
      idd = dd
      idm = dm
      write (arh, '(I3)') 100 + irh
      write (arm, '(I3)') 100 + irm
      write (add, '(I3)') 100 + idd
      write (adm, '(I3)') 100 + idm
*
      write (16, 1000) arh(2 : 3), arm(2 : 3), asign,
     +       add(2 : 3), adm(2 : 3), rd(1),
     +       arh(2 : 3), arm(2 : 3), asign,
     +       add(2 : 3), adm(2 : 3)
 1000 format (
     + 'set title "Trajectory of an Object at ', 2A2, A1, 2A2,
     + ' and ', F5.2, 'kpc away in Flat Rotation Model' /
     + 'set size 1.5, 0.725' /
     + 'set xrange [] reverse' /
     + 'set xlabel "Displacement in RA (mas)"'/
     + 'set ylabel "Displacement in Dec (mas)"'/
     + 'set terminal postscript portrait color' /
     + 'set output "frmodel', 2A2, A1, 2A2,
     + '.ps"' /
     + 'plot \\'/
     + '"galrot.dat" title "Galact. Rot./year" with vector , \\'/
     + '"solmot.dat" title "Solar Motion/year" with vector , \\'/
     + '"galsol.dat" title "Sum of Above     " with vector , \\'/
     + '"paralx.dat" title "Annual Parallax  " with linespoints, \\'/
     + '"combmt.dat" title "Combined Motion  " with linespoints ')
*
      close (16)
*
C      write (*, *)
C      write (*, *) 'Do you have "gnuplot" (y/n)?'
C      read (*, *) ans
*
C      if (ans .eq. 'y' .or. ans .eq. 'Y') then
C        call system('gnuplot frmodel.gp')
*
C        write (*, *) 'Do you have "gv" (y/n)?'
C        read (*, *) ans
*
C        if (ans .eq. 'y' .or. ans .eq. 'Y') then
C          call system('gv frmodel' //  arh(2 : 3) // arm(2 : 3) //
C     +                 asign // add(2 : 3) // adm(2 : 3) // '.ps &')
C        else
          write (*, *) 'PostScript file is stored in frmodel' //
     +                 arh(2 : 3) // arm(2 : 3) //
     +                 asign // add(2 : 3) // adm(2 : 3) // '.ps'
C        endif
*
C      else
C        write (*, *) 'gnuplot script file is stored in frmodel.gp'
C      endif
*

      stop
      end


PROGRAM ufld2gp

  implicit none
  integer,parameter :: u1=1, u2=10, u3=11
  integer,parameter :: maxloop=1000000
  integer :: loop,ik,k,n,i,j,s,nk,nk0,nb,ns,ne,kmax
  character(5) :: cbuf
  character(128) :: cbuf_long
  real(8),parameter :: aB=0.529177d0, HT=27.2116d0
  real(8),allocatable :: kxyz_pc(:,:),kxyz_sc(:,:)
  real(8),allocatable :: esp(:,:,:), weight(:,:,:)
  real(8) :: emax,emin,e_mergin,eta,de,pi,f(2),e,x,dummy(4)

! ---

  ne = 500

  eta = 0.10d0/27.2116d0

  pi = acos(-1.0d0)

! ---

  write(*,*) "eta(eV), ne="
  read(*,*) eta, ne
  eta = eta/HT

! ---

  open(u1,file="band_ufld",status="old")

  ns=0
  nb=0
  nk=0
  kmax=0
  do loop=1,maxloop
     read(u1,*,END=1) cbuf,k
     if ( cbuf == "iktrj" ) then
        kmax=max(k,kmax)
        nk=nk+1
        nb=0
     else
        nb=nb+1
     end if
  end do
1 continue

  rewind u1
  read(u1,*)
  read(u1,'(a)') cbuf_long
  read(cbuf_long,*,END=2) i,j,dummy
  ns=2
2 continue
  if ( ns == 0 ) ns=1

  write(*,*) "ns, nk, nb=",ns,nk,nb
  write(*,*) "kmax=",kmax

  nk0=nk
  nk=kmax

! ---

  allocate( kxyz_pc(3,0:nk)  ) ; kxyz_pc=0.0d0
  allocate( kxyz_sc(3,nk)    ) ; kxyz_sc=0.0d0
  allocate( esp(nb,nk,ns)    ) ; esp=0.0d0
  allocate( weight(nb,nk,ns) ) ; weight=0.0d0

! ---

  rewind u1

  do ik=1,nk0

     read(u1,*) cbuf,k,kxyz_pc(1:3,k),kxyz_sc(1:3,k)

     do n=1,nb

        read(u1,*) i,j,(esp(n,k,s),weight(n,k,s),s=1,ns)

     end do

  end do

! ---

  emin = minval( esp )
  emax = maxval( esp )

  write(*,*) "emin, emax=",emin,emax

  e_mergin = (emax-emin)*0.1d0

  emax = emax + e_mergin
  emin = emin - e_mergin

  write(*,*) "emin, emax, e_mergin=",emin,emax,e_mergin

  de = (emax-emin)/ne

  write(*,*) "ne, de=",ne,de

  write(*,*) "eta=",eta

! ---

  rewind u2
  rewind u3

  kxyz_pc(:,0) = kxyz_pc(:,1)
  x=0.0d0

  do k=1,nk

     x = x + sqrt( sum( (kxyz_pc(:,k)-kxyz_pc(:,k-1))**2 ) )/aB

     do i=1,ne

        e = emin + (i-1)*de

        do s=1,ns
           f(s)=0.0d0
           do n=1,nb
              f(s) = f(s) + eta/( (e-esp(n,k,s))**2 + eta**2 )*weight(n,k,s)
           end do
           f(s)=f(s)/pi
        end do

        write(u2,'(1x,4f20.15)') x,e*HT,(f(s),s=1,ns)
        write(u3,'(1x,4f20.15)') x,e*HT,(log(f(s)),s=1,ns)

     end do ! i

     write(u2,*)
     write(u3,*)

  end do ! k

! ---

  deallocate( weight  )
  deallocate( esp     )
  deallocate( kxyz_sc )
  deallocate( kxyz_pc )

  close(u1)

END PROGRAM ufld2gp


module Plik_CMBonly

  implicit none
  private
  integer, parameter :: campc = KIND(1.d0)

  character(LEN=500),public :: data_dir
  character(LEN=*), parameter, public :: plik_like='Plik_v18_cmbonly_like'

  !Possible combinations: TT only, TE only, EE only, TT+TE+EE
  logical :: use_tt  = .true.
  logical :: use_ee  = .false.
  logical :: use_te  = .false.

  integer, public :: tt_lmax  = 3000
  integer, parameter,public :: plmax  = 2508
  integer, parameter,public :: plmin  = 30
  integer, parameter,public :: nbin   = 613 ! total bins
  integer, public, parameter :: nspectt = 4
  integer, public, parameter :: nspecte = 6
  integer, public, parameter :: nspecee = 6
  integer, public :: nbintt, nbinte, nbinee

  !-------------------------------------------------------
  real(campc), parameter :: PI    = 3.14159265358979323846264d0
  real(campc), dimension(:), allocatable ::  bval,X_data,X_sig,diff_vec
  real(campc), dimension(:,:), allocatable :: covmat, fisher
  !  real(campc), dimension(:), allocatable :: blmin,blmax,bin_w changed to accomodate gfortran
    integer, dimension(:), allocatable :: blmin, blmax
    real(campc) :: campcbuf
    real(campc), dimension(:), allocatable :: bin_w
  real(campc), dimension(:), allocatable :: bl,bm

  public like_init_cmbonly, calc_like_cmbonly,use_tt,use_te,use_ee
  contains

  ! ===========================================================================
  subroutine like_init_cmbonly

  integer  :: i,j,lun,il,info,dum,k,bin_no
  character(LEN=1024) :: like_file, cov_file, blmin_file, blmax_file, binw_file
  logical  :: good

  print *, 'Initializing Planck likelihood, version '//plik_like

  nbintt = 215 !30-2508
  nbinte = 199 !30-1996
  nbinee = 199 !30-1996

  like_file = trim(data_dir)//'cl_cmb_plik_v18.dat'
  cov_file  = trim(data_dir)//'c_matrix_plik_v18.dat'
  blmin_file = trim(data_dir)//'blmin.dat'
  blmax_file = trim(data_dir)//'blmax.dat'
  binw_file = trim(data_dir)//'bweight.dat'

  allocate(bval(nbin),X_data(nbin),X_sig(nbin))
  allocate(covmat(nbin,nbin))

  inquire(file=like_file, exist=good)
  if(.not.good)then
     write(*,*) 'file not found', trim(like_file), trim(data_dir)
     stop
  endif

  call get_free_lun(lun)
  open(unit=lun,file=like_file,form='formatted',status='unknown',action='read')
  do i=1,nbin !read Planck
     read(lun,*) bval(i),X_data(i),X_sig(i)
  enddo
  close(lun)

  inquire(file=cov_file, exist=good)
  if(.not.good)then
     write(*,*) 'file not found', trim(cov_file), trim(data_dir)
     stop
  endif
  call get_free_lun(lun)
  open(unit=lun,file=cov_file,form='unformatted',status='old')
      read(lun) covmat
  close(lun)
  do i=1,nbin
     do j=i+1,nbin
        covmat(j,i)=covmat(i,j) !covmat is now full matrix
     enddo
  enddo

  !Select covmat
  !Only TT
  if((use_tt .eqv. .true.) .and. (use_te .eqv. .false.) .and. (use_ee .eqv. .false.)) then
       bin_no=nbintt
       allocate(fisher(bin_no,bin_no))
       fisher(:,:)=covmat(1:bin_no,1:bin_no)
  !Only TE
  else if((use_tt .eqv. .false.) .and. (use_te .eqv. .true.) .and. (use_ee .eqv. .false.)) then
       bin_no=nbinte
       allocate(fisher(bin_no,bin_no))
       fisher(:,:)=covmat(nbintt+1:nbintt+bin_no,nbintt+1:nbintt+bin_no)
  !Only EE
  else if((use_tt .eqv. .false.) .and. (use_te .eqv. .false.) .and. (use_ee .eqv. .true.)) then
       bin_no=nbinee
       allocate(fisher(bin_no,bin_no))
       fisher(:,:)=covmat(nbintt+nbinte+1:nbintt+nbinte+bin_no,nbintt+nbinte+1:nbintt+nbinte+bin_no)
  !All
  else if ((use_tt .eqv. .true.) .and. (use_te .eqv. .true.) .and. (use_ee .eqv. .true.)) then
       bin_no=nbin
       allocate(fisher(nbin,nbin))
       fisher(:,:)=covmat(:,:)
  else
     write(*,*) 'Fail: no possible options chosen'
  endif

  !Invert covmat
  call dpotrf('U',bin_no,fisher,bin_no,info)
  if(info.ne.0)then
     print*, ' info in dpotrf =', info
     stop
  endif
  call dpotri('U',bin_no,fisher,bin_no,info)
  if(info.ne.0)then
     print*, ' info in dpotri =', info
     stop
  endif
  do i=1,bin_no
     do j=i,bin_no
        fisher(j,i)=fisher(i,j)
     enddo
  enddo

  allocate(blmin(nbintt),blmax(nbintt),bin_w(0:plmax),bl(0:plmax),bm(nbintt))

  call get_free_lun(lun)
  open(unit=lun,file=blmin_file,form='formatted',status='old')
  do i=1,nbintt
  !       read(lun,*) blmin(i)
    read(lun,*) campcbuf
    blmin(i) = int(campcbuf)
  end do
  close(lun)

  call get_free_lun(lun)
  open(unit=lun,file=blmax_file,form='formatted',status='old')
  do i=1,nbintt
!       read(lun,*) blmax(i)
    read(lun,*) campcbuf
    blmax(i) = int(campcbuf)
  end do
  close(lun)

  call get_free_lun(lun)
  open(unit=lun,file=binw_file,form='formatted',status='old')
  do i=0,plmax
       read(lun,*) bin_w(i)
  end do
  close(lun)

!!  do i=0,plmax
!!     bl(i) = i*(i+1)/2./PI
!!  end do
!!
!!  do i=1,nbintt !binned ell
!!     bm(i) = sum(bl(blmin(i)+plmin:blmax(i)+plmin)*bin_w(blmin(i):blmax(i)))
!!  end do

  end subroutine like_init_cmbonly

  ! ===========================================================================
  subroutine calc_like_cmbonly(plike,cell_tt,cell_te,cell_ee,calPlanck)

  real(campc), dimension(2:) :: cell_tt,cell_ee,cell_te
  real(campc) :: cl_tt(nbintt),cl_te(nbinte),cl_ee(nbinee)
  real(campc) :: plike, calPlanck
  integer :: bin_no,lun,il,i,j,info
  real(campc), allocatable, save ::  Y(:), X_model(:)
  real(campc), allocatable :: ptemp(:)

  if (.not. allocated(Y)) then
     allocate(X_model(nbin),Y(nbin))
     X_model = 0
     Y = 0
  end if

  do i=2,tt_lmax
     cell_tt(i)=cell_tt(i)/real(i)/real(i+1.d0)*2.d0*PI
     cell_te(i)=cell_te(i)/real(i)/real(i+1.d0)*2.d0*PI
     cell_ee(i)=cell_ee(i)/real(i)/real(i+1.d0)*2.d0*PI
  end do

  do i=1,nbintt
     cl_tt(i) = sum(cell_tt(blmin(i)+plmin:blmax(i)+plmin)*bin_w(blmin(i):blmax(i)))
  end do
  do i=1,nbinte
     cl_te(i) = sum(cell_te(blmin(i)+plmin:blmax(i)+plmin)*bin_w(blmin(i):blmax(i)))
  end do
  do i=1,nbinee
     cl_ee(i) = sum(cell_ee(blmin(i)+plmin:blmax(i)+plmin)*bin_w(blmin(i):blmax(i)))
  end do

  !!cl_tt(1:nbintt)=cl_tt(1:nbintt)/bm(1:nbintt)
  !!cl_te(1:nbinte)=cl_te(1:nbinte)/bm(1:nbinte)
  !!cl_ee(1:nbinee)=cl_ee(1:nbinee)/bm(1:nbinee)

  X_model(1:nbintt) = cl_tt(1:nbintt)/calPlanck**2.d0 !TT
  X_model(nbintt+1:nbintt+nbinte) = cl_te(1:nbinte)/calPlanck**2.d0 !TE
  X_model(nbintt+nbinte+1:nbintt+nbinte+nbinee) = cl_ee(1:nbinee)/calPlanck**2.d0 !EE

!Start basic chisq
  Y = X_data - X_model

  !Select data
  !Only TT
  if((use_tt .eqv. .true.) .and. (use_te .eqv. .false.) .and. (use_ee .eqv. .false.)) then
       bin_no=nbintt
       allocate(diff_vec(bin_no),ptemp(bin_no))
       diff_vec(:)=Y(1:bin_no)
  !Only TE
  else if((use_tt .eqv. .false.) .and. (use_te .eqv. .true.) .and. (use_ee .eqv. .false.)) then
       bin_no=nbinte
       allocate(diff_vec(bin_no),ptemp(bin_no))
       diff_vec(:)=Y(nbintt+1:nbintt+bin_no)
  !Only EE
  else if((use_tt .eqv. .false.) .and. (use_te .eqv. .false.) .and. (use_ee .eqv. .true.)) then
       bin_no=nbinee
       allocate(diff_vec(bin_no),ptemp(bin_no))
       diff_vec(:)=Y(nbintt+nbinte+1:nbintt+nbinte+bin_no)
  !All
  else if ((use_tt .eqv. .true.) .and. (use_te .eqv. .true.) .and. (use_ee .eqv. .true.)) then
       bin_no=nbin
       allocate(diff_vec(nbin),ptemp(nbin))
       diff_vec(:)=Y(:)
  else
     write(*,*) 'Fail: no possible options chosen'
  endif

  ptemp=matmul(fisher,diff_vec)
  plike=sum(ptemp*diff_vec)
  plike = plike/2.d0

  deallocate(X_model,Y)
  deallocate(diff_vec,ptemp)

 end subroutine calc_like_cmbonly

 subroutine get_free_lun(lun)

 implicit none
 integer, intent(out) :: lun
 integer, save :: last_lun = 19
 logical :: used
 lun = last_lun
 do
   inquire( unit=lun, opened=used )
   if ( .not. used ) exit
       lun = lun + 1
 end do

 last_lun = lun
 end subroutine get_free_lun

end module Plik_CMBonly


!=============================================================================!
        subroutine csolve1p( nsys, np, nblk, mat, rhs, per, per2, mult, fact)
!=============================================================================!
!
!  Solves a block tridiagonal system of equations without pivoting.
!  Vectorized over the second index.
!
!  This routine solves a PERIODIC block tridiagonal system.
!
!  WARNING: Since pivoting is not done, this algorithm could fail
!
!  input:
!    nsys       : number of systems to vectorize over
!    np         : number of rows in the systems including periodic node
!    nblk       : dimension of the blocks in each row
!
!  inout:
!    mat        : the block tridiagonal matrix to be solved
!    rhs        : the right hand side
!=============================================================================!
        implicit none

        integer, intent(in) :: np, nblk, nsys
        complex, intent(inout) :: mat(3,nblk,nblk,nsys,np), rhs(nblk,nsys,np)
        complex, intent(inout) :: per(nblk,nblk,nsys,np)
        complex, intent(inout) :: per2(2,nblk,nblk,nsys)
        complex, intent(inout) :: mult(nsys), fact(nsys)

!.... useful constants

        real, parameter :: zero = 0.0, one = 1.0

!.... local variables

        integer :: nc, nr, i, l, m, n, p, q, r, iv
!=============================================================================!

c!.... don't solve for the redundant nodes

        n = np - 1

        !$omp parallel do private(nc,i,l,m,p,q,r,iv)
        do iv = 1, nsys

!.... setup the periodic fillin vector

        per(:,1:nblk,iv,1)  = mat(1,:,1:nblk,iv,1)
        per2(1,:,1:nblk,iv) = mat(3,:,1:nblk,iv,n)

!=============================================================================!
!                     F O R W A R D   E L I M I N A T I O N
!=============================================================================!
        do i = 1, n - 3

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              mult(iv) = -mat(2,l,nc,iv,i) / mat(2,nc,nc,iv,i)
              do q = nc + 1, nblk
                mat(2,l,q,iv,i) = mat(2,l,q,iv,i) + mult(iv) * mat(2,nc,q,iv,i)
              end do
              do q = 1, nblk
                mat(3,l,q,iv,i) = mat(3,l,q,iv,i) + mult(iv) * mat(3,nc,q,iv,i)
                per(l,q,iv,i) = per(l,q,iv,i) + mult(iv) * per(nc,q,iv,i)
              end do
              rhs(l,iv,i) = rhs(l,iv,i) + mult(iv) * rhs(nc,iv,i)
            end do

          end do        ! end of loop on nc

!.... for all columns

          nc = 1

          p = i + 1

          fact(iv) = one / mat(2,nc,nc,iv,i)
          do m = 1, nblk
            mult(iv) = -mat(1,m,nc,iv,p) * fact(iv)
            do q = nc + 1, nblk
              mat(1,m,q,iv,p) = mat(1,m,q,iv,p) + mult(iv) * mat(2,nc,q,iv,i)
            end do
            do q = 1, nblk
              mat(2,m,q,iv,p) = mat(2,m,q,iv,p) + mult(iv) * mat(3,nc,q,iv,i)
              per(m,q,iv,p) = mult(iv) * per(nc,q,iv,i)
            end do
            rhs(m,iv,p) = rhs(m,iv,p) + mult(iv) * rhs(nc,iv,i)

!.... the periodic stuff on the last row

            mult(iv) = -per2(1,m,nc,iv) * fact(iv)
            do q = nc + 1, nblk
              per2(1,m,q,iv) = per2(1,m,q,iv) + mult(iv) * mat(2,nc,q,iv,i)
            end do
            do q = 1, nblk
              per2(2,m,q,iv) = mult(iv) * mat(3,nc,q,iv,i)
              mat(2,m,q,iv,n) = mat(2,m,q,iv,n) + mult(iv) * per(nc,q,iv,i)
            end do
            rhs(m,iv,n) = rhs(m,iv,n) + mult(iv) * rhs(nc,iv,i)
          end do

          do nc = 2, nblk

            fact(iv) = one / mat(2,nc,nc,iv,i)
            do m = 1, nblk
              mult(iv) = -mat(1,m,nc,iv,p) * fact(iv)
              do q = nc + 1, nblk
                mat(1,m,q,iv,p) = mat(1,m,q,iv,p) + mult(iv) * mat(2,nc,q,iv,i)
              end do
              do q = 1, nblk
                mat(2,m,q,iv,p) = mat(2,m,q,iv,p) + mult(iv) * mat(3,nc,q,iv,i)
                per(m,q,iv,p) = per(m,q,iv,p) + mult(iv) * per(nc,q,iv,i)
              end do
              rhs(m,iv,p) = rhs(m,iv,p) + mult(iv) * rhs(nc,iv,i)

!.... the periodic stuff on the last row

              mult(iv) = -per2(1,m,nc,iv) * fact(iv)
              do q = nc + 1, nblk
                per2(1,m,q,iv) = per2(1,m,q,iv) + mult(iv) * mat(2,nc,q,iv,i)
              end do
              do q = 1, nblk
                per2(2,m,q,iv) = per2(2,m,q,iv) + mult(iv) * mat(3,nc,q,iv,i)
                mat(2,m,q,iv,n) = mat(2,m,q,iv,n) + mult(iv) * per(nc,q,iv,i)
              end do
              rhs(m,iv,n) = rhs(m,iv,n) + mult(iv) * rhs(nc,iv,i)
            end do

          end do        ! end of loop on nc

          per2(1,:,:,iv) = per2(2,:,:,iv)

        end do          ! end of loop on i

!.... do the third to the last row

        i = n - 2

!.... do the first four columns

        do nc = 1, nblk - 1

          do m = nc, nblk - 1
            l = m + 1
            mult(iv) = -mat(2,l,nc,iv,i) / mat(2,nc,nc,iv,i)
            do q = nc + 1, nblk
              mat(2,l,q,iv,i) = mat(2,l,q,iv,i) + mult(iv) * mat(2,nc,q,iv,i)
            end do
            do q = 1, nblk
              mat(3,l,q,iv,i) = mat(3,l,q,iv,i) + mult(iv) * mat(3,nc,q,iv,i)
              per(l,q,iv,i) = per(l,q,iv,i) + mult(iv) * per(nc,q,iv,i)
            end do
            rhs(l,iv,i) = rhs(l,iv,i) + mult(iv) * rhs(nc,iv,i)
          end do

        end do  ! end of loop on nc

!.... for all columns

        do nc = 1, nblk

          p  = i + 1

          fact(iv) = one / mat(2,nc,nc,iv,i)
          do m = 1, nblk
            mult(iv) = -mat(1,m,nc,iv,p) * fact(iv)
            do q = nc + 1, nblk
              mat(1,m,q,iv,p) = mat(1,m,q,iv,p) + mult(iv) * mat(2,nc,q,iv,i)
            end do
            do q = 1, nblk
              mat(2,m,q,iv,p) = mat(2,m,q,iv,p) + mult(iv) * mat(3,nc,q,iv,i)
              mat(3,m,q,iv,p) = mat(3,m,q,iv,p) + mult(iv) * per(nc,q,iv,i)
            end do
            rhs(m,iv,p) = rhs(m,iv,p) + mult(iv) * rhs(nc,iv,i)

!.... the periodic stuff on the last row

            mult(iv) = -per2(1,m,nc,iv) * fact(iv)
            do q = nc + 1, nblk
              per2(1,m,q,iv) = per2(1,m,q,iv) + mult(iv) * mat(2,nc,q,iv,i)
            end do
            do q = 1, nblk
              mat(1,m,q,iv,n) = mat(1,m,q,iv,n) + mult(iv) * mat(3,nc,q,iv,i)
              mat(2,m,q,iv,n) = mat(2,m,q,iv,n) + mult(iv) * per(nc,q,iv,i)
            end do
            rhs(m,iv,n) = rhs(m,iv,n) + mult(iv) * rhs(nc,iv,i)
          end do

        end do  ! end of loop on nc

!.... do the second to the last row

        i = n - 1

!.... do the first four columns

          do nc = 1, nblk - 1

            do m = nc, nblk - 1
              l = m + 1
              mult(iv) = -mat(2,l,nc,iv,i) / mat(2,nc,nc,iv,i)
              do q = nc + 1, nblk
                mat(2,l,q,iv,i) = mat(2,l,q,iv,i) + mult(iv) * mat(2,nc,q,iv,i)
              end do
              do q = 1, nblk
                mat(3,l,q,iv,i) = mat(3,l,q,iv,i) + mult(iv) * mat(3,nc,q,iv,i)
              end do
              rhs(l,iv,i) = rhs(l,iv,i) + mult(iv) * rhs(nc,iv,i)
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p  = i + 1

            fact(iv) = one / mat(2,nc,nc,iv,i)
            do m = 1, nblk
              mult(iv) = -mat(1,m,nc,iv,p) * fact(iv)
              do q = nc + 1, nblk
                mat(1,m,q,iv,p) = mat(1,m,q,iv,p) + mult(iv) * mat(2,nc,q,iv,i)
              end do
              do q = 1, nblk
                mat(2,m,q,iv,p) = mat(2,m,q,iv,p) + mult(iv) * mat(3,nc,q,iv,i)
              end do
              rhs(m,iv,p) = rhs(m,iv,p) + mult(iv) * rhs(nc,iv,i)
            end do

          end do        ! end of loop on nc

!.... do the last row

        i = n

        do nc = 1, nblk - 1

          do m = nc, nblk - 1
            l = m + 1
            mult(iv) = -mat(2,l,nc,iv,i) / mat(2,nc,nc,iv,i)
            do q = nc + 1, nblk
              mat(2,l,q,iv,i) = mat(2,l,q,iv,i) + mult(iv) * mat(2,nc,q,iv,i)
            end do
            rhs(l,iv,i) = rhs(l,iv,i) + mult(iv) * rhs(nc,iv,i)
          end do

        end do  ! end of loop on nc

!=============================================================================!
!                   B A C K W A R D   S U B S T I T U T I O N
!=============================================================================!

!.... do the last row first

        i = n

        do m = nblk, 1, -1
          do q = m+1, nblk
            rhs(m,iv,i) = rhs(m,iv,i) - rhs(q,iv,i) * mat(2,m,q,iv,i)
          end do
          rhs(m,iv,i) = rhs(m,iv,i) / mat(2,m,m,iv,i)
        end do

!.... do the second to the last row

        i = n - 1

        p = i + 1

        do m = nblk, 1, -1
          do q = m+1, nblk
            rhs(m,iv,i) = rhs(m,iv,i) - rhs(q,iv,i) * mat(2,m,q,iv,i)
          end do
          do q= 1, nblk
            rhs(m,iv,i) = rhs(m,iv,i) - rhs(q,iv,p) * mat(3,m,q,iv,i)
          end do
          rhs(m,iv,i) = rhs(m,iv,i) / mat(2,m,m,iv,i)
        end do

!.... now do the rest of the rows in reverse order

        do i = n - 2, 1, -1

          p = i + 1

          do m = nblk, 1, -1
            do q = m+1, nblk
              rhs(m,iv,i) = rhs(m,iv,i) - rhs(q,iv,i) * mat(2,m,q,iv,i)
            end do
            do q = 1, nblk
              rhs(m,iv,i) = rhs(m,iv,i) - rhs(q,iv,p) * mat(3,m,q,iv,i)
              rhs(m,iv,i) = rhs(m,iv,i) - rhs(q,iv,n) * per(m,q,iv,i)
            end do
            rhs(m,iv,i) = rhs(m,iv,i) / mat(2,m,m,iv,i)
          end do

        end do

!.... account for periodicity

        rhs(1,iv,np) = rhs(1,iv,1)
        rhs(2,iv,np) = rhs(2,iv,1)
        rhs(3,iv,np) = rhs(3,iv,1)
        rhs(4,iv,np) = rhs(4,iv,1)
        rhs(5,iv,np) = rhs(5,iv,1)

        end do

        return
        end


!      HotCross Distribution - Version 1.0

       subroutine density

!      tag: subroutine ../vents2/lavelle/NewCross/density_3d.f - version 6.4.97

!
! ----- perturbation density - rho prime
!
       use tracer_module
       use grid_module

       include 'array_size.inc'

       real rho_rho, xisw
       integer i,j,k,isw

       isw = 0
       xisw = real (isw)
!$OMP PARALLEL DO

       do  k = 1, nz
       do  j = 1, ny
       do  i = 1, nx

          rhop(i,j,k) = rho_rho(s(i,j,k), t(i,j,k), 0.) - rho_bkg(k)
          rrho(i,j,k)=rhop(i,j,k)+rho_bkg(k)

       enddo;enddo;enddo

!$OMP END PARALLEL DO

       do k = 1, nz
       do j = 1, ny

        i = 0
        rhop(i,j,k) = rho_rho(s(i,j,k),t(i,j,k),0.) - rho_bkg(k)
        rrho(i,j,k) = rhop(i,j,k) + rho_bkg(k)
        i = nx+1
        rhop(i,j,k) = rho_rho(s(i,j,k),t(i,j,k),0.) - rho_bkg(k)
        rrho(i,j,k) = rhop(i,j,k) + rho_bkg(k)

       enddo;enddo

       do k = 1, nz
       do i = 1, nx

        j = 0
        rhop(i,j,k) = rho_rho(s(i,j,k),t(i,j,k),0.) - rho_bkg(k)
        rrho(i,j,k) = rhop(i,j,k) + rho_bkg(k)
        j = ny+1
        rhop(i,j,k) = rho_rho(s(i,j,k),t(i,j,k),0.) - rho_bkg(k)
        rrho(i,j,k) = rhop(i,j,k) + rho_bkg(k)

       enddo;enddo

       do  j = 1, ny
       do  i = 1, nx

        k = 0
        rhop(i,j,k) = rho_rho(s(i,j,k),t(i,j,k),0.) - rho_bkg(k)
        rrho(i,j,k) = rhop(i,j,k) + rho_bkg(k)
        k = nz+1
        rhop(i,j,k) = rho_rho(s(i,j,k),t(i,j,k),0.) - rho_bkg(k)
        rrho(i,j,k) = rhop(i,j,k) + rho_bkg(k)

       enddo;enddo

!       call view_3d(rhop,0,nx+1,0,ny+1,0,nz+1); write(6,*) 'rhop';stop

       end subroutine density

! --------------------------------------------------------------------
! ------------------ Equation of state of seawater -------------------
! --------------------------------------------------------------------

       real function rho_rho(s,t,p)

! ---  seawater density for 0<T<40 C and 0<S<42 0/00 and 0<p<1000 bars
! ---  from Gill, pp. 599-600
! ---  JW Lavelle, 1986,  checked against UNESCO and PMEL
! ---  equal to rho, named changed to rho_rho to free variable in code

       real  kw, kst0, kstp
       real    p, s, t
       real  rho0, rho1

!       if( (t.gt.40).or.(s.gt.42).or.(t.lt.0.0).or.(s.lt.0.0).or.          !dummed to speed calculation
!     1      (p.lt.0.0).or.(p.gt.1000.0) ) then
!             write(6,*) 'density parameters out of range'
!             stop
!       endif

       rho0 = 999.842594d0 + 6.793952d-2*t - 9.095290d-3*t*t
     1  +1.001685d-4*t**3 - 1.120083d-6*t**4 + 6.536332d-9*t**5

       rho1 = rho0 + s*(0.824493d0 - 4.0899d-3*t + 7.6438d-5*t*t
     1  - 8.2467d-7*t**3 + 5.3875d-9*t**4) + s**1.5*( - 5.72466d-3
     2  + 1.0227d-4*t - 1.6546d-6*t*t) + 4.8314d-4*s*s

       rho_rho = rho1

! if (p.ewq. 0) skip the following

!       kw = 19652.21d0 + 148.4206d0*t - 2.327105d0*t*t
!     1  + 1.360477d-2*t**3 - 5.155288d-5*t**4

!       kst0 = kw + s*( 54.6746d0 - 0.603459d0*t + 1.09987d-2*t*t
!     1  - 6.1670d-5*t**3) + s**1.5*( 7.944d-2 + 1.6483d-2*t
!     2  - 5.3009d-4*t*t)

!          kstp = kst0 + p*( 3.239908d0 + 1.43713d-3*t + 1.16092d-4*t*t
!     1    - 5.77905d-7*t**3) + p*s*( 2.2838d-3 - 1.0981d-5*t
!     2    - 1.6078d-6*t*t) + 1.91075d-4*p*s**1.5 + p*p*( 8.50935d-5
!     3    - 6.12293d-6*t + 5.2787d-8*t*t) + p*p*s*( - 9.9348d-7
!     4    + 2.0816d-8*t + 9.1697d-10*t*t)

!       rho_rho = rho1 / ( 1.0d0 - p / kstp )

       return

       end


program alloc
implicit none
integer,allocatable,dimension(:) :: vector
integer :: element,i
print*, "enter the number of element in the vector"
read*,element
allocate (vector(element))
print*, "your vector is of size ",'element'
	do i =1,element
		read*, vector(i)
	end do
	do i =1,element
		print*, vector(i)
	end do
deallocate (vector)

end program alloc


      subroutine rand(seed,n,vector)
c---------------------------------------------------------------------
c
c This random number generator generates random numbers in ]0,1[
c Note that if the seed value is zero on the first call, a default
c value of 7931 will be used  in a linear congruential generator to
c generate 55 odd integers for the array 'itab()'. These values are
c preserved by a common statement, so that they may be used in sub-
c sequent calls by setting the seed to zero.If the value of 'seed'
c is greater than zero in a call to the subroutine, then the array
c 'itab' will be initialized and a new seed value will be returned
c by the subroutine. Best results are obtained by making the initial
c call with a seed of your choice and then setting the seed to '0'
c for all subsequent calls.
c
c---------------------------------------------------------------------
      dimension vector(*)
      common /unusual/itab(55),n1,n2,nseed
      integer rn1,seed
c
c Test to see if 55 odd integers must be generated.
c
      if((seed.gt.0).or.(nseed.lt.1)) then
            nseed = seed
            if(seed.le.0) nseed  = 7931
            do i=1,55
                  rn1=mod(nseed*9069,32768)
                  if(mod(rn1,2).eq.0) rn1 = rn1-1
                  itab(i) = rn1
                  nseed = rn1
            end do
            n1 = 0
            n2 = 24
      endif
c
c Generate "n" random components for the vector "VECTOR"
c
      do i=1,n
            itab(55-n1) = mod(itab(55-n2)*itab(55-n1),32768)
            vector(i)   = abs(float(itab(55-n1))/float(32768))
            n1 = mod(n1+1,55)
            n2 = mod(n2+1,55)
      end do
      if(seed.gt.0) seed=nseed
c
c Return with the vector of random numbers:
c
      return
      end


subroutine php_relaxVector(a,itask,w_r,w_rmax,r_i1,r_i21)
   !This routine solves an iteration of the physical problem equations
   use MPI
   use typre
   use Mod_PhysicalProblem
   implicit none
   class(PhysicalProblem) :: a
   character(5) :: itask
   real(rp) :: vnor,prod,part_prod,w,w_r,w_rmax
   integer  idime,ndime,inod,npoin,npoinLocal,ierr
   real(rp), intent(in) :: r_i1(:,:),r_i21(:,:)

   w = 0.0_rp

   select case(itask)

   case('AITKE')

      !Calculating Aitken relaxation variables, see kuttler2008 for notations

      call a%Mesh%GetNpoin(npoin)
      call a%Mesh%GetNpoinLocal(npoinLocal)
      call a%Mesh%GetNdime(ndime)

      !So that Aitken relaxes
      !r_i+2(:,:)  = x_guess(i+2,:)   - x_(i+1,:)

      !r_i+1(:,:)  = x_guess(i+1,:)   - x_(i,:)

      !r_i21(:,:) = r_i+2     - r_i+1

      part_prod = 0.0_rp
      prod = 0.0_rp
      do inod = 1, npoin
          do idime =1,ndime
              part_prod = part_prod + r_i1(idime,inod)*r_i21(idime,inod)
          end do
      end do

      call MPI_REDUCE(part_prod,prod,1,MPI_REAL8,MPI_SUM,a%MPIroot,a%MPIcomm,ierr)

      call vecnorGenericMPI(r_i21,npoinLocal,ndime,vnor,2,a%MPIcomm,a%MPIrank,a%MPIroot,a%MPIsize)

      if (a%MPIrank == a%MPIroot) then

          if(vnor > 0.0_rp) then
              if(a%cpiter .le. a%kfl_initRelax) then !We allow two iters to have residuals
                  w_r = min(w_r,w_rmax)
              else
                  w_r = -w_r*(prod/(vnor**2))
              endif
          endif

      endif

      CALL MPI_BCAST(w_r,1,MPI_REAL8,a%MPIroot,a%MPIcomm,ierr)

   end select

end subroutine php_relaxVector


! this code is used to obtain the ML-DE infomation from cubic(3D) scalar field

       program main
       implicit none
       include "param.h"
       double precision,external::interp

       character(len=50):: R_str,sc
       integer i,j,windex,numends,zx,zy,zz,endfind,ni,nj,i0,j0,k0,kk,c
       integer windowfind,force0,status,meetbound,ii,jj,n1,n2,n3,n,m,Rball
       integer locmax,locmin,numpairs,pairsize,count,R,note(ndimx,ndimy)
       integer endid,backindex,oldmax,oldmin,numpairsm(winnum)
       integer pairing(1000000,3),k1,notem(winnum,1000000)

       double precision subdvx(-1:0,-1:1),subdvy(-1:1,-1:0),reed
       double precision maxxcor,maxycor,maxpsi,minxcor,minycor,minpsi,lenmean,dpsimean,spsimean,sum,len2mean
       double precision jpdf(0:100,0:200),tdiff0,tdiff1,mpdf(0:100),ypdf(0:100),my(0:100)
       double precision jpdf2(0:100,0:200),mpdf2(0:100),ypdf2(0:100),my2(0:100)
       double precision switch,endx,endy,jumpratio,window
       double precision xmax,xmin,ymax,ymin,px,py,x(1000000),y(1000000)
       double precision posx,posy,psimax,epsilon,inter(1000000)
       double precision minxco,minyco,mingrid,len1,deltapsi,len2
       double precision xcorball,ycorball,psiball
       double precision pairmsize(winnum,200000)
       double precision Rall_mpdf(0:100),Rall_my(0:100),Rall_mpdf2(0:100),Rall_my2(0:100)
       double precision Rall_jpdf(0:100,0:100),Rall_jpdf2(0:100,0:100)
       double precision, dimension(:,:),pointer:: points
       double precision, dimension(:,:),pointer:: psi
       double precision, dimension(:),pointer:: dx,dy
       double precision, dimension(:,:),pointer:: coordx,coordy
       double precision, dimension(:,:,:),pointer:: multiscale
       double precision sign(5000000),pairingm(winnum,10000,2,2)
       double precision pairing_tao(1000000)
       character(len = 512)::cFile,ccFile,cccFile

      common/large0/ psi
      common/large1/ pairing
      common/large2/ coordx,coordy
      common/large5/ points

      allocate(psi(ndimx,ndimy),STAT = status)
      allocate(points(5000000,3),STAT = status)
      allocate(coordx(ndimx,ndimy),STAT = status)
      allocate(coordy(ndimx,ndimy),STAT = status)
      allocate(dx(ndimx-1),STAT = status)
      allocate(dy(ndimy-1),STAT = status)

      Rall_my = 0.d0
      Rall_my2 = 0.d0
      Rall_jpdf = 0.d0
      Rall_jpdf2 = 0.d0

	  ! ======= multi-level DE algorithm
      ! a loop for different sample field. Set [do m = 1,1] if only one sample under  consideration.
      do m = 1,1
      write(sc,*) m
      write(*,*) 'we are begining snapshot '//Trim(adjustl(sc))

      ! ======= real coordinate calculation =======
      ! set domain size based on the cases under consideration in 'param.h'
      write(*,*) '======= begin coord calculation ======='
      do j = 1,ndimy
      do i = 1,ndimx
          coordx(i,j) = (i-1)*dimx/(ndimx-1)
          coordy(i,j) = (j-1)*dimy/(ndimy-1)
      enddo
      enddo
      write(*,*) '======= end coord calculation ======='

      ! ======= data input =======
      ! assign the data to be processed to psi, whose dimension needs to adapt to the cases under consideration
      ! if the 2D field, you can assign the data into psi(:,:,1) and set psi(:,:,*) (*.ne.1) as 0 or other constant
      write(*,*) '======= begin reading ======='
      open(20,file='./ocean_summer'//TRim(adjustl(sc))//'.dat')
      do j = 1,ndimy
          do i = 1,ndimx
              read(20,*) psi(i,j)
          enddo
      enddo
      close(20)
      write(*,*) '======= end reading ======='

      numends = 0
      numpairs = 0
      sign = 0.d0
      pairing = 0
      points = 0.d0

      ! ======= read the 0+ level DE info ======
      open(12,file = './numends'//TRim(adjustl(sc))//'.dat')
      read(12,*) numends
      close(12)

      open(12,file = './numpairs'//TRim(adjustl(sc))//'.dat')
      read(12,*) numpairs
      close(12)

      open(12,file = './pairing'//TRim(adjustl(sc))//'.dat')
      do i = 1,numpairs
          read(12,*) pairing(i,1),pairing(i,2),pairing(i,3)
      enddo
      close(12)

      open(12,file = './points'//TRim(adjustl(sc))//'.dat')
      read(12,*)
      do i = 1,numends
          read(12,*) points(i,1),points(i,2),sign(i)
      enddo
      close(12)

      open(12,file = './ave_in_DE'//TRim(adjustl(sc))//'.dat')
      do i = 1,numpairs
          read(12,*) pairing_tao(i)
      enddo
      close(12)

      open(12,file = './note'//TRim(adjustl(sc))//'.dat')
      do i = 1,ndimx
      do j = 1,ndimy
          read(12,*) note(i,j)
      enddo
      enddo
      close(12)

      allocate(multiscale(winnum,numends,3),STAT = status)

      multiscale = 0.d0
      numpairsm = 0.d0
      pairingm = 0.d0
      notem = 0.d0
      dx = dimx/(ndimx-1)
      dy = dimy/(ndimy-1)
      minxco = minval(dx)
      minyco = minval(dy)
      mingrid = min(minxco,minyco)
      epsilon = 1.d-4

      write(*,*)
      write(*,*) '======= begin multi-level calculation ======='
      do windex = 1,winnum    !!!!!!! high level searching process
          write(*,*) 'windex = ',windex
          do i = 1,numends
              if (windex.eq.1) then
                  multiscale(windex,i,1) = points(i,1)
                  multiscale(windex,i,2) = points(i,2)
                  multiscale(windex,i,3) = interp(points(i,1),points(i,2),psi)
              else
                  endid = 0
                  windowfind = 0
                  ! judge the extremal points is max or min
                  if (sign(i).eq.1) then
                      switch = 1.d0
                  else
                      switch = -1.d0
                  endif
                  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
                  ni = multiscale(windex-1,i,1)
                  nj = multiscale(windex-1,i,2)
                  endx = multiscale(windex-1,i,1)-ni
                  endy = multiscale(windex-1,i,2)-nj
                  zx = multiscale(windex-1,i,1)
                  zy = multiscale(windex-1,i,2)
                  if (zx.lt.0.or.zy.lt.0) then
                      multiscale(windex,i,:) = -100000.d0
                      goto 40
                  endif
                  if (switch.gt.0) then
                      psimax = maxval(psi(zx:zx+1,zy:zy+1))+epsilon
                  else
                      psimax = minval(psi(zx:zx+1,zy:zy+1))-epsilon
                  endif

                  Rball = 1 ! ======= searching R initialization =======
                  do while(.true.)
                      window = Rball*mingrid
                      call sphere(ni,nj,endx,endy,psimax,Rball,window,switch,psiball,xcorball,ycorball,meetbound)
60                  if(meetbound.eq.1) then
                          multiscale(windex,i,:) = -100000.d0
                          exit
                      endif
                      ! ======= If no jump, R increases =======
                      if ((meetbound.eq.0).and.(abs(psiball-psimax).le.1.d-5)) then
                          if (Rball.lt.windex) then     ! =======[If now R < windex, R++]=======
                              Rball = Rball + 1
                          else if (Rball.eq.windex) then    ! =======[If now R = windex, windowfind = 1]=======
                              windowfind = 1
                          endif
                      ! ======= If jump, then search along grad_traj =======
                      else if ((meetbound.eq.0).and.(abs(psiball-psimax).gt.1.d-5)) then
                          ! ======= search along gradient trajectory from grid/sphere-surface point
                          ni = xcorball
                          nj = ycorball
                          psimax = psiball
                          posx = xcorball - ni
                          posy = ycorball - nj
                          force0 = 0
                          endfind = 0
                          do while(endfind.eq.0)
                              if((ni.eq.1).or.(ni.eq.ndimx).or.(nj.eq.1).or.(nj.eq.ndimy)) then
                                  meetbound = 1
                                  go to 60
                              endif
                              do i0=-1,0
                              do j0=-1,1
                                  subdvx(i0,j0)= (psi(ni+i0+1,nj+j0)-psi(ni+i0,nj+j0))/(dimx/ndimx)
                              enddo
                              enddo
                              do i0=-1,1
                              do j0=-1,0
                                  subdvy(i0,j0)= (psi(ni+i0,nj+j0+1)-psi(ni+i0,nj+j0))/(dimy/ndimy)
                              enddo
                              enddo
                              call endpoint(posx,posy,endx,endy,switch,subdvx,subdvy,endfind,jumpratio)
                              call tellnew(ni,nj,endx,endy,posx,posy)
                              force0=force0+1
                              if(force0.gt.500) then
                                  endfind=1
                                  exit
                              endif
                          enddo
                          Rball = 1
                      endif
                      if (windowfind.eq.1) then
                          multiscale(windex,i,1) = xcorball
                          multiscale(windex,i,2) = ycorball
                          multiscale(windex,i,3) = psimax
                          exit
                      endif
                  enddo      ! end loop when windowfind = 0
              endif      ! judge if windex = 1
40        enddo    ! loop for extremal points at given level
      enddo  ! loop for multi-level searching process end
      write(*,*) '======= end multi-level calculation ======='
      write(*,*)

      write(*,*) '======= begin multi-level pairing ======='
      do windex = 1,winnum
       numpairsm(windex) = 0
       do k0 = 1,numpairs
           notem(windex,k0) = 0
           if(multiscale(windex,pairing(k0,1),1).gt.0.d0.and.multiscale(windex,pairing(k0,1),2).gt.0.d0.and. &
&           multiscale(windex,pairing(k0,2),1).gt.0.d0.and.multiscale(windex,pairing(k0,2),2).gt.0.d0 ) then
           xmax = multiscale(windex,pairing(k0,1),1)
           ymax = multiscale(windex,pairing(k0,1),2)
           xmin = multiscale(windex,pairing(k0,2),1)
           ymin = multiscale(windex,pairing(k0,2),2)
           if (numpairsm(windex).eq.0) then
               numpairsm(windex) = 1
               pairingm(windex,1,1,1) = xmax
               pairingm(windex,1,1,2) = ymax
               pairingm(windex,1,2,1) = xmin
               pairingm(windex,1,2,2) = ymin
               notem(windex,k0) = 1
              goto 45
           else
               do k1 = 1,numpairsm(windex)
                   if(abs(xmax-pairingm(windex,k1,1,1)).lt.1.d0.and.abs(ymax-pairingm(windex,k1,1,2)).lt.1.d0.and. &
&                   abs(xmin-pairingm(windex,k1,2,1)).lt.1.d0.and.abs(ymin-pairingm(windex,k1,2,2)).lt.1.d0) then
                       notem(windex,k0) = k1
                       goto 45
                   endif
              enddo
           endif
           numpairsm(windex) = numpairsm(windex)+1
           pairingm(windex,numpairsm(windex),1,1) = xmax
           pairingm(windex,numpairsm(windex),1,2) = ymax
           pairingm(windex,numpairsm(windex),2,1) = xmin
           pairingm(windex,numpairsm(windex),2,2) = ymin
           notem(windex,k0) = numpairsm(windex)
           endif
45     enddo
      enddo
      write(*,*) '======= end multi-level pairing ======='

      ! ======= ML-DE boundary extraction =======
      ! here is the example of R = 5\Delta x level extraction
!      open(330,file = 'bound_5x.dat',action = 'write')
!      write(330,*) ' variables = "x","y" '
!      do i = 2,ndimx-1
!      do j = 2,ndimy-1
!      if (psi(i,j).ge.1.d0) then
!      force0 = 0
!      endfind = 0
!      posx = 0
!      posy = 0
!      ni = i
!      nj = j
!      switch = 1.d0
!
!       do while(endfind.eq.0)
!       if((ni.eq.1).or.(ni.eq.ndimx).or.(nj.eq.1).or.(nj.eq.ndimy)) then
!       goto 17
!       endif
!
!       do i0 = -1,0
!       do j0 = -1,1
!       subdvx(i0,j0) = (psi(ni+i0+1,nj+j0)-psi(ni+i0,nj+j0))/(dimx/(ndimx-1))
!       enddo
!       enddo
!
!       do i0 = -1,1
!       do j0 = -1,0
!       subdvy(i0,j0) = (psi(ni+i0,nj+j0+1)-psi(ni+i0,nj+j0))/(dimy/(ndimx-1))
!       enddo
!       enddo
!
!       call endpoints(posx,posy,endx,endy,switch,subdvx,subdvy,endfind,jumpratio,ii,x,y)
!
!	  do i0 = 1,ii
!           px = ni+x(i0)
!           py = nj+y(i0)
!      if ( px.gt.1.and.px.lt.ndimx.and.py.gt.1.and.py.lt.ndimy ) then
!      if ( notem(5,note(px,py)).eq.notem(5,note(px+1,py)).and.&
!          &notem(5,note(px,py)).eq.notem(5,note(px,py+1)).and.&
!          &notem(5,note(px,py)).eq.notem(5,note(px+1,py+1)) ) then
!          inter(i0) = 0.d0
!      else
!          inter(i0) = 1.d0
!      endif
!      endif ! 1<R<ndim
!      enddo
!
!	  do i0 = 1,ii
!      if ( inter(i0).eq.1.d0 ) then
!      if ( i0.gt.1.and.i0.lt.ii) then
!      if ( MOD(i0,5).eq.1 ) then
!           inter(i0) = 1.d0
!           write(330,'(2(1x,f12.6))') ni+x(i0)-1,nj+y(i0)-1
!      endif
!      endif
!      endif
!      enddo
!
!      force0 = force0+1
!      if(force0.gt.500) then
!          endfind = 1
!          goto 17
!      endif
!
!      call tellnew(ni,nj,endx,endy,posx,posy)
!      enddo
!
!17   force0 = 0
!       endfind = 0
!       posx = 0
!       posy = 0
!       ni = i
!       nj = j
!       switch = -1.d0
!       do while(endfind.eq.0)
!       if((ni.eq.1).or.(ni.eq.ndimx).or.(nj.eq.1).or.(nj.eq.ndimy)) then
!       goto 18
!       endif
!
!       do i0 = -1,0
!       do j0 = -1,1
!       subdvx(i0,j0) = (psi(ni+i0+1,nj+j0)-psi(ni+i0,nj+j0))/(dimx/(ndimx-1))
!       enddo
!       enddo
!
!       do i0 = -1,1
!       do j0 = -1,0
!       subdvy(i0,j0) = (psi(ni+i0,nj+j0+1)-psi(ni+i0,nj+j0))/(dimy/(ndimx-1))
!       enddo
!       enddo
!
!       call endpoints(posx,posy,endx,endy,switch,subdvx,subdvy,endfind,jumpratio,ii,x,y)
!
!	  do i0 = 1,ii
!           px = ni+x(i0)
!           py = nj+y(i0)
!      if ( px.gt.1.and.px.lt.ndimx.and.py.gt.1.and.py.lt.ndimy ) then
!      if ( notem(5,note(px,py)).eq.notem(5,note(px+1,py)).and.&
!          &notem(5,note(px,py)).eq.notem(5,note(px,py+1)).and.&
!          &notem(5,note(px,py)).eq.notem(5,note(px+1,py+1))  )then
!          inter(i0) = 0.d0
!      else
!          inter(i0) = 1.d0
!      endif
!      endif ! 1<R<ndim
!      enddo
!
!	  do i0 = 1,ii
!      if ( inter(i0).eq.1.d0 ) then
!      if ( i0.gt.1.and.i0.lt.ii) then
!      if ( MOD(i0,5).eq.1 ) then
!           inter(i0) = 1.d0
!           write(330,'(2(1x,f12.6))') ni+x(i0)-1,nj+y(i0)-1
!      endif
!      endif
!      endif
!      enddo
!
!       force0 = force0+1
!       if(force0.gt.500) then
!       endfind = 1
!       goto 18
!       endif
!
!       call tellnew(ni,nj,endx,endy,posx,posy)
!      enddo
!
!       endif
!18    enddo
!      enddo
!      close(330)
      ! ======= ML-DE boundary extraction ends =======

      write(*,*) '======= begin postprocess ======='
      ! let's postprocess
      write(*,*) '_______ begin overall windowsize _______'
      ! joint PDF, marginal PDF, conditional mean value in different R scale levels can be obtained
       dpsimean = 0.d0
       lenmean = 0.d0
       spsimean = 0.d0
       sum = 0.d0
       mpdf = 0.d0
       mpdf2 = 0.d0
       jpdf = 0.d0
       jpdf2 = 0.d0
       ypdf = 0.d0
       ypdf2 = 0.d0
       my = 0.d0
       my2 = 0.d0
       do jj = 1,winnum      ! to adjust the range of window size if needed
           do ii = 1,numpairs
               locmax = pairing(ii,1)
               locmin = pairing(ii,2)
               pairsize = pairing(ii,3)
               if (locmax.gt.0.and.locmin.gt.0) then
                   !  if ((locmax.ne.oldmax).or.(locmin.ne.oldmin)) then
                   if (multiscale(jj,locmax,1).gt.0.and.multiscale(jj,locmin,1).gt.0) then
                      maxxcor = interp(multiscale(jj,locmax,1),multiscale(jj,locmax,2),coordx)
                      maxycor = interp(multiscale(jj,locmax,1),multiscale(jj,locmax,2),coordy)
                      maxpsi = interp(multiscale(jj,locmax,1),multiscale(jj,locmax,2),psi)
                      minxcor = interp(multiscale(jj,locmin,1),multiscale(jj,locmin,2),coordx)
                      minycor = interp(multiscale(jj,locmin,1),multiscale(jj,locmin,2),coordy)
                      minpsi = interp(multiscale(jj,locmin,1),multiscale(jj,locmin,2),psi)
                      len1 = sqrt((minxcor-maxxcor)**2+(minycor-maxycor)**2)   ! linear distance between extremal points of ML-DEs
                      deltapsi = dabs(maxpsi-minpsi)    ! scalar difference between extremal points of ML-DEs
                      dpsimean = dpsimean+dabs(deltapsi)
                      spsimean = spsimean + pairing_tao(ii)/pairing(ii,3)
                      lenmean = lenmean+len1
                      sum = sum+1
                  endif
              endif
          enddo
      enddo
      dpsimean = dpsimean/sum   ! averaged scalar difference
      lenmean = lenmean/sum    ! average ML-DE linear distance
      spsimean = spsimean/sum   ! average DE mean value
      write(*,*) 'dpsimean = ',dpsimean
      write(*,*) 'lenmean = ',lenmean
      write(*,*) 'spsimean = ',spsimean
      write(*,*) 'sum = ',sum

      do jj = 1,winnum
           do ii = 1,numpairs
               locmax = pairing(ii,1)
               locmin = pairing(ii,2)
               pairsize = pairing(ii,3)
               if (locmax.gt.0.and.locmin.gt.0) then
                   if (multiscale(jj,locmax,1).gt.0.and.multiscale(jj,locmin,1).gt.0) then
                      maxxcor = interp(multiscale(jj,locmax,1),multiscale(jj,locmax,2),coordx)
                      maxycor = interp(multiscale(jj,locmax,1),multiscale(jj,locmax,2),coordy)
                      maxpsi = interp(multiscale(jj,locmax,1),multiscale(jj,locmax,2),psi)
                      minxcor = interp(multiscale(jj,locmin,1),multiscale(jj,locmin,2),coordx)
                      minycor = interp(multiscale(jj,locmin,1),multiscale(jj,locmin,2),coordy)
                      minpsi = interp(multiscale(jj,locmin,1),multiscale(jj,locmin,2),psi)
                      len1 = sqrt((minxcor-maxxcor)**2+(minycor-maxycor)**2)
                      deltapsi = dabs(maxpsi-minpsi)
                      ! 100 bins are used to show joint PDF and identify different length scale, deltapsi and psimean
                      n1 = 25*len1/lenmean
                      n1 = min(n1,100)
                      n1 = max(n1,0)
                      n2 = 10*deltapsi!/dpsimean
                      n2 = min(n2,100)
                      n2 = max(n2,0)
                      n3 = 5.d0*(pairing_tao(ii)/pairing(ii,3)-25.d0)
                      n3 = min(n3,100)
                      n3 = max(n3,0)
                      jpdf(n1,n2) = jpdf(n1,n2) + pairing(ii,3)
                      jpdf2(n1,n3) = jpdf2(n1,n3) + pairing(ii,3)
                      Rall_jpdf(n1,n2) = Rall_jpdf(n1,n2) + pairing(ii,3)
                      Rall_jpdf2(n1,n3) = Rall_jpdf2(n1,n3) + pairing(ii,3)
                  endif
              endif
          enddo
      enddo

      open(60,file = 'jpdf_deltatao_summer.dat')
      write(60,*) ' variables = "length","deltapsi","pdf" '
      write(60,*) ' zone I = 101, J = 101, F = POINT '
      open(61,file = 'jpdf_taomean_summer.dat')
      write(61,*) ' variables = "length","deltapsi","pdf" '
      write(61,*) ' zone I = 101, J = 101, F = POINT '
      do j = 0,100
          do i = 0,100
              write(60,'(3es14.4)') i/25.d0*lenmean*8.d0,j/10.d0,Rall_jpdf(i,j)/m
              write(61,'(3es14.4)') i/25.d0*lenmean*8.d0,j/5.d0+25.d0,Rall_jpdf2(i,j)/m
          enddo
      enddo
      close(60)
      close(61)

      ! extract marginal PDF and conditional mean from joint PDF results
      do i = 0,100
          do j = 0,99
              mpdf(i) = mpdf(i) + jpdf(i,j)
              mpdf2(i) = mpdf2(i) + jpdf2(i,j)
              ypdf(i) = ypdf(i) + j/10.d0*jpdf(i,j)
              ypdf2(i) = ypdf2(i) + (j/5.d0+25.d0)*jpdf2(i,j)
          enddo
          if ( mpdf(i).eq.0 ) then
              my(i) = 0.d0
          else
              my(i) = ypdf(i)/mpdf(i)
          endif
          if ( mpdf2(i).eq.0 ) then
              my2(i) = 0.d0
          else
              my2(i) = ypdf2(i)/mpdf2(i)
          endif
          Rall_mpdf(i) = Rall_mpdf(i) + mpdf(i)
          Rall_my(i) = Rall_my(i) + my(i)
          Rall_my2(i) = Rall_my2(i) + my2(i)
      enddo

      open(60,file= 'conmean_deltatao_Rall_summer.dat' ,action='write')
      write(60,*) ' variables = "length", "dtao|length" '
      write(60,*) ' ZONE I=101 , F=POINT '
      open(61,file= 'conmean_taomean_Rall_summer.dat' ,action='write')
      write(61,*) ' variables = "length", "taom|length" '
      write(61,*) ' ZONE I=101 , F=POINT '
      do i=0,100
          write(60,'(2(1x,f10.6,f10.6))') i/25.d0*lenmean*8.d0, Rall_my(i)/m
          write(61,'(2(1x,f10.6,f10.6))') i/25.d0*lenmean*8.d0, Rall_my2(i)/m
      enddo
      close(60)
      close(61)
      write(*,*) '_______ end overall windowsize _______'
      write(*,*) ' ======= end postprocess ======='

      enddo

      deallocate(multiscale)
      deallocate(dx)
      deallocate(dy)

56 format(i3,2es15.4)
      call CPU_TIME(tdiff1)
      write(*,*) 'diff_scale_duration = ',tdiff1-tdiff0
      end

      ! subroutine [sphere]: to find the maximal/minimal point within the Rball window size (sphere for 3D & circle for 2D)
       subroutine sphere(ni,nj,endx,endy,psimax,Rball,window,switch,psiball,xcorball,ycorball,meetbound)
      implicit none
      include "param.h"
      double precision,external::lamda
      double precision psimax,psiball,xcorball,ycorball,R
      double precision epsilon,endx,endy,exmpsi,window,switch
      double precision dx,dy,exmx1,exmx2,lam,lampsi
      double precision distance(1:ndimx,1:ndimy)
      double precision, dimension(:,:),pointer:: coordx,coordy

      double precision, dimension(:,:),pointer:: psi
      double precision, dimension(:,:),pointer:: points
      integer pairing(1000000,3)
      integer status,numends,loop,px,py,zx,zy,i,j,ni,nj
      integer meetbound,Rball
      common/large0/ psi
      common/large1/ pairing
      common/large2/ coordx,coordy
      common/large5/ points

      epsilon = 1.d-4
      R = window
      meetbound = 0
      ! ======= psimax mean the local extremal(max/min) in the cubic
      psiball = psimax
      xcorball = ni+endx
      ycorball = nj+endy
      ! ======= psiball means the extremal point in the ball with radius R
      px = ni+endx
      py = nj+endy
      dx = ni+endx-px
      dy = nj+endy-py

      if (((xcorball-Rball).lt.1.d0).or.((ycorball-Rball).lt.1.d0).or.((ndimx-xcorball).lt.Rball).or.((ndimy-ycorball).lt.Rball)) then
          meetbound = 1
          go to 80
      else
          exmx1 = (ni+endx)*dimx/(ndimx-1)
          exmx2 = (nj+endy)*dimy/(ndimy-1)
          do j = max(1,nj-Rball),min(nj+Rball,ndimy-1)
          do i = max(1,ni-Rball),min(ni+Rball,ndimx-1)
              distance(i,j) = sqrt((coordx(i,j)-exmx1)**2+(coordy(i,j)-exmx2)**2)
          enddo
          enddo
          ! ======= calculate the max/min inside the ball
          do j = max(1,nj-Rball),min(nj+Rball+1,ndimy)
          do i = max(1,ni-Rball),min(ni+Rball+1,ndimx)
              if (distance(i,j).le.R) then
              if ((psi(i,j)*switch).gt.(psiball*switch)) then
                  psiball = psi(i,j)
                  xcorball = i
                  ycorball = j
              endif
              endif
          enddo
          enddo
          ! ======= calculate the min/max in the surface
          do j = max(1,nj-Rball),min(nj+Rball,ndimy-1)
          do i = max(1,ni-Rball),min(ni+Rball,ndimx-1)
              ! ======= grid in x dirction
              if((distance(i,j)-R)*(distance(i+1,j)-R).le.0) then
                  lam = lamda(exmx1,exmx2,coordx(i,j),coordy(i,j),coordx(i+1,j),coordy(i+1,j),window)
                  if(lam.ge.0) then
                      lampsi = psi(i,j)+lam*(psi(i+1,j)-psi(i,j))
                      if ((switch*lampsi).gt.(switch*psiball)) then
                          psiball = lampsi
                          xcorball = i+lam
                          ycorball = j
                      endif
                  endif
              endif
              ! ======= grid in y dirction
              if((distance(i,j)-R)*(distance(i,j+1)-R).le.0) then
                  lam = lamda(exmx1,exmx2,coordx(i,j),coordy(i,j),coordx(i,j+1),coordy(i,j+1),window)
                  if(lam.ge.0) then
                      lampsi = psi(i,j)+lam*(psi(i,j+1)-psi(i,j))
                      if ((switch*lampsi).gt.(switch*psiball)) then
                          psiball = lampsi
                          xcorball = i
                          ycorball = j+lam
                      endif
                  endif
              endif
          enddo
          enddo
      endif

80  end subroutine

       ! function to get the distance between the boundary point of the sphere (circle) and the nearest grid point
       function lamda(x0,y0,x1,y1,x2,y2,r)
       implicit none
       double precision x0,y0,x1,y1,x2,y2,r,d,l,cross
       double precision vect1x,vect1y,vect2x,vect2y,lamda1,lamda2,lamda
       d = dsqrt((x1-x0)**2+(y1-y0)**2)
       l = dsqrt((x2-x0)**2+(y2-y0)**2)
       if (((d.le.r).and.(l.gt.r)).or.((d.gt.r).and.(l.le.r))) then
           ! ======= vector OM
           vect1x = x1-x0
           vect1y = y1-y0
           ! ======= vector ON
           vect2x = x2-x0
           vect2y = y2-y0
           cross = vect1x*vect2x+vect1y*vect2y
           lamda1 = (d**2-cross+dsqrt((cross-d**2)**2-(d**2+l**2-2*cross)*(d**2-r**2)))/(d**2+l**2-2*cross)
           if ((lamda1.ge.0).and.(lamda1.le.1)) lamda = lamda1
           lamda2 = (d**2-cross-dsqrt((cross-d**2)**2-(d**2+l**2-2*cross)*(d**2-r**2)))/(d**2+l**2-2*cross)
           if ((lamda2.ge.0).and.(lamda2.le.1)) lamda = lamda2
       else
           lamda = -100.d0
       endif
       return
       end function

       ! linear interpolation function
       function interp(tx,ty,phi)
       implicit none
       include "param.h"
       double precision tx,ty,dx,dy,interp
       double precision phi(ndimx,ndimy)
       integer px,py,status

       px = tx
       py = ty
       dx = tx-px
       dy = ty-py
       interp=(1.d0-dx)*(1.d0-dy)*phi(px,py)+dx*(1.d0-dy)*phi(px+1,py)+(1.d0-dx)*dy*phi(px,py+1)+dx*dy*phi(px+1,py+1)

    end function

      subroutine endpoint(posx,posy,endx,endy,switch,subdvx,subdvy,endfind,jumpratio)
      implicit none
      double precision jumpratio
      double precision posx,posy,nposx,nposy,endx,endy
      double precision switch,angle(3),temp,temp1,temp2,temp3
      double precision subdvx(-1:0,-1:1),subdvy(-1:1,-1:0)
      double precision normx,normy,normt,jump
      integer ix,iy,iz,inner,endfind,force
      double precision xp,xm,yp,ym,zp,zm
      double precision vxp(3),vxm(3),vyp(3),vym(3)
      double precision diverg,totv,vsum(3)

      include "param.h"

      inner=1
      force=0

      nposx=posx
      nposy=posy

      normx=0.d0
      normy=0.d0
      do ix=-1,0
      do iy=-1,1
      normx=max(dabs(subdvx(ix,iy)),normx)
      enddo
      enddo
      do ix=-1,1
      do iy=-1,0
      normy=max(dabs(subdvy(ix,iy)),normy)
      enddo
      enddo
      normt=dsqrt(normx*normx+normy*normy)+1.d-20

      do while(inner.eq.1)

      if(abs(nposx).gt.0.5d0.or.abs(nposy).gt.0.5d0) then
      inner=0
      endx=nposx
      endy=nposy
      goto 54
      endif

      call findangle(nposx,nposy,switch,subdvx,subdvy,angle,totv)

      jump=min(pace,totv/normt/4.d0)

      if(jump.lt.jumpeps) then

       xp=nposx+pace
       xm=nposx-pace
       yp=nposy+pace
       ym=nposy-pace
       call findangle(xp,nposy,switch,subdvx,subdvy,vxp,temp)
       call findangle(xm,nposy,switch,subdvx,subdvy,vxm,temp)
       call findangle(nposx,yp,switch,subdvx,subdvy,vyp,temp)
       call findangle(nposx,ym,switch,subdvx,subdvy,vym,temp)
       diverg=vxp(1)-vxm(1)+vyp(2)-vym(2)
       if(diverg.gt.-2.5) then
       call random_number(vsum(1))
       call random_number(vsum(2))

       if(abs(angle(1)).ge.abs(angle(2))) then
       temp2=vsum(2)**2*angle(2)
        temp1=10*temp2*angle(2)/angle(1)
        temp=1.d-20+dsqrt(temp1**2+temp2**2)
        nposx=nposx-temp1/temp*pace
        nposy=nposy+temp2/temp*pace
        goto 55
        else
        temp1=vsum(1)**2*angle(1)
        temp2=10*temp1*angle(1)/angle(2)
        temp=1.d-20+dsqrt(temp1**2+temp2**2)
        nposx=nposx+temp1/temp*pace
        nposy=nposy-temp2/temp*pace
        goto 55
        endif
       endif

       endfind=1
       inner=0
       endx=nposx
       endy=nposy
       goto 54

      else
       nposx=nposx+angle(1)*jump
       nposy=nposy+angle(2)*jump
      endif

  55  force=force+1
      if(force.gt.10000) then
      jumpratio=jumpratio+1
      endfind=1
      inner=0
      endx=nposx
      endy=nposy
      goto 54
      endif

      enddo

  54  return

    end

      subroutine endpoints(posx,posy,endx,endy,switch,subdvx,subdvy,endfind,jumpratio,ii,x,y)
       implicit none
      double precision jumpratio
      double precision posx,posy,nposx,nposy,endx,endy
      double precision switch,angle(2),temp,temp1,temp2
      double precision subdvx(-1:0,-1:1),subdvy(-1:1,-1:0),x(1000000),y(1000000)
      double precision normx,normy,normt,jump
      integer ix,iy,inner,endfind,force,ii
      double precision xp,xm,yp,ym
      double precision vxp(3),vxm(3),vyp(3),vym(3)
      double precision diverg,totv,vsum(3)

      include "param.h"

      inner = 1
      force = 0

      nposx = posx
      nposy = posy

      normx = 0.d0
      normy = 0.d0
      do ix = -1,0
      do iy = -1,1
      normx = max(dabs(subdvx(ix,iy)),normx)
      enddo
      enddo
      do ix = -1,1
      do iy = -1,0
      normy = max(dabs(subdvy(ix,iy)),normy)
      enddo
      enddo
      normt = dsqrt(normx*normx+normy*normy)+1.d-20

      ii = 0
      do while(inner.eq.1)
      ii = ii+1
      x(ii) = nposx
      y(ii) = nposy
      if((abs(nposx).gt.0.5d0).or.(abs(nposy).gt.0.5d0)) then
      inner = 0
      endx = nposx
      endy = nposy
      goto 64
      endif

      call findangle(nposx,nposy,switch,subdvx,subdvy,angle,totv)

      jump = min(pace,totv/normt/4.d0)

      if(jump.lt.jumpeps) then
      xp = nposx+pace
      xm = nposx-pace
      yp = nposy+pace
      ym = nposy-pace
       call findangle(xp,nposy,switch,subdvx,subdvy,vxp,temp)
       call findangle(xm,nposy,switch,subdvx,subdvy,vxm,temp)
       call findangle(nposx,yp,switch,subdvx,subdvy,vyp,temp)
       call findangle(nposx,ym,switch,subdvx,subdvy,vym,temp)
      diverg = vxp(1)-vxm(1)+vyp(2)-vym(2)
      if(diverg.gt.-2.5) then
      call random_number(vsum(1))
      call random_number(vsum(2))

       if(abs(angle(1)).ge.abs(angle(2))) then
       temp2 = vsum(2)**2*angle(2)
       temp1 = 10*temp2*angle(2)/angle(1)
       temp = 1.d-20+dsqrt(temp1**2+temp2**2)
       nposx = nposx-temp1/temp*pace
       nposy = nposy+temp2/temp*pace
       goto 65
       else if(abs(angle(2)).ge.abs(angle(1))) then
       temp1 = vsum(1)**2*angle(1)
       temp2 = 10*temp1*angle(1)/angle(2)
       temp = 1.d-20+dsqrt(temp1**2+temp2**2)
       nposx = nposx+temp1/temp*pace
       nposy = nposy-temp2/temp*pace
       goto 65
       endif
      endif

      endfind = 1
      inner = 0
      endx = nposx
      endy = nposy
      goto 64

      else
       nposx = nposx+angle(1)*jump
       nposy = nposy+angle(2)*jump
      endif

  65  force = force+1
      if(force.gt.100) then
      jumpratio = jumpratio+1
      endfind = 1
      inner = 0
      endx = nposx
      endy = nposy
      goto 64
      endif

      enddo

  64  return

      end

      subroutine findangle(nposx,nposy,switch,subdvx,subdvy,angl,totv)
      implicit none
      double precision nposx,nposy,totv
      double precision switch,angl(2)
      double precision subdvx(-1:0,-1:1),subdvy(-1:1,-1:0)
      double precision sx,sy
      integer ix,iy

      ix=-1
      iy=0
      sx=nposx+0.5d0
      sy=nposy
      if(nposy.lt.0.d0) then
       sy=1.d0+nposy
       iy=-1
      endif
      angl(1)=(1.d0-sx)*(1.d0-sy)*subdvx(ix,iy)+sx*(1.d0-sy)*subdvx(ix+1,iy)+&
          & (1.d0-sx)*sy*subdvx(ix,iy+1)+sx*sy*subdvx(ix+1,iy+1)
      angl(1)=angl(1)*switch

      ix=0
      iy=-1
      sx=nposx
      sy=nposy+0.5d0
      if(nposx.lt.0.d0) then
       sx=1.d0+nposx
       ix=-1
      endif
      angl(2)=(1.d0-sx)*(1.d0-sy)*subdvy(ix,iy)+sx*(1.d0-sy)*subdvy(ix+1,iy)+&
          & (1.d0-sx)*sy*subdvy(ix,iy+1)+sx*sy*subdvy(ix+1,iy+1)
      angl(2)=angl(2)*switch

      totv=1.d-20+dsqrt(angl(1)**2+angl(2)**2)
      angl(1)=1.d-20+angl(1)/totv
      angl(2)=1.d-20+angl(2)/totv

      return
      end

      subroutine tellnew(ni,nj,endx,endy,posx,posy)
      implicit none
      integer ni,nj
      double precision endx,endy,posx,posy

      if(abs(endx).le.0.5.and.abs(endy).le.0.5) then
      ni=ni
      nj=nj
      posx=endx
      posy=endy
      elseif(endx.gt.0.5.and.abs(endy).le.0.5) then
      ni=ni+1
      nj=nj
      posx=endx-1.d0
      posy=endy
      elseif(endx.lt.-0.5.and.abs(endy).le.0.5) then
      ni=ni-1
      nj=nj
      posx=endx+1.d0
      posy=endy
      elseif(abs(endx).le.0.5.and.endy.gt.0.5) then
      ni=ni
      nj=nj+1
      posx=endx
      posy=endy-1.d0
      elseif(abs(endx).le.0.5.and.endy.lt.-0.5) then
      ni=ni
      nj=nj-1
      posx=endx
      posy=endy+1.d0
      elseif(endx.gt.0.5.and.endy.gt.0.5) then
      ni=ni+1
      nj=nj+1
      posx=endx-1.d0
      posy=endy-1.d0
      elseif(endx.lt.-0.5.and.endy.gt.0.5) then
      ni=ni-1
      nj=nj+1
      posx=endx+1.d0
      posy=endy-1.d0
      elseif(endx.lt.-0.5.and.endy.lt.-0.5) then
      ni=ni-1
      nj=nj-1
      posx=endx+1.d0
      posy=endy+1.d0
      elseif(endx.gt.0.5.and.endy.lt.-0.5) then
      ni=ni+1
      nj=nj-1
      posx=endx-1.d0
      posy=endy+1.d0
      endif

      return
      end


! =====================================================================
subroutine rp1(maxmx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,fwave,s,amdq,apdq)
! =====================================================================
!
!solve Riemann problems for the 1D shallow water equations
!    with source-term resulting from variable topography b(x,t)
!    (h)_t + (u h)_x = 0
!    (uh)_t + (uuh + 0.5*gh**2)_x = -g*h*b_x
!
!
!
!     On input,
!     ql contains the state vector at the left edge of each cell
!     qr contains the state vector at the right edge of each cell
!
!     On output, wave contains the fwaves/s,
!                s the speeds,
!                amdq the  left-going flux difference  A**- \Delta q
!               apdq the right-going flux difference  A**+ \Delta q
!
!     Note that the i'th Riemann problem has left state qr(i-1,:)
!     #                                    and right state ql(i,:)
!     From the basic clawpack routine step1, rp1 is called with ql=qr=q.
!
!      This is for use with the Riemann solver(s) used in GeoClaw
!        but for 1D problems. That is, it calls the same solver for left and
!        right states that is used for 2d problems.
!
!        This routine deals with dry-state problems over topography
!        by testing a wall boundary condition, like that done in GeoClaw 2d
!
!        to call other point-wise Riemann solvers alter the call on line 177

    use geoclaw_module, only: dry_tolerance, grav

    implicit none

    ! Input arguments
    integer, intent(in) :: maxmx,meqn,mwaves,mbc,mx,maux

    double precision, intent(in), dimension(meqn, 1-mbc:maxmx+mbc) :: ql,qr
    double precision, intent(in), dimension(maux, 1-mbc:maxmx+mbc) :: auxl,auxr

    ! Output arguments
    double precision, intent(out) :: s(mwaves, 1-mbc:maxmx+mbc)
    double precision, intent(out) :: fwave(meqn, mwaves, 1-mbc:maxmx+mbc)
    double precision, intent(out), dimension(meqn, 1-mbc:maxmx+mbc) :: amdq,apdq

    !Local
    integer :: m,i,mw,maxiter
    double precision :: hR,hL,huR,huL,uR,uL,hvR,hvL,vR,vL,phiR,phiL
    double precision :: bR,bL,sL,sR,sRoe1,sRoe2,sE1,sE2,uhat,chat
    double precision :: hstartest,hstarHLL,sLtest,sRtest
    double precision :: wall(2), fw(3,3), sw(3)
    double precision :: g,drytol

    g=grav
    drytol=dry_tolerance

    !loop through Riemann problems at each grid cell
      do i=2-mbc,mx+mbc

!-----------------------Initializing-----------------------------------
         !inform of a bad riemann problem from the start
         if((qr(1,i-1).lt.0.d0).or.(ql(1,i) .lt. 0.d0)) then
            write(*,*) 'Negative input: hl,hr,i=',qr(1,i-1),ql(1,i),i
         endif

         !Initialize Riemann problem for grid interface
         do mw=1,mwaves
              s(mw,i)=0.d0
              do m=1,meqn
                 fwave(m,mw,i)=0.d0
              enddo
         enddo

         !skip problem if in a completely dry area
         if (qr(1,i-1).le.drytol.and.ql(1,i).le.drytol) then
            go to 30
         endif

         !Riemann problem variables
         hL = qr(1,i-1)
         hR = ql(1,i)
         huL = qr(2,i-1)
         huR = ql(2,i)
         bL = auxr(1,i-1)
         bR = auxl(1,i)

         hvL=0.d0
         hvR=0.d0

         !check for wet/dry boundary
         sE1= 1.d99
         sE2=-1.d99
         wall(2) = 1.d0
         wall(1) = 1.d0
         if (hR.le.drytol) then
            sLtest=min(-sqrt(g*hL),huL/hL-sqrt(g*hL)) !what would be the Einfeldt speed of wall problem
            hstartest=hL-(huL/sLtest) !what would be middle state in approx Riemann solution
            if (hstartest+bL.lt.bR) then !right state should become ghost values that mirror left for wall problem
               wall(2)=0.d0
               hR=hL
               huR=-huL
               bR=bL
               phiR=phiL
            endif
         elseif (hL.le.drytol) then ! right surface is lower than left topo
            sRtest=max(sqrt(g*hR),huR/hR+sqrt(g*hR)) !what would be the Einfeldt speed of wall
            hstartest= hR-(huR/sRtest) !what would be middle state in approx Rimeann solution
            if (hstartest+bR.lt.bL) then  !left state should become ghost values that mirror right
               wall(1)=0.d0
               hL=hR
               huL=-huR
               bL=bR
               phiL=phiR
            endif
         endif

         if (hR.gt.drytol) then
            uR=huR/hR
            vR=hvR/hR
            phiR = 0.5d0*g*hR**2 + huR**2/hR
         else
            hR = 0.d0
            huR = 0.d0
            uR = 0.d0
            vR = 0.d0
            phiR = 0.d0
            sE2 = max(sE2,huL/hL+2.d0*sqrt(g*hL))
         endif

         if (hL.gt.drytol) then
            uL=huL/hL
            vL=hvL/hL
            phiL = 0.5d0*g*hL**2 + huL**2/hL
         else
            hL=0.d0
            huL=0.d0
            uL=0.d0
            vL=0.d0
            phiL = 0.d0
            sE1 = min(sE1,huR/hR - 2.d0*sqrt(g*hR))
         endif

         !determine wave speeds
         sL=uL-sqrt(g*hL) ! 1 wave speed of left state
         sR=uR+sqrt(g*hR) ! 2 wave speed of right state

         uhat=(sqrt(g*hL)*uL + sqrt(g*hR)*uR)/(sqrt(g*hR)+sqrt(g*hL)) ! Roe average
         chat=sqrt(g*0.5d0*(hR+hL)) ! Roe average
         sRoe1=uhat-chat ! Roe wave speed 1 wave
         sRoe2=uhat+chat ! Roe wave speed 2 wave

         sE1 = min(sE1,min(sL,sRoe1)) ! Eindfeldt speed 1 wave
         sE2 = max(sE2,max(sR,sRoe2)) ! Eindfeldt speed 2 wave

         !--------------------end initializing...finally----------
         !solve Riemann problem.

         maxiter = 1

         call riemann_aug_JCP(maxiter,3,3,hL,hR,huL, &
     &  huR,hvL,hvR,bL,bR,uL,uR,vL,vR,phiL,phiR,sE1,sE2,drytol,g,sw,fw)

!         call riemann_ssqfwave(maxiter,meqn+1,mwaves+1,hL,hR,huL,huR, &
!         &  hvL,hvR,bL,bR,uL,uR,vL,vR,phiL,phiR,sE1,sE2,drytol,g,sw,fw)

!         call riemann_fwave(meqn+1,mwaves+1,hL,hR,huL,huR,hvL,hvR, &
!           &   bL,bR,uL,uR,vL,vR,phiL,phiR,sE1,sE2,drytol,g,sw,fw)

         s(1,i) = sw(1)*wall(1)
         s(2,i) = sw(3)*wall(2)

         do m=1,meqn
            fwave(m,1,i)=fw(m,1)*wall(1)
            fwave(m,2,i)=fw(m,3)*wall(2)
            if (sw(2)>0.0) then
               fwave(m,2,i) = fwave(m,2,i) + fw(m,2)*wall(2)
            else
               fwave(m,1,i) = fwave(m,1,i) + fw(m,2)*wall(1)
            endif
         enddo

 30      continue
      enddo

      do i=2-mbc,mx+mbc
         do m=1,meqn
            amdq(m,i) = 0.d0
            apdq(m,i) = 0.d0
            do  mw=1,mwaves
               if (s(mw,i).lt.0.d0) then
                  amdq(m,i) = amdq(m,i) + fwave(m,mw,i)
               elseif (s(mw,i).gt.0.d0) then
                  apdq(m,i) = apdq(m,i) + fwave(m,mw,i)
               else
                  amdq(m,i) = amdq(m,i) + .5d0*fwave(m,mw,i)
                  apdq(m,i) = apdq(m,i) + .5d0*fwave(m,mw,i)
               endif
            enddo
         enddo
      enddo

      return
      end subroutine rp1