c This module/program is part of DaliLite (c) L. Holm 1999
c
c
c-------------------------------------------------------------------------------
c
	subroutine lean_mc(imax0,blocksize,nres1,nres2,d1,d2,lsave,
     $		preali1,itrimx,score,bestali1,ntetra,tetrapool)
	implicit none
	include 'gagasizes.for'
	integer imax,blocksize,nres1,nres2,itrimx
	integer*2 d1(maxres,maxres),d2(maxres,maxres),preali1(maxres0)
	real totscore
	logical lsave
	integer*2 initfragali(maxres),
     $		bestali1(maxres,popsize),outfragali(maxres),tetrapool(2,maxpair)
	integer ntetra
c
c	input
c		imax0 -- max # Monte Carlo steps
c		itrimx -- trim every itrimxth step
c		blocksize -- blocksize used by alignment
c		initfragali -- set of blocksize-genes to start from
c		ltop -- TRUE means sequential constraint
c		lsave -- TRUE means use rescore,dscore; FALSE means calculate all
c	output
c		score -- scores of saved alignments
c		bestali1 -- per residue alignment
c
	integer cnt(maxres),prev1(0:maxres+1),next1(0:maxres+1)
	integer nextres(0:maxres+1),next2(0:maxres+1)
	integer*2 ali1(maxres),ali2(maxres),fragali1(maxres),fragali2(maxres)
 	logical ltest(maxres,maxres)
	integer ncand, candij(2,maxpair*4)
	real rescore(maxres,maxres),dscore(maxres,maxres)
	integer imax0
	real score(popsize),bestscore
c
c	local bookkeeping
c		cnt(i) -- multiplicity of genes at residue i
c		ali1(i),ali2(j) -- per residue alignment
c		fragali1(i),fragali2(j) -- per gene alignment
c		prev1(i),next1(i) -- lookup with respect to fragali1(i)
c		next2(j) -- lookup with respect to fragali2(j)
c		nextres(i) -- lookup with respect to ali1(i)
c		ltest(i,j) -- TRUE if residue pair has been appended to cand-list
c		ncand -- length of candidate (residue pairs i,j) list
c		candij(2,ix) -- pointer from candidate to residue pair
c		rescore(i,j) -- worth of residue pair in current alignment
c		dscore(i,j) -- how much residue pair would add to current ali
c
c	make sure to delete incompatible residues before adding new ones !
c
c
c	functions
c
	real getp
	real ran
c
c	locals
c
	integer istep,nacc,ndel,ncand0,lenali
	logical lfr
	real alfa,delta
	real dx,p
	integer i,j,ix
	integer nrem,rem(2,maxres),nnew,new(2,maxres),ngenedel,genedel(maxres)
	integer di(maxpair),ve(maxpair),q,imp
	real impscore
c
	integer jnk1(dim1)
	common /junk1/jnk1
	integer jnk23(dim23)
	common /junk23/jnk23
	equivalence (jnk23(1),rescore)
	equivalence (jnk23(maxres*maxres+1),dscore)
	integer jnk5(dim5)
	common /junk5/jnk5
	equivalence (jnk5(1),candij)
	equivalence (jnk5(maxpair*8+1),di)
	equivalence (jnk5(maxpair*9+1),ve)
	integer jnk6(dim6)
	common /junk6/jnk6
	equivalence (jnk6,ltest)
c
	imax=imax0
	if(lverb)write(*,*) 'This is lean Monte Carlo',imax,ntetra,ltop,lsave,
     $		nres1,nres2
c
c	initialize
c
!	totscore=bestscore
!	call gettotscore(preali1,d1,d2,nres1,totscore)
!	if(totscore.gt.bestscore) then
!		do i=1,nres1
!			bestali1(i,1)=preali1(i)
!		end do
!		bestscore=totscore
!	end if

	bestscore=0.0
	call initialize_lean(cnt,ali1,ali2,fragali1,fragali2,prev1,next1,
     $		ltest,ncand,rescore,dscore,nres1,nres2,nextres,
     $		next2)
c
c	load candidates
c
	do ix=1,ntetra
		i=tetrapool(1,ix)
		j=tetrapool(2,ix)
		call appendcand_lean(i,j,blocksize,ltest,dscore,ncand,
     $			candij,ali1,ali2,nres1,d1,d2,nextres,lsave)
	end do
	write(*,*) 'ncand:',ncand
	write(*,500) (preali1(i),i=1,min(maxres,nres1))
c
c	convert preali1 to initfragali -- !!! assumes ltop=.TRUE. !!!
c
	do i=1,min(maxres,nres1)
		initfragali(i)=0
	end do
	do i=1,min(maxres,nres1)-3
		j=preali1(i)
		if(j.gt.0.and.j.le.min(maxres,nres2)-3) then
c
c			at least one candidate per segment, more on long ones
c
			if(i.gt.1) then
				if(preali1(i-1).eq.0) initfragali(i)=j
			end if
			if(preali1(i+3).eq.j+3) initfragali(i)=j
		end if
	end do
c
c	load initali
c
	lenali=0
	totscore=0.0
	do i=1,min(maxres,nres1)
		j=initfragali(i)
		if(j.ne.0) then
		  call testaddition(i,j,lsave,blocksize,prev1,next1,
     $			ali1,cnt,nres1,d1,d2,rescore,dscore,
     $			dx,nrem,rem,nnew,new,ngenedel,genedel,
     $			nres2,fragali1,fragali2,nextres,next2)
		  ! aconitase fix 20-Sep-95				    !
		  ! force accept even if dx=0 from dscore < short cand-list !
		  bestscore=0.0
		  call changeconfig_lean(ngenedel,genedel,nrem,rem,i,j,
     $			nnew,new,fragali1,fragali2,ali1,ali2,next1,prev1,next2,
     $			nextres,candij,ncand,d1,d2,rescore,dscore,lenali,
     $			cnt,ndel,nacc,blocksize,lsave,totscore,bestscore,
     $			nres1,outfragali,bestali1,dx)
		  !write(*,*),i,j,nrem,nnew,bestscore,totscore
		end if
	end do
	if(lverb)write(*,*) 'initial totscore',totscore,lenali
cwrite(*,500) (bestali1(i,1),i=1,nres1)
!	call gettotscore(ali1,d1,d2,nres1,totscore)
!        write(*,*) 'gettotscore',totscore
c	write(*,500) (initfragali(i),i=1,nres1)
!	write(*,500) (ali1(i),i=1,nres1)
c
c	Monte Carlo step
c
	lfr=.false.
	ncand0=0
	alfa=50.0
	delta=0.0
	imp=0
	istep=0
	impscore=0.0
	do while(istep.lt.imax)
		istep=istep+1
c
c		heatshock if score improvement is stalled
c
		if(istep-imp.eq.1) then
			alfa=50.0
			delta=0.0
		else if(istep-imp.eq.2) then
			alfa=1.0/sqrt(max(10000.0,totscore))
			delta=alfa/1000
		end if
		ndel=0
		nacc=0
		alfa=alfa+delta
c
c		adding phase  WARM
c
c
c		test in randomized order
c
		do ix=1,ntetra
			di(ix)=ix
			ve(ix)=nint(100.0*ran(seed))
		end do
		call j_index_Qsort(1,ntetra,maxpair,di,ve)
		do q=1,ntetra
			ix=di(q)
			i=tetrapool(1,ix)
			j=tetrapool(2,ix)
			if(fragali1(i).ne.j) then
				call testaddition(i,j,lsave,blocksize,
     $					prev1,next1,ali1,cnt,nres1,d1,d2,
     $					rescore,dscore,dx,nrem,rem,nnew,new,
     $					ngenedel,genedel,nres2,
     $					fragali1,fragali2,nextres,next2)
				p=getp(alfa*dx)
				if(ran(seed).lt.p) then
c				  write(*,*)'accepted',i,j,dx

				  call changeconfig_lean(ngenedel,genedel,
     $		nrem,rem,i,j,
     $		nnew,new,fragali1,fragali2,ali1,ali2,next1,prev1,next2,
     $		nextres,candij,ncand,d1,d2,rescore,dscore,lenali,
     $		cnt,ndel,nacc,blocksize,lsave,totscore,bestscore,
     $		nres1,outfragali,bestali1,dx)
				  if(totscore.gt.impscore) then
					imp=istep
					impscore=totscore
				  end if
				end if
19			end if
		end do
c!!!		call gettotscore(ali1,d1,d2,nres1,totscore)
c
c		trimming phase COLD
c
!		if(mod(istep,itrimx).eq.0) then
                if(istep.gt.0) then
		 i=0
		 do while(next1(i).le.nres1)
		  i=next1(i)
		  j=fragali1(i)
c		  Trim from ends only
		  if((cnt(i).eq.1).or.(cnt(i+blocksize-1).eq.1))then
			ngenedel=1
			genedel(1)=i
			call testdeletion(ngenedel,genedel,blocksize,cnt,
     $				rescore,ali1,nextres,nres1,d1,d2,lsave,dx,
     $				nrem,rem)
c			p=getp(alfa*dx)
c			if(ran(seed).lt.p) then
c			only accept improvements !
			if(dx.gt.0.0) then
				  call changeconfig_lean(ngenedel,genedel,
     $		nrem,rem,0,0,
     $		nnew,new,fragali1,fragali2,ali1,ali2,next1,prev1,next2,
     $		nextres,candij,ncand,d1,d2,rescore,dscore,lenali,
     $		cnt,ndel,nacc,blocksize,lsave,totscore,bestscore,
     $		nres1,outfragali,bestali1,dx)
				  if(totscore.gt.impscore+1.0) then
					imp=istep
					impscore=totscore
				  end if

			end if
		  end if
		 end do
		end if
		if(lverb)write(*,510) istep,imp,nacc,ndel,lenali,ncand,
     $			totscore,bestscore,alfa
c!!!		call gettotscore(ali1,d1,d2,nres1,totscore)
c		if(lsave)call print(ncand,candij,dscore,rescore,ali1,
c     $			next1,d1,d2,nres1)
		if(istep-imp.ge.20) istep=imax0+1
		if(nacc/float(ntetra).gt.0.1) alfa=10*alfa
	end do
	score(1)=bestscore/100
c	write(*,*) 'lean bestali1 ',bestscore
c	write(*,500) (bestali1(i,1),i=1,nres1)
c
500	format(20i4)
510	format('step',6i6,2f10.2,f10.5)
c
	return
	end
c
c-------------------------------------------------------------------------------
c
	subroutine changeconfig_lean(ngenedel,genedel,nrem,rem,i,j,
     $		nnew,new,fragali1,fragali2,ali1,ali2,next1,prev1,next2,
     $		nextres,candij,ncand,d1,d2,rescore,dscore,lenali,
     $		cnt,ndel,nacc,blocksize,lsave,totscore,bestscore,
     $		nres1,outfragali,bestali1,dx)
c
c	input:
c		ngenedel,genedel -- genes to delete
c		i,j -- gene to add
c		nrem,rem -- residues to delete
c		nnew,new -- residues to add
c		istep -- for imp
c		dx -- change in totscore
c
c	output:
c		imp -- updated if score improved
c		totscore -- updated
c		outfragali -- bestever fragali1 updated
c		bestali1 -- bestever ali1 updated
c
	implicit none
	include 'gagasizes.for'
	integer ngenedel,genedel(maxres),nrem,rem(2,maxres),i,j,nnew
	integer new(2,maxres)
	integer*2 fragali1(maxres),fragali2(maxres),ali1(maxres),ali2(maxres)
	integer next1(0:maxres+1),prev1(0:maxres+1),next2(0:maxres+1)
	integer nextres(0:maxres+1),candij(2,maxpair*4),ncand,lenali
	integer*2 d1(maxres,maxres),d2(maxres,maxres)
	real rescore(maxres,maxres)
	real dscore(maxres,maxres),totscore,bestscore,dx
	integer cnt(maxres),ndel,nacc,blocksize
	logical lsave
	integer nres1
	integer*2 outfragali(maxres),bestali1(maxres)
c
	integer k
c
	call dodeletions_lean(ngenedel,genedel,nrem,rem,fragali1,fragali2,ali1,
     $		ali2,next1,prev1,candij,ncand,d1,d2,rescore,dscore,
     $		lenali,cnt,ndel,lsave, nextres,blocksize,next2)
	if(i.ne.0) call doadditions_lean(i,j,nnew,new,fragali1,fragali2,ali1,
     $		ali2,next1,prev1,candij,ncand,d1,d2,rescore,dscore,lenali,
     $		cnt,blocksize,nacc,lsave,nextres,next2,nres1)
	totscore=totscore+dx
	if(ldebug) then
		write(*,*) 'totscore now',totscore,nacc,ndel
		write(*,500) (ali1(k),k=1,nres1)
		write(*,500) (fragali1(k),k=1,nres1)
		write(*,500) (cnt(k),k=1,nres1)
		write(*,500) (nextres(k),k=1,nres1)
c		if(lsave)call print(ncand,candij,dscore,
c     $			rescore,ali1,next1,d1,d2,nres1)
		write(*,500) (rem(1,k),rem(2,k),k=1,nrem)
		write(*,500) (new(1,k),new(2,k),k=1,nnew)
		call gettotscore(ali1,d1,d2,nres1,totscore)
		call checkcnt(cnt,fragali1,nres1,blocksize)
	end if
	if(totscore.gt.bestscore) then
		call saveali(nres1,fragali1,outfragali,totscore,bestscore)
		call saveali(nres1,ali1,bestali1,totscore,bestscore)
	end if
c
500	format(20i4)
c
	return
	end
