! This code is not protected by the DART copyright agreement.
! DART $Id$

! ======================================================================
! NIST Guide to Available Math Software.
! Source for module FFT from package GO.
! Retrieved from NETLIB on Wed Jul  5 11:50:07 1995.
! ======================================================================

      subroutine fft(a,b,ntot,n,nspan,isn)

!  multivariate complex fourier transform, computed in place
!    using mixed-radix fast fourier transform algorithm.
!  by r. c. singleton, stanford research institute, sept. 1968
!  arrays a and b originally hold the real and imaginary
!    components of the data, and return the real and
!    imaginary components of the resulting fourier coefficients.
!  multivariate data is indexed according to the fortran
!    array element successor function, without limit
!    on the number of implied multiple subscripts.
!    the subroutine is called once for each variate.
!    the calls for a multivariate transform may be in any order.
!  ntot is the total number of complex data values.
!  n is the dimension of the current variable.
!  nspan/n is the spacing of consecutive data values
!    while indexing the current variable.
!  the sign of isn determines the sign of the complex
!    exponential, and the magnitude of isn is normally one.
!  a tri-variate transform with a(n1,n2,n3), b(n1,n2,n3)
!    is computed by
!      call fft(a,b,n1*n2*n3,n1,n1,1)
!      call fft(a,b,n1*n2*n3,n2,n1*n2,1)
!      call fft(a,b,n1*n2*n3,n3,n1*n2*n3,1)
!  for a single-variate transform,
!    ntot = n = nspan = (number of complex data values), e.g.
!      call fft(a,b,n,n,n,1)
!  the data can alternatively be stored in a single complex array c
!    in standard fortran fashion, i.e. alternating real and imaginary
!    parts. then with most fortran compilers, the complex array c can
!    be equivalenced to a real array a, the magnitude of isn changed
!    to two to give correct indexing increment, and a(1) and a(2) used
!    to pass the initial addresses for the sequences of real and
!    imaginary values, e.g.
!       complex c(ntot)
!       real    a(2*ntot)
!       equivalence (c(1),a(1))
!       call fft(a(1),a(2),ntot,n,nspan,2)
!  arrays at(maxf), ck(maxf), bt(maxf), sk(maxf), and np(maxp)
!    are used for temporary storage.  if the available storage
!    is insufficient, the program is terminated by a stop.
!    maxf must be .ge. the maximum prime factor of n.
!    maxp must be .gt. the number of prime factors of n.
!    in addition, if the square-free portion k of n has two or
!    more prime factors, then maxp must be .ge. k-1.
!      dimension a(1),b(1)
      dimension a(*),b(*)
!  array storage in nfac for a maximum of 15 prime factors of n.
!  if n has more than one square-free factor, the product of the
!    square-free factors must be .le. 210
      dimension nfac(101),np(209)
!  array storage for maximum prime factor of 23
      dimension at(53),ck(53),bt(53),sk(53)
      equivalence (i,ii)
!  the following two constants should agree with the array dimensions.
      maxp=209
      if(n .lt. 2) return
      inc=isn
      c72=0.30901699437494742
      s72=0.95105651629515357
      s120=0.86602540378443865
      rad=6.2831853071796
      if(isn .ge. 0) go to 10
      s72=-s72
      s120=-s120
      rad=-rad
      inc=-inc
   10 nt=inc*ntot
      ks=inc*nspan
      kspan=ks
      nn=nt-inc
      jc=ks/n
      radf=rad*float(jc)*0.5
      i=0
      jf=0
!  determine the factors of n
      m=0
      k=n
      go to 20
   15 m=m+1
      nfac(m)=4
      k=k/16
   20 if(k-(k/16)*16 .eq. 0) go to 15
      j=3
      jj=9
      go to 30
   25 m=m+1
      nfac(m)=j
      k=k/jj
   30 if(mod(k,jj) .eq. 0) go to 25
      j=j+2
      jj=j**2
      if(jj .le. k) go to 30
      if(k .gt. 4) go to 40
      kt=m
      nfac(m+1)=k
      if(k .ne. 1) m=m+1
      go to 80
   40 if(k-(k/4)*4 .ne. 0) go to 50
      m=m+1
      nfac(m)=2
      k=k/4
   50 kt=m
      j=2
   60 if(mod(k,j) .ne. 0) go to 70
      m=m+1
      nfac(m)=j
      k=k/j
   70 j=((j+1)/2)*2+1
      if(j .le. k) go to 60
   80 if(kt .eq. 0) go to 100
      j=kt
   90 m=m+1
      nfac(m)=nfac(j)
      j=j-1
      if(j .ne. 0) go to 90
!  compute fourier transform
  100 sd=radf/float(kspan)
      cd=2.0*sin(sd)**2
      sd=sin(sd+sd)
      kk=1
      i=i+1
      if(nfac(i) .ne. 2) go to 400
!  transform for factor of 2 (including rotation factor)
      kspan=kspan/2
      k1=kspan+2
  210 k2=kk+kspan
      ak=a(k2)
      bk=b(k2)
      a(k2)=a(kk)-ak
      b(k2)=b(kk)-bk
      a(kk)=a(kk)+ak
      b(kk)=b(kk)+bk
      kk=k2+kspan
      if(kk .le. nn) go to 210
      kk=kk-nn
      if(kk .le. jc) go to 210
      if(kk .gt. kspan) go to 800
  220 c1=1.0-cd
      s1=sd
  230 k2=kk+kspan
      ak=a(kk)-a(k2)
      bk=b(kk)-b(k2)
      a(kk)=a(kk)+a(k2)
      b(kk)=b(kk)+b(k2)
      a(k2)=c1*ak-s1*bk
      b(k2)=s1*ak+c1*bk
      kk=k2+kspan
      if(kk .lt. nt) go to 230
      k2=kk-nt
      c1=-c1
      kk=k1-k2
      if(kk .gt. k2) go to 230
      ak=c1-(cd*c1+sd*s1)
      s1=(sd*c1-cd*s1)+s1
      c1=2.0-(ak**2+s1**2)
      s1=c1*s1
      c1=c1*ak
      kk=kk+jc
      if(kk .lt. k2) go to 230
      k1=k1+inc+inc
      kk=(k1-kspan)/2+jc
      if(kk .le. jc+jc) go to 220
      go to 100
!  transform for factor of 3 (optional code)
  320 k1=kk+kspan
      k2=k1+kspan
      ak=a(kk)
      bk=b(kk)
      aj=a(k1)+a(k2)
      bj=b(k1)+b(k2)
      a(kk)=ak+aj
      b(kk)=bk+bj
      ak=-0.5*aj+ak
      bk=-0.5*bj+bk
      aj=(a(k1)-a(k2))*s120
      bj=(b(k1)-b(k2))*s120
      a(k1)=ak-bj
      b(k1)=bk+aj
      a(k2)=ak+bj
      b(k2)=bk-aj
      kk=k2+kspan
      if(kk .lt. nn) go to 320
      kk=kk-nn
      if(kk .le. kspan) go to 320
      go to 700
!  transform for factor of 4
  400 if(nfac(i) .ne. 4) go to 600
      kspnn=kspan
      kspan=kspan/4
  410 c1=1.0
      s1=0
  420 k1=kk+kspan
      k2=k1+kspan
      k3=k2+kspan
      akp=a(kk)+a(k2)
      akm=a(kk)-a(k2)
      ajp=a(k1)+a(k3)
      ajm=a(k1)-a(k3)
      a(kk)=akp+ajp
      ajp=akp-ajp
      bkp=b(kk)+b(k2)
      bkm=b(kk)-b(k2)
      bjp=b(k1)+b(k3)
      bjm=b(k1)-b(k3)
      b(kk)=bkp+bjp
      bjp=bkp-bjp
      if(isn .lt. 0) go to 450
      akp=akm-bjm
      akm=akm+bjm
      bkp=bkm+ajm
      bkm=bkm-ajm
      if(s1 .eq. 0) go to 460
  430 a(k1)=akp*c1-bkp*s1
      b(k1)=akp*s1+bkp*c1
      a(k2)=ajp*c2-bjp*s2
      b(k2)=ajp*s2+bjp*c2
      a(k3)=akm*c3-bkm*s3
      b(k3)=akm*s3+bkm*c3
      kk=k3+kspan
      if(kk .le. nt) go to 420
  440 c2=c1-(cd*c1+sd*s1)
      s1=(sd*c1-cd*s1)+s1
      c1=2.0-(c2**2+s1**2)
      s1=c1*s1
      c1=c1*c2
      c2=c1**2-s1**2
      s2=2.0*c1*s1
      c3=c2*c1-s2*s1
      s3=c2*s1+s2*c1
      kk=kk-nt+jc
      if(kk .le. kspan) go to 420
      kk=kk-kspan+inc
      if(kk .le. jc) go to 410
      if(kspan .eq. jc) go to 800
      go to 100
  450 akp=akm+bjm
      akm=akm-bjm
      bkp=bkm-ajm
      bkm=bkm+ajm
      if(s1 .ne. 0) go to 430
  460 a(k1)=akp
      b(k1)=bkp
      a(k2)=ajp
      b(k2)=bjp
      a(k3)=akm
      b(k3)=bkm
      kk=k3+kspan
      if(kk .le. nt) go to 420
      go to 440
!  transform for factor of 5 (optional code)
  510 c2=c72**2-s72**2
      s2=2.0*c72*s72
  520 k1=kk+kspan
      k2=k1+kspan
      k3=k2+kspan
      k4=k3+kspan
      akp=a(k1)+a(k4)
      akm=a(k1)-a(k4)
      bkp=b(k1)+b(k4)
      bkm=b(k1)-b(k4)
      ajp=a(k2)+a(k3)
      ajm=a(k2)-a(k3)
      bjp=b(k2)+b(k3)
      bjm=b(k2)-b(k3)
      aa=a(kk)
      bb=b(kk)
      a(kk)=aa+akp+ajp
      b(kk)=bb+bkp+bjp
      ak=akp*c72+ajp*c2+aa
      bk=bkp*c72+bjp*c2+bb
      aj=akm*s72+ajm*s2
      bj=bkm*s72+bjm*s2
      a(k1)=ak-bj
      a(k4)=ak+bj
      b(k1)=bk+aj
      b(k4)=bk-aj
      ak=akp*c2+ajp*c72+aa
      bk=bkp*c2+bjp*c72+bb
      aj=akm*s2-ajm*s72
      bj=bkm*s2-bjm*s72
      a(k2)=ak-bj
      a(k3)=ak+bj
      b(k2)=bk+aj
      b(k3)=bk-aj
      kk=k4+kspan
      if(kk .lt. nn) go to 520
      kk=kk-nn
      if(kk .le. kspan) go to 520
      go to 700
!  transform for odd factors
  600 k=nfac(i)
      kspnn=kspan
      kspan=kspan/k
      if(k .eq. 3) go to 320
      if(k .eq. 5) go to 510
      if(k .eq. jf) go to 640
      jf=k
      s1=rad/float(k)
      c1=cos(s1)
      s1=sin(s1)
      if(jf .gt. maxf) go to 998
      ck(jf)=1.0
      sk(jf)=0.0
      j=1
  630 ck(j)=ck(k)*c1+sk(k)*s1
      sk(j)=ck(k)*s1-sk(k)*c1
      k=k-1
      ck(k)=ck(j)
      sk(k)=-sk(j)
      j=j+1
      if(j .lt. k) go to 630
  640 k1=kk
      k2=kk+kspnn
      aa=a(kk)
      bb=b(kk)
      ak=aa
      bk=bb
      j=1
      k1=k1+kspan
  650 k2=k2-kspan
      j=j+1
      at(j)=a(k1)+a(k2)
      ak=at(j)+ak
      bt(j)=b(k1)+b(k2)
      bk=bt(j)+bk
      j=j+1
      at(j)=a(k1)-a(k2)
      bt(j)=b(k1)-b(k2)
      k1=k1+kspan
      if(k1 .lt. k2) go to 650
      a(kk)=ak
      b(kk)=bk
      k1=kk
      k2=kk+kspnn
      j=1
  660 k1=k1+kspan
      k2=k2-kspan
      jj=j
      ak=aa
      bk=bb
      aj=0.0
      bj=0.0
      k=1
  670 k=k+1
      ak=at(k)*ck(jj)+ak
      bk=bt(k)*ck(jj)+bk
      k=k+1
      aj=at(k)*sk(jj)+aj
      bj=bt(k)*sk(jj)+bj
      jj=jj+j
      if(jj .gt. jf) jj=jj-jf
      if(k .lt. jf) go to 670
      k=jf-j
      a(k1)=ak-bj
      b(k1)=bk+aj
      a(k2)=ak+bj
      b(k2)=bk-aj
      j=j+1
      if(j .lt. k) go to 660
      kk=kk+kspnn
      if(kk .le. nn) go to 640
      kk=kk-nn
      if(kk .le. kspan) go to 640
!  multiply by rotation factor (except for factors of 2 and 4)
  700 if(i .eq. m) go to 800
      kk=jc+1
  710 c2=1.0-cd
      s1=sd
  720 c1=c2
      s2=s1
      kk=kk+kspan
  730 ak=a(kk)
      a(kk)=c2*ak-s2*b(kk)
      b(kk)=s2*ak+c2*b(kk)
      kk=kk+kspnn
      if(kk .le. nt) go to 730
      ak=s1*s2
      s2=s1*c2+c1*s2
      c2=c1*c2-ak
      kk=kk-nt+kspan
      if(kk .le. kspnn) go to 730
      c2=c1-(cd*c1+sd*s1)
      s1=s1+(sd*c1-cd*s1)
      c1=2.0-(c2**2+s1**2)
      s1=c1*s1
      c2=c1*c2
      kk=kk-kspnn+jc
      if(kk .le. kspan) go to 720
      kk=kk-kspan+jc+inc
      if(kk .le. jc+jc) go to 710
      go to 100
!  permute the results to normal order---done in two stages
!  permutation for square factors of n
  800 np(1)=ks
      if(kt .eq. 0) go to 890
      k=kt+kt+1
      if(m .lt. k) k=k-1
      j=1
      np(k+1)=jc
  810 np(j+1)=np(j)/nfac(j)
      np(k)=np(k+1)*nfac(j)
      j=j+1
      k=k-1
      if(j .lt. k) go to 810
      k3=np(k+1)
      kspan=np(2)
      kk=jc+1
      k2=kspan+1
      j=1
      if(n .ne. ntot) go to 850
!  permutation for single-variate transform (optional code)
  820 ak=a(kk)
      a(kk)=a(k2)
      a(k2)=ak
      bk=b(kk)
      b(kk)=b(k2)
      b(k2)=bk
      kk=kk+inc
      k2=kspan+k2
      if(k2 .lt. ks) go to 820
  830 k2=k2-np(j)
      j=j+1
      k2=np(j+1)+k2
      if(k2 .gt. np(j)) go to 830
      j=1
  840 if(kk .lt. k2) go to 820
      kk=kk+inc
      k2=kspan+k2
      if(k2 .lt. ks) go to 840
      if(kk .lt. ks) go to 830
      jc=k3
      go to 890
