	program readIRIS
*
*      reads   unformatted  (pixel)  data of 1000^2 pixels from file IRIS401
*       draws a line through two points, determines lightcurve
*	for circular source, radius sigma,  with flat profile
*	   (Gaussian source with width sigma possible as well)
*
*
*
*					Joachim Wambsganss, January 2008
*							jkw, 2/27/96
*
*
      implicit none
*
      integer ipix,ipix1,pixlow,i1,i2,iii,ix1,ix2,iy1,iy2,i0
     &	,ixxx,iyyy,pixmax,ilines,iamp,sigma,Rn
     &	,ipoints,ix,iy
      parameter(ipix=1000,ipix1=500)
      integer*2 pix(ipix,ipix),pix1(ipix1,ipix1)
      double precision aaa,x1,x2,y1,y2,slope, alpha,sinalpha,cosalpha
     &	,x0,y0,x_end,y_end,x_start,y_start,x_diff,y_diff,xxx,yyy,value
     &  ,a,b
      real  pix_real(ipix,ipix)
      character*3 string3
      character*1 string1
      character*80 fileread, filewrite
      parameter(ipoints = 505)
      real  x(ipoints),y(ipoints), xx(ipoints),yy(ipoints)

*       My meddling
	open(1,file='source'status='old')
	read(1,1000)startLocx,startLocy,endLocx,endLocy,radius

*
* name of magnification pattern to be read:
*
	fileread  = 'IRIS001'

*
* name of magnification pattern to be written on:
*
      filewrite = 'IRIS001-track'
*
*
* position of start point and end point of lightcurve:
*
*
	ix1 = startLocx
	iy1 = startLocy
	ix2 = endLocx
	iy2 = endLocy
*
* source size in pixels (Gaussian width)
*
       sigma = radius
       Rn=20
       a=-5
       b=0
*
         x1 = dble(ix1)
         x2 = dble(ix2)
         y1 = dble(iy1)
         y2 = dble(iy2)
*
*
*
*
      write(*,*)' reading from file ',fileread
      open(3,file=fileread ,status='old',form='unformatted')
      read(3)pix,pix1
      close(3)
      write(*,*)'                           ...  done'
*
* determine maximum of magnification pattern:
*
       pixmax = 0
       do i1 = 1,ipix
          do i2 = 1,ipix
	      pixmax = max(pixmax,pix(i2,i1))
	     pix_real(i2,i1) = 10**(0.4*(float(pix(i2,i1)-1024)/256.0))
          enddo
       enddo
       write(*,*)' pixmax = ',pixmax
*
*
* determine points of line:
*
         slope = (y2-y1)/(x2-x1)
         write(*,*)' slope = ',slope
*
         alpha = atan(slope)
         write(*,*)' alpha = ',alpha
         sinalpha = sin(alpha)
         cosalpha = cos(alpha)
*
* points for x = 1    and    y = 1:
*
	 if(slope.ne.0) then
	    y0  =   y1 + (1.0d0-x1)*slope
	    x0  =   x1 + (1.0d0-y1)/slope
	    write(*,*)' y0 = ',y0
	    write(*,*)' x0 = ',x0
	 else
	    y0=y1
	    x0=x1
*
*
*
         if(x0.ge.1.0d0.and.x0.le.dble(ipix))then
            x_start = x0
            y_start = 1.0d0
         elseif(y0.ge.1.0d0.and.y0.le.dble(ipix))then
            x_start = 1.0d0
            y_start = y0
         endif

         write(*,*)' x_start = ',x_start
         write(*,*)' y_start = ',y_start
*
*
*
* points for x = ipix    and    y = ipix:
*
	 if(slope.ne.0) then
	    y0  =   y1 + (dble(ipix)-x1)*slope
	    x0  =   x1 + (dble(ipix)-y1)/slope
	    write(*,*)' y0 = ',y0
	    write(*,*)' x0 = ',x0
	 else
	    x0=x1
	    y0=y1
*
*
*
         if(x0.ge.1.0d0.and.x0.le.dble(ipix))then
            x_end = x0
            y_end = y1 + (x_end-x1)*slope
         elseif(y0.ge.1.0d0.and.y0.le.dble(ipix))then
            y_end = y0
            x_end = x1 + (y_end-y1)/slope
         endif
         write(*,*)' x_end = ',x_end
         write(*,*)' y_end = ',y_end

         x_diff = x_end - x_start
         y_diff = y_end - y_start
         write(*,*)' x_diff = ',x_diff
         write(*,*)' y_diff = ',y_diff
*
*
*
* mark pixels along line:
*
* AND   determine light curve for Gaussian source:
*
*
*
         open(23,file='out_line',status='unknown')
c        do i0 = 0,2*ipix
         do i0 = -2*ipix,2*ipix

	    xxx = x_start + i0*cosalpha
	    yyy = y_start + i0*sinalpha
	    ixxx = nint(xxx)
	    iyyy = nint(yyy)
	    if(ixxx.ge.1+3*sigma.and.ixxx.le.ipix-3*sigma.and.
     &	          iyyy.ge.1+3*sigma.and.iyyy.le.ipix-3*sigma)then
*
*
                 call gauss(sigma,Rn,a,b,xxx,yyy,value,pix_real,ipix)
*
*
*
ccc	         value = 10**(float(pix(ixxx,iyyy)-1024)/256.0)
	         write(23,1010)i0,xxx,yyy,pix(ixxx,iyyy),value,ixxx,iyyy
            endif
	 enddo
         do i0 = -2*ipix,2*ipix
	    xxx = x_start + i0*cosalpha
	    yyy = y_start + i0*sinalpha
	    ixxx = nint(xxx)
	    iyyy = nint(yyy)
	    if(ixxx.ge.1+3*sigma.and.ixxx.le.ipix-3*sigma.and.
     &	          iyyy.ge.1+3*sigma.and.iyyy.le.ipix-3*sigma)then
                  pix(ixxx,iyyy) = 0
                  pix(ixxx,iyyy) = 2000
                  pix(ixxx,iyyy) = 5000
            endif
	 enddo
 1010 format(i5,2f15.5,i8,f12.5,2i5)

*
*
*030711: indicate source in lower left corner:
*
*
         do i1 = -2*sigma, 2*sigma
            do i2 = -2*sigma, 2*sigma
		 if(i1*i1+i2*i2.le.2*sigma*2*sigma)then
	             pix(10+2*sigma+i1,10+2*sigma+i2) = 2*pixmax/3
		 endif
	    enddo
	 enddo

         do i1 = -sigma, sigma
            do i2 = -sigma, sigma
		 if(i1*i1+i2*i2.le.sigma*sigma)then
	             pix(10+2*sigma+i1,10+2*sigma+i2) = pixmax
		 endif
	    enddo
	 enddo

*
*
* convert x and y into pixels:
* 		and add pixel values to magpat:
*
      do i1 = 1,ipoints
        ix = ((x(i1) +1.1)*1000/2.2) + 1
        iy = ((y(i1) +1.1)*1000/2.2) + 1
c	write(*,*)' i1,x(i1),ix,y(i1),iy: ', i1,x(i1),ix,y(i1),iy
	if(ix.ge.1.and.ix.le.ipix.and.iy.ge.1.and.iy.le.ipix)then
c	   pix(ix,iy) = 5000
c	   pix(ix,1000-iy) = 5000
	   pix(ix,iy)      = pix(ix,iy)      + 500
	   pix(ix,1000-iy) = pix(ix,1000-iy) + 500
	else
c	   write(*,*)' i1,x(i1),ix,y(i1),iy: ', i1,x(i1),ix,y(i1),iy
	endif
      enddo
*
*
*
*
*
*
*
*
*
      write(*,*)' filewrite = ',filewrite
      open(12,file=filewrite,form='unformatted',status='unknown')
      write(12)pix,pix1
      close(12)
*
      close(13)
*
*
      stop
      end
******
***********************************************************************
******
      subroutine gauss(isig,iRn,ia,ib,xxx,yyy,value,pix,ipix)
*
* modified: disk of constant brightness
*
*
*
      integer isig,i1,i2,isig3sq,ix,iy,ipix,iRn,test,pixarea
      real      pix(ipix,ipix)
      double precision normfac,factorex,sigsq2,value,dum,xxx,yyy
     &	      ,delx,dely,dist2,dist3,ia,ib
*

	ix    =  nint(xxx)
	iy    =  nint(yyy)
	delx  =  xxx - dble(ix)
	dely  =  yyy - dble(iy)
*
*
* 030711: isig3 = RADIUS  for source!!!
*
*
	isig3 = 3*isig
c	isig3 =   isig
	isig3sq = isig3**2
 	sigsq2  = 2.0*dble(isig)**2
	value = 0.0

	test=300
	pixarea=0
c	 write(*,*)' in GAUSS'
cwrite(*,*)' isig,ix,iy,value = ',isig,ix,iy,value
c	pause
*
* Gaussian source profiles with width  isig:
*
	      normfac = 0.0
	      do i1 = -isig3,isig3
		if(ix.eq.test)then
		write(*,*)
		endif
	         do i2 = -isig3,isig3
*
c	            dist2 = i2*i2 + i1*i1
c		    dist3 = (i2-ib)*(i2-ib) + (i1-ia)*(i1-ia)
*
	            dist2 = (i1-delx)**2  + (i2-dely)**2
		    dist3 = (i1-delx-ia)**2  + (i2-dely-ib)**2
*
*
*
	            if(isig.ne.0)then
  	               if(dist2.le.dble(isig**2))then
c 	                   factorex = exp(-dist2/sigsq2)
	                   factorex = 1.0
			  if(dist3.le.dble(iRn**2))then
			   factorex = 0.0
			  endif
			  if(factorex.eq.1.0)then
			   pixarea=pixarea+1
			  endif
			   dum = pix(ix+i1,iy+i2)
	                   value = value + dum*factorex
	                   normfac = normfac + factorex
			elseif(dist2.ge.dble(isig**2))then
			   factorex = 0.0
                           dum = pix(ix+i1,iy+i2)
	                   value = value + dum*factorex
	                   normfac = normfac + factorex
	               endif
	            elseif(isig.eq.0)then
                      factorex = 1.0
                      dum = pix(ix+i1,iy+i2)
	              value = value + dum*factorex
	              normfac = normfac + factorex
		    endif
		if(ix.eq.test)then
		write(*,"(i1)",advance="no")  int(factorex)
		endif
	         enddo
	      enddo
	if(ix.eq.test)then
		write(*,*)
		write(*,*)
		write(*,*) 'Area in pixels =', pixarea
		endif

*
 	      value = value/normfac

	return
	end


*deck ang2
      subroutine ang2(ang,binom,crda,dfac,it,l,lit,lmlo,lmhi,lmf,lml,
     &  lmx,lmy,lmz,lmnv,mproju,xk,yk,zk,zlm)
c
c  compute type 2 angular integrals
c
      implicit real*8 (a-h,o-z)
      parameter (a0=0.0d0, a1=1.0d0, a2=2.0d0, a3=3.0d0)
      dimension ang(lit,mproju,*), binom(*), crda(lit,3), dfac(*),
     &  lmf(*), lml(*), lmx(*), lmy(*), lmz(*), lmnv(3,*), zlm(*)