c
c-------------------------------------------------------------------------------
c
	subroutine dodeletions_lean(ngenedel,genedel,nrem,rem,fragali1,
     $		fragali2,ali1,ali2,next1,prev1,candij,ncand,d1,d2,
     $		rescore,dscore,lenali,cnt,ndel,lsave,nextres,blocksize,
     $		next2)
	implicit none
	include 'gagasizes.for'
	integer ngenedel,genedel(maxres),nrem,rem(2,maxres)
	integer next2(0:maxres+1)
	integer*2 fragali1(maxres),fragali2(maxres),ali1(maxres),ali2(maxres)
	integer next1(0:maxres+1),prev1(0:maxres+1),cnt(maxres),blocksize
	integer candij(2,maxpair*4),ncand
	integer*2 d1(maxres,maxres),d2(maxres,maxres)
	real rescore(maxres,maxres),dscore(maxres,maxres)
	integer lenali,ndel,nextres(0:maxres+1)
	logical lsave
c
	real scorefun
c
	integer irem,i,j,j1,k,l,ix,jx,in,ip
	real s,dx
c
	if(ldebug)then
		write(*,*) 'This is dodeletions',ngenedel
		write(*,500) (genedel(i),i=1,ngenedel)
		write(*,500) (rem(1,i),rem(2,i),i=1,nrem)
		write(*,500) (ali1(i),i=1,38)
		write(*,500) (nextres(i),i=0,39)
	end if
c
c	delete genes
c
	do irem=1,ngenedel
		i=genedel(irem)
		j=fragali1(i)
		fragali1(i)=0
		fragali2(abs(j))=0
		do l=0,blocksize-1
			cnt(i+l)=cnt(i+l)-1
			if(cnt(i+l).lt.0) write(*,*)
     $				' WARNING: subzero cnt ' ,i,j,i+l,j+l
		end do
c
c		update prev1,next
c
		ip=prev1(i)
		in=next1(i)
		do ix=i,in
			prev1(ix)=ip
		end do
		do ix=ip,i
			next1(ix)=in
		end do
		j1=abs(j)
		in=next2(j1)
		ix=j1
		do while((ix.gt.0).and.(next2(ix-1).eq.j1))
			ix=ix-1
			next2(ix)=in
		end do
	end do
c
c	delete residues
c
	do irem=1,nrem
		i=rem(1,irem)
		j=rem(2,irem)
c
c		update nextres
c
		in=nextres(i)
		ix=i
c		write(*,*) 'nextres',in,i,nextres(ix-1)
		do while((ix.gt.0).and.(nextres(ix-1).eq.i))
			ix=ix-1
			nextres(ix)=in
c			if(ldebug)write(*,*) 'set nextres',ix,' to ',in
		end do
		if(lsave) then
c
c			update dscore(x,y), rescore(x,y)
c
			do k=1,ncand
				ix=candij(1,k)
				jx=candij(2,k)
				dx=0.0
				if((i.ne.ix).and.(j.ne.jx)) then
					s=-scorefun(d1(ix,i),d2(jx,j))
					dx=s+s
				end if
				if(ali1(ix).eq.jx) then
					rescore(ix,jx)=rescore(ix,jx)+dx
				else
					dscore(ix,jx)=dscore(ix,jx)+dx
				end if
			end do
			dscore(i,j)=rescore(i,j)
			rescore(i,j)=0.0
		end if
c
c		delete residue pair, update lenali
c
		ali1(i)=0
		ali2(j)=0
		lenali=lenali-1
		ndel=ndel+1
	end do
c
500	format(20i4)
c
	return
	end
c
c-------------------------------------------------------------------------------
c
	subroutine doadditions_lean(i,j,nnew,new,fragali1,fragali2,
     $		ali1,ali2,next1,prev1,candij,ncand,d1,d2,
     $		rescore,dscore,lenali,cnt,blocksize,nacc,lsave,nextres,
     $		next2,nres1)
	implicit none
	include 'gagasizes.for'
	integer nnew,new(2,maxres),i,j,nres1
	integer*2 fragali1(maxres),fragali2(maxres),ali1(maxres),ali2(maxres)
	integer next1(0:maxres+1),prev1(0:maxres+1),cnt(maxres)
	integer candij(2,maxpair*4),ncand
	integer*2 d1(maxres,maxres),d2(maxres,maxres)
	real rescore(maxres,maxres),dscore(maxres,maxres)
	integer lenali,blocksize,nacc,nextres(0:maxres+1),next2(0:maxres+1)
	logical lsave
c
	real scorefun
c
	integer inew,k,l,i1,j1,ix,jx,in,ip,iold,jold
	real s,dx
c
	if(ldebug)then
		write(*,*) 'This is doadditions',i,j,nnew
		write(*,500) (new(1,k),new(2,k),k=1,nnew)
		write(*,500) (ali1(k),k=1,38)
		write(*,500) (nextres(k),k=0,39)
	end if
c
c	add gene
c
	fragali1(i)=j
	if(j.lt.0) fragali2(-j)=-i
	if(j.gt.0) fragali2(j)=i
	do l=0,blocksize-1
		cnt(i+l)=cnt(i+l)+1
		if(cnt(i+l).gt.blocksize) write(*,*)
     $			' WARNING: excess cnt',i+l,j+l
	end do
c
c	update prev1,next
c
	ip=prev1(i)
	in=next1(i)
	do ix=ip,i-1
		next1(ix)=i
	end do
	do ix=i+1,in
		prev1(ix)=i
	end do
	j1=abs(j)
	in=next2(j1)
	ix=j1
	do while((ix.gt.0).and.(next2(ix-1).eq.in))
		ix=ix-1
		next2(ix)=j1
	end do
c
c	add residues
c
	do inew=1,nnew
		i1=new(1,inew)
		j1=new(2,inew)
c
c		update nextres
c
		in=nextres(i1)
		ix=i1
c		write(*,*) 'nextres',in,i,nextres(ix-1)
		do while((ix.gt.0).and.(nextres(ix-1).eq.in))
			ix=ix-1
			nextres(ix)=i1
c			if(ldebug) write(*,*) 'set nextres',ix,' to ',i1
		end do
		if(lsave) then
c
c			update dscore(x,y), rescore(x,y)
c
			do k=1,ncand
				ix=candij(1,k)
				jx=candij(2,k)
				dx=0.0
				if((i1.ne.ix).and.(j1.ne.jx)) then
					s=scorefun(d1(ix,i1),d2(jx,j1))
					dx=s+s
				end if
				if(ali1(ix).eq.jx) then
					rescore(ix,jx)=rescore(ix,jx)+dx
				else
					dscore(ix,jx)=dscore(ix,jx)+dx
				end if
				if(ldebug) write(*,510) k,i1,j1,ix,jx,
     $					dscore(ix,jx),rescore(ix,jx),dx
			end do
			rescore(i1,j1)=dscore(i1,j1)
			dscore(i1,j1)=0.0
		end if
c
c		add residue pair, update lenali
c
		iold=ali2(j1)
		jold=ali1(i1)
		if((iold.ne.0).or.(jold.ne.0)) then
			write(*,*) ' WARNING: undeleted ',i1,j1,iold,jold
			write(*,500) (ali1(k),k=1,nres1)
			write(*,500) (fragali1(k),k=1,nres1)
		end if
		if(iold.ne.0) ali1(iold)=0
		if(jold.ne.0) ali2(jold)=0
		ali1(i1)=j1
		ali2(j1)=i1
		lenali=lenali+1
		nacc=nacc+1
	end do
c
500	format(20i4)
510	format('update',5i5,3f10.3)
c
	return
	end
c
c-------------------------------------------------------------------------------
c
	subroutine appendcand_lean(i,j,blocksize,
     $		ltest,dscore,ncand,candij,
     $		ali1,ali2,nres1,d1,d2,nextres,lsave)
c
c	in: gene (i,j), where j may be negative
c	out: residue pair candidates (x,y), where y is always positive !
c
	implicit none
	include 'gagasizes.for'
	integer blocksize,nres1,i,j
	integer*2 d1(maxres,maxres),d2(maxres,maxres)
	logical lsave
	integer*2 ali1(maxres),ali2(maxres)
	logical ltest(maxres,maxres)
	integer ncand, candij(2,maxpair*4)
	integer nextres(0:maxres+1)
	real dscore(maxres,maxres)
c
	real addscore
c
	integer l,j1
c
	if(ldebug) write(*,*) 'This is appendcand',i,j,ncand,lsave
	if(lsave) then
	  do l=0,blocksize-1
	   j1=abs(j+l)
	   if(.not.ltest(i+l,j1)) then
c
c		add to residue-candidate list
c			used to update rescore(x,y),dscore(x,y)
c
		ncand=ncand+1
		candij(1,ncand)=i+l
		candij(2,ncand)=j1
		ltest(i+l,j1)=.true.
c
c		calculate dscore(i+l,j1)
c
		if(ali1(i+l).ne.j1) dscore(i+l,j1)
     $			  =addscore(i+l,j1,ali1,ali2,nextres,nres1,d1,d2)
	   end if
	  end do
	end if
c
	return
	end
c
c-------------------------------------------------------------------------------
c
	subroutine initialize_lean(cnt,ali1,ali2,fragali1,fragali2,
     $		prev1,next1,ltest,ncand,rescore,dscore,
     $		nres1,nres2,nextres,next2)
	implicit none
	include 'gagasizes.for'
	integer cnt(maxres),prev1(0:maxres+1),next1(0:maxres+1)
	integer nres1,nres2
	integer*2 ali1(maxres),ali2(maxres),fragali1(maxres),fragali2(maxres)
	logical ltest(maxres,maxres)
	integer ncand, nextres(0:maxres+1),next2(0:maxres+1)
	real rescore(maxres,maxres),dscore(maxres,maxres)
c
	integer i,j
c
	call initali1(ali1,nres1)
	call initali1(ali2,nres2)
	call initali1(fragali1,nres1)
	call initali1(fragali2,nres2)
	do i=1,nres1
		cnt(i)=0
		do j=1,nres2
			ltest(i,j)=.false.
			rescore(i,j)=0.0
			dscore(i,j)=0.0
		end do
	end do
	do i=0,nres1+1
		prev1(i)=0
		next1(i)=nres1+1
		nextres(i)=nres1+1
	end do
	do i=0,nres2+1
		next2(i)=nres2+1
	end do
	ncand=0
c
	return
	end
c
c-------------------------------------------------------------------------------
c


      SUBROUTINE INIT
      REAL MFSTOP
      LOGICAL PREVER
      COMMON /SNTCP/G,AJ,PRPC,ICASE,PREVER,MFSTOP,JUMP,LOPIN,ISCASE,
     1KN,GAMF,IP,SCRIT,PTRN,ISECT,KSTG,WTOL,RHOTOL,PRTOL,TRLOOP,LSTG,
     2LBRC,IBRC,ICHOKE,ISORR,CHOKE,PT0PS1(6,8),PTRS2(6,8),TRDIAG,SC,RC,
     3DELPR,PASS,IPC,LOPC,ISS
C
      COMMON /SINIT/H1(6,8),H2(6,8),DP0(6,8),DP1(6,8),DP1A(6,8),DP2(6,8)
     1,DP2A(6,8),CSALF1(6,8),ALF1(6,8),CSBET2(6,8),BET2(6,8),RADSD(6,8),
     2RADRD(6,8),ANN1(6,8),ANN2(6,8),ANN2A(6,8),ANN1A(6,8),U1A(6,8),
     3U2(6,8),ANN0(6,8),PT0(6,8),TT0(6,8),ALPHA0(6,8),PTP(6,8)
C
      COMMON /SINPUT/
     1PTPS,PTIN,TTIN,WAIR,FAIR,DELC,DELL,DELA,AACS,VCTD,STG,SECT,EXPN,
     2EXPP,EXPRE,RG,RPM,PAF,SLI,STGCH,ENDJOB,XNAME(20),TITLE(20),
     3PCNH(6),GAM(6,8),DR(6,8),DT(6,8),RWG(6,8),ALPHAS(6,8),ALPHA1(6,8),
     4ETARS(6,8),ETAS(6,8),CFS(6,8),ANDO(6,8),BETA1(6,8),BETA2(6,8),ETAR
     5R(6,8),ETAR(6,8),CFR(6,8),TFR(6,8),ANDOR(6,8),OMEGAS(6,8),AS0(6,8)
     6,ASMP0(6,8),ACMN0(6,8),A1(6,8),A2(6,8),A3(6,8),A4(6,8),A5(6,8),A6(
     76,8),OMEGAR(6,8),BSIA(6,8),BSMPIA(6,8),BCMNIA(6,8),B1(6,8),B2(6,8)
     8,B3(6,8),B4(6,8),B5(6,8),B6(6,8),SESTHI(8),RERTHI(8)
     9,fairx(5,8),wairx(5,8),rg1(8),rg1a(8),rg2(8),rg2a(8)
      COMMON/SADIN2/PTINH(6),TTINH(6),ALF0H(6)
      COMMON/RPMCOM/RPMK(8)
      COMMON/DESOPT/RVU1(6,8),RVU2(6,8),WG,EPR
      dimension arh(4),arm(4),arl(4),car(4),cxs(8),cxr(8)
      dimension tangms(6,8),tangmr(6,8),tangm1(6,8),tangm2(6,8),tang0(6)
      common/slope/tangms,tangmr,tangm1,tangm2,tang0,iar,icyl
      COMMON    D(6),RES(8),                H1A(6  ),H0(6  ),H2A(6  )
      DATA KFIT/-2/
      DATA ARH/5.7162E-3,2.0062E-4,0.58705,-1.1622/
      DATA ARM/3.0740E-2,2.5228E-4,0.57930,-1.1487/
      DATA ARL/6.6559E-2,2.2132E-4,0.47043,-0.86488/
C
C     READ INPUT DATA, CHECK FOR ERRORS,
C          SKIP CHANGE CASES IF BASIC CASE HAS AN ERROR
C
3     CALL INPUT
      ICASE=ICASE+1