!  permutation for multivariate transform
  850 k=kk+jc
  860 ak=a(kk)
      a(kk)=a(k2)
      a(k2)=ak
      bk=b(kk)
      b(kk)=b(k2)
      b(k2)=bk
      kk=kk+inc
      k2=k2+inc
      if(kk .lt. k) go to 860
      kk=kk+ks-jc
      k2=k2+ks-jc
      if(kk .lt. nt) go to 850
      k2=k2-nt+kspan
      kk=kk-nt+jc
      if(k2 .lt. ks) go to 850
  870 k2=k2-np(j)
      j=j+1
      k2=np(j+1)+k2
      if(k2 .gt. np(j)) go to 870
      j=1
  880 if(kk .lt. k2) go to 850
      kk=kk+jc
      k2=kspan+k2
      if(k2 .lt. ks) go to 880
      if(kk .lt. ks) go to 870
      jc=k3
  890 if(2*kt+1 .ge. m) return
      kspnn=np(kt+1)
!  permutation for square-free factors of n
      j=m-kt
      nfac(j+1)=1
  900 nfac(j)=nfac(j)*nfac(j+1)
      j=j-1
      if(j .ne. kt) go to 900
      kt=kt+1
      nn=nfac(kt)-1
      if(nn .gt. maxp) go to 998
      jj=0
      j=0
      go to 906
  902 jj=jj-k2
      k2=kk
      k=k+1
      kk=nfac(k)
  904 jj=kk+jj
      if(jj .ge. k2) go to 902
      np(j)=jj
  906 k2=nfac(kt)
      k=kt+1
      kk=nfac(k)
      j=j+1
      if(j .le. nn) go to 904
!  determine the permutation cycles of length greater than 1
      j=0
      go to 914
  910 k=kk
      kk=np(k)
      np(k)=-kk
      if(kk .ne. j) go to 910
      k3=kk
  914 j=j+1
      kk=np(j)
      if(kk .lt. 0) go to 914
      if(kk .ne. j) go to 910
      np(j)=-j
      if(j .ne. nn) go to 914
      maxf=inc*maxf
!  reorder a and b, following the permutation cycles
      go to 950
  924 j=j-1
      if(np(j) .lt. 0) go to 924
      jj=jc
  926 kspan=jj
      if(jj .gt. maxf) kspan=maxf
      jj=jj-kspan
      k=np(j)
      kk=jc*k+ii+jj
      k1=kk+kspan
      k2=0
  928 k2=k2+1
      at(k2)=a(k1)
      bt(k2)=b(k1)
      k1=k1-inc
      if(k1 .ne. kk) go to 928
  932 k1=kk+kspan
      k2=k1-jc*(k+np(k))
      k=-np(k)
  936 a(k1)=a(k2)
      b(k1)=b(k2)
      k1=k1-inc
      k2=k2-inc
      if(k1 .ne. kk) go to 936
      kk=k2
      if(k .ne. j) go to 932
      k1=kk+kspan
      k2=0
  940 k2=k2+1
      a(k1)=at(k2)
      b(k1)=bt(k2)
      k1=k1-inc
      if(k1 .ne. kk) go to 940
      if(jj .ne. 0) go to 926
      if(j .ne. 1) go to 924
  950 j=k3+1
      nt=nt-kspnn
      ii=nt-inc+1
      if(nt .ge. 0) go to 924
      return
! error finish, insufficient array storage
  998 isn=0
      print*,'array bounds exceeded within subroutine fft'

      stop
      end

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


module orbitstart
  use numeric_kinds
  use interpolpot
  implicit none
  private

  ! accuracy of integrator
  real (kind=dp),private :: integrator_accuracy=1d-4

  ! temporary pos and velocity array for the dense output of the integrator
  real (kind=dp),private,allocatable,dimension(:,:) :: vel_t,pos_t

  ! functions and variables copied from original orblib
  private :: derivs,soloutob,findtubeorbitwidth,calc_startpos,findtube

  public :: runorbitstart

  private :: findReq,make_startpoints,find_type,solouttype
  character (len=256), private  :: orbitstart_status, orbitstart_begin, orbitstart_beginbox
contains

  subroutine runorbitstart()

    use initial_parameters, only: nEner,nI2,nI3,rlogmin,rlogmax,&
         psi_view,orbit_dithering,conversion_factor
    use triaxpotent, only: pintr, triaxpar

    real    (kind=dp ), dimension(nEner):: rCirc,vcirc,tcirc,Epot
    real    (kind=dp ), dimension(nI2)  :: Theta,rib,rob,focplane
    real    (kind=dp ), dimension(nEner,nI2) :: boundout,boundin,boundmid
    real    (kind=dp ), dimension(nEner,nI2) :: noreggrid

    integer (kind=i4b), dimension(nEner):: irregular
    integer (kind=i4b), dimension(nEner,Ni2,Ni3) :: grid
    real    (kind=dp ), dimension(6):: startpos
    integer (kind=i4b) :: i,j,k
    real    (kind=dp ) :: pot,vx,vy,vz
    real    (kind=dp ) ::tube
    real    (kind=dp ) ::t1,t2,t3
    integer            ::i1,i2

 	read (unit=*, fmt="(a256)") orbitstart_status
	read (unit=*, fmt="(a256)") orbitstart_begin
	read (unit=*, fmt="(a256)") orbitstart_beginbox

	print*,"Maximum triaxility:",maxval(triaxpar)

	! define the orbits logarithmically.
	do i=1,nEner
   		rcirc(i)=rLogMin + (rLogMax-rLogMin) *&
        	(i-1.0)/(Nener-1.0)
	end do

    rcirc(:) = 10.0_dp ** rcirc(:)
    print*,'Radiia of the energies in arcsec:'
    print*,rcirc(:)/conversion_factor

    ! calculate the circular velocities at the radii
    do i=1,nEner
       ! estimate the tube is at 0.5_dp
	   ! [Later in the program this will be computed correctly]
       t1=0.5_dp

       call ip_accel(rcirc(i)*t1,0.0_dp,0.0_dp,vx,vy,vz)
       vcirc(i) = sqrt(       rcirc(i)*t1*abs(vx)  )
       tcirc(i) = 2.0_dp*pi_d*rcirc(i)*t1/vcirc(i)
       call ip_potent(rcirc(i),0.0_dp,0.0_dp,Epot(i))
    end do

    print*,'Potentials of the energies'
    print*,epot(:)

    ! time for a approx. circular orbit.
    tcirc(:)= 2.0_dp*pi_d*rcirc(:)*t1/vcirc(:)

    ! The angular space in x,z start space is open.
    ! This is done to avoid duplicate orbits at x=0
    ! and to avoid the (un-integratable) centrophilic box orbits at z=0
    do i=1,nI2
       Theta(i) = Pi_d/2.0_dp * (0.5+ i-1 ) / nI2 !( nI2+1.0_dp )
    end do

    print*,"Finding R_eq"
    do j=1,NEner
       do i=1,nI2
          call findReq(Rcirc(j),Epot(j),theta(i),0.0_dp,boundout(j,i))
       end do
    end do

    call find_innerboundary(boundin,irregular,boundout,tcirc,epot,theta)

    do i=1,nEner
       ! Use the position of the tube to define the 'circular' velocity
       t1=boundin(i,Ni2)/rcirc(i)
       call ip_accel(rcirc(i)*t1,0.0_dp,0.0_dp,vx,vy,vz)
       vcirc(i) = sqrt( rcirc(i)*t1*abs(vx)  )
       tcirc(i)= 2.0_dp*pi_d*rcirc(i)*t1/vcirc(i)
    end do

    ! check if galaxy model is triaxial.
    if ( maxval (triaxpar(:)) > 0.01_dp .or. minval(triaxpar(:)) > 0.99_dp) then
       ! galaxy is triaxial
       print*,"galaxy is triaxial"

       call find_outerboundary(boundin,boundmid,boundout,irregular,tcirc,epot,theta)

       ! mark all the energys inside the last "irregular energy" as irregular
       j=0
       do i=1,Nener
          if (irregular(i) == 1) j=i
       end do
       print*,"last irregular energy is :",j

       ! round irregular energy up to nearest dithering boundary
       ! (to make sure each orbital dithering is similar)
       j= floor((j-1.0_dp+orbit_dithering)/orbit_dithering)*orbit_dithering
       print*,"moved for dithering to:",j

       if (j > 0 ) irregular(1:j) = 1
    else
       ! special settings for the axisymmetric case.
       print*,"galaxy is assumed to be axisymmetric"
       irregular(:)=0
       boundmid=boundout
    endif

    call find_unregorbits(boundout,boundmid,irregular,noreggrid)

    call make_startpoints(boundin,boundmid,boundout,irregular,noreggrid, &
         theta,epot,tcirc,rcirc,vcirc)

    call make_boxstartpoints(epot,tcirc,rcirc,vcirc)

    ! write a status file, confirming that we finished succesfully
    open (unit=31,file=orbitstart_status,status="new",action="write",&
           position="rewind")
    write (unit=31, fmt=*) " finished "
    close (unit=31)

end subroutine  runorbitstart

subroutine  find_unregorbits(boundout,boundmid,irregular,noreggrid)
 use initial_parameters, only: nEner,nI2,nI3
  real    (kind=dp ),intent(in), dimension(nEner,nI2) :: boundmid,boundout
  real    (kind=dp ),intent(out), dimension(nEner,nI2) :: noreggrid
  integer (kind=i4b),dimension(Nener),intent(in) :: irregular
  integer (kind=i4b) :: i,j,k,noreg

! don't allow long axis tubes at the border to be regularized with
! the box orbits

do i=1,nEner
   noreg=0
   do j=nI2,1,-1
      if ( abs(boundmid(i,j)-boundout(i,j))/boundout(i,j) .gt. 1.0e-5  &
           .and. irregular(i) .eq. 0 )  &
           noreg=1
      noreggrid(i,j) = noreg
   end do
end do
end subroutine find_unregorbits

subroutine make_startpoints(boundin,boundmid,boundout,irregular &
                           ,noreggrid,theta,epot,tcirc,rcirc,vcirc)
 use initial_parameters, only: nEner,nI2,nI3
 real    (kind=dp ),intent(in),dimension(nEner):: tcirc,Epot,rcirc,vcirc
 real    (kind=dp ),intent(in), dimension(nI2)  :: Theta
 real    (kind=dp ),intent(in), dimension(nEner,nI2) :: boundin,boundmid
 real    (kind=dp ),intent(in), dimension(nEner,nI2) :: boundout,noreggrid
 integer (kind=i4b),dimension(Nener),intent(in) :: irregular
 real    (kind=dp ),dimension(nEner,nI2) :: bndin,bndmid
 real    (kind=dp ) :: t1
 real    (kind=dp ), dimension(6):: startpos
 integer (kind=i4b) :: i,j,k
 integer (kind=i4b) :: noreg,LastIrregE

 print*," Writing ", orbitstart_begin

 bndin(:,:)=boundin(:,:)
 bndmid(:,:)=boundmid(:,:)
 LastIrregE=0
 do i=1,NEner
	! If this energy is classified as irregular sample the whole X-Z plane.
    if (irregular(i) .eq. 1) then
	  bndin (i,:)=0.0_dp
      bndmid(i,:)=boundout(i,:)
	  LastIrregE =i ! Keep track of the last irregular energy
    endif
 end do

  open (unit=31,file=orbitstart_begin,status="new",action="write" , &
      position="rewind")
 write (unit=31, fmt=*) nEner,nI2,nI3

 do i=1,NEner
    ! reset the do_not_regularize counter for each energy
    do j=1,nI2
       do k=1,nI3
          ! open boundaries:
          !t1= bndin(i,j) + (bndmid(i,j)-bndin(i,j)) * (k-0.5_dp)/nI3
		  ! nearly closed boundaries  (fully close boundaries do not work. RvdB 27032010):
          t1= bndin(i,j) + (bndmid(i,j)-bndin(i,j)) * (k-0.9_dp)/(nI3-0.8_dp)
          call calc_startpos(t1,theta(j),Epot(i), startpos)
          noreg=0

          ! do not regularize the orbits on the boundmid
          if (k .eq. nI3 .and. noreggrid(i,j) .eq. 1 ) noreg=1
          ! if this is the last irregular energy do not regularize
          if (maxval(irregular(:)) .eq. i)  noreg=1

          write (unit=31, fmt="(3I5,9ES30.10,I4)") i,j,k,startpos,rcirc(i),tcirc(i),vcirc(i),noreg
       enddo
    enddo
 enddo
 close (unit=31)
end subroutine make_startpoints

subroutine make_boxstartpoints(epot,tcirc,rcirc,vcirc)
 use initial_parameters, only: nEner,nI2,nI3
 real    (kind=dp ),intent(in),dimension(nEner):: tcirc,Epot,rcirc,vcirc
 real    (kind=dp ) :: t1,theta,phi,rorbit,xp,yp,zp
 integer (kind=i4b) :: i,j,k

 print*," Writing ", orbitstart_beginbox
  open (unit=31,file=orbitstart_beginbox,status="new",action="write",&
      position="rewind")
 write (unit=31, fmt=*) nEner,nI2,nI3
 do i=1,NEner
    do j=1,nI2
       do k=1,nI3
          ! open boundaries:
          Theta = Pi_d/2.0_dp * ( j -0.5_dp) / nI2
          Phi   = Pi_d/2.0_dp * ( k -0.5_dp) / nI3

         call findReq(Rcirc(i),Epot(i),theta,phi,rorbit)

         xp=Rorbit*sin(theta)*cos(phi)   ! x
         yp=Rorbit*sin(theta)*sin(phi)   ! y
         zp=Rorbit*cos(theta)            ! z
         write (unit=31, fmt="(3I5,9ES30.10,I4)") i,j,k,xp,yp,zp,0.0_dp &
                    ,0.0_dp,0.0_dp,rcirc(i),tcirc(i),vcirc(i),0
       enddo
    enddo
 enddo
 close (unit=31)
end subroutine make_boxstartpoints

