*DECK BSKIN
      SUBROUTINE BSKIN (X, N, KODE, M, Y, NZ, IERR)
C***BEGIN PROLOGUE  BSKIN
C***PURPOSE  Compute repeated integrals of the K-zero Bessel function.
C***LIBRARY   SLATEC
C***CATEGORY  C10F
C***TYPE      SINGLE PRECISION (BSKIN-S, DBSKIN-D)
C***KEYWORDS  BICKLEY FUNCTIONS, EXPONENTIAL INTEGRAL,
C             INTEGRALS OF BESSEL FUNCTIONS, K-ZERO BESSEL FUNCTION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C         The following definitions are used in BSKIN:
C
C   Definition 1
C         KI(0,X) = K-zero Bessel function.
C
C   Definition 2
C         KI(N,X) = Bickley Function
C                 =  integral from X to infinity of KI(N-1,t)dt
C                     for X .ge. 0 and N = 1,2,...
C   ____________________________________________________________________
C      BSKIN computes sequences of Bickley functions (repeated integrals
C      of the K0 Bessel function); i.e. for fixed X and N and K=1,...,
C      BSKIN computes the M-member sequence
C
C                     Y(K) =        KI(N+K-1,X) for KODE=1
C      or
C                     Y(K) = EXP(X)*KI(N+K-1,X) for KODE=2,
C
C      for N.ge.0 and X.ge.0 (N and X cannot be zero simultaneously).
C
C      INPUT
C        X      - Argument, X .ge. 0.0E0
C        N      - Order of first member of the sequence N .ge. 0
C        KODE   - Selection parameter
C                 KODE = 1 returns Y(K)=       KI(N+K-1,X), K=1,M
C                      = 2 returns Y(K)=EXP(X)*KI(N+K-1,X), K=1,M
C        M      - Number of members in the sequence, M.ge.1
C
C      OUTPUT
C        Y      - A vector of dimension at least M containing the
C                 sequence selected by KODE.
C        NZ     - Underflow flag
C                 NZ = 0 means computation completed
C                    = M means an exponential underflow occurred on
C                        KODE=1.  Y(K)=0.0E0, K=1,...,M is returned
C        IERR   - Error flag
C                 IERR = 0, Normal return, computation completed.
C                      = 1, Input error,   no computation.
C                      = 2, Error,         no computation.  The
C                           termination condition was not met.
C
C      The nominal computational accuracy is the maximum of unit
C      roundoff (=R1MACH(4)) and 1.0e-18 since critical constants
C      are given to only 18 digits.
C
C      DBSKIN is the double precision version of BSKIN.
C
C *Long Description:
C
C         Numerical recurrence on
C
C      (L-1)*KI(L,X) = X(KI(L-3,X) - KI(L-1,X)) + (L-2)*KI(L-2,X)
C
C         is stable where recurrence is carried forward or backward
C         away from INT(X+0.5).  The power series for indices 0,1 and 2
C         on 0.le.X.le. 2 starts a stable recurrence for indices
C         greater than 2.  If N is sufficiently large (N.gt.NLIM), the
C         uniform asymptotic expansion for N to INFINITY is more
C         economical.  On X.gt.2 the recursion is started by evaluating
C         the uniform expansion for the three members whose indices are
C         closest to INT(X+0.5) within the set N,...,N+M-1.  Forward
C         recurrence, backward recurrence or both, complete the
C         sequence depending on the relation of INT(X+0.5) to the
C         indices N,...,N+M-1.
C
C***REFERENCES  D. E. Amos, Uniform asymptotic expansions for
C                 exponential integrals E(N,X) and Bickley functions
C                 KI(N,X), ACM Transactions on Mathematical Software,
C                 1983.
C               D. E. Amos, A portable Fortran subroutine for the
C                 Bickley functions KI(N,X), Algorithm 609, ACM
C                 Transactions on Mathematical Software, 1983.
C***ROUTINES CALLED  BKIAS, BKISR, EXINT, GAMRN, I1MACH, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement label.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BSKIN
      INTEGER I, ICASE, IERR, IL, I1M, K, KK, KODE, KTRMS, M,
     * M3, N, NE, NFLG, NL, NLIM, NN, NP, NS, NT, NZ
      INTEGER I1MACH
      REAL A, ENLIM, EXI, FN, GR, H, HN, HRTPI, SS, TOL, T1, T2, W, X,
     * XLIM, XNLIM, XP, Y, YS, YSS
      REAL GAMRN, R1MACH
      DIMENSION EXI(102), A(50), YS(3), YSS(3), H(31), Y(*)
      SAVE A, HRTPI
C-----------------------------------------------------------------------
C             COEFFICIENTS IN SERIES OF EXPONENTIAL INTEGRALS
C-----------------------------------------------------------------------
      DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), A(8), A(9), A(10),
     * A(11), A(12), A(13), A(14), A(15), A(16), A(17), A(18), A(19),
     * A(20), A(21), A(22), A(23), A(24) /1.00000000000000000E+00,
     * 5.00000000000000000E-01,3.75000000000000000E-01,
     * 3.12500000000000000E-01,2.73437500000000000E-01,
     * 2.46093750000000000E-01,2.25585937500000000E-01,
     * 2.09472656250000000E-01,1.96380615234375000E-01,
     * 1.85470581054687500E-01,1.76197052001953125E-01,
     * 1.68188095092773438E-01,1.61180257797241211E-01,
     * 1.54981017112731934E-01,1.49445980787277222E-01,
     * 1.44464448094367981E-01,1.39949934091418982E-01,
     * 1.35833759559318423E-01,1.32060599571559578E-01,
     * 1.28585320635465905E-01,1.25370687619579257E-01,
     * 1.22385671247684513E-01,1.19604178719328047E-01,
     * 1.17004087877603524E-01/
      DATA A(25), A(26), A(27), A(28), A(29), A(30), A(31), A(32),
     * A(33), A(34), A(35), A(36), A(37), A(38), A(39), A(40), A(41),
     * A(42), A(43), A(44), A(45), A(46), A(47), A(48)
     * /1.14566502713486784E-01,1.12275172659217048E-01,
     * 1.10116034723462874E-01,1.08076848895250599E-01,
     * 1.06146905164978267E-01,1.04316786110409676E-01,
     * 1.02578173008569515E-01,1.00923686347140974E-01,
     * 9.93467537479668965E-02,9.78414999033007314E-02,
     * 9.64026543164874854E-02,9.50254735405376642E-02,
     * 9.37056752969190855E-02,9.24393823875012600E-02,
     * 9.12230747245078224E-02,9.00535481254756708E-02,
     * 8.89278787739072249E-02,8.78433924473961612E-02,
     * 8.67976377754033498E-02,8.57883629175498224E-02,
     * 8.48134951571231199E-02,8.38711229887106408E-02,
     * 8.29594803475290034E-02,8.20769326842574183E-02/
      DATA A(49), A(50) /8.12219646354630702E-02,8.03931690779583449E-02
     * /
C-----------------------------------------------------------------------
C             SQRT(PI)/2
C-----------------------------------------------------------------------
      DATA HRTPI /8.86226925452758014E-01/