c     IF(STGCH)5,5,4
4     IK=1
   5  l=2
      GO TO(6,8),L
6     WRITE(16,100)ICASE
C     IF(STGCH)3,3,7
C     replaced by .............
      IF(STGCH.LE.0.) THEN
         GO TO 3
      ELSE
         GO TO 7
      ENDIF
7     IK=2
      GO TO 3
C8     IF (IK-2)9,3,3
C     replaced by .............
8     IF((IK-2).LT.0) THEN
         GO TO 9
      ELSE
         GO TO 3
      ENDIF
C        INITIALIZE INDEX REGISTERS AND FORKS
9     ISECT=SECT+.0001
      KSTG= STG+.0001
      LOPC=0
      CHOKE=0.
      ICHOKE=0
      ISORR=1
      KN=1
      LSTG=1
      IBRC=1
      LBRC=1
      DELPR=DELC
      SC=0.0
      RC=0.0
      PRPC=0.0
      IPC=0
      ISS=0
      PTRN=0.0
C        TEST STAGE LOSS INDICATOR
C     IF(SLI)13,13,11
C     replaced by .............
      IF(SLI.LE.0.) THEN
         GO TO 13
      ELSE
         GO TO 11
      ENDIF
11    DO 12 I=1,ISECT
      DO 12 J=1,KSTG
      ETARS(I,J)=ETARS(I,1)
      ETAS(I,J)=ETAS(I,1)
      CFS(I,J)=CFS(I,1)
      ETARR(I,J)=ETARR(I,1)
      ETAR(I,J)=ETAR(I,1)
      CFR(I,J)=CFR(I,1)
      TFR(I,J)=TFR(I,1)
12    CONTINUE
C        TEST FOR EQUAL SECTORS
13    CONTINUE
      IF(PTINH(ISECT).NE. 0.) PTIN= 0.
      IF(TTINH(ISECT).NE. 0.) TTIN= 0.
      IF(PCNH(1).NE.1.)GO TO 43
      DO 42 I=1,ISECT
42    PCNH(I)=1./SECT
43    DO 15 I=1,ISECT
      IF(PTINH(ISECT).NE. 0.) PTIN= PTIN + PCNH(I)*PTINH(I)
      IF(TTINH(ISECT).NE. 0.) TTIN= TTIN + PCNH(I)*TTINH(I)
      IF(PTINH(ISECT).EQ. 0.) PTINH(I)= PTIN
      PTP(I,1)= PTINH(I)
      PT0(I,1)= PTINH(I)
      IF(TTINH(ISECT).EQ. 0.) TTINH(I)= TTIN
      TT0(I,1)= TTINH(I)
      IF(ALF0H(ISECT).EQ. 0.) ALF0H(I)= 0.
      ALPHA0(I,1)= ALF0H(I)* .017453
      if (icyl.eq.1) alpha0(i,1)=atan(tan(alpha0(i,1))
     & *cos(atan(tang0(i))))
      PT0PS1(I,1)= PTPS
15    CONTINUE
      IF(ICASE.EQ.1)GO TO 16
      DO 150 K=1,KSTG
      KF=KFIT
      CALL BESFIT(ISECT,DP0 (1,K),RADSD(1,K),KF  ,D,RES)
      KFIT1=IABS(KF)+1
      DO 155 I=1,ISECT
      RADSD(I,K)=0.
      DRP=1.
      DO 155 ID=1,KFIT1
      RADSD(I,K)= RADSD(I,K)+DRP*D(ID)
155   DRP=DRP*DP0  (I,K)
      KF=KFIT
      CALL BESFIT(ISECT,DP1 (1,K),ALF1 (1,K),KF  ,D,RES)
      KFIT1=IABS(KF)+1
      DO 165 I=1,ISECT
      ALF1(I,K)=0.
      DRP=1.
      DO 165 ID=1,KFIT1
      ALF1  (I,K)= ALF1  (I,K)+DRP*D(ID)
165   DRP=DRP*DP1  (I,K)
      KF=KFIT
      CALL BESFIT(ISECT,DP1A(1,K),RADRD(1,K),KF  ,D,RES)
      KFIT1=IABS(KF)+1
      DO 175 I=1,ISECT
      RADRD(I,K)=0.
      DRP=1.
      DO 175 ID=1,KFIT1
      RADRD (I,K)= RADRD (I,K)+DRP*D(ID)
175   DRP=DRP*DP1A  (I,K)
      KF=KFIT
      CALL BESFIT(ISECT,DP2 (1,K),BET2 (1,K),KF  ,D,RES)
      KFIT1=IABS(KF)+1
      DO 185 I=1,ISECT
      BET2(I,K)=0.
      DRP=1.
      DO 185 ID=1,KFIT1
      BET2  (I,K)= BET2  (I,K)+DRP*D(ID)
185   DRP=DRP*DP2   (I,K)
150   CONTINUE
C        SET UP SECTOR HEIGHT, PITCH DIAMETER, ANNULUS AREA,
C             PITCHLINE WHEEL SPEED
16    DO 19 K=1,KSTG
      SH0=DT(1,K)-DR(1,K)
      SH1=DT(2,K)-DR(2,K)
      SH1A=DT(3,K)-DR(3,K)
      SH2=DT(4,K)-DR(4,K)
      SH2A=DT(5,K)-DR(5,K)
      DO 18 I=1,ISECT
      H0(I  )=.5*PCNH(I)*SH0
      H1(I,K)=.5*PCNH(I)*SH1
      H1A(I  )=.5*PCNH(I)*SH1A
      H2(I,K)=.5*PCNH(I)*SH2
      H2A(I  )=.5*PCNH(I)*SH2A
C     IF(I-1)20,20,17
C     replaced by .............
      IF((I-1).LE.0) THEN
         GO TO 20
      ELSE
         GO TO 17
      ENDIF
20    DP0(I,K)=DR(1,K)+   H0(I  )
      DP1(I,K)=DR(2,K)+   H1(I,K)
      DP1A(I,K)=DR(3,K)+   H1A(I  )
      DP2(I,K)=DR(4,K)+   H2(I,K)
      DP2A(I,K)=DR(5,K)+   H2A(I  )
      GO TO 21
17    DP0(I,K)=        H0(I-1  )+   H0(I  )+DP0(I-1,K)
      DP1(I,K)=        H1(I-1,K)+   H1(I,K)+DP1(I-1,K)
      DP1A(I,K)=        H1A(I-1  )+   H1A(I  )+DP1A(I-1,K)
      DP2(I,K)=        H2(I-1,K)+   H2(I,K)+DP2(I-1,K)
      DP2A(I,K)=        H2A(I-1  )+   H2A(I  ) +DP2A(I-1,K)
21    ANN0(I,K)=.02182*DP0(I,K)*H0(I  )
      ANN1(I,K)=.02182*DP1(I,K)*H1(I,K)
      ANN1A(I,K)=DP1A(I,K)*H1A(I  )*.02182
      ANN2(I,K)=.02182*DP2(I,K)*H2(I,K)
      ANN2A(I,K)=.02182*DP2A(I,K)*H2A(I  )
      U2(I,K)= 3.14159*DP2(I,K)*RPMK(K)/720.0
      U1A(I,K)= 3.14159*DP1A(I,K)*RPMK(K)/720.0
18    CONTINUE
19    CONTINUE
C        DEFINE PITCHLINE INDEX
      IT=ISECT-2*(ISECT/2)
C     IF(IT)22,22,23
C     replaced by .............
      IF(IT.LE.0) THEN
         GO TO 22
      ELSE
         GO TO 23
      ENDIF
22    IP=ISECT/2
      GO TO 24
23    IP=(ISECT+1)/2
24    CONTINUE
c        Set Axial-Chord Correlation Coefficients
      IF (IAR.EQ.1) THEN
        DO 300 I=1,4
        CAR(I) = ARH(I)
  300   CONTINUE
      ELSE IF (IAR.EQ.2) THEN
        DO 310 I=1,4
        CAR(I) = ARM(I)
  310   CONTINUE
      ELSE if (iar.eq.3) then
        DO 320 I=1,4
        CAR(I) = ARL(I)
  320   CONTINUE
      else if (iar.ge.10.and.iar.le.20) then
        car2=(float(iar)-10.)/10.
        car1=1.0-car2
        do 321 i=1,4
        car(i)=car1*arh(i)+car2*arm(i)
  321   continue
      else if (iar.gt.20.and.iar.le.30) then
        car3=(float(iar)-20.)/10.
        car2=1.0-car3
        do 322 i=1,4
        car(i)=car2*arm(i)+car3*arl(i)
  322   continue
      END IF
c        Calculate Axial Chords and Sector Slopes
      if (iar.ne.0) then
        sumcx=0.0
        do 330 k=1,kstg
        cxs(k)=car(1)*dp1(ip,k)+car(2)*dp1(ip,k)**2+car(3)+
     &         car(4)/dp1(ip,k)
        cxr(k)=car(1)*dp2(ip,k)+car(2)*dp2(ip,k)**2+car(3)+
     &         car(4)/dp2(ip,k)
        sumcx=sumcx+cxs(k)+cxr(k)
        do 325 i=1,isect
        tangms(i,k)=(dp1(i,k)-dp0(i,k))/2./cxs(k)
        tangmr(i,k)=(dp2(i,k)-dp1a(i,k))/2./cxr(k)
  325   continue
  330   continue
        sumcx=4./3.*sumcx-cxr(kstg)/3.
      else
        do 340 k=1,kstg
        do 335 i=1,isect
        tangms(i,k)=0.0
        tangmr(i,k)=0.0
  335   continue
  340   continue
        sumcx=0.0
      end if
      do 350 i=1,isect
      tang0(i)=(tangms(i,1)+tangms(ip,1))/2.
  350 continue
      do 360 k=1,kstg
      do 355 i=1,isect
      tangm1(i,k)=(tangms(i,k)+tangmr(i,k))/2.
      if (k.ne.kstg) then
        tangm2(i,k)=(tangmr(i,k)+tangms(i,k+1))/2.
      else
        tangm2(i,k)=(tangmr(i,k)+tangmr(ip,k))/2.
      end if
  355 continue
  360 continue
      write (16,400) sumcx
  400 format (1h0,' TURBINE LENGTH = ',f6.2,' INCHES')
C        CALCULATE INLET AND EXIT ANGLES IN RADIANS
      DO 31 K=1,KSTG
C     IF(ALPHA1(1,K))27,25,27
C     replaced by .............
      IF((ALPHA1(1,K)).NE.0.) THEN
         GO TO 27
      ELSE
         GO TO 25
      ENDIF
C25    IF(ANDO(1,K))31,31,125
C     replaced by .............
25    IF((ANDO(1,K)).LE.0.) THEN
         GO TO 31
      ELSE
         GO TO 125
      ENDIF
125   DO 26 I=1,ISECT
      CSALF1(I,K)=ANDO(I,K)*CFS(I,K)/(SESTHI(K)*3.14159*DP1(I,K)*
     1SQRT(ETAS(I,K)))
26    ALF1(I,K)=ATAN2(SQRT(1.-CSALF1(I,K)*CSALF1(I,K)),CSALF1(I,K))
      GO TO 31
27    DO 28 I=1,ISECT
      ALF1(I,K)=    ALPHA1(I,K)*.017453
      if (icyl.eq.1) alf1(i,k)=atan(tan(alf1(i,k))
     & *cos(atan(tangm1(i,k))))
28    CSALF1(I,K)=COS(ALF1(I,K))
31    CONTINUE
      DO 130 K=1,KSTG
C     IF(BETA2(1,K))32,29,32
C     replaced by .............
      IF((BETA2(1,K)).NE.0.) THEN
         GO TO 32
      ELSE
         GO TO 29
      ENDIF
C29    IF(ANDOR(1,K))130,130,129
C     replaced by .............
29    IF((ANDOR(1,K)).LE.0.) THEN
         GO TO 130
      ELSE
         GO TO 129
      ENDIF
129   DO 30 I=1,ISECT
      CSBET2(I,K)=ANDOR(I,K)*CFR(I,K)/(RERTHI(K)*3.14159*DP2(I,K)*
     1SQRT(ETAR(I,K)))
30    BET2(I,K)=ATAN2( SQRT(1.-CSBET2(I,K)*CSBET2(I,K)),CSBET2(I,K))
      GO TO 130
32    DO 33 I=1,ISECT
      BET2(I,K)=    BETA2(I,K)*.017453
      if (icyl.eq.1) bet2(i,k)=atan(tan(bet2(i,k))
     & *cos(atan(tangm2(i,k))))
33    CSBET2(I,K)=COS(BET2(I,K))
130   CONTINUE
      DO 35 K=1,KSTG
      DO 35 I=1,ISECT
      IF(ALPHAS(I,K).NE.0.)
     *RADSD(I,K)=ALPHAS(I,K)*.017453
      if (icyl.eq.1.and.k.eq.1) radsd(i,k)=atan(tan(radsd(i,k))
     & *cos(atan(tang0(i))))
      if (icyl.eq.1.and.k.gt.1) radsd(i,k)=atan(tan(radsd(i,k))
     & *cos(atan(tangm2(i,k-1))))
      IF(BETA1(I,K).NE.0.)
     *RADRD(I,K)=BETA1(I,K)*.017453
      if (icyl.eq.1) radrd(i,k)=atan(tan(radrd(i,k))
     & *cos(atan(tangm1(i,k))))
35    continue
C     IF(RG)36,36,37
C     replaced by .............
      IF(RG.LE.0.) THEN
         GO TO 36
      ELSE
         GO TO 37
      ENDIF
36    CALL R(PTIN,TTIN,FAIR,WAIR,RG)
      GAMF=0.0
      GO TO 38