c
      call wzero(lit*mproju*lmhi,ang,1)
      na1=lmnv(1,it)+1
      la1=lmnv(2,it)+1
      ma1=lmnv(3,it)+1
      naind=(na1*(na1-1))/2
      laind=(la1*(la1-1))/2
      maind=(ma1*(ma1-1))/2
      loc1=(l-1)**2
      mhi=l+l-1
      do 80 ia=1,na1
      pab1=binom(naind+ia)*crda((na1+1)-ia,1)
      if(pab1.eq.a0) go to 80
      do 70 ib=1,la1
      pab2=pab1*binom(laind+ib)*crda((la1+1)-ib,2)
      if(pab2.eq.a0) go to 70
      do 60 ic=1,ma1
      pab3=pab2*binom(maind+ic)*crda((ma1+1)-ic,3)
      if(pab3.eq.a0) go to 60
      n=((ia-3)+ib)+ic
      lamlo=max(l-n,lmlo+mod(l+n+lmlo,2))
      lamhi=min(l+n,lmhi-mod(l+n+lmhi,2))
      if(lamlo.gt.lamhi) go to 60
      do 55 m=1,mhi
      mstart=lmf(loc1+m)
      mend=lml(loc1+m)
      do 50 lam=lamlo,lamhi,2
      l2=lam+lam-1
      angt=a0
      loc2=(lam-1)**2
      do 40 mu=1,l2
      istart=lmf(loc2+mu)
      if(mod(ia+lmx(mstart)+lmx(istart),2).ne.1.or.
     1   mod(ib+lmy(mstart)+lmy(istart),2).ne.1.or.
     2   mod(ic+lmz(mstart)+lmz(istart),2).ne.1) go to 40
      pre=a0
      iend=lml(loc2+mu)
      aint=a0
      do 30 i=istart,iend
        indx=lmx(i)
        indy=lmy(i)
        indz=lmz(i)
        if(indx.eq.0) then
          xkp=a1
        else
          xkp=xk**indx
        endif
        if(indy.eq.0) then
          ykp=a1
        else
          ykp=yk**indy
        endif
        if(indz.eq.0) then
          zkp=a1
        else
          zkp=zk**indz
        endif
        pre=pre+zlm(i)*xkp*ykp*zkp
        do 20 j=mstart,mend
          mndx=lmx(j)
          mndy=lmy(j)
          mndz=lmz(j)
          aint=aint+zlm(i)*zlm(j)*
     &              dfac(ia+indx+mndx)*
     &              dfac(ib+indy+mndy)*
     &              dfac(ic+indz+mndz)/
     &              dfac(ia+indx+mndx+ib+indy+mndy+ic+indz+mndz)
   20   continue
   30 continue
      angt=angt+pre*aint
   40 continue
      ang(n+1,m,lam)=ang(n+1,m,lam)+angt*pab3
   50 continue
   55 continue
   60 continue
   70 continue
   80 continue
      return
      end


Module grid_utils
  use num_types
  use vector_matrix_utilities, only: matrix_inverse, minkowski_reduce_basis, norm, cross_product, determinant
  use numerical_utilities, only: equal
  use kpointgeneration, only: generateIrredKpointList

  implicit none
  private
  public transform_supercell, grid_selection, grid_metrics, compare_grids

CONTAINS

  !!Finds the symmetry preserving supercell in the users
  !!basis.
  !!<parameter name="spHNF" regular="true">One of the symmetry
  !!preserving HNFs in our basis</parameter>
  !!<parameter name="No" regular="true">Our niggli basis.</parameter>
  !!<parameter name="Nu" regular="true">The users niggli
  !!basis.</parameter>
  !!<parameter name="Co" regular="true">Transformation from our basis
  !!to the our niggli basis.</parameter>
  !!<parameter name="Cu" regular="true">Transformation from the users
  !!basis to the users niggli basis.</parameter>
  !!<parameter name="O" regular="true">Our basis vectors.</parameter>
  !!<parameter name="UB" regular="true">The supercell in the users
  !!basis.</parameter>
  SUBROUTINE transform_supercell(spHNF,No,Nu,Co,Cu,O,UB)
    integer, intent(in) :: spHNF(3,3)
    integer, intent(in) :: Co(3,3), Cu(3,3)
    real(dp), intent(in) :: No(3,3), Nu(3,3), O(3,3)
    real(dp), intent(out) :: UB(3,3)

    integer :: F(3,3)
    real(dp) :: Oinv(3,3), Noinv(3,3), Cuinv(3,3), L(3,3)

    call matrix_inverse(O,Oinv)
    call matrix_inverse(No,Noinv)
    call matrix_inverse(real(Cu,dp),Cuinv)
    L = matmul(matmul(O,spHNF),Oinv)
    F = nint(matmul(Noinv,matmul(matmul(L,O),Co)))
    UB = matmul(matmul(Nu,F),Cuinv)

  end SUBROUTINE transform_supercell

  !!Finds the rmin and the number of irreducible k-points for
  !!lattice given an HNF.
  !!<parameter name="lat_vecs" regular="true">The lattice vectors for
  !!the crystal.</parameter>
  !!<parameter name="B_vecs" regular="true">The atomic basis
  !!vectors.</parameter>
  !!<parameter name="at" regular="true">The atom types of each atom in
  !!the basis.</parameter>
  !!<parameter name="HNF" regular="true">The list of generating
  !!vectors for the candidate grids.</parameter>
  !!<parameter name="No" regular="true">Our niggli basis.</parameter>
  !!<parameter name="Nu" regular="true">The users niggli
  !!basis.</parameter>
  !!<parameter name="Co" regular="true">Transformation from our basis
  !!to the our niggli basis.</parameter>
  !!<parameter name="Cu" regular="true">Transformation from the users
  !!basis to the users niggli basis.</parameter>
  !!<parameter name="O" regular="true">Our basis vectors.</parameter>
  !!<parameter name="rmin" regular="true">The rmin for this grid.</parameter>
  !!<parameter name="n_irr" regular="true">The number of irreducbile
  !!k-points.</parameter>
  !!<parameter name="eps_" regular="true">Floating point
  !!tolerance.</parameter>
  !!<parameter name="grid" regular="true">The grid from the HNF.</parameter>
  !!<parameter name="symm_flag" regular="true">Flag that indicates the
  !!symmetries to use.</parameter>
  SUBROUTINE grid_metrics(lat_vecs, B_vecs, at, HNF, No, Nu, Co, Cu, O, grid, rmin, &
       n_irr, symm_flag, eps_)
    real(dp), intent(in) :: lat_vecs(3,3)
    real(dp), optional, intent(in) :: eps_
    real(dp), allocatable :: B_vecs(:,:)
    integer, intent(inout) :: at(:)
    integer, intent(in) :: HNF(3,3), symm_flag
    integer, intent(in) :: Co(3,3), Cu(3,3)
    real(dp), intent(in) :: No(3,3), Nu(3,3), O(3,3)
    real(dp), intent(out) :: rmin, grid(3,3)
    integer, intent(out) :: n_irr

    real(dp) :: supercell(3,3), shift(3), norms(3), reduced_grid(3,3)
    real(dp) :: grid_inv(3,3), lat_trans(3,3)
    real(dp) :: eps
    real(dp)              :: R(3,3)
    real(dp), pointer     :: rdKlist(:,:)
    integer, pointer      :: weights(:)

    if (present(eps_)) then
       eps = eps_
    else
       eps = 1E-3
    end if

    shift = 0.0_dp

    call transform_supercell(HNF, No, Nu, Co, Cu, O, supercell)

    grid_inv = transpose(supercell)
    call matrix_inverse(grid_inv, grid)
    lat_trans = transpose(lat_vecs)
    call matrix_inverse(lat_trans, R)

    call minkowski_reduce_basis(grid, reduced_grid, eps, aeps_=1E-10_dp)
    norms(1) = sqrt(dot_product(reduced_grid(:,1), reduced_grid(:,1)))
    norms(2) = sqrt(dot_product(reduced_grid(:,2), reduced_grid(:,2)))
    norms(3) = sqrt(dot_product(reduced_grid(:,3), reduced_grid(:,3)))
    rmin = min(norms(1), norms(2), norms(3))
    call generateIrredKpointList(lat_vecs, B_vecs, at, grid, R, shift, rdKlist, weights, &
         reps_=eps, symm_=symm_flag)
    n_irr = size(rdKlist,1)

  end SUBROUTINE grid_metrics

  !!Compares a grid to the metrics of another to see which is
  !!has the better rmin or number of irreducible k-points.
  !!Finds the rmin and the number of irreducible k-points for
  !!lattice given an HNF.
  !!<parameter name="HNF" regular="true">The list of generating
  !!vectors for the candidate grids.</parameter>
  !!<parameter name="No" regular="true">Our niggli basis.</parameter>
  !!<parameter name="Nu" regular="true">The users niggli
  !!basis.</parameter>
  !!<parameter name="Co" regular="true">Transformation from our basis
  !!to the our niggli basis.</parameter>
  !!<parameter name="Cu" regular="true">Transformation from the users
  !!basis to the users niggli basis.</parameter>
  !!<parameter name="O" regular="true">Our basis vectors.</parameter>
  !!<parameter name="rmin" regular="true">The rmin for these grids.</parameter>
  !!<parameter name="eps_" regular="true">Floating point
  !!tolerance.</parameter>
  !!<parameter name="grids" regular="true">A list of grids with the best
  !!r_min.</parameter>
  !!<parameter name="best_hnfs" regular="true">The HNFs for the grids with
  !!this r_min.</parameter>
  !!<parameter name="ngrids" regular="true">The number of grids
  !!currently stored in the list of grids.</parameter>
  SUBROUTINE compare_grids(HNF, No, Nu, Co, Cu, O, grids, rmin, &
       best_HNFs, ngrids, eps_)
    real(dp), optional, intent(in) :: eps_
    integer, intent(in) :: HNF(3,3)
    integer, intent(in) :: Co(3,3), Cu(3,3)
    real(dp), intent(in) :: No(3,3), Nu(3,3), O(3,3)
    real(dp), intent(inout) :: rmin(2)
    real(dp), allocatable, intent(inout) :: grids(:,:,:,:)
    integer, intent(inout) :: ngrids(2)
    integer, allocatable, intent(inout) :: best_HNFs(:,:,:,:)

    real(dp) :: supercell(3,3), shift(3), reduced_grid(3,3), norms(3)
    real(dp) :: eps
    integer, allocatable :: ralloc_HNFs(:,:,:,:)
    real(dp), allocatable :: ralloc_grids(:,:,:,:)
    real(dp) :: temp_rmin, temp_grid(3,3)
    real(dp) :: pi, pac_limit, pac_frac

    pi = 3.1415926535897932384626433832795028841971693993751058209749445923078164_dp
    pac_limit = 0.3_dp

    if (present(eps_)) then
       eps = eps_
    else
       eps = 1E-3
    end if

    shift = 0.0_dp
    if (.not. allocated(grids)) then
       allocate(grids(3,3,10,2))
       grids = 0.0_dp
       ngrids = 0
    end if
    if (.not. allocated(best_HNFs)) then
       allocate(best_HNFs(3,3,10,2))
       best_HNFs = 0
    end if

    call transform_supercell(HNF, No, Nu, Co, Cu, O, supercell)

    ! temp_grid_inv = transpose(supercell)
    call matrix_inverse(transpose(supercell), temp_grid)
    call minkowski_reduce_basis(temp_grid, reduced_grid, eps, aeps_=1e-10_dp)
    norms(1) = sqrt(dot_product(reduced_grid(:,1), reduced_grid(:,1)))
    norms(2) = sqrt(dot_product(reduced_grid(:,2), reduced_grid(:,2)))
    norms(3) = sqrt(dot_product(reduced_grid(:,3), reduced_grid(:,3)))
    temp_rmin = min(norms(1), norms(2), norms(3))
    pac_frac = ((4.0_dp*pi*((temp_rmin/2.0_dp)**3))/3.0_dp)/determinant(reduced_grid)

    if (pac_frac >= pac_limit) then
       if (temp_rmin > (rmin(1)+temp_rmin*eps) .and. (.not. equal(temp_rmin, rmin(1), eps))) then
          rmin(2) = rmin(1)
          ngrids(2) = ngrids(1)
          grids(:,:,:,2) = 0.0_dp
          best_HNFs(:,:,:,2) = 0
          best_HNFs(1:3,1:3,1:ngrids(2),2) = best_HNFs(1:3,1:3,1:ngrids(2),1)
          grids(1:3,1:3,1:ngrids(2),2) = grids(1:3,1:3,1:ngrids(2),1)

          rmin(1) = temp_rmin
          ngrids(1) = 1
          grids(:,:,:,1) = 0.0_dp
          best_HNFs(:,:,:,1) = 0
          grids(:,:,ngrids(1),1) = reduced_grid
          best_HNFs(:,:,ngrids(1),1) = HNF

       else if ((temp_rmin > (rmin(2)+temp_rmin*eps)) .and. &
            (.not. equal(temp_rmin, rmin(1), eps)) &
            .and. (.not. equal(temp_rmin, rmin(2), eps))) then
          rmin(2) = temp_rmin
          ngrids(2) = 1
          grids(:,:,:,2) = 0.0_dp
          best_HNFs(:,:,:,2) = 0
          grids(:,:,ngrids(2),2) = reduced_grid
          best_HNFs(:,:,ngrids(2),2) = HNF
       else if (equal(temp_rmin, rmin(1), eps)) then
          if (size(grids,3) == ngrids(1)) then
             allocate(ralloc_HNFs(3,3,ngrids(1),2), ralloc_grids(3,3,ngrids(1),2))
             ralloc_HNFs = best_HNFs
             ralloc_grids = grids
             deallocate(best_HNFs, grids)
             allocate(best_HNFs(3,3,2*ngrids(1),2), grids(3,3,2*ngrids(1),2))
             best_HNFs = 0
             grids = 0.0_dp
             best_HNFs(1:3,1:3,1:ngrids(1),1) = ralloc_HNFs(1:3,1:3,1:ngrids(1),1)
             grids(1:3,1:3,1:ngrids(1),1) = ralloc_grids(1:3,1:3,1:ngrids(1),1)
             best_HNFs(1:3,1:3,1:ngrids(2),2) = ralloc_HNFs(1:3,1:3,1:ngrids(2),2)
             grids(1:3,1:3,1:ngrids(2),2) = ralloc_grids(1:3,1:3,1:ngrids(2),2)
          end if
          ngrids(1) = ngrids(1) + 1
          grids(:,:,ngrids(1),1) = reduced_grid
          best_HNFs(:,:,ngrids(1),1) = HNF
       else if (equal(temp_rmin, rmin(2), eps)) then
          if (size(grids,3) == ngrids(2)) then
             allocate(ralloc_HNFs(3,3,ngrids(2),2), ralloc_grids(3,3,ngrids(2),2))
             ralloc_HNFs = best_HNFs
             ralloc_grids = grids
             deallocate(best_HNFs, grids)
             allocate(best_HNFs(3,3,2*ngrids(2),2), grids(3,3,2*ngrids(2),2))
             best_HNFs = 0
             grids = 0.0_dp
             best_HNFs(1:3,1:3,1:ngrids(1),1) = ralloc_HNFs(1:3,1:3,1:ngrids(1),1)
             grids(1:3,1:3,1:ngrids(1),1) = ralloc_grids(1:3,1:3,1:ngrids(1),1)
             best_HNFs(1:3,1:3,1:ngrids(2),2) = ralloc_HNFs(1:3,1:3,1:ngrids(2),2)
             grids(1:3,1:3,1:ngrids(2),2) = ralloc_grids(1:3,1:3,1:ngrids(2),2)
          end if
          ngrids(2) = ngrids(2) + 1
          grids(:,:,ngrids(2),2) = reduced_grid
          best_HNFs(:,:,ngrids(2),2) = HNF
       end if
    end if

  end SUBROUTINE compare_grids

  !!Selects the best grid from the list of grids.
  !!<parameter name="lat_vecs" regular="true">The lattice vectors for
  !!the crystal.</parameter>
  !!<parameter name="B_vecs" regular="true">The atomic basis
  !!vectors.</parameter>
  !!<parameter name="at" regular="true">The atom types of each atom in
  !!the basis.</parameter>
  !!<parameter name="cand_grids" regular="true">The list of generating
  !!vectors for the candidate grids.</parameter>
  !!<parameter name="best_grid" regular="true">The best grid given the
  !!criteria.</parameter>
  !!<parameter name="ngrids" regular="true">The number of
  !!grids.</parameter>
  !!<parameter name="cand_HNFs" regular="true">The cand HNFs.</parameter>
  !!<parameter name="offsets" regular="true">The offsets to apply to
  !!the grids.</parameter>
  !!<parameter name="best_offset" regular="true">The offset that gives
  !!the best reduction for the best grid.</parameter>
  !!<parameter name="n_irr" regular="true">The number of irreducible kpoints
  !!of best_grid</parameter>
  !!<parameter name="eps_" regular="true">Floating point
  !!tolerance.</parameter>
  !!<parameter name="symm_flag" regular="true">Flag that indicates the
  !!symmetries to use.</parameter>
  SUBROUTINE grid_selection(lat_vecs, B_vecs, at, cand_grids, cand_HNFs, ngrids, &
       offsets, best_grid, best_HNF, best_offset, n_irr, symm_flag, eps_)
    real(dp), intent(in) :: lat_vecs(3,3), offsets(:,:)
    real(dp), allocatable, intent(in) :: cand_grids(:,:,:,:)
    real(dp), optional, intent(in) :: eps_
    real(dp), intent(out) :: best_grid(3,3), best_offset(3)
    real(dp), allocatable :: B_vecs(:,:)
    integer, intent(inout) :: at(:)
    integer, intent(in), allocatable :: cand_HNFs(:,:,:,:)
    integer, intent(out) :: best_HNF(3,3), n_irr
    integer, intent(in) :: ngrids(2), symm_flag

    real(dp) :: temp_grid(3,3), grid_offsets(sum(ngrids),3)
    integer :: i, n_irreducible(sum(ngrids)), n_ir_min(1), count, j
    real(dp) :: eps

    real(dp)              :: R(3,3), invLat(3,3), temp_R(3,3)
    real(dp), pointer     :: rdKlist(:,:)
    integer, pointer      :: weights(:)
    integer :: err

    if (present(eps_)) then
       eps = eps_
    else
       eps = 1E-3
    end if

    call matrix_inverse(lat_vecs, invLat)
    temp_R = transpose(invLat)
    call minkowski_reduce_basis(temp_R, R, eps)

    n_irreducible = 0
    count = 0
    do i=1,ngrids(1)
       temp_grid = cand_grids(:,:,i,1)
       do j=1, size(offsets,1)
          call generateIrredKpointList(lat_vecs, B_vecs, at, temp_grid, R, &
               offsets(j,:), rdKlist, weights, reps_=eps, symm_=symm_flag, &
               err_=err)
          if (err==0) then
             if (n_irreducible(i) == 0) then
                n_irreducible(i) = size(rdKlist,1)
                grid_offsets(i,:) = offsets(j,:)
             elseif (size(rdKlist,1) < n_irreducible(i)) then
                n_irreducible(i) = size(rdKlist,1)
                grid_offsets(i,:) = offsets(j,:)
             end if
          end if
       end do
       count = count + 1
    end do

    do i=1,ngrids(2)
       temp_grid = cand_grids(:,:,i,2)
       do j=1, size(offsets, 1)
          call generateIrredKpointList(lat_vecs, B_vecs, at, temp_grid, R, &
               offsets(j,:), rdKlist, weights, eps, err_=err)
          if (err==0) then
             if (n_irreducible(i) == 0) then
                n_irreducible(count+i) = size(rdKlist,1)
                grid_offsets(count+i,:) = offsets(j,:)
             elseif (size(rdKlist,1) < n_irreducible(i)) then
                n_irreducible(count+i) = size(rdKlist,1)
                grid_offsets(count+i,:) = offsets(j,:)
             end if
          end if
       end do
    end do
    if (any(n_irreducible > 0)) then
       n_ir_min = minloc(n_irreducible, n_irreducible>0)
       n_irr = n_irreducible(n_ir_min(1))
       best_offset = grid_offsets(n_ir_min(1),:)
       if (n_ir_min(1) <= count) then
          best_grid = cand_grids(:,:, n_ir_min(1),1)
          best_HNF = cand_HNFs(:,:, n_ir_min(1),1)
       else
          best_grid = cand_grids(:,:, n_ir_min(1)-count,2)
          best_HNF = cand_HNFs(:,:, n_ir_min(1)-count,2)
       end if
    else
       best_HNF = 0
       best_grid = 0.0_dp
       best_offset = 0.0_dp
       n_irr = 0
    end if

  end SUBROUTINE grid_selection