C
C***FIRST EXECUTABLE STATEMENT  BSKIN
      IERR = 0
      NZ=0
      IF (X.LT.0.0E0) IERR=1
      IF (N.LT.0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (M.LT.1) IERR=1
      IF (X.EQ.0.0E0 .AND. N.EQ.0) IERR=1
      IF (IERR.NE.0) RETURN
      IF (X.EQ.0.0E0) GO TO 300
      I1M = -I1MACH(12)
      T1 = 2.3026E0*R1MACH(5)*I1M
      XLIM = T1 - 3.228086E0
      T2 = T1 + N + M - 1
      IF (T2.GT.1000.0E0) XLIM = T1 - 0.5E0*(LOG(T2)-0.451583E0)
      IF (X.GT.XLIM .AND. KODE.EQ.1) GO TO 320
      TOL = MAX(R1MACH(4),1.0E-18)
      I1M = I1MACH(11)
C-----------------------------------------------------------------------
C     LN(NLIM) = 0.125*LN(EPS),   NLIM = 2*KTRMS+N
C-----------------------------------------------------------------------
      XNLIM = 0.287823E0*(I1M-1)*R1MACH(5)
      ENLIM = EXP(XNLIM)
      NLIM = INT(ENLIM) + 2
      NLIM = MIN(100,NLIM)
      NLIM = MAX(20,NLIM)
      M3 = MIN(M,3)
      NL = N + M - 1
      IF (X.GT.2.0E0) GO TO 130
      IF (N.GT.NLIM) GO TO 280
C-----------------------------------------------------------------------
C     COMPUTATION BY SERIES FOR 0.LE.X.LE.2
C-----------------------------------------------------------------------
      NFLG = 0
      NN = N
      IF (NL.LE.2) GO TO 60
      M3 = 3
      NN = 0
      NFLG = 1
   60 CONTINUE
      XP = 1.0E0
      IF (KODE.EQ.2) XP = EXP(X)
      DO 80 I=1,M3
        CALL BKISR(X, NN, W, IERR)
      IF(IERR.NE.0) RETURN
        W = W*XP
        IF (NN.LT.N) GO TO 70
        KK = NN - N + 1
        Y(KK) = W
   70   CONTINUE
        YS(I) = W
        NN = NN + 1
   80 CONTINUE
      IF (NFLG.EQ.0) RETURN
      NS = NN
      XP = 1.0E0
   90 CONTINUE
C-----------------------------------------------------------------------
C     FORWARD RECURSION SCALED BY EXP(X) ON ICASE=0,1,2
C-----------------------------------------------------------------------
      FN = NS - 1
      IL = NL - NS + 1
      IF (IL.LE.0) RETURN
      DO 110 I=1,IL
        T1 = YS(2)
        T2 = YS(3)
        YS(3) = (X*(YS(1)-YS(3))+(FN-1.0E0)*YS(2))/FN
        YS(2) = T2
        YS(1) = T1
        FN = FN + 1.0E0
        IF (NS.LT.N) GO TO 100
        KK = NS - N + 1
        Y(KK) = YS(3)*XP
  100   CONTINUE
        NS = NS + 1
  110 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     COMPUTATION BY ASYMPTOTIC EXPANSION FOR X.GT.2
C-----------------------------------------------------------------------
  130 CONTINUE
      W = X + 0.5E0
      NT = INT(W)
      IF (NL.GT.NT) GO TO 270
C-----------------------------------------------------------------------
C     CASE NL.LE.NT, ICASE=0
C-----------------------------------------------------------------------
      ICASE = 0
      NN = NL
      NFLG = MIN(M-M3,1)
  140 CONTINUE
      KK = (NLIM-NN)/2
      KTRMS = MAX(0,KK)
      NS = NN + 1
      NP = NN - M3 + 1
      XP = 1.0E0
      IF (KODE.EQ.1) XP = EXP(-X)
      DO 150 I=1,M3
        KK = I
        CALL BKIAS(X, NP, KTRMS, A, W, KK, NE, GR, H, IERR)
      IF(IERR.NE.0) RETURN
        YS(I) = W
        NP = NP + 1
  150 CONTINUE
C-----------------------------------------------------------------------
C     SUM SERIES OF EXPONENTIAL INTEGRALS BACKWARD
C-----------------------------------------------------------------------
      IF (KTRMS.EQ.0) GO TO 160
      NE = KTRMS + KTRMS + 1
      NP = NN - M3 + 2
      CALL EXINT(X, NP, 2, NE, TOL, EXI, NZ, IERR)
      IF(NZ.NE.0) GO TO 320
      IF(IERR.EQ.2) RETURN
  160 CONTINUE
      DO 190 I=1,M3
        SS = 0.0E0
        IF (KTRMS.EQ.0) GO TO 180
        KK = I + KTRMS + KTRMS - 2
        IL = KTRMS
        DO 170 K=1,KTRMS
          SS = SS + A(IL)*EXI(KK)
          KK = KK - 2
          IL = IL - 1
  170   CONTINUE
  180   CONTINUE
        YS(I) = YS(I) + SS
  190 CONTINUE
      IF (ICASE.EQ.1) GO TO 200
      IF (NFLG.NE.0) GO TO 220
  200 CONTINUE
      DO 210 I=1,M3
        Y(I) = YS(I)*XP
  210 CONTINUE
      IF (ICASE.EQ.1 .AND. NFLG.EQ.1) GO TO 90
      RETURN
  220 CONTINUE
C-----------------------------------------------------------------------
C     BACKWARD RECURSION SCALED BY EXP(X) ICASE=0,2
C-----------------------------------------------------------------------
      KK = NN - N + 1
      K = M3
      DO 230 I=1,M3
        Y(KK) = YS(K)*XP
        YSS(I) = YS(I)
        KK = KK - 1
        K = K - 1
  230 CONTINUE
      IL = KK
      IF (IL.LE.0) GO TO 250
      FN = NN - 3
      DO 240 I=1,IL
        T1 = YS(2)
        T2 = YS(1)
        YS(1) = YS(2) + ((FN+2.0E0)*YS(3)-(FN+1.0E0)*YS(1))/X
        YS(2) = T2
        YS(3) = T1
        Y(KK) = YS(1)*XP
        KK = KK - 1
        FN = FN - 1.0E0
  240 CONTINUE
  250 CONTINUE
      IF (ICASE.NE.2) RETURN
      DO 260 I=1,M3
        YS(I) = YSS(I)
  260 CONTINUE
      GO TO 90
  270 CONTINUE
      IF (N.LT.NT) GO TO 290
C-----------------------------------------------------------------------
C     ICASE=1, NT.LE.N.LE.NL WITH FORWARD RECURSION
C-----------------------------------------------------------------------
  280 CONTINUE
      NN = N + M3 - 1
      NFLG = MIN(M-M3,1)
      ICASE = 1
      GO TO 140
C-----------------------------------------------------------------------
C     ICASE=2, N.LT.NT.LT.NL WITH BOTH FORWARD AND BACKWARD RECURSION
C-----------------------------------------------------------------------
  290 CONTINUE
      NN = NT + 1
      NFLG = MIN(M-M3,1)
      ICASE = 2
      GO TO 140
C-----------------------------------------------------------------------
C     X=0 CASE
C-----------------------------------------------------------------------
  300 CONTINUE
      FN = N
      HN = 0.5E0*FN
      GR = GAMRN(HN)
      Y(1) = HRTPI*GR
      IF (M.EQ.1) RETURN
      Y(2) = HRTPI/(HN*GR)
      IF (M.EQ.2) RETURN
      DO 310 K=3,M
        Y(K) = FN*Y(K-2)/(FN+1.0E0)
        FN = FN + 1.0E0
  310 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     UNDERFLOW ON KODE=1, X.GT.XLIM
C-----------------------------------------------------------------------
  320 CONTINUE
      NZ=M
      DO 330 I=1,M
        Y(I) = 0.0E0
  330 CONTINUE
      RETURN
      END


***
      REAL*8 FUNCTION RL(Q)
      IMPLICIT NONE
      REAL*8 Q,P
*
* A function to evaluate R_L/a(q), Eggleton 1983.
*
      P = Q**(1.d0/3.d0)
      RL = 0.49d0*P*P/(0.6d0*P*P + LOG(1.d0+P))
*
      RETURN
      END
***


module procgridmod
use deftype

type pleequa
real*8 a,b,c,d    !plane pleequa ax+by+cz+d=0
end type

contains !some trivial math functions, mainly invoked by doproject

!--------- distance between two 3D points
real*8 function dist2p(pta,ptb)
type(content) pta,ptb
dist2p=dsqrt((pta%x-ptb%x)**2+(pta%y-ptb%y)**2+(pta%z-ptb%z)**2)
end function
!--------- Return vector from two content type points
function vecfrom2p(veca,vecb)
type(content) veca,vecb,vecfrom2p
vecfrom2p%x=vecb%x-veca%x
vecfrom2p%y=vecb%y-veca%y
vecfrom2p%z=vecb%z-veca%z
vecfrom2p%value=0D0
end function
!--------- Vector multiplication
function vecmul(a,b)
type(content) a,b,vecmul
vecmul%x=a%y*b%z-a%z*b%y
vecmul%y=-(a%x*b%z-a%z*b%x)
vecmul%z=a%x*b%y-a%y*b%x
end function
!--------- project a point to a given plane
function protoplane_pos(point,plane,fa)
type(content) protoplane_pos,point,fa !fa is normal vector
type(pleequa) plane
real*8 scale !!scale of vector of trans point from a1 to a2
! write(*,*) "1",point
! write(*,*) "2",plane
! write(*,*) "3",fa
scale=(plane%a*point%x+plane%b*point%y+plane%c*point%z+plane%d)/&
      (plane%a*fa%x+plane%b*fa%y+plane%c*fa%z)
protoplane_pos%x=point%x-scale*fa%x
protoplane_pos%y=point%y-scale*fa%y
protoplane_pos%z=point%z-scale*fa%z
protoplane_pos%value=point%value
end function
!--------- Value of determinant of 2x2 matrix
function det2_2(vala,valb,valc,vald)
real*8 vala,valb,valc,vald,det2_2
det2_2=vala*vald-valb*valc
end function
!--------- cos value of two vectors
real*8 function cos_2v(veca,vecb)
type(content) veca,vecb
cos_2v=abs(veca%x*vecb%x+veca%y*vecb%y+veca%z*vecb%z)/dsqrt(veca%x**2+veca%y**2+veca%z**2)/dsqrt(vecb%x**2+vecb%y**2+vecb%z**2)
end function

end module

!!-------- Process grid data. This module are mainly transplanted from GsGrid
!We use Bohr in interal processes, but convert to Angstrom when input and output
subroutine procgriddata
use deftype
use defvar
use util
use GUI
implicit real*8(a-h,o-z)
real*8,allocatable :: avgdata(:,:)
integer,allocatable :: atmlist(:),atmlist2(:)
character gridfile2*200,gridfilenew*200,atmidxfile*200,atmidxfile2*200,c200tmp*200,tmpchar,c2000tmp*2000
type(content) useratom(3),maxv,minv

if (.not.allocated(cubmat)) then
	write(*,"(a)") " Error: Grid data has not been loaded or generated! If you want to load a grid data file now, &
	input its path, e.g. C:\nico.cub, else input 0 to return"
	do while(.true.)
		read(*,"(a)") c200tmp
		if (c200tmp(1:1)=='0') then
			return
		else
			inquire(file=c200tmp,exist=alive)
			if (alive) then
				inamelen=len_trim(c200tmp)
				!Only load grid data, do not perturb other variables
				if (c200tmp(inamelen-2:inamelen)=="grd") then
					call readgrd(c200tmp,1,1)
				else if (c200tmp(inamelen-2:inamelen)=="cub".or.c200tmp(inamelen-3:inamelen)=="cube") then
					call readcube(c200tmp,1,1)
				else
					write(*,*) "Error: Unknown file type, input again"
					cycle
				end if
				exit
			else
				write(*,*) "Cannot find the file, input again"
			end if
		end if
	end do
end if

do while(.true.)
	write(*,*)
	write(*,*) "                 ============= Process grid data =============="
	write(*,*) "-2 Visualize isosurface of present grid data"
	write(*,*) "-1 Return to main menu"
	write(*,*) "0 Export present grid data to Gaussian-type cube file (.cub)"
	write(*,*) "1 Output all data points with value and coordinate to output.txt"
	write(*,*) "2 Output data points in a XY plane by specifying Z to output.txt"
	write(*,*) "3 Output data points in a YZ plane by specifying X to output.txt"
	write(*,*) "4 Output data points in a XZ plane by specifying Y to output.txt"
	write(*,*) "5 Output average data of XY planes in a range of Z to output.txt"
	write(*,*) "6 Output average data of YZ planes in a range of X to output.txt"
	write(*,*) "7 Output average data of XZ planes in a range of Y to output.txt"
	write(*,*) "8 Output data points in a plane defined by three atom indices to output.txt"
	write(*,*) "9 Output data points in a plane defined by three points to output.txt"
	write(*,*) "10 Output data points in specified value range to output.txt"
	write(*,*) "11 Grid data calculation"
	write(*,"(a)") " 12 Map values of a cube file to specified isosurface of present grid data"
	write(*,*) "13 Set value of the grid points that far away from / close to some atoms"
	write(*,*) "14 Set value of the grid points outside overlap region of two fragments"
	write(*,*) "15 If data value is within certain range, set it to a specified value"
	write(*,*) "16 Scale data range of present grid data"
	write(*,*) "17 Show statistic data of the points in specific spatial and value range"
	write(*,*) "18 Calculate and plot integral curve in X/Y/Z direction"
	read(*,*) isel

    if (isel>=2.and.isel<=7.and.ifgridortho()/=1) then
        write(*,*) "Error: This function is only available for orthogonal grid!"
        write(*,*) "Press ENTER button to return"
        read(*,*)
        cycle
    end if

	if (isel==-2) then
		call drawisosurgui(1)
	else if (isel==-1) then
		exit
	else if (isel==0) then
        call outcube_wrapper
	else if (isel==1) then
		open(10,file="output.txt",status="replace")
		write(*,*) "Outputting data, please wait..."
		ii=0
		do k=1,nz
			do j=1,ny
				do i=1,nx
					call getgridxyz(i,j,k,tmpx,tmpy,tmpz)
					write(10,"(3f10.5,f22.15)") tmpx*b2a,tmpy*b2a,tmpz*b2a,cubmat(i,j,k)
				end do
			end do
			call showprog(k,nz)
		end do
		write(*,*)
		write(*,*) "The data have been saved to output.txt in current folder"
		write(*,"(a)") " The first three columns correspond to X,Y,Z, unit is Angstrom, the last column is data value"
		close(10)
	else if (isel==2) then
		write(*,*) "Input Z (in Angstrom) to define a XY plane, e.g. 0.52"
		read(*,*) posZ
		posZ=posZ/b2a
		rmindist=abs(orgz-posZ)
		k=1
		do icycz=2,nz
			disttmp=abs((orgz+(icycz-1)*dz)-posZ)
			if (disttmp<rmindist) then
				rmindist=disttmp
				k=icycz
			end if
		end do
		write(*,"(a,f14.6,a)") " The X-Y plane closest to your input is Z=",(orgz+(k-1)*dz)*b2a," Angstrom"
		open(10,file="output.txt",status="replace")
		do i=1,nx
			do j=1,ny
				write(10,"(3f11.6,f22.15)") (orgx+(i-1)*dx)*b2a,(orgy+(j-1)*dy)*b2a,(orgz+(k-1)*dz)*b2a,cubmat(i,j,k)
			end do
		end do
		close(10)
		write(*,*) "The data have been exported to output.txt in current folder"
		write(*,*) "The first three columns correspond to X,Y,Z, unit is Angstrom"

	else if (isel==3) then
		write(*,*) "Input X (in Angstrom) to define a YZ plane, e.g. 0.52"
		read(*,*) posX
		posX=posX/b2a
		rmindist=abs(orgx-posX)
		i=1
		do icycx=2,nx
			disttmp=abs((orgx+(icycx-1)*dx)-posX)
			if (disttmp<rmindist) then
				rmindist=disttmp
				i=icycx
			end if
		end do
		write(*,"(a,f14.6,a)") " The YZ plane closest to your input is X=",(orgx+(i-1)*dx)*b2a," Angstrom"
		open(10,file="output.txt",status="replace")
		do j=1,ny
			do k=1,nz
				write(10,"(3f11.6,f22.15)") (orgx+(i-1)*dx)*b2a,(orgy+(j-1)*dy)*b2a,(orgz+(k-1)*dz)*b2a,cubmat(i,j,k)
			end do
		end do
		close(10)
		write(*,*) "The data have been exported to output.txt in current folder"
		write(*,*) "The first three columns correspond to X,Y,Z, unit is Angstrom"

	else if (isel==4) then
		write(*,*) "Input Y (in Angstrom) to define a XZ plane, e.g. 0.52"
		read(*,*) posY
		posY=posY/b2a
		rmindist=abs(orgy-posY)
		j=1
		do icycy=2,ny
			disttmp=abs((orgy+(icycy-1)*dy)-posY)
			if (disttmp<rmindist) then
				rmindist=disttmp
				j=icycy
			end if
		end do
		write(*,"(a,f14.6,a)") " The XZ plane closest to your input is Y=",(orgy+(j-1)*dy)*b2a," Angstrom"
		open(10,file="output.txt",status="replace")
		do i=1,nx
			do k=1,nz
				write(10,"(3f11.6,f22.15)") (orgx+(i-1)*dx)*b2a,(orgy+(j-1)*dy)*b2a,(orgz+(k-1)*dz)*b2a,cubmat(i,j,k)
			end do
		end do
		close(10)
		write(*,*) "The data have been exported to output.txt in current folder"
		write(*,*) "The column 1/2/3/4 correspond to X,Y,Z,value respectively unit is Angstrom"

	else if (isel==5) then
		if (allocated(avgdata)) deallocate(avgdata)
		allocate(avgdata(nx,ny))
		avgdata=0D0
		write(*,*) "Input the range of Z (Angstrom) for XY planes, e.g. 3.0 12.4"
		read(*,*) rangelow,rangehigh
		rangelow=rangelow/b2a
		rangehigh=rangehigh/b2a
		nlayers=0
		do icyck=1,nz
			if ((orgz+(icyck-1)*dz)>rangelow.and.(orgz+(icyck-1)*dz)<rangehigh) then
				avgdata=avgdata+cubmat(:,:,icyck)
				nlayers=nlayers+1
			end if
		end do
		avgdata=avgdata/nlayers
		write(*,"(' There are ',i8,' layers within the range')") nlayers
		open(10,file="output.txt",status="replace")
		do i=1,nx
			do j=1,ny
				write(10,"(2f11.6,f22.15)") (orgx+(i-1)*dx)*b2a,(orgy+(j-1)*dy)*b2a,avgdata(i,j)
			end do
		end do
		close(10)
		write(*,*) "The data have been exported to output.txt in current folder"
		write(*,*) "Column 1,2,3 correspond to X,Y,value respectively"

	else if (isel==6) then
		if (allocated(avgdata)) deallocate(avgdata)
		allocate(avgdata(ny,nz))
		avgdata=0D0
		write(*,*) "Input the range of X (Angstrom) for YZ planes, e.g. 3.0 12.4"
		read(*,*) rangelow,rangehigh
		rangelow=rangelow/b2a
		rangehigh=rangehigh/b2a
		nlayers=0
		do icyci=1,nx
			if ((orgx+(icyci-1)*dx)>rangelow.and.(orgx+(icyci-1)*dx)<rangehigh) then
				avgdata=avgdata+cubmat(icyci,:,:)
				nlayers=nlayers+1
			end if
		end do
		avgdata=avgdata/nlayers
		write(*,"(' There are ',i8,' layers within the range')") nlayers
		open(10,file="output.txt",status="replace")
		do j=1,ny
			do k=1,nz
				write(10,"(2f11.6,f22.15)") (orgy+(j-1)*dy)*b2a,(orgz+(k-1)*dz)*b2a,avgdata(j,k)
			end do
		end do
		close(10)
		write(*,*) "The data have been exported to output.txt in current folder"
		write(*,*) "Column 1,2,3 correspond to Y,Z,value respectively"

	else if (isel==7) then
		if (allocated(avgdata)) deallocate(avgdata)
		allocate(avgdata(nx,nz))
		avgdata=0D0
		write(*,*) "Input the range of Y (Angstrom) for XZ planes, e.g. 3.0 12.4"
		read(*,*) rangelow,rangehigh
		rangelow=rangelow/b2a
		rangehigh=rangehigh/b2a
		nlayers=0
		do icycj=1,ny
			if ((orgy+(icycj-1)*dy)>=rangelow.and.(orgy+(icycj-1)*dy)<=rangehigh) then
				avgdata=avgdata+cubmat(:,icycj,:)
				nlayers=nlayers+1
			end if
		end do
		avgdata=avgdata/nlayers
		write(*,"(' There are ',i8,' layers within the range')") nlayers
		open(10,file="output.txt",status="replace")
		do i=1,nx
			do k=1,nz
				write(10,"(2f11.6,f22.15)") (orgx+(i-1)*dx)*b2a,(orgz+(k-1)*dz)*b2a,avgdata(i,k)
			end do
		end do
		close(10)
		write(*,*) "The data have been exported to output.txt in current folder"
		write(*,*) "Column 1,2,3 correspond to X,Z,value respectively"

	else if (isel==8) then
		do while(.true.)
			write(*,*) "Please input indices of three atoms to define a plane, e.g. 4,8,3"
			read(*,*) iatm1,iatm2,iatm3
			if (iatm1<=ncenter.and.iatm1>=1.and.iatm2<=ncenter.and.iatm2>=1.and.iatm3<=ncenter.and.iatm3>=1) exit
			write(*,*) "The atom indices are invalid, input again"
		end do
		useratom(1)%x=a(iatm1)%x
		useratom(1)%y=a(iatm1)%y
		useratom(1)%z=a(iatm1)%z
		useratom(2)%x=a(iatm2)%x
		useratom(2)%y=a(iatm2)%y
		useratom(2)%z=a(iatm2)%z
		useratom(3)%x=a(iatm3)%x
		useratom(3)%y=a(iatm3)%y
		useratom(3)%z=a(iatm3)%z
		write(*,"(' The coordinate (Angstrom) of the three atoms you inputted:')")
		write(*,"(' Atom 1  x, y, z:',3f12.6)") useratom(1)%x*b2a,useratom(1)%y*b2a,useratom(1)%z*b2a
		write(*,"(' Atom 2  x, y, z:',3f12.6)") useratom(2)%x*b2a,useratom(2)%y*b2a,useratom(2)%z*b2a
		write(*,"(' Atom 3  x, y, z:',3f12.6)") useratom(3)%x*b2a,useratom(3)%y*b2a,useratom(3)%z*b2a
		call doproject(useratom)
	else if (isel==9) then

		write(*,*) "Please input three points to define a plane (in Angstrom)"
		do ipt=1,3
			write(*,"('Now input x,y,z of point ',i5,'  e.g. 3.0,1.2,4.5')") ipt
			read(*,*) useratom(ipt)%x,useratom(ipt)%y,useratom(ipt)%z
		end do
		useratom%x=useratom%x/b2a !Convert to Bohr
		useratom%y=useratom%y/b2a
		useratom%z=useratom%z/b2a
		call doproject(useratom)
	else if (isel==10) then
		write(*,*) "Input the value range of data points you want to output, e.g. 0.5,0.9"
		write(*,"(a)") " Note: If the two values are identical, points with value within deviation of 3% will be outputted"
		read(*,*) rangelow,rangehigh
		if (rangelow==rangehigh) then
			rangelow=rangelow-0.03D0*abs(rangelow)
			rangehigh=rangehigh+0.03D0*abs(rangehigh)
		end if
		write(*,"(' Points with value within ',1PE13.5, ' and ',1PE13.5,' will be outputted')") rangelow,rangehigh
		write(*,*) "Outputting, please wait..."

		open(10,file="output.txt",status="replace")
		do k=1,nz
			do j=1,ny
				do i=1,nx
					if (cubmat(i,j,k)>=rangelow.and.cubmat(i,j,k)<=rangehigh) then
                        call getgridxyz(i,j,k,tmpx,tmpy,tmpz)
					    write(10,"(3f11.6,f22.15)") tmpx*b2a,tmpy*b2a,tmpz*b2a,cubmat(i,j,k)
                    end if
				end do
			end do
		end do
		close(10)
		write(*,*) "The data have been exported to output.txt in current folder"
		write(*,*) "The column 1/2/3/4 correspond to X,Y,Z,value respectively, unit is Angstrom"

	else if (isel==11) then
		write(*,*) "               --------------- Grid data calculation ------------"
		write(*,*) "0 Return"
		write(*,*) "1 Add a constant                       e.g. A+0.1=C"
		write(*,*) "2 Add a grid file                      i.e. A+B=C"
		write(*,*) "3 Subtract a constant                  e.g. A-0.1=C"
		write(*,*) "4 Subtract a grid file                 i.e. A-B=C"
		write(*,*) "5 Multiplied by a constant             e.g. A*0.1=C"
		write(*,*) "6 Multiplied by a grid file            i.e. A*B=C"
		write(*,*) "7 Divided by a constant                e.g. A/5.2=C"
		write(*,*) "8 Divided by a grid file               i.e. A/B=C"
		write(*,*) "9 Exponentiation                       e.g. A^1.3=C"
		write(*,*) "10 Square sum with a grid file         i.e. A^2+B^2=C"
		write(*,*) "11 Square subtract with a grid file    i.e. A^2-B^2=C"
		write(*,*) "12 Get average with a grid file        i.e. (A+B)/2=C"
		write(*,*) "13 Get absolute value                  i.e. |A|=C"
		write(*,*) "14 Get exponential value with base 10  i.e. 10^A=C"
		write(*,*) "15 Get logarithm with base 10          i.e. log10(A)=C"
		write(*,*) "16 Get natural exponential value       i.e. e^A=C"
		write(*,*) "17 Get natural logarithm               i.e. ln(A)=C"
		write(*,*) "18 Add a grid file multiplied by a value  i.e. A+0.4*B=C"
		write(*,*) "19 The same as 6 but with weighting function min(|A|,|B|)/max(|A|,|B|)"
		write(*,*) "20 Multiplied by a coordinate variable"
		write(*,*) "21 Get minimal value with another function    i.e. min(A,B)"
		write(*,*) "22 Get min(|A|,|B|)"
		read(*,*) isel2

		if (isel2==0) then
			continue
		else if (isel2==1.or.isel2==3.or.isel2==5.or.isel2==7.or.isel2==9) then
			write(*,*) "Input the value for the calculation, e.g. 2.3"
			read(*,*) calconstant
			if (isel2==1) cubmat=cubmat+calconstant
			if (isel2==3) cubmat=cubmat-calconstant
			if (isel2==5) cubmat=cubmat*calconstant
			if (isel2==7) cubmat=cubmat/calconstant
			if (isel2==9) cubmat=cubmat**calconstant
		else if (isel2==2.or.isel2==4.or.isel2==6.or.isel2==8.or.isel2==10.or.isel2==11.or.isel2==12.or.isel2==18.or.isel2==19.or.isel2==21.or.isel2==22) then
			do while(.true.)
				write(*,*) "Input another file containing grid data (.cub, .grd or CHGCAR/CHG)"
                write(*,*) "e.g. C:\mius\Umi.cub"
				read(*,"(a)") gridfile2
				inquire(file=gridfile2,exist=alive)
				if (alive) exit
				write(*,*) "File not found, input again"
				write(*,*)
			end do
			inamelen=len_trim(gridfile2)
			if (gridfile2(inamelen-2:inamelen)=="cub".or.gridfile2(inamelen-3:inamelen)=="cube") then
				call readcubetmp(gridfile2,1,inconsis)
			else if (gridfile2(inamelen-2:inamelen)=="grd") then
				call readgrdtmp(gridfile2,inconsis)
			else if (index(gridfile2,"CHG")/=0) then
				call readVASPgrdtmp(gridfile2,inconsis)
			end if
			if (inconsis==1) cycle
			if (isel2==2) cubmat=cubmat+cubmattmp
			if (isel2==4) cubmat=cubmat-cubmattmp
			if (isel2==6) cubmat=cubmat*cubmattmp
			if (isel2==8) cubmat=cubmat/cubmattmp
			if (isel2==10) cubmat=cubmat**2+cubmattmp**2
			if (isel2==11) cubmat=cubmat**2-cubmattmp**2
			if (isel2==12) cubmat=(cubmat+cubmattmp)/2D0
			if (isel2==19) cubmat=cubmat*cubmattmp*min(abs(cubmat),abs(cubmattmp)) / max(abs(cubmat),abs(cubmattmp))
			if (isel2==21) cubmat=min(cubmat,cubmattmp)
			if (isel2==22) cubmat=min(abs(cubmat),abs(cubmattmp))

			if (isel2==18) then
				write(*,*) "Input the value to be multiplied to the just loaded cube file"
				read(*,*) tmpval
				cubmat=cubmat+tmpval*cubmattmp
			end if
			deallocate(cubmattmp)
		else if (isel2==13) then
			cubmat=abs(cubmat)
		else if (isel2==14) then
			cubmat=10**cubmat
		else if (isel2==15) then
			cubmat=log10(cubmat)
		else if (isel2==16) then
			cubmat=exp(cubmat)
		else if (isel2==17) then
			cubmat=log(cubmat)
		else if (isel2==20) then
			write(*,*) "Multiplied by which variable? Input ""X"" or ""Y"" or ""Z"""
			read(*,*) tmpchar
		    do k=1,nz
			    do j=1,ny
				    do i=1,nx
                        call getgridxyz(i,j,k,tmpx,tmpy,tmpz)
					    if (tmpchar=='x'.or.tmpchar=='X') then
                            cubmat(i,j,k)=cubmat(i,j,k)*tmpx
                        else if (tmpchar=='y'.or.tmpchar=='Y') then
                            cubmat(i,j,k)=cubmat(i,j,k)*tmpy
                        else if (tmpchar=='z'.or.tmpchar=='Z') then
                            cubmat(i,j,k)=cubmat(i,j,k)*tmpz
                        end if
				    end do
			    end do
		    end do
		end if
		if (isel2/=0) write(*,*) "Done, the grid data has been updated"

	else if (isel==12) then
		write(*,*) "Input a value to define a isosurface of present grid data, e.g. 0.001"
		read(*,*) value_ref
		write(*,*) "Input allowed deviation (%)   e.g. 4"
		read(*,*) deviation
		rangehigh=value_ref+abs(value_ref)*0.01D0*deviation
		rangelow=value_ref-abs(value_ref)*0.01D0*deviation
		write(*,"(' Value between ',1PE13.5, ' and ',1PE13.5,' are regarded as isosurface points')") rangelow,rangehigh

		do while(.true.)
			write(*,*) "Map which grid file to the isosurface?  e.g. C:\t.cub"
			read(*,"(a)") gridfile2
			inquire(file=gridfile2,exist=alive)
			if (alive) exit
			write(*,*) "File not found, input again"
			write(*,*)
		end do
		call readcubetmp(gridfile2,1,inconsis)
		open(10,file="output.txt",status="replace")
        do k=1,nz
			do j=1,ny
		        do i=1,nx
					if (cubmat(i,j,k)>=rangelow.and.cubmat(i,j,k)<=rangehigh) then
                        call getgridxyz(i,j,k,tmpx,tmpy,tmpz)
					    write(10,"(3f11.6,f22.15)") tmpx*b2a,tmpy*b2a,tmpz*b2a,cubmattmp(i,j,k)
                    end if
				end do
			end do
		end do
		close(10)
		write(*,"(a)") "The mapped data on the isosurface have been exported to output.txt in current folder"
		write(*,*) "The column 1/2/3/4 correspond to X,Y,Z,value respectively, unit is Angstrom"
		deallocate(cubmattmp)

	else if (isel==13) then
		write(*,*) "Input the value for scaling vdW radius  e.g. 1.3"
		write(*,"(a)") " Note: Inputting a positive(negative) value means the grid points outside(inside) the distance cutoff will be set to a given value"
		read(*,*) vdwscale
		write(*,*) "Set to what value? e.g. 100"
		read(*,*) setval
		write(*,*) "Select mode of inputting atomic indices"
		write(*,*) "1 Load atomic indices from a plain text file"
		write(*,*) "2 Inputting atomic indices by hand"
		read(*,*) imodinput
		if (imodinput==1) then
			write(*,*) "Input the filename that recorded atom indices, e.g. C:\niconiconi\atmlist.txt"
			do while(.true.)
				read(*,"(a)") atmidxfile
				inquire(file=atmidxfile,exist=alive)
				if (alive) exit
				write(*,*) "Cannot find the file, input again"
			end do
			open(10,file=atmidxfile,status="old")
			read(10,*) numatmidx
			allocate(atmlist(numatmidx))
			read(10,*) atmlist
			close(10)
		else if (imodinput==2) then
			write(*,*) "Input atomic indices, e.g. 3,5,7-20,25"
			read(*,"(a)") c2000tmp
			call str2arr(c2000tmp,numatmidx)
			allocate(atmlist(numatmidx))
			call str2arr(c2000tmp,numatmidx,atmlist)
		end if

		do k=1,nz
			do j=1,ny
				do i=1,nx
                    call getgridxyz(i,j,k,xnow,ynow,znow)
					if (vdwscale>0) then
						do ind=1,numatmidx
							iatm=atmlist(ind)
							dist2=(xnow-a(iatm)%x)**2+(ynow-a(iatm)%y)**2+(znow-a(iatm)%z)**2
							if (dist2< (vdwscale*vdwr(a(iatm)%index))**2 ) exit !If this point is near any atom in the list, it will be unchanged
							if (ind==numatmidx) cubmat(i,j,k)=setval !Final cycle, suggests that this point is outside any atom in the list, set its value
						end do
					else if (vdwscale<0) then
						do ind=1,numatmidx
							iatm=atmlist(ind)
							dist2=(xnow-a(iatm)%x)**2+(ynow-a(iatm)%y)**2+(znow-a(iatm)%z)**2
							if (dist2< (vdwscale*vdwr(a(iatm)%index))**2 ) then
								cubmat(i,j,k)=setval
								exit
							end if
						end do
					end if
				end do
			end do
		end do
		if (vdwscale>0) write(*,"(a,f10.6,a,E16.8)") " Done! The value of all points ouside",abs(vdwscale)," times vdW radius of specified atoms have been set to",setval
		if (vdwscale<0) write(*,"(a,f10.6,a,E16.8)") " Done! The value of all points inside",abs(vdwscale)," times vdW radius of specified atoms have been set to",setval
		deallocate(atmlist)

	else if (isel==14) then
		write(*,*) "Input the value for scaling vdW radius  e.g. 1.3"
		read(*,*) vdwscale
		write(*,*) "Set to what value?"
		read(*,*) setval
		write(*,*) "Select mode of inputting atomic indices"
		write(*,*) "1 Load atomic indices from a plain text file"
		write(*,*) "2 Inputting atomic indices by hand"
		read(*,*) imodinput
		if (imodinput==1) then
			write(*,*) "Input path of the file recording atom indices of fragment 1"
			write(*,*) "e.g. C:\nicomaki\frag1.txt"
			do while(.true.)
				read(*,"(a)") atmidxfile
				inquire(file=atmidxfile,exist=alive)
				if (alive) exit
				write(*,*) "Cannot find the file, input again"
			end do
			write(*,*) "Input path of the file recording atom indices of fragment 2"
			write(*,*) "e.g. C:\nicomaki\frag2.txt"
			do while(.true.)
				read(*,"(a)") atmidxfile2
				inquire(file=atmidxfile2,exist=alive)
				if (alive) exit
				write(*,*) "Cannot find the file, input again"
			end do

			open(10,file=atmidxfile,status="old")
			read(10,*) numatmidx
			allocate(atmlist(numatmidx))
			read(10,*) atmlist
			close(10)
			open(10,file=atmidxfile2,status="old")
			read(10,*) numatmidx2
			allocate(atmlist2(numatmidx2))
			read(10,*) atmlist2
			close(10)
		else if (imodinput==2) then
			write(*,*) "Input atomic indices for fragment 1, e.g. 3,5,7-20,25"
			read(*,"(a)") c2000tmp
			call str2arr(c2000tmp,numatmidx)
			allocate(atmlist(numatmidx))
			call str2arr(c2000tmp,numatmidx,atmlist)
			write(*,*) "Input atomic indices for fragment 2, e.g. 3,5,7-20,25"
			read(*,"(a)") c2000tmp
			call str2arr(c2000tmp,numatmidx2)
			allocate(atmlist2(numatmidx2))
			call str2arr(c2000tmp,numatmidx2,atmlist2)
		end if

		do k=1,nz
			do j=1,ny
				do i=1,nx
                    call getgridxyz(i,j,k,xnow,ynow,znow)
					iwithoutfrag1=0
					do ind=1,numatmidx
						iatm=atmlist(ind)
						dist2=(xnow-a(iatm)%x)**2+(ynow-a(iatm)%y)**2+(znow-a(iatm)%z)**2
						if (dist2< (vdwscale*vdwr(a(iatm)%index))**2 ) exit
						if (ind==numatmidx) iwithoutfrag1=1
					end do
					if (iwithoutfrag1==1) then !This point is without fragment 1, hence mustn't be within overlap of frag.1 and 2, so set its value now
						cubmat(i,j,k)=setval
					else !This point is within fragment 1, check if it is also within fragment 2, if yes then lzeave it unchanged, else set its value
						do ind=1,numatmidx2
							iatm=atmlist2(ind)
							dist2=(xnow-a(iatm)%x)**2+(ynow-a(iatm)%y)**2+(znow-a(iatm)%z)**2
							if (dist2< (vdwscale*vdwr(a(iatm)%index))**2 ) exit
							if (ind==numatmidx2) cubmat(i,j,k)=setval !Final cycle, suggest this point is simutaneously without fragment 1 and 2
						end do
					end if
				end do
			end do
		end do
		write(*,"(a,1PE16.8)") " Done! The value of all points outside overlap region of fragment 1 and 2 have been set to",setval
		deallocate(atmlist,atmlist2)

	else if (isel==15) then
		write(*,*) "Input lower limit and upper limit  e.g. 3.9,4.2"
		read(*,*) flow,fhigh
		write(*,"(' If the value >= ',E15.8,' and <=',E15.8,', set it to what value?')") flow,fhigh
		read(*,*) calconstant
		where (cubmat>=flow.and.cubmat<=fhigh) cubmat=calconstant

	else if (isel==16) then !Scale certain range of original data to specified range
		write(*,*) "Input lower and upper limit of original data range, e.g. 0,1.5"
		write(*,"(a)") " Note: If input 0,0 then minimum and maximum value of present grid data will be used"
		read(*,*) orglow,orgup
		if (orglow==0D0.and.orgup==0D0) then
			orglow=minval(cubmat)
			orgup=maxval(cubmat)
		end if
		write(*,*) "Input lower and upper limit of new data range, e.g. 0,255"
		read(*,*) rnewlow,rnewup
		where (cubmat>orgup) cubmat=orgup
		where (cubmat<orglow) cubmat=orglow
		cubmat=cubmat-orglow
		ratiofac=(rnewup-rnewlow)/(orgup-orglow)
		cubmat=cubmat*ratiofac
		cubmat=cubmat+rnewlow
		write(*,*) "Done!"

	else if (isel==17) then
		call gridmaxxyz(rhighx,rhighy,rhighz)
		call gridminxyz(rlowx,rlowy,rlowz)
		rlowv=minval(cubmat)
		rhighv=maxval(cubmat)
		write(*,*) "1 Obtain statistic data for all grid points"
		write(*,*) "2 Obtain statistic data for grid points in specific spatial and value range"
		read(*,*) iselrange
		if (iselrange==2) then
			write(*,"(a)") " Input the lower and upper limits of X coordinate (in Angstrom), e.g. -40,33.5"
            write(*,*) "If you don't want to set constraint, input ""a"""
			read(*,"(a)") c200tmp
			if (index(c200tmp,'a')/=0) then
				read(c200tmp,*) rlowx,rhighx
				rlowx=rlowx/b2a
				rhighx=rhighx/b2a
			end if
			write(*,"(a)") " Input the lower and upper limits of Y coordinate (in Angstrom)"
            write(*,*) "If you do not want to set this constraint, input ""a"""
			read(*,"(a)") c200tmp
			if (index(c200tmp,'a')/=0) then
				read(c200tmp,*) rlowy,rhighy
				rlowy=rlowy/b2a
				rhighy=rhighy/b2a
			end if
			write(*,"(a)") " Input the lower and upper limits of Z coordinate (in Angstrom), e.g. -40,33.5"
            write(*,*) "If you do not want to set this constraint, input ""a"""
			read(*,"(a)") c200tmp
			if (index(c200tmp,'a')/=0) then
				read(c200tmp,*) rlowz,rhighz
				rlowz=rlowz/b2a
				rhighz=rhighz/b2a
			end if
			write(*,"(a)") " Input the lower and upper limits of value, e.g. -2,3.25"
            write(*,*) "If you do not want to set this constraint, input ""a"""
			read(*,"(a)") c200tmp
			if (index(c200tmp,'a')/=0) read(c200tmp,*) rlowv,rhighv
		end if

		write(*,*) "The geometry and value range for statistics"
		write(*,"(' Lower and upper limit of X:',2f14.8,' Bohr')") rlowx,rhighx
		write(*,"(' Lower and upper limit of Y:',2f14.8,' Bohr')") rlowy,rhighy
		write(*,"(' Lower and upper limit of Z:',2f14.8,' Bohr')") rlowz,rhighz
		write(*,"(' Lower and upper limit of value:',2E20.10)") rlowv,rhighv
		write(*,*)
		maxv%value=cubmat(1,1,1)
		maxv%x=orgx
		maxv%y=orgy
		maxv%z=orgz
		minv%value=cubmat(1,1,1)
		minv%x=orgx
		minv%y=orgy
		minv%z=orgz
		sumuppos=0D0
		sumupneg=0D0
		cenxpos=0D0
		cenypos=0D0
		cenzpos=0D0
		cenxneg=0D0
		cenyneg=0D0
		cenzneg=0D0
		igoodpointpos=0
		igoodpointneg=0
		sumupsqrtot=0
		do k=1,nz
			do j=1,ny
				do i=1,nx
                    call getgridxyz(i,j,k,tmpx,tmpy,tmpz)
			        if (tmpx<rlowx.or.tmpx>rhighx) cycle
				    if (tmpy<rlowy.or.tmpy>rhighy) cycle
					if (tmpz<rlowz.or.tmpz>rhighz) cycle
					valtmp=cubmat(i,j,k)
					if (valtmp<rlowv.or.valtmp>rhighv) cycle
					if (valtmp>0) then
						sumuppos=sumuppos+valtmp
						cenxpos=cenxpos+tmpx*valtmp
						cenypos=cenypos+tmpy*valtmp
						cenzpos=cenzpos+tmpz*valtmp
						igoodpointpos=igoodpointpos+1
					else if (valtmp<0) then
						sumupneg=sumupneg+valtmp
						cenxneg=cenxneg+tmpx*valtmp
						cenyneg=cenyneg+tmpy*valtmp
						cenzneg=cenzneg+tmpz*valtmp
						igoodpointneg=igoodpointneg+1
					end if
					if (valtmp>maxv%value) then
						maxv%value=cubmat(i,j,k)
						call getgridxyz(i,j,k,maxv%x,maxv%y,maxv%z)
					end if
					if (valtmp<minv%value) then
						minv%value=cubmat(i,j,k)
						call getgridxyz(i,j,k,minv%x,minv%y,minv%z)
					end if
					sumupsqrtot=sumupsqrtot+valtmp**2
				end do
			end do
		end do
		sumuptot=sumuppos+sumupneg
		cenxtot=(cenxpos+cenxneg)/sumuptot
		cenytot=(cenypos+cenyneg)/sumuptot
		cenztot=(cenzpos+cenzneg)/sumuptot
		cenxpos=cenxpos/sumuppos
		cenypos=cenypos/sumuppos
		cenzpos=cenzpos/sumuppos
		cenxneg=cenxneg/sumupneg
		cenyneg=cenyneg/sumupneg
		cenzneg=cenzneg/sumupneg
		numpt=nx*ny*nz
        call calc_dvol(dvol)
		avgtot=sumuptot/numpt
		stddev=0
		!Calculate standard deviation
		do k=1,nz
			do j=1,ny
				do i=1,nx
                    call getgridxyz(i,j,k,tmpx,tmpy,tmpz)
			        if (tmpx<rlowx.or.tmpx>rhighx) cycle
				    if (tmpy<rlowy.or.tmpy>rhighy) cycle
					if (tmpz<rlowz.or.tmpz>rhighz) cycle
					if (valtmp<rlowv.or.valtmp>rhighv) cycle
					stddev=stddev+(cubmat(i,j,k)-avgtot)**2
				end do
			end do
		end do
		stddev=dsqrt(stddev/numpt)
		write(*,"(' The minimum value:',E16.8,' at',3f12.6,' Bohr')") minv%value,minv%x,minv%y,minv%z
		write(*,"(' The maximum value:',E16.8,' at',3f12.6,' Bohr')") maxv%value,maxv%x,maxv%y,maxv%z
		write(*,"(' Differential element:',f15.10,' Bohr^3')") dvol
		write(*,"(' Average value:',E16.8)") avgtot
		write(*,"(' Root mean square (RMS):',E16.8)") dsqrt(sumupsqrtot/numpt)
		write(*,"(' Standard deviation:',E16.8)") stddev
		write(*,*)
		write(*,"(' Volume of positive value space:',f30.10,' Bohr^3')") igoodpointpos*dvol
		write(*,"(' Volume of negative value space:',f30.10,' Bohr^3')") igoodpointneg*dvol
		write(*,"(' Volume of all space:           ',f30.10,' Bohr^3')") (igoodpointpos+igoodpointneg)*dvol
		write(*,*)
		write(*,"(' Summing up positive values:',f30.10)") sumuppos
		write(*,"(' Summing up negative values:',f30.10)") sumupneg
		write(*,"(' Summing up all values:     ',f30.10)") sumuptot
		write(*,*)
		write(*,"(' Integral of positive data:',f30.10)") sumuppos*dvol
		write(*,"(' Integral of negative data:',f30.10)") sumupneg*dvol
		write(*,"(' Integral of all data:     ',f30.10)") sumuptot*dvol
		write(*,*)
		write(*,"(' X,Y,Z of barycenter (in Bohr)')")
		write(*,"(' Positive part:',3f20.8)") cenxpos,cenypos,cenzpos
		write(*,"(' Negative part:',3f20.8)") cenxneg,cenyneg,cenzneg
		!If positive and negative cancel each other exactly, namely sumuptot is about zero, total barycenter will be infinitely large
		if (abs(sumuptot)>0.001D0) write(*,"(' Total:        ',3f20.8)") cenxtot,cenytot,cenztot

	else if (isel==18) then !Integral curve
        call drawintcurve
	end if
end do
end subroutine

!!----------- Project grid data to a specified plane, selectly project to XY plane, then output to plain text file
subroutine doproject(useratom)
use defvar
use procgridmod
implicit real*8(a-h,o-z)
type(content) vec1,vec2,vec3,useratom(3),pttemp,point1,point2,cubmatpt
type(content),allocatable :: planedata(:)
type(pleequa) userplane
integer flipmethod
vec1=vecfrom2p(useratom(1),useratom(2))
vec2=vecfrom2p(useratom(1),useratom(3))
vec3=vecmul(vec1,vec2)  !normal vector of userplane!!!
userplane%a=vec3%x  !ax+by+cz+d=0
userplane%b=vec3%y
userplane%c=vec3%z
userplane%d=-vec3%x*useratom(1)%x-vec3%y*useratom(1)%y-vec3%z*useratom(1)%z
cosang=cos_2v(content(0,0,1,0),vec3) !cos between userplane and XY plane
ang=2*180*acos(cosang)/(2D0*pi)
write(*,"(' The angle between your defined plane and XY plane is ',f6.2,' degrees')") ang

if (userplane%a==0.and.userplane%b==0) then
	write(*,"(' Warning: You defined plane is parallel to XY plane, use function 2 instead! Now exit...')")
	return
else if (userplane%b==0.and.userplane%c==0) then
	write(*,"(' Warning: You defined plane is parallel to YZ plane, use function 3 instead! Now exit...')")
	return
else if (userplane%a==0.and.userplane%c==0) then
	write(*,"(' Warning: You defined plane is parallel to XZ plane, use function 4 instead! Now exit...')")
	return
end if

distoler=dsqrt(dx**2+dy**2+dz**2)/4D0  !Default tolerance distance between grid to userplane
write(*,*)
write(*,"(' Input tolerance distance for projecting grids to your defined plane, unit is Angstrom. (Note: You can input 0 to use recommended value: ',f9.4,' Angstrom)')") distoler*b2a
read(*,*) temp
temp=temp/b2a
if (temp/=0) distoler=temp

allocate(planedata(nx*ny*nz))
npt=0
do k=1,nz
	do j=1,ny
		do i=1,nx
			cubmatpt%value=cubmat(i,j,k)
            call getgridxyz(i,j,k,cubmatpt%x,cubmatpt%y,cubmatpt%z)
			pttemp=protoplane_pos(cubmatpt,userplane,vec3)  !Project original data a(i,j,k) to userplane
			if (dist2p(pttemp,cubmatpt)<distoler) then
				npt=npt+1
				planedata(npt)=pttemp
			end if
		end do
	end do
end do
write(*,"(i10,' points are presented in the plane you defined')") npt

write(*,*) "If projecting data to XY plane? 1=yes 2=no"
read(*,*) itest

if (itest==1) then
	point1%x=1
	point1%y=(-userplane%d-userplane%a*point1%x)/userplane%b  !find arbitrary two points(x=1 and x=2) in userplane and XY plane(Z=0) crossing
	point1%z=0
	point2%x=2
	point2%y=(-userplane%d-userplane%a*point2%x)/userplane%b
	point2%z=0
	vec1=vecfrom2p(point1,point2)  !crossing vector of XY plane and userplane
	detvalue=det2_2(vec1%x, vec1%y, userplane%a, userplane%b)
	scalex=abs(vec3%x)/dsqrt(vec3%x**2+vec3%y**2)  !The ratio of x component to norm of vec3. scalex/y have direction, namely positive or negative sign
	scaley=abs(vec3%y)/dsqrt(vec3%x**2+vec3%y**2)

	if (ang>80) then
		flipmethod=1
	else
		flipmethod=0
	end if

	do i=1,npt
!Use Cramer law to find a point (point1) in crossing vector (namely vec1) of userplane and XY plane
!point1 fulfill two condition (of course, its z=0, since it is laying on XY plane):
!(1) The vector of point1 to planedata(n) is vertical to crossing vector (2)the point is in userplane. so we can use cramer law to solve linear equation to get point1
		point1%x=det2_2(vec1%x*planedata(i)%x+vec1%y*planedata(i)%y, vec1%y, -userplane%d, userplane%b)/detvalue
		point1%y=det2_2(vec1%x, vec1%x*planedata(i)%x+vec1%y*planedata(i)%y, userplane%a, -userplane%d)/detvalue
		temp2=dist2p(planedata(i),point1) - dist2p(planedata(i),point1)*cosang !temp2 is distance between point1 and original grid point i

		if (flipmethod==0) then
			if (planedata(i)%x>point1%x) then       ! used to determine adding direction
				planedata(i)%x=planedata(i)%x+scalex*temp2
			else
				planedata(i)%x=planedata(i)%x-scalex*temp2
			end if
			if (planedata(i)%y>point1%y) then
				planedata(i)%y=planedata(i)%y+scaley*temp2
			else
				planedata(i)%y=planedata(i)%y-scaley*temp2
			end if
		else !Angle near 90 degree
			if (userplane%a*userplane%b>0) then
				if (planedata(i)%z>0) then
					planedata(i)%x=point1%x+dist2p(planedata(i),point1)*scalex
					planedata(i)%y=point1%y+dist2p(planedata(i),point1)*scaley
				else
					planedata(i)%x=point1%x-dist2p(planedata(i),point1)*scalex
					planedata(i)%y=point1%y-dist2p(planedata(i),point1)*scaley
				end if
			else
				if (planedata(i)%z>0) then
					planedata(i)%x=point1%x-dist2p(planedata(i),point1)*scalex
					planedata(i)%y=point1%y+dist2p(planedata(i),point1)*scaley
				else
					planedata(i)%x=point1%x+dist2p(planedata(i),point1)*scalex
					planedata(i)%y=point1%y-dist2p(planedata(i),point1)*scaley
				end if
			end if
		end if
		planedata(i)%z=0
	end do
end if

open(10,file="output.txt",status="replace")
do i=1,npt
	write(10,"(3f11.6,f22.15)") planedata(i)%x*b2a,planedata(i)%y*b2a,planedata(i)%z*b2a,planedata(i)%value
end do
close(10)
write(*,*) "Completed!"
write(*,"(' In the output.txt, column 1/2/3/4 correspond to x/y/z/value respectively, unit is Angstrom')")
deallocate(planedata)
end subroutine

!!------- Integrate grid data along a direction to obtain integral curve
subroutine drawintcurve
use defvar
use util
use GUI
implicit real*8 (a-h,o-z)
character c200tmp*200
real*8,allocatable :: intcurve(:),locintcurve(:),intcurvepos(:)

if (gridv1(2)==0.and.gridv1(3)==0) then !Can integrate along X axis
    continue
else if (gridv2(1)==0.and.gridv2(3)==0) then !Can integrate along Y axis
    continue
else if (gridv3(1)==0.and.gridv3(2)==0) then !Can integrate along Z axis
    continue
else
    write(*,"(a)") "Error: This function cannot be used for present grid. The grid must satisfy at least one below conditions"
    write(*,*) "1 Grid vector 1 is parallel along X axis and the other two are in YZ plane"
    write(*,*) "2 Grid vector 2 is parallel along Y axis and the other two are in XZ plane"
    write(*,*) "3 Grid vector 3 is parallel along Z axis and the other two are in XY plane"
    write(*,*) "Press ENTER button to continue"
    read(*,*)
    return
end if

write(*,*) "Integrating in which direction? Input ""X"" or ""Y"" or ""Z"""
read(*,*) c200tmp
if (index(c200tmp,'X')/=0.or.index(c200tmp,'x')/=0) idir=1
if (index(c200tmp,'Y')/=0.or.index(c200tmp,'y')/=0) idir=2
if (index(c200tmp,'Z')/=0.or.index(c200tmp,'z')/=0) idir=3
if (idir==1) then
    if (gridv1(2)==0.and.gridv1(3)==0.and.sum(gridv1*gridv2)==0.and.sum(gridv1*gridv3)==0) then
        continue
    else
        write(*,"(a)") " Error: To integrate along X axis, grid vector 1 is must be parallel &
        along X axis and the other two are in YZ plane. The present grid does not meet this conditions"
        write(*,*) "Press ENTER button to continue"
        read(*,*)
        return
    end if
else if (idir==2) then
    if (gridv2(1)==0.and.gridv2(3)==0.and.sum(gridv2*gridv1)==0.and.sum(gridv2*gridv3)==0) then
        continue
    else
        write(*,"(a)") " Error: To integrate along Y axis, grid vector 2 is must be parallel &
        along Y axis and the other two are in XZ plane. The present grid does not meet this conditions"
        write(*,*) "Press ENTER button to continue"
        read(*,*)
        return
    end if
else if (idir==3) then
    if (gridv3(1)==0.and.gridv3(2)==0.and.sum(gridv3*gridv1)==0.and.sum(gridv3*gridv2)==0) then
        continue
    else
        write(*,"(a)") " Error: To integrate along Z axis, grid vector 3 is must be parallel &
        along Z axis and the other two are in XY plane. The present grid does not meet this conditions"
        write(*,*) "Press ENTER button to continue"
        read(*,*)
        return
    end if
end if

write(*,*) "Input lower and upper limits of the position (in Angstrom), e.g. -30,51.5"
write(*,*) "Input ""a"" can choose the entire range"
read(*,"(a)") c200tmp
if (index(c200tmp,"a")==0) then
	read(c200tmp,*) rlow,rhigh
	rlow=rlow/b2a
	rhigh=rhigh/b2a
end if
write(*,*) "Calculating data..."
tmpintval=0
if (idir==1) then !Direction 1
	allocate(intcurve(nx),locintcurve(nx),intcurvepos(nx))
	intcurve=0
	locintcurve=0
	ncurpt=nx
    v1len=dsqrt(sum(gridv1**2))
	if (index(c200tmp,"a")/=0) then
		rlow=orgx
		rhigh=orgx+(nx-1)*v1len
	end if
	do ix=1,nx
		intcurvepos(ix)=orgx+(ix-1)*v1len
		if (intcurvepos(ix)<rlow.or.intcurvepos(ix)>rhigh) cycle
        call vec2area(gridv2(:),gridv3(:),area)
		locintcurve(ix)=sum(cubmat(ix,:,:))*area
		tmpintval=tmpintval+locintcurve(ix)*v1len
		intcurve(ix)=tmpintval
	end do
else if (idir==2) then !Direction 2
	allocate(intcurve(ny),locintcurve(ny),intcurvepos(ny))
	intcurve=0
	locintcurve=0
	ncurpt=ny
    v2len=dsqrt(sum(gridv2**2))
	if (index(c200tmp,"a")/=0) then
		rlow=orgy
		rhigh=orgy+(ny-1)*v2len
	end if
	do iy=1,ny
		intcurvepos(iy)=orgy+(iy-1)*v2len
		if (intcurvepos(iy)<rlow.or.intcurvepos(iy)>rhigh) cycle
        call vec2area(gridv1(:),gridv3(:),area)
		locintcurve(iy)=sum(cubmat(:,iy,:))*area
		tmpintval=tmpintval+locintcurve(iy)*v2len
		intcurve(iy)=tmpintval
	end do
else if (idir==3) then !Direction 3
	allocate(intcurve(nz),locintcurve(nz),intcurvepos(nz))
	intcurve=0
	locintcurve=0
	ncurpt=nz
    v3len=dsqrt(sum(gridv3**2))
	if (index(c200tmp,"a")/=0) then
		rlow=orgz
		rhigh=orgz+(nz-1)*v3len
	end if
	do iz=1,nz
		intcurvepos(iz)=orgz+(iz-1)*v3len
		if (intcurvepos(iz)<rlow.or.intcurvepos(iz)>rhigh) cycle
        call vec2area(gridv1(:),gridv2(:),area)
		locintcurve(iz)=sum(cubmat(:,:,iz))*area
		tmpintval=tmpintval+locintcurve(iz)*v3len
		intcurve(iz)=tmpintval
	end do
end if
do while(.true.)
	write(*,*)
	if (ilenunit1D==1) write(*,*) "-1 Change length unit of the graph to Angstrom"
	if (ilenunit1D==2) write(*,*) "-1 Change length unit of the graph to Bohr"
	write(*,*) "0 Return"
	write(*,*) "1 Plot graph of integral curve"
	write(*,*) "2 Plot graph of local integral curve"
	write(*,*) "3 Save graph of integral curve to current folder"
	write(*,*) "4 Save graph of local integral curve to current folder"
	write(*,*) "5 Export data of integral curve to intcurve.txt in current folder"
	write(*,*) "6 Export data of local integral curve to locintcurve.txt in current folder"
	read(*,*) isel2
	if (isel2==-1) then
		if (ilenunit1D==1) then
			ilenunit1D=2
		else if (ilenunit1D==2) then
			ilenunit1D=1
		end if
	else if (isel2==0) then
		exit
	else if (isel2==1.or.isel2==3) then
		disminmax=maxval(intcurve)-minval(intcurve)
		ylow=minval(intcurve)-0.1D0*disminmax
		yhigh=maxval(intcurve)+0.1D0*disminmax
		stplabx=(rhigh-rlow)/10
		stplaby=(yhigh-ylow)/10
		if (isel2==1) call drawcurve(intcurvepos,intcurve,ncurpt,rlow,rhigh,stplabx,ylow,yhigh,stplaby,"show")
		if (isel2==3) call drawcurve(intcurvepos,intcurve,ncurpt,rlow,rhigh,stplabx,ylow,yhigh,stplaby,"save")
	else if (isel2==2.or.isel2==4) then
		disminmax=maxval(locintcurve)-minval(locintcurve)
		ylow=minval(locintcurve)-0.1D0*disminmax
		yhigh=maxval(locintcurve)+0.1D0*disminmax
		stplabx=(rhigh-rlow)/10
		stplaby=(yhigh-ylow)/10
		if (isel2==2) call drawcurve(intcurvepos,locintcurve,ncurpt,rlow,rhigh,stplabx,ylow,yhigh,stplaby,"show")
		if (isel2==4) call drawcurve(intcurvepos,locintcurve,ncurpt,rlow,rhigh,stplabx,ylow,yhigh,stplaby,"save")
	else if (isel2==5) then
		open(10,file="intcurve.txt",status="replace")
		do ipt=1,ncurpt
			if (intcurvepos(ipt)<rlow.or.intcurvepos(ipt)>rhigh) cycle
			write(10,"(2f14.8,f20.10)") intcurvepos(ipt),intcurvepos(ipt)*b2a,intcurve(ipt)
		end do
		close(10)
		write(*,"(a)") " Done! 1,2,3 columns correspond to the coordinate (in Bohr and in Angstrom) in the direction you selected and the integral, respectively"
	else if (isel2==6) then
		open(10,file="locintcurve.txt",status="replace")
		do ipt=1,ncurpt
			if (intcurvepos(ipt)<rlow.or.intcurvepos(ipt)>rhigh) cycle
			write(10,"(2f14.8,f20.10)") intcurvepos(ipt),intcurvepos(ipt)*b2a,locintcurve(ipt)
		end do
		close(10)
		write(*,"(a)") " Done! 1,2,3 columns correspond to the coordinate (in Bohr and in Angstrom) in the direction you selected and the local integral, respectively"
	end if
end do
end subroutine


      SUBROUTINE BCUINT(Y,Y1,Y2,Y12,X1L,X1U,X2L,X2U,X1,X2,ANSY,ANSY1,ANS
     *Y2)
      DIMENSION Y(4),Y1(4),Y2(4),Y12(4),C(4,4)
      CALL BCUCOF(Y,Y1,Y2,Y12,X1U-X1L,X2U-X2L,C)
      IF(X1U.EQ.X1L.OR.X2U.EQ.X2L)PAUSE 'bad input'
      T=(X1-X1L)/(X1U-X1L)
      U=(X2-X2L)/(X2U-X2L)
      ANSY=0.
      ANSY2=0.
      ANSY1=0.
      DO 11 I=4,1,-1
        ANSY=T*ANSY+((C(I,4)*U+C(I,3))*U+C(I,2))*U+C(I,1)
        ANSY2=T*ANSY2+(3.*C(I,4)*U+2.*C(I,3))*U+C(I,2)
        ANSY1=U*ANSY1+(3.*C(4,I)*T+2.*C(3,I))*T+C(2,I)
11    CONTINUE
      ANSY1=ANSY1/(X1U-X1L)
      ANSY2=ANSY2/(X2U-X2L)
      RETURN
      END


C
C $Id: wtproj.f,v 1.4 2008-09-18 00:42:18 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE WTPROJ (DLAT,DLON,UVAL,VVAL,CSLT)
C
        DOUBLE PRECISION DLAT,DLON,UVAL,VVAL,CSLT
C
C The subroutine WTPROJ implements a closed form of the Winkel tripel
C projection, using formulas identical to those given on various Web
C sites (for example, Wikipedia), using the rather odd function SINC(X),
C the value of which is SIN(X)/X, when X is not zero, and 1, otherwise.
C For efficiency, this function is incorporated into the local code.
C
C DLAT and DLON are input values of latitude and longitude, in radians.
C UVAL and VVAL are output values of U and V, in the projection plane.
C CSLT is the cosine of the standard parallel of the Winkel tripel, for
C which Winkel used ACOS(2/PI); in EZMAP, though, it is allowed to vary.
C
C Local variable.
C
        DOUBLE PRECISION TVAL
C
        TVAL=ACOS(COS(DLAT)*COS(.5D0*DLON))
C
        IF (ABS(TVAL).GT.1.D-6) THEN
          TVAL=SIN(TVAL)/TVAL
        ELSE
          TVAL=1.D0
        END IF
C
        UVAL=2.D0*COS(DLAT)*SIN(.5D0*DLON)/TVAL
        VVAL=SIN(DLAT)/TVAL
C
        UVAL=.5D0*(DLON*CSLT+UVAL)
        VVAL=.5D0*(DLAT+VVAL)
C
        RETURN
C
      END


      real function depend(xu,xl,a,b,cdep,phi,theta,ktrato,qostar)
c
c     + + + PURPOSE + + +
c     Calculates for a segment of an Overland Flow Element that
c     has deposition at the beginning of the segment - where that
c     deposition ends - using the analytic solution to the
c     deposition equation.
c
c     Called (once) from subroutine ROUTE
c     Author(s): G. Foster, M. Nearing, J. Ascough, D. Flanagan
c     Reference in User Guide:
c
c     Changes: 1) TMPVR1 added to eliminate redundant calculations.
c              2) ITMPV1 added and moved outside the do-loop to reduce
c                 the number of calls to ABS, and to substitute an
c                 integer comparison (.NE.) for a floating-point one.
c              3) KTRATO & QOSTAR added to argument list so that
c                 common blocks ENDS1 & INFCO1 do not need to be ref-
c                 erenced.
c              4) MXPLAN is never used.  Reference to PROUTE1.INC is
c                 deleted.
c
c     Version: This module recoded from WEPP version 90.92.
c     Date recoded: 01/08/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real xu, xl, a, b, cdep, phi, theta, ktrato, qostar
c
c     + + + ARGUMENT DEFINITIONS + + +
c     xu     - n.d. distance at top of slope segment
c     xl     - n.d. distance at end of slope segment
c     a      - shear stress equation coefficient
c     b      - shear stress equation coefficient
c     cdep   - portion of the solution to deposition equation
c     phi    - n.d. deposition parameter
c     theta  - n.d. interrill detachment parameter
c     ktrato -
c     qostar -
c
c     + + + LOCAL VARIABLES + + +
      real xdend, r1, r2, ratio, expon, f, df, xmin, tmpvr1
      integer j, kkkk, itmpv1, loopfg