37    GAMF=1.0
38    continue
      do 420 k=1,kstg
      rg1(k)=rg
      rg1a(k)=rg
      rg2(k)=rg
      rg2a(k)=rg
  420 continue
      if (fair.eq.0.0.and.wair.eq.0.0) go to 40
      do 440 k=1,kstg
      do 430 i=2,5
      fairx(i,k)=fair/(1.+(rwg(i,k)-1.)*(1.+fair))
      wairx(i,k)=wair/(1.+(rwg(i,k)-1.)*(1.+wair))
      if (i.eq.2) call r(ptin,ttin,fairx(2,k),wairx(2,k),rg1(k))
      if (i.eq.3) call r(ptin,ttin,fairx(3,k),wairx(3,k),rg1a(k))
      if (i.eq.4) call r(ptin,ttin,fairx(4,k),wairx(4,k),rg2(k))
      if (i.eq.5) call r(ptin,ttin,fairx(5,k),wairx(5,k),rg1a(k))
  430 continue
  440 continue
   40 continue
      RETURN
100   FORMAT(28X,6HCASE  ,I5,13H HAS AN ERROR)
      END


module burner_module

   use bl_types
   use bl_constants_module
   use bl_error_module
   use eos_module, only: eos_input_rt, eos
   use eos_type_module
   use network
   use bdf
   use parallel

   private
   public :: burner, burner_vec

   !integer, public, save :: nst = 0
   !integer, public, save :: nfe = 0
   !integer, public, save :: nje = 0
   !integer, public, save :: nlu = 0
   !integer, public, save :: nit = 0

contains

   !subroutine burner(dens, temp, Xin, dt, Xout, rho_omegadot, rho_Hnuc)

   !   ! A wrapper for compatibility purposes
   !   ! outputs:
   !   !   Xout are the mass fractions after burning through timestep dt
   !   !   rho_omegadot = rho dX/dt
   !   !   rho_Hnuc = - sum_k q_k rho_omegadot_k  [erg / cm^3 / s]

   !   use burner_data
   !   use bdf

   !   implicit none

   !   !!Arguments
   !   real(kind=dp_t), intent(in   ) :: dens, temp, Xin(:), dt
   !   real(kind=dp_t), intent(  out) :: Xout(:), rho_omegadot(:), rho_Hnuc

   !   real(kind=dp_t) :: dens_arr(1), temp_arr(1), Xin_arr(nspec,1)
   !   real(kind=dp_t) :: Xout_arr(nspec,1), rho_omegadot_arr(nspec,1), rho_Hnuc_arr(1)

   !   dens_arr(1) = dens
   !   temp_arr(1) = temp
   !   Xin_arr(:,1) = Xin(:)

   !   call burner_vec(dens_arr, temp_arr, Xin_arr, dt, Xout_arr, &
   !                   rho_omegadot_arr, rho_Hnuc_arr)
   !
   !   Xout(:) = Xout_arr(:,1)
   !   rho_omegadot(:) = rho_omegadot_arr(:,1)
   !   rho_Hnuc = rho_Hnuc_arr(1)

   !end subroutine burner

   subroutine burner(dens, temp, Xin, dt, Xout, rho_omegadot, rho_Hnuc)
   !$acc routine seq

      ! outputs:
      !   Xout are the mass fractions after burning through timestep dt
      !   rho_omegadot = rho dX/dt
      !   rho_Hnuc = - sum_k q_k rho_omegadot_k  [erg / cm^3 / s]

      use burner_data, only: neqs, burn_max_order, burn_npts, reset, reuse,    &
                             burn_npts, irp_dens, irp_cp, irp_dhdx, irp_o16,   &
                             irp_rate, irp_dratedt, irp_sc1212, irp_dsc1212dt, &
                             irp_xc12tmp, n_rpar_comps
      use network, only: nspec, nspec_advance, ic12_, io16_, img24_
      use bdf

      implicit none

      !!Arguments
      real(kind=dp_t), intent(in   ) :: dens, temp, Xin(nspec), dt
      real(kind=dp_t), intent(  out) :: Xout(nspec), rho_omegadot(nspec), rho_Hnuc

      !!Local constants
      real(kind=dp_t), parameter :: DT0 = 1.0d-9 !Initial dt to be used in getting from
                                                 !t to tout.  This is arbitrary,
                                                 !multiple values should be
                                                 !explored, or an optimal value
                                                 !should be calculated.
      !!Local variables
      integer :: n, i, j, npt, ierr, ierr_tot  ! npt is the size of the vectors
                                           !passed in, basically the number of
                                           !hydro cells.
      !logical, save :: firstCall = .true.
      real(kind=dp_t), dimension(neqs) :: y, atol, rtol   ! input state, abs and rel tolerances
      real(kind=dp_t) :: eos_cp, eos_dhdX(nspec)
      real(kind=dp_t) :: upar(n_rpar_comps, burn_npts), y0(neqs, burn_npts), y1(neqs, burn_npts)
      real(kind=dp_t) :: t0, t1, enuc, dX
      type(eos_t)  :: eos_state
      type(bdf_ts) :: ts

      !!Execution
      !if (firstCall) then

      !   if (.NOT. network_initialized) then
      !      call bl_error("ERROR in burner: must initialize network first")
      !   endif
      !
      !   ic12 = network_species_index("carbon-12")
      !   io16 = network_species_index("oxygen-16")
      !   img24 = network_species_index("magnesium-24")
      !
      !   if (ic12 < 0 .OR. io16 < 0 .OR. img24 < 0) then
      !      call bl_error("ERROR in burner: species undefined")
      !   endif
      !
      !   firstCall = .false.
      !endif

      ! configure data that's the same for all pts

      ! set the tolerances.  We will be more relaxed on the temperature
      ! since it is only used in evaluating the rates.
      atol(1:nspec_advance) = 1.d-12    ! mass fractions
      atol(nspec_advance+1) = 1.d-8     ! temperature
      rtol(1:nspec_advance) = 1.d-12    ! mass fractions
      rtol(nspec_advance+1) = 1.d-5     ! temperature

      ierr_tot = 0
      ! Call EoS.  Maestro's being redesigned to have already done
      ! this, so this is just a temporary hack for the purposes of rapid GPU development.
      ! we need the specific heat at constant pressure and dhdX |_p.  Take
      ! T, rho, Xin as input
      eos_state%rho   = dens
      eos_state%T     = temp
      do i = 1, nspec
         eos_state%xn(i) = Xin(i)
      enddo

      !call eos(eos_input_rt, eos_state)

      eos_cp = eos_state%cp
      do i = 1, nspec
         eos_dhdX(i) = eos_state%dhdX(i)
      enddo

      ! Build the bdf_ts time-stepper object
      call bdf_ts_build(ts, rtol, atol, upar)

      ! abundances are the first nspec_advance values and temperature is the last
      y(ic12_) = Xin(ic12_)
      y(nspec_advance+1) = temp

      ! density, specific heat at constant pressure, c_p, and dhdX are needed
      ! in the righthand side routine, so we will pass these in through the
      ! burner_aux module.
      !
      ! Since evaluating the EOS is expensive, we don't call it for every RHS
      ! call -- instead we freeze these values over the timestep.
      ! Since we are only integrating C12, we will need the O16 mass fraction
      ! in the RHS routine to compute the screening (and we know that the
      ! Mg24 abundance is constraint so things add to 1).
      ts%upar(irp_dens,1) = dens
      !ts%upar(irp_cp,1)   = eos_cp
      ts%upar(irp_cp,1)   = 19451875.637384996
      !ts(i)%upar(irp_dhdX:irp_dhdX-1+nspec,1) = eos_dhdX(i)
      j=1
      do i = irp_dhdX, irp_dhdX-1+nspec
         !We replace the array notation assignment commented out above
         !because such operations often cause errors on GPU.
         ts%upar(i,1) = eos_dhdX(j)
         j = j + 1
      end do
      ts%upar(irp_o16,1)  = Xin(io16_)

      !y0(:,1) = y
      do i = 1, neqs
         y0(i,1) = y(i)
      end do
      t0 = ZERO
      t1 = dt
      call bdf_advance(ts, y0, t0, y1, t1, &
                       DT0, reset, reuse, ierr, .true.)
      !y = y1(:,1)
      do i = 1, neqs
         y(i) = y1(i,1)
      end do
      ierr_tot = ierr_tot + ierr

      ! store the new mass fractions -- note, we discard the temperature
      ! here and instead compute the energy release from the binding
      ! energy -- make sure that they are positive
      Xout(ic12_)  = max(y(ic12_), ZERO)
      Xout(io16_)  = Xin(io16_)
      Xout(img24_) = ONE - Xout(ic12_) - Xout(io16_)

      ! compute the energy release.  Our convention is that the binding
      ! energies are negative, so the energy release is
      ! - sum_k { (Xout(k) - Xin(k)) ebin(k) }
      !
      ! since this version of the network only evolves C12, we can
      ! compute the energy release easily
      enuc = (ebin(img24_) - ebin(ic12_))*(Xout(ic12_) - Xin(ic12_))

      ! also compute the density-weighted creation rates, rho_omegadot
      do i = 1, nspec
         dX = Xout(i) - Xin(i)
         rho_omegadot(i) = dens * dX / dt
      enddo

      rho_Hnuc = dens*enuc/dt

      call bdf_ts_destroy(ts)

      !TODO: Here I'm using fact I know success is 0, need to update this since
      !      we're looping over cells and have ierr_tot now instead of single ierr
      !if (ierr_tot /= BDF_ERR_SUCCESS) then
      !   print *, 'ERROR: integration failed'
      !   print *, 'sum(ierr) for all GPU threads: ', ierr_tot
      !   call  bl_error("ERROR in burner: integration failed")
      !endif

      !TODO: This worked for dvode -- implement in bdf
      !nst = nst + iwork(11)
      !nfe = nfe + iwork(12)
      !nje = nje + iwork(13)
      !nlu = nlu + iwork(19)
      !nit = nit + iwork(20)
   end subroutine burner
end module burner_module


c               Copyright 1993 Colorado State University
c                       All Rights Reserved

C ... MNRACC.F

      subroutine mnracc (mnrflo,gross,net)

      implicit none

c ... Argument declarations
      double precision mnrflo, gross, net

c ... Update mineralization accumulators.
c ... written by vek 05/91

c ... Input:
c ...   mnrflo = mineralization value returned by esched.
c ...            A negative value indicates immobilization.
c ...
c ... Transput:
c ...   gross = gross mineralization (sums only mineralization, not
c ...           immoblization)
c ...   net   = net mineralization (mineralization - immobilization)

c ... Gross mineralization
      if (mnrflo .gt. 0.0) then
        gross = gross + mnrflo
      endif

c ... Net mineralization
      net = net + mnrflo

      return
      end