end Module grid_utils


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program 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 General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine objective_stress_se(nk,iobject,mi,dstn,objectset,
     &  ialnneigh,naneigh,nbneigh,stn,dksper)
!
!     calculates the sum of the square of the von Mises stress of a node
!     set
!
      implicit none
!
      character*81 objectset(4,*)
!
      integer nk,idir,iobject,mi(*),j,k,ialnneigh(*),naneigh,nbneigh
!
      real*8 stn(6,*),p,rho,xstress,dksper,dstn(6,*),mises,dmises
!
!     reading rho and the mean stress for the Kreisselmeier-Steinhauser
!     function
!
      read(objectset(2,iobject)(41:60),'(f20.0)') rho
      read(objectset(2,iobject)(61:80),'(f20.0)') xstress
!
      dksper=0.d0
      do j=naneigh,nbneigh
         k=ialnneigh(j)
!
!        Calculate unperturbed mises stress
!
         p=-(stn(1,k)+stn(2,k)+stn(3,k))/3.d0
         mises=dsqrt(1.5d0*((stn(1,k)+p)**2+
     &                      (stn(2,k)+p)**2+
     &                      (stn(3,k)+p)**2+
     &                 2.d0*(stn(4,k)**2+stn(5,k)**2+
     &                       stn(6,k)**2)))
!
!        Calculate perturbed mises stress
!
         p=-(dstn(1,k)+dstn(2,k)+dstn(3,k))/3.d0
         dmises=dsqrt(1.5d0*((dstn(1,k)+p)**2+
     &                       (dstn(2,k)+p)**2+
     &                       (dstn(3,k)+p)**2+
     &                  2.d0*(dstn(4,k)**2+dstn(5,k)**2+
     &                        dstn(6,k)**2)))
!
!        Calculate delta mises stress
!
         dmises=dmises-mises
!
         dksper=dksper+dexp(rho*dsqrt(1.5d0*
     &   ((dstn(1,k)+p)**2+
     &   (dstn(2,k)+p)**2+
     &   (dstn(3,k)+p)**2+
     &   2.d0*(dstn(4,k)**2+
     &         dstn(5,k)**2+
     &         dstn(6,k)**2)))/xstress)*dmises
      enddo
!
      dksper=dksper/xstress
!
      return
      end