c
c     xdend  - current trial value for n.d. distance where
c              deposition ends
c     r1     - portion of solution to deposition equation solved
c              for conditions of rate equal to 0 and beginning
c              point equal to x=xu
c     r2     -   "       "          "          "        "
c     ratio  -   "       "          "          "        "
c     expon  -   "       "          "          "        "
c     f      - current solution for deposition rate at x=xdend
c     df     - current solution for derivative of deposition rate
c     j      - counter variable - in loop to only allow a finite
c              number of iterations to determine where dep. ends
c     loopfg - flag. 1 = exit L1 Loop
c
c     + + + SUBROUTINES CALLED + + +
c     undflo
c
c     + + + END SPECIFICATIONS + + +
c
c       Solve for first term of deposition equation
      tmpvr1 = 2.0 * a * ktrato
c
      r1 = (phi/(1.0+phi)) * (b*ktrato-theta-(tmpvr1*qostar))
c
c     Solve for second term of deposition equation
c
      r2 = tmpvr1 * phi / (2.0+phi)
c
c     If flow is increasing down the OFE, check whether deposition
c     at the end of the current segment (uniform or convex shape)
c
      if (qostar.ge.0.0) then
        xdend = xl
        ratio = (xu+qostar) / (xdend+qostar)
        expon = 1.0 + phi
        call undflo(ratio,expon)