ACCEPTABLE LEFT PRIMERS
                                  1-based     #               self  self  qual-
   # sequence                       start ln  N   GC%     Tm   any   end   lity
   0 TATTCCTGTCCCTGTGCCTC              49 20  0 55.00 60.073  2.00  1.00  0.073
   1 GCCTCAGAAACCTGGCTACA              64 20  0 55.00 60.397  3.00  1.00  0.397
   2 TGCCTCAGAAACCTGGCTAC              63 20  0 55.00 60.397  3.00  3.00  0.397
   3 GTGCCTCAGAAACCTGGCTA              62 20  0 55.00 60.397  3.00  2.00  0.397
   4 CTGTCCCTGTGCCTCAGAA               54 19  0 57.89 59.963  5.00  1.00  1.037
   5 ATTCCTGTCCCTGTGCCTC               50 19  0 57.89 60.064  2.00  1.00  1.064
   6 AATATTCCTGTCCCTGTGCC              47 20  0 50.00 58.864  6.00  1.00  1.136
   7 AATATTCCTGTCCCTGTGCCT             47 21  0 47.62 59.841  6.00  0.00  1.159
   8 CCCTGTGCCTCAGAAACCT               58 19  0 57.89 60.245  5.00  0.00  1.245
   9 TGTCCCTGTGCCTCAGAAAC              55 20  0 55.00 61.259  5.00  5.00  1.259
  10 ATATTCCTGTCCCTGTGCCTC             48 21  0 52.38 60.342  4.00  1.00  1.342
  11 GAAACCTGGCTACAGTTCCC              70 20  0 55.00 58.646  3.00  3.00  1.354
  12 AAACCTGGCTACAGTTCCCTC             71 21  0 52.38 59.630  3.00  0.00  1.370
  13 GAAACCTGGCTACAGTTCCCT             70 21  0 52.38 59.630  3.00  1.00  1.370
  14 AGAAACCTGGCTACAGTTCCC             69 21  0 52.38 59.630  3.00  3.00  1.370
  15 TGTCCCTGTGCCTCAGAAA               55 19  0 52.63 60.385  5.00  3.00  1.385
  16 CTGTCCCTGTGCCTCAGAAA              54 20  0 55.00 61.390  5.00  3.00  1.390
  17 GTGCCTCAGAAACCTGGCT               62 19  0 57.89 60.402  3.00  3.00  1.402
  18 TGCCTCAGAAACCTGGCTA               63 19  0 52.63 59.531  3.00  2.00  1.469
  19 ATATTCCTGTCCCTGTGCCT              48 20  0 50.00 58.473  4.00  0.00  1.527
  20 CTGTGCCTCAGAAACCTGG               60 19  0 57.89 59.399  5.00  3.00  1.601
  21 CCTGTGCCTCAGAAACCTG               59 19  0 57.89 59.399  5.00  2.00  1.601
  22 AACCTGGCTACAGTTCCCTC              72 20  0 55.00 58.255  3.00  0.00  1.745
  23 GTCCCTGTGCCTCAGAAACC              56 20  0 60.00 62.024  5.00  3.00  2.024
  24 TAATATTCCTGTCCCTGTGCC             46 21  0 47.62 58.917  6.00  1.00  2.083
  25 TAATATTCCTGTCCCTGTGCCT            46 22  0 45.45 59.856  6.00  0.00  2.144
  26 TCCCTGTGCCTCAGAAACCT              57 20  0 55.00 62.145  5.00  0.00  2.145
  27 CAGAAACCTGGCTACAGTTCC             68 21  0 52.38 58.851  3.00  2.00  2.149
  28 CCTCAGAAACCTGGCTACAGTT            65 22  0 50.00 59.810  3.00  2.00  2.190
  29 GTGCCTCAGAAACCTGGCTAC             62 21  0 57.14 61.195  3.00  3.00  2.195
  30 TTAATATTCCTGTCCCTGTGCC            45 22  0 45.45 60.204  6.00  1.00  2.204
  31 AAACCTGGCTACAGTTCCCT              71 20  0 50.00 57.789  3.00  1.00  2.211
  32 TCCCTGTGCCTCAGAAACC               57 19  0 57.89 61.213  5.00  1.00  2.213
  33 TTCCTGTCCCTGTGCCTC                51 18  0 61.11 59.749  2.00  1.00  2.251
  34 GCCTCAGAAACCTGGCTACAG             64 21  0 57.14 61.316  3.00  3.00  2.316
  35 CCTGTCCCTGTGCCTCAG                53 18  0 66.67 60.405  5.00  5.00  2.405
  36 CCTCAGAAACCTGGCTACAG              65 20  0 55.00 57.547  3.00  3.00  2.453
  37 TGCCTCAGAAACCTGGCT                63 18  0 55.56 59.499  3.00  3.00  2.501
  38 AGAAACCTGGCTACAGTTCCCT            69 22  0 50.00 60.528  3.00  2.00  2.528
  39 CCTCAGAAACCTGGCTACAGT             65 21  0 52.38 58.468  3.00  3.00  2.532
  40 GTGCCTCAGAAACCTGGC                62 18  0 61.11 59.345  3.00  2.00  2.655
  41 TCAGAAACCTGGCTACAGTTCC            67 22  0 50.00 60.661  3.00  2.00  2.661
  42 GTCCCTGTGCCTCAGAAAC               56 19  0 57.89 58.201  5.00  5.00  2.799
  43 CCCTGTGCCTCAGAAACC                58 18  0 61.11 59.180  5.00  1.00  2.820
  44 TATTCCTGTCCCTGTGCCT               49 19  0 52.63 58.086  2.00  0.00  2.914
  45 ATTCCTGTCCCTGTGCCTCA              50 20  0 55.00 62.996  3.00  3.00  2.996
  46 CTGTCCCTGTGCCTCAGAAAC             54 21  0 57.14 62.180  5.00  5.00  3.180
  47 TGTCCCTGTGCCTCAGAA                55 18  0 55.56 58.812  5.00  1.00  3.188
  48 GAAACCTGGCTACAGTTCCCTC            70 22  0 54.55 61.364  3.00  0.00  3.364
  49 TGTGCCTCAGAAACCTGGC               61 19  0 57.89 62.397  3.00  2.00  3.397
  50 ATTAATATTCCTGTCCCTGTGCC           44 23  0 43.48 60.438  6.00  1.00  3.438
  51 TCCTGTCCCTGTGCCTCA                52 18  0 61.11 61.468  3.00  3.00  3.468
  52 CCTGTCCCTGTGCCTCAGA               53 19  0 63.16 62.470  5.00  3.00  3.470
  53 TCCTGTCCCTGTGCCTCAG               52 19  0 63.16 62.470  5.00  5.00  3.470
  54 GCCTCAGAAACCTGGCTAC               64 19  0 57.89 57.465  3.00  3.00  3.535
  55 AATATTCCTGTCCCTGTGCCTC            47 22  0 50.00 61.574  6.00  1.00  3.574
  56 ATATTCCTGTCCCTGTGCC               48 19  0 52.63 57.370  4.00  1.00  3.630
  57 CTGTCCCTGTGCCTCAGA                54 18  0 61.11 58.348  5.00  3.00  3.652
  58 TGTGCCTCAGAAACCTGG                61 18  0 55.56 58.249  3.00  3.00  3.751
  59 CTCAGAAACCTGGCTACAGTTC            66 22  0 50.00 58.135  3.00  2.00  3.865
  60 TTCCTGTCCCTGTGCCTCA               51 19  0 57.89 62.869  3.00  3.00  3.869
  61 GTCCCTGTGCCTCAGAAACCT             56 21  0 57.14 62.881  5.00  0.00  3.881
  62 TATTCCTGTCCCTGTGCCTCA             49 21  0 52.38 62.891  3.00  3.00  3.891
  63 TCAGAAACCTGGCTACAGTTC             67 21  0 47.62 57.065  3.00  2.00  3.935
  64 ATTCCTGTCCCTGTGCCT                50 18  0 55.56 57.991  2.00  0.00  4.009
  65 TTAATATTCCTGTCCCTGTGCCT           45 23  0 43.48 61.044  6.00  0.00  4.044
  66 GCCTCAGAAACCTGGCTACAGT            64 22  0 54.55 62.045  3.00  3.00  4.045
  67 CAGAAACCTGGCTACAGTTCCC            68 22  0 54.55 62.245  3.00  3.00  4.245
  68 TATTAATATTCCTGTCCCTGTGCC          43 24  0 41.67 60.432  8.00  1.00  4.432
  69 CTCAGAAACCTGGCTACAGTTCC           66 23  0 52.17 61.514  3.00  2.00  4.514
  70 CCTCAGAAACCTGGCTACAGTTC           65 23  0 52.17 61.514  3.00  2.00  4.514
  71 TAATATTCCTGTCCCTGTGCCTC           46 23  0 47.83 61.529  6.00  1.00  4.529
  72 TCCCTGTGCCTCAGAAAC                57 18  0 55.56 57.158  5.00  3.00  4.842
  73 GTCCCTGTGCCTCAGAAA                56 18  0 55.56 57.158  5.00  3.00  4.842
  74 ATTAATATTCCTGTCCCTGTGC            44 22  0 40.91 57.155  6.00  2.00  4.845
  75 AGAAACCTGGCTACAGTTCCCTC           69 23  0 52.17 62.164  3.00  0.00  5.164
  76 ATTAATATTCCTGTCCCTGTGCCT          44 24  0 41.67 61.230  6.00  0.00  5.230
  77 ATATTAATATTCCTGTCCCTGTGCC         42 25  0 40.00 60.638 10.00  1.00  5.638
  78 TATTAATATTCCTGTCCCTGTGC           43 23  0 39.13 57.263  8.00  2.00  5.737
  79 AAATATTAATATTCCTGTCCCTGTGC        40 26  0 34.62 59.917 12.00  2.00  6.083
  80 AATATTAATATTCCTGTCCCTGTGC         41 25  0 36.00 58.823 12.00  2.00  6.177
  81 TATTAATATTCCTGTCCCTGTGCCT         43 25  0 40.00 61.200  8.00  0.00  6.200
  82 ATATTAATATTCCTGTCCCTGTGC          42 24  0 37.50 57.627 10.00  2.00  6.373
  83 TTAATATTCCTGTCCCTGTGCCTC          45 24  0 45.83 62.607  6.00  1.00  6.607
  84 CAAATATTAATATTCCTGTCCCTGTG        39 26  0 34.62 59.176 12.00  1.00  6.824
  85 TCAAATATTAATATTCCTGTCCCTG         38 25  0 32.00 57.690 12.00  1.00  7.310
  86 ATATTAATATTCCTGTCCCTGTGCCT        42 26  0 38.46 61.365 10.00  0.00  7.365
  87 CTCAAATATTAATATTCCTGTCCCTG        37 26  0 34.62 58.540 12.00  1.00  7.460
  88 TCAAATATTAATATTCCTGTCCCTGT        38 26  0 30.77 58.425 12.00  0.00  7.575
  89 TCAAATATTAATATTCCTGTCCCTGTG       38 27  0 33.33 60.641 12.00  1.00  7.641
  90 AATATTAATATTCCTGTCCCTGTGCC        41 26  0 38.46 61.650 12.00  1.00  7.650
  91 ATTAATATTCCTGTCCCTGTGCCTC         44 25  0 44.00 62.718  6.00  1.00  7.718
  92 CTCAAATATTAATATTCCTGTCCCTGT       37 27  0 33.33 59.222 12.00  0.00  7.778
  93 TATTAATATTCCTGTCCCTGTGCCTC        43 26  0 42.31 62.643  8.00  1.00  8.643
  94 CAAATATTAATATTCCTGTCCCTGTGC       39 27  0 37.04 62.049 12.00  2.00  9.049
  95 AATATTAATATTCCTGTCCCTGTGCCT       41 27  0 37.04 62.311 12.00  0.00  9.311
  96 AAATATTAATATTCCTGTCCCTGTGCC       40 27  0 37.04 62.579 12.00  1.00  9.579
  97 ATATTAATATTCCTGTCCCTGTGCCTC       42 27  0 40.74 62.745 10.00  1.00  9.745


      subroutine trafor ( pmsa   , fl     , ipoint , increm , noseg  , &
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   , &
     &                    noq3   , noq4   )
!DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'TRAFOR' :: TRAFOR
!>\file
!>       Process: TraFor - Transport formula for one ISS or IBS fraction

!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!------------------------------------------------------------------------------
      use precision
      use sediment_basics_module
      use morphology_data_module
      !
      IMPLICIT NONE

!
!     Type                      Name          I/O Description
!
      real(4), dimension(*)  :: pmsa        !<I/O Process Manager System Array, window of routine to process library
      real(4), dimension(*)  :: fl          !< O  Array of fluxes made by this process in mass/volume/time
      integer, dimension(85) :: ipoint      !< I  Array of pointers in pmsa to get and store the data
      integer, dimension(85) :: increm      !< I  Increments in ipoint for segment loop, 0=constant, 1=spatially varying
      integer                :: noseg       !< I  Number of computational elements in the whole model schematisation
      integer                :: noflux      !< I  Number of fluxes, increment in the fl array
      integer, dimension(4,*):: iexpnt      !< I  From, To, From-1 and To+1 segment numbers of the exchange surfaces
      integer, dimension(*)  :: iknmrk      !< I  Active-Inactive, Surface-water-bottom, see manual for use
      integer                :: noq1        !< I  Nr of exchanges in 1st direction (the horizontal dir if irregular mesh)
      integer                :: noq2        !< I  Nr of exchanges in 2nd direction, noq1+noq2 gives hor. dir. reg. grid
      integer                :: noq3        !< I  Nr of exchanges in 3rd direction, vertical direction, pos. downward
      integer                :: noq4        !< I  Nr of exchanges in the bottom (bottom layers, specialist use only)
