*----------------------------------------------------------------------
*       S P I N T G R L
*----------------------------------------------------------------------
*       This routine reads the yint.lst data storing the concatenated
*       arrays for the different blocks

	SUBROUTINE SPINTGRL(cf_tot)
        IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      include 'mpif.h'
      parameter (MAXPROC=100)
      common /MPI/ myid, nprocs, ierr, istat(MPI_STATUS_SIZE)
*
        PARAMETER (NWD=70,NOD=220,NOFFD=800)
        PARAMETER(MEIG=20,MTERM=20)
*
        CHARACTER EL*3,ATOM*6,TERM*6
        INTEGER       IN,OUT,PRI,OUC,OUF,OUH,OUD
        COMMON/INOUT/ IN,OUT,PRI,IUC,IUF,IUD,OUC,OUF,OUD,OUH,ISCW
        COMMON/LABEL/ EL(60),ATOM,TERM
        LOGICAL       FAIL,OMIT,EZERO,REL,ALL,TRACE
        COMMON/TEST/  FAIL,OMIT,EZERO,REL,ALL,TRACE
       COMMON/WAVE/EC,ED,AZD,PDE(NOD),IJE(noffd),EIJ(noffd),IPR
        COMMON/PARAM/  H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,
     :  NCFG,IB,IC,ID,
     :                D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,
     :                NSCF,NCLOSD,RMASS
        COMMON/RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
      POINTER (QWT,WT(1)),(QWP,WP(1)), (IQWPTR,W(1))
      COMMON /CFGS/ETOTAL,QWT,QWP,IQWPTR
*
      POINTER (pkval,kval(1)),(pvalue,value(1)),
     :        (pih,ih(1)),(pjh,jh(1)),
     :        (pcoeff,coeff(1)),(pnijptr,nijptr(1)),
     :        (pinptr,inptr(1))
      COMMON/STATE/INTPTR(6),IDIM,PKVAL,PVALUE,NZE,PIH,PJH,
     :             NCODIM,PCOEFF,PNIJPTR,PINPTR

*     .. Logical array passed from nonh to give the used integrals
      POINTER (plused,lused(1))
      COMMON/USED/plused
      LOGICAL lused

      POINTER (pico,ico(1))
      COMMON/ICOFF/pico

      POINTER (qjptr,jptr(1))
      COMMON/COLS/qjptr

      integer cf_tot(nblock), n_read, n_left;
      logical leigen(meig,mterm), lguess
      integer nume(mterm),iws(mterm),iiws(mterm),
     :        nze_bl(mterm), ncfg_bl(mterm), niv_bl(mterm)
      character term_bl(mterm)*3
      pointer   (qeigvec,eigvec(1)),(pen,en(1))
      common/st/leigen,nblock,nume,iws,iiws,ncfg_bl,nze_bl,
     :          term_bl, qeigvec, pen, lguess
*
      logical                   ::clst_disk, clst_memory
      common/use_disk/clst_disk, clst_memory

      CHARACTER*72 string

*     print *, 'Entering spintgrl'
*      read the begining of yint.lst
       rewind(iud)
       read(iud) ncl, mwf, nbb, lsd
       maxorb = nwf-nclosd
       if (ncl.ne.nclosd.or.mwf.ne.maxorb.or.nbb.ne.nblock) then
         write(0,*) 'Yint.lst data not consistent with cfg.h data'
         write(0,*) 'Yint.lst :', ncl, mwf, nbb
         write(0,*) 'cfg.h    :', nclosd, nwf, nblock
         stop
       end if
*      .. electron labels have already been read.
       read(iud) string

101    read(iud) string
       maxorb = maxorb - 24
       if (maxorb .gt. 0) go to 101
*      end read

       call alcsts(cf_tot);
       ico = 0
       ih = 0;
       jptr = 0;
       kval = 0;

       ib1 = 0
       ib2 = 0
*      read for each block
       do iblock = 1, nblock
         nij = 0
2        read(iud,iostat=ierr) n, (ih(i+nij),i=ib1+1,ib1+n),
     :                (ico(i+nij),i=ib1+1,ib1+n)
         nij = nij+n
         if (n .ge. lsd) go to 2
         read(iud,iostat=ierr) ncol,(jptr(i),i=ib2+1,(ib2+ncol))
       ib1 = ib1 + nij
       ib2 = ib2 + ncol
*       print '(6i12)',(ih(i),i=1,ib1)
*       print '(6i12)',(ico(i),i=1,ib1)
*       print '(6i12)',(jptr(i),i=1,ib2)
       end do

        nij = 0
C
C ***** READ  THE LIST OF INTEGRALS
C
        lasti = 0

*
        DO 10 INT = 1,4
*
*          ...F, G, R, or L integrals....
           icount = 1
           read(iud) itype, nint

*          .. ipackn of nonh is called kval here
*          .. integral pack number and logical variable indicating usage
           read(iud) (kval(i),i=lasti+1,nint),
     :               (lused(i),i=lasti+1,nint)
           lasti = nint
           icount = icount + 1
           intptr(int) = lasti
   10  CONTINUE

*      .. adjust for the fact that overlaps have been removed

       intptr(6) = intptr(4)
       intptr(5) = intptr(3)
       intptr(4) = intptr(2)
       intptr(3) = intptr(2)

*      ibe = 0;
*      n = ncodim;
*      do iblock = 1, nblock
*        do while (n == ncodim)
*        read(39) n, (coeff(j),j = ibe+1,ibe+n),
*     :                    (inptr(j), j = ibe+1,ibe+n)
*          ibe = ibe + n;
*        end do
*      end do

      if (clst_memory) then
        ibe = 0;
        do iblock = 1, nblock
          n_left = cf_tot(iblock)
          if (cf_tot(iblock)>ncodim) then
            n_read = ncodim;
          else
            n_read = cf_tot(iblock);
          end if
          do while (n_left > 0)
            if (n_left<ncodim) n_read = n_left;
            read(39) n, (coeff(j),j = ibe+1,ibe+n_read),
     :                    (inptr(j), j = ibe+1,ibe+n_read)
*          if (myid == 0) then
*            print*, n, (coeff(j),j = ibe+1,ibe+n_read),
*     :                    (inptr(j), j = ibe+1,ibe+n_read)
*            end if
            ibe = ibe + n_read;
            n_left = n_left - n_read
          end do
        end do
      end if
      return
      end