c
c       Determine deposition rate at x = xl (end of segment) -
c       if a negative value deposition occurs from xu to xl - RETURN
c
        f = r1 + r2 * (xdend+qostar) + cdep * ratio ** expon
        if (f.lt.0.0) then
          depend = xdend
          return
        end if
c
c       If deposition not occurring at x=xl, set beginning point for
c       iterative solution for xdent close to x=xu
c
        xdend = xu + 0.01
        if (xdend.gt.xl) xdend = (xu+xl) / 2.0
c
c     else - flow is decreasing down the OFE segment, first check
c     to determine that deposition does not immediately end
c     past the initial point ( x = xu ) - then set the
c     beginning point for the iterative solution for xdend
c     close to x = xu
c
      else

c new dcf
        if(abs(xu+qostar).le.0.0001)then
          depend=-qostar
          return
        endif
c new dcf end

        xdend = xu + 0.0001
        if (xdend.gt.xl) xdend = (xu+xl) / 2.0
        ratio = (xu+qostar) / (xdend+qostar)
        expon = 1.0 + phi
        call undflo(ratio,expon)
c
c       determine deposition at x = xdend, and if the value
c       is positive or zero - RETURN
c
        f = r1 + r2 * (xdend+qostar) + cdep * ratio ** expon
        if (f.ge.0.0) then
          depend = xdend
          return
        end if