!
!------------------------------------------------------------------------------
!
!     Type                                  Name          I/O Description                                        Unit
!
      real(fp)                           :: UxEff2D     !< I  x-component of effective depth averaged velocity   (m/s)
      real(fp)                           :: UyEff2D     !< I  y-component of effective depth averaged velocity   (m/s)
      real(fp)                           :: UEff2D      !< I  effective depth averaged velocity magnitude        (m/s)
      real(fp)                           :: UxMor       !< I  x-component of velocity for morphology             (m/s)
      real(fp)                           :: UyMor       !< I  y-component of velocity for morphology             (m/s)
      real(fp)                           :: UMor        !< I  velocity magnitude for morphology                  (m/s)
      real(fp)                           :: zUMor       !< I  height above bed for morphology velocity           (m)
      real(fp)                           :: UxBed       !< I  x-component of velocity in lowest layer            (m/s)
      real(fp)                           :: UyBed       !< I  y-component of velocity in lowest layer            (m/s)
      real(fp)                           :: UBed        !< I  velocity in lowest layer                           (m/s)
      real(fp)                           :: zUBed       !< I  height above bed of velocity of lowest layer       (m)
      real(fp)                           :: UxDepAvg    !< I  x-component of depth averaged velocity             (m/s)
      real(fp)                           :: UyDepAvg    !< I  y-component of depth averaged velocity             (m/s)
      real(fp)                           :: UDepAvg     !< I  depth averaged velocity                            (m/s)
      real(fp)                           :: UStar       !< I  shear velocity u_star                              (m/s)
      real(fp)                           :: Tau         !< I  total bottom shear stress                          (N/m2)
      real(fp)                           :: TauAdd      !< I  extra shear stress                                 (-)
      real(fp)                           :: LocalDepth  !< I  depth from water surface to bottom of segment      (m)
      real(fp)                           :: RhoWater    !< I  density of water                                   (kg/m3)
      real(fp)                           :: Salinity    !< I  Salinity                                           (g/kg)
      real(fp)                           :: NatTemp     !< I  natural temperature                                (oC)
      real(fp)                           :: GRAV        !< I  Gravitational acceleration                         (m/s2)
      real(fp)                           :: VonKarman   !< I  Von Karman constant                                (-)
      real(fp)                           :: KinViscos   !< I  Kinematic viscosity                                (m2/s)
      real(fp)                           :: WaveHeight  !< I  calculated height of a wind induced wave           (m)
      real(fp)                           :: WaveLength  !< I  calculated length of a wind induced wave           (m)
      real(fp)                           :: WavePeriod  !< I  calculated period of a wind induced wave           (s)
      real(fp)                           :: WaveAngle   !< I  direction of waves                                 (deg)
      real(fp)                           :: UOrb        !< I  (peak) orbital velocity at bottom layer            (m/s)
      real(fp)                           :: RhoSolid    !< I  density of sediment fraction                       (kg/m3)
      integer                            :: TypeSed     !< I  type of sediment fraction (0=bedl, 1=noncoh, 2=coh)(-)
      real(fp)                           :: D50_frac    !< I  D50 of sediment fraction                           (m)
      real(fp)                           :: Dss_frac    !< I  Dss of sediment fraction                           (m)
      real(fp)                           :: D10_mix     !< I  D10 of sediment mixture                            (m)
      real(fp)                           :: D90_mix     !< I  D90 of sediment mixture                            (m)
      real(fp)                           :: conc        !< I  concentration of this fraction                     (gDM/m3)
      real(fp)                           :: fracMud     !< I  mud fraction in bed                                (-)
      real(fp)                           :: frac        !< I  mass fraction of this fraction in bed              (-)
      real(fp)                           :: hidexp      !< I  hiding and exposure factor for this fraction       (-)
      real(fp)                           :: Wsettle     !< I  settling velocity for this fraction                (m/s)
      real(fp)                           :: factcr      !< I  adjusting shields critical shear stress            (-)
      real(fp)                           :: cal_sus     !< I  calibration factor suspended load                  (-)
      real(fp)                           :: cal_bed     !< I  calibration factor bed load                        (-)
      real(fp)                           :: cal_susw    !< I  calibration factor suspended load due to waves     (-)
      real(fp)                           :: cal_bedw    !< I  calibration factor bed load due to waves           (-)
      real(fp)                           :: cal_espir   !< I  calibration factor spiral flow effect              (-)
      real(fp)                           :: SpirFloInt  !< I  spiral flow intensity                              (-)
      real(fp)                           :: SlopeX      !< I  x-component of slope in segment                    (m/m)
      real(fp)                           :: SlopeY      !< I  y-component of slope in segment                    (m/m)
      real(fp)                           :: ksRip       !< I  ripple roughness height                            (-)
      real(fp)                           :: z0cur       !< I  current related bed roughness z_0 height           (m)
      real(fp)                           :: z0rou       !< I  wave enhanced bed roughness z_0 height             (m)
      real(fp)                           :: TraFrm      !< I  transport formula number                           (-)
      real(fp)                           :: TraPar01    !< I  transport formula specific parameter 1             (-)
      real(fp)                           :: TraPar02    !< I  transport formula specific parameter 2             (-)
      real(fp)                           :: TraPar03    !< I  transport formula specific parameter 3             (-)
      real(fp)                           :: TraPar04    !< I  transport formula specific parameter 4             (-)
      real(fp)                           :: TraPar05    !< I  transport formula specific parameter 5             (-)
      real(fp)                           :: TraPar06    !< I  transport formula specific parameter 6             (-)
      real(fp)                           :: TraPar07    !< I  transport formula specific parameter 7             (-)
      real(fp)                           :: TraPar08    !< I  transport formula specific parameter 8             (-)
      real(fp)                           :: TraPar09    !< I  transport formula specific parameter 9             (-)
      real(fp)                           :: TraPar10    !< I  transport formula specific parameter 10            (-)
      real(fp)                           :: ITIME       !< I  DELWAQ time                                        (scu)
      real(fp)                           :: DELT        !< I  timestep for processes                             (d)
      real(fp)                           :: AuxSys      !< I  ratio between days and system clock                (scu/d)
      real(fp)                           :: fixfac      !< I  non-erodible layer factor                          (-)
!
      real(fp), parameter                :: day2sec = 86400.0_fp
!
      real(fp)                           :: SBCx        !< O  x-comp of bed-load due to currents                 (kg/m)
      real(fp)                           :: SBCy        !< O  y-comp of bed-load due to currents                 (kg/m)
      real(fp)                           :: SBWx        !< O  x-comp of bed-load due to waves                    (kg/m)
      real(fp)                           :: SBWy        !< O  y-comp of bed-load due to waves                    (kg/m)
      real(fp)                           :: SSWx        !< O  x-comp of susp load due to waves                   (kg/m)
      real(fp)                           :: SSWy        !< O  y-comp of susp load due to waves                   (kg/m)
      real(fp)                           :: AKS         !< O  Van Rijn's reference height                        (m)
      real(fp)                           :: CAKS        !< O  Equilibrium concentration at reference level aks   (kg/m3)
      real(fp)                           :: TAURAT      !< O  bed shear stress ratio (cw over critical)          (-)
      real(fp)                           :: Conc2D      !< O  Concentration in 2D                                (kg/m3)
      real(fp)                           :: caks_ss3d   !< O  caks_ss3d                                          (-)
      real(fp)                           :: aks_ss3d    !< O  aks_ss3d                                           (-)
      real(fp)                           :: USt2        !< O  UStar**2                                           (-)
      real(fp)                           :: T_relax     !< O  T_relax                                            (-)
      real(fp)                           :: DSS         !< O  Dss of ISS fraction output                         (m)
      real(fp)                           :: SourSe      !< O  SourSe for ISS frac                                (kg/m3/s)
      real(fp)                           :: sour_im     !< O  SourSe for ISS frac (implicit part)                (kg/m3/s)
      real(fp)                           :: SinkSe      !< O  SinkSe for ISS frac                                (1/s)
!
      real(4)                            :: flxsrc      !< F  source flux for ISS frac                           (kg/m3/d)
      real(4)                            :: flxsnk      !< F  sink flux for ISS frac                             (kg/m3/d)
!
      integer                            :: iflux       !<    Local index for pointering the fluxes
      integer, dimension(85)             :: ipnt        !<    Local work array for the pointering
      integer                            :: iseg        !<    Local loop counter for computational element loop
!
      integer                            :: kmax        !<    number of layers
      integer, parameter                 :: kmax2d = 20 !<    number of layers to be used in 2D
      integer                            :: ltur        !<    turbulence model number
      integer                            :: lundia      !<    handle of diagnostic file
      integer                            :: i2d3d       !<    flag depth-averaged (2) or 3D (3)
      integer                            :: iform       !<    transport formula number (integer of TraFrm)
      integer                            :: istat       !<    error status flag
      integer                            :: segtype     !<    segment type (surface, column, bottom, all)
      integer(pntrsize)                  :: dllhandle   !<    handle for shared sediment transport formula library
      integer                            :: lsecfl      !<    1 if secondary flow included, 0 otherwise
      integer                            :: nsegments2D !<    number of segments (noseg) in one layer
      integer                            :: nlayers     !<    number of layers in delwaq model
      logical                            :: scour       !<    .TRUE. if AddTau included
      logical                            :: suspfrac    !<    .TRUE. if suspended sediment fraction
      logical                            :: ubot_from_com !<  .TRUE. if ubot should be used instead of local formula
      logical                            :: wave        !<    .TRUE. if waves included
      real(fp)                           :: chezy       !<    chezy number
      real(fp)                           :: dstar       !<    Dstar
      real(fp)                           :: taucr0      !<    critical shear stress
      real(fp)                           :: tetacr      !<    critical Shields stress
      real(fp)                           :: ee          !<    exp(1)                                             (-)
      real(fp)                           :: third       !<    1/3                                                (-)
      real(fp)                           :: Delta       !<    relative sediment density                          (-)
      real(fp)                           :: timsec      !<    time since simulation start in seconds             (s)
      character(256)                     :: dllfunc     !<    name of transport formula routine in shared library
      logical                            :: error       !<    .FALSE. Suppose there would be no error
      logical                            :: oldmudfrac  !<    ignore frac factor for cohesive fractions
      logical                            :: flmd2l      !<    2 layer fluid mud model
!
      real(fp)                           :: srcmax      !<    maximum entrainment rate                           (kg/m2/s)
      real(fp)                           :: dzmax       !<    maximum bed level change as fraction of LocalDepth (-)
      real(fp)                           :: dz          !<    bed level change                                   (m)
      real(fp)                           :: wstau       !<    special sink term for flmd2l
      real(fp)                           :: reducfac    !<    reduction factor in case of too high erosion rate  (-)
      real(fp)                           :: sigmol      !<    Prandtl-Schmidt number                             (-)
      real(fp)                           :: thick0      !<    thickness of gridcell kmaxsd during entrainment    (m)
      real(fp)                           :: thick1      !<    thickness of gridcell kmaxsd during deposition     (m)
      real(fp)                           :: camax       !<    maximum sediment concentration (approx 1600/2650)  (-)
      real(fp)                           :: eps         !<    precision threshold                                (-)
      real(fp), dimension(:), allocatable:: sig         !<    sigma-level of centre of layer                     (-)
      real(fp), dimension(:), allocatable:: thick       !<    sigma-thickness of layer                           (-)
      real(fp), dimension(:), allocatable:: concin      !<    concentration vertical
      real(fp), dimension(:), allocatable:: ws          !<    settling velocity array (at interfaces)
      real(fp), dimension(:), allocatable:: dicww       !<    diffusion coefficient array for fluid
      real(fp), dimension(:), allocatable:: seddif      !<    diffusion coefficient array for sediment
      real(fp), dimension(:), allocatable:: rsedeq      !<    diffusion coefficient array
      integer                            :: active      !<    attribute 1 - segment active flag
      integer                            :: kmaxsd      !<    flag depth-averaged (2) or 3D (3)!
      integer                            :: k           !<    layer number
      integer                            :: kmaxloc     !<    local number of layers (less or equal kmax)
!
      integer                            :: iflufflyr
      real(fp)                           :: mflufftot
      real(fp)                           :: fracf
      real(fp)                           :: SinkTot
      real(fp)                           :: SourFl
!
      real(fp), dimension(:), allocatable:: par         !<    old array for real transport formula parameters
      real(hp), dimension(:), allocatable:: realpar     !<    real transport formula parameters
      integer, dimension(:), allocatable :: intpar      !<    integer transport formula parameters
      character(256), dimension(:), allocatable :: strpar !<    string transport formula parameters
!
!------------------------------------------------------------------------------
!
!     Initialise pointers
!
      ipnt        = ipoint
      iflux       = 0
      nsegments2D = noseg - noq3
      nlayers     = noseg / nsegments2D
      kmax        = nlayers
      if (nlayers==1) kmax = kmax2d
!
!     Initialize constants and arrays
!
      ee          = exp(1.0)
      third       = 1.0/3.0
      ITIME       = pmsa( ipnt( 65) ) ! TODO: check that increm(65) and increm(66) are 0
      DELT        = pmsa( ipnt( 66) ) ! TODO: check that increm(65) and increm(66) are 0
      AuxSys      = pmsa( ipnt( 67) )
      timsec      = ITIME * (day2sec/AuxSys) ! default value of AuxSys is day2sec, thus scu = s
      lundia      = 308 ! "MOR" diagnostic file
      istat       = 0
      if (istat==0) allocate(concin (kmax)  , stat=istat)
      if (istat==0) allocate(dicww  (0:kmax), stat=istat)
      if (istat==0) allocate(rsedeq (kmax)  , stat=istat)
      if (istat==0) allocate(seddif (0:kmax), stat=istat)
      if (istat==0) allocate(sig    (kmax)  , stat=istat)
      if (istat==0) allocate(thick  (kmax)  , stat=istat)
      if (istat==0) allocate(ws     (0:kmax), stat=istat)
      if (istat==0) allocate(par    (30)    , stat=istat)
      if (istat==0) allocate(realpar(MAX_RP), stat=istat)
      if (istat==0) allocate(intpar (MAX_IP), stat=istat)
      if (istat==0) allocate(strpar (MAX_SP), stat=istat)
      concin  = 0.0
      dicww   = 0.0
      rsedeq  = 0.0
      seddif  = 0.0
      sig     = 0.0
      thick   = 0.0
      ws      = 0.0
      par     = 0.0
      realpar = 0.0
      intpar  = 0
      strpar  = ' '
!
      if (nlayers == 1) then
         thick(1:kmax2d) = (/ 0.1747, 0.1449, 0.1202, 0.0997, 0.0827, 0.0686, 0.0569, 0.0472, &
           & 0.0391, 0.0325, 0.0269, 0.0223, 0.0185, 0.0154, 0.0127, 0.0106, 0.0088,&
           & 0.0073, 0.0060, 0.0050/)
         sig(1:kmax2d) = (/ - 0.0874, -0.2472, -0.3797, -0.4897, -0.5809, -0.6565, -0.7193, &
           & -0.7713, -0.8145, -0.8503, -0.8800, -0.9046, -0.9250, -0.9419, -0.9560,&
           & -0.9676, -0.9773, -0.9854, -0.9920, -0.9975/)
      endif
!
!     Loop over all segments
!
      do iseg = 1, noseg
         call dhkmrk(1, iknmrk(iseg), active)
         call dhkmrk(2, iknmrk(iseg), segtype)
         if (active==0 .or. (segtype /= 0 .and. segtype /= 3)) then ! 1 (3D at surface), 2 (3D between surface and bottom)
            fl  ( iflux +  1  ) = 0.0
            fl  ( iflux +  2  ) = 0.0
            !
            ! Increment pointers and continue
            !
            iflux       = iflux       + noflux
            ipnt        = ipnt        + increm
            cycle
         endif