subroutine find_innerboundary(boundin,irregular,boundout,tcirc,epot,theta)
  use initial_parameters, only: nEner,nI2,nI3,rlogmin,rlogmax
  real    (kind=dp ),intent(in),dimension(nEner):: tcirc,Epot
  real    (kind=dp ),intent(in), dimension(nI2)  :: Theta
  real    (kind=dp ),intent(in), dimension(nEner,nI2) :: boundout
  real    (kind=dp ),intent(out), dimension(nEner,nI2) :: boundin
  integer (kind=i4b),dimension(Nener),intent(out) :: irregular
  real    (kind=dp ), dimension(6):: startpos
  integer (kind=i4b) :: i,j
  integer (kind=i4b),dimension(nI2) :: otype
  real    (kind=dp ) :: pot,vx,vy,vz,rbu,rbi,rg,acc
  integer (kind=i4b) :: orbtype,foundxtubes
  real    (kind=sp ) ::t1,t2,t3
  integer (kind=i2b) ::i1,i2

  print*,"Finding inner tubes"

  if (nI2 <= 3) stop "nI2 is smaller then 4"

  irregular(:)=0
  do j=1,nEner

	 ! Setup bounds for first guess.
     foundxtubes=0
     i=nI2
     rbi=boundout(j,i)*0.11
     rbu=boundout(j,i)*0.89
     rg =boundout(j,i)*0.50
     if (j>1) rg=boundin(j-1,i)/boundout(j-1,i)*boundout(j,i)
     rg= max(min(rg,boundout(j,i)*0.88),boundout(j,i)*0.12)

     ! Find first
     call findtube(rbi, rg,rbu,Epot(j),tcirc(j),theta(i),2,boundin(j,i))
     call find_type(boundin(j,i),theta(i),Epot(j),tcirc(j),otype(i))
     t1=boundin(j,i)/boundout(j,i)
     print*,j,i,t1,nEner,otype(i)

     ! find second
     i=nI2-1
     rg=boundin(j,i+1)
     rg= max(min(boundin(j,i+1) ,boundout(j,i)*0.99),boundout(j,i)*0.02)
     rbi=max(rg - boundout(j,i)*0.10,boundout(j,i)*0.01)
     rbu=min(rg + boundout(j,i)*0.10,boundout(j,i)     )
     call findtube(rbi,rg,rbu,Epot(j),tcirc(j),theta(i),2,boundin(j,i))
     call find_type(boundin(j,i),theta(i),Epot(j),tcirc(j),otype(i))
     t1=boundin(j,i)/boundout(j,Ni2)
     print*,j,i,t1,ni2,otype(i)

     do i=nI2-2,1,-1
        ! Use previous radius as guess.
        rg=boundin(j,i+1)

        ! set sane boundaries
        rg =min(max(rg ,boundout(j,i)*0.11),boundout(j,i)*0.99)
        rbi=max(rg - boundout(j,nI2)*0.08,boundout(j,i)*0.10)
        rbu=min(rg + boundout(j,nI2)*0.08,boundout(j,i)*1.00)

        call findtube(rbi,rg,rbu,Epot(j),tcirc(j),theta(i),2,boundin(j,i))
        if (abs(boundin(j,i)-rbi) < boundin(j,i)*1.0e-2  .or. &
            abs(boundin(j,i)-rbu) < boundin(j,i)*1.0e-2 ) then
           print*,'tube moved to edge of allowed boundary. irregular set'
           irregular(j)=1
           !exit
        endif
        call find_type(boundin(j,i),theta(i),Epot(j),tcirc(j),otype(i))
        ! If we detect boxorbits as a type orbit, define irregular energy
        if (otype(i) == 1) then
            foundxtubes=1
        endif
        t1=boundin(j,i)/boundout(j,nI2)
        t2=rbu/boundout(j,i)
        print*,j,i,t1,t2,otype(i)

     enddo

     if (foundxtubes == 0) irregular(j)=1
     if (irregular(j) == 1) print*,"irregular energy"
  end do
end subroutine find_innerboundary

subroutine find_outerboundary(boundin,boundmid,boundout,irregular,&
                              tcirc,epot,theta)
  use initial_parameters, only: nEner,nI2,nI3,rlogmin,rlogmax
  real    (kind=dp ),intent(in),  dimension(nEner):: tcirc,Epot
  real    (kind=dp ),intent(in),  dimension(nI2)  :: Theta
  real    (kind=dp ),intent(in),  dimension(nEner,nI2) :: boundout
  real    (kind=dp ),intent(out), dimension(nEner,nI2) :: boundmid
  real    (kind=dp ),intent(in ), dimension(nEner,nI2) :: boundin
  integer (kind=i4b),dimension(Nener),intent(inout)    :: irregular
  real    (kind=dp ), dimension(6):: startpos
  integer (kind=i4b) :: i,j,k,l,o1,o2,o3,notubes
  integer (kind=i4b),dimension(nI2) :: otype
  real    (kind=dp ) :: pot,vx,vy,vz,rbu,rbi,rg,acc,bp,r,rel_rbi
  integer (kind=i4b) :: nodice
  real    (kind=dp ) ::t1,t2,t3
  integer (kind=i2b) ::i1,i2

  print*,"Finding outer tubes"
  if (nI2 <= 3) stop "nI2 is smaller then 4"

  ! if we cannot find the outer thin tubes use equipotential.
  boundmid(:,:)=boundout(:,:)

  do j=1,NEner
     notubes=0
     ! find box orbits at last theta first and work backwards
     i=nI2

     ! rel_rbi will be the relative radius at which tubes convert box orbits.
     ! But first we underestimate it by the rel. radius of the thin short orbit tubes
     rel_rbi=(boundin(j,i))/boundout(j,i)

     ! Find the radius at which (short) axis tubes convert to box orbits
     do k=1,nI3*3

	      ! we keep increasing r until we hit boxes
	      r=boundin(j,i) + (boundout(j,i)-(boundin(j,i))) *k / (nI3*3+1)
	      call find_type(r,theta(i),Epot(j),tcirc(j),o1)

	      if (o1 .eq. 3) rel_rbi= r/boundout(j,i) ! Have not found boxes (yet), so we set
	                                              ! so we move up rel_rbi

          ! if we find boxes we are done.
		  if ((o1 .eq. 1 .or. o1 .eq. 4) .and. k .ge. 2 ) exit
     end do

     ! if we couldn't find any box orbits then there is no point in looking for thin tubes,
     ! as further in would not add more orbit resolution
      if ((o1 .eq. 3 .and. k .ge. nI3))  then
       print*,'Short to box conversion at',rel_rbi,', which is to close enough to the outer boundary'
       ! to not search for intermediate boundary'

	   irregular(j)=0
	   notubes=1

	 else

      if (o1 .eq. 4 .or. o1 .eq. 5 ) then
     	! found boxes. Now find the transitition to x tubes in the theta direction.

        ! r is the radius at which boxes are found in the previous step.
        ! bp is the relative radius at which the boxes are found.
     	bp=r/boundout(j,i)

     	do i=nI2-1,1,-1

	        ! See if the're tubes at this rel. radius.
        	call find_type(boundout(j,i)*bp,theta(i),Epot(j),tcirc(j),o1)
        	if ( o1 == 1 ) exit ! x tubes found; done
	    	print "(3I5 , 4F7.3)", -j,i,o1,boundin(j,i)/boundout(j,Ni2),rel_rbi*boundout(j,i)/boundout(j,Ni2), &
	               boundmid(j,i)/boundout(j,Ni2),boundout(j,i)/boundout(j,Ni2)
     	enddo
        i=minval( (/ i+1 , nI2-1/) )
      endif
      endif

     if ( notubes == 0 .and. i > 1) then
	    ! Found boxes and long axis tubes. Now find the thin x-axis tubes.

        ! Find the thin long axis tubes is not very robust. I sometimes wonder
        ! why we bother. The current approach tries to be robust by creating the
        ! smallest possible search boundaries, based on the previous estimate and
        ! the expectation that the radius does not decrease faster than 3 times
        ! the maxiumum possible avg. linear speed. RvdB 27032010

	    boundmid(j,i)=boundout(j,i)

        if ( i > 2) then

           do k=i-1,1,-1

	          ! inner boundary is either the relative tube-to-box conversion radius or
	          ! the thin tube orbit radius.
              rbi=maxval( (/boundout(j,k)*rel_rbi,boundin(j,:) /))

              ! Outer boundary is the equipotential
              rbu=boundout(j,k)	- 1.0e-6 ! Make sure we do not go over the equipotential
                                         ! as then the V_y velocity becomes undefined
                                         ! Rvdb 27032010

              ! boundmid should always shrink, due to galaxy flattening, hence we can assume
              ! that boundmid(j,k) < boundmid(j,k+1)
              rbu=minval((/boundmid(j,k+1),rbu/))

              ! guess that the new boundmid is the relative boundmid of the previous step.
              rg =maxval((/minval((/boundmid(j,k+1)/boundout(j,k+1)*boundout(j,k),rbu/)),rbi/))

              ! In the most extreme case boundmid could touch rel_rbi at the end,
              ! this we allow boundmid to go towards that in linear steps.
              ! (This is not perfect, but works well.)
              r=((1-rel_rbi)/Ni3*3)
              rbi=maxval((/rg*(1-r),rbi/))

              !print "(3F7.3)" ,rbi/boundout(j,k),rg/boundout(j,k),rbu/boundout(j,k)
              ! Sanity check on the boundaries
              if (rbi .ge. rbu) then
                print *, 'inner boundary ', rbi, ' bigger than outer boundary ', rbu
                stop 'inner boundary bigger than outer boundary'
              endif
              if (rg .le. rbi .or. rg .ge. rbu) rg = 0.5*(rbi+rbu)

              ! find the thin long axis tubes radius
			  call findtube(rbi,rg,rbu,Epot(j),tcirc(j),theta(k),1,r)
              boundmid(j,k)=r

              call find_type(r,theta(k),Epot(j),tcirc(j),o1)

			  print "(3I5 , 4F7.3)" ,j,k,o1,boundin(j,k)/boundout(j,Ni2),rel_rbi*boundout(j,k)/boundout(j,Ni2), &
			  boundmid(j,k)/boundout(j,Ni2),boundout(j,k)/boundout(j,Ni2)

           end do
        endif
     endif

  end do

end subroutine find_outerboundary

subroutine calc_startpos(r,theta,eeq,Y)
  real(kind=dp),intent(in) :: r,theta,eeq
  real(kind=dp),intent(out), dimension(6) :: Y
  real(kind=dp) :: E
  Y(1)=R*sin(theta)            ! x
  Y(2)=0.0_dp                  ! y
  Y(3)=R*cos(theta)            ! z
  call ip_potent(Y(1),Y(2),Y(3),E)
  Y(4)=0.0_dp                  ! vx
  Y(5)=2.0_dp *(E- Eeq)        ! vy^2
  if ( Y(5) >= 1.0e-300_dp) Y(5)=sqrt(Y(5))
  if ( Y(5) <  0.0_dp .or. ISNAN(Y(5))) then
	print*,r,theta,eeq,e,2*(e-eeq),Y(1:6), 'Starting velocity is negative or NAN' ,sqrt(2.0_dp *(E*1.0e-8))
	Y(5)= sqrt(2.0_dp *(E*1.0e-12))! set vy to a really small positive value
  endif
  Y(6)=0.0_dp                  ! vz
end subroutine calc_startpos

  subroutine findReq(Req,E,th,ph,R)
    real    (kind=dp ),intent(in ):: Req,E,th,ph
    real    (kind=dp ),intent(out):: R
    real    (kind=dp )            :: pot,emn,emx,rmn,rmx
    real    (kind=dp )            :: sth,cth,sph,cph
    integer (kind=i4b)            :: i

    ! Find the position R for which pot(E,th) = E

    ! th is defined from the other side:
    sth = sin(th)
    cth = cos(th)

    sph = sin(ph)
    cph = cos(ph)

    ! bisection
    rmx = 1.1_dp * Req
    rmn = 0.01_dp * Req

    call ip_potent( Rmx*sth*cph,Rmx*sth*sph,Rmx*cth,Emx)
    call ip_potent( Rmn*sth*cph,Rmn*sth*sph,Rmn*cth,Emn)

    i=0

    do
       R = 0.5_dp*(Rmn+Rmx)

       call ip_potent(R*sth*cph,R*sth*sph,R*cth,pot)
        if ( abs(( E - pot )/E) < 1.0e-7_dp ) exit

       if (pot > E ) then
          Rmn = 0.5_dp*(Rmn+Rmx)
          Emn = pot
       else
          Rmx = 0.5_dp*(Rmn+Rmx)
          Emx = pot
       end  if

       i=i+1

       if ( i > 60000_i4b ) then
	   print*,E,emn,emx
	   print*,R,rmn,rmx ,1.5_dp * Req ,0.01_dp * Req
	   stop "Can not find R_eq"
       endif

    end do

  end subroutine findReq

 subroutine  findtube(Rin,Rmid,Rout,Epot,tcirc,theta,plane,R)
    real    (kind=dp ),intent(in ):: Rin,Rmid,Rout,Epot,theta,tcirc
    integer (kind=i4b),intent(in)  :: plane
    real    (kind=dp ),intent(out):: R
    real    (kind=dp ),parameter  :: gldn=0.61803399_dp
    real    (kind=dp )            :: Tube,r0,r1,r2,r3,t1,t2
    real    (kind=dp )            :: sth,cth
    real    (kind=sp )            :: t4,t5,t6,t7
    integer (kind=i4b)            :: i

    ! golden Ratio search
    R0 = Rin
    R3 = Rout

    if (abs(Rout-Rmid) > abs (Rmid-Rin)) then
       R1=Rmid
       R2=Rmid+(1.0_dp-gldn)*(Rout-Rmid)
    else
       R2=Rmid
       R1=Rmid-(1.0_dp-gldn)*(Rmid-Rin)
    endif
    call findtubeorbitwidth(R1,theta,Epot,tcirc,plane,T1)
    call findtubeorbitwidth(R2,theta,Epot,tcirc,plane,T2)
    do
       if (abs(R3-R0) < 1.0e-4 *(abs(R1)+abs(R2))) exit
       if (T2 < T1 ) then
          R0=R1
          R1=R2
          R2=gldn*R1+(1.0-gldn)*R3
          T1=T2
          call findtubeorbitwidth(R2,theta,Epot,tcirc,plane,T2)
       else
          R3=R2
          R2=R1
          R1=gldn*R2+(1.0-gldn)*R0
          T2=T1
          call findtubeorbitwidth(R1,theta,Epot,tcirc,plane,T1)
       end if
     end do
    if (T1 < T2) then
       R=R1
    else
       R=R2
    endif
  end subroutine findtube