c
      end if
c
c     *** Begin L1 Loop ***
c
      loopfg = 0
      j = 0
      xmin = xl
      kkkk = 0
   10 continue
      j = j + 1
c
c     ITMPV1 is a flag set if ABS(XDEND + QOSTAR) > 0.0 .  This
c     replacement code is put inside the loop, since XDEND, which
c     it depends on, is supposed to change value each time through
c     the loop. We still save time, since the line of original
c     code above is repeated below.
c
c
c
c     Iterative solution for XDEND
c
c
c     Solve for portions of the deposition equation
c     at the trial value of xdend
c
c     Original Code:
c     if(abs(xdend+qostar).gt.0.0)then
c
c     ITMPV1 is a flag set if ABS(XDEND + QOSTAR) > 0.0 this
c     replacement code is put inside the loop, since XDEND,
c     which it depends on, is supposed to change value each
c     time through the loop. We still save time, since the
c     line of orignial code above is repeated below
c
      tmpvr1 = xdend + qostar
      if (abs(tmpvr1).gt.0.0) then
        itmpv1 = 1
      else
        itmpv1 = 0
      end if
c
      if (itmpv1.ne.0) then
        ratio = (xu+qostar) / tmpvr1
      else
        ratio = 1.0
      end if
      if (ratio.lt.0.0) ratio = 1.0
      expon = 1.0 + phi
      call undflo(ratio,expon)