!==========================================================================
elemental function gsw_pot_enthalpy_from_pt_ice (pt0_ice)
!==========================================================================
!
!  Calculates the potential enthalpy of ice from potential temperature of
!  ice (whose reference sea pressure is zero dbar).
!
!  pt0_ice  =  potential temperature of ice (ITS-90)              [ deg C ]
!
!  gsw_pot_enthalpy_ice  =  potential enthalpy of ice              [ J/kg ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_t0

use gsw_mod_gibbs_ice_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: pt0_ice

real (r8) :: gsw_pot_enthalpy_from_pt_ice

real (r8) :: tau
complex (r8) :: h0_part, sqtau_t1, sqtau_t2

tau = (pt0_ice + gsw_t0)*rec_tt

sqtau_t1 = (tau/t1)**2
sqtau_t2 = (tau/t2)**2

h0_part = r1*t1*(log(1.0_r8 - sqtau_t1) + sqtau_t1) &
          + r20*t2*(log(1.0_r8 - sqtau_t2) + sqtau_t2)

gsw_pot_enthalpy_from_pt_ice = g00 + tt*real(h0_part)

return
end function

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


      SUBROUTINE slPDQH (P, D, Q, H1, J1, H2, J2)
*+
*     - - - - - -
*      P D Q H
*     - - - - - -
*
*  Hour Angle corresponding to a given parallactic angle
*
*  (double precision)
*
*  Given:
*     P       d        latitude
*     D       d        declination
*     Q       d        parallactic angle
*
*  Returned:
*     H1      d        hour angle:  first solution if any
*     J1      i        flag: 0 = solution 1 is valid
*     H2      d        hour angle:  second solution if any
*     J2      i        flag: 0 = solution 2 is valid
*
*  Called:  slDA1P
*
*  P.T.Wallace   Starlink   6 October 1994
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program 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 General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION P,D,Q,H1
      INTEGER J1
      DOUBLE PRECISION H2
      INTEGER J2

      DOUBLE PRECISION DPI
      PARAMETER (DPI=3.141592653589793238462643D0)
      DOUBLE PRECISION D90
      PARAMETER (D90=DPI/2D0)
      DOUBLE PRECISION TINY
      PARAMETER (TINY=1D-12)
      DOUBLE PRECISION PN,QN,DN,SQ,CQ,SQSD,QT,QB,HPT,T
      DOUBLE PRECISION slDA1P

*  Preset status flags to OK
      J1=0
      J2=0

*  Adjust latitude, declination, parallactic angle to avoid critical values
      PN=slDA1P(P)
      IF (ABS(ABS(PN)-D90).LT.TINY) THEN
         PN=PN-SIGN(TINY,PN)
      ELSE IF (ABS(PN).LT.TINY) THEN
         PN=TINY
      END IF
      QN=slDA1P(Q)
      IF (ABS(ABS(QN)-DPI).LT.TINY) THEN
         QN=QN-SIGN(TINY,QN)
      ELSE IF (ABS(QN).LT.TINY) THEN
         QN=TINY
      END IF
      DN=slDA1P(D)
      IF (ABS(ABS(D)-ABS(P)).LT.TINY) THEN
         DN=DN-SIGN(TINY,DN)
      ELSE IF (ABS(ABS(D)-D90).LT.TINY) THEN
         DN=DN-SIGN(TINY,DN)
      END IF

*  Useful functions
      SQ=SIN(QN)
      CQ=COS(QN)
      SQSD=SQ*SIN(DN)

*  Quotient giving sin(h+t)
      QT=SIN(PN)*SQ*COS(DN)
      QB=COS(PN)*SQRT(CQ*CQ+SQSD*SQSD)

*  Any solutions?
      IF (ABS(QT).LE.QB) THEN

*     Yes: find h+t and t
         HPT=ASIN(QT/QB)
         T=ATAN2(SQSD,CQ)

*     The two solutions
         H1=slDA1P(HPT-T)
         H2=slDA1P(-HPT-(T+DPI))

*     Reject if h and Q different signs
         IF (H1*QN.LT.0D0) J1=-1
         IF (H2*QN.LT.0D0) J2=-1
      ELSE
         J1=-1
         J2=-1
      END IF

      END


      subroutine DMstandard(q, DM, natoms, apos)
      implicit none

      integer natoms
      real*8 q(3), apos(3,natoms)
      complex*16 DM(3,natoms,3,natoms)

      integer iat1, iat2, j1, j2
      real*8  AposDiff(3), QxR, x(3), tpi
      complex*16 expQxR

      tpi = 8d0*atan(1d0)

c     Conjugate the dynamical matrix, since we read row into column in main.f !!!
      DM = conjg( DM )
      do iat1=1,Natoms
         do iat2=1,Natoms
            AposDiff = apos(:,iat2) - apos(:,iat1)
            QxR = tpi * dot_product(q, AposDiff)
            expQxR = dcmplx( cos(QxR), -sin(QxR) )

            DM(:,iat1,:,iat2) = DM(:,iat1,:,iat2)*expQxR

         end do
      end do

c$$$      print 110, q
c$$$      print 100, DM
c$$$      print *
c$$$ 100  format(6('(',f6.2,',',f6.2,')',2x))
c$$$ 110  format('   q=   ', 3f12.6)

      return
      end


! = = = = = = = = = = = = = = = =
!
!  Diffusion proccess for SSC
!
! = = = = = = = = = = = = = = = =

!    SUBROUTINE SSC_Diffusion_2D_Model(SSC1,SSC2)
!
!        IMPLICIT NONE
!
!        REAL(fp) , DIMENSION(:,:) , POINTER :: SSC1 , SSC2 , TEMP
!        INTEGER :: I , J , i1 , i2 , j1 , j2
!
!
!! Calculate local erosion
!
!        CALL LocalErosion
!
!!- - - - - - - - - - - - - -
!!    ADI method is used
!!- - - - - - - - - - - - - -
!
!! Y-Direcsion
!
!        LX   => DY
!        LY   => DX
!        LT   => DT
!        LXX = LX**2
!        LYY = LY**2
!
!        ILOW => ML
!        IUP  => MU
!        JLOW => NL
!        JUP  => NU
!
!        DO J = JLOW , JUP
!
!            j1 = J+1
!            j2 = J-1
!            IF(J==JLOW) j2=J
!            IF(J==JUP) j1=J
!
!! results of last step
!
!            VARS  => SSC1(:,j2)
!            VARP  => SSC1(:,J)
!            VARN  => SSC1(:,j1)
!
!! wet AND dry information
!
!            GIDS  => HNDD(:,j2)
!            GIDP  => HNDD(:,J)
!            GIDN  => HNDD(:,j1)
!
!! diffusion coefficient -Y
!
!            VSCP  => SSC_DIFFU_HWL_Y(:,J)
!
!! diffusion coefficient -X
!
!            VSCS  => SSC_DIFFU_HWL_X(:,j2)
!            VSCN  => SSC_DIFFU_HWL_X(:,J)
!
!! erosion term: local source term
!
!            CEP   => ERO(:,J)
!
!! local water Depth
!
!            HP    => HTDEP0(:,J)
!
!! result
!
!            FRUIT => SSC2(:,J)
!
!! ADI solver
!
!            CALL Tridiagonal_ADI('Y',J)
!
!        END DO
!
!! Exchange pointers
!
!        TEMP=>SSC2
!        SSC2=>SSC1
!        SSC1=>TEMP
!        NULLIFY(VARS,VARP,VARN,FRUIT,GIDS,GIDP,GIDN,VSCP,VSCS,VSCN,TEMP,CEP)
!        NULLIFY(LX,LY,LT,ILOW,IUP,JLOW,JUP)
!
! ! - - - - - - - - - - - - - - - - -
!
! ! X-Direcsion
!
!        LX   => DX
!        LY   => DY
!        LT   => DT
!        LXX = LX**2
!        LYY = LY**2
!
!        ILOW => NL
!        IUP  => NU
!        JLOW => ML
!        JUP  => MU
!
!        DO J = JLOW , JUP
!
!            j1 = J+1
!            j2 = J-1
!            IF(J==JLOW) j2=J
!            IF(J==JUP ) j1=J
!
!! results of last step
!
!            VARS  => SSC1(j2,:)
!            VARP  => SSC1(J,:)
!            VARN  => SSC1(j1,:)
!
!! wet AND dry information
!
!            GIDS  => HNDD(j2,:)
!            GIDP  => HNDD(J,:)
!            GIDN  => HNDD(j1,:)
!
!! diffusion coefficient -Y
!
!            VSCP  => SSC_DIFFU_HWL_X(J,:)
!
!! diffusion coefficient -X
!
!            VSCS  => SSC_DIFFU_HWL_Y(j2,:)
!            VSCN  => SSC_DIFFU_HWL_Y(J,:)
!
!! erosion term: local source term
!
!            CEP   => ERO(J,:)
!
!! local water Depth
!
!            HP    => HTDEP0(J,:)
!
!! result
!
!            FRUIT => SSC2(J,:)
!
!! ADI solver
!
!            CALL Tridiagonal_ADI('X',J)
!
!        END DO
!
!! Exchange pointers
!
!        TEMP=>SSC2
!        SSC2=>SSC1
!        SSC1=>TEMP
!        NULLIFY(VARS,VARP,VARN,FRUIT,GIDS,GIDP,GIDN,VSCP,VSCS,VSCN,TEMP,CEP)
!        NULLIFY(LX,LY,LT,ILOW,IUP,JLOW,JUP)
!
!    END SUBROUTINE SSC_Diffusion_2D_Model

! = = = = = = = = = = = = = = = =
!
!     SSC constant model
!
! = = = = = = = = = = = = = = = =

    !SUBROUTINE SSC_Constant_Model(SSC1)
    !    IMPLICIT NONE
    !
    !    REAL(fp) , DIMENSION(:,:) , POINTER :: SSC1
    !
    !    CALL LocalErosion
    !
    !END SUBROUTINE SSC_Constant_Model

    ! 2D routine

!    SUBROUTINE Bed_Evolution(SSC1)
!
!        IMPLICIT NONE
!
!        REAL(fp) , DIMENSION(:,:) , POINTER :: SSC1
!        INTEGER :: I , J
!
!! Erosion is positive and Deposition is negative
!
!        DO I = ML , MU
!            DO J = NL , NU
!                EVOSTEP(I,J) = ERO(I,J) - SSC1(I,J)*WS
!                Evolution_TDCYC(I,J) = Evolution_TDCYC(I,J) + EVOSTEP(I,J)
!            END DO
!        END DO
!
!    END SUBROUTINE Bed_Evolution

! = = = = = = = = = = = = = = = = = = = =
!
!   ADI ROUTINE: solve tridiagonal matrix
!
! = = = = = = = = = = = = = = = = = = = =

!    SUBROUTINE Tridiagonal_ADI(DIR,ROW)
!
!        IMPLICIT NONE
!
!        CHARACTER(LEN=1) :: DIR
!        INTEGER          :: ROW
!
!        REAL(fp) :: AMT(6,3001)
!        REAL(fp) :: DCE , DCW , DCN , DCS
!        INTEGER  :: I , IC , K
!        INTEGER  :: IDE, IDW, IDS, IDN
!        IC = 0
!
!        DO I = ILOW , IUP
!
!            IC = IC+1
!
!! Local point is dry
!
!            IF(GIDP(I)==1) THEN
!
!! set zero
!
!                amt(1,IC) = 0.D0
!                amt(2,IC) = 1.D0
!                amt(3,IC) = 0.D0
!                amt(4,IC) = 0.D0
!                CYCLE
!
!! Local point is wet
!
!            ELSEIF(GIDP(I)==0) THEN
!
!!- - - - - - - - - - - - - -
!! Set diffusion coefficients
!!- - - - - - - - - - - - - -
!
!!SOUTH
!
!                IF(ROW==JLOW) THEN
!                    IDS = 1
!                ELSE
!                    IDS = GIDS(I)
!                END IF
!
!                IF(IDS==0) THEN
!                    DCS = VSCS(I)  * LT / LYY * 0.5D0 / HP(I)
!                END IF
!
!!NORTH
!
!                IF(ROW==JUP) THEN
!                    IDN = 1
!                ELSE
!                    IDN = GIDN(I)
!                END IF
!
!                IF(IDN==0) THEN
!                    DCN = VSCN(I)  * LT / LYY * 0.5D0 / HP(I)
!                END IF
!
!!WEST
!
!                IF(I==ILOW) THEN
!                    IDW = 1
!                ELSE
!                    IDW = GIDP(I-1)
!                END IF
!
!                IF(IDW==0) THEN
!                    DCW = VSCP(I-1) * LT / LXX * 0.5D0 / HP(I)
!                END IF
!
!!EAST
!
!                IF(I==IUP) THEN
!                    IDE = 1
!                ELSE
!                    IDE = GIDP(I+1)
!                END IF
!
!                IF(IDE==0) THEN
!                    DCE = VSCP(I)  * LT / LXX * 0.5D0 / HP(I)
!                END IF
!
!!- - - - - - - - - - - - - - - -
!! Left hand side of the equation
!!- - - - - - - - - - - - - - - -
!
!                IF(IDE==1.AND.IDW==0) THEN
!
!                    amt(1,IC) = - 2.D0*DCW
!                    amt(2,IC) = + 2.D0*DCW + 1.D0
!                    amt(3,IC) = 0.D0
!
!                ELSEIF(IDW==1.AND.IDE==0) THEN
!
!                    amt(1,IC) =   0.D0
!                    amt(2,IC) = + 2.D0*DCE + 1.D0
!                    amt(3,IC) = - 2.D0*DCE
!
!                ELSEIF(IDW==1.AND.IDE==1) THEN
!
!                    amt(1,IC) =   0.D0
!                    amt(2,IC) =   1.D0
!                    amt(3,IC) =   0.D0
!
!                ELSEIF(IDW==0.AND.IDE==0)  THEN
!
!                    amt(1,IC) = - DCW
!                    amt(2,IC) = + DCW + DCE + 1.D0
!                    amt(3,IC) = - DCE
!
!                ELSE
!
!                    WRITE(*,*) ROW, GIDP(I-1) , GIDP(I+1)
!                    PAUSE 'tri_matrix_error_1'
!
!                END IF
!
!!- - - - - - - - - - - - - - - -
!! Left hand side of the equation
!!- - - - - - - - - - - - - - - -
!
!                IF(    IDN==1.AND.IDS==0) THEN
!
!                    amt(4,IC) = VARP(I) + 2.D0*DCS*(VARS(I)-VARP(I))
!
!                ELSEIF(IDS==1.AND.IDN==0) THEN
!
!                    amt(4,IC) = VARP(I) + 2.D0*DCN*(VARN(I)-VARP(I))
!
!                ELSEIF(IDS==1.AND.IDN==1) THEN
!
!                    amt(4,IC) = VARP(I)
!
!                ELSEIF(IDS==0.AND.IDN==0)  THEN
!
!                    amt(4,IC) = VARP(I) + DCN*(VARN(I)-VARP(I)) + DCS*(VARS(I)-VARP(I))
!
!                ELSE
!
!                    WRITE(*,*) ROW, IDS , IDN
!                    PAUSE 'tri_matrix_error_2'
!
!                END IF
!
!        ! sourse term
!
!                amt(4,IC) = amt(4,IC) + CEP(I)/HP(I)*0.5D0*LT
!                amt(2,IC) = amt(2,IC) + WS/HP(I)*0.5D0*LT
!
!            END IF
!
!        END DO
!
!    !    OPEN(5,file='amt.txt')
!    !    do I = 1, IC
!    !        WRITE(5,'(10e25.10)') (amt(K,I),K=1,4)
!    !    end do
!    !    CLOSE(5)
!
!        CALL solve3_LU(IC)
!
!        fruit(:) = amt(4,:)
!
!        !IF(pros=='sedi') THEN
!        !IF(dir=='y') THEN
!        !OPEN(5,file='amt2.txt')
!        !do I = 1, IC
!        !    WRITE(5,'(10e25.10)') (amt(K,I),K=1,4)
!        !end do
!        !CLOSE(5)
!        !pause 'xg'
!        !end IF
!
!    END SUBROUTINE Tridiagonal_ADI

!- - - - - - - - - - - - - -
!
!   Bed evolution per step
!
!- - - - - - - - - - - - - -

! 1D routine


      SUBROUTINE TDRSLOC(TSEC50,POS,XLONG)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  FOR TIME TSEC50, THIS ROUTINE RETURNS TO THE CALLER THE INERTIAL
C  POSITION OF THE TDRS'S AND THEIR EAST LONGITUDES.
C
C  VAR    DIM      TYPE    I/O   DESCRIPTION
C  ---    ---      ----    ---   -----------
C
C  TSEC50 1        R*8     I     TIME FOR WHICH POSITIONS ARE WANTED.
C                                IN SECONDS SINCE 1/1/50, 0.0 HR UT.
C
C  POS    3,2      R*8     O     CARTESIAN POSITION VECTOR OF THE TDRS'S
C                                AT TIME TSEC50. IN MEAN OF 1950.0
C
C                                POS(-,I) REFERS TO THE TDRS HAVING
C                                LONGITUDE XLONG(I) AND LATITUDE 0.D0.
C                                IN KILOMETERS.
C
C  XLONG  2        R*8     O     THE LONGITUDE EAST OF GREENWICH OF THE
C                                TDRS'S. IN RADIANS.
C
C
C***********************************************************************
C
C  CODED BY C PETRUZZO. 6/82.
C  MODIFIED............CJP 7/83. COMMENT MODS, NO CODE MODS.
C                      CJP 4/84. VECM50TOD CALL. ALMOST ALL NEW CODE.
C                                PREVIOUS VERSION GAVE MEAN OF DATE POS.
C
C***********************************************************************
C
      REAL*8 DEGRAD/ 57.29577951308232D0 /
      REAL*8 XLONG(2),POS(3,2)
C
C SET THE TDRS LOCATIONS IN LAT/LONG/RADIUS
      XLAT = 0.D0
      XLONG(1)=319.D0/DEGRAD
      XLONG(2)=189.D0/DEGRAD
      RAD=42166.D0
C
C GET POSITIONS IN TRUE OF DATE COORDS
      GHA = GHANGL(TSEC50,1)
      CALL XYZSPH(1,GHA+XLONG(1),XLAT,RAD,POS(1,1),1.D0)
      CALL XYZSPH(1,GHA+XLONG(2),XLAT,RAD,POS(1,2),1.D0)
C
C ROTATE FROM TRUE OF DATE TO MEAN OF 1950.0 COORDS
      CALL VECM50TOD(TSEC50,-1,POS(1,1),POS(1,1))
      CALL VECM50TOD(TSEC50,-1,POS(1,2),POS(1,2))
C
      RETURN
      END


c
C***********************************************************************
      subroutine h2dmpmphf_vec(nd,zk,rscale1,center1,hexp1,nterms1,
     1                rscale2,center2,hexp2,nterms2)
      implicit none
C***********************************************************************
c
c     This routine shifts multipole expansions HEXP1 to a new center,
C     generating the multipole expansions HEXP2, using FFT convolution.
C     THIS IS NOT AN INCREMENTING ROUTINE - ONLY A TESTING ROUTINE.
C
C     The subroutine h2d_diagtrans(nsig,sig,transvec,sig2)
C     IS INCREMENTAL - that is sig2 is incremented by the translation of
C     sig. Inside the FMM, sig2 accumulates the contributions from all
C     children before transformation back to the "physical" hexp2 form.
C---------------------------------------------------------------------
c      INPUT:
c
c      nd      : vector length (number of expansions)
c      zk      : Helmholtz parameter
c      rscale1 : scaling parameter (IGNORED and assumed equal to 1)
c      center1 : center of original multiple expansion
c      hexp1   : coefficients of original multiple expansion
c      nterms1 : order of original multipole expansion
c      rscale2 : scaling parameter (IGNORED and assumed equal to 1)
c      center2 : center of shifted multipole expansion
c      nterms2 : order of shifted multipole expansion
C---------------------------------------------------------------------
c      OUTPUT:
c
c      hexp2   = coefficients of shifted multipole expansion
c
c      Note:
c      The FFT accelerated convolution is only valid at high
c      frequencies, and therefore rscale1 and rscale2 parameters
c      are assumed to be 1 (i.e. ignored) inside this routine.
C---------------------------------------------------------------------
      integer nterms1,nterms2,nsig,j,next235,nd,ii
      double precision center1(2),center2(2),dn,rscale1,rscale2
      double complex zk,hexp1(nd,-nterms1:nterms1)
      double complex hexp2(nd,-nterms2:nterms2)
      double complex, allocatable :: sig(:,:),wsave(:)
      double complex, allocatable :: transvec(:)
      double complex, allocatable :: sig2(:,:)
c
c     do the convolution via fft
c
      dn = 2*(nterms1+nterms2) + 1
      nsig = next235(dn)
c
      allocate(sig(nd,nsig))
      allocate(transvec(nsig))
      allocate(sig2(nd,nsig))
      allocate(wsave(4*nsig+100))

c
      call zffti(nsig, wsave)
      call h2d_mptosig(nd,nterms1,nsig,hexp1,sig,wsave)
      call h2d_mkmpshift(zk, center1, nterms1,
     1           center2, nterms2, nsig, wsave, transvec)
c
      do ii = 1,nd
      do j = 1,nsig
         sig2(ii,j) = 0.0d0
      enddo
      enddo
c
      call h2d_diagtrans(nd,nsig,sig,transvec,sig2)
      call h2d_sig2exp_vec(nd,nsig, sig2, wsave, nterms2, hexp2)
      return
      end
c
c
c
c
C***********************************************************************
      subroutine h2d_mptosig(nd,nterms1,nsig,hexp,sig,wsave)
      implicit none
C***********************************************************************
c
c     Converts h-expansion HEXP to far-field  high-frequency
c     signature function SIG (using FFT).
C---------------------------------------------------------------------
c     INPUT:
c
c     nd      : vector length (number of expansions)
c     nterms1 : order of original local expansion
c     nsig    : order of the HF signature
c     hexp    : coefficients of original local expansion
c     wsave   : FFT work array from call to ZFFTI with size nsig
c
C---------------------------------------------------------------------
c     OUTPUT:
c
c     sig     : far-field signature function, stored FFT style.
C---------------------------------------------------------------------
      integer :: nterms1, nsig,j,nd,ii
      double complex :: hexp(nd,-nterms1:nterms1),sig(nd,nsig),wsave(*)
      double complex, allocatable :: sigtmp(:)
c
c     insert hexp to sig in FFT ordering
c
      allocate(sigtmp(nsig))
c
      do ii = 1,nd
         do j = 1,nsig
            sigtmp(j) = 0
         end do
         do j = 0,nterms1
            sigtmp(j+1) = hexp(ii,j)
         end do
         do j = 1,nterms1
            sigtmp(nsig-j+1) = hexp(ii,-j)
         end do
c
         call zfftf(nsig, sigtmp, wsave)
         do j = 1,nsig
            sig(ii,j) = sigtmp(j)
         end do
      end do

      return
      end
c
c
c
c
c
C***********************************************************************
      subroutine h2d_mkmpshift(zk, center1, nterms1,
     1           center2, nterms2, nsig, wsave, transvec)
      implicit none
C***********************************************************************
c
c     Create diagonal translation operator for shifting center of either
c     h- or j- expansion.
C---------------------------------------------------------------------
c     INPUT:
c
c     zk       : Helmholtz parameter
c     center1  : center of original local expansion
c     nterms1  : order of original local expansion
c     center2  : center of shifted local expansion
c     nterms2  : order of the eventual shifted local expansion
c     nsig     : order of the HF signature, should be good for FFT and
c                greater than 2*(nterm1+nterms2)+1
c     wsave    : FFT work array from call to ZFFTI with size nsig
C---------------------------------------------------------------------
c     OUTPUT:
c
c     transvec : translation operator in diagonal form
C---------------------------------------------------------------------
      integer :: nterms1,nterms2,nterms,nsig,ifder,j
      double precision :: center1(2),center2(2)
      double precision :: zdiff(2),done,pi,theta,r,rscale1
      double complex :: zk,transvec(nsig),wsave(*)
      double complex :: z,ima,zmul,zinv,ztemp1,ztemp2
      double complex, allocatable :: jval(:),jder(:),jtemp(:)
      data ima/(0.0d0,1.0d0)/
c
      done=1
      pi=4*atan(done)
      nterms = nterms1+nterms2
c
      allocate(jval(0:nterms+3))
      allocate(jder(0:nterms+3))
      allocate(jtemp(-nterms-3:nterms+3))
c
      zdiff(1)=center2(1)-center1(1)
      zdiff(2)=center2(2)-center1(2)
      call h2cart2polar(zdiff,r,theta)
      theta=theta-pi
      z=zk*r
c
      ifder=0
      rscale1 = 1
      call jbessel2d(nterms,z,rscale1,jval,ifder,jder)
c
      jtemp(0) = jval(0)
      zmul=exp(-ima*theta)
      zinv=conjg(zmul)
      ztemp1= zmul
      ztemp2=-zinv
      do j = 1,nterms
      jtemp( j) = ztemp1*jval(j)
      jtemp(-j) = ztemp2*jval(j)
      ztemp1= ztemp1*zmul
      ztemp2=-ztemp2*zinv
      enddo
c
c     compute translation operator by FFT
c
      do j = 1,nsig
      transvec(j) = 0
      end do
      do j = 0,nterms
      transvec(j+1) = jtemp(j)/nsig
      end do
      do j = 1,nterms
      transvec(nsig-j+1) = jtemp(-j)/nsig
      end do
      call zfftf(nsig, transvec, wsave)
c
      return
      end
c
c
c
c
c
C***********************************************************************
      subroutine h2d_diagtrans(nd,nsig,sig,transvec,sig2)
      implicit none
C***********************************************************************
c
c     Carry out vector translation operator in diagonal form and
c     INCREMENT SIG2.
c
C---------------------------------------------------------------------
c     INPUT:
c
c     nd       : vector length (number of expansions)
c     nsig     : order of the HF signature,
c     sig      : original far-field signature function
c     transvec : diagonal translation operator
C---------------------------------------------------------------------
C     OUTPUT:
c
c     sig2     : translated expansion in diagonal form
C---------------------------------------------------------------------
      integer :: nsig,i,nd,ii
      double complex :: sig(nd,nsig), transvec(nsig), sig2(nd,nsig)
c
      do i = 1,nsig
         do ii = 1,nd
            sig2(ii,i) = sig2(ii,i) + transvec(i)*sig(ii,i)
         end do
      end do
c
      return
      end
c
c
c
c
c
C***********************************************************************
      subroutine h2dmplochf_vec(nd,zk,rscale1,center1,hexp,nterms1,
     1                rscale2,center2,jexp,nterms2)
      implicit none
C***********************************************************************
c
c     This routine maps multipole expansions HEXP to local expansions
C     using FFT convolution.
C     THIS IS NOT AN INCREMENTING ROUTINE - ONLY A TESTING ROUTINE.
C
C     The subroutine h2d_mploctrans(nsig,sig,transvec,sig2)
C     IS INCREMENTAL - that is sig2 is incremented by the translation of
C     sig. Inside the FMM, sig2 accumulates the contributions from all
C     incoming expansions before transformation back to the "physical" jexp
C     form.
C---------------------------------------------------------------------
c      INPUT:
c
c      nd      : vector length (number of expansions)
c      zk      : Helmholtz parameter
c      rscale1 : scaling parameter (IGNORED and assumed equal to 1)
c      center1 : center of original multiple expansion
c      hexp    : coefficients of original multiple expansions
c      nterms1 : order of original multipole expansion
c      rscale2 : scaling parameter (IGNORED and assumed equal to 1)
c      center2 : center of shifted multipole expansion
c      nterms2 : order of shifted multipole expansion
C---------------------------------------------------------------------
c      OUTPUT:
c
c      jexp    : coefficients of shifted local expansions
c
c      Note:
c      The FFT accelerated convolution is only valid at high
c      frequencies, and therefore rscale1 and rscale2 parameters
c      are assumed to be 1 (i.e. ignored) inside this routine.
C---------------------------------------------------------------------
      integer nterms1,nterms2,nsig,j,next235,nd,ii
      double precision center1(2),center2(2),dn,rscale1,rscale2
      double complex zk,hexp(nd,-nterms1:nterms1)
      double complex jexp(nd,-nterms2:nterms2)
      double complex, allocatable :: sig(:,:),wsave(:)
      double complex, allocatable :: transvec(:)
      double complex, allocatable :: sig2(:,:)
c
c     do the convolution via fft
c
      dn = 2*(nterms1+nterms2) + 1
      nsig = next235(dn)
ccc      write(6,*) ' nterms1 is',nterms1
ccc      write(6,*) ' nterms2 is',nterms2
ccc      write(6,*) ' nsig is',nsig
c
      allocate(sig(nd,nsig))
      allocate(transvec(nsig))
      allocate(sig2(nd,nsig))
      allocate(wsave(4*nsig+100))
c
      call zffti(nsig, wsave)
      call h2d_mptosig(nd,nterms1,nsig,hexp,sig,wsave)
      call h2d_mkm2ltrans(zk, center1, nterms1,
     1           center2, nterms2, nsig, wsave, transvec)
c
      do ii = 1,nd
      do j = 1,nsig
         sig2(ii,j) = 0.0d0
      enddo
      enddo
c
      call h2d_diagtrans(nd,nsig,sig,transvec,sig2)
c
      call h2d_sig2exp_vec(nd,nsig, sig2, wsave, nterms2, jexp)
      return
      end
c
c
c
c
c
C***********************************************************************
      subroutine h2d_sig2exp_vec(nd,nsig,sig,wsave,nterms,expans)
      implicit none
C***********************************************************************
c
c     This routine converts high-frequency signature functions to
c     either h-expansions or j-expansions (since it's the same formula
c     for both).
c
C---------------------------------------------------------------------
c     INPUT:
c
c     nd     : vector length (number of expansions)
c     nsig   : order of signature function
c     sig    : values of signature function, ordered FFT style
c     wsave  : work array constructed via a previous call to ZFFTI
c
C---------------------------------------------------------------------
c     OUTPUT:
c
c     nterms : desired order of expansion
c     expans : expansion coefficients, ordered multipole style
C---------------------------------------------------------------------
        integer :: nd,nsig, nterms,ii,j
        double complex :: sig(nd,nsig), wsave(nsig)
        double complex :: expans(nd,-nterms:nterms)
        double complex, allocatable :: sig2(:)
c
      allocate(sig2(nsig))
c
      do ii = 1,nd
         do j = 1,nsig
           sig2(j) = sig(ii,j)
         end do
         call zfftb(nsig, sig2, wsave)

         do j = 0,nterms
            expans(ii,j) = expans(ii,j) + sig2(j+1)
         end do
         do j = 1,nterms
            expans(ii,-j) = expans(ii,-j) + sig2(nsig-j+1)
         end do
      enddo

      return
      end
c
c
c
c
c
C***********************************************************************
      subroutine h2d_mkm2ltrans(zk, center1, nterms1,
     1           center2, nterms2, nsig, wsave, transvec)
C***********************************************************************
      implicit none
c
c
c     Create diagonal translation operator for mapping h-expansion to
c     j-expansion.
C---------------------------------------------------------------------
c      INPUT:
c
c      zk      : Helmholtz parameter
c      center1 : center of original multipole expansion
c      nterms1 : order of original multipole expansion
c      center2 : center of shifted local expansion
c      nterms2 : order of the eventual shifted local expansion
c      nsig    : order of the HF signature, should be good for FFT and
c                greater than 2*(nterm1+nterms2)+1
c      wsave   : FFT work array from call to ZFFTI with size nsig
C---------------------------------------------------------------------
c      OUTPUT:
c
c     transvec : translation operator in diagonal form
C---------------------------------------------------------------------
      integer :: nterms1,nterms2,nsig,nterms,ifder,j
      double complex :: zk, transvec(nsig)
      double complex :: wsave(*)
      double precision :: center1(2), center2(2), zdiff(2)
      double precision :: done,pi,r,theta,rscale1
      double complex :: z,ima, zmul,zinv,ztemp1,ztemp2
      double complex, allocatable :: hval(:), hder(:), htemp(:)

      data ima/(0.0d0,1.0d0)/

      done=1
      pi=4*atan(done)

      nterms = nterms1+nterms2
c
      allocate(hval(0:nterms+5))
      allocate(hder(0:nterms+5))
      allocate(htemp(-nterms-5:nterms+5))

      zdiff(1)=center2(1)-center1(1)
      zdiff(2)=center2(2)-center1(2)
      call h2cart2polar(zdiff,r,theta)

      theta=theta-pi
      z=zk*r
c
      ifder=0
      rscale1 = 1
      call h2dall(nterms+1,z,rscale1,hval,ifder,hder)

      htemp(0) = hval(0)
      zmul=exp(-ima*theta)
      zinv=conjg(zmul)
      ztemp1= zmul
      ztemp2=-zinv
      do j = 1,nterms
        htemp( j) = ztemp1*hval(j)
        htemp(-j) = ztemp2*hval(j)
        ztemp1= ztemp1*zmul
        ztemp2=-ztemp2*zinv
      enddo
c
c     compute transfer function by FFT
c
      do j = 1,nsig
        transvec(j) = 0
      end do
      do j = 0,nterms
        transvec(j+1) = htemp(j)/nsig
      end do
      do j = 1,nterms
        transvec(nsig-j+1) = htemp(-j)/nsig
      end do
c
      call zfftf(nsig, transvec, wsave)
c
      return
      end


!*****************************************************************************************
!> author: Jacob Williams
!  license: BSD
!
!  The main module that uses all the other modules.
!  Allows for a single `use fortran_astrodynamics_toolkit`
!  to access the entire library.

    module fortran_astrodynamics_toolkit

    use analytical_ephemeris_module
    use base_class_module
    use bplane_module
    use brent_module
    use celestial_body_module
    use complex_step_module
    use conversion_module
    use crtbp_module
    use drag_module
    use eispack_module
    use ephemeris_module
    use geodesy_module
    use geometry_module
    use geopotential_module
    use gooding_module
    use gravity_module
    use halo_orbit_module
    use iau_orientation_module
    use jpl_ephemeris_module
    use kepler_module
    use kind_module
    use lambert_module
    use math_module
    use matrix_module
    use minpack_module
    use modified_equinoctial_module
    use numbers_module
    use obliquity_module
    use orbital_mechanics_module
    use random_module
    use relative_motion_module
    use rk_module
    use rk_module_variable_step
    use standish_module
    use string_module
    use time_module
    use transformation_module
    use vector_module

    use c_interface_module

    implicit none

    public

    end module fortran_astrodynamics_toolkit
!*****************************************************************************************


! Some very basic vector analysis operations using autodiff for vectors in the x-y plane

! grad, div, curl, del_squared

module vector_analysis
    use auto_diff
    implicit none

    abstract interface
        function f(p)
            import
            type(auto_var) :: f
            type(auto_var), intent(in) :: p(3)
        end function f
    end interface

    interface
        module function grad(p, phi) result(r)
            real(8) :: r(3)
            real(8), intent(in) :: p(3)
            procedure(f)        :: phi
        end function grad

        module function div(p, phi)
            real(8) :: div
            real(8), intent(in) :: p(3)
            procedure(f)        :: phi
        end function div

        !module function del_squared(p, phi)
        !    real(8) :: del_squared
        !    real(8), intent(in) :: p(3)
        !    procedure(f)        :: phi
        !end function del_squared
        !
        !module function curl(p, phi)
        !    real(8) :: curl
        !    real(8), intent(in) :: p(3)
        !    procedure(f)        :: phi
        !end function curl

        module function evaluate(p, phi)
            real(8) :: evaluate
            real(8), intent(in) :: p(3)
            procedure(f)        :: phi
        end function evaluate

    end interface

    ! Access the cross product as an operator so that the code reads better
    interface operator(.cross.)
        module pure function cross(a, b) result(r)
            real(8), intent(in) :: a(3), b(3)
            real(8) :: r(3)
        end function cross
    end interface

end module vector_analysis


! mimic NWChem tgt_sd_t_s1_1 kernel

#define simd schedule(static,1)

  implicit integer (a-z)
  l1 = 1; l2 = 1; l3 = 1; l4 = 1; l5 = 1; l6 = 1;
  u1 = 24; u2 = 24; u3 = 24; u4 = 24; u5 = 24; u6 = 24;
  call tgt_sd_t_s1_1(l1,l2,l3,l4,l5,l6, u1,u2,u3,u4,u5,u6)
  end

subroutine tgt_sd_t_s1_1(l1,l2,l3,l4,l5,l6, u1,u2,u3,u4,u5,u6)
  implicit integer (a-z)
  real a(24,24,24,24,24,24)
  real b(24,24,24,24,24,24)

  a=3.0
  b=0.0

  n1 = 24
  n2 = 24
  n3 = 24
  n4 = 24
  n5 = 24
  n6 = 24

  nn = n1*n2*n3*n4*n5*n6

!$omp target teams distribute parallel do simd
  do ii = 1, nn
     t = ii-1
     q = t / n6
     r = t - q*n6
     i6 = l6 + r

     t = q
     q = t / n5
     r = t - q*n5
     i5 = l5 + r

     t = q
     q = t / n4
     r = t - q*n4
     i4 = l4 + r

     t = q
     q = t / n3
     r = t - q*n3
     i3 = l3 + r

     t = q
     q = t / n2
     r = t - q*n2
     i2 = l2 + r

     t = q
     q = t / n1
     r = t - q*n1
     i1 = l1 + r

     b(i6,i5,i4,i3,i2,i1) = a(i6,i5,i4,i3,i2,i1) + i3
enddo
!$omp end target teams distribute parallel do

!  write(6,*) b(1,1,1,1,1,1)
!  write(6,*) a(1,1,1,1,1,1)

  write(6,*) ((b(k,j,1,1,1,1),j=1,4),k=1,4)
  return
end


catc     program DRDPRPL1
c>> 1996-06-27 DRDPRPL1  Krogh Special code for C conversion.
c>> 1994-10-19 DRDPRPL1  Krogh  Changes to use M77CON
c>> 1992-02-14 DRDPRPL1  CLL
c     ------------------------------------------------------------------
c--D replaces "?": DR?PRPL1, ?PRPL1
c     ------------------------------------------------------------------
      integer I, IERR, LINE, NLMAX, NCMAX, NP
      parameter(NLMAX = 45, NCMAX = 110, NP = 101)
      double precision ALPHA, BETA, DX, X(NP),XT, Y(NP)
      parameter(ALPHA = 0.15d0, BETA = 0.015d0, DX = 1.0d0)
c%%    long int ierr, line;
c%%    char image[45][111], image2[45][80];
      character IMAGE(NLMAX)*(NCMAX)
c     ------------------------------------------------------------------
      XT= -36.0d0
      do 10 I=1,NP
        X(I)=XT
        Y(I)=X(I)*SIN(ALPHA*X(I)+BETA)
        XT=XT+DX
   10 continue
c
c++ Code for ~.C. is active
      call DPRPL1(X,Y,NP,
     *   'Demo of DPRPL1 with NLINES = 45 and NCHARS = 110',
     *   'X VALUES','Y VALUES', 45, 110, IMAGE, IERR)
      print'(1x,a)',IMAGE
      print'(1x/1x)'
c
      call DPRPL1(X,Y,NP,
     *   'Demo of DPRPL1 with NLINES = 22 and NCHARS = 79',
     *   'X VALUES','Y VALUES', 22, 79, IMAGE, IERR)
      print'(1x,a)',(IMAGE(LINE)(1:79), LINE = 1,22)
c++ Code for .C. is inactive
c%%   dprpl1( x,y,NP,"Demo of DPRPL1 with NLINES = 45 and NCHARS = 110",
c%%    "X VALUES","Y VALUES",45,111,(byte*)image,&ierr );
c%%   for(line=0; line < 45; line++)
c%%           printf( "\n%111.111s", image[line]);
c%%   printf( "\n" );
c%%   printf( " \n \n" );
c%%   dprpl1( x,y,NP,"Demo of DPRPL1 with NLINES = 22 and NCHARS = 79",
c%%    "X VALUES","Y VALUES",22,80,(byte*)image2,&ierr );
c%%   printf( " " );
c%%   for (line = 0; line < 22; line++)
c%%     printf( "\n%80.80s", image2[line] );
c%%   printf( "\n" );
c++ End
      stop
      end


C
C $Id: hstmed.f,v 1.7 2008-07-27 00:17:15 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C *****************************************************
C
      SUBROUTINE HSTMED(DATARR,NPTS2,WRK2,MED)
C
C *****************************************************
C
C  FINDS MEDIAN OF ALL DATA POINTS USING SHELL SORT
C
      REAL DATARR(NPTS2), WRK2(NPTS2), MED, TEMP
      INTEGER FLAG, D, HALFN
C
C  COPY DATA ARRAY TO WORK ARRAY
C
        DO 790 I = 1,NPTS2
  790     WRK2(I) = DATARR(I)
C
C  DO SHELL SORT
C
        HALFN = NPTS2/2
        D = NPTS2
  810   D = (D+1)/2
        FLAG = 0
        DO 830 I=1, NPTS2-D
          IF(WRK2(I) .GT. WRK2(I+D)) THEN
            TEMP = WRK2(I)
            WRK2(I) = WRK2(I+D)
            WRK2(I+D) = TEMP
            FLAG = 1
          ENDIF
  830   CONTINUE
        IF (FLAG .EQ. 1 .OR. D .GT. 1)GOTO 810
C
  850 IF (REAL(NPTS2)/2. .GT. REAL(HALFN)) THEN
        MED = WRK2(MIN(HALFN + 1,NPTS2))
      ELSE
        MED = (WRK2(MAX(1,HALFN)) + WRK2(MIN(HALFN + 1,NPTS2)))/2.
      ENDIF
      RETURN
      END


          program demo_unit_check
          use M_verify, only: unit_check
          use M_verify, only: unit_check_start
          use M_verify, only: unit_check_done
          use M_verify,  only: almost

          !!use M_verify, only: unit_check_keep_going         ! default is unit_check_keep_going=.false.
          !!use M_verify, only: debug              ! default is .false.
          !!use M_verify, only: unit_check_command ! default is unit_check_command='goodbad'

          implicit none
          integer :: i
          integer :: x
          integer,allocatable :: arr(:)
          real,allocatable :: arr1(:)
          real,allocatable :: arr2(:)

             !!unit_check_command=''
             x=10
             arr1=[1.0,10.0,100.0]
             arr2=[1.0001,10.001,100.01]
             call unit_check_start('myroutine')

             call unit_check('myroutine', x.gt.3 ,'test if big enough')
             call unit_check('myroutine', x.lt.100 ,'test if small enough')

             do i=1,size(arr1)
                call unit_check('myroutine', almost(arr1(i),arr2(i),3.9,verbose=.true.) )
             enddo

             arr=[10,20,30]
             call unit_check('myroutine', .not.any(arr.lt.0) ,'test if any negative values in array ARR')
             call unit_check('myroutine', all(arr.lt.100) ,'test if all values less than 100 in array ARR')

             call unit_check_done('myroutine',msg='checks on "myroutine" all passed')

              end program demo_unit_check


program vin
  integer :: numbers(9)
  numbers = 3
  numbers(1:3) = numbers(2:4) + numbers(3:5) + 2 - numbers(8)
  print *,numbers
end program vin


      FUNCTION XSPENZ_Wdec(X)
*     ---------------
* Hans Kuijf, 1988
* XSPENZ(X) calcs the complex spence-function, through mapping on
* the area where there is a quickly convergent series.
      REAL*8 PI
      COMPLEX*16 X, SPENC_Wdec, XSPENZ_Wdec
      PI=4D0*DATAN(1D0)
* Map the x on the unit circle.
* But so that x is not in the neighbourhood of (1,0)
* ABS(Z)=-CDLOG(1D0-X) is always smaller than 1.10
* But (1.10)^19/(19!)*bernoulli(19)=2.7D-15
      IF (CDABS(1D0-X).LT.1D-13) THEN
        XSPENZ_Wdec=PI*PI/6D0
      ELSE IF (CDABS(1D0-X).LT.0.5D0) THEN
        XSPENZ_Wdec=PI*PI/6D0-CDLOG(1D0-X)*CDLOG(X)-SPENC_Wdec(1D0-X)
      ELSE IF (CDABS(X).GT.1D0) THEN
        XSPENZ_Wdec=-PI*PI/6D0-0.5D0*CDLOG(-X)*CDLOG(-X)
     &              -SPENC_Wdec(1D0/X)
      ELSE
        XSPENZ_Wdec = SPENC_Wdec(X)
      END IF
      END

      FUNCTION SPENC_Wdec(X)
      COMPLEX*16 X,SUM,Z,Z2,SPENC_Wdec
      Z=-CDLOG(1D0-X)
      Z2=Z*Z
* Horner's rule for the powers z^3 through z^19
      SUM=43867D0/798D0
      SUM=SUM*Z2/342D0-3617D0/510D0
      SUM=SUM*Z2/272D0+7D0/6D0
      SUM=SUM*Z2/210D0-691D0/2730D0
      SUM=SUM*Z2/156D0+5D0/66D0
      SUM=SUM*Z2/110D0-1D0/30D0
      SUM=SUM*Z2/ 72D0+1D0/42D0
      SUM=SUM*Z2/ 42D0-1D0/30D0
      SUM=SUM*Z2/ 20D0+1D0/6D0
* The first three terms of the power series
      SUM=Z2*Z*SUM/6D0-0.25D0*Z2+Z
      SPENC_Wdec=SUM
      END
*
        FUNCTION CSPEN_Wdec(Z)
C       FUNCTION XSPENZ(Z)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       SPENCE-FUNKTION KOMPLEX, FREI NACH HOLLIK                     C
C---------------------------------------------------------------------C
C       20.07.83    UE 20.08.85                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       COMPLEX*16 XSPENZ_Wdec,W,SUM,Z,U
        COMPLEX*16 CSPEN_Wdec ,W,SUM,Z,U
        REAL*8 RZ,AZ,A1
        REAL*8 B(9)
      DATA B/
     1   0.1666666666666666666666666667D0,
     2  -0.0333333333333333333333333333D0,
     3   0.0238095238095238095238095238D0,
     4  -0.0333333333333333333333333333D0,
     5   0.0757575757575757575757575758D0,
     6  -0.2531135531135531135531135531D0,
     7   1.1666666666666666666666666667D0,
     8  -7.09215686274509804D0         ,
     9  54.97117794486215539D0         /
C     BEACHTE:                 B(N)=B2N
C     B(1)=1./6.
C     B(2)=-1./30.
C     B(3)=1./42.
C     B(4)=-1./30.
C     B(5)=5./66.
C     B(6)=-691./2730.
C     B(7)=7./6.
C     B(8)=-3617./510.
C     B(9)=43867./798.
C     B(10)=-174611./330.
C     B(11)=854513./138.
C     PI=3.1415926535897932384
C     PI*PI/6.=1.6449..., PI*PI/3=3.28986...
C
C---> GENAUIGKEIT
c      II = 9
      ii = 8
      RZ=DREAL(Z)
      AZ=CDABS(Z)
      A1=CDABS(1D0-Z)
      IF((DABS(RZ-1D0).LE.1D-15).AND.(dabs(DIMAG(Z)).le.1D-15))GOTO 40
      IF(RZ.GT.5D-1) GOTO 20
      IF(AZ.GT.1D0) GOTO 10
      W=-CDLOG(1D0-Z)
      SUM=W-0.25D0*W*W
      U=W
      DO 1 K=1,II
      U=U*W*W/DFLOAT(2*K*(2*K+1))
      SUM=SUM+U*B(K)
 1    CONTINUE
      CSPEN_Wdec=SUM
      RETURN
10    W=-CDLOG(1D0-1D0/Z)
      SUM=W-0.25D0*W*W
      U=W
      DO 11 K=1,II
      U=U*W*W/DFLOAT(2*K*(2*K+1))
      SUM=SUM+U*B(K)
11    CONTINUE
      CSPEN_Wdec=-SUM-1.64493406684822643D0-.5D0*CDLOG(-Z)**2
      RETURN
20    IF(A1.GT.1D0) GOTO 30
      W=-CDLOG(Z)
      SUM=W-0.25D0*W*W
      U=W
      DO 21 K=1,II
      U=U*W*W/DFLOAT(2*K*(2*K+1))
      SUM=SUM+U*B(K)
21    CONTINUE
      CSPEN_Wdec=-SUM+1.64493406684822643D0-CDLOG(Z)*CDLOG(1D0-Z)
      RETURN
30    W=CDLOG(1D0-1D0/Z)
      SUM=W-0.25D0*W*W
      U=W
      DO 31 K=1,II
      U=U*W*W/DFLOAT(2*K*(2*K+1))
      SUM=SUM+U*B(K)
31    CONTINUE
      CSPEN_Wdec=SUM+3.28986813369645287D0
     *               +.5D0*CDLOG(Z-1D0)**2-CDLOG(Z)*CDLOG(1D0-Z)
50    CONTINUE
      RETURN
40    CSPEN_Wdec=DCMPLX(1.64493406684822643D0,0D0)
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program 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 General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine basis(x,y,z,xo,yo,zo,nx,ny,nz,planfa,ifatet,nktet,
     &     netet,field,nfield,cotet,kontyp,ipkon,kon,iparent,xp,yp,zp,
     &     value,ratio,iselect,nselect,istartset,iendset,ialset,
     &     imastset,ielemnr,nterms,konl,nelem,loopa,dist)
!
!     interpolates fields from a master mesh onto a new node at an
!     arbitrary position p. The master mesh must consist of volumetric
!     elements. These are called the parent elements. They are supposed
!     to be subdivided into 1 or more linear (= 4-noded) tetrahedral
!     elements.
!     The search to which parent element position p belongs is done
!     using the tetrangulation. It permits to find the appropriate
!     tetrahedron to which p belongs and through the parent relationship
!     to which parent element
!
!     INPUT
!
!     x(*)            x-coordinates of the center of gravity of the
!                     tetrahedra in the tetrangulation of the master mesh,
!                     = xo, sorted in ascending order
!     y(*)            y-coordinates of the center of gravity of the
!                     tetrahedra in the tetrangulation of the master mesh,
!                     = yo, sorted in ascending order
!     z(*)            z-coordinates of the center of gravity of the
!                     tetrahedra in the tetrangulation of the master mesh,
!                     = zo, sorted in ascending order
!     xo(*)           x-coordinates of the center of gravity of the
!                     tetrahedra in the tetrangulation of the master mesh,
!     yo(*)           y-coordinates of the center of gravity of the
!                     tetrahedra in the tetrangulation of the master mesh,
!     zo(*)           z-coordinates of the center of gravity of the
!                     tetrahedra in the tetrangulation of the master mesh,
!     nx(i)           position in xo of entry i of x
!     ny(i)           position in yo of entry i of y
!     nz(i)           position in zo of entry i of z
!     planfa(4,i)     coefficients of the plane of tetrahedral face i:
!                     planfa(1)*x+planfa(2)*y+planfa(3)*z+planfa(4)=0
!     ifatet(1..4,i)  faces of tetrahedron i
!     nktet           highest node number in the tetrahedral mesh
!     netet           number of tets in the tetrahedral mesh = highest
!                     element number
!     field(i,nktet)  nodal values of field i in the tet nodes
!     nfield          maximum number of available field in the master mesh
!     cotet(3,*)      coordinates of the tet nodes
!     kontyp(i)       type of parent element i (convention for the types as
!                     in CalculiX GraphiX)
!     ipkon(i)        entry before the start of the topology description
!                     for parent element i (= list of nodes belonging to the
!                     element) in field kon
!     kon(*)          field with the topology of all parent elements
!     iparent(i)      parent element of tetrahedral element i;
!     xp              x-coordinate for the location in which the field are
!                     to be interpolated
!     yp              y-coordinate for the location in which the field are
!                     to be interpolated
!     zp              z-coordinate for the location in which the field are
!                     to be interpolated
!     iselect(*)      selected fields for interpolation. Must be numbers
!                     in the interval [1,nfield]
!     nselect         number of selected fields for interpolation. Must be
!                     smaller or equal to nfield
!     istartset(i)    starting position in field ialset for set i
!     iendset(i)      ending position in field ialset for set i
!     ialset(*)       field containing all set information
!     imastset        element set consisting of parent element within
!                     which the interpolation is to be done. This
!                     allows to limit the interpolation to a subset
!                     of parent elements. This may be important in
!                     case of a discontinuous master field
!     ielemnr(i)      number of parent element i as used in set imastset
!     loopa           number of loops used in attached_3d.f. The accuracy
!                     of the projection onto the parent element in local
!                     coordinates is 10**(-loopa)
!
!     OUTPUT
!
!     value(nfield)   interpolated values (max. nfield values)
!     ratio(nterms)   coefficients for the interpolation within the parent
!                     element
!     nterms          number of coeffients in the interpolation. This is
!                     also the number of nodes belonging to the parent
!                     element
!     konl(nterms)    node numbers of the parent element ielemnr
!     nelem           number of the parent element to which p belongs.
!     dist            distance from p to the parent element to which
!                     it belongs. Ideally this is a very small number,
!                     however, if p is external to the master mesh this
!                     number may be finite
!     xp              x-coordinate of the closest location within the
!                     master mesh
!     yp              y-coordinate of the closest location within the
!                     master mesh
!     zp              z-coordinate of the closest location within the
!                     master mesh
!
      implicit none
!
!     100 nearest nodes: node(100),idummy1(100),idummy2(100),iparentel(100)
!
      integer ifatet(4,*),id,node(netet),near,nx(*),ny(*),nz(*),
     &     ifs,iface,i,konl(20),nfield,nktet,ielement,ielmax,netet,k,
     &     j,iselect(nselect),nselect,kontyp(*),ipkon(*),kon(*),
     &     nterms,indexe,nelem,konl_opt(20),idummy1(netet),
     &     iparentel(netet),nparentel,kflag,ii,inside,nterms_opt,
     &     istartset(*),iendset(*),ialset(*),imastset,ielemnr(*),
     &     ielementnr,nlength,nearset,nelem_opt,loopa,ielement2,
     &     iparent(*),idummy2(netet)
!
      real*8 cotet(3,*),planfa(4,*),dface,dfacemax,tolerance,
     &     dist,field(nfield,nktet),ratio(20),pneigh(3,20),pnode(3),xi,
     &     et,ze,dist_opt,ratio_opt(20),xp,yp,zp,x(*),y(*),z(*),xo(*),
     &     yo(*),zo(*),value(nfield)
!
      tolerance=1.d-6
!
      if(imastset.ne.0) then
        nlength=iendset(imastset)-istartset(imastset)+1
      endif
!
!     look for the global element encompassing point (xp,yp,zp)
!
      do ii=1,4
!
!     three/four-level algorithm
!     - start with the search for the nearest neighboring element
!     - if this element is not the right one search for the 10
!     nearest neighbors
!     - if no fitting element was found, search for the 100 nearest
!     neighbors
!     - fourth level (only if a master element set is given)
!     if none of the 100 nearest neighbors belongs to the given
!     master element set, loop over all elements
!
        if(ii.eq.1) then
          near=1
        elseif(ii.eq.2) then
          near=min(10,netet)
        elseif(ii.eq.3) then
          near=min(100,netet)
        else
          write(*,*) '*WARNING in basis: more than 100'
          write(*,*) '         neighbors are needed in order'
          write(*,*) '         to find a global element to'
          write(*,*) '         which the local node belongs;'
          write(*,*) '         the global element set may not'
          write(*,*) '         be correctly selected by the'
          write(*,*) '         user;'
          write(*,*) '         global coordinates of the local'
          write(*,*) '         node: ',xp,yp,zp
          near=netet
        endif
c     write(*,*) 'basis ',ii
!
        if(ii.lt.4) then
!
!     looking for the nearest linear tetrahedral element
!
          call near3d(xo,yo,zo,x,y,z,nx,ny,nz,xp,yp,zp,netet,
     &         node,near)
        endif
!
        inside=0
        nearset=0
        ielmax=0
!
        do i=1,near
          if(ii.lt.4) then
            ielement=node(i)
          else
            ielement=i
          endif
!
!     check whether the linear tetrahedral element belongs to the
!     right set, if a set is specified
!
!     ielement is a tetrahedral element number
!     iparent(ielement) is a running number from 1 to the
!     total number of elements
!     ielemnr(iparent(ielement)) is the real element number
!     (there can be gaps in the numbering)
!
          if(imastset.ne.0) then
            ielementnr=ielemnr(iparent(ielement))
            call nident(ialset(istartset(imastset)),ielementnr,
     &           nlength,id)
            if(id.le.0) cycle
            if(ialset(istartset(imastset)+id-1).ne.ielementnr) cycle
            nearset=nearset+1
            node(nearset)=node(i)
          else
            nearset=near
          endif
!
          dface=0.d0
          do j=1,4
!
!     the face number in ifatet is negative, if the equation
!     of the face plane is such, that its value in the
!     remaining node of the tetrahedron is negative
!
            ifs=ifatet(j,ielement)
            iface=abs(ifs)
            dist=planfa(1,iface)*xp+planfa(2,iface)*yp
     &           +planfa(3,iface)*zp+planfa(4,iface)
            if(dist*ifs.lt.-1.d-10*iface) then
              dface=dface+dist*ifs/iface
            endif
          enddo
c          write(*,*) 'basis dface 1',dface,ielemnr(iparent(ielement))
          if(dface.gt.-1.d-10) then
            inside=1
!
!     check whether the other parent elements are in the
!     master set (the fact that the node is inside a linear
!     tetrahedron does not mean that the node is within the
!     parent element; if not, all parent elements are checked;
!     therefore the other parent elements have
!     to be checked on whether they belong to the master set;
!
            if(imastset.ne.0) then
              do j=i+1,near
                if(ii.lt.4) then
                  ielement2=node(j)
                else
                  ielement2=j
                endif
                ielementnr=ielemnr(iparent(ielement2))
                call nident(ialset(istartset(imastset)),ielementnr,
     &               nlength,id)
                if(id.le.0) cycle
                if(ialset(istartset(imastset)+id-1).ne.ielementnr)
     &               cycle
                nearset=nearset+1
                node(nearset)=node(j)
              enddo
            else
              nearset=near
            endif
!
            exit
          endif
c     if(i.eq.1) then
          if(ielmax.eq.0) then
            dfacemax=dface
            ielmax=ielement
          else
            if(dface.gt.dfacemax) then
              ielmax=ielement
              dfacemax=dface
            endif
          endif
        enddo
!
!     if a global element set was defined, check whether an
!     appropriate element was found
!
        if(imastset.ne.0) then
          if(nearset.eq.0) then
            if(ii.lt.4) then
              cycle
            else
              write(*,*) '*ERROR: no suitable global element found'
              write(*,*) '        for location (',xp,yp,zp,')'
              call exit(201)
            endif
          endif
        endif
!
!     if no linear tetrahedral element was found, the linear tetrahedral
!     element with the smallest dfacemax (in absolute value; summed distance)
!     is taken
!
        if(inside.eq.0) then
          ielement=ielmax
        endif
!
        nelem=iparent(ielement)
c     write(*,*) 'basis element ',nelem,kontyp(nelem)
        if(kontyp(nelem).eq.1) then
          nterms=8
        elseif(kontyp(nelem).eq.2) then
          nterms=6
        elseif(kontyp(nelem).eq.3) then
          nterms=4
        elseif(kontyp(nelem).eq.4) then
          nterms=20
        elseif(kontyp(nelem).eq.5) then
          nterms=15
        elseif(kontyp(nelem).eq.6) then
          nterms=10
        else
          nterms=0
        endif
        indexe=ipkon(nelem)
!
!     modify order of connectivity ccx <-> cgx
!
        if(kontyp(nelem).eq.4) then
          do i=1,12
            konl(i)=kon(indexe+i)
          enddo
          do i=13,16
            konl(i+4)=kon(indexe+i)
          enddo
          do i=17,20
            konl(i-4)=kon(indexe+i)
          enddo
        elseif(kontyp(nelem).eq.5) then
          do i=1,9
            konl(i)=kon(indexe+i)
          enddo
          do i=10,12
            konl(i+3)=kon(indexe+i)
          enddo
          do i=13,15
            konl(i-3)=kon(indexe+i)
          enddo
        else
          do i=1,nterms
            konl(i)=kon(indexe+i)
          enddo
        endif
!
!     nodes of master element
!
        do i=1,nterms
          do j=1,3
            pneigh(j,i)=cotet(j,konl(i))
          enddo
        enddo
!
!     slave node
!
        pnode(1)=xp
        pnode(2)=yp
        pnode(3)=zp
!
!     attaching slave node to master element
!
        if(nterms.ne.0) then
          call attach_3d(pneigh,pnode,nterms,ratio,dist,xi,et,ze,
     &         loopa)
        endif
c        write(*,*) 'basis dist 2',dist
c     write(*,123) xi,et,ze,dist
c     123     format('basis ',4(1x,e11.4))
!
!     checking the parent elements of the "best" tetrahedra
!     in case the distance between slave node and location of
!     interpolation exceeds "tolerance"
!
        if(dist.gt.tolerance) then
          do i=1,nterms
            konl_opt(i)=konl(i)
            ratio_opt(i)=ratio(i)
          enddo
          nelem_opt=nelem
          nterms_opt=nterms
          dist_opt=dist
!
!     sorting the parent elements (different linear tetrahedrals
!     may have the same parent element)
!
          do i=1,nearset
            idummy1(i)=iparent(node(i))
          enddo
          kflag=1
          call isortii(idummy1,idummy2,nearset,kflag)
          nparentel=0
          do i=1,nearset
            if(idummy1(i).eq.nelem) cycle
            if(i.eq.1) then
              iparentel(1)=idummy1(1)
              nparentel=1
            else
              if(idummy1(i).ne.idummy1(i-1)) then
                nparentel=nparentel+1
                iparentel(nparentel)=idummy1(i)
              endif
            endif
          enddo
!
          do k=1,nparentel
!
!     slave node
!
            pnode(1)=xp
            pnode(2)=yp
            pnode(3)=zp
            nelem=iparentel(k)
            if(kontyp(nelem).eq.1) then
              nterms=8
            elseif(kontyp(nelem).eq.2) then
              nterms=6
            elseif(kontyp(nelem).eq.3) then
              nterms=4
            elseif(kontyp(nelem).eq.4) then
              nterms=20
            elseif(kontyp(nelem).eq.5) then
              nterms=15
            elseif(kontyp(nelem).eq.6) then
              nterms=10
            else
              nterms=0
            endif
            indexe=ipkon(nelem)
!
!     modify order of connectivity ccx <-> cgx
!
            if(kontyp(nelem).eq.4) then
              do i=1,12
                konl(i)=kon(indexe+i)
              enddo
              do i=13,16
                konl(i+4)=kon(indexe+i)
              enddo
              do i=17,20
                konl(i-4)=kon(indexe+i)
              enddo
            elseif(kontyp(nelem).eq.5) then
              do i=1,9
                konl(i)=kon(indexe+i)
              enddo
              do i=10,12
                konl(i+3)=kon(indexe+i)
              enddo
              do i=13,15
                konl(i-3)=kon(indexe+i)
              enddo
            else
              do i=1,nterms
                konl(i)=kon(indexe+i)
              enddo
            endif
!
!     nodes of master element
!
            do i=1,nterms
              do j=1,3
                pneigh(j,i)=cotet(j,konl(i))
              enddo
            enddo
!
!     attaching slave node to master element
!
            if(nterms.ne.0) then
              call attach_3d(pneigh,pnode,nterms,ratio,dist,
     &             xi,et,ze,loopa)
            endif
c      write(*,*) 'basis ii 3',ii,nelem,dist
!
!     check whether the present element yields better results
!
            if(dist.lt.dist_opt) then
c     write(*,123) xi,et,ze,dist
              do i=1,nterms
                konl_opt(i)=konl(i)
                ratio_opt(i)=ratio(i)
              enddo
              nelem_opt=nelem
              nterms_opt=nterms
              dist_opt=dist
            endif
            if(dist.lt.tolerance) exit
          enddo
!
!     storing the optimal configuration
!
          nelem=nelem_opt
          nterms=nterms_opt
c
          dist=dist_opt
c
          do i=1,nterms
            konl(i)=konl_opt(i)
            ratio(i)=ratio_opt(i)
          enddo
        endif
!
        if((ii.eq.3).or.(dist.lt.tolerance)) exit
!
      enddo
!
!     calculate the coordinates of the closest location
!
      xp=0.d0
      yp=0.d0
      zp=0.d0
      do j=1,nterms
        xp=xp+ratio(j)*cotet(1,konl(j))
        yp=yp+ratio(j)*cotet(2,konl(j))
        zp=zp+ratio(j)*cotet(3,konl(j))
      enddo
!
!     interpolating the fields
!
c      write(*,*) 'basis end 4',dist,tolerance,near
      do k=1,nselect
        i=iselect(k)
        value(k)=0.d0
        do j=1,nterms
!
!     due to round-off the values can be slightly outside the
!     (0,1) range
!
c          ratio(j)=max(0.d0,ratio(j))
c          ratio(j)=min(1.d0,ratio(j))
!
          value(k)=value(k)+ratio(j)*field(i,konl(j))
c     write(*,*) 'basis j',j,konl(j),field(i,konl(j))
        enddo
c     write(*,*) 'basis select',k,i,value(k)
      enddo
!
      return
      end