!
!        Get input values from arrays
!
         UxEff2D     = real(pmsa( ipnt(  1) ),fp)
         UyEff2D     = real(pmsa( ipnt(  2) ),fp)
         UEff2D      = real(pmsa( ipnt(  3) ),fp)
         UxMor       = real(pmsa( ipnt(  4) ),fp)
         UyMor       = real(pmsa( ipnt(  5) ),fp)
         UMor        = real(pmsa( ipnt(  6) ),fp)
         zUMor       = real(pmsa( ipnt(  7) ),fp)
         UxBed       = real(pmsa( ipnt(  8) ),fp)
         UyBed       = real(pmsa( ipnt(  9) ),fp)
         UBed        = real(pmsa( ipnt( 10) ),fp)
         zUBed       = real(pmsa( ipnt( 11) ),fp)
         UxDepAvg    = real(pmsa( ipnt( 12) ),fp)
         UyDepAvg    = real(pmsa( ipnt( 13) ),fp)
         UDepAvg     = real(pmsa( ipnt( 14) ),fp)
         UStar       = real(pmsa( ipnt( 15) ),fp)
         Tau         = real(pmsa( ipnt( 16) ),fp)
         TauAdd      = real(pmsa( ipnt( 17) ),fp)
         LocalDepth  = real(pmsa( ipnt( 18) ),fp)
         RhoWater    = real(pmsa( ipnt( 19) ),fp)
         Salinity    = real(pmsa( ipnt( 20) ),fp)
         NatTemp     = real(pmsa( ipnt( 21) ),fp)
         GRAV        = real(pmsa( ipnt( 22) ),fp)
         VonKarman   = real(pmsa( ipnt( 23) ),fp)
         KinViscos   = real(pmsa( ipnt( 24) ),fp)
         WaveHeight  = real(pmsa( ipnt( 25) ),fp)
         wave        = increm(25)>0 .or. WaveHeight>0.0_fp
         WaveLength  = real(pmsa( ipnt( 26) ),fp)
         WavePeriod  = real(pmsa( ipnt( 27) ),fp)
         WaveAngle   = real(pmsa( ipnt( 28) ),fp)
         UOrb        = real(pmsa( ipnt( 29) ),fp)
         RhoSolid    = real(pmsa( ipnt( 30) ),fp)
         TypeSed     = int(pmsa( ipnt( 31) ))
         D50_frac    = real(pmsa( ipnt( 32) ),fp)
         if (TypeSed==1) then
            Dss_frac = real(pmsa( ipnt( 33) ),fp)
         else
            Dss_frac = 0.0
         endif
         D10_mix     = real(pmsa( ipnt( 34) ),fp)
         D90_mix     = real(pmsa( ipnt( 35) ),fp)
         if (TypeSed==0) then
            conc     = 0.0
         else
            conc     = real(pmsa( ipnt( 36) ),fp)
         endif
         fracMud     = real(pmsa( ipnt( 37) ),fp)
         frac        = real(pmsa( ipnt( 38) ),fp)
         hidexp      = real(pmsa( ipnt( 39) ),fp)
         if (TypeSed==0) then
            Wsettle  = 0.0
         else
            Wsettle  = real(pmsa( ipnt( 40) ),fp)
         endif
         factcr      = real(pmsa( ipnt( 41) ),fp)
         cal_sus     = real(pmsa( ipnt( 42) ),fp)
         cal_bed     = real(pmsa( ipnt( 43) ),fp)
         cal_susw    = real(pmsa( ipnt( 44) ),fp)
         cal_bedw    = real(pmsa( ipnt( 45) ),fp)
         cal_espir   = real(pmsa( ipnt( 46) ),fp)
         SpirFloInt  = real(pmsa( ipnt( 47) ),fp)
         SlopeX      = real(pmsa( ipnt( 48) ),fp)
         SlopeY      = real(pmsa( ipnt( 49) ),fp)
         ksRip       = real(pmsa( ipnt( 50) ),fp)
         z0cur       = real(pmsa( ipnt( 51) ),fp)
         z0rou       = real(pmsa( ipnt( 52) ),fp)
         TraFrm      = real(pmsa( ipnt( 53) ),fp)
         TraPar01    = real(pmsa( ipnt( 54) ),fp)
         TraPar02    = real(pmsa( ipnt( 55) ),fp)
         TraPar03    = real(pmsa( ipnt( 56) ),fp)
         TraPar04    = real(pmsa( ipnt( 57) ),fp)
         TraPar05    = real(pmsa( ipnt( 58) ),fp)
         TraPar06    = real(pmsa( ipnt( 59) ),fp)
         TraPar07    = real(pmsa( ipnt( 60) ),fp)
         TraPar08    = real(pmsa( ipnt( 61) ),fp)
         TraPar09    = real(pmsa( ipnt( 62) ),fp)
         TraPar10    = real(pmsa( ipnt( 63) ),fp)
         !ITIME       = real(pmsa( ipnt( 64) ),fp)
         !DELT        = real(pmsa( ipnt( 65) ),fp)
         !AuxSys      = real(pmsa( ipnt( 66) ),fp)
         fixfac      = real(pmsa( ipnt( 67) ),fp)
!
!   *****     Insert your code here  *****
!
         if (segtype == 0) then
            !
            ! single segment in vertical: 2D (might be 2D cell in 3D Z-layer model: do I want to do this then?)
            !
            i2d3d  = 2
            ws     = Wsettle
            dicww  = 0.0
            concin = conc
         elseif (segtype == 3) then ! bottom segment
            !
            ! bottom segment in vertical with multiple segments: 3D
            !
            i2d3d  = 3
         endif
         !
         if (nlayers>1) then
            sig     = LocalDepth
            !
            ! determine the depth for the bottom of every layer
            !
            kmaxloc = 1 + (iseg-1)/nsegments2D
            do k = kmaxloc-1,1,-1
               sig(k)    = real(pmsa( ipnt( 18) - increm(18)*nsegments2D*(kmaxloc-k) ),fp)
               concin(k) = real(pmsa( ipnt( 36) - increm(36)*nsegments2D*(kmaxloc-k) ),fp)
               ws(k)     = real(pmsa( ipnt( 40) - increm(40)*nsegments2D*(kmaxloc-k) ),fp)
            enddo
            !
            ! determine for every layer the relative thickness
            !
            thick(1) = sig(1)/LocalDepth
            do k = 2, kmax
               thick(k) = (sig(k)-sig(k-1))/LocalDepth
            enddo
            !
            ! determine for the mid point of every layer the relative depth
            !
            do k = 1, kmax
               sig(k) = -sig(k)/LocalDepth + thick(k)/2.0
            enddo
         endif
         !
         iform         = int(TraFrm)
         chezy         = sqrt(GRAV) * log( 1.0 + LocalDepth/max(1.0e-8,ee*z0rou) ) / VonKarman
         Delta         = (RhoSolid - RhoWater) / RhoWater
         dstar         = D50_frac * (Delta * GRAV / KinViscos**2)**third
         if (dstar < 1.0_fp) then
            if (iform == -2) then
               tetacr = 0.115 / (dstar**0.5_fp)
            else
               tetacr = 0.24 / dstar
            endif
         elseif (dstar <= 4.0_fp) then
            if (iform == -2) then
               tetacr = 0.115 / (dstar**0.5)
            else
               tetacr = 0.24 / dstar
            endif
         elseif (dstar>4.0_fp .and. dstar<=10.0_fp) then
            tetacr = 0.14  / (dstar**0.64)
         elseif (dstar>10.0_fp .and. dstar<=20.0_fp) then
            tetacr = 0.04  / (dstar**0.1)
         elseif (dstar>20.0 .and. dstar<=150.0_fp) then
            tetacr = 0.013 * (dstar**0.29)
         else
            tetacr = 0.055
         endif
         taucr0        = factcr * (RhoSolid-RhoWater) * GRAV * D50_frac * tetacr
         !
         ltur          = 0
         sigmol        = 1.0_fp
         lsecfl        = 1
         suspfrac      = TypeSed>0
         scour         = TauAdd>0.0
         ubot_from_com = .true.
         camax         = 0.65_fp
         eps           = 1e-6_fp
         !
         realpar(RP_TIME ) = real(timsec     ,hp)
         realpar(RP_EFUMN) = real(UxEff2D    ,hp)
         realpar(RP_EFVMN) = real(UyEff2D    ,hp)
         realpar(RP_EFVLM) = real(UEff2D     ,hp)
         realpar(RP_UCHAR) = real(UxMor      ,hp)
         realpar(RP_VCHAR) = real(UyMor      ,hp)
         realpar(RP_VELCH) = real(UMor       ,hp)
         realpar(RP_ZVLCH) = real(zUMor      ,hp)
         realpar(RP_DEPTH) = real(LocalDepth ,hp)
         realpar(RP_CHEZY) = real(chezy      ,hp)
         realpar(RP_HRMS ) = real(WaveHeight ,hp)
         realpar(RP_TPEAK) = real(WavePeriod ,hp)
         realpar(RP_TETA ) = real(WaveAngle  ,hp)
         realpar(RP_RLAMB) = real(WaveLength ,hp)
         realpar(RP_UORB ) = real(UOrb       ,hp)
         realpar(RP_D50  ) = real(D50_frac   ,hp)
         realpar(RP_DSS  ) = real(Dss_frac   ,hp)
         realpar(RP_DSTAR) = real(dstar      ,hp)
         realpar(RP_D10MX) = real(D10_mix    ,hp)
         realpar(RP_D90MX) = real(D90_mix    ,hp)
         realpar(RP_MUDFR) = real(fracMud    ,hp)
         realpar(RP_HIDEX) = real(hidexp     ,hp)
         realpar(RP_SETVL) = real(Wsettle    ,hp)
         realpar(RP_RHOSL) = real(RhoSolid   ,hp)
         realpar(RP_RHOWT) = real(RhoWater   ,hp)
         realpar(RP_SALIN) = real(Salinity   ,hp)
         realpar(RP_TEMP ) = real(NatTemp    ,hp)
         realpar(RP_GRAV ) = real(GRAV       ,hp)
         realpar(RP_VICML) = real(KinViscos  ,hp)
         realpar(RP_TAUB ) = real(Tau        ,hp) ! should be increased by TauAdd
         realpar(RP_UBED ) = real(UxBed      ,hp)
         realpar(RP_VBED ) = real(UyBed      ,hp)
         realpar(RP_VELBD) = real(UBed       ,hp)
         realpar(RP_ZVLBD) = real(zUBed      ,hp)
         realpar(RP_VNKAR) = real(VonKarman  ,hp)
         realpar(RP_Z0CUR) = real(z0cur      ,hp)
         realpar(RP_Z0ROU) = real(z0rou      ,hp)
         realpar(RP_UMEAN) = real(UxDepAvg   ,hp)
         realpar(RP_VMEAN) = real(UyDepAvg   ,hp)
         realpar(RP_VELMN) = real(UDepAvg    ,hp)
         realpar(RP_USTAR) = real(UStar      ,hp)
         !
         par( 1) = GRAV
         par( 2) = RhoWater
         par( 3) = RhoSolid
         par( 4) = Delta
         par( 5) = KinViscos
         par( 6) = D50_frac
         par(11) = TraPar01
         par(12) = TraPar02
         par(13) = TraPar03
         par(14) = TraPar04
         par(15) = TraPar05
         par(16) = TraPar06
         par(17) = TraPar07
         par(18) = TraPar08
         par(19) = TraPar09
         par(20) = TraPar10
         !
         aks       = -999.0_fp
         caks      = -999.0_fp
         taurat    = -999.0_fp
         seddif    = -999.0_fp
         rsedeq    = -999.0_fp
         kmaxsd    = -999
         conc2d    = -999.0_fp
         SBCx      = -999.0_fp
         SBCy      = -999.0_fp
         SBWx      = -999.0_fp
         SBWy      = -999.0_fp
         SSWx      = -999.0_fp
         SSWy      = -999.0_fp
         dss       = -999.0_fp
         caks_ss3d = -999.0_fp
         aks_ss3d  = -999.0_fp
         ust2      = -999.0_fp
         T_relax   = -999.0_fp
         error     = .false.
         !
         thick0 = thick(kmaxsd) * LocalDepth
         thick1 = thick0 ! deposition term treated explicitly in delwaq
         !
         if (TypeSed<2) then
            ! non-cohesive sediment fraction
            call eqtran(sig       ,thick     ,kmax      ,ws        ,ltur      , &
                      & frac      ,sigmol    ,dicww     ,lundia    ,taucr0    , &
                      & ksRip     ,i2d3d     ,lsecfl    ,SpirFloInt,suspfrac  , &
                      & tetacr    ,concin    , &
                      & SlopeX    ,SlopeY    ,UOrb      ,TauAdd    ,cal_sus   , &
                      & cal_bed   ,cal_susw  ,cal_bedw  ,cal_espir ,wave      , &
                      & scour     ,ubot_from_com        ,camax     ,eps       , &
                      & iform     ,par       ,MAX_IP    ,MAX_RP    ,MAX_SP    , &
                      & dllfunc   ,dllhandle ,intpar    ,realpar   ,strpar    , &
!output:
                      & aks       ,caks      ,taurat    ,&  ! output
                      & seddif    ,rsedeq    , &            ! local variables in array
                      & kmaxsd    ,&                        ! local variables
                      & conc2d    ,SBCx      ,SBCy      ,SBWx      , &
                      & SBWy      ,SSWx      ,SSWy      ,dss       ,caks_ss3d , &
                      & aks_ss3d  ,ust2      ,T_relax   ,error     )
            !
            if (suspfrac) then
               ! suspended load
               if (kmax == 1) then
                  ! 2D model
                  call soursin_2d(UEff2D    ,UStar    ,LocalDepth ,LocalDepth, &
                                & Wsettle   ,T_relax  ,rsedeq(1)  ,1.0_fp,   &
!output
                                & SourSe    ,sour_im  ,SinkSe   )
               else
                  ! 3D model
                  call soursin_3d(LocalDepth    , thick0  , thick1    , sig(kmaxsd), &
                                & thick(kmaxsd) , conc    , KinViscos , sigmol     , &
                                & seddif(kmaxsd), RhoSolid, caks_ss3d , ws(kmaxsd) , &
                                & aks_ss3d      , &
!output
                                & SourSe        , sour_im , SinkSe     )
               endif
               !
               !dz = (SourSe*thick0 - SinkSe*conc*thick1)*DELT*day2sec*MorFac/RhoBed
               !if (dz > dzmax*LocalDepth) then
               !   reducfac = (LocalDepth*dzmax)/abs(dz)
               !   SinkSe = SinkSe*reducfac
               !   SourSe = SourSe*reducfac
               !endif
               !
               SinkSe = SinkSe*fixfac
               SourSe = SourSe*fixfac
               do k = 1, kmax
                  rsedeq = rsedeq*fixfac
               enddo
            else
               ! bedload/total load
               SourSe = 0.0_fp
               SinkSe = 0.0_fp
            endif
         else
            ! cohesive sediment fraction
            oldmudfrac = .false.
            flmd2l     = .false.
            srcmax     = 1.0e10_fp ! not yet supported
            !
            !if (flmd2l) then
            !   par(1) = entr(nm,l)
            !   par(2) = tcrdep(nm,l)
            !endif
            !
            iflufflyr = 0
            mflufftot = 0.0_fp
            fracf     = 0.0_fp
            call erosilt(thick    ,kmax      ,ws       ,lundia   , &
                       & thick0   ,thick1    ,fixfac   ,srcmax   , &
                       & frac     ,oldmudfrac,flmd2l   ,iform    , &
                       & par      ,MAX_IP    ,MAX_RP   ,MAX_SP   , &
                       & dllfunc  ,dllhandle ,intpar   ,realpar  , &
                       & strpar   ,iflufflyr ,mflufftot,fracf    , &
                       & 0.0_fp   ,0.0_fp    , &
! output:
                       & error    ,wstau     ,SinkTot  ,SourSe   , &
                       & SourFl   )
            SinkSe = SinkTot
         endif
         !
         !if (sourse > 0.0) then
         !   write(iseg,'(42E13.5)') realpar
         !   write(iseg,'(30E13.5)') par
         !   write(iseg,'(4E13.5)') conc2d    ,SBCx      ,SBCy      ,SBWx
         !   write(iseg,'(5E13.5)') SBWy      ,SSWx      ,SSWy      ,dss       ,caks_ss3d
         !   write(iseg,'(5E13.5)') aks_ss3d  ,ust2      ,T_relax   ,SourSe    ,SinkSe
         !   write(iseg,'(A)') '--'
         !endif
         !
         ! The source/sink terms are computed as kg/s, but we need g/d for delwaq
         !
         flxsrc = SourSe*day2sec*1000.0_fp
         flxsnk = SinkSe*conc*day2sec*1000.0_fp