subroutine findtubeorbitwidth(R,theta,Eeq,tcirc,plane,Tube)
    real    (kind=dp ),intent(in ) :: R,theta,Eeq,tcirc
    real    (kind=dp), intent(out) :: tube
    integer (kind=i4b),intent(in)  :: plane
    !----------------------------------------------------------------------
    integer (kind=i4b),parameter :: intsteps=400
	integer (kind=i4b),parameter :: N=6,nrdens=3,LWORK=11*N+8*NRDENS+21
    integer (kind=i4b),parameter :: LIWORK = NRDENS+21
    integer (kind=i4b) :: IOUT,IDID,ITOL
    real    (kind=dp ) :: X,Xend,TOL,E,tvx,tvy,tvz
    real    (kind=dp ), dimension(N) :: Y,RTOL,ATOL
    real    (kind=dp ), dimension(LWORK):: WORK
    integer (kind=i4b), dimension(LIWORK) :: IWORK
    real    (kind=dp ), dimension(2) :: RPAR
    integer (kind=i4b), dimension(1) :: IPAR
    real    (kind=dp ), dimension(intsteps) :: Rad
    ! Setting up the array for storing the points.
    allocate (pos_t(intsteps,3))
    ! --- DIMENSION OF THE SYSTEM
    IDID=0
    ! --- OUTPUT ROUTINE (AND DENSE OUTPUT) IS USED DURING INTEGRATION
    IOUT=2
    ! --- INITIAL VALUES
    X=0.0
    call calc_startpos(R,theta,eeq, Y)

    ! --- ENDPOINT OF INTEGRATION
    ! integration time 800 * tcirc
    Xend = 500.0_dp * intsteps * tcirc
    ! Stepsize. Make sure enough steps are in the integration by adding
    ! room for one extra step. RvdB, DK 16/06/03
    RPAR(2) = 0.0 ! unused
    RPAR(1) = R   ! used for the relative bisection accuracy
    IPAR(1) = plane   ! find crossings of coordinate ( x = Y(1),etc)
    ! --- REQUIRED TOLERANCE
    ! Use same relative tolerance TOL for (R,z,VR,Vz)
    ! but ensures a fixed absolute tolerance of
    ! TOL*rcirc on (R,z) and TOL*vcirc on (VR,Vz).
    ! The integrator keeps the local error on Y(I)
    ! below RTOL(I)*ABS(Y(I)) + ATOL(I).
    TOL     = integrator_accuracy
    ITOL    = 1 ! Tolerances are vectors
    RTOL(:) = TOL
    ATOL(:) = 1e-8_dp !TOL* (/R,R,R,sqrt(R*abs( Y(5))),sqrt(R*abs( Y(5))),&
         !sqrt(R*abs( Y(5))) /)

    ! --- VALUES FOR PARAMETERS
    ! Default values are used when IWORK or WORK are zero
    IWORK(:)=0
     WORK(:)=0.0_dp
    ! Maximum of allowed steps (just really high) (100000)
    IWORK(1)=100000000_i4b
    !number of dense components needed. (only the positions in this cases)
    IWORK(5)=nrdens
    IWORK(21)=1
    IWORK(22)=2
    IWORK(23)=3
    !stiffnes detection (negative --> do not try to detect)
    IWORK(4)=-1
    ! maximal stepsize
    !WORK(6) = XEND/(4000+1.0_dp)
    ! Print no messages:
    IWORK(3)=-1
    ! --- CALL OF THE SUBROUTINE DOPRI8 ( The dop853 integrator.)
    CALL DOP853(N,derivs,X,Y,XEND, RTOL,ATOL,ITOL, SOLOUTOB,IOUT, &
         &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
    select case (IDID)
    case (-1)
       stop "integrator:  INPUT IS NOT CONSISTENT,"
    case (-2)
       stop "integrator:  LARGER NMAX IS NEEDED,"
    case (-3)
       stop "integrator:  STEP SIZE BECOMES TOO SMALL."
    case (-4)
       stop "integrator:  PROBLEM IS PROBABLY STIFF (INTERRUPTED)."
    case default
       ! Integrating went ok!
    end select

    if (plane .eq. 1) then
       rad(:)=pos_t(:,2)**2.0_dp + pos_t(:,3)**2.0_dp
    endif

    if (plane .eq. 2) then
       rad(:)=pos_t(:,1)**2.0_dp + pos_t(:,3)**2.0_dp
    endif

    if (plane .eq. 3) then
       rad(:)=pos_t(:,1)**2.0_dp + pos_t(:,2)**2.0_dp
    endif

    tube  = maxval(sqrt(rad(:))) - minval(sqrt(rad(:)))

    deallocate(pos_t)

  end subroutine findtubeorbitwidth

  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  subroutine derivs (N,xin,yin,dydx,RPAR,IPAR)
    use interpolpot, only : ip_accel
    integer           ,intent(in   )              :: N
    real    (kind=dp ),intent(in   )              :: xin
    real    (kind=dp ),intent(in   ),dimension(6) :: yin
    real    (kind=dp ),intent(out  ),dimension(6) :: dydx
    real    (kind=dp ),intent(inout),dimension(2) :: RPAR
    integer (kind=i4b),intent(inout),dimension(1) :: IPAR
  !----------------------------------------------------------------------

    ! subroutine which returns the right-hand side derivatives.
    !   x      = t
    !   yin(1) = x
    !   yin(2) = y
    !   yin(3) = z
    !   yin(4) = dx/dt
    !   yin(5) = dy/dt
    !   yin(6) = dz/dt

    ! First calculate the true accelerations at the given position
    dydx(1:3) = yin(4:6)
    call ip_accel(yin(1),yin(2),yin(3),dydx(4),dydx(5),dydx(6))

  end subroutine derivs

  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  SUBROUTINE SOLOUTOB (NR,XOLD,X,Y,N,CON,ICOMP,ND,RPAR,IPAR,IRTRN)
    ! --- PRINTS SOLUTION AT EQUIDISTANT OUTPUT-POINTS
    ! --- BY USING "CONTD8", THE CONTINUOUS COLLOCATION SOLUTION
    integer          ,intent(in)    :: NR,N,ND
    real   (kind=dp ),intent(in)    :: XOLD,X
    integer          ,intent(inout) :: IRTRN
    real   (kind=dp ),intent(in)   ,dimension(N)    :: Y
    real   (kind=dp ),intent(in)   ,dimension(8*ND) :: CON
    integer(kind=i4b),intent(in)   ,dimension(ND)   :: ICOMP
    real   (kind=dp ),intent(inout),dimension(2)    :: RPAR
    integer(kind=i4b),intent(inout),dimension(1)    :: IPAR
    !--------------------------------------------------------------------
    real   (kind=dp ),save          :: XOUT,yold
    integer(kind=i4b),save          :: count=0
    real   (kind=dp )               :: contd8,R
    real   (kind=dp) :: Xmx,Xmn,Ymn,Ymx,Yt,Xt
    integer (kind=i4b) :: biscount,tp
    tp=ipar(1) ! find crossing of this plane. x=1, y=2 and x=3
    R=RPAR(1)
    IF (NR == 1) THEN
       count=0
    ELSE
       if (count >= size(pos_t,1)) IRTRN=-1
       IF (y(tp) * yold < 0.0_dp .and. count < size(pos_t,1)) THEN

          if (y(tp)> 0.0_dp) then
             Xmx = X
             Xmn = Xold
          else
             Xmx = Xold
             Xmn = X
          endif
          Ymx=CONTD8(tp,Xmx,CON,ICOMP,ND)
          Ymn=CONTD8(tp,Xmn,CON,ICOMP,ND)
          biscount=0
          do
             Xt=(Xmx+Xmn)/2.0_dp
             Yt=CONTD8(tp,Xt,CON,ICOMP,ND)
             biscount=biscount+1
             if ( abs( Yt - 0.0_dp ) < R*1.0e-4 .or. biscount > 40) exit

             if (Yt < 0.0_dp ) then
                Xmn = Xt
                Ymn = Yt
             else
                Xmx = Xt
                Ymx = Yt
             end  if
          end do
          if (biscount < 40) then
             ! only store value if the bisection converged.
             count = count+1
             pos_t(count,1) = CONTD8(1,Xt,CON,ICOMP,ND)
             pos_t(count,2) = CONTD8(2,Xt,CON,ICOMP,ND)
             pos_t(count,3) = CONTD8(3,Xt,CON,ICOMP,ND)
          end if
       END IF
    END IF
    yold=y(tp)
  END SUBROUTINE SOLOUTOB

  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  subroutine find_type(R,theta,Eeq,tcirc,orbtype)
    real    (kind=dp ),intent(in ) :: R,theta,Eeq,tcirc
    integer (kind=i4b), intent(out) :: orbtype
  !----------------------------------------------------------------------

    integer (kind=i4b),parameter :: intsteps=5000
	integer (kind=i4b),parameter :: N=6,NRDENS=N,LWORK=11*N+8*NRDENS+21
    integer (kind=i4b),parameter :: LIWORK = NRDENS+21
    integer (kind=i4b) :: IOUT,IDID,ITOL
    real    (kind=dp ) :: X,Xend,TOL,E,tvx,tvy,tvz
    real    (kind=dp ), dimension(N) :: Y,RTOL,ATOL
    real    (kind=dp ), dimension(LWORK)  :: WORK
    integer (kind=i4b), dimension(LIWORK) :: IWORK
    real    (kind=dp ), dimension(2) :: RPAR
    integer (kind=i4b), dimension(1) :: IPAR
    real (kind=dp) :: lxmax,lxmin,lymax,lymin,lzmax,lzmin,lxc,lyc,lzc
    real (kind=dp),dimension(intsteps) :: t
    real (kind=dp),parameter :: nul=0.0_dp

    ! setting up the array for storing the points.
    allocate (pos_t(intsteps,3),vel_t(intsteps,3))
    ! --- DIMENSION OF THE SYSTEM
    IDID=0
    ! --- OUTPUT ROUTINE (AND DENSE OUTPUT) IS USED DURING INTEGRATION
    IOUT=2
    ! --- INITIAL VALUES
    X=0.0
    call calc_startpos(R,theta,eeq, Y)

    ! --- ENDPOINT OF INTEGRATION
    XEND =  100.0_dp * tcirc
    ! Stepsize. Make sure enough steps are in the integration by adding
    ! room for a couple of  extra steps. RvdB 19/12/04
    RPAR(2) = XEND/(intsteps+4)
    RPAR(1) = 0.0 ! Unused
    ! --- REQUIRED TOLERANCE
    ! Use same relative tolerance TOL for (R,z,VR,Vz)
    ! but ensures a fixed absolute tolerance of
    ! TOL*rcirc on (R,z) and TOL*vcirc on (VR,Vz).
    ! The integrator keeps the local error on Y(I)
    ! below RTOL(I)*ABS(Y(I)) + ATOL(I).
    TOL     = integrator_accuracy
    ITOL    = 1 ! Tolerances are vectors
    RTOL(:) = TOL
    ATOL(:) = 1e-8_dp !TOL * (/R,R,R,  &
         !sqrt(R*abs(y(5))),sqrt(R*abs(y(5))),sqrt(R*abs(y(5))) /)

    ! Work arrays's
    ! --- VALUES FOR PARAMETERS
    ! Default values are used when IWORK or WORK are zero
    IWORK(:)=0
     WORK(:)=0.0_dp
    ! Maximum of allowed steps (just really high) (100000)
    IWORK(1)=100000000_i4b
    !number of dense components needed. (all in our case)
    IWORK(5)=NRDENS
    !stiffnes detection (negative --> do not try to detect)
    IWORK(4)=-1

    ! --- CALL OF THE SUBROUTINE DOPRI8 ( The dop853 integrator.)
    CALL DOP853(N,derivs,X,Y,XEND, RTOL,ATOL,ITOL, SOLOUTTYPE,IOUT, &
         &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
    select case (IDID)
    case (-1)
       stop "integrator:  INPUT IS NOT CONSISTENT,"
    case (-2)
       stop "integrator:  LARGER NMAX IS NEEDED,"
    case (-3)
       stop "integrator:  STEP SIZE BECOMES TOO SMALL."
    case (-4)
       stop "integrator:  PROBLEM IS PROBABLY STIFF (INTERRUPTED)."
    case default
       ! Integrating went ok!
    end select

    !  Lx = y*Vz-z*Vy
    t= pos_t(:,2) * vel_t(:,3) - pos_t (:,3) * vel_t(:,2)
    lxc=maxval(t) * minval(t)

    !  Ly = z*Vx-x*Vz
    t= pos_t(:,3) * vel_t(:,1) - pos_t(:,1) * vel_t(:,3)
    lyc=maxval(t) * minval(t)

    !  Lz = x*Vy-y*Vx
    t= pos_t(:,1) * vel_t(:,2) - pos_t (:,2) * vel_t(:,1)
    lzc=maxval(t) * minval(t)

    ! assume orbit is chaotic, unless proven otherwise.
    orbtype=5

    ! X tube
    if (lxc > nul .and. lyc < nul .and. lzc < nul ) orbtype=1
    ! Y tube
    if (lxc < nul .and. lyc > nul .and. lzc < nul ) orbtype=2
    ! Z tube
    if (lxc < nul .and. lyc < nul .and. lzc > nul ) orbtype=3
    ! Box
    if (lxc < nul .and. lyc < nul .and. lzc < nul ) orbtype=4

    deallocate(pos_t,vel_t)

  end subroutine find_type

  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  SUBROUTINE SOLOUTtype (NR,XOLD,X,Y,N,CON,ICOMP,ND,RPAR,IPAR,IRTRN)
    ! --- PRINTS SOLUTION AT EQUIDISTANT OUTPUT-POINTS
    ! --- BY USING "CONTD8", THE CONTINUOUS COLLOCATION SOLUTION
    integer          ,intent(in)    :: NR,N,ND
    real   (kind=dp ),intent(in)    :: XOLD,X
    integer          ,intent(inout) :: IRTRN
    real   (kind=dp ),intent(in)   ,dimension(N)    :: Y
    real   (kind=dp ),intent(in)   ,dimension(8*ND) :: CON
    integer(kind=i4b),intent(in)   ,dimension(ND)   :: ICOMP
    real   (kind=dp ),intent(inout),dimension(2)    :: RPAR
    integer(kind=i4b),intent(inout),dimension(1)    :: IPAR
  !----------------------------------------------------------------------
    real   (kind=dp ),save          :: XOUT
    integer(kind=i4b),save          :: count=0
    real   (kind=dp )               :: contd8,step,rnd
    step=RPAR(2)
    IF (NR == 1) THEN
       XOUT=X+step
       count=0
    ELSE
       do
          ! Make sure count > integrator_points to make sure we do not
          ! go out of bounds on pos_t(:,:). RvdB, DK 16/06/03
          IF (X < XOUT .or. count >= size(pos_t,1)) exit
          count = count+1
          pos_t(count,1) = CONTD8(1,XOUT,CON,ICOMP,ND)
          pos_t(count,2) = CONTD8(2,XOUT,CON,ICOMP,ND)
          pos_t(count,3) = CONTD8(3,XOUT,CON,ICOMP,ND)
          vel_t(count,1) = CONTD8(4,XOUT,CON,ICOMP,ND)
          vel_t(count,2) = CONTD8(5,XOUT,CON,ICOMP,ND)
          vel_t(count,3) = CONTD8(6,XOUT,CON,ICOMP,ND)
          XOUT = XOUT + step
       end do
    END IF
  END SUBROUTINE SOLOUTtype

end module orbitstart

program orbitstart_run
use orbitstart
use initial_parameters
use interpolpot
use triaxpotent

implicit none

integer :: r_seed
double precision :: ran1, r_num

! read random number seed, any value <= 0 results in stochastic seed
read (unit=*, fmt=*) r_seed
if (r_seed <= 0) then
  call random_seed()
  call random_number(r_num)
  r_seed = 2147483647 * r_num
  r_num = ran1(-r_seed)
  write(*,*) "Using ran1 with random seed ", r_seed
else
  r_num = ran1(-r_seed)
  write(*,*) "Using ran1 with given seed ", r_seed
end if

call iniparam()
call ip_setup()
call runorbitstart()
call ip_stop()
end program orbitstart_run


program kmc
implicit none
! KMC computes the population vs time of a number of species involved in several dynamical processes
! rate: rate constant of a given processes
! p:    population of a given species (p0 is its initial value)
! re (pr): reactant (product) for a given process
character*80 :: title
integer, parameter :: dp = selected_real_kind(15,307)
integer :: m,nran,nr,nesp,inran,i,j,k,l,mu,pd,kk,ia,iz,ijk,nespct
real(dp) :: t,tmax,tprint,tint,a0,r2a0,suma,vol,avog,conv
real(dp) :: rnd(2)
integer,dimension(:),allocatable :: re1,re2,pr1,pr2,n,iespct
real (dp) ,dimension(:),allocatable :: a,rate,c0,p,p0,cont
avog=6.022d23
read(*,"(a80)") title
print "(t3,a80)",title
read(*,*) m,nesp,nran
print*, m,nesp,nran
allocate(re1(m),re2(m),pr1(m),pr2(m),a(m),rate(m),p0(nesp),p(nesp),n(nesp),c0(nesp),cont(m))
n=(/ (l,l=1,nesp) /)
! The vol relates to population of species i p_i and concentration c_i as: vol=p_i/c_i/avog
! So, choose vol for a expected population of a given species i (p_i)
read(*,*) vol
conv=vol*avog
! nespct is the number of species with constant values of population throughout
! the simulation. For instance, in a catalyic cycles those species could be
! gases
read(*,*) nespct
print*, "Number of species that keep their concentrations constant=",nespct
allocate(iespct(nespct))
do i=1,nespct
   read(*,*) iespct(i)
   print*, iespct(i)
enddo
print*, ""
print*, "Rates in (time-1),i.e.,s-1"
do i=1,m
   read(*,*) rate(i),re1(i),re2(i),pr1(i),pr2(i)
   if(re1(i)/=0.and.re2(i)/=0) rate(i)=rate(i)/conv
   print*, i,rate(i),re1(i),re2(i),pr1(i),pr2(i)
   if(re1(i)==re2(i)) rate(i)=2*rate(i)
enddo
print*, "Initial concentration (M) and population of each species"
do ijk=1,m
   cont(ijk)=0
enddo
do i=1,nesp
   read(*,*) c0(i)
   p0(i)=c0(i)*conv
   print*, i,c0(i),p0(i)
enddo
read(*,*) tmax,tint
ia=1
iz=nesp
print "(/,t3,a,1p,e10.2,a,/,t3,a,1p,e10.2,a,/)","Total time=",tmax," in input units","Step size =",tint," in input units"
big: do inran=1,nran
   print "(/,t3,a,i4,/,t3,a,500(i10))","Calculation number",inran, &
 "Time    ",(n(i),i=ia,iz)
   p=p0
   t=0.d0
   tprint=0.d0
   do while(tprint<tmax)
! keep the initial population for the iespct species
     do j=1,nespct
        p(iespct(j))=p0(iespct(j))
     enddo
     do j=1,m
        if(re1(j)==0) then
! unimolecular reaction
          a(j)=rate(j)*p(re2(j))
        else if(re2(j)==0) then
          a(j)=rate(j)*p(re1(j))
        else
          if(re1(j)/=re2(j)) a(j)=rate(j)*p(re1(j))*p(re2(j))
          if(re1(j)==re2(j)) a(j)=rate(j)*p(re1(j))*(p(re2(j))-1)/2
        endif
     enddo
     a0=sum(a)
     call random_number(rnd)
     t=t-log(rnd(1))/a0
     do while (t>=tprint)
        print "(e10.4,500(f15.0))",tprint,(p(i),i=ia,iz)
        tprint=tprint+tint
        if(tprint>tmax) cycle big
     enddo
     r2a0=rnd(2)*a0
     suma=0.d0
     s1: do mu=1,m
       suma=suma+a(mu)
       if(suma>=r2a0) exit s1
     enddo s1
     if(re1(mu)==0) then
! unimolecular reaction
        p(re2(mu))=p(re2(mu))-1
     else if(re2(mu)==0) then
        p(re1(mu))=p(re1(mu))-1
! unimolecular reaction
     else
        p(re1(mu))=p(re1(mu))-1
        p(re2(mu))=p(re2(mu))-1
     endif
     if(pr1(mu)==0) then
! only one product
        p(pr2(mu))=p(pr2(mu))+1
     else if(pr2(mu)==0) then
        p(pr1(mu))=p(pr1(mu))+1
     else
        p(pr1(mu))=p(pr1(mu))+1
        p(pr2(mu))=p(pr2(mu))+1
     endif
     cont(mu)=cont(mu)+1
   enddo
enddo big
print*,"Population of every species"
do i=1,nesp
   print "(i6,f20.0)",i,p(i)
enddo
print*,"counts per process"
do i=1,m
   print "(i6,f30.0)",i,cont(i)
enddo
end program kmc


module dmpotent
  use numeric_kinds
  use initial_parameters
  implicit none
  private

  ! Generic module for black hole mass and dark halo potential
  ! calls triaxpotent

  ! RvdB 17 Mar 2010

  ! Bugs

  ! calculate potential phi at (x,y,z)
  public:: dm_potent

  ! calculate accel ax,ay,ax at (x,y,z)
  public:: dm_accel

  ! setup the constants for the potential
  public:: dm_setup

  ! setup the constants for the potential
  public:: dm_stop

  real (kind=dp), private :: rhoc, rc, dm_logslp

contains

subroutine dm_setup()
   use triaxpotent, only : tp_setup
   real(kind=dp) :: darkmass,dm_zeta,zh_betai,tmp_gamma,zh_gammln
   call tp_setup()

   select case (dm_profile_type)
	case (0)
		print*, 'No additional DM halo'
	case (1)
        !	     dmparam(1) = concentration
        !        dmparam(2) = dm_fraction   (fraction of DM mass within R200 radius)
	    if (n_dmparam .ne. 2)  stop 'wrong number of NFW halo parameters'
	    print*,'Parameters of NFW concentration and fraction',dmparam(1),dmparam(2)

        ! Parameters for NFW profile
	    rhoc = (200.0_dp/3.0_dp)*rho_crit*dmparam(1)**3/  &
	        ( log(1.0_dp+dmparam(1)) - dmparam(1)/(1.0_dp+dmparam(1)))

	    rc = (3.0_dp/(800.0_dp*pi_d*rho_crit*dmparam(1)**3) &
	           * dmparam(2) * totalmass)**(1.0_dp/3.0_dp)

	    ! 12 Oct 2011: LW found unit conversion bug in print statment
		print*, "Parameters of NFW potential (rho_c in solarmass/km^3 and r_c in km): ", rhoc, rc
		! Calculate M200, in Msun
		darkmass = 800_dp*pi_d/3_dp*rho_crit*rc**3*dmparam(1)**3

		print*, "Total stellar mass is (Msun): ", totalmass
		print*,"Total dark halo mass (M200 in Msun): ", darkmass

	case (2)
	    !	     dmparam(1) = rhoc
        !        dmparam(2) = rc
 	    if (n_dmparam .ne. 2)  stop 'wrong number of Hernquist halo parameters'
        rhoc=dmparam(1)
		rc  =dmparam(2)
		print*,'Parameters of Hernquist profile', rhoc, rc
	case (3)
	   print*, "  * triaxial cored logarithmic potential. "
	   ! from Thomas et al. 2005  & B&T 1987 (p. 46)
	    if (n_dmparam .ne. 4)  stop 'wrong number of halo parameters'

       print*, "  Vc (km/s), Rc (kpc,km):",dmparam(1), dmparam(2),dmparam(2)*parsec_km*1d3
       if (dmparam(1) .le. 0.0_dp) stop 'VC < 0'
       if (dmparam(2) .le. 0.0_dp) stop 'Rc < 0'

       print*, "  flattening p & q", dmparam(3),dmparam(4)
	   if (dmparam(3) .gt. 1.0_dp .or. dmparam(4) .le. 0.0_dp &
	          .or. dmparam(3) .lt. dmparam(4)) stop ' Flattening is not 0<q<=p<=1'

       ! turning p and q into p^2 and q^2
       dmparam(3)=dmparam(3)**2
       dmparam(4)=dmparam(4)**2

       ! Turning Core radius from kpc to km^2
       dmparam(2)=(dmparam(2)*parsec_km*1d3)**2.0_dp

       ! Turning VC into km^2
       dmparam(1)=dmparam(1)**2.0_dp

	!case (4)
		!read (unit=13, fmt=*) dm_profile_rhoc, dm_profile_parameter, r200, dm_rho_crit, dm_profile_a, dm_profile_b, dm_profile_c
		!print*,'Parameters of NFW(triaxial approximation)', dm_profile_rhoc, dm_profile_parameter, r200, dm_rho_crit
		!print*,'rho crit:', rho_crit
		!print*, dm_profile_a, dm_profile_b, dm_profile_c
		!dm_profile_axes_length = dm_profile_a**2 + dm_profile_b**2 + dm_profile_c**2
		!print*,'unnormalized axes length:', dm_profile_axes_length
		!dm_profile_a = dm_profile_a *sqrt(3/dm_profile_axes_length)
		!dm_profile_b = dm_profile_b *sqrt(3/dm_profile_axes_length)
		!dm_profile_c = dm_profile_c *sqrt(3/dm_profile_axes_length)
		!dm_profile_axes_length = dm_profile_a**2 + dm_profile_b**2 + dm_profile_c**2
		!print*,' normalized axes length:', dm_profile_axes_length
        case (5)
        !	     dmparam(1) = concentration=r_vir/r_s
        !        dmparam(2) = dm_fraction   (fraction of DM mass within R200 radius)
	    if (n_dmparam .ne. 3)  stop 'wrong number of gNFW halo parameters'
	    print*,'Parameters of NFW concentration, Mvir, inner log-slope',dmparam(1),dmparam(2),dmparam(3)
!Update, JJA. Use c_vir=r_vir/r_s, M_vir=(4/3)*pi*Del_c*rho_crit*r_v^3,
!analytically integrated to M(r), and equate to get rho_s/rho_crit==delta_c.
!dm_zeta is a simplification for Barnable+12 Eq 10.
           if (dmparam(3) .lt. 1.0_dp) then
              dm_zeta=((1.0_dp+dmparam(1))/dmparam(1))**(dmparam(3)-2.0_dp)*(2.0_dp*dmparam(3)*dmparam(1)-3.0_dp&
*dmparam(1)+dmparam(3)-2.0_dp)/(dmparam(3)*dmparam(3)-3.0_dp*dmparam(3)+2.0_dp)/dmparam(1)+exp(zh_gammln(2.0_dp&
-dmparam(3))-zh_gammln(1.0_dp-dmparam(3)))*zh_betai(1.0_dp-dmparam(3),0.0_dp,dmparam(1)/(dmparam(1)+1.0_dp))/(1.0_dp-dmparam(3))
           else if (dmparam(3) .eq. 1.0_dp) then
              dm_zeta=log(1.0_dp+dmparam(1))-dmparam(1)/(1.0_dp+dmparam(1))
           else
!Must protect against the argument in gammln going negative, using Euler's
!reflection formula. Will be singular if gamma runs away to large integers >1,
!but those cases are unreasonable anyway.
              tmp_gamma=pi_d/sin(pi_d*(1.0_dp-dmparam(3)))/exp(zh_gammln(dmparam(3)))
              dm_zeta=((1.0_dp+dmparam(1))/dmparam(1))**(dmparam(3)-2.0_dp)*(2.0_dp*dmparam(3)*dmparam(1)-3.0_dp&
*dmparam(1)+dmparam(3)-2.0_dp)/(dmparam(3)*dmparam(3)-3.0_dp*dmparam(3)+2.0_dp)/dmparam(1)+(exp(zh_gammln(2.0_dp&
-dmparam(3)))/tmp_gamma)*zh_betai(1.0_dp-dmparam(3),0.0_dp,dmparam(1)/(dmparam(1)+1.0_dp))/(1.0_dp-dmparam(3))
           end if

	    rhoc = (200.0_dp/3.0_dp)*rho_crit*dmparam(1)**3/dm_zeta

	    rc = (3.0_dp*dmparam(2)/(800.0_dp*pi_d*rho_crit*dmparam(1)**3))**(1.0_dp/3.0_dp)
	    gamma_var=dmparam(3)
	    ! 12 Oct 2011: LW found unit conversion bug in print statment
		print*, "Parameters of NFW potential (rho_c in solarmass/km^3 and r_c in km): ", rhoc, rc
		! Calculate M200, in Msun
		darkmass = dmparam(2)
!               print*, rhoc, rc, "DM values----------------------------"

    end select

end subroutine dm_setup

subroutine dm_stop()
   ! use triaxpotent, only : tp_stop
   ! call tp_stop()  ! function does not exist, but should.
end subroutine dm_stop

subroutine dm_potent(x,y,z,pot)
  use triaxpotent, only : tp_potent
  use initial_parameters
  real(kind=dp), intent(in) ::  x, y, z
  real(kind=dp), intent(out):: pot
  real(kind=dp) :: d,d2,dnorm,xi,ibeta_v2,ibeta_v3,zh_betai

  d2 = x*x + y*y + z*z

  call tp_potent(x,y,z,pot)

  ! add Plummer style black hole
  pot = pot + grav_const_km *  xmbh / sqrt( d2 + softl_km*softl_km )

  select case (dm_profile_type)
	case (0)
            !blank
	case (1)
     ! add NFW dark halo
	 !d =sqrt(d2)
	 if (sqrt(d2)/rc .ge. 1.0) then
     pot = pot + 4.0_dp*pi_d*grav_const_km*rhoc*rc**3/sqrt(d2) * log(1.0_dp+sqrt(d2)/rc)
     else
     ! indentity log (1+x) = 2* atanh(x/(2+x)) , required when 0<x<<1
	  pot = pot + 4.0_dp*pi_d*grav_const_km*rhoc*rc**3/sqrt(d2) * 2*atanh( (sqrt(d2)/rc)/(2+sqrt(d2)/rc))
	 endif
    case (2)
     ! Hernquist
     d =sqrt(d2)
	 pot = pot + 4.0_dp*pi_d*grav_const_km*rhoc*rc**2 / (2*(1+d/rc))
    case(3)
     ! cored logarihtmic
     ! phi=1/2*vc^2*log(rc^2+x^2+y^2/p^2+z^2/q^2)
     pot = pot - 0.5_dp *dmparam(1) *  log(dmparam(2) + (x**2.0_dp + y**2.0_dp /dmparam(3) + z**2.0_dp /dmparam(4)))
     if ((x**2.0_dp + y**2.0_dp /dmparam(3) + z**2.0_dp /dmparam(4))/dmparam(2) .le. 1.0d-14)  &
stop ' potential fails log(x+y) test'
     ! density rho is the laplacian of the potential phi:
	 !rho = -vc**2*(-p**4*q**4*rc**2+x**2*p**4*q**4-p**2*q**4*y**2-p*        $
	 !    *4*q**2*z**2-q**4*rc**2*p**2-q**4*x**2*p**2+y**2*q**4-q**2*z**2*   $
	 !    p**2-p**4*rc**2*q**2-p**4*x**2*q**2-p**2*y**2*q**2+z**2*p**4)      $
	 !    /(rc**2*p**2*q**2+x**2*p**2*q**2+y**2*q**2+z**2*p**2)**2

	!case (4)
   	! r = d
	! ra = dm_profile_parameter
	! re = sqrt(x**2/dm_profile_a**2 + y**2/dm_profile_b**2 + z**2/dm_profile_c**2)
	! rtilde = (ra+r)*re / (ra+re)
    !
	! pot = pot + 4.0_dp * pi_d * grav_const_km*dm_profile_rhoc*dm_profile_parameter**3/rtilde * log(1.0_dp + rtilde/dm_profile_parameter)
    case(5)
!This can be derived from Zhao'96 Eq 6-7.
       dnorm=sqrt(d2)/rc
       xi=dnorm/(1.0_dp+dnorm)
       ibeta_v2=zh_betai(3.0_dp-gamma_var,0.0_dp,xi)
       ibeta_v3=zh_betai(1.0_dp,2.0_dp-gamma_var,1.0_dp-xi)
       pot = pot + (4.0_dp*pi_d)*grav_const_km*rhoc*(ibeta_v2/dnorm&
       +ibeta_v3)*rc*rc
    end select

end subroutine dm_potent

!+++++++++++++++++++++++++++++++++++
subroutine dm_accel(x,y,z,vx,vy,vz)
  use triaxpotent, only : tp_accel
  use initial_parameters
  real(kind=dp), intent(in) ::  x, y, z
  real(kind=dp), intent(out):: vx,vy,vz
  !------------------------------------
   real(kind=dp) :: t,t1,t2,t3,t4,d2,acceleration_r
   real(kind=dp) :: d,ibeta_v1,ibeta_v2,ibeta_v3,xi,dnorm,zh_betai,zh_beta
!  integer(kind=i4b) :: p,r

   call tp_accel(x,y,z,vx,vy,vz)

   d2 = x*x + y*y + z*z
   ! Add Plummer style blackhole.
   t  =  - grav_const_km *  xmbh * ( d2 + softl_km*softl_km ) ** (-3.0_dp/2.0)
   vx = vx + x * t
   vy = vy + y * t
   vz = vz + z * t

  select case (dm_profile_type)
	case (0)
            !blank
	case (1)   ! Add NFW dark matter halo
     t1 = -4.0_dp*pi_d*grav_const_km*rhoc*rc**3/d2
     ! indentity log (1+x) = 2* atanh(x/(2+x)) , required when 0<x<<1
     if (sqrt(d2)/rc .ge. 1.0) then
	   t2 = log(1.0_dp + sqrt(d2)/rc)
     else
	   t2= 2*atanh( (sqrt(d2)/rc)/(2+sqrt(d2)/rc))
     endif
     t3 = (sqrt(d2)/rc)/(1.0_dp+sqrt(d2)/rc)
     vx = vx + x/sqrt(d2) * t1*(t2 - t3)
     vy = vy + y/sqrt(d2) * t1*(t2 - t3)
     vz = vz + z/sqrt(d2) * t1*(t2 - t3)
      if (x/sqrt(d2) * t1*(t2 - t3) .gt. 0 .and. x .gt. 0)  then
	   print*,vx,x/sqrt(d2) * t1*(t2 - t3) ,d2
	   print*,t1,t2,t3
	   print*,sqrt(d2)/rc,d2,rc
	   stop 'NFW accelations flipped sign'
      endif
    case (2)     !Hernquist
  	 acceleration_r = -2.0_dp * pi_d * grav_const_km * rhoc*rc/(1+sqrt(d2)/rc)**2
	 vx = vx + x/sqrt(d2) * acceleration_r
	 vy = vy + y/sqrt(d2) * acceleration_r
	 vz = vz + z/sqrt(d2) * acceleration_r
    case (3) ! cored logarihtmic
     ! phi=1/2*vc^2*log(rc^2+x^2+y^2/p^2+z^2/q^2)
     ! vx= diff(phi,x)
     vx= vx - dmparam(1)* x             / (dmparam(2)+x*x+ y*y/dmparam(3) + z*z/dmparam(4))
     vy= vy - dmparam(1)*(y/dmparam(3)) / (dmparam(2)+x*x+ y*y/dmparam(3) + z*z/dmparam(4))
     vz= vz - dmparam(1)*(z/dmparam(4)) / (dmparam(2)+x*x+ y*y/dmparam(3) + z*z/dmparam(4))

    !case (4)     !Vogelsberger
	!	    d = sqrt(d2)
	!		! see Vogelsberger+ 2008
	!		r = d
	!		ra = dm_profile_parameter
	!		re = sqrt(x**2/dm_profile_a**2 + y**2/dm_profile_b**2 + z**2/dm_profile_c**2)
	!		rtilde = (ra+r)*re / (ra+re)
    !
	!		t1 = -4.0_dp*pi_d*grav_const_km*dm_profile_rhoc*dm_profile_parameter**3/rtilde**2
	!		t2 = log(1.0_dp + rtilde/dm_profile_parameter)
	!		t3 = (rtilde/dm_profile_parameter)/(1.0_dp+rtilde/dm_profile_parameter)
    !
	!		acceleration_rtilde = t1*(t2 - t3)
    !
	!		drtildedx = 1 / (ra+re)**2 * (1/re * x / dm_profile_a**2 * (ra+r) * ra + 1/r * x * (ra+re)*re)
	!		drtildedy = 1 / (ra+re)**2 * (1/re * y / dm_profile_b**2 * (ra+r) * ra + 1/r * y * (ra+re)*re)
	!		drtildedz = 1 / (ra+re)**2 * (1/re * z / dm_profile_c**2 * (ra+r) * ra + 1/r * z * (ra+re)*re)
	!		vx = vx + acceleration_rtilde * drtildedx
	!		vy = vy + acceleration_rtilde * drtildedy
	!		vz = vz + acceleration_rtilde * drtildedz
    case (5) ! gNFW
!Derived by JJA, starting with the results of Zhao'06 Eq 6-7.
       dnorm=sqrt(d2)/rc
       xi=dnorm/(1.0_dp+dnorm)
       ibeta_v2=zh_betai(3.0_dp-gamma_var,0.0_dp,xi)
       acceleration_r = 4.0_dp * pi_d * grav_const_km * rhoc*rc/dnorm
       t1 = xi**(2.0_dp-gamma_var)/(1.0_dp-xi)/rc/dnorm/(1.0_dp+dnorm)**2
       t2 = xi**(1.0_dp-gamma_var)/rc/(1.0_dp+dnorm)**2
       t3 = ibeta_v2*rc/d2
       t4 = acceleration_r * (t1 - t2 - t3)
       vx = vx + x * t4
       vy = vy + y * t4
       vz = vz + z * t4
    end select

end subroutine dm_accel
end module dmpotent


! This routine will perform a coordinates conversion of the errors in the
! magnetic field inclination and azimuth. It takes the heliocentric
! angle (theta), the local magnetic inclination (Gamma), the
! line-of-sight magnetic inclination (Gamma_p) and azimuth
! (Chi_p), and their respective errors (dGamma_p, dChi_p), and returns the
! errors in the local inclination (dGamma) and azimuth (dChi).
! All of these angles are real arrays of size npoints. This is obtained
! by derivating the formulae in the routine los_to_local.
!
! It is assumed that the heliocentriz azimuth is zero, which means that
! the observed point is on the E-W line that crosses the solar disk center.
! If that is not the case, the azimuth obtained is uncalibrated by an
! additive constant.
!
! navarro@hao.ucar.edu , Mar 2000
!
Subroutine los_to_local_errors(npoints, Theta, Gamma, Gamma_p, Chi_p, &
     dGamma_p, dChi_p, dGamma, dChi)
  Implicit None
  Integer :: npoints
  Real :: Theta
  Real, parameter :: Pi = 3.14159265389793D0, Deg_to_rad = Pi/180.
  Real, dimension (npoints) :: Gamma, Gamma_p, Chi_p, dGamma_p, dChi_p, &
       dGamma, dChi
  Integer :: ipoint
!
! Piece of cake
!
  dChi=dChi_p
!
!     There is a special case when gamma = 0 (it results in a 0/0
!                     avoidable uncertainty)
  Do ipoint=1, npoints
     If (Gamma(ipoint) .lt. 1.E-3) Gamma(ipoint)=1.E-3
  End do
  dGamma=(Cos(Gamma_p*Deg_to_rad)*Cos(Chi_p*Deg_to_rad)* &
       Sin(Theta*Deg_to_rad)*dGamma_p - &
       Sin(Gamma_p)*Sin(Chi_p)*Sin(Theta)*dChi_p - &
       Sin(Gamma_p)*Cos(Theta)*dGamma_p)/Sin(Gamma)
!
! Done!
!
  dGamma=Abs(dGamma)
  Return
End Subroutine los_to_local_errors


!Clase Serendipity
module MSerendipity
    implicit none

    type Serendipity
        real :: X(8)
        real :: Y(8)
        real :: t
        real :: l
        real :: l0
        real :: PUNTOS(3)
        real :: PESOS(3)
        integer, allocatable :: nolocales(:)
    contains
        procedure, pass :: psi
        procedure, pass :: dzpsi
        procedure, pass :: dnpsi
        procedure, pass :: TX
        procedure, pass :: TY
        procedure, pass :: JAC
        procedure, pass :: ML
        procedure, pass :: MNL

    end type Serendipity

contains
    real function dzpsi(this,i,z,n)
        class(Serendipity), intent(inout) :: this
        integer :: i
        real :: z
        real :: n
        dzpsi = -1.0
        if (i==1) then
            dzpsi = -1.0/4.0*(n-1.0)*(2.0*z+n)
        else if (i==2) then
            dzpsi = -1.0/4.0*(n-1.0)*(2.0*z-n)
        else if (i==3) then
            dzpsi = 1.0/4.0*(n+1.0)*(2.0*z+n)
        else if (i==4) then
            dzpsi = 1.0/4.0*(n+1.0)*(2.0*z-n)
        else if (i==5) then
            dzpsi = (n-1.0)*z
        else if (i==6) then
            dzpsi = -1.0/2.0*(n*n-1.0)
        else if (i==7) then
            dzpsi = -(n+1.0)*z
        else
            dzpsi = 1.0/2.0*(n*n-1.0)
        endif
    end function dzpsi

    real function dnpsi(this,i,z,n)
        class(Serendipity), intent(inout) :: this
        integer :: i
        real :: z
        real :: n
        dnpsi = -1.0
        if (i==1) then
            dnpsi = -1.0/4.0*(z-1.0)*(2.0*n+z)
        else if (i==2) then
            dnpsi = 1.0/4.0*(z+1.0)*(2.0*n-z)
        else if (i==3) then
            dnpsi = 1.0/4.0*(z+1.0)*(2.0*n+z)
        else if (i==4) then
            dnpsi = -1.0/4.0*(z-1.0)*(2.0*n-z)
        else if (i==5) then
            dnpsi = 1.0/2.0*(z*z-1.0)
        else if (i==6) then
            dnpsi = -n*(z+1.0)
        else if (i==7) then
            dnpsi = -1.0/2.0*(z*z-1.0)
        else
            dnpsi = n*(z-1.0)
        endif
    end function dnpsi

    real function psi(this,i,z,n)
        class(Serendipity), intent(inout) :: this
        integer :: i
        real :: z
        real :: n
        psi = -1.0
        if (i==1) then
            psi = 1.0/4.0*(1.0-z)*(1.0-n)*(-1.0-z-n)
        else if (i==2) then
            psi = 1.0/4.0*(1.0+z)*(1.0-n)*(-1.0+z-n)
        else if (i==3) then
            psi = 1.0/4.0*(1.0+z)*(1.0+n)*(-1.0+z+n)
        else if (i==4) then
            psi = 1.0/4.0*(1.0-z)*(1.0+n)*(-1.0-z+n)
        else if (i==5) then
            psi = 1.0/2.0*(1.0-z*z)*(1.0-n)
        else if (i==6) then
            psi = 1.0/2.0*(1.0+z)*(1.0-n*n)
        else if (i==7) then
            psi = 1.0/2.0*(1.0-z*z)*(1.0+n)
        else
            psi = 1.0/2.0*(1.0-z)*(1.0-n*n)
        endif
    end function psi

    real function TX(this,z,n)
        class(Serendipity), intent(inout) :: this
        integer :: i
        real :: z
        real :: n
        TX = 0.0
        do i=1,8
            TX = TX + this%X(i)*this%psi(i,z,n)
        enddo
    end function TX

    real function TY(this,z,n)
        class(Serendipity), intent(inout) :: this
        integer :: i
        real :: z
        real :: n
        TY = 0.0
        do i=1,8
            TY = TY + this%Y(i)*this%psi(i,z,n)
        enddo
    end function TY

    subroutine JAC(this,matriz,z,n)
        implicit none
        real :: matriz(2,2)
        real :: z
        real :: n
        integer :: i
        integer :: j
        class(Serendipity), intent(inout) :: this
        do i=1,2
            do j=1,2
                matriz(i,j)=0
            enddo
        enddo
        do i=1,8
            matriz(1,1)=matriz(1,1)+this%X(i)*this%dzpsi(i,z,n)
            matriz(1,2)=matriz(1,2)+this%Y(i)*this%dzpsi(i,z,n)
            matriz(2,1)=matriz(2,1)+this%X(i)*this%dnpsi(i,z,n)
            matriz(2,2)=matriz(2,2)+this%Y(i)*this%dnpsi(i,z,n)
        enddo
    end
    subroutine ML(e,matriz,C11,C12,C66)
        implicit none
        real :: matriz(16,16)
        integer :: gdli
        integer :: gdlj
        integer :: i
        integer :: j
        integer :: inl
        integer :: jnl

        real :: z
        real :: n
        real :: x
        real :: y
        real :: detjac
        real :: jacobiano(2,2)
        real :: jacobiano_(2,2)
        real :: dz_i
        real :: dn_i
        real :: dfdx_i
        real :: dfdy_i
        real :: dz_j
        real :: dn_j
        real :: dfdx_j
        real :: dfdy_j
        real :: t
        real :: C11
        real :: C12
        real :: C66
        real :: an
        real :: PESOS(3)

        class(Serendipity), intent(inout) :: e

        PESOS = e%PESOS
        t = e%t
        do i=1,16
            do j=1,16
                matriz(i,j)=0
            enddo
        enddo

        do gdli=1,8
            do gdlj=1,8
                do i=1,3
                    z = e%PUNTOS(i)
                    do j=1,3
                        n = e%PUNTOS(j)

                        x = e%TX(z,n)
                        y = e%TY(z,n)

                        call e%JAC(jacobiano,z,n)
                        detjac = jacobiano(1,1)*jacobiano(2,2)-jacobiano(1,2)*jacobiano(2,1)

                        jacobiano_(1,1)=jacobiano(2,2)/detjac
                        jacobiano_(1,2)=-jacobiano(1,2)/detjac
                        jacobiano_(2,1)=-jacobiano(2,1)/detjac
                        jacobiano_(2,2)=jacobiano(1,1)/detjac

                        dz_i = e%dzpsi(gdli,z,n)
                        dn_i = e%dnpsi(gdli,z,n)

                        dfdx_i = dz_i * jacobiano_(1,1) + dn_i* jacobiano_(1,2)
                        dfdy_i = dz_i * jacobiano_(2,1) + dn_i* jacobiano_(2,2)

                        dz_j = e%dzpsi(gdlj,z,n)
                        dn_j = e%dnpsi(gdlj,z,n)

                        dfdx_J = dz_j * jacobiano_(1,1) + dn_j* jacobiano_(1,2)
                        dfdy_J = dz_j * jacobiano_(2,1) + dn_j* jacobiano_(1,1)

                        an = detjac*PESOS(j)*PESOS(i)

                        matriz(gdli,gdlj)=matriz(gdli,gdlj)+t*(C11*dfdx_i*dfdx_j+C66*dfdy_i*dfdy_j)*an
                        matriz(gdli,gdlj+8)=matriz(gdli,gdlj+8)+t*(C12*dfdx_i*dfdy_j+C66*dfdy_i*dfdx_j)*an
                        matriz(gdli+8,gdlj)=matriz(gdli+8,gdlj)+t*(C12*dfdy_i*dfdx_j+C66*dfdx_i*dfdy_j)*an
                        matriz(gdli+8,gdlj+8)=matriz(gdli+8,gdlj+8)+t*(C11*dfdy_i*dfdy_j+C66*dfdx_i*dfdx_j)*an
                    enddo
                enddo
            enddo
        enddo
    end
    subroutine MNL(e,enl,matriz,C11,C12,C66)
        implicit none
        real :: matriz(16,16)
        integer :: gdli
        integer :: gdlj
        integer :: i
        integer :: j
        integer :: inl
        integer :: jnl

        real :: z
        real :: n
        real :: x
        real :: y
        real :: detjac
        real :: jacobiano(2,2)
        real :: jacobiano_(2,2)
        real :: dz_i
        real :: dn_i
        real :: dfdx_i
        real :: dfdy_i

        real :: znl
        real :: nnl
        real :: xnl
        real :: ynl
        real :: detjacnl
        real :: jacobianonl(2,2)
        real :: jacobiano_nl(2,2)
        real :: dznl_j
        real :: dnnl_j
        real :: dfdxnl_j
        real :: dfdynl_j
        real :: AZN
        real :: t
        real :: distancia
        real :: C11
        real :: C12
        real :: C66
        real :: an
        real :: PESOS(3)

        class(Serendipity), intent(inout) :: e
        class(Serendipity), intent(inout) :: enl

        PESOS = e%PESOS
        t = e%t
        do i=1,16
            do j=1,16
                matriz(i,j)=0
            enddo
        enddo

        do gdli=1,8
            do gdlj=1,8
                do i=1,3
                    z = e%PUNTOS(i)
                    do j=1,3
                        n = e%PUNTOS(j)

                        x = e%TX(z,n)
                        y = e%TY(z,n)

                        call e%JAC(jacobiano,z,n)
                        detjac = jacobiano(1,1)*jacobiano(2,2)-jacobiano(1,2)*jacobiano(2,1)

                        jacobiano_(1,1)=jacobiano(2,2)/detjac
                        jacobiano_(1,2)=-jacobiano(1,2)/detjac
                        jacobiano_(2,1)=-jacobiano(2,1)/detjac
                        jacobiano_(2,2)=jacobiano(1,1)/detjac

                        dz_i = e%dzpsi(gdli,z,n)
                        dn_i = e%dnpsi(gdli,z,n)

                        dfdx_i = dz_i * jacobiano_(1,1) + dn_i* jacobiano_(1,2)
                        dfdy_i = dz_i * jacobiano_(2,1) + dn_i* jacobiano_(2,2)

                        do inl=1,3
                            znl = enl%PUNTOS(inl)
                            do jnl=1,3
                                nnl = enl%PUNTOS(jnl)

                                xnl = enl%TX(zNL,nNL)
                                ynl = enl%TY(zNL,nNL)

                                call enl%JAC(jacobianonl,znl,nnl)
                                detjacnl = jacobianonl(1,1)*jacobianonl(2,2)-jacobianonl(1,2)*jacobianonl(2,1)

                                jacobiano_nl(1,1)=jacobianonl(2,2)/detjacnl
                                jacobiano_nl(1,2)=-jacobianonl(1,2)/detjacnl
                                jacobiano_nl(2,1)=-jacobianonl(2,1)/detjacnl
                                jacobiano_nl(2,2)=jacobianonl(1,1)/detjacnl

                                dznl_j = enl%dzpsi(gdlj,znl,nnl)
                                dnnl_j = enl%dnpsi(gdlj,znl,nnl)

                                dfdxnl_J = dznl_j * jacobiano_nl(1,1) + dnnl_j* jacobiano_nl(1,2)
                                dfdynl_J = dznl_j * jacobiano_nl(2,1) + dnnl_j* jacobiano_nl(1,1)
                                distancia = sqrt((x-xnl)**2.0+(y-ynl)**2.0)
                                AZN = e%L0*exp(-distancia/e%l)
                                ! print *, AZN,distancia,x,xnl,y,ynl,"=",z,n,znl,nnl
                                ! print *, "========================="
                                an = detjac*detjacnl*PESOS(jnl)*PESOS(inl)*PESOS(j)*PESOS(i)
                                matriz(gdli,gdlj)=matriz(gdli,gdlj)+t*t*AZN*(C11*dfdx_i*dfdxnl_j+C66*dfdy_i*dfdynl_j)*an
                                matriz(gdli,gdlj+8)=matriz(gdli,gdlj+8)+t*t*AZN*(C12*dfdx_i*dfdynl_j+C66*dfdy_i*dfdxnl_j)*an
                                matriz(gdli+8,gdlj)=matriz(gdli+8,gdlj)+t*t*AZN*(C12*dfdy_i*dfdxnl_j+C66*dfdx_i*dfdynl_j)*an
                                matriz(gdli+8,gdlj+8)=matriz(gdli+8,gdlj+8)+t*t*AZN*(C11*dfdy_i*dfdynl_j+C66*dfdx_i*dfdxnl_j)*an
                            enddo
                        enddo
                    enddo
                enddo

            enddo
        enddo

    end

end module MSerendipity

program NLFEM
    use MSerendipity
    implicit none
!   Variables globales
    real :: PI
    real,allocatable :: GDLS(:,:)
    real,allocatable :: ELEMENTOS_NO_LOCALES(:)
    real :: E, V, L, T, L0, C11, C12, C66
    real :: PUNTOS(3)
    real :: PESOS(3)
    integer :: NGAUSS
    integer :: NGDL
    integer :: NUMERO_GDL
    integer :: NUMERO_ELEMENTOS
    integer :: NUMERO_NODOS_ELEMENTO
    real :: EQUIS(8)
    real :: YE(8)
    integer :: gdl_e(8)
    integer :: longitudLinea
    real :: start, finish
    real :: tiempo_transcurrido, tiempo_promedio

    integer :: i
    integer :: j
    integer :: k
    integer :: m
    integer :: kkkkk
    character(len=255) :: X1
    character(len=255) :: X2

    character(len=9999) format
    real :: MATRIZ_NKLNM(16,16)
    real :: MATRIZ_L(16,16)

    type(Serendipity), allocatable :: ELEMENTOS(:)

    E = 2.1*10.0**6
    V = 0.2
    L = 0.1
    T = 0.5
    C11 = E/(1.0-V**2)
    C12 = V*E/(1.0-V**2)
    C66 = E/2/(1.0+V)
    PI = 3.141592653589793238463
    L0 = 1.0/2.0/PI/L**2/T

    PUNTOS(1) = -sqrt(3.0/5.0)
    PUNTOS(2) = 0
    PUNTOS(3) = sqrt(3.0/5.0)

    NGAUSS = size(PUNTOS)
    NGDL = 16

    PESOS(1) = 5.0/9.0
    PESOS(2) = 8.0/9.0
    PESOS(3) = 5.0/9.0

    open(unit=10, file='input.txt')
    read(10,*) NUMERO_GDL, NUMERO_ELEMENTOS

    allocate(ELEMENTOS(NUMERO_ELEMENTOS))
    allocate(GDLS(NUMERO_GDL,2))

    do i=1,NUMERO_GDL
        read(10,*) GDLS(i,1),GDLS(i,2)
    enddo

    do i=1,NUMERO_ELEMENTOS
        read(10,*) gdl_e
        do j=1,8
            YE(j)=GDLS(gdl_e(j),2)
            EQUIS(j)=GDLS(gdl_e(j),1)
        enddo
        ELEMENTOS(i)%X = EQUIS
        ELEMENTOS(i)%Y = YE
        ELEMENTOS(i)%t = T
        ELEMENTOS(i)%l = L
        ELEMENTOS(i)%l0 = L0

        ELEMENTOS(i)%PUNTOS = PUNTOS
        ELEMENTOS(i)%PESOS = PESOS

    enddo
    do i=1,NUMERO_ELEMENTOS
        read(10, '(A)') format
        read(format,*) longitudLinea
        allocate(ELEMENTOS(i)%nolocales(longitudLinea+1))
        read(format,*) ELEMENTOS(i)%nolocales
    enddo
    close(10)
    call execute_command_line ('mkdir MATRICES')
    kkkkk = chdir('MATRICES')
    tiempo_transcurrido = 0
    do i=1,NUMERO_ELEMENTOS
        call cpu_time(start)
        write(X1,*) i
        call execute_command_line ('mkdir Elemento'// trim(adjustl(X1)))
        call ELEMENTOS(i)%ML(MATRIZ_L,C11,C12,C66)
        open(10,file='Elemento'//trim(adjustl(X1))//'/KL_'//trim(adjustl(X1))//'.csv')
        write (10, "(*(G0,:,','))") MATRIZ_L
        close(10)
        open(11,file='Elemento'//trim(adjustl(X1))//'/KNLS'//'.csv')
        do j=2,ELEMENTOS(i)%nolocales(1)+1
            call ELEMENTOS(i)%MNL(ELEMENTOS(ELEMENTOS(i)%nolocales(j)),MATRIZ_NKLNM,C11,C12,C66)
            write (11, "(*(G0,:,','))") MATRIZ_NKLNM
        enddo
        close(11)
        print *, "------------------------------------------------------------"
        call cpu_time(finish)
        tiempo_transcurrido = tiempo_transcurrido + (finish-start)
        tiempo_promedio = tiempo_transcurrido/i
        print *, "Elemento ",i, " - Tiempo: ",(finish-start)*1000, " ms - ", "ETA [min]: ", tiempo_promedio/60*(NUMERO_ELEMENTOS-i)
    enddo
end program NLFEM


      SUBROUTINE UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,
     1RPL,DDSDDT,DRPLDE,DRPLDT,
     2STRAN,DSTRAN,TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,CMNAME,
     3NDI,NSHR,NTENS,NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,
     4CELENT,DFGRD0,DFGRD1,NOEL,NPT,LAYER,KSPT,JSTEP,KINC)
      ! Note that IMPLICIT definition is active
      INCLUDE 'ABA_PARAM.INC'
C
      CHARACTER*80 CMNAME
C
      DIMENSION STRESS(NTENS),STATEV(NSTATV),
     1DDSDDE(NTENS,NTENS),DDSDDT(NTENS),DRPLDE(NTENS),
     2STRAN(NTENS),DSTRAN(NTENS),TIME(2),PREDEF(1),DPRED(1),
     3PROPS(NPROPS),COORDS(3),DROT(3,3),DFGRD0(3,3),DFGRD1(3,3),
     4JSTEP(4)
C
C
      ! Subroutine control
      INTEGER :: i, j, n_backstresses, it_num, converged
      ! Material properties
      REAL(8) :: elastic_modulus, Q_inf, b, D_inf, a,
     1shear_modulus, bulk_modulus, poisson_ratio, mu2
      ! Used for intermediate calculations
      REAL(8) :: yield_stress, ep_eq, ep_eq_init,
     1hard_iso_Q, hard_iso_D, hard_iso_total, isotropic_modulus,
     2yield_function, e_k, beta, gamma_denom, denom,
     3yield_condition, f_bar, f_bar_2, beta_prime, consist_param
      ! Tangent modulus
      REAL(8), DIMENSION(3) :: n_tilde, n_hat, H_prime, H_tilde
      REAL(8), DIMENSION(3,3) :: H_out_n, n_out_n, A_mat,
     1Xi_tilde, Xi_tilde_A, C_ep
      REAL(8) :: theta_1, theta_2
      ! Backstress arrays
      REAL(8), DIMENSION(:, :), ALLOCATABLE :: alpha_k, alpha_k_i
      REAL(8), DIMENSION(:), ALLOCATABLE :: C_k, gamma_k
      ! Tensors
      REAL(8), DIMENSION(3) :: strain_plastic, dstran_p,
     1alpha, gamma_diag, alpha_tilde,alpha_tilde_prime,
     2strain, eta, eta_tilde, eta_trial, stress_trial,
     3gamma_prime_diag, stress_rel
      REAL(8), DIMENSION(3, 3) :: Q_mat, Q_mat_t, Lambda_P, Lambda_C,
     1elastic_matrix, P_mat, compliance_matrix, ID3
      ! Parameters
      INTEGER :: N_BASIC_PROPS, TERM_PER_BACK, MAX_ITERATIONS,
     1I_ALPHA
      REAL(8) :: TOL, ONE, TWO, THREE, ZERO, SQRT23, SIX
      PARAMETER(TOL=1.0D-8,
     1N_BASIC_PROPS=7, TERM_PER_BACK=2, MAX_ITERATIONS=1000,
     2ONE=1.0D0, TWO=2.0D0, THREE=3.0D0, ZERO=0.D0, SIX=6.0D0,
     3SQRT23=SQRT(2.0D0/3.0D0), I_ALPHA=4)
C ----------------------------------------------------------------------C
C
      ! Initialize
C
C ----------------------------------------------------------------------C
      ! Get the number of backstresses
      n_backstresses = (nprops - N_BASIC_PROPS) / TERM_PER_BACK
      IF (n_backstresses .EQ. 0) THEN
      PRINT *, "No backstresses defined, exiting!"
        CALL XIT  ! Exit from analysis command in Abaqus
      END IF
C
      ! Allocate the backstress related arrays
      ALLOCATE(C_k(n_backstresses))
      ALLOCATE(gamma_k(n_backstresses))
      ALLOCATE(alpha_k(n_backstresses, ntens))
      ALLOCATE(alpha_k_i(n_backstresses, ntens))
C
      ! Material Properties
      elastic_modulus = props(1)
      poisson_ratio = props(2)
      yield_stress = props(3)
      q_inf = props(4)
      b = props(5)
      d_inf = props(6)
      a = props(7)
      DO i = 1, n_backstresses  ! First backstress starts at index = 8
        c_k(i) = props((N_BASIC_PROPS - 1) + 2 * i)
        gamma_k(i) = props(N_BASIC_PROPS + 2 * i)
      END DO
      shear_modulus = elastic_modulus / (TWO * (ONE + poisson_ratio))
      mu2 = TWO * shear_modulus
C
      ! Elastic matrix (defined in column major)
      elastic_matrix = RESHAPE((/ ONE, poisson_ratio, ZERO,
     1poisson_ratio, ONE, ZERO,
     2ZERO, ZERO, (ONE-poisson_ratio) / TWO /),
     3SHAPE(elastic_matrix))
      elastic_matrix = elastic_modulus / (ONE - poisson_ratio ** 2) *
     1elastic_matrix
      ! Compliance matrix
      compliance_matrix = RESHAPE((/ ONE, -poisson_ratio, ZERO,
     1-poisson_ratio, ONE, ZERO,
     2ZERO, ZERO, TWO*(ONE + poisson_ratio)/), SHAPE(compliance_matrix))
      compliance_matrix = ONE/elastic_modulus * compliance_matrix
C
      gamma_diag(:) = ZERO
      Q_mat = RESHAPE((/ ONE, ONE, ZERO, -ONE, ONE, ZERO,
     1ZERO, ZERO, SQRT(TWO) /), SHAPE(Q_mat))
      Q_mat = ONE / SQRT(TWO) * Q_mat
      Q_mat_t = TRANSPOSE(Q_mat)
C
      P_mat = RESHAPE((/ TWO, -ONE, ZERO, -ONE, TWO, ZERO,
     1ZERO, ZERO, SIX /), SHAPE(P_mat))
      P_mat = ONE / THREE * P_mat
C
      Lambda_P(:, :) = ZERO
      Lambda_P(1, 1) = ONE/THREE
      Lambda_P(2, 2) = ONE
      Lambda_P(3, 3) = TWO
C
      Lambda_C(:, :) = ZERO
      Lambda_C(1, 1) = elastic_modulus / (ONE - poisson_ratio)
      Lambda_C(2, 2) = mu2
      Lambda_C(3, 3) = shear_modulus
C
      ! Read state variables
      ep_eq = statev(1)
      ep_eq_init = statev(1)
      CALL ROTSIG(statev(2), drot, strain_plastic, 2, ndi, nshr)
      alpha(:) = ZERO
      DO i = 1, n_backstresses
        DO j = 1, ntens
        CALL ROTSIG(statev(I_ALPHA+1 + (i-1) * ntens), drot,
     1  alpha_k(i, :), 1, ndi, nshr)
        END DO
        alpha = alpha + alpha_k(i, :)
      END DO
      alpha_k_i = alpha_k
C
      ID3(:, :) = ZERO
      DO i = 1, NTENS
        ID3(i, i) = ONE
      END DO
C ----------------------------------------------------------------------C
C
      ! Elastic trial step
C
C ----------------------------------------------------------------------C
      ! Don't include e33, and calculate it later
      strain = stran + dstran
      stress_trial = stress + MATMUL(elastic_matrix, dstran)
      !stress_trial = MATMUL(elastic_matrix, strain - strain_plastic)
C
      hard_iso_Q = q_inf * (ONE - EXP(-b * ep_eq))
      hard_iso_D = d_inf * (ONE - EXP(-a * ep_eq))
      hard_iso_total = yield_stress + hard_iso_Q - hard_iso_D
C
      eta_trial = MATMUL(Q_mat_t, stress_trial - alpha)
      eta = eta_trial
C
      f_bar_2 = ZERO
      DO i = 1, ntens
        f_bar_2 = f_bar_2 + eta_trial(i)**2 * Lambda_P(i, i)
      END DO
      yield_condition = ONE/TWO*f_bar_2 - ONE/THREE*hard_iso_total**2
C
      IF (yield_condition .LT. TOL) THEN
        converged = 1
      ELSE
        converged = 0
      END IF
C ----------------------------------------------------------------------C
C
      ! Return mapping in plane-stress subspace if plastic loading
C
C ----------------------------------------------------------------------C
      ! Calculate the consitency parameter
      it_num = 0
      consist_param = ZERO
      DO WHILE ((converged .EQ. 0) .AND. (it_num .LT. MAX_ITERATIONS))
        it_num = it_num + 1
C
        ! Calculate the isotropic hardening parameters
        hard_iso_Q = q_inf * (ONE - EXP(-b * ep_eq))
        hard_iso_D = d_inf * (ONE - EXP(-a * ep_eq))
        hard_iso_total = yield_stress + hard_iso_Q - hard_iso_D
        isotropic_modulus = b*(q_inf-hard_iso_Q) - a*(d_inf-hard_iso_D)
C
        ! Calculate the kinematic hardening related parameters
        beta = ZERO
        alpha_tilde(:) = ZERO
        DO i = 1, n_backstresses
          e_k = EXP(-gamma_k(i) * (ep_eq - ep_eq_init))
          beta = beta + C_k(i) / gamma_k(i) * (ONE - e_k)
          DO j = 1, ntens
            alpha_tilde(j) = alpha_tilde(j) + alpha_k(i, j) * e_k
          END DO
        END DO
        alpha_tilde = alpha - alpha_tilde
        beta = ONE + beta / hard_iso_total
C
        ! Update the relative stress and eta
        gamma_denom = beta + mu2 * consist_param
        gamma_diag(1) = ONE / (beta
     1  + consist_param*elastic_modulus / (THREE*(ONE - poisson_ratio)))
        gamma_diag(2) = ONE / gamma_denom
        gamma_diag(3) = ONE / gamma_denom
        eta_tilde = eta_trial + MATMUL(Q_mat_t, alpha_tilde)
        eta = gamma_diag * eta_tilde
C
        ! Calculate the norm of the relative stress
        f_bar_2 = ONE/THREE * eta(1)**2 + eta(2)**2 + TWO * eta(3)**2
        f_bar = SQRT(f_bar_2)
C
        beta_prime = ZERO
        alpha_tilde_prime(:) = ZERO
        DO i = 1, n_backstresses
          e_k = EXP(-gamma_k(i) * (ep_eq - ep_eq_init))
          beta_prime = beta_prime
     1    - C_k(i) * isotropic_modulus
     2    / (gamma_k(i) * hard_iso_total**2) * (ONE - e_k)
     3    + C_k(i) * e_k / hard_iso_total
          DO j = 1, ntens
            alpha_tilde_prime(j) = alpha_tilde_prime(j)
     1      + gamma_k(i) * e_k * alpha_k(i, j)
          END DO
        END DO
        beta_prime = SQRT23 * f_bar * beta_prime
        alpha_tilde_prime = SQRT23 * f_bar * alpha_tilde_prime
        DO i = 1, ntens
          gamma_prime_diag(i) = -gamma_diag(i) ** 2
     1    * (beta_prime + Lambda_P(i, i) * Lambda_C(i, i))
        END DO

        yield_condition = ONE/TWO*f_bar_2 - ONE/THREE*hard_iso_total**2
        denom = DOT_PRODUCT( MATMUL(Lambda_P, eta),
     1  gamma_prime_diag * eta_tilde
     2  + gamma_diag * MATMUL(Q_mat_t, alpha_tilde_prime) )
     3  - SQRT23*TWO/THREE * hard_iso_total * isotropic_modulus * f_bar
C
        consist_param = consist_param - yield_condition / denom
        ep_eq = ep_eq_init + SQRT23 * consist_param * f_bar
C
        IF (ABS(yield_condition) .LT. TOL) THEN
          converged = 1
        END IF
      END DO
C ----------------------------------------------------------------------C
C
      ! Update variables
C
C ----------------------------------------------------------------------C
      IF (it_num .EQ. 0) THEN  ! Elastic loading
        stress = stress_trial
        ddsdde = elastic_matrix
      ELSE  ! Plastic loading
        eta_tilde = eta_trial + MATMUL(Q_mat_t, alpha_tilde)
        eta = gamma_diag * eta_tilde
        stress_rel = MATMUL(Q_mat, eta)
C
        hard_iso_Q = q_inf * (ONE - EXP(-b * ep_eq))
        hard_iso_D = d_inf * (ONE - EXP(-a * ep_eq))
        hard_iso_total = yield_stress + hard_iso_Q - hard_iso_D
        DO i = 1, n_backstresses
          e_k = EXP(-gamma_k(i) * (ep_eq - ep_eq_init))
          DO j = 1, ntens
            alpha_k(i, j) = alpha_k(i, j) * e_k +
     1      stress_rel(j)/hard_iso_total * c_k(i)/gamma_k(i)*(ONE-e_k)
          END DO
        END DO
C        strain_plastic = strain_plastic
C     1  + consist_param * MATMUL(P_mat, stress_rel)
C        stress = MATMUL(elastic_matrix, strain - strain_plastic)
        dstran_p = consist_param * MATMUL(P_mat, stress_rel)
        strain_plastic = strain_plastic + dstran_p
        stress = stress_trial - MATMUL(elastic_matrix, dstran_p)
      END IF
C ----------------------------------------------------------------------C
C
      ! Compute consistent tangent moduli
C
C ----------------------------------------------------------------------C
      IF (it_num .GT. 0) THEN
        n_hat = stress_rel / f_bar
        H_prime =-(beta-ONE)*isotropic_modulus*stress_rel/hard_iso_total
        DO i = 1, n_backstresses
          e_k = EXP(-gamma_k(i) * (ep_eq - ep_eq_init))
          H_prime = H_prime + C_k(i) * e_k * stress_rel / hard_iso_total
     1    - gamma_k(i) * e_k * alpha_k_i(i, :)
        END DO
        H_prime = SQRT23 * H_prime
        DO i = 1, NTENS
          DO j = 1, NTENS
            H_out_n(i, j) = H_prime(i) * n_hat(j)
          END DO
        END DO
        A_mat = beta * ID3 + consist_param * MATMUL(H_out_n, P_mat)
        A_mat = matinv3(A_mat)
C
        n_tilde = n_hat - consist_param * MATMUL(A_mat, H_prime)
        Xi_tilde = compliance_matrix+consist_param*MATMUL(P_mat, A_mat)
        Xi_tilde = matinv3(Xi_tilde)
        Xi_tilde_A = MATMUL(A_mat, Xi_tilde)
C
        theta_2 = ONE - TWO/THREE * isotropic_modulus * consist_param
        H_tilde = H_prime + MATMUL(Xi_tilde, MATMUL(P_mat, n_tilde))
        theta_1 = TWO/THREE * isotropic_modulus
     1  + theta_2*DOT_PRODUCT(n_hat,MATMUL(P_mat,MATMUL(A_mat,H_tilde)))
        DO i = 1, NTENS
          DO j = 1, NTENS
            n_out_n(i, j) = n_tilde(i) * n_hat(j)
          END DO
        END DO

        C_ep = Xi_tilde - theta_2 / theta_1 *
     1  MATMUL(Xi_tilde,
     2  MATMUL(P_mat,
     3  MATMUL(n_out_n,
     4  MATMUL(P_mat, Xi_tilde_A))))
C
        ddsdde = ONE/TWO * (C_ep + TRANSPOSE(C_ep))
        END IF
C ----------------------------------------------------------------------C
C
      ! Update the state variables
C
C ----------------------------------------------------------------------C
      statev(1) = ep_eq
      statev(2:(1+ntens)) = strain_plastic
      DO i = 1, n_backstresses
        DO j = 1, ntens
          statev(I_ALPHA + (i-1) * ntens + j) = alpha_k(i, j)
        END DO
      END DO
C ----------------------------------------------------------------------C
C
      ! Reduce time increment if did not converge
C
C ----------------------------------------------------------------------C
      IF (it_num .EQ. MAX_ITERATIONS) THEN
        PRINT *, "WARNING: Return mapping in integration point ", npt,
     1  " of element ", noel, " did not converge."
        PRINT *, "Reducing time increment to 1/4 of current value."
        PNEWDT = 0.25
      END IF
      RETURN

      CONTAINS
C ----------------------------------------------------------------------C
C
      ! Define matrix inverse
C
C ----------------------------------------------------------------------C
      ! From: http://fortranwiki.org/fortran/show/Matrix+inversion
      pure function matinv3(A) result(B)
      !! Performs a direct calculation of the inverse of a 3×3 matrix.
      REAL(8), intent(in) :: A(3,3)   !! Matrix
      REAL(8)             :: B(3,3)   !! Inverse matrix
      REAL(8)             :: detinv

      ! Calculate the inverse determinant of the matrix
      detinv = 1.D0 / (A(1,1)*A(2,2)*A(3,3) - A(1,1)*A(2,3)*A(3,2)
     1- A(1,2)*A(2,1)*A(3,3) + A(1,2)*A(2,3)*A(3,1)
     2+ A(1,3)*A(2,1)*A(3,2) - A(1,3)*A(2,2)*A(3,1))

      ! Calculate the inverse of the matrix
      B(1,1) = +detinv * (A(2,2)*A(3,3) - A(2,3)*A(3,2))
      B(2,1) = -detinv * (A(2,1)*A(3,3) - A(2,3)*A(3,1))
      B(3,1) = +detinv * (A(2,1)*A(3,2) - A(2,2)*A(3,1))
      B(1,2) = -detinv * (A(1,2)*A(3,3) - A(1,3)*A(3,2))
      B(2,2) = +detinv * (A(1,1)*A(3,3) - A(1,3)*A(3,1))
      B(3,2) = -detinv * (A(1,1)*A(3,2) - A(1,2)*A(3,1))
      B(1,3) = +detinv * (A(1,2)*A(2,3) - A(1,3)*A(2,2))
      B(2,3) = -detinv * (A(1,1)*A(2,3) - A(1,3)*A(2,1))
      B(3,3) = +detinv * (A(1,1)*A(2,2) - A(1,2)*A(2,1))
      end function
      END


module para
implicit none
integer*8 ::ndim
integer,parameter::driv_id=20
real*8,parameter:: r_saturn=60268.d0!,Grho=
real*8,allocatable :: grids(:,:,:,:)!存储网格坐标,dim为网格边长
real*8,allocatable :: cyl(:,:,:,:) !网格柱坐标，积分时用到
real*8 :: dim,r1,r2 !环尺寸
!real*8 :: cyl_r,cyl_phi,cyl_z !被积函数中的柱坐标
real*8,parameter::pi=dacos(-1.d0)
end module para