!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!       NAHOON_1D.F90
!       Wakelam V. and Hersant F. Jan. 2011
!
! 	Chemical eovlution is computed as a function of time.
!       This version of the code can compute the chemistry in more than
!       one shell of gas but does not include any diffusion terme.
!       The jacobian is explicitly given in this version of the code.
!	Output times are read in an input file (timeres.dat).
! 	In 0D, the temperature and density are read in the input_parameter.dat
!	file.
!	In 1D, the temperature and density can be read in an external file but the
!	user must change the format in the code.
!
!       DLSODES integretor is used.
!
! 	Output files:
!       - Kout.dat contain the values of the rate coefficients
!       - plot.dat the abundances as a function of time
!       - verif.dat contains some balance verifications and the
!       rates of formation and destruction for each species at
!       specific times
!       - output.dat is the chemical composition at one time (by default
!       in the same format as cond_initial.dat
!	- photodiss_XX.dat files give the column densities of H2 and (H2 and CO)
!       with the photorates
!
!	April 2011 VW  Modifications:
!		- read new format of KIDA
!		- including a test on the T range of validity of rate coefficients
!		- including a test on duplicated reactions
!		- changing the H2 formation rate
!       August 2013 VW Bug fixing
!       STRONG WARNING: FOR TEMPERATURES OUTSIDE THE T RANGE, RATE COEFFICIENTS ARE
!       NOT EXTRAPOLATED
!              - modification of the way rate coefficients are calculated accoding to T range
!                  in the case of multiple reactions
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       PROGRAM NAHOON_1D

       IMPLICIT NONE

       include 'header.f90'

       INTEGER ITYPE,IPROD,                                        &
     &              ITEST,ITEST2,ELEMENT,I,J,ISP,JSTEP,L,NPLOT,IH,      &
     &              IGRAIN0,IGRAINN,JSPACE,IE,ICO,IH2,NUMBER,FORMULA
       PARAMETER (NPLOT=NS)
       DOUBLE PRECISION SN,Y,AB,PLOTAB,TPLOT,TD,TIMERES,TYR,            &
     &              TIMESELEC,XK1,YGRAIN,XCO,XH2,A,B,C,RANDOM1,UNC,ZETA,&
     &              GTODN,TAU,NCO,T_CO,NH2_1,T_H2_1,AV,T_AV,NH2_2,T_H2_2,&
     &          SNGRAIN,ABBIS,NH2TOT,PLUS,XELEC,ALPHA,Tmin,Tmax

       CHARACTER*10 SPEC,REACTANT
       DIMENSION SN(NS,nx),Y(NS,nx),AB(NS,nx),PLOTAB(NTIME,NPLOT,nx),&
     &              A(NRTOT),B(NRTOT),C(NRTOT),TD(NX),ABBIS(NS),XK1(NX),&
     &              TAU(NX),NH2TOT(NX),TIMERES(NTIME),SPEC(NS+1),ITEST(6),&
     &              ELEMENT(NELEM,NS+1),REACTANT(3,NRTOT),ITYPE(NRTOT),   &
     &              NCO(52),NH2_2(105),Tmin(NRTOT),Tmax(NRTOT),       &
     &              T_H2_2(105),T_CO(52),NH2_1(43),T_H2_1(43),AV(43),       &
     &              T_AV(43),PLUS(NX),XELEC(NX),XCO(NX),XH2(NX),ALPHA(NRTOT), &
     &              NUMBER(NRTOT),FORMULA(NRTOT)
       CHARACTER AA*78,RANDMODE

       INTEGER REACT(NRTOT,7)
       DOUBLE PRECISION K(NRTOT,NX),NHTOT(NX),RADIUS(2,NX)
       COMMON/EQUA/K,NHTOT,RADIUS,REACT

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!        Variable declaration FOR THE DLSODES SUBROUTINE
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       EXTERNAL F, JAC, JACFH
       INTEGER NEQ,ITOL,ITASK,ISTATE,IOPT,LRW,IWORK,LIW,JEX,MF
       DOUBLE PRECISION T, TOUT, RTOL, ATOL, RWORK
       PARAMETER (NEQ=NS*NX,LIW=31+NEQ+2000*NEQ,LRW=20+9*NEQ+2000*NEQ)
       DIMENSION IWORK(LIW), RWORK(LRW)                                 &
     &       , ATOL(NS,NX)

       DATA ITOL, ITASK, ISTATE, IOPT, MF, RTOL                         &
     &              /2, 1, 1, 1, 21, 1.D-6/
! Specific variables for the jacobian geometry
       integer, dimension(NS*NX+1) :: IA, IAN
       integer, dimension(liw) :: JA, JAN
       integer :: NNZ
       integer, dimension(NEQ*NEQ+20) :: IWK
       equivalence(iwk(1),rwork(21))

       IWORK(6)=1000
       RWORK(6)=3.154E+15
       IWORK(5)=5
       IWORK(7)=10

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!       Files declaration
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       OPEN (UNIT=1,FILE='kida.uva.2014',STATUS='OLD')
       OPEN (UNIT=2,FILE='cond_initial_kida.uva.2014.dat',STATUS='OLD')
       OPEN (UNIT=3,FILE='input_parameter.dat',STATUS='OLD')
       OPEN (UNIT=4,FILE='timeres.dat',STATUS='OLD')
       OPEN (UNIT=7,FILE='Self_Shielding_data',STATUS='OLD')

       OPEN (UNIT=9,FILE='Kout.dat',STATUS='UNKNOWN')
       OPEN (UNIT=10,FILE='plot.dat',STATUS='UNKNOWN')
       OPEN (UNIT=11,FILE='verif.dat',STATUS='UNKNOWN')
       OPEN (UNIT=12,FILE='output.dat',STATUS='UNKNOWN')
       OPEN (UNIT=13,FILE='photodiss_H2.dat',STATUS='UNKNOWN')
       OPEN (UNIT=14,FILE='photodiss_CO.dat',STATUS='UNKNOWN')

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!       read data files
!
!       AB is the abundance species with respect to total
!       SN is in number density (cm-3)

!       First put some numbers to zero
       DO I=1,NS
              DO JSPACE=1,NX
                     SN(I,JSPACE)=0.D0
                     Y(I,JSPACE)=0.D0
                     AB(I,JSPACE)=0.D0
                     PLUS(JSPACE)=0.D0
              ENDDO
              DO ISP=1,NELEM
                     ELEMENT(ISP,I)=0
              ENDDO
       ENDDO
       DO ISP=1,NELEM
              ELEMENT(ISP,NS+1)=0
       ENDDO

       DO I=1,NRTOT
              DO JSPACE=1,NX
                  K(I,JSPACE) = 0.0D0
              enddo
       ENDDO

       DO I=1,NX
              TD(I)=0.D0
              NHTOT(I)=0.D0
              TAU(I)=0.D0
       ENDDO

       T=0.D0
       JSTEP=0

!       read output times
       READ(4,*) TIMERES

!       read initial conditions from cond_initial.dat (abundance /H)
!       WHEN THE COND_INITIAL.DAT IS 0D
!       if you want to read 1D initial conditions, the format has to
!       be changed here
       DO I=1,1
              READ (2,*) AA
       ENDDO
       DO I=1,NS
              READ (2,1) SPEC(I),(ELEMENT(ISP,I),ISP=1,NELEM),          &
     &              ABBIS(I)
               DO JSPACE=1,NX
                     AB(I,JSPACE)=ABBIS(I)
                     IF (ELEMENT(1,I).EQ.1) PLUS(JSPACE)=PLUS(JSPACE)+AB(I,JSPACE)
              ENDDO
              IF (SPEC(I).EQ.'H         ') IH=I
              IF (SPEC(I).EQ.'GRAIN0    ') IGRAIN0=I
              IF (SPEC(I).EQ.'GRAIN-    ') IGRAINN=I
	      IF (SPEC(I).EQ.'e-        ') IE=I
              IF (SPEC(I).EQ.'CO        ') ICO=I
              IF (SPEC(I).EQ.'H2        ') IH2=I
       ENDDO
    1   FORMAT(5X,A10,14(I3),2X,D14.8)

!       for the additional blank species
        SPEC(NS+1)='          '

!       read the parameters from the input_parameter.dat file
! 	if the number of physical points are larger than one, T and n are
!	read in another file

	if (nx.gt.1) then
       DO I=1,9
              READ (3,14) AA
       ENDDO
       READ(3,2) RANDMODE
       READ (3,14) AA
       READ (3,14) AA
       READ (3,14) AA
       READ(3,3) TIMESELEC
          endif

! 	if the number of physical points is one, T and n are
!	read in the input_parameter.dat file

	 if (nx.eq.1) then
	 DO I=1,9
              READ (3,14) AA
       ENDDO
       READ(3,2) RANDMODE
       READ(3,3) NHTOT(1)
       READ(3,3) TD(1)
       READ(3,3) TAU(1)
       READ(3,3) TIMESELEC
	endif
 14    FORMAT(A78)
 2   FORMAT(A1)
 3   FORMAT(D9.3)

!-----------------------------------------------------------------
!        READ THE TEMPERATURE, DENSITY AND VISUAL EXTINCTION IN AN
!       EXTERNAL FILE, current format of ratran code output
!       THIS HAS TO BE CHANGED ACCORDING TO YOUR CASE !!!!!

!       if (nx.gt.1) then
!       DO I=1,7
!              READ (8,14) AA
!       ENDDO
!       DO I=1,NX
!              READ (8,*) RADIUS(1,I),RADIUS(2,I),NHTOT(I),   &
!     &        TD(I),TAU(I)
!!              NHTOT(I)=2.D0*NH2TOT(I)
!       ENDDO
!  100     FORMAT(3X,3E13.6,13X,F7.3)
!	endif
!-----------------------------------------------------------------

!       compute the species densities from the initial abundances
!       SNGRAIN is the total abundance of grains
       DO I=1,NS
              DO JSPACE=1,NX
!                     IF (AB(I,JSPACE).EQ.0.D0) AB(I,JSPACE)=1.D-50
                     SN(I,JSPACE)=AB(I,JSPACE)*NHTOT(JSPACE)
                     PLOTAB(1,I,JSPACE)=AB(I,JSPACE)
              ENDDO
        ENDDO

!      COMPUTE THE TOTAL ABUNDANCE OF GRAINS
       SNGRAIN=SN(IGRAIN0,1)+SN(IGRAINN,1)

!        COMPUTE THE INITIAL ABUNDANCE OF ELECTRONS, THIS IS TO BE SURE
!	THAT WE HAVE NEUTRALITY

	DO JSPACE=1,NX
	   XELEC(JSPACE)=AB(IE,JSPACE)
	   AB(IE,JSPACE)=PLUS(JSPACE)
	ENDDO

        DO I=1,NS
	   DO JSPACE=1,NX
	      IF ((ELEMENT(1,I).EQ.-1).AND.(I.NE.IE)) AB(IE,JSPACE)=AB(IE,JSPACE)-AB(I,JSPACE)
           ENDDO
        ENDDO
        IF (AB(IE,1).NE.XELEC(1)) then

	WRITE(*,*) 'THE INITIAL ABUNDANCE OF ELECTRONS HAVE BEEN MODIFIED TO HAVE NEUTRALITY'
        write(*,*) 'previous electron abundance ', XELEC
        write(*,*) 'new electron abundance ', (ab(ie,jspace), jspace=1,nx)
	  endif

!        WE SET THE EXTERNAL CONDITIONS FOR THE H2 AND CO SELF-SHIELDING. POINT 1 OF
!	JSPACE HAS TO BE THE EXTERNAL POINT WHERE AV IS THE SMALLER ONE.
      XCO(1)=XCO_0
      XH2(1)=XH2_0

!       read the chemical database
       CALL READ_REACT(ELEMENT,A,B,C,REACTANT,         &
     &       SPEC,ITYPE,ZETA,GTODN,TAU,NCO,T_CO,NH2_1,      &
     &       T_H2_1,AV,T_AV,NH2_2,T_H2_2,Tmin,Tmax,NUMBER,FORMULA)

!
!       compute the rate coefficients
!
       CALL RATE_COEFF(A,B,C,GTODN,TAU,ZETA,TD,XH2,XCO,                 &
     &              NCO,T_CO,NH2_1,T_H2_1,AV,T_AV,NH2_2,T_H2_2, &
     &                   JSTEP,ITYPE,RANDMODE,REACTANT,SNGRAIN,Tmin,Tmax,NUMBER,FORMULA)

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!       compte the chemical evolution
!

!       definition of the times at which the rates of formation/destruct
!       are writen in verif.dat
       ITEST(1) = 2
       ITEST(2) = 11
       ITEST(3) = 34
       ITEST(4) = 56
       ITEST(5) = 79
       ITEST(6) = 101
       ITEST2=1

       DO ISP=1,NS
              DO JSPACE=1,NX
                     Y(ISP,JSPACE) = AB(ISP,JSPACE)
              ENDDO
       ENDDO

       TOUT=0.D0

       ISTATE=1

!       starting the loop

       WRITE (*,*) 'It is computing.... wait !'

       DO JSTEP=2,NTIME

!       TOUT is the output time of the dlsode subroutine and is set to b
!       time in sec from the table timeres
!       TYR is the time in year writen in the output file
       TOUT=TIMERES(JSTEP)*3.154D7
       TYR=TIMERES(JSTEP)

!       we transfer the values of the species densities into the
!       variable Y used by dlsode
       DO ISP=1,NS
              DO JSPACE=1,NX
                     Y(ISP,JSPACE) = AB(ISP,JSPACE)
!       defining atol
              ATOL(ISP,jspace)=1.D-30
                     if ((Y(ISP,JSPACE)*1.D-12).ge.1.D-24)              &
     &                     ATOL(ISP,jspace)=Y(ISP,JSPACE)*1.D-12
              ENDDO
       ENDDO

! Fancy "do while" loop

       do while (T.lt.TOUT)

!------------------------------------------------------------------
! Determine the Jacobian geometry

       IWORK(31:liw)=0

       call computeIAJA(IA,JA,liw,SPEC,Y)
       NNZ=IA(NEQ+1)-1
       iwork(30+1:30+NEQ+1)=IA(1:NEQ+1)
       iwork(31+NEQ+1:31+NEQ+NNZ)=JA(1:NNZ)

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

       ISTATE=1
!       we call the subroutine to solve the differential equations
       CALL DLSODES (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,       &
     &                ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JACFH, MF)

      enddo ! fancy while loop

       print *,'TIME = ',T/3.154d7, 'YR'

!       put the densities as abundances compared to total H
       DO JSPACE=1,NX
              DO ISP=1,NS
              IF (SN(ISP,JSPACE).LT.0.D0) SN(ISP,JSPACE)=0.D0
              SN(ISP,JSPACE) = Y(ISP,JSPACE)*NHTOT(JSPACE)
              AB(ISP,JSPACE) = Y(ISP,JSPACE)
              ENDDO

!       writing the abundances in the PLOTAB for the plot.dat file
              DO ISP=1,NS
                         PLOTAB(JSTEP,ISP,JSPACE)=AB(ISP,JSPACE)
              ENDDO
       ENDDO

!       write the verif.dat file, the output.dat file
       if (itest2.ne.7) then
          IF (JSTEP.EQ.ITEST(ITEST2)) THEN
              WRITE(*,*) 'T(YR)=',TYR
              WRITE(11,*) 'T(YR)=',TYR

              CALL CHECKING(ELEMENT,SN,IGRAIN0,IGRAINN)
              CALL COMP_RATES(SN,SPEC,NUMBER)
              ITEST2=ITEST2+1
          ENDIF
       endif

       IF (TYR.EQ.TIMESELEC) THEN
       WRITE(12,5) TIMESELEC,' +-  H  He C  O  S  G    '
    5   FORMAT(D8.2,A70)
       DO JSPACE=1,NX
       write(12,*) 'JSPACE = ',JSPACE
              DO I=1,NS
              WRITE(12,6) I,SPEC(I),(ELEMENT(ISP,I),ISP=1,NELEM),       &
     &              AB(I,JSPACE)
              ENDDO
       ENDDO
       ENDIF
    6   FORMAT (I4,1X,A10,14(I3),2X,D14.8)

!	HERE WE DEFINE THE ABUNDANCES OF CO AND H2 THAT WE HAVE IN FRONT OF
!	EACH POINT
        IF (NX.GT.1) THEN
	DO JSPACE=2,NX
       	      XCO(JSPACE)=XCO(JSPACE-1)+Y(ICO,JSPACE-1)
      	      XH2(JSPACE)=XH2(JSPACE-1)+Y(IH2,JSPACE-1)
	ENDDO
        ENDIF

!       re-compute the rate coefficients.
!       This is useful if one wants the temperature to evolve and
!       to compute the H2 and CO self-shielding which depend on the H2 a
        CALL RATE_COEFF(A,B,C,GTODN,TAU,ZETA,TD,XH2,XCO,                 &
     &              NCO,T_CO,NH2_1,T_H2_1,AV,T_AV,NH2_2,T_H2_2, &
     &                   JSTEP,ITYPE,RANDMODE,REACTANT,SNGRAIN,Tmin,Tmax,NUMBER,FORMULA)

       ENDDO

!       end of big loop

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!       write the plot.dat file for all times

       DO JSPACE=1,NX
              WRITE (10,*) 'Jspace = ',JSPACE
              WRITE (10,7) 'Gas temperature (K)', TD(JSPACE)
              WRITE (10,7) 'Total H density (cm-3)',NHTOT(JSPACE)
    7          FORMAT(A23,E10.2)
              WRITE(10,8) TIMERES
    8          FORMAT(10X,124(2X,D14.8))
              DO ISP=1,NS
              WRITE(10,9) SPEC(ISP),(PLOTAB(I,ISP,JSPACE),I=1,NTIME)
              ENDDO
    9          FORMAT(A10,124(2X,D14.8))
       ENDDO

       STOP
      END

!       end of main program
!ccccccccccccccccccccccccccccccccccccccccccccccccccccc

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!       this subroutine reads the reactions in the database

       SUBROUTINE READ_REACT(ELEMENT,A,B,C,REACTANT,   &
     &              SPEC,ITYPE,ZETA,GTODN,TAU,NCO,T_CO,NH2_1,&
     &              T_H2_1,AV,T_AV,NH2_2,T_H2_2,Tmin,Tmax,NUMBER,FORMULA)

       IMPLICIT NONE

       include 'header.f90'

       DOUBLE PRECISION A,B,C,ZETA,DTOGM,RD,RHOD,TAU,       &
     &              NCO,T_CO,NH2_1,T_H2_1,AV,T_AV,NH2_2,T_H2_2,GTODN,   &
     &          SUM1,SUM2,AMH,BOLTZ,PI,MOLE,Tmin, Tmax
       INTEGER ITYPE,ELEMENT,IR1,IR2,IR3, Tmini,Tmaxi,     &
     &              DES1,DES2,IPROD1,IPROD2,IPROD3,IPROD4,L,I,J, NUMBER, FORMULA

       CHARACTER REACTANT*10,PRODUIT*10,SPEC*10,AA*78
       DIMENSION ITYPE(NRTOT),A(NRTOT),B(NRTOT),C(NRTOT), TAU(NX),NCO(52),    &
     &           T_CO(52),NH2_1(43),T_H2_1(43),AV(43),T_AV(43),        &
     &           NH2_2(105),T_H2_2(105),ELEMENT(NELEM,NS+1),         &
     &           REACTANT(3,NRTOT),PRODUIT(4,NRTOT),SPEC(NS+1),Tmin(NRTOT),&
     &           Tmax(NRTOT),NUMBER(NRTOT), FORMULA(NRTOT)

       INTEGER REACT(NRTOT,7)
       DOUBLE PRECISION K(NRTOT,NX),NHTOT(NX),RADIUS(2,NX)
       COMMON/EQUA/K,NHTOT,RADIUS,REACT

       DATA AMH,BOLTZ,PI,MOLE                                           &
     &     /1.66043D-24, 1.38054D-16, 3.14159265, 6.023D23/

!       reading other parameters
       READ(3,10) ZETA
       READ(3,10) DTOGM
       READ(3,10) RD
       READ(3,10) RHOD

   10    FORMAT (D9.3)

!       reading the CO and H2 self-shielding parameters
       READ(7,14) AA
       DO J=1,43
              READ(7,12) NCO(J),T_CO(J),NH2_1(J),T_H2_1(J),AV(J),T_AV(J)
       ENDDO
       DO J=44,52
              READ(7,13) NCO(J),T_CO(J)
       ENDDO

       READ(7,15) AA
14       FORMAT(A52)
15       FORMAT(A17)

       DO J=1,105
             READ(7,13) NH2_2(J),T_H2_2(J)
       ENDDO
12       FORMAT (6(E9.3,3X))
13       FORMAT (E9.3,3X,E9.3)

!       reading the chemical database
       DO J=1,NRTOT
              READ (1,11) REACTANT(1,J),REACTANT(2,J),REACTANT(3,J),    &
     &         PRODUIT(1,J),PRODUIT(2,J),PRODUIT(3,J),PRODUIT(4,J),     &
     &          A(J),B(J),C(J), ITYPE(J),   Tmini,Tmaxi, FORMULA(J)  , NUMBER(J)

        Tmin(J)=real(Tmini)
        Tmax(J)=real(Tmaxi)

!       replace the species names by blanks for non chemical species
      		if ((REACTANT(1,J).eq.'CR        ').or.(REACTANT(1,J).eq.'CRP       ').or.&
     &		(REACTANT(1,J).eq.'Photon    ')) reactant(1,J)='          '
     		if ((REACTANT(2,J).eq.'CR        ').or.(REACTANT(2,J).eq.'CRP       ').or.&
     &		(REACTANT(2,J).eq.'Photon    ')) reactant(2,J)='          '
     		if ((REACTANT(3,J).eq.'CR        ').or.(REACTANT(3,J).eq.'CRP       ').or.&
     &		(REACTANT(3,J).eq.'Photon    ')) reactant(3,J)='          '
      		if ((Produit(1,J).eq.'CR        ').or.(PRODUIT(1,J).eq.'CRP       ').or.&
     &		(PRODUIT(1,J).eq.'Photon    ')) PRODUIT(1,J)='          '
      		if ((Produit(2,J).eq.'CR        ').or.(PRODUIT(2,J).eq.'CRP       ').or.&
     &		(PRODUIT(2,J).eq.'Photon    ')) PRODUIT(2,J)='          '
      		if ((Produit(3,J).eq.'CR        ').or.(PRODUIT(3,J).eq.'CRP       ').or.&
     &		(PRODUIT(3,J).eq.'Photon    ')) PRODUIT(3,J)='          '
      		if ((Produit(4,J).eq.'CR        ').or.(PRODUIT(4,J).eq.'CRP       ').or.&
     &		(PRODUIT(4,J).eq.'Photon    ')) PRODUIT(4,J)='          '

       ENDDO

  11    FORMAT (3(a10,1x),1x,4(a10,1x),11x,3(e11.3),24x,i2,2(i7),i3,I6)

!       GTODN is the ratio between the density of gas and the density of
       GTODN=(4.d0*PI*RHOD*RD*RD*RD)/(3.d0*DTOGM*AMH)
       write(*,*) GTODN

!       construct the table REACT which is used to construct the differe
        DO I=1,NRTOT
              DO J=1,NS+1
              DO L=1,3
              IF (REACTANT(L,I).EQ.SPEC(J)) REACT(I,L)=J
              ENDDO
              DO L=1,4
              IF (PRODUIT(L,I).EQ.SPEC(J)) REACT(I,L+3)=J
              ENDDO
              ENDDO
       ENDDO

!       check the balance of the reactions (elements and charges)
      DO I=1,NRTOT
              IR1=REACT(I,1)
              IR2=REACT(I,2)
              IR3=REACT(I,3)
              IPROD1=REACT(I,4)
              IPROD2=REACT(I,5)
              IPROD3=REACT(I,6)
              IPROD4=REACT(I,7)
              DO J=1,NELEM
              SUM1=ELEMENT(J,IR1)+ELEMENT(J,IR2)+ELEMENT(J,IR3)
              SUM2=ELEMENT(J,IPROD1)+ELEMENT(J,IPROD2)+                 &
     &                     ELEMENT(J,IPROD3)+ELEMENT(J,IPROD4)
                   IF (SUM1.NE.SUM2)                                    &
     &              WRITE(*,*) 'BALANCE PROBLEM AT THE REACTION',I
              ENDDO

       ENDDO

!       check for the reactions that are present more than once in the network

       RETURN
      END
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!       this subroutine computes the rate coefficients of the reactions
!
!       the formula to compute the rates depends on the type of reaction

!       if you add a new kind of reaction, you have to add here the way
!       to compute the rate coefficient

       SUBROUTINE RATE_COEFF(A,B,C,GTODN,TAU,ZETA,TD,XH2,XCO,           &
     &              NCO,T_CO,NH2_1,T_H2_1,AV,T_AV,NH2_2,T_H2_2, &
     &                   JSTEP,ITYPE,RANDMODE,REACTANT,SNGRAIN,Tmin,Tmax,NUMBER,FORMULA)

       IMPLICIT NONE

       INCLUDE 'header.f90'

       DOUBLE PRECISION MOLE,GTODN,                                     &
     &         PI,AMH,BOLTZ,TT,TD,ZETA,A,B,C,TAU,ALPHA,          &
     &         NCO,T_CO,NH2_1,T_H2_1,AV,T_AV,NH2_2,T_H2_2,         &
     &         SNGRAIN,NCOLLH2,XH2,XCO,TETA,NCOLLCO,TETA1,TETA2,TETA3
        DOUBLE PRECISION U,V,CHD,MG,RD,RHOD,EV,MU0,DS,TCOLL,SIGD ,Tmin,Tmax
        real(kind=8), dimension(10) :: distmin, distmax

       INTEGER ITYPE,L,M,N,W,JSTEP,I,J,ISP,JSPACE,NUMBER,INDICE ,FORMULA
       CHARACTER REACTANT*10,RANDMODE,AA*78
       DIMENSION ITYPE(NRTOT),A(NRTOT),B(NRTOT),C(NRTOT), TAU(NX),      &
     &              REACTANT(3,NRTOT),ALPHA(NRTOT),Tmin(NRTOT),Tmax(NRTOT), &
     &              NCO(52),T_CO(52),NH2_1(43),T_H2_1(43),AV(43),T_AV(43),&
     &              NH2_2(105),T_H2_2(105),TD(NX),TT(NX),XCO(NX),XH2(NX),  &
     &              INDICE(10),NUMBER(NRTOT),FORMULA(NRTOT)

       INTEGER REACT(NRTOT,7)
       DOUBLE PRECISION K(NRTOT,NX),NHTOT(NX),RADIUS(2,NX)
       COMMON/EQUA/K,NHTOT,RADIUS,REACT

       DATA AMH,BOLTZ,PI,MOLE                                        &
     &     /1.66043D-24, 1.38054D-16, 3.14159265, 6.023D23/

!      READ THE ALPHAS IF RANDMODE EQ 'Y'

       IF (RANDMODE.EQ.'Y') THEN
          OPEN (UNIT=5,FILE='alpha',STATUS='OLD')
	  DO J=1,NRTOT
	  	READ(5,*) ALPHA(J)
!		REPLACE THE A VALUES BY THE ONES COMPUTED BY THE
!    		MONTE CARLOT SIMULATION
		A(J)=ALPHA(J)
	  ENDDO
	  close(unit=5)
       ENDIF

       DO JSPACE=1,NX
              TT(JSPACE)=TD(JSPACE)/300.D0
       ENDDO

       DO JSPACE=1,NX

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!	reactions for kida networks
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 	W=1
	N=0
	INDICE(:)=0

!       start computing the rate coefficients depending on the formula
       DO J=1,NRTOT

!	REACTIONS WITH GRAINS

         IF (FORMULA(J).EQ.0) THEN
              K(J,jspace)=A(J)*(TT(jspace)**B(J))
         ENDIF

          IF  	(FORMULA(J).EQ.10) K(J,jspace)=A(J)*1.186D7*exp(225.D0/TD(jspace))**(-1)*GTODN/NHTOT(jspace)
          IF  	(FORMULA(J).EQ.11) K(J,jspace)=A(J)*(TT(jspace)**B(J))*NHTOT(jspace)/GTODN

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!	REACTIONS WITH COSMIC-RAYS

	   IF (FORMULA(J).EQ.1) K(J,jspace)=A(J)*ZETA

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!	PHOTOREACTIONS

	   IF (FORMULA(J).EQ.2) THEN
	       K(J,jspace)=A(J)*EXP(-C(J)*TAU(jspace))

!             computation of the H2 and CO self-shielding by linear extrapola

              IF (REACTANT(1,J).EQ.'H2        ') THEN
                  NCOLLH2=(TAU(jspace)/5.34D-22)*XH2(JSPACE)
                  TETA=1
                  DO L=1,104
                     IF ((NH2_2(L).LE.NCOLLH2).AND.(NH2_2(L+1).GE.NCOLLH2))         &
     &                            TETA=T_H2_2(L)+(NCOLLH2-NH2_2(L))*                &
     &                            (T_H2_2(L+1)-T_H2_2(L))/(NH2_2(L+1)-NH2_2(L))
                  ENDDO

!                     IF (NCOLLH2.GT.NH2_2(105)) K(J,JSPACE)=A(J)*EXP(-C(J)*TAU(jspace))
!
!     VW Sept 08, we change the way the photodissociation is computed when the H2
!     column density exceeds the largest value in Self-Shielding_data file, we use the smallest value of teta.
!     If H2 column density is smaller
!     than the smallest value in the file, we use a photorate of 2.54e-11 (teta=1).

                  IF (NCOLLH2.GT.NH2_2(105)) TETA=T_H2_2(105)

		  K(J,JSPACE)=2.54D-11*TETA

			write(13,*)  NCOLLH2, K(J,JSPACE)

              ENDIF

                  IF (REACTANT(1,J).EQ.'CO        ') THEN
                     NCOLLH2=(TAU(jspace)/5.34D-22)*XH2(JSPACE)
                     NCOLLCO=(TAU(jspace)/5.34D-22)*XCO(JSPACE)
                     TETA1=1
                     TETA2=1
                     TETA3=1
                     DO L=1,51
                            IF ((NCO(L).LE.NCOLLCO).AND.(NCO(L+1).GE.NCOLLH2))             &
     &                            TETA2=T_CO(L)+(NCOLLCO-NCO(L))*(T_CO(L+1)-T_CO(L))        &
     &                            /(NCO(L+1)-NCO(L))
                     ENDDO
                     DO L=1,42
                            IF ((NH2_1(L).LE.NCOLLH2).AND.(NH2_1(L+1).GE.NCOLLH2))             &
     &                            TETA1=T_H2_1(L)+(NCOLLH2-NH2_1(L))*(T_H2_1(L+1)-T_H2_1(L))   &
     &                            /(NH2_1(L+1)-NH2_1(L))
                            IF ((AV(L).LE.TAU(jspace)).AND.(AV(L+1).GE.TAU(jspace)))                &
     &                            TETA3=T_AV(L)+(TAU(jspace)-AV(L))*(T_AV(L+1)-T_AV(L))     &
     &                            /(AV(L+1)-AV(L))
                     ENDDO

!     VW Sept 08, we change the way the photodissociation is computed when the H2 and/or CO
!     column density and tau exceeds the largest value in Self-Shielding_data file, we use the smallest values of tetas.
!     If H2 column density is smaller
!     than the smallest value in the file, we use a photorate of 2.54e-11 (teta=1).

                     IF (NCOLLH2.GT.NH2_1(43)) TETA1=T_H2_1(43)

                     IF (NCOLLCO.GT.NCO(52)) TETA2=T_CO(52)

                     IF (TAU(jspace).GT.AV(43)) TETA3=T_AV(43)

		     K(J,JSPACE)=1.03D-10*TETA1*TETA2*TETA3

                      write(14,*)  NCOLLH2, NCOLLCO, K(J,JSPACE)

                   ENDIF
          ENDIF

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!	KOOIJ FORMULA

	IF (FORMULA(J).EQ.3) 	then
     	       K(J,jspace)=A(J)*(TT(jspace)**B(J))*EXP(-C(J)/TD(jspace))

!                  Check for temperature bounderies !!! Temperatures outside the T range are not extrapolated
		if (TD(jspace).LT.Tmin(J)) K(J,jspace)=A(J)*((Tmin(J)/300.D0)**B(J))*EXP(-C(J)/Tmin(J))
		if (TD(jspace).GT.Tmax(J)) K(J,jspace)=A(J)*((Tmax(J)/300.D0)**B(J))*EXP(-C(J)/Tmax(J))

!                  Check for the presence of several rate coefficients present in the network for the
!                  the same reaction
                IF (NUMBER(J+1).EQ.NUMBER(J)) THEN
			INDICE(W)=J
			W=W+1
			distmin(w)=tmin(j)-TD(jspace)
              		distmax(w)=TD(jspace)-tmax(j)
         		if (jstep.eq.0) write(*,*) 'Reaction ',NUMBER(J),' is present more than once in the network'
         	ENDIF

         	IF ((NUMBER(J+1).NE.NUMBER(J)).AND.(W.NE.1)) THEN
              		INDICE(W)=J
              		distmin(w)=tmin(j)-TD(jspace)
              		distmax(w)=TD(jspace)-tmax(j)

              		DO M=1,W
                		N=INDICE(M)
                		IF (TD(jspace).LT.Tmin(N)) K(N,jspace)=0.d0
                		IF (TD(jspace).GT.Tmax(N)) K(N,jspace)=0.d0
              		ENDDO

              		if (maxval(K(indice(1:w),jspace)).lt.1.d-99) then
              			if (minval(abs(distmin)).lt.minval(abs(distmax))) then
              				N=indice(minloc(abs(distmin),dim=1))
              				K(N,jspace)=A(N)*((Tmin(N)/300.D0)**B(N))*EXP(-C(N)/Tmin(N))
              			else
              				N=indice(minloc(abs(distmax),dim=1))
              				K(N,jspace)=A(N)*((Tmax(N)/300.D0)**B(N))*EXP(-C(N)/Tmax(N))
              			endif
              		endif

              		W=1
              		INDICE(:)=0
              		distmin(:)=9999.
              		distmax(:)=9999.
         	ENDIF
         endif

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!	IONPOL1 and IONPOL2 FORMULA

 	IF ((FORMULA(J).EQ.4).OR.(FORMULA(J).EQ.5))	then
     	        if (FORMULA(J).EQ.4)   K(J,jspace)=A(J)*B(J)*(0.62d0+0.4767d0*C(J)*((300.D0/TD(JSPACE))**0.5))
		if (FORMULA(J).EQ.5)   K(J,jspace)=A(J)*B(J)*((1.d0+0.0967*C(J)*(300.D0/TD(JSPACE))**0.5)+(C(J)**2*300.d0/(10.526*TD(JSPACE))))

!                  Check for temperature bounderies
		if ((TD(jspace).LT.Tmin(J)).AND.(FORMULA(J).EQ.4)) K(J,jspace)=A(J)*B(J)*(0.62d0+0.4767d0*C(J)*((300.D0/Tmin(J))**0.5))
		if ((TD(jspace).GT.Tmax(J)).AND.(FORMULA(J).EQ.4)) K(J,jspace)=A(J)*B(J)*(0.62d0+0.4767d0*C(J)*((300.D0/TMAX(J))**0.5))
		if ((TD(jspace).LT.Tmin(J)).AND.(FORMULA(J).EQ.5)) &
     &	K(J,jspace)=A(J)*B(J)*((1.d0+0.0967*C(J)*(300.D0/TMIN(J))**0.5)+(C(J)**2*300.d0/(10.526*TMIN(J))))
		if ((TD(jspace).GT.Tmax(J)).AND.(FORMULA(J).EQ.5)) &
     &	K(J,jspace)=A(J)*B(J)*((1.d0+0.0967*C(J)*(300.D0/TMAX(J))**0.5)+(C(J)**2*300.d0/(10.526*TMAX(J))))

!                  Check for the presence of several rate coefficients present in the network for the
!                  the same reaction
                IF (NUMBER(J+1).EQ.NUMBER(J)) THEN
               			INDICE(W)=J
               			distmin(w)=tmin(j)-TD(jspace)
               			distmax(w)=TD(jspace)-tmax(j)
               			W=W+1
               			if (jstep.eq.0) write(*,*) 'Reaction ',NUMBER(J),' is present more than once in the network'
             	ENDIF
             	IF ((NUMBER(J+1).NE.NUMBER(J)).AND.(W.NE.1)) THEN
               		INDICE(W)=J
               		distmin(w)=tmin(j)-TD(jspace)
               		distmax(w)=TD(jspace)-tmax(j)

               		DO M=1,W
               			N=INDICE(M)
               			IF (TD(jspace).LT.Tmin(N)) K(N,jspace)=       0.d0
               			IF (TD(jspace).GT.Tmax(N)) K(N,jspace)=       0.d0
               		ENDDO

               		if (maxval(K(indice(1:w),jspace)).lt.1.d-99) then
               			if (minval(abs(distmin)).lt.minval(abs(distmax))) then
               				N=indice(minloc(abs(distmin),dim=1))
					if (FORMULA(N).EQ.4)   K(N,jspace)=A(N)*B(N)*(0.62d0+0.4767d0*C(N)*((300.D0/Tmin(N))**0.5))
					if (FORMULA(N).EQ.5)   &
     &					K(N,jspace)=A(N)*B(N)*((1.d0+0.0967*C(N)*(300.D0/TMIN(N))**0.5)+(C(N)**2*300.d0/(10.526*TMIN(N))))
               			else
               				N=indice(minloc(abs(distmax),dim=1))
               				if (FORMULA(N).EQ.4)   K(N,jspace)=A(N)*B(N)*(0.62d0+0.4767d0*C(N)*((300.D0/TMAX(N))**0.5))
					if (FORMULA(N).EQ.5)   &
     &					K(N,jspace)=A(N)*B(N)*((1.d0+0.0967*C(N)*(300.D0/TMAX(N))**0.5)+(C(N)**2*300.d0/(10.526*TMAX(N))))
               			endif
               		endif

              		W=1
              		INDICE(:)=0
               		distmin(:)=9999.
               		distmax(:)=9999.
             	ENDIF

         ENDIF

        enddo
!       remove the very small rate coefficients
       DO J=1,NRTOT
              IF (K(J,JSPACE).LT.1.D-50) K(J,JSPACE)=0.D0
       ENDDO

!       writing the rate coefficients in the Kout.dat file
       IF (JSTEP.EQ.0) THEN
              WRITE (9,*) 'Rate coefficients of the reactions'
              WRITE (9,*) 'Tk =    ',TD(JSPACE)
              DO J=1,NRTOT
                        WRITE (9,*) NUMBER(J), K(J,JSPACE)
              ENDDO
       ENDIF
       enddo

       RETURN
      END

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!       this subroutine contains the differential equations
!
       SUBROUTINE F (NEQ, T, Y, YDOT)

       IMPLICIT NONE

       include 'header.f90'

       INTEGER NEQ,jspace

       INTEGER IR1,IR2,IR3,DES1,DES2,IPROD1,IPROD2,IPROD3,IPROD4,I,J

       DOUBLE PRECISION Y, YDOT, UP, DOWN, RATE,T,DY,DD,NHTOT2,      &
     &              RADIUS2
       DIMENSION Y(NS,NX), YDOT(NS,NX), UP(NS,NX), DOWN(NS,NX),DD(NX),  &
     &              NHTOT2(NX),RADIUS2(NX),DY(NX)

       INTEGER REACT(NRTOT,7)
       DOUBLE PRECISION K(NRTOT,NX),NHTOT(NX), RADIUS(2,NX)
       COMMON/EQUA/K,NHTOT,RADIUS,REACT

       DO JSPACE=1,NX
              DO I=1,NS
                     UP(I,JSPACE)=0.d0
                     DOWN(I,JSPACE)=0.d0
              ENDDO
       ENDDO

!       the differential equations are calcultaed in a loop here
       DO I=1,NRTOT
              IR1=REACT(I,1)
              IR2=REACT(I,2)
              IR3=REACT(I,3)
              IPROD1=REACT(I,4)
              IPROD2=REACT(I,5)
              IPROD3=REACT(I,6)
              IPROD4=REACT(I,7)

              DO JSPACE=1,NX
                      IF (IR3.NE.NS+1) THEN
                      RATE=K(I,JSPACE)*Y(IR1,JSPACE)*Y(IR2,JSPACE)      &
     &                   *Y(IR3,JSPACE)*NHTOT(JSPACE)*NHTOT(JSPACE)

                     IF (IPROD1.NE.NS+1) UP(IPROD1,JSPACE)=UP(IPROD1,JSPACE)+RATE
                     IF (IPROD2.NE.NS+1) UP(IPROD2,JSPACE)=UP(IPROD2,JSPACE)+RATE
                     IF (IPROD3.NE.NS+1) UP(IPROD3,JSPACE)=UP(IPROD3,JSPACE)+RATE
                     IF (IPROD4.NE.NS+1) UP(IPROD4,JSPACE)=UP(IPROD4,JSPACE)+RATE

                      DOWN(IR1,JSPACE)=DOWN(IR1,JSPACE)+RATE
                      DOWN(IR2,JSPACE)=DOWN(IR2,JSPACE)+RATE
                      DOWN(IR3,JSPACE)=DOWN(IR3,JSPACE)+RATE

                     ENDIF

                      IF ((IR3.EQ.NS+1).AND.(IR2.NE.NS+1)) THEN
                      RATE=K(I,JSPACE)*Y(IR1,JSPACE)*Y(IR2,JSPACE)* &
     &                NHTOT(JSPACE)

                     IF (IPROD1.NE.NS+1) UP(IPROD1,JSPACE)=UP(IPROD1,JSPACE)+RATE
                     IF (IPROD2.NE.NS+1) UP(IPROD2,JSPACE)=UP(IPROD2,JSPACE)+RATE
                     IF (IPROD3.NE.NS+1) UP(IPROD3,JSPACE)=UP(IPROD3,JSPACE)+RATE
                     IF (IPROD4.NE.NS+1) UP(IPROD4,JSPACE)=UP(IPROD4,JSPACE)+RATE

                      DOWN(IR1,JSPACE)=DOWN(IR1,JSPACE)+RATE
                      DOWN(IR2,JSPACE)=DOWN(IR2,JSPACE)+RATE

                     ENDIF

                      IF (IR2.EQ.NS+1) THEN
                            RATE=K(I,JSPACE)*Y(IR1,JSPACE)

                     IF (IPROD1.NE.NS+1) UP(IPROD1,JSPACE)=UP(IPROD1,JSPACE)+RATE
                     IF (IPROD2.NE.NS+1) UP(IPROD2,JSPACE)=UP(IPROD2,JSPACE)+RATE
                     IF (IPROD3.NE.NS+1) UP(IPROD3,JSPACE)=UP(IPROD3,JSPACE)+RATE
                     IF (IPROD4.NE.NS+1) UP(IPROD4,JSPACE)=UP(IPROD4,JSPACE)+RATE

                      DOWN(IR1,JSPACE)=DOWN(IR1,JSPACE)+RATE

                     ENDIF

              ENDDO

       ENDDO

	do I=1,ns
		DO JSPACE=1,NX
			YDOT(I,JSPACE)=(UP(I,JSPACE)-DOWN(I,JSPACE))
		ENDDO
	enddo

       RETURN
      END

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!       this subroutine computes the rates of formation and destruction
!       for each species and put them in the increasing order

       SUBROUTINE COMP_RATES (Y,SPEC,NUMBER)

       IMPLICIT NONE

       INCLUDE 'header.f90'

       INTEGER J,IR1,IR2,IR3,IPROD1,IPROD2,IPROD3,                      &
     &               IPROD4,IY,M,I,JSPACE,NUMBER
       DOUBLE PRECISION Y,FORMTOT,DESTOT,RATE,X,FORM,DEST
       DIMENSION Y(NS,NX),FORMTOT(NS),DESTOT(NS),FORM(NS,NRTOT),        &
     &              DEST(NS,NRTOT),IY(NRTOT),X(NRTOT),NUMBER(NRTOT)
       CHARACTER*10 SPEC(NS+1)

       INTEGER REACT(NRTOT,7)
       DOUBLE PRECISION K(NRTOT,NX),NHTOT(NX),RADIUS(2,NX)
       COMMON/EQUA/K,NHTOT,RADIUS,REACT

       DO JSPACE=1,NX

       DO J=1,NS
              FORMTOT(J)=0.D0
              DESTOT(J)=0.D0
       ENDDO

       DO I=1,NRTOT

              IR1=REACT(I,1)
              IR2=REACT(I,2)
              IR3=REACT(I,3)
              IPROD1=REACT(I,4)
              IPROD2=REACT(I,5)
              IPROD3=REACT(I,6)
              IPROD4=REACT(I,7)

               IF (IR3.NE.NS+1) RATE=K(I,JSPACE)*Y(IR1,JSPACE)*         &
     &              Y(IR2,JSPACE)*Y(IR3,JSPACE)

               IF ((IR3.EQ.NS+1).AND.(IR2.NE.NS+1))        &
     &              RATE=K(I,JSPACE)*Y(IR1,JSPACE)*Y(IR2,JSPACE)

               IF (IR2.EQ.NS+1) RATE=K(I,JSPACE)*Y(IR1,JSPACE)

              IF (IPROD1.NE.NS+1) FORM(IPROD1,I)=RATE
              IF (IPROD2.NE.NS+1) FORM(IPROD2,I)=RATE
              IF (IPROD3.NE.NS+1) FORM(IPROD3,I)=RATE
              IF (IPROD4.NE.NS+1) FORM(IPROD4,I)=RATE
              IF (IR1.NE.NS+1) DEST(IR1,I)=RATE
              IF (IR2.NE.NS+1) DEST(IR2,I)=RATE
              IF (IR3.NE.NS+1) DEST(IR3,I)=RATE

              IF (IPROD1.NE.NS+1) FORMTOT(IPROD1)=FORMTOT(IPROD1)+RATE
              IF (IPROD2.NE.NS+1) FORMTOT(IPROD2)=FORMTOT(IPROD2)+RATE
              IF (IPROD3.NE.NS+1) FORMTOT(IPROD3)=FORMTOT(IPROD3)+RATE
              IF (IPROD4.NE.NS+1) FORMTOT(IPROD4)=FORMTOT(IPROD4)+RATE
              IF (IR1.NE.NS+1) DESTOT(IR1)=DESTOT(IR1)+RATE
              IF (IR2.NE.NS+1) DESTOT(IR2)=DESTOT(IR2)+RATE
              IF (IR3.NE.NS+1) DESTOT(IR3)=DESTOT(IR3)+RATE

       ENDDO

!       put FORM and DEST in the increasing order
       DO M=1,NS
       DO I=1,NRTOT
              X(I)=FORM(M,I)
              IY(I)=NUMBER(I)
       ENDDO

       CALL SSORT (X, IY, NRTOT)

       WRITE (11,*) SPEC(M)
       WRITE (11,*) 'REACTIONS OF PRODUTION    Total flux (cm-3s-1) =',FORMTOT(M)
       DO I=1,5
              IF (X(I).NE.0D0) WRITE(11,*)  IY(I), X(I)
       ENDDO

       DO I=1,NRTOT
              X(I)=DEST(M,I)
              IY(I)=NUMBER(I)
       ENDDO

       CALL SSORT (X, IY, NRTOT)

       WRITE (11,*) 'REACTIONS OF DESTRUCTION    Total flux (cm-3s-1) =',DESTOT(M)
       DO I=1,5
              IF (X(I).NE.0D0) WRITE(11,*)  IY(I), -X(I)
       ENDDO

       ENDDO

       ENDDO

       RETURN
      END

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!       this subroutine checks that the densities of charged species
!       and elements are conservative

       SUBROUTINE CHECKING (ELEMENT,SN,IGRAIN0,IGRAINN)

       IMPLICIT NONE

       include 'header.f90'

       INTEGER ELEMENT,I,J,IGRAIN0,IGRAINN,jspace
       DOUBLE PRECISION SN,PLUS,MINUS,DPM,CHECK_ELEM
       DIMENSION SN(NS,NX),ELEMENT(NELEM,NS+1),                           &
     &              CHECK_ELEM(NELEM-1)

       PLUS=0.D0
       MINUS=0.D0

       DO JSPACE=1,NX
       WRITE(*,*) 'jspace ',JSPACE

       DO I=1,NELEM-1
              CHECK_ELEM(I)=0.D0
       ENDDO

       DO I=1,NS
              IF (ELEMENT(1,I).EQ.1) PLUS=PLUS+SN(I,JSPACE)
              IF (ELEMENT(1,I).EQ.-1) MINUS=MINUS+SN(I,JSPACE)
       ENDDO

       DPM=(PLUS-MINUS)/PLUS

       WRITE (*,*) '(positive) - (negative)/(positive)',DPM
       WRITE (*,*) 'grains',SN(IGRAIN0,JSPACE)+SN(IGRAINN,JSPACE)
       DO I=1,NELEM-1
              DO J=1,NS
                     CHECK_ELEM(I)=CHECK_ELEM(I)+                       &
     &                     FLOAT(ELEMENT(I+1,J))*SN(J,JSPACE)
              ENDDO
       ENDDO

       WRITE(11,*) '( H  He C  N  O  SI S  FE NA MG CL P F)'
       WRITE(11,*) CHECK_ELEM
       WRITE(*,*) '( H  He C  N  O  SI S  FE NA MG CL P F)'
       WRITE(*,*) CHECK_ELEM
       enddo

       RETURN
      END

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!       dummy subroutine
!       this subroutine is needed because we are not supplying
!       the jacobian matrix
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       SUBROUTINE DUMMY
       IMPLICIT NONE
       INTEGER N,J
       DOUBLE PRECISION T,Y,IAN,JAN,PDJ

       ENTRY JAC (N, T, Y, J, IAN, JAN, PDJ)

       RETURN
      END

!       SUBROUTINE DUMMY

!       ENTRY JAC (NEQ, T, Y, ML, MU, PD, NROWPD)

!       RETURN
!       END

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!       subroutine to sort the numbers

      SUBROUTINE SSORT (X, IY, N)
      IMPLICIT NONE

!
!    Example of an Insertion Sort
!
!***BEGIN PROLOGUE  SSORT
!***PURPOSE  Sort an array and make the same interchanges in
!            an auxiliary array.  The array is sorted in
!            decreasing order.
!***TYPE      SINGLE PRECISION
!***KEYWORDS  SORT, SORTING
!
!   Description of Parameters
!      X - array of values to be sorted   (usually abscissas)
!      IY - array to be carried with X (all swaps of X elements are
!          matched in IY .  After the sort IY(J) contains the original
!          postition of the value X(J) in the unsorted X array.
!      N - number of values in array X to be sorted
!      KFLAG - Not used in this implementation
!
!***REVISION HISTORY  (YYMMDD)
!   950310  DATE WRITTEN
!   John Mahaffy
!***END PROLOGUE  SSORT
!     .. Scalar Arguments ..
      INTEGER N
!     .. Array Arguments ..
      DOUBLE PRECISION X(*)
      INTEGER IY(*)
!     .. Local Scalars ..
      DOUBLE PRECISION TEMP
      INTEGER I, J, L, ITEMP
!     .. External Subroutines ..
!     None
!     .. Intrinsic Functions ..
!     None
!
!***FIRST EXECUTABLE STATEMENT  SSORT
!
      DO 100 I=2,N
         IF ( X(I).GT.X(I-1) ) THEN
            DO 50 J=I-2,1,-1
              IF(X(I).LT.X(J)) go to 70
   50         CONTINUE
            J=0
   70       TEMP=X(I)
            ITEMP=IY(I)
            DO 90 L=I,J+2,-1
              IY(L)=IY(L-1)
   90         X(L)=X(L-1)
            X(J+1)=TEMP
            IY(J+1)=ITEMP
         ENDIF
  100 END DO
      RETURN
      END

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       SUBROUTINE JACFH(NEQ,T,Y, ZJ,IAN,JAN, PDJ)

       IMPLICIT NONE

       include 'header.f90'

       INTEGER NEQ,jspace

       INTEGER IR1,IR2,IR3,DES1,DES2,IPROD1,IPROD2,IPROD3,IPROD4,I,J, ZJ,ipdj,jpdj

       DOUBLE PRECISION Y, YDOT, UP, DOWN, RATE,T,DD,nu2
       DIMENSION Y(NS,NX), YDOT(NS,NX), UP(NS,NX), DOWN(NS,NX),DD(NX)
       real(kind=8),dimension(ns,nx) :: PDJ
       real(kind=8), dimension(nx) :: DY, radius2
       real(kind=8), dimension(2,nx) :: radius
       REAL(KIND=8), dimension(NEQ) :: IAN, JAN

       real(kind=8), dimension(1:nx) :: ajac, bjac, cjac

       INTEGER REACT(NRTOT,7)
       DOUBLE PRECISION K(NRTOT,NX),NHTOT(NX)
       COMMON/EQUA/K,NHTOT,radius, REACT

! Find the relevant i and j corresponding to zj

       ipdj=mod(zj,ns)
       jpdj=int(zj/ns)+1
       if (ipdj.eq.0) then
       ipdj=ns
       jpdj=jpdj-1
       endif

! Initialize PDJ

       PDJ=0.d0

! Flee if ipdj=NS
!       if (ipdj.eq.NS) return

       UP=0.d0
       DOWN=0.d0

!       the differential equations are calcultaed in a loop here
       DO I=1,NRTOT
              IR1=REACT(I,1)
              IR2=REACT(I,2)
              IR3=REACT(I,3)
              IPROD1=REACT(I,4)
              IPROD2=REACT(I,5)
              IPROD3=REACT(I,6)
              IPROD4=REACT(I,7)

                if (IR3.ne.NS+1) then
!                RATE=K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR2,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)

       if (IR1.eq.IPDJ) then
       IF (IPROD1.NE.NS+1) PDJ(IPROD1,jpdj)=PDJ(IPROD1,jpdj)+K(I,JPDJ)*Y(IR2,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       IF (IPROD2.NE.NS+1) PDJ(IPROD2,jpdj)=PDJ(IPROD2,jpdj)+K(I,JPDJ)*Y(IR2,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       IF (IPROD3.NE.NS+1) PDJ(IPROD3,jpdj)=PDJ(IPROD3,jpdj)+K(I,JPDJ)*Y(IR2,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       IF (IPROD4.NE.NS+1) PDJ(IPROD4,jpdj)=PDJ(IPROD4,jpdj)+K(I,JPDJ)*Y(IR2,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       PDJ(IR1,jpdj)=PDJ(IR1,jpdj)-K(I,JPDJ)*Y(IR2,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       PDJ(IR2,jpdj)=PDJ(IR2,jpdj)-K(I,JPDJ)*Y(IR2,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       PDJ(IR3,jpdj)=PDJ(IR3,jpdj)-K(I,JPDJ)*Y(IR2,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       endif

       if (IR2.eq.IPDJ) then
       IF (IPROD1.NE.NS+1) PDJ(IPROD1,jpdj)=PDJ(IPROD1,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       IF (IPROD2.NE.NS+1) PDJ(IPROD2,jpdj)=PDJ(IPROD2,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       IF (IPROD3.NE.NS+1) PDJ(IPROD3,jpdj)=PDJ(IPROD3,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       IF (IPROD4.NE.NS+1) PDJ(IPROD4,jpdj)=PDJ(IPROD4,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       PDJ(IR1,jpdj)=PDJ(IR1,jpdj)-K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       PDJ(IR2,jpdj)=PDJ(IR2,jpdj)-K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       PDJ(IR3,jpdj)=PDJ(IR3,jpdj)-K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR3,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       endif

       if (IR3.eq.IPDJ) then
       IF (IPROD1.NE.NS+1) PDJ(IPROD1,jpdj)=PDJ(IPROD1,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       IF (IPROD2.NE.NS+1) PDJ(IPROD2,jpdj)=PDJ(IPROD2,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       IF (IPROD3.NE.NS+1) PDJ(IPROD3,jpdj)=PDJ(IPROD3,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       IF (IPROD4.NE.NS+1) PDJ(IPROD4,jpdj)=PDJ(IPROD4,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       PDJ(IR1,jpdj)=PDJ(IR1,jpdj)-K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       PDJ(IR2,jpdj)=PDJ(IR2,jpdj)-K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       PDJ(IR3,jpdj)=PDJ(IR3,jpdj)-K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)*NHTOT(JPDJ)
       endif

                endif
                if ((IR3.eq.NS+1).and.(IR2.ne.NS+1)) then
!                RATE=K(I,JPDJ)*Y(IR1,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)

       if (IR1.eq.IPDJ) then
       IF (IPROD1.NE.NS+1) PDJ(IPROD1,jpdj)=PDJ(IPROD1,jpdj)+K(I,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)
       IF (IPROD2.NE.NS+1) PDJ(IPROD2,jpdj)=PDJ(IPROD2,jpdj)+K(I,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)
       IF (IPROD3.NE.NS+1) PDJ(IPROD3,jpdj)=PDJ(IPROD3,jpdj)+K(I,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)
       IF (IPROD4.NE.NS+1) PDJ(IPROD4,jpdj)=PDJ(IPROD4,jpdj)+K(I,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)
       PDJ(IR1,jpdj)=PDJ(IR1,jpdj)-K(I,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)
       PDJ(IR2,jpdj)=PDJ(IR2,jpdj)-K(I,JPDJ)*Y(IR2,JPDJ)*NHTOT(JPDJ)
       endif

       if (IR2.eq.IPDJ) then
       IF (IPROD1.NE.NS+1) PDJ(IPROD1,jpdj)=PDJ(IPROD1,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*NHTOT(JPDJ)
       IF (IPROD2.NE.NS+1) PDJ(IPROD2,jpdj)=PDJ(IPROD2,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*NHTOT(JPDJ)
       IF (IPROD3.NE.NS+1) PDJ(IPROD3,jpdj)=PDJ(IPROD3,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*NHTOT(JPDJ)
       IF (IPROD4.NE.NS+1) PDJ(IPROD4,jpdj)=PDJ(IPROD4,jpdj)+K(I,JPDJ)*Y(IR1,JPDJ)*NHTOT(JPDJ)
       PDJ(IR1,jpdj)=PDJ(IR1,jpdj)-K(I,JPDJ)*Y(IR1,JPDJ)*NHTOT(JPDJ)
       PDJ(IR2,jpdj)=PDJ(IR2,jpdj)-K(I,JPDJ)*Y(IR1,JPDJ)*NHTOT(JPDJ)
       endif

       endif

       if (IR2.eq.NS+1) then

       if (IR1.eq.IPDJ) then
       IF (IPROD1.NE.NS+1) PDJ(IPROD1,jpdj)=PDJ(IPROD1,jpdj)+K(I,JPDJ)
       IF (IPROD2.NE.NS+1) PDJ(IPROD2,jpdj)=PDJ(IPROD2,jpdj)+K(I,JPDJ)
       IF (IPROD3.NE.NS+1) PDJ(IPROD3,jpdj)=PDJ(IPROD3,jpdj)+K(I,JPDJ)
       IF (IPROD4.NE.NS+1) PDJ(IPROD4,jpdj)=PDJ(IPROD4,jpdj)+K(I,JPDJ)
       PDJ(IR1,jpdj)=PDJ(IR1,jpdj)-K(I,JPDJ)
       endif

                endif
       ENDDO

       RETURN
      END

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine computeIAJA(IA,JA,liw,SPEC,Y)
      implicit none
      include 'header.f90'
      integer :: liw
      integer, dimension(NS*NX+1) :: IA
      integer, dimension(liw) :: JA
      real(kind=8), dimension(NS,NX) :: DUMMYY, Y
      real(kind=8), dimension(NS*NX) :: PDJ
      CHARACTER(len=8), dimension(NS) :: SPEC

      integer :: i,j,kjac
      real(kind=8) :: T, hop
      REAL(KIND=8), dimension(NS*NX) :: IAN, JAN

      INTEGER REACT(NRTOT,7)
      DOUBLE PRECISION K(NRTOT,NX),NHTOT(NX)
       real(kind=8), dimension(2,nx) :: radius
      COMMON/EQUA/K,NHTOT,radius, react

      DUMMYY(:,1)=1.d-5
      do i=1,NX-1
      DUMMYY(:,I+1)=DUMMYY(:,I)*1.1d0
      enddo

      kjac=1

      do j=1,NS*NX
      call JACFH(NS*NX,T,Y,j,IAN,JAN,PDJ)

!      print *, j, maxval(PDJ)

      IA(j)=kjac

      hop=1.d-4*maxval(abs(PDJ))
!      hop=0.D0
      do i=1,NS*NX
!      if (PDJ(i).ne.0.d0) then
!      if (abs(PDJ(i)).gt.1.d-9) then
      if (abs(PDJ(i)).gt.hop) then
      JA(kjac)=i
      kjac=kjac+1
      endif
      enddo

      enddo

!      stop

      IA(NS*NX+1)=kjac

      return
      end


Subroutine dchout(l, ii, t)
  Implicit Double Precision (A-H, O-Z)
  Parameter (maxptn=400001)
  Common /prec2/gx(maxptn), gy(maxptn), gz(maxptn), ft(maxptn), px(maxptn), py(maxptn), pz(maxptn), e(maxptn), xmass(maxptn), ityp(maxptn)
  Common /prec4/vx(maxptn), vy(maxptn), vz(maxptn)
  Common /ilist3/size1, size2, size3, v1, v2, v3, size
  Common /ilist5/ct(maxptn), ot(maxptn), tlarge
  Save
  External integ
  tt = ft(l)
  td = t - size
  x1 = gx(l) + vx(l)*(t-tt)
  x2 = gy(l) + vy(l)*(t-tt)
  x3 = gz(l) + vz(l)*(t-tt)
  If (td<=0D0) Then
     i1 = integ(x1/size1) + 6
     i2 = integ(x2/size2) + 6
     i3 = integ(x3/size3) + 6
     If (integ(x1/size1)==x1/size1 .And. vx(l)<0D0) i1 = i1 - 1
     If (integ(x2/size2)==x2/size2 .And. vy(l)<0D0) i2 = i2 - 1
     If (integ(x3/size3)==x3/size3 .And. vz(l)<0D0) i3 = i3 - 1
  Else
     i1 = integ(x1/(size1+v1*td)) + 6
     i2 = integ(x2/(size2+v2*td)) + 6
     i3 = integ(x3/(size3+v3*td)) + 6
     If (integ(x1/(size1+v1*td))==x1/(size1+v1*td) .And. vx(l)<(i1-6)*v1) i1 = i1 - 1
     If (integ(x2/(size2+v2*td))==x2/(size2+v2*td) .And. vy(l)<(i2-6)*v2) i2 = i2 - 1
     If (integ(x3/(size3+v3*td))==x3/(size3+v3*td) .And. vz(l)<(i3-6)*v3) i3 = i3 - 1
  End If
  If (ii==1) Then
     i = 9
     Do j = i2 - 1, i2 + 1
        Do k = i3 - 1, i3 + 1
           If (j>=1 .And. j<=10 .And. k>=1 .And. k<=10) Then
              Call dchcel(l, i, j, k, t)
           End If
        End Do
     End Do
  End If
  If (ii==2) Then
     i = 2
     Do j = i2 - 1, i2 + 1
        Do k = i3 - 1, i3 + 1
           If (j>=1 .And. j<=10 .And. k>=1 .And. k<=10) Then
              Call dchcel(l, i, j, k, t)
           End If
        End Do
     End Do
  End If
  If (ii==3) Then
     j = 9
     Do i = i1 - 1, i1 + 1
        Do k = i3 - 1, i3 + 1
           If (i>=1 .And. i<=10 .And. k>=1 .And. k<=10) Then
              Call dchcel(l, i, j, k, t)
           End If
        End Do
     End Do
  End If
  If (ii==4) Then
     j = 2
     Do i = i1 - 1, i1 + 1
        Do k = i3 - 1, i3 + 1
           If (i>=1 .And. i<=10 .And. k>=1 .And. k<=10) Then
              Call dchcel(l, i, j, k, t)
           End If
        End Do
     End Do
  End If
  If (ii==5) Then
     k = 9
     Do i = i1 - 1, i1 + 1
        Do j = i2 - 1, i2 + 1
           If (i>=1 .And. i<=10 .And. j>=1 .And. j<=10) Then
              Call dchcel(l, i, j, k, t)
           End If
        End Do
     End Do
  End If
  If (ii==6) Then
     k = 2
     Do i = i1 - 1, i1 + 1
        Do j = i2 - 1, i2 + 1
           If (i>=1 .And. i<=10 .And. j>=1 .And. j<=10) Then
              Call dchcel(l, i, j, k, t)
           End If
        End Do
     End Do
  End If
  Return
End Subroutine dchout


      SUBROUTINE CONCAL( NIN, NOUT, LERR,
     &			 CVECT, CENTRE,
     &			 ATMAX, ATNO, ATBRK, ATRES, ATCHN, ATRNO,
     &			 ATXYZ, ATVDW, ATBND,
     &                   SPDBSP, FPDBSP,
     &			 SHORTO,
     &			 ENDRAD, CUTSIZE, CONNR,
     &			 PERPVE, PERPVN, REQUIV, PEG_WRITEALL, IREC,
     &                   SAMPLE)
      IMPLICIT NONE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Oliver Smart. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Oliver Smart are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 2000 Oliver Smart *
C *                                                                  *
C ********************************************************************
C
C s/r to perform connolly type surface calc within hole
C
C Modification history:
C
C Date  Author          Modification
C 01/00 O.S.S.    	CONN option introduced
C 10/00 O.S.S.		PEG_WRITEALL option added for PEG effect calcs

C passed vbles *****************

C input/output stream numbers
      INTEGER			NIN, NOUT

C error indicator
      LOGICAL			LERR

C a vector in the direction of the channel
C must be a unit vector - return unchanged
      DOUBLE PRECISION          CVECT(3)

C The centre about which the connolly grid is to be
C done (s/r holcal normal supplies lowcen)
      DOUBLE PRECISION          CENTRE(3)

C maximum no. of atoms
      INTEGER                   ATMAX

C number of atoms read in from each file:
      INTEGER                   ATNO

C atom names found in Brookhaven file:
      CHARACTER*4               ATBRK(ATMAX)

C residue name in brook
      CHARACTER*3               ATRES(ATMAX)

C chain identifier in brookhaven pdb file
      CHARACTER*1               ATCHN(ATMAX)

C integer residue no.
      INTEGER                   ATRNO(ATMAX)

C co-ordinates
      DOUBLE PRECISION          ATXYZ( 3, ATMAX)

C vdw and bond radii of each atoms
      DOUBLE PRECISION          ATVDW(ATMAX), ATBND(ATMAX)

C pdb format output file 'atoms' are sphere centres
C default to none by setting FPDBSP to 'NONE'
      CHARACTER*200             FPDBSP
      INTEGER                   SPDBSP

C 11/95 introduce new variable to reduce text output -
C if oshort =
C 0: full text output
C 1: no in run progress reported
C 2: ditto plus no graph type output - only leaving
C    Minimum radius & conductance calculations.
C 3: All text output other than input card mirroring
C    and error messages turned off
      INTEGER                   SHORTO

C ENDRAD: Radius above which a point is considered to have escaped
C ENDRP3 also need to have a slightly higher value for the purposes of this s/r
      DOUBLE PRECISION          ENDRAD, ENDRP3

C cut off list control vble, -ve: no cutoff lists used in calculation
C otherwise this is the additional radius above the sphere radius
C to be used for cutoff list (see s/r holeen)
      DOUBLE PRECISION		CUTSIZE

C option CONN introduced 1/00 -
C CONNR(1) is the connolly surface probe radius (default 1.15Angs)
C          the option is turned off by setting this radius negative
C CONNR(2) is the grid size to be used in the calculation - default .25 angs
      DOUBLE PRECISION		CONNR(2)

C unit vectors in plane normal to cvect
C needed to a number of routines - originally h2dmap but now conn
C and addend
C these are normal - first is east direction (x on plane)
C                    and second is north     (y on plane)
C return unchanged!!!
      DOUBLE PRECISION		PERPVE(3), PERPVN(3)

C area of final assembly returned as a effective radius = sqrt(area/pi)
      DOUBLE PRECISION		REQUIV

C write all the records? (for PEG calcs)
      LOGICAL 			PEG_WRITEALL

C record number for sph write
      INTEGER                   IREC

! a sampling distance - the distance between planes
      DOUBLE PRECISION		SAMPLE

C internal variables ***********

C a new point
      DOUBLE PRECISION          NEWCEN(3), NEWENG

C atom list no. with smallest dist-vdw radius, 2nd smallest
C 07/06/94 as iat's may or may not be supplied with previously
C found numbers then we can use this to speed up the procedure
C Dec 97 add iat3
      INTEGER			IAT1, IAT2, IAT3

C 2nd/3rd smallest distance-vdw radius (of iat2/3)
      DOUBLE PRECISION		DAT2, DAT3

C arrays for connolly calc
C maximum size of the array STRMAX
      INTEGER			SCOMAX
      PARAMETER(		SCOMAX= 10000)
C number of entries stored
      INTEGER			SCONUM
C number of entries - that have been "checked"
C that is looking at the neighbouring eight points
C
C      INTEGER			SCOCHK
C the next entry to check
      INTEGER			SCONXT

C a stored entry - a point with a radius above the probe radius connr(1)
      DOUBLE PRECISION		SCOXYZ( 3, SCOMAX)
C the radius of the point
      DOUBLE PRECISION		SCORAD( SCOMAX)
C logical vble whether point needs to be checked\
C if point is on grid then it must be if
C  produced by the spike procedure it need no
C
C at the end of the procedure change meaning -
C it then becomes a store of whether point should be
C included in output/ area calculations
      LOGICAL			SCOTDO( SCOMAX)
C s/r coarea needs a store for the east/north coords of
C each point on grid - these are measured relative to the
C initial point
! SCOCIRCRAD: the radius of the point in the plane under consideration
! in the case of calls from concal this we equal scocrad
      DOUBLE PRECISION		SCOENC( 2, SCOMAX),
     &				SCOCIRCRAD( SCOMAX)

      ! vbles needed by coarea - not used here only required
      ! for peg calls to coarea by sph_process
      INTEGER			SCO_PEG_ACC(SCOMAX)
      LOGICAL			SCO_PEG_FLAG(SCOMAX)

CORIGC the status of the  surronding points
CORIGC if .false. then point in relevant direction has been accepted or not yet checked
CORIGC if .true. then last point in that direction has been rejected
CORIGC first variable is "East" and next is "North":
CORIGC i.e. point 0,0 is the point itself
CORIGC and directions:
CORIGC  (-1,+1) ( 0,+1) (+1,+1)
CORIGC  (-1, 0)  Cpoint (+1, 0)
CORIGC  (-1,-1) ( 0,-1) (+1,-1)
CORIG      LOGICAL			SCONEI( -1:1, -1:1, SCOMAX)
CORIG
CORIGC number of new points
CORIG INTEGER			SCONEW

C GRID SIZE, working variable - dist2
      DOUBLE PRECISION 		GRIDS, DIST2, DIFF1, DIFF2, DIFF3

C loop counts
      INTEGER			NCOUNT, ECOUNT, SCOUNT, JCOUNT, XCOUNT,
     &				CCOUNT

C test point
      DOUBLE PRECISION		TSTXYZ(3)

C variables for spike like routine
      DOUBLE PRECISION		VDISP(3), DELTA

C max radius indicator
      DOUBLE PRECISION		MAXRAD

C number of points eliminated, elimination distance
      INTEGER			NELIM
      DOUBLE PRECISION		DELIM2

! for writing .sph file correctly
      INTEGER			WRESNO
      DOUBLE PRECISION 		WREQUIV

C end of decs ******************

C bigger value of endrad
      ENDRP3 = ENDRAD + 3D0

      IF (SHORTO.LT.2) WRITE( NOUT, '(A)')
     & ' Connolly routine for this plane'
D	WRITE( NOUT, '(//A/ A,F8.3/ A,F8.3/ A,3F8.3)')
D    & 'D-line: Call to s/r concal',
D    &' D-line: CONNR(1) = ', CONNR(1),
D    &' D-line: CONNR(2) = ', CONNR(2),
D    &' D-line: CENTRE = ', CENTRE(1), CENTRE(2), CENTRE(3)

C find the pore radius of the initial point
      CALL HOLEEN( CENTRE, NEWENG, IAT1, IAT2, IAT3, DAT2, DAT3,
     &           ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)

D      WRITE( NOUT, '(A,F8.3,A)')
D    & 'D-line pore radius of supplied CENTRE = ', -NEWENG, ' Angs'

C is the hole pore radius less than the probe radius - if so cannot do connolly
       IF (-NEWENG.LT.CONNR(1)) THEN
	   WRITE(NOUT, '(/ A/ A,F8.3,A,F8.3/ A)')
     &' Connolly routine (s/r concal)',
     &'   initial point probe radius=', -NEWENG,
     &              ' less than probe radius=',CONNR(1),
     &'   So using HOLE point for calcs........'

C simply return the hole radius as the effective
        REQUIV = -NEWENG

      ELSE
C initial point has a pore radius above the probe radius so can check
C initialize array - one point - the initial
        SCONUM = 1
C next point to check is the first
        SCONXT = 1
        SCOXYZ(1,SCONUM) = CENTRE(1)
        SCOXYZ(2,SCONUM) = CENTRE(2)
        SCOXYZ(3,SCONUM) = CENTRE(3)
        SCORAD(SCONUM) = -NEWENG
	SCOTDO(SCONUM) = .TRUE.
C gridsize - set outside this routine
C (n.b. neighbouring points must overlap)
        GRIDS = CONNR(2)

C jump back here to check next unchecked point
222    CONTINUE
C ignore points that have a radius above ENDRP3 - these should not spawn more
C and points that have been generated by spike procedure
        IF ( (SCORAD(SCONXT).LT.ENDRP3) .AND.
     &              SCOTDO(SCONXT)            ) THEN
C mark the point as checked
          SCOTDO(SCONXT) = .FALSE.
C check points around scoxyz(1,SCONXT), scoxyz(2,SCONXT), scoxyz(3,SCONXT)
C increment south, zero, north
          DO 15 NCOUNT = -1, 1
            DO 25 ECOUNT = -1, 1
C test point:
              TSTXYZ(1) = SCOXYZ(1,SCONXT)
              TSTXYZ(2) = SCOXYZ(2,SCONXT)
              TSTXYZ(3) = SCOXYZ(3,SCONXT)
C movement east by grids
              TSTXYZ(1) = TSTXYZ(1) + REAL(ECOUNT)*GRIDS*PERPVE(1)
              TSTXYZ(2) = TSTXYZ(2) + REAL(ECOUNT)*GRIDS*PERPVE(2)
              TSTXYZ(3) = TSTXYZ(3) + REAL(ECOUNT)*GRIDS*PERPVE(3)
C movement north by grids
              TSTXYZ(1) = TSTXYZ(1) + REAL(NCOUNT)*GRIDS*PERPVN(1)
              TSTXYZ(2) = TSTXYZ(2) + REAL(NCOUNT)*GRIDS*PERPVN(2)
              TSTXYZ(3) = TSTXYZ(3) + REAL(NCOUNT)*GRIDS*PERPVN(3)
C Q: have we already produced this point?
C look through existing list
              DO 67 SCOUNT = 1, SCONUM
C find distance**2 between the points
                DIFF1 = TSTXYZ(1)-SCOXYZ(1,SCOUNT)
                DIFF2 = TSTXYZ(2)-SCOXYZ(2,SCOUNT)
                DIFF3 = TSTXYZ(3)-SCOXYZ(3,SCOUNT)
                DIST2 = DIFF1*DIFF1 + DIFF2*DIFF2 + DIFF3+DIFF3
                IF (DIST2.LT.GRIDS/1000D0) THEN
C this point already considered and accepted
CORIG                  SCONEI( ECOUNT, NCOUNT, SCONXT) = .FALSE.
D                 WRITE( NOUT, '(A,3F8.3)')
D    & 'D-line Have already considered + accepted point= ',
D    &       TSTXYZ(1), TSTXYZ(2),TSTXYZ(3)
C jump to next point
                  GOTO 25
                ENDIF
67            CONTINUE

C find the radius of this point
              CALL HOLEEN( TSTXYZ, NEWENG, IAT1, IAT2, IAT3, DAT2, DAT3,
     &                   ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)
C change sign to give +ve pore radius
              NEWENG = -NEWENG
C Q: is this an accepted point?
              IF (NEWENG.GE.CONNR(1)) THEN
C YES this is an accepted point (and its unique)
CORIGC first store information for point that produced this
CORIG                SCONEI( ECOUNT, NCOUNT, SCONXT) = .FALSE.

C now add point onto end of list to be considered
C array check here
                IF (SCONUM+1.GT.SCOMAX) THEN
                  WRITE( NOUT, '(A)')
     &' ERROR SCOMAX reached in s/r concal',
     &' this should not generally happen (unless grid set too small)!',
     &' please report to Oliver Smart o.s.smart@bham.ac.uk',
     &' with input and output files'
                  LERR = .TRUE.
                  GOTO 55555
                ENDIF
C store the extra point
                SCONUM = SCONUM + 1
                SCOXYZ(1,SCONUM) = TSTXYZ(1)
                SCOXYZ(2,SCONUM) = TSTXYZ(2)
                SCOXYZ(3,SCONUM) = TSTXYZ(3)
                SCORAD(SCONUM) = NEWENG
C this is a not spike so must be checked
		SCOTDO(SCONUM) = .TRUE.
D               WRITE( NOUT, '(A,3F8.3,A,F8.3,A)')
D    & 'D-line ACCEPT point= ', TSTXYZ(1), TSTXYZ(2),TSTXYZ(3),
D    &               ' radius= ', NEWENG, ' Angs'
C must finish as soon as a ENDRP3 point arrived at
                IF (NEWENG.GT.ENDRP3) THEN
		  IF (SHORTO.LT.2) WRITE( NOUT, '(A)')
     &' Escaped to outside at this level'
                  GOTO 333
		ENDIF

              ELSE
C NO this point is rejected (Q: is this an accepted point?)
CORIGC first store information for point that produced this
CORIG                SCONEI( ECOUNT, NCOUNT, SCONXT) = .TRUE.
D               WRITE( NOUT, '(A,3F8.3,A,F8.3,A)')
D    & 'D-line REJECT point= ', TSTXYZ(1), TSTXYZ(2),TSTXYZ(3),
D    &               ' radius= ', NEWENG, ' Angs'
C "spike" procedure - adjust point towards originating vector until
C it gets to desired radius
C vector starts from SCOXYZ(*,SCONXT) and goes to TSTXYZ(*)
                VDISP(1) = TSTXYZ(1)-SCOXYZ(1,SCONXT)
                VDISP(2) = TSTXYZ(2)-SCOXYZ(2,SCONXT)
                VDISP(3) = TSTXYZ(3)-SCOXYZ(3,SCONXT)
C make unit
                CALL DUVEC2( VDISP)
C DISP is the proportion displacement along this vector
C will adjust this to give a pore radius equal to the probe
C first estimate approx way along
                DELTA = 0.25D0*GRIDS
C next bit is analogous to procedure in hodotu.f for producing spikes
C do ten cycles of refinement to find sphere centre SEE f048 FOR METHOD
                DO 55 CCOUNT = 1, 100
C load up current point dum is the distance along line
C from the sphere which is current estimate of overlap point.
                  TSTXYZ(1) = SCOXYZ(1,SCONXT) + DELTA*VDISP(1)
                  TSTXYZ(2) = SCOXYZ(2,SCONXT) + DELTA*VDISP(2)
                  TSTXYZ(3) = SCOXYZ(3,SCONXT) + DELTA*VDISP(3)
C find the radius of this point
                  CALL HOLEEN( TSTXYZ, NEWENG, IAT1, IAT2, IAT3,
     &			       DAT2, DAT3,
     &                        ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)
C make neweng=poreradius
                  NEWENG = -NEWENG
D               WRITE( NOUT, '(A,I5,AF8.3,A,F8.3,A)')
D    & 'D-line SPIKE cycle ',CCOUNT,' DELTA= ', DELTA,
D    &                    ' radius= ', NEWENG, ' Angs'
C take off the probe radius plus a very little bit
                  NEWENG =  NEWENG - (CONNR(1)+0.0001D0)
		  IF (ABS(NEWENG).LT.0.0005) GOTO 56
C if this number is greater than zero then we are too close to point SCONXT
C so add number on
                  DELTA = DELTA + NEWENG
C as we go thru this cycle the pore radius at the point should get closer to probe radius
55              CONTINUE
C at the end should have a point close to the probe radius
C store it if good enough
C very occasionally delta goes less than zero - this can produce big jumps
C so eliminate these points
56              CONTINUE
                IF ((ABS(NEWENG).LT.0.0005).AND.DELTA.GT.0.0) THEN
C check to see whether point is close to an already existing point
C look through existing list
                   DO 667 SCOUNT = 1, SCONUM
C find distance**2 between the points
                     DIFF1 = TSTXYZ(1)-SCOXYZ(1,SCOUNT)
                     DIFF2 = TSTXYZ(2)-SCOXYZ(2,SCOUNT)
                     DIFF3 = TSTXYZ(3)-SCOXYZ(3,SCOUNT)
                     DIST2 = DIFF1*DIFF1 + DIFF2*DIFF2 + DIFF3+DIFF3
C distance must be above 0.3 angs
                     IF (DIST2.LT.0.09D0) THEN
C this point already considered and accepted
CORIG                  SCONEI( ECOUNT, NCOUNT, SCONXT) = .FALSE.
D                 WRITE( NOUT, '(A,3F8.3)')
D    & 'D-line Point close (.3 angs) to already stored point '
C jump to next point
                       GOTO 25
                     ENDIF
667               CONTINUE

C array check here
                  IF (SCONUM+1.GT.SCOMAX) THEN
                    WRITE( NOUT, '(A)')
     &' ERROR SCOMAX reached in s/r concal',
     &' this should not generally happen (unless grid set too small)!',
     &' please report to Oliver Smart o.s.smart@bham.ac.uk',
     &' with input and output files'
                    LERR = .TRUE.
                    GOTO 55555
                  ENDIF
C store point
                  SCONUM = SCONUM + 1
                  SCOXYZ(1,SCONUM) = TSTXYZ(1)
                  SCOXYZ(2,SCONUM) = TSTXYZ(2)
                  SCOXYZ(3,SCONUM) = TSTXYZ(3)
C get back to the pore radius
                  SCORAD(SCONUM) = NEWENG + (CONNR(1)+0.0001D0)
C this is a spike - so should not produce any new point
		  SCOTDO(SCONUM) = .FALSE.
	        ENDIF
              ENDIF
25          CONTINUE
15        CONTINUE
C finished considering point SCONXT
        ENDIF

C jump back to consider next point if necessary
C at each stage the highest radius point propogates
C this is to keep number of points down when we get escape to infinity
C initialize maximum radius array
        MAXRAD = -1D10
	SCONXT = -1000
C go thru all the point
        DO 701 SCOUNT = 1, SCONUM
          IF (SCOTDO(SCOUNT)) THEN
	     IF (SCORAD(SCOUNT).GT.MAXRAD) THEN
	       SCONXT = SCOUNT
	       MAXRAD = SCORAD(SCOUNT)
	     ENDIF
	  ENDIF
701     CONTINUE

C do we have to jump back - are there any points to check?
        IF (SCONXT.GT.0) THEN
D         	WRITE( NOUT, '(A,I5,A,F8.3)')
D    & 'D-line Jump back next point SCONXT= ', SCONXT, ' MAXRAD= ', MAXRAD
          GOTO 222
        ENDIF

C Jump out here if ENDRP3 is hit
333     CONTINUE
C tell user vectors used to define rotation
        IF (SHORTO.LT.2) WRITE( NOUT, '(A,I5,A)')
     & ' Have stored total of ', SCONUM, ' points'

C eliminate unnecessary points.
C use SCOTDO as a flag for consideration
C set all to true
        DO 702 SCOUNT = 1, SCONUM
          SCOTDO(SCOUNT) = .TRUE.
702     CONTINUE
C if we have found an end (which will allways be the last point found)
C then eliminate all points whose centres lie within it
        IF (SCORAD(SCONUM).GT.ENDRP3) THEN
	  NELIM = 0
          DELIM2 = SCORAD(SCONUM)
	  DELIM2 = DELIM2*DELIM2
C go thru points - but not the last
          DO 703 SCOUNT = 1, SCONUM-1
C find distance**2 between the point and end point
            DIFF1 = SCOXYZ(1,SCONUM)-SCOXYZ(1,SCOUNT)
            DIFF2 = SCOXYZ(2,SCONUM)-SCOXYZ(2,SCOUNT)
            DIFF3 = SCOXYZ(3,SCONUM)-SCOXYZ(3,SCOUNT)
            DIST2 = DIFF1*DIFF1 + DIFF2*DIFF2 + DIFF3+DIFF3
C within limits?
            IF (DIST2.LT.DELIM2) THEN
	      SCOTDO(SCOUNT) = .FALSE.
	      NELIM = NELIM + 1
	    ENDIF
703       CONTINUE
          IF (SHORTO.LT.2) WRITE( NOUT, '(A,I5,A)')
     & ' Have eliminated ', NELIM,
     &    ' of these points as they are within the end found',
     & ' leaves ', SCONUM-NELIM, ' points '
	ENDIF

C 2nd cycle of elimination - points that lie well within original HOLE point
C that is with 1.5 probe radii
        IF (SCORAD(1).GT.2.5D0*CONNR(1)) THEN
	  NELIM = 0
          DELIM2 = SCORAD(1)-1.5D0*CONNR(1)
	  DELIM2 = DELIM2*DELIM2

C go thru points - but not the first
          DO 704 SCOUNT = 2, SCONUM
	    IF (.NOT.SCOTDO(SCOUNT)) GOTO 704
C find distance**2 between the point and original point
            DIFF1 = SCOXYZ(1,1)-SCOXYZ(1,SCOUNT)
            DIFF2 = SCOXYZ(2,1)-SCOXYZ(2,SCOUNT)
            DIFF3 = SCOXYZ(3,1)-SCOXYZ(3,SCOUNT)
            DIST2 = DIFF1*DIFF1 + DIFF2*DIFF2 + DIFF3+DIFF3
C within limits?
            IF (DIST2.LT.DELIM2) THEN
	      SCOTDO(SCOUNT) = .FALSE.
	      NELIM = NELIM + 1
	    ENDIF
704       CONTINUE
          IF (SHORTO.LT.2) WRITE( NOUT, '(A,I5,A)')
     & ' Have eliminated ', NELIM,
     &    ' points as they are well within original HOLE centre',
     & ' leaves ', SCONUM-NELIM, ' points '
	ENDIF

C now do the area calculation for this set
        CALL COAREA( REQUIV, NOUT, LERR, SHORTO, ENDRAD,
     &		     CENTRE, PERPVE, PERPVN,
     &               SCOMAX, SCONUM, SCOXYZ, SCORAD, SCOTDO,
     &               SCOENC, SCOCIRCRAD, CVECT, SAMPLE,
     &		     .FALSE., SCO_PEG_ACC, SCO_PEG_FLAG, -1)

C write out the records if we need to
        IF (FPDBSP.NE.'NONE') THEN
	  WRESNO = IREC ! first record is the centre supplied
	                ! to routine write this as a normal record
	  WREQUIV = REQUIV
	  IF (WREQUIV.GT.1000.) WREQUIV = 999.99
	  DO 4100 SCOUNT = 1, SCONUM

C PEG_WRITEALL option do not edit out records
C set the record number to -999 for all records
             IF (       SCOTDO(SCOUNT) .OR.
     &            (SCORAD(SCOUNT).GT.ENDRAD) .OR.
     &                    PEG_WRITEALL                ) THEN
	       WRITE( SPDBSP, '(A,I4,4X,3F8.3,2F6.2)')
     &   'ATOM      1  QSS SPH S', WRESNO,
     &       (SCOXYZ(XCOUNT,SCOUNT), XCOUNT= 1, 3),
     &       SCORAD(SCOUNT), WREQUIV
               IF (SCORAD(SCOUNT).GT.ENDRAD)
     &           WRITE( SPDBSP, '(A)') 'LAST-REC-END'
               WRESNO = -999 ! after first write mark as connolly type records
             ENDIF
4100      CONTINUE
	ENDIF

C end of if Q is the hole pore radius less than the probe radius?
      ENDIF

C      STOP 'temp stop in HOLCAL'

55555 RETURN
CORIGD       DO 5010 SCOUNT = 1, SCONUM
CORIGD          WRITE( NOUT, '(A,3F8.3,A,F8.3,A/ 3L1/ 3L1/ 3L1/)')
CORIGD    & ' xyz=', (SCOXYZ(XCOUNT,SCOUNT), XCOUNT = 1,3),
CORIGD    &   '  rad=', SCORAD(SCOUNT),
CORIGD    &   '   flags=',
CORIGD    &   SCONEI( -1,  1, SCOUNT),
CORIGD    &   SCONEI(  0,  1, SCOUNT),
CORIGD    &   SCONEI( +1,  1, SCOUNT),
CORIGD    &   SCONEI( -1,  0, SCOUNT),
CORIGD    &   SCONEI(  0,  0, SCOUNT),
CORIGD    &   SCONEI( +1,  0, SCOUNT),
CORIGD    &   SCONEI( -1, -1, SCOUNT),
CORIGD    &   SCONEI(  0, -1, SCOUNT),
CORIGD    &   SCONEI( +1, -1, SCOUNT)
CORIGD5010 CONTINUE

CORIGC original procedure - involved halving gridsize but failed
CORIGC just in case leave in commented CORIG
CORIGC have finished original gridsize - halve it and then
CORIGC check the half points
CORIG        IF (GRIDS.GT.CONNR(1)/1.999) THEN
CORIG
CORIGC halve the grid size
CORIG          GRIDS = GRIDS/2D0
CORIG
CORIGD         WRITE( NOUT, '(A,F10.4)')
CORIGD    & 'D-line GRIDS reduced to = ', GRIDS
CORIG
CORIGC go thru the existing list
CORIG          SCONEW = SCONUM
CORIG          DO 89 SCOUNT = 1, SCONUM
CORIGC look at each direction of stored point
CORIGC increment south, zero, north
CORIG            DO 157 NCOUNT = -1, 1
CORIG              DO 257 ECOUNT = -1, 1
CORIGC if the flag SCONEI( ECOUNT, NCOUNT, SCOUNT) is .true.
CORIGC then this point was rejected for previous grid size
CORIGC so check again
CORIG                IF (SCONEI( ECOUNT, NCOUNT, SCOUNT)) THEN
CORIGC test point for this direction with new grid
CORIG                  TSTXYZ(1) = SCOXYZ(1,SCOUNT)
CORIG                  TSTXYZ(2) = SCOXYZ(2,SCOUNT)
CORIG                  TSTXYZ(3) = SCOXYZ(3,SCOUNT)
CORIGC movement east by grids
CORIG                  TSTXYZ(1) = TSTXYZ(1) + REAL(ECOUNT)*GRIDS*PERPVE(1)
CORIG                  TSTXYZ(2) = TSTXYZ(2) + REAL(ECOUNT)*GRIDS*PERPVE(2)
CORIG                  TSTXYZ(3) = TSTXYZ(3) + REAL(ECOUNT)*GRIDS*PERPVE(3)
CORIGC movement north by grids
CORIG                  TSTXYZ(1) = TSTXYZ(1) + REAL(NCOUNT)*GRIDS*PERPVN(1)
CORIG                  TSTXYZ(2) = TSTXYZ(2) + REAL(NCOUNT)*GRIDS*PERPVN(2)
CORIG                  TSTXYZ(3) = TSTXYZ(3) + REAL(NCOUNT)*GRIDS*PERPVN(3)
CORIGC Q: have we already produced this point?
CORIGC look through existing list including new points
CORIG                  DO 677 JCOUNT = 1, SCONEW
CORIGC find distance**2 between the points
CORIG                    DIFF1 = TSTXYZ(1)-SCOXYZ(1,JCOUNT)
CORIG                    DIFF2 = TSTXYZ(2)-SCOXYZ(2,JCOUNT)
CORIG                    DIFF3 = TSTXYZ(3)-SCOXYZ(3,JCOUNT)
CORIG                    DIST2 = DIFF1*DIFF1 + DIFF2*DIFF2 + DIFF3+DIFF3
CORIG                    IF (DIST2.LT.GRIDS/1000D0) THEN
CORIGC this point already considered and accepted
CORIG                      SCONEI( ECOUNT, NCOUNT, SCOCHK) = .FALSE.
CORIGD                     WRITE( NOUT, '(A,3F8.3)')
CORIGD    & 'D-line 2nd loop Have already considered + accepted point= ',
CORIGD    &       TSTXYZ(1), TSTXYZ(2),TSTXYZ(3)
CORIGC jump to next point
CORIG                     GOTO 257
CORIG                   ENDIF
CORIG677              CONTINUE
CORIG
CORIGC find the radius of this point
CORIG                 CALL HOLEEN( TSTXYZ, NEWENG, IAT1, IAT2, IAT3,
CORIG     &			      DAT2, DAT3,
CORIG     &                        ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)
CORIGC change sign to give +ve pore radius
CORIG                 NEWENG = -NEWENG
CORIGC Q: is this an accepted point?
CORIG                 IF (NEWENG.GE.CONNR(1)) THEN
CORIGC YES this is an accepted point (and its unique)
CORIGC first store information for point that produced this
CORIG                   SCONEI( ECOUNT, NCOUNT, SCOUNT) = .FALSE.
CORIGC now add point onto end of list to be considered
CORIGC array check here
CORIG                   IF (SCONEW+1.GT.SCOMAX) THEN
CORIG                     WRITE( NOUT, '(A)')
CORIG     &' ERROR SCOMAX reached in s/r concal',
CORIG     &' this should not generally happen!',
CORIG     &' please report to Oliver Smart o.s.smart@bham.ac.uk',
CORIG     &' with input and output files'
CORIG                     LERR = .TRUE.
CORIG                     GOTO 55555
CORIG                  ENDIF
CORIGC store the extra point
CORIG                  SCONEW = SCONEW + 1
CORIG                  SCOXYZ(1,SCONEW) = TSTXYZ(1)
CORIG                  SCOXYZ(2,SCONEW) = TSTXYZ(2)
CORIG                  SCOXYZ(3,SCONEW) = TSTXYZ(3)
CORIG                  SCORAD(SCONEW) = NEWENG
CORIGD                 WRITE( NOUT, '(A,3F8.3,A,F8.3,A)')
CORIGD    & 'D-line 2nd loop ACCEPT point= ', TSTXYZ(1), TSTXYZ(2),TSTXYZ(3),
CORIGD    &               ' radius= ', NEWENG, ' Angs'
CORIG                  ELSE
CORIGC NO this point is rejected (Q: is this an accepted point?)
CORIGC first store information for point that produced this
CORIG                    SCONEI( ECOUNT, NCOUNT, SCOUNT) = .TRUE.
CORIGD                   WRITE( NOUT, '(A,3F8.3,A,F8.3,A)')
CORIGD    & 'D-line REJECT point= ', TSTXYZ(1), TSTXYZ(2),TSTXYZ(3),
CORIGD    &               ' radius= ', NEWENG, ' Angs'
CORIG                  ENDIF
CORIG                ENDIF
CORIG257           CONTINUE
CORIG157        CONTINUE
CORIG89        CONTINUE
CORIGC finished adding extra points for half grids
CORIG          SCONUM = SCONEW
CORIG
CORIGC jump back to consider next point if necessary
CORIG          IF (SCOCHK.LT.SCONUM) THEN
CORIGD           WRITE( NOUT, '(A,I5,A,I5)')
CORIGD    & ' Jump back as SCOCHK= ', SCOCHK, ' SCONUM= ', SCONUM
CORIG            GOTO 222
CORIG          ENDIF
CORIG        ENDIF
      END