c
c     Solve the deposition equation at trial value of xdend.
c
      f = r1 + r2 * (xdend+qostar) + cdep * ratio ** expon
c
c     Check added 2/7/91 to flag if any positive values
c     of f have been calculated between xu and xl, and
c     then to record the point on slope where this was found.
c
      if (f.gt.0.0.and.qostar.lt.0.0) then
        kkkk = kkkk + 1
        if (xdend.lt.xmin) xmin = xdend
      end if
c
c     TEST - If the value of nondimensional deposition
c     rate is less than 0.0001, jump out of DO LOOP and
c     use the current value of XDEND as point where
c     deposition predicted to end.
c
      if (abs(f).gt.0.0001) then
c       Original Code:
c       if(abs(xdend+qostar).gt.0.0)then
        if (itmpv1.ne.0) then
c
c         Solve for the derivative of the deposition function
c
          df = r2 - (1.0+phi) * cdep * (ratio**expon) / tmpvr1
          if (abs(df).gt.0.0) then
c
c           Use the derivative to obtain a new trial value for XDEND
c
            xdend = xdend - f / df
c
            if (qostar.lt.0.0) then
              if (xdend.lt.xu) xdend = xu + 0.0001
              if (xdend.gt.-qostar) xdend = -qostar - 0.0001
              if (xdend.gt.xl) xdend = xl
            end if
          else