!
!   *****     End of your code       *****
!
!        Put output and flux values into arrays
!
         fl  ( iflux +  1  ) = flxsrc
         fl  ( iflux +  2  ) = flxsnk
         pmsa( ipnt( 68)   ) = real(SBCx     ,4)
         pmsa( ipnt( 69)   ) = real(SBCy     ,4)
         pmsa( ipnt( 70)   ) = real(SBWx     ,4)
         pmsa( ipnt( 71)   ) = real(SBWy     ,4)
         pmsa( ipnt( 72)   ) = real(SSWx     ,4)
         pmsa( ipnt( 73)   ) = real(SSWy     ,4)
         pmsa( ipnt( 74)   ) = real(AKS      ,4)
         pmsa( ipnt( 75)   ) = real(CAKS     ,4)
         pmsa( ipnt( 76)   ) = real(TAURAT   ,4)
         pmsa( ipnt( 77)   ) = real(Conc2D   ,4)
         pmsa( ipnt( 78)   ) = real(caks_ss3d,4)
         pmsa( ipnt( 79)   ) = real(aks_ss3d ,4)
         pmsa( ipnt( 80)   ) = real(USt2     ,4)
         pmsa( ipnt( 81)   ) = real(T_relax  ,4)
         pmsa( ipnt( 82)   ) = real(DSS      ,4)
         pmsa( ipnt( 83)   ) = real(SourSe   ,4)
         pmsa( ipnt( 84)   ) = real(SinkSe   ,4)
!
!        Increment pointers
!
         iflux       = iflux       + noflux
         ipnt        = ipnt        + increm
!
      enddo
!
      deallocate(concin , stat=istat)
      deallocate(dicww  , stat=istat)
      deallocate(rsedeq , stat=istat)
      deallocate(seddif , stat=istat)
      deallocate(sig    , stat=istat)
      deallocate(thick  , stat=istat)
      deallocate(ws     , stat=istat)
      deallocate(realpar, stat=istat)
      deallocate(intpar , stat=istat)
      deallocate(strpar , stat=istat)
!
      end subroutine trafor


    MODULE module_data_radm2
      IMPLICIT NONE
      REAL, PARAMETER :: epsilc = 1.E-16

      INTEGER, PARAMETER :: ldiag = 18, lpred = 39, lss = 2, &
        lump = 4, naqre = 70, nreacj = 21, nreack = 140, &
        ntroe = 7, numchem_radm = 41
      INTEGER, PARAMETER :: lspec = lpred + lss
      INTEGER, DIMENSION(1:NTROE) :: itroe = (/11, 22, 10, 15, 21, 24, 28/)

      INTEGER, PARAMETER :: lso2=1
      INTEGER, PARAMETER :: lsulf=2
      INTEGER, PARAMETER :: lno2=3
      INTEGER, PARAMETER :: lno=4
      INTEGER, PARAMETER :: lo3=5
      INTEGER, PARAMETER :: lhno3=6
      INTEGER, PARAMETER :: lh2o2=7
      INTEGER, PARAMETER :: lald=8
      INTEGER, PARAMETER :: lhcho=9
      INTEGER, PARAMETER :: lop1=10
      INTEGER, PARAMETER :: lop2=11
      INTEGER, PARAMETER :: lpaa=12
      INTEGER, PARAMETER :: lora1=13

      INTEGER, PARAMETER :: lora2=14
      INTEGER, PARAMETER :: lnh3=15
      INTEGER, PARAMETER :: ln2o5=16
      INTEGER, PARAMETER :: lno3=17
      INTEGER, PARAMETER :: lpan=18
      INTEGER, PARAMETER :: lhc3=19
      INTEGER, PARAMETER :: lhc5=20
      INTEGER, PARAMETER :: lhc8=21

      INTEGER, PARAMETER :: leth=22
      INTEGER, PARAMETER :: lco=23
      INTEGER, PARAMETER :: lol2=24
      INTEGER, PARAMETER :: lolt=25
      INTEGER, PARAMETER :: loli=26
      INTEGER, PARAMETER :: ltol=27
      INTEGER, PARAMETER :: lxyl=28
      INTEGER, PARAMETER :: laco3=29

      INTEGER, PARAMETER :: ltpan=30
      INTEGER, PARAMETER :: lhono=31
      INTEGER, PARAMETER :: lhno4=32
      INTEGER, PARAMETER :: lket=33
      INTEGER, PARAMETER :: lgly=34
      INTEGER, PARAMETER :: lmgly=35
      INTEGER, PARAMETER :: ldcb=36
      INTEGER, PARAMETER :: lonit=37

      INTEGER, PARAMETER :: lcsl=38
      INTEGER, PARAMETER :: liso=39
      INTEGER, PARAMETER :: lho=40
      INTEGER, PARAMETER :: lho2=41

      INTEGER, DIMENSION(1:lpred) :: intgrt = (/1, 1, 1, 0, 1, &
                                 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, &
                                 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, &
                                 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, &
                                                   1, 1, 1, 1 /)

      INTEGER, DIMENSION(1:lspec) :: qdtc = (/1, 1, 1, 0, 1, &
                                 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, &
                                 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, &
                                 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, &
                                             1, 1, 1, 1, 0, 0 /)

      INTEGER :: itrdu

      REAL, DIMENSION(1:lspec) :: cmin =(/(1.E-16,itrdu=1,lspec)/)

      REAL, DIMENSION(1:lspec) :: cmax=(/1., 1., 1., 1., .2, &
                3., .05, .01, .01, .01, .05, .01, .05, .05,.05, &
                1., 1., 1., 1., 1., 1., 1., 1., 1., 1., &
                1., 1., 1., 1., 1., 1., 1., 1.,.0001, .1, &
                                    1., .001, .01, .01, .01, .01/)

      INTEGER, PARAMETER :: lo3p=1
      INTEGER, PARAMETER :: lo1d=2
      INTEGER, PARAMETER :: ltco3=3
      INTEGER, PARAMETER :: lhc3p=4
      INTEGER, PARAMETER :: lhc5p=5
      INTEGER, PARAMETER :: lhc8p=6

      INTEGER, PARAMETER :: lol2p=7
      INTEGER, PARAMETER :: loltp=8
      INTEGER, PARAMETER :: lolip=9
      INTEGER, PARAMETER :: ltolp=10
      INTEGER, PARAMETER :: lxylp=11
      INTEGER, PARAMETER :: lethp=12
      INTEGER, PARAMETER :: lketp=13
      INTEGER, PARAMETER :: loln=14

      INTEGER, PARAMETER :: lxo2=15
      INTEGER, PARAMETER :: lxno2=16
      INTEGER, PARAMETER :: lxho=17
      INTEGER, PARAMETER :: lmo2=18

      INTEGER, PARAMETER :: lnox=1
      INTEGER, PARAMETER :: lhox=2
      INTEGER, PARAMETER :: lpao3=3
      INTEGER, PARAMETER :: ln2n3=4

      REAL, PARAMETER :: ch4=1.7
      REAL, PARAMETER :: co2=350.
      REAL, PARAMETER :: n2=7.81E5
      REAL, PARAMETER :: o2=2.09E5
      REAL, PARAMETER :: pi=3.141592654

      REAL :: afac(2), &
        bfac(2), const(3), eor(nreack), &
        thafac(nreack), &
        xk0300(ntroe), &
        xkf300(ntroe), xmtroe(ntroe), xntroe(ntroe)

      DATA thafac/0.00, 6.50E-12, 1.80E-11, 3.20E-11, 2.20E-10, 2.00E-12, &
        1.60E-12, 1.10E-14, 3.70E-12, 4*0.00, 3.30E-12, 0.00, 3.30E-19, &
        1.40E-13, 1.70E-11, 2.50E-14, 2.50E-12, 2*0.00, 2.00E-21, 2*0.00, &
        1.30E-12, 4.60E-11, 2*0.00, 6.95E-18, 1.37E-17, 1.59E-11, 1.73E-11, &
        3.64E-11, 2.15E-12, 5.32E-12, 1.07E-11, 2.10E-12, 1.89E-11, 4.00E-11, &
        9.00E-12, 6.87E-12, 1.20E-11, 1.15E-11, 1.70E-11, 2.80E-11, 1.00E-11, &
        1.00E-11, 1.00E-11, 6.85E-18, 1.55E-11, 2.55E-11, 2.80E-12, 1.95E+16, &
        4.70E-12, 1.95E+16, 4.20E-12, 4.20E-12, 0.00, 4.20E-12, 0.00, &
        4.20E-12, 0.00, 10*4.20E-12, 6.00E-13, 1.40E-12, 6.00E-13, 1.40E-12, &
        1.40E-12, 2.20E-11, 2.00E-12, 1.00E-11, 3.23E-11, 5.81E-13, 1.20E-14, &
        1.32E-14, 7.29E-15, 1.23E-14, 14*7.70E-14, 1.90E-13, 1.40E-13, &
        4.20E-14, 3.40E-14, 2.90E-14, 1.40E-13, 1.40E-13, 1.70E-14, 1.70E-14, &
        9.60E-13, 1.70E-14, 1.70E-14, 9.60E-13, 3.40E-13, 1.00E-13, 8.40E-14, &
        7.20E-14, 3.40E-13, 3.40E-13, 4.20E-14, 4.20E-14, 1.19E-12, 4.20E-14, &
        4.20E-14, 1.19E-12, 7.70E-14, 1.70E-14, 4.20E-14, 3.60E-16, 4.20E-12, &
        4.20E-12, 7.70E-14, 1.70E-14, 4.20E-14, 3.60E-16, 0.00, 1.70E-14, &
        4.20E-14, 3.60E-16/

      DATA eor/0., -120., -110., -70., 0., 1400., 940., 500., -240., 0., 0., &
        0., 0., 200., 0., -530., 2500., -150., 1230., 0., 0., 0., 0., 0., 0., &
        -380., -230., 0., 0., 1280., 444., 540., 380., 380., -411., -504., &
        -549., -322., -116., 0., 0., -256., 745., 0., 0., 0., 0., 0., 0., &
        444., 540., -409., -181., 13543., 0., 13543., -180., -180., 0., -180., &
        0., -180., 0., -180., -180., -180., -180., -180., -180., -180., -180., &
        -180., -180., 2058., 1900., 2058., 1900., 1900., 0., 2923., 1895., &
        975., 0., 2633., 2105., 1136., 2013., -1300., -1300., -1300., -1300., &
        -1300., -1300., -1300., -1300., -1300., -1300., -1300., -1300., &
        -1300., -1300., 25* -220., -1300., -220., -220., -220., -180., -180., &
        -1300., -220., -220., 0., 0., -220., -220., -220./

      DATA xk0300/1.8E-31, 2.2E-30, 1.8E-31, 7.E-31, 2.2E-30, 2.6E-30, 3.E-31/
      DATA xntroe/3.2, 4.3, 3.2, 2.6, 4.3, 3.2, 3.3/
      DATA xkf300/4.7E-12, 1.5E-12, 4.7E-12, 1.5E-11, 1.5E-12, 2.4E-11, &
        1.5E-12/
      DATA xmtroe/1.4, 0.5, 1.4, 2*.5, 1.3, 0./
      DATA afac/2.1E-27, 1.1E-27/
      DATA bfac/10900., 11200./
      DATA const/7.34E21, 4.4E17, 3.23E33/

    END MODULE module_data_radm2