c
c           If the derivative is zero at the point,
c           restart the iterations with xdend close to xu
c
            xdend = xu + 0.0001
          end if
        end if
        if (xdend.lt.xu) xdend = xu + 0.0001
      else
        loopfg = 1
      end if
      if (j.lt.10.and.loopfg.eq.0) go to 10
c
c     Check if solution has not converged for a plane on which
c     flow is decreasing - if it has not and none of the trial
c     values of xdend between xu and xl (or -qostar) have produced
c     non-negative results - then set xdend equal to xl.
c
      if (loopfg.eq.0.and.qostar.lt.0.0) then
        if (kkkk.eq.0) then
          xdend = xl
        else
          xdend = xmin
        end if
      end if
c
      depend = xdend
c
      return
      end


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_rot3_turnover
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine uses the generators for three Givens rotations represented
! by 3 real numbers: the real and imaginary parts of a complex cosine
! and a scrictly real sine and performs a turnover. The input arrays should be
! ordered:
!
!    G1  G3
!      G2
!
! The new generators are stored as:
!
!      G1
!    G3  G2
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  G1, G2, G3       REAL(8) arrays of dimension (3)
!                    generators for givens rotations
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_rot3_turnover(G1,G2,G3)

  implicit none

  ! input variables
  real(8), intent(inout) :: G1(3), G2(3), G3(3)

  ! compute variables
  real(8) :: nrm, ar, ai, b
  real(8) :: c1r, c1i, s1
  real(8) :: c2r, c2i, s2
  real(8) :: c3r, c3i, s3
  real(8) :: c4r, c4i, s4
  real(8) :: c5r, c5i, s5
  real(8) :: c6r, c6i, s6

  ! set local variables
  c1r = G1(1)
  c1i = G1(2)
  s1 = G1(3)
  c2r = G2(1)
  c2i = G2(2)
  s2 = G2(3)
  c3r = G3(1)
  c3i = G3(2)
  s3 = G3(3)

  ! compute first rotation
  ar = s1*c3r + (c1r*c2r + c1i*c2i)*s3
  ai = s1*c3i + (c1r*c2i - c1i*c2r)*s3
  b = s2*s3
  call z_rot3_vec3gen(ar,ai,b,c4r,c4i,s4,nrm)

  ! nrm == 0
  if (nrm.EQ.0d0) then
    ! compute second rotation
    ar = c1r*c3r - c1i*c3i - s1*c2r*s3
    ai = c1r*c3i + c1i*c3r - s1*c2i*s3
    call d_rot2_unitvec2gen(ar,ai,c5r,c5i)
    s5 = 0d0

    ! update first rotation
    call d_rot2_vec2gen(c1r,c1i,ar,ai,nrm)
    c4r = c5r*ar + c5i*ai
    c4i = c5i*ar - c5r*ai
    call d_rot2_unitvec2gen(c4r,c4i,c4r,c4i)

    ! compute third rotation
    ar = c2r*c4r + c2i*c4i
    ai = c2i*c4r - c2r*c4i
    b = nrm*s2
    call z_rot3_unitvec3gen(ar,ai,b,c6r,c6i,s6)

  ! all other cases
  else
    ! compute second rotation
    ar = c1r*c3r - c1i*c3i - s1*c2r*s3
    ai = c1r*c3i + c1i*c3r - s1*c2i*s3
    b = nrm
    call z_rot3_unitvec3gen(ar,ai,b,c5r,c5i,s5)

    ! compute third rotation
    ar = c2r*c4r + c2i*c4i + c1r*s2*s4
    ai = c2i*c4r - c2r*c4i + c1i*s2*s4
    b = s1*s2/s5
    call z_rot3_unitvec3gen(ar,ai,b,c6r,c6i,s6)
  end if

  ! store output
  G1(1) = c5r
  G1(2) = c5i
  G1(3) = s5
  G2(1) = c6r
  G2(2) = c6i
  G2(3) = s6
  G3(1) = c4r
  G3(2) = c4i
  G3(3) = s4

end subroutine z_rot3_turnover


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE PENDIS (SCORD, FCORD, DIST, NDIM, NNOD)
      DIMENSION SCORD(*), FCORD(NDIM, NNOD)

      IF (NDIM .EQ. 3) THEN

C -- DETERMINE PLANE EQUATION

         XI = FCORD(1, 1)
         YI = FCORD(2, 1)
         ZI = FCORD(3, 1)

         XJ = FCORD(1, 2)
         YJ = FCORD(2, 2)
         ZJ = FCORD(3, 2)

         XK = FCORD(1, 3)
         YK = FCORD(2, 3)
         ZK = FCORD(3, 3)

         XL = FCORD(1, 4)
         YL = FCORD(2, 4)
         ZL = FCORD(3, 4)

         A =  (YK - YI) * (ZL - ZJ) - (ZK - ZI) * (YL - YJ)
         B =  (ZK - ZI) * (XL - XJ) - (XK - XI) * (ZL - ZJ)
         C =  (XK - XI) * (YL - YJ) - (YK - YI) * (XL - XJ)
         RMAG = SQRT (A**2 + B**2 + C**2)

         A = A / RMAG
         B = B / RMAG
         C = C / RMAG
         D = A * FCORD(1,1) + B * FCORD(2,1) + C * FCORD(3,1)

         DIST = ABS(A * SCORD(1) + B * SCORD(2) + C * SCORD(3) - D) /
     *      SQRT(A**2 + B**2 + C**2)

      ELSE IF (NDIM .EQ. 2) THEN
         A  = FCORD(1,2) - FCORD(1,1)
         B  = FCORD(2,2) - FCORD(2,1)

         X1 = FCORD(1,1)
         Y1 = FCORD(2,1)

         X0 = SCORD(1)
         Y0 = SCORD(2)
         T  = -1. * (A * (X1 - X0) + B * (Y1 - Y0)) / (A**2 + B**2)

         X = X1 + A * T
         Y = Y1 + B * T

         DIST = SQRT((X - X0)**2 + (Y - Y0)**2)
      END IF
      RETURN
      END