c This module/program is part of DaliLite (c) L. Holm 1999,2008
c
	program wolf_grid
c
c	f77 wolf_grid.f
c
c       reads list1
c       writes out SSE-vectors in all frames
c
c       use in pipe to create wolf-db, to compare query versus wolf-db
c
c
	implicit none
	include 'parsizes.for'
	character secstr(maxseg)
	integer nseg
c
	integer nprot2
	character*5 cd,list2(maxprot)
c
	logical lverb,lgrid
c
	character*80 dalidatpath
c
	real yca(3,maxres),x(3,maxres)
	integer ny
	real midpoint(3,maxseg+3),direction(3,maxseg+3),neidist(maxseg,maxseg)
	real neiborcutoff, fitzrcut
c
        real r,midx(3),dirx(3)
        integer gx,gy,gz,iseg,jseg,kseg,iprot,fung,i
        character atype,ctype
c
c	write(*,*),'# enter dalidatpath, neiborcutoff'
	read(*,520) dalidatpath
	read(*,*) neiborcutoff
c	write(*,*),'# imported parameters are:',dalidatpath,neiborcutoff
c
	lverb=.false.
	nprot2=0
	call getlist('list1',90,list2,nprot2)
c
c       loop over list2: write all boxed segments
c        nocc=0
        do iprot=1,nprot2
                cd=list2(iprot)
                call setupprotein(cd,nseg,midpoint,direction,
     $                  secstr,90,
     $                  yca,ny,neidist,dalidatpath)
                if(nseg.gt.2) then
                 do iseg=1,nseg
                  atype=secstr(iseg)
                  do jseg=1,nseg
                    if(iseg.ne.jseg) then
                      r=neidist(iseg,jseg)
                      if(r.lt.neiborcutoff) then
                 call preparex(x,iseg,jseg,nseg,midpoint,direction)
                 call twist(x,3+nseg+nseg)
                        do kseg=1,nseg
                          if(kseg.ne.iseg) then
                                do i=1,3
        midx(i)=(x(i,3+kseg)+x(i,3+nseg+kseg))/2
        dirx(i)=x(i,3+nseg+kseg)-midx(i)
                                end do
                                ctype=secstr(kseg)
                                r=(x(1,3+kseg)+x(1,3+nseg+kseg))/2.0
                                gx=fung(r)
                                r=(x(2,3+kseg)+x(2,3+nseg+kseg))/2.0
                                gy=fung(r)
                                r=(x(3,3+kseg)+x(3,3+nseg+kseg))/2.0
                                gz=fung(r)
                                if(lgrid(gx,gy,gz,20)) then
c output text to STDOUT
c        write(*,530) cd,iseg,jseg,kseg,
c     $  atype,ctype,gx,gy,gz,(midx(i),i=1,3),(dirx(i),i=1,3)
c output binary to fort.1
        write(1) cd,iseg,jseg,kseg,
     $  atype,ctype,gx,gy,gz,(midx(i),i=1,3),(dirx(i),i=1,3)
                                end if

                          end if
                        end do
                      end if
                    end if
                  end do
                 end do
                else
                        write(*,*) '# too few SSEs: ',cd,nseg
                end if
        end do

520	format(a80)
530     format('#boxing ',a5,3i5,2(1x,a1),3i5,6f10.1)

	end
c
c----------------------------------------------------------------------
c
	subroutine preparex(x,iseg,jseg,nx,midpoint,direction)
	implicit none
	include 'parsizes.for'
	integer nx,iseg,jseg
	real x(3,*),midpoint(3,*),direction(3,*)
c
	integer i,kseg
c
	do i=1,3
		x(i,1)=midpoint(i,iseg)
		x(i,2)=midpoint(i,iseg)+direction(i,iseg)
		x(i,3)=midpoint(i,jseg)
	end do
	do kseg=1,nx
		do i=1,3
		  x(i,3+kseg)=midpoint(i,kseg)-direction(i,kseg)
		  x(i,3+nx+kseg)=midpoint(i,kseg)+direction(i,kseg)
		end do
	end do

	return
	end
c
c----------------------------------------------------------------------
c

c
c----------------------------------------------------------------------
c
	function distance(a1,a2,a3,b1,b2,b3)
	implicit none
	real distance,a1,a2,a3,b1,b2,b3
c
	distance=sqrt((a1-b1)*(a1-b1)+(a2-b2)*(a2-b2)+(a3-b3)*(a3-b3))
c
	return
	end
c
c----------------------------------------------------------------------
c

c
c----------------------------------------------------------------------
c
	subroutine vec(ca,nres,nseg,segmentrange,midpoint,direction)
	implicit none
	include 'parsizes.for'
	integer nseg,segmentrange(2,maxseg),nres
	real ca(3,maxres),midpoint(3,maxseg+3),direction(3,maxseg+3)
c
	integer iseg,ires,left,rite,mid,i,l,r
	real nmid(3),cmid(3)
c
	do iseg=1,nseg
		left=segmentrange(1,iseg)
		rite=segmentrange(2,iseg)
		mid=(left+rite)/2
		l=mid-left+1
		r=rite-mid+1
		do i=1,3
			nmid(i)=0
			cmid(i)=0
		end do
		do ires=left,mid
			do i=1,3
				nmid(i)=nmid(i)+ca(i,ires)/l
			end do
		end do
		do ires=mid,rite
			do i=1,3
				cmid(i)=cmid(i)+ca(i,ires)/r
			end do
		end do
		do i=1,3
			midpoint(i,iseg)=(nmid(i)+cmid(i))/2
			direction(i,iseg)=cmid(i)-nmid(i)
		end do
	end do

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine readproteindata(nseg,secstr,segmentrange,ca,nres,iunit)
	implicit none
	include 'parsizes.for'
        integer ndom,node_child(2,maxdom),nres,nseg,iunit
        character node_type(maxdom),secstr(maxseg)
	integer domns(maxdom),domseglist(maxseg,maxdom),na,nb
	real ca(3,maxres)
	integer segmentrange(2,maxseg),checkrange(2,maxseg),checkx(maxseg)
c
	integer i,j,idom,iseg
c
	read(iunit,500) nres,nseg,na,nb,(secstr(i),i=1,nseg)
	do iseg=1,nseg
	  read(iunit,510) i,(segmentrange(j,i),j=1,2),(checkrange(j,i),j=1,2),
     $		checkx(i)
	end do
	read(iunit,520) ((ca(j,i),j=1,3),i=1,nres)
	read(iunit,500) ndom
	do idom=1,ndom
	  read(iunit,530) i,node_type(i),(node_child(j,i),j=1,2),domns(i),
     $		(domseglist(j,i),j=1,domns(i))
	end do

500	format(10x,4i5,2x,<maxseg>a1)
510	format(6i10)
520	format(10f8.1)
530	format(i4,1x,a1,1x,3i4,<maxseg>i4)

	return
	end
c
c-------------------------------------------------------------------------------
c
	subroutine setupprotein(cd,nseg,midpoint,direction,secstr,iunit,
     $		ca,nres,neidist,dalidatpath)
	implicit none
	include 'parsizes.for'
	character*5 cd
	integer nseg,iunit
	character secstr(maxseg)
	real midpoint(3,maxseg+3),direction(3,maxseg+3),neidist(maxseg,maxseg)
c
	character*80 filnam,constructfilnam,dalidatpath
	integer segmentrange(2,maxseg),nres,jseg,iseg
	real ca(3,maxres),distance,r
c
	filnam=constructfilnam(cd,dalidatpath,'.dat')
c	write(*,*),'setup: ',filnam
	open(iunit,file=filnam,status='old')
	call readproteindata(nseg,secstr,segmentrange,ca,nres,iunit)
	close(iunit)
c	write(*,*) cd,nseg,nres,' ',(secstr(i),i=1,nseg)
	call vec(ca,nres,nseg,segmentrange,midpoint,direction)
!	remember all distances in neidist
	do iseg=1,nseg
		do jseg=1,nseg
			if(iseg.ne.jseg) then
	r=distance(midpoint(1,iseg),midpoint(2,iseg),midpoint(3,iseg),
     $	midpoint(1,jseg),midpoint(2,jseg),midpoint(3,jseg))
				neidist(iseg,jseg)=r
			else
				neidist(iseg,jseg)=0.0
			end if
		end do
	end do

500	format(a4,a1)

	end
c
c----------------------------------------------------------------------
c
	subroutine getlist(filnam,iunit,list,nprot)
	implicit none
	include 'parsizes.for'
	character*5 list(maxprot)
	integer nprot,iunit
	character*(*) filnam
c
	character*5 cd
c
	nprot=0
	open(iunit,file=filnam,status='old')
10	read(iunit,500,end=19) cd
	if(nprot.eq.maxprot) then
		write(*,*) '# WARNING: skip reading list after maxprot',maxprot
		goto 19
	end if
	nprot=nprot+1
	list(nprot)=cd
	goto 10
19	close(iunit)
c	write(*,*) nprot,' proteins in list from ',filnam
c
500	format(a5)
c

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine twist(x,looplen)
c
c	puts x(*,1) in origo, x(*,2) along y axis, x(*,3) in positive yz plane
c	output: transrotated coordinates x
c
	implicit none
	integer looplen
	real x(3,looplen)
c
	real pii
	parameter(pii=3.141592653589793)
c
	integer i,j
	real u,sinu,cosu,y(3)
c
c	set origo
c
	do i=looplen,1,-1
		do j=1,3
			x(j,i)=x(j,i)-x(j,1)
		end do
	end do
c
c	rotate around x
c	-- if y=0 do first 90 deg around z
c
	if(abs(x(2,2)).lt.1e-6) then
		do i=2,looplen
			y(1)=-x(2,i)
			y(2)=x(1,i)
			y(3)=x(3,i)
			do j=1,3
				x(j,i)=y(j)
			end do
		end do
	end if
c
c	-- if y=0 & x=0 do first 90 deg around x
c
	if(abs(x(2,2)).lt.1e-6.and.abs(x(1,2)).lt.1e-6) then
		do i=2,looplen
			y(2)=-x(3,i)
			y(3)=x(2,i)
			y(1)=x(1,i)
			do j=1,3
				x(j,i)=y(j)
			end do
		end do
	end if
	if(abs(x(2,2)).gt.1e-6) then
		u=atan(x(3,2)/x(2,2))
	else
		u=0.0
	end if
	sinu=sin(u)
	cosu=cos(u)
	do i=2,looplen
		y(2)=cosu*x(2,i)+sinu*x(3,i)
		y(3)=-sinu*x(2,i)+cosu*x(3,i)
		y(1)=x(1,i)
		do j=1,3
			x(j,i)=y(j)
		end do
	end do
c	if(x(2,2).eq.0.0) write(*,*) ' y=0 !!!',u,sinu,cosu
c
c	rotate around z
c
	if(abs(x(2,2)).gt.1e-6) then
		u=-atan(x(1,2)/x(2,2))
	else
		u=0.0
	end if
	if(x(2,2).lt.0.0) u=pii+u
	sinu=sin(u)
	cosu=cos(u)
	do i=2,looplen
		y(1)=cosu*x(1,i)+sinu*x(2,i)
		y(2)=-sinu*x(1,i)+cosu*x(2,i)
		y(3)=x(3,i)
		do j=1,3
			x(j,i)=y(j)
		end do
	end do
c
c	rotate around y
c	-- if z=0 do first 90 deg around y
c
	if(abs(x(3,3)).lt.1e-6) then
		do i=2,looplen
			y(1)=x(3,i)
			y(2)=x(2,i)
			y(3)=-x(1,i)
			do j=1,3
				x(j,i)=y(j)
			end do
		end do
	end if
	if(x(3,3).ne.0.0) then
		u=atan(x(1,3)/x(3,3))
	else
		u=0.0
	end if
	sinu=sin(u)
	cosu=cos(u)
	do i=3,looplen
		y(3)=cosu*x(3,i)+sinu*x(1,i)
		y(1)=-sinu*x(3,i)+cosu*x(1,i)
		y(2)=x(2,i)
		do j=1,3
			x(j,i)=y(j)
		end do
	end do
c
c	-- if z<0 then rotate 180 deg around y
c
	if(x(3,3).lt.0.0) then
		do i=2,looplen
			y(1)=-x(1,i)
			y(2)=x(2,i)
			y(3)=-x(3,i)
			do j=1,3
				x(j,i)=y(j)
			end do
		end do
	end if
c	if(x(3,3).lt.0) write(*,*) ' z<0 !!!',u,sinu,cosu

	return
	end
c
c---------------------------------------------------------------------------
c
	function lgrid(gx,gy,gz,maxgrid)
c
c       check that g* are inside -maxgrid..+maxgrid
c       .true. if ok, .false. if outside
c
        implicit none
        logical lgrid
        integer gx,gy,gz,maxgrid
c
        lgrid=.true.
        if(gx.gt.maxgrid) lgrid=.false.
        if(gx.lt.-maxgrid)lgrid=.false.
        if(gy.gt.maxgrid) lgrid=.false.
        if(gy.lt.-maxgrid)lgrid=.false.
        if(gz.gt.maxgrid) lgrid=.false.
        if(gz.lt.-maxgrid)lgrid=.false.

        return
        end
c
c------------------------------------------------------------------------------
c
        function fung(x)
        implicit none
        integer fung
        real x

        fung=nint(x/2)

        return
        end
c
c------------------------------------------------------------------------------
c


module netJina_bdat

contains

    subroutine do_get_bdat_channels(reaclib,rates_dict, &
    & handles,n_coeff,rate_coefficients,q,rate_mask)
        use utils_def, only: integer_dict
        use utils_lib, only: integer_dict_lookup
        use netJina_def

        type(reaclib_data), intent(in) :: reaclib
        type(integer_dict), pointer :: rates_dict
        character(len=max_id_length), intent(in),  &
        & dimension(N_bdat_channels) :: handles
        integer, intent(out), dimension(N_bdat_channels) :: n_coeff
        real(dp), dimension(ncoefficients*max_terms_per_rate,N_bdat_channels), &
        & intent(out) :: rate_coefficients
        real(dp), intent(out), dimension(N_bdat_channels) :: q
        logical, intent(out), dimension(N_bdat_channels) :: rate_mask
        integer :: ierr
        integer :: i, indx, istart, iend

        ierr = 0
        do i = 1, N_bdat_channels
            call integer_dict_lookup(rates_dict,trim(handles(i)),indx,ierr)
            if (ierr /= 0) then
                rate_mask(i) = .FALSE.
                cycle
            end if
            q(i) = reaclib% Qvalue(indx)
            n_coeff(i) = reaclib% N_rate_terms(indx)*ncoefficients
            istart = indx - reaclib% N_rate_terms(indx) + 1
            iend = indx
            rate_coefficients(1:n_coeff(i),i) =  reshape( &
            & reaclib% coefficients(1:ncoefficients,istart:iend),[n_coeff(i)])
            rate_mask(i) = (reaclib% reverse_flag(indx) /= 'v')
        end do
    end subroutine do_get_bdat_channels

    subroutine do_get_bdat_rates(starlib,rates_dict, &
    & handles,T9,rate,uncertainty,q,rate_mask)
        use utils_def, only: integer_dict
        use utils_lib, only: integer_dict_lookup
        use netJina_def

        type(starlib_data), intent(in) :: starlib
        type(integer_dict), pointer :: rates_dict
        character(len=max_id_length), intent(in),  &
        & dimension(N_bdat_channels) :: handles
        real(dp), dimension(number_starlib_temps,N_bdat_channels), &
        & intent(out) :: T9,rate,uncertainty
        real(dp), intent(out), dimension(N_bdat_channels) :: q
        logical, intent(out), dimension(N_bdat_channels) :: rate_mask
        integer :: ierr
        integer :: i, indx

        ierr = 0
        do i = 1, N_bdat_channels
            call integer_dict_lookup(rates_dict,trim(handles(i)),indx,ierr)
            if (ierr /= 0) then
                rate_mask(i) = .FALSE.
                cycle
            end if
            q(i) = starlib% Qvalue(indx)
            rate_mask(i) = (starlib% reverse_flag(indx) /= 'v')
            T9(:,i) = starlib% T9(:,indx)
            rate(:,i) = starlib% rate(:,indx)
            uncertainty(:,i) = starlib% uncertainty(:,indx)
        end do
    end subroutine do_get_bdat_rates

    subroutine do_make_channel_handles(isotope,nuclib,nuclide_dict,handles,ierr)
        use netJina_def
        use utils_def
        use utils_lib
        use iso_fortran_env, only: error_unit
        character(len=iso_name_length), intent(in) :: isotope
        type(nuclib_data), intent(in) :: nuclib
        type(integer_dict), pointer :: nuclide_dict
        character(len=max_id_length),dimension(N_bdat_channels),intent(out) :: &
        & handles
        integer, intent(out) :: ierr
        character(len=2),parameter :: nj = 'nJ'
        character(len=3),parameter :: sep = '_to'
        character(len=5),parameter,dimension(N_bdat_channels) ::  &
        & lhs = [character(len=5) :: '_p_','_he4_','_he4_','_he4_','_n_', &
        & '_n_','_','_n_','_','_p_','_','_p_']
        character(len=5),parameter,dimension(N_bdat_channels) ::  &
        & rhs = [character(len=5) :: '_','_n_','_','_p_','_','_p_','_p_', &
        & '_he4_','_he4_','_he4_','_n_','_n_']
        integer :: indx
        character(len=iso_name_length), dimension(N_bdat_channels) :: products
        integer :: Z, N, Zt, Nt, i
        character(len=*), parameter :: null_handle = 'None'

        ! lookup nuclide
        call integer_dict_lookup(nuclide_dict,trim(isotope),indx,ierr)
        if (failure('looking for '//trim(isotope)//'. error code ',ierr)) &
        & return
        Z = nuclib% Z(indx)
        N = nuclib% N(indx)

        handles = null_handle

        ! set limits on Z, N
        if (Z <= 2 .or. Z > max_element_z-2) then
            ierr = -10
            write(error_unit,'(a,i3,a)') 'Z = ',Z, &
            & ' will produce out-range-links'
            return
        end if
        if (N <= 2 .or. N > maxval(nuclib% N)-2) then
            ierr = -11
            write(error_unit,'(a,i3,a)') 'N = ',N, &
            & ' will produce out-of-range links'
            return
        end if

        do i = 1, N_bdat_channels
            Zt = Z + bdat_dZ(i)
            Nt = N + bdat_dN(i)
            write(products(i),'(a,i0)') trim(element_name(Zt)),Zt+Nt
        end do

        do i = 1, N_bdat_channels
            handles(i) = nj//trim(lhs(i))//trim(isotope)// &
            & sep//trim(rhs(i))//trim(products(i))
        end do

    end subroutine do_make_channel_handles

    function failure(action,ierr)
        use iso_fortran_env, only: error_unit
        character(len=*), intent(in) :: action
        integer, intent(in) :: ierr
        logical :: failure
        character(len=*), parameter :: err_format = &
        &  '("Error while ",a,". error code = ",i0)'

        if (ierr == 0) then
            failure = .FALSE.
            return
        end if
        failure = .TRUE.
        write (error_unit,err_format) action, ierr
    end function failure

end module netJina_bdat


! Compares two output files, usually "struct_enum.out" from enumlib (enum.x) to see if they contain
! equivalent lists.
!
! Started around 2008, used on and off, extensively revised in 2019 when the Smith Normal Form
! code in symlib (rational_mathematics) was updated to be more numerically stable (but
! unfortunately that affected many of the unit tests of enumlib). This program is used to compare
! output data from different versions of the code. The challenge is that data may often be
! equivalent but NOT identical.
!
! A further challenge is that the format of the input and output files change slowly over time and
! this code is fragile to that.
!
! This is not a pretty program. Nor is it efficient. Not for general distribution.
! Don't release it into the wild. It has really been used, a lot, and it works...but is fragile.
! GLWH 2019
program compare_two_struct_enum
use num_types
use symmetry
use enumeration_types
use numerical_utilities
use enumeration_utilities
use io_utils
use derivative_structure_generator
use vector_matrix_utilities
use labeling_related
use combinatorics
implicit none
character(800)  title, dummy
character(len=:), allocatable :: f1name, f2name
real(dp), dimension(3,3) :: pLV1, pLV2, L2inv, T!, L1inv!, Tinv
integer, dimension(3,3,1):: L1, SNF, L2
real(dp), allocatable :: dset1(:,:), dset2(:,:), rot(:,:,:), shift(:,:)
real(dp), pointer :: sLVlist(:,:,:)
integer, pointer :: HNFout(:,:,:), eq(:), digit(:), HNFin(:,:,:)
integer, pointer, dimension(:,:) :: label, g1=>null(), g2=>null(), dlabel, qLabel
integer :: LatDim1, LatDim2, match, nD1, nD2, Nmin, Nmax, k, ioerr
integer :: strN, sizeN, n, pgOps, diag(3), a, b, c, d, e, f, i, jl, j
integer :: iP, nP, lc, iStr2, HNFtest(3,3), hdgenfact, labdgen, totdgen
integer :: strN2, hnfN2, n2, pgOps2, diag2(3), idx, f1, f2, iLP, nLP
integer, allocatable :: ilabeling1(:), ilabeling2(:), atomType(:), automorphism(:)
integer, allocatable :: tempLab(:)
real(dp) :: eps
logical full, HNFmatch, foundLab, err, concMatch
character(maxLabLength)   :: labeling ! List, 0..k-1, of the atomic type at each site
type(RotPermList)         :: dRotList1, dRotList2
type(RotPermList),pointer :: LattRotList2(:)
type(opList), pointer     :: fixOp(:)
integer, pointer          :: crange(:,:), degen_list(:), rotProdLab(:), labPerms(:,:)

SNF = 0
allocate(HNFin(3,3,1))
eps = 1e-4
write(*,'("Epsilon is currently hardwired at ", g11.4)') eps

!
! Read command line arguments for names of files to be compared
!
call getarg(1,dummy)
f1name = trim(dummy)
call getarg(2,dummy)
f2name = trim(dummy)
read(dummy,'(a800)') f2name
if(iargc()/=2) stop "Need two arguments: source and target struct_enum.out-type files"
! This old "read" line was for a previous format of struct_enum.out, presumably.
!call read_struct_enum_out(title,LatDim1,pLV1,nD1,dset1,k,eq,Nmin,Nmax,eps,full,pLabel,digit,f1name,crange,conc_check)
!call read_struct_enum_out_oldstyle(title,LatDim1,pLV1,nD1,dset1,k,eq,Nmin,Nmax,eps,full,dLabel,digit,f1name,crange)

call read_struct_enum_out(title,LatDim1,pLV1,nD1,dset1,k,eq,Nmin,Nmax,eps,full,dlabel,digit,cRange,f1name)
!call read_struct_enum_out(title,LatDim2,pLV2,nD2,dset2,k,eq,Nmin,Nmax,eps,full,pLabel,digit,f2name,crange,conc_check)
call read_struct_enum_out(title,LatDim2,pLV2,nD2,dset2,k,eq,Nmin,Nmax,eps,full,dLabel,digit,crange,f2name)
if (LatDim1/=LatDim2) stop "Bulk/surf modes are not the same in the input files"
print*,"Finished reading header info in both files"

! Basic checks for possible equivalence
if (.not. equal(pLV2,pLV1,eps)) stop "Parent lattice vectors are not identical"
if (nD1/=nD2) stop "Number of d-vectors are not equivalent"
if (.not. equal(dset1,dset2,eps)) stop "D-vectors are not equivalent"
allocate(label(1,nD1),digit(nD1))
label = 1
digit = 1

!
! "Fast forward" to structures in file1
!
f1 = 10; open(f1,file=f1name,status="old")
do ! read f1name file until the structure list begins
   read(f1,*) title
   title = adjustl(title)
   if(title(1:5).eq."start")exit
enddo
print *,"Successfully opened first file and advanced to the structures list"

! If there are multiple d-vectors in the parent lattice, we need to know what permutations (if any)
! are allowed. The permutations are needed to eliminate duplicate lattices.
allocate(atomType(nD1)); atomType = 1
call get_spaceGroup(pLV1, atomType, dset1, rot, shift, .false., eps)
do i = 1, size(dset1,2)
write(*,'(3("dset1:   ",3(f10.6,1x)))') dset1(:,i)
enddo
call get_dvector_permutations(pLV1,dset1,nD1,rot,shift,dRotList1,LatDim1,eps)

print *, "Be aware that HNFs are directly compared"
print *, "Rotationally equivalent HNFs are not considered"
print *, "Change this in the future"

call get_permutations((/(i,i=0,k-1)/),labPerms)
nLP = size(labPerms,2)
write(*,'("label Perms: ",30i2)') (labPerms(i,:),i=1,size(labPerms,1))

!
! Loop over all structures in file1
!
open(13,file="debug_match_check.out")
f1loop: do ! Read each structure from f1 and see if it is in the list of f2 structures
   read(f1,*,iostat=ioerr) strN, sizeN, hdgenfact, labdgen, totdgen, idx, n,  pgOps, diag, a,b,c,d,e,f, L1(:,:,1), labeling
   !read(f1,*,iostat=ioerr) strN, sizeN, n,  pgOps, diag, a,b,c,d,e,f, L(:,:,1), labeling
   if(ioerr/=0) exit
   write(13,'("file1 str: ",i5)') strN
   L1(:,:,1) = transpose(L1(:,:,1)) ! Written out column-wise but read in row-wise. So fix it by transposing
   SNF(1,1,1) = diag(1); SNF(2,2,1) = diag(2); SNF(3,3,1) = diag(3)

   HNFin = 0 ! Load up the HNF with the elements that were read in.
   HNFin(1,1,1) = a; HNFin(2,1,1) = b; HNFin(2,2,1) = c;
   HNFin(3,1,1) = d; HNFin(3,2,1) = e; HNFin(3,3,1) = f;

   ! Use the permutations effected by the rotations that fix the superlattice to generate labelings
   ! that are equivalent. The list of equivalent labelings will be used when we look for a match in the struct_enum file
   if (allocated(tempLab)) deallocate(tempLab)
   allocate(ilabeling1(n*nD1),ilabeling2(n*nD1),tempLab(n*nD1))!,permutedLab(n*nD1)) 26 July, permutedLab not used
   read(labeling,'(500i1)') ilabeling1
   !write(*,'("ilabeling1:",/,30(i1),/)') ilabeling1
   match = 0
   ! Read in each structure from the second file and see if it matches the current structures from
   ! file 1.

!! END read from file1

   f2 = 14; ! Define a unit number for the second file.
   open(f2,file=f2name,status="old")
   lc = 0 ! Count the number of lines
   do ! read the second file until the structure list begins
      read(f2,*) title
      title = adjustl(title)
      if(title(1:5).eq."start")exit
      lc = lc + 1
      if (lc > 100) stop "Didn't find the 'start' tag in the second file"
   enddo
   iStr2 = 0

!! END reading of 'header' from file2
! You can get a subtle bug here, hard to chase down, if you have another module opening files with the same unit number. Make sure that the unit numbers for files opened by this program are unique.  GLWH 2019 (that's why f2 is set to 14 above)

   compareloop: do
      write(13,'("Compare loop: file1 strN ",i6)') strN
      iStr2 = iStr2 + 1
      read(f2,*,iostat=ioerr) strN2, hnfN2, hdgenfact, labdgen, totdgen, sizeN, n2, pgOps2, diag2, a,b,c,d,e,f, L2(:,:,1), labeling
      write(13,'("read from file 2: strN2: ",i5)') strN2
      if(ioerr/=0) exit
      read(labeling,'(500i1)') ilabeling2
      L2(:,:,1) = transpose(L2(:,:,1)) ! Written out column-wise but read in row-wise. So fix it by transposing

      write(*,'("Comparing structures (f1 vs f2): ",2(i6,1x))') strN, strN2
      write(13,'("Comparing structures (f1 vs f2): ",2(i6,1x))') strN, strN2
      if (n2 < n) then ! Unit cells in this block are too small
         write(13,'("Volume is too small for structure #: ",i9," in file 2 (label # ",i9,")")') iStr2
         cycle
      endif
      ! Note here that we are assuming the structures are listed in ascending order by size. If
      ! that is not the case, one cannot use this early exit to speed things up. As it stands now
      ! though, the enum code always writes in ascending size order.
      if (n2 > n) then  ! We've passed the point in the f2 file where the size of cells matches
         write(13,'("Volume is too big for structure #: ",i9," in file 2 (label # ", &
              !& i9,")")') iStr2, strN2
         exit
      else
         write(13,'("Volume matches for structure #: ",i9," in file 2 (label # ", &
              !& i9,")")') iStr2, strN2
      endif
      !read(labeling,'(500i1)') ilabeling2(1:n2*nD2)
      HNFtest = 0;
      HNFtest = reshape((/a,b,d,0,c,e,0,0,f/),(/3,3/))
      HNFmatch = .false.
      if(all(HNFtest==HNFin(:,:,1))) then ! HNFs match, next check the labeling
         write(13,'("HNF matches for structure #: ",i9," in file 2 (label # ", &
              !& i9,")")') iStr2, strN2
         HNFmatch = .true.
      else
         write(13,'("HNF doesn''t match for structure #: ",i9," in file 2 (label # ", &
               !        & i9,")")') iStr2, strN2
         cycle
      endif
      ! If ilabeling2 *or* one if its complements has the correct concentration, then we need to continue in the check.

      do iLP = 1, nLP ! Loop over all complements of the labels (stored in 'labPerms')
         do i = 0,k-1 ! Loop over each color to make the complement of the label
            where  (ilabeling2==i) tempLab = labPerms(iLP,i+1)
         enddo
         concMatch = .true.
         do i = 0, k-1
            if (count(tempLab==i)/=count(ilabeling1==i)) then
               concMatch = .false.
            endif
         enddo
         if (concMatch) exit
      enddo
      if (.not. concMatch) then
         write(13,'("Concentrations (and all complements) don''t match")')
         cycle compareloop
      endif
      write(13,'("Concentrations (or complements) match for structures:",2(i6,1x))') strN, strN2
! <<< The next 100 lines or so compares the labelings---everything else matches at this point >>>

   ! We do "remove_duplicate_lattices" even though there are no duplicates to remove because the routine also generates the vector subscripts for the label permutations and we need these to generate the list of equivalent labelings
   ! We could use dRotList1 is used in the "remove_..." and "get_r..." calls below because, at this point, we've established that dRotList1 and dRotList2 would be the same, and it would be more efficient to find dRotList1 outside of the compare loop
   call get_dvector_permutations(pLV2,dset2,nD2,rot,shift,dRotList2,LatDim2,eps) ! get dRotList2
   call remove_duplicate_lattices(HNFin,LatDim2,pLV2,rot,shift,dset2,dRotList2,HNFout,fixOp,&
                                  LattRotList2,sLVlist,degen_list,eps) ! get fixing operations
   !open(17,file="debug_rotation_permutations.out")
   ! Get the list of label permutations
   call get_rotation_perms_lists(pLV2,HNFout,L2,SNF,fixOp,LattRotList2,dRotList2,eps)
   !write(17,'("Rots Indx:",/,8(24(i3,1x),/))') LattRotList2(1)%RotIndx(:)
   !write(17,'("Permutation group (trans+rot):")')
   nP = size(LattRotList2(1)%perm,1)
   ! do ip = 1, nP
   !    write(17,'("Perm #",i3,":",1x,200(i2,1x))') ip,LattRotList2(1)%perm(ip,:)
   ! enddo
   call find_equivalent_labelings(ilabeling2,LattRotList2,qLabel,rotProdLab)
   if (any(L1/=L2)) then ! We must find the automorphism that connects the two different groups and adjust ilabeling2 accordingly
      print*,"L1/=L2"
      if (associated(g1)) deallocate(g1); if (associated(g2)) deallocate(g2)
      !1) build the member list
      call make_member_list(diag,g1) ! This routine allocates g1
      !2) find the group automorphism
      call matrix_inverse(real(L2(:,:,1),dp),L2inv,err)
      if (err) stop "Inverse of L_2 matrix is not defined"
      T = matmul(L1(:,:,1),L2inv)
      allocate(g2(3,size(g1,2)))
      !g2 = -1
      g2 = nint(matmul(T,g1))
      g2 = modulo(g2,spread(diag,2,n))

      ! Next, find the rearrangement between the two groups (the automorphism)
      if (allocated(automorphism)) deallocate(automorphism)
      allocate(automorphism(n2))
      call find_permutation_of_group(g1,g2,automorphism)
      !write(13,"('automorphism')")
      !write(13,"(50i1)") automorphism
      ! 3) Apply the automorphism to every permuted labeling (qLabels)
      do j = 1,size(qLabel,1)
         do i = 0, n*nD2-1, n ! Each block of 'n' needs a copy of the automorphism
            qLabel(j,1+i:n+i) = qLabel(j,automorphism+i)
         enddo
      enddo
   endif
   !4) proceed as normal

   foundLab = .false.
   ! We need to loop over all permutations (to get the full orbit) because we do not know
   ! which member of the orbit is the representative.
   ! We also need to check the complement of each labeling because any of the complements ! may appear in either list. GLWH 2019, see email chain, subject: "Monk?", with Rod Forcade starting May 16 2019, and subject "Eureka" starting Sep 5 2019
   do jL = 1, size(qlabel,1)
      !ilabeling2 = qLabel(jL,:)
      ! if(all(ilabeling2==ilabeling1)) then
      !    foundLab = .true.
      !    write(13,'("MATCH  Perm #: ",i3)') jl
      !    if (match/=0) then
      !       write(13,'("Additional match found: ",i6," == ",i6)') strN, strN2
      !        write(13,'("In file 2, structure ",i6)') strN2
      !        write(13,'("was equivalent to ",i6)') match
      !        write(13,'("in file 1")')
      !       stop "BUG! Found more than one match in struct_enum.out file"
      !    endif
      !    match = strN2
      !    exit
      ! endif
      do iLP = 1, nLP ! Loop over all complements of the labels (stored in 'labPerms').
         do i = 0,k-1 ! Loop over each color to make the complement of the label
            where  (qLabel(jL,:)==i) ilabeling2 = labPerms(iLP,i+1)
         enddo
         if(all(ilabeling1==ilabeling2)) then
            foundLab = .true.
            if (match/=0) then
               write(13,'("Additional match found: ",i6," == ",i6)') strN, strN2
               write(13,'("In file 2, structure ",i6)') strN2
               write(13,'("was also equivalent to ",i6)') match
               write(13,'("in file 1")')
               stop "BUG! Found more than one match in struct_enum.out file"
            endif
            match = strN2
            exit !iLP loop over complements
         endif
      enddo !iLP loop
      if (foundLab) exit ! loop over permutations. Some labelings are invariant under some permutations. So without the exit, we will find a duplicate
   enddo ! jL Loop over permutations
   if(.not. foundLab) then
      write(13,'("Labeling didn''t match for str #:",i8)') strN
   else
      write(13,'("Structure number:",i8," in file2 is a match to ",i8," in file1!")') strN2, strN
   endif
   !if (match/=0) exit
   enddo compareloop
   close(f2)
   if(match==0) then
      write(13,'("Match for str #:",i8," in file 1 was not found in file 2")') strN
      stop "Match not found!"
   else
      write(13,'("Structure number:",i8," is a match to # ",i9," in file 2.")') strN, match
   endif
   deallocate(ilabeling2)
   deallocate(ilabeling1)
enddo f1loop
close(13)
write(*,'("The labelings in the two lists have 1-1 correspondence.")')

endprogram compare_two_struct_enum


MODULE module_kpp_racm_esrlsorg_interf
  USE module_state_description
  USE module_configure
  USE racm_esrlsorg_Parameters
  USE racm_esrlsorg_Precision
  USE racm_esrlsorg_UpdateRconstWRF
  USE racm_esrlsorg_Integrator
  USE module_wkppc_constants
  USE module_data_sorgam, ONLY : PXYL, PTOL, PCSL1, PCSL2, PHC8, POLI1, POLI2, POLI3, POLT1, POLT2, POLT3, PAPI1, PAPI2, PAPI3, PLIM1, PLIM2, PLIM3
     INTEGER, PARAMETER, PRIVATE :: Pj_o31d = 1
     INTEGER, PARAMETER, PRIVATE :: Pj_o33p = 2
     INTEGER, PARAMETER, PRIVATE :: Pj_no2 = 3
     INTEGER, PARAMETER, PRIVATE :: Pj_no3o2 = 4
     INTEGER, PARAMETER, PRIVATE :: Pj_no3o = 5
     INTEGER, PARAMETER, PRIVATE :: Pj_hno2 = 6
     INTEGER, PARAMETER, PRIVATE :: Pj_hno3 = 7
     INTEGER, PARAMETER, PRIVATE :: Pj_hno4 = 8
     INTEGER, PARAMETER, PRIVATE :: Pj_h2o2 = 9
     INTEGER, PARAMETER, PRIVATE :: Pj_ch2or = 10
     INTEGER, PARAMETER, PRIVATE :: Pj_ch2om = 11
     INTEGER, PARAMETER, PRIVATE :: Pj_ch3cho = 12
     INTEGER, PARAMETER, PRIVATE :: Pj_ch3coch3 = 13
     INTEGER, PARAMETER, PRIVATE :: Pj_ch3coc2h5 = 14
     INTEGER, PARAMETER, PRIVATE :: Pj_hcocho = 15
     INTEGER, PARAMETER, PRIVATE :: Pj_ch3cocho = 16
     INTEGER, PARAMETER, PRIVATE :: Pj_hcochest = 17
     INTEGER, PARAMETER, PRIVATE :: Pj_ch3o2h = 18
     INTEGER, PARAMETER, PRIVATE :: Pj_ch3coo2h = 19
     INTEGER, PARAMETER, PRIVATE :: Pj_ch3ono2 = 20
     INTEGER, PARAMETER, PRIVATE :: Pj_hcochob = 21
     INTEGER, PARAMETER, PRIVATE :: Pj_macr = 22
     INTEGER, PARAMETER, PRIVATE :: Pj_n2o5 = 23
     INTEGER, PARAMETER, PRIVATE :: Pj_o2 = 24
     INTEGER, PARAMETER, PRIVATE :: Pj_pan = 25
     INTEGER, PARAMETER, PRIVATE :: Pj_acet = 26
     INTEGER, PARAMETER, PRIVATE :: Pj_mglo = 27
     INTEGER, PARAMETER, PRIVATE :: Pj_hno4_2 = 28
     INTEGER, PARAMETER, PRIVATE :: Pj_n2o = 29
     INTEGER, PARAMETER, PRIVATE :: Pj_pooh = 30
     INTEGER, PARAMETER, PRIVATE :: Pj_mpan = 31
     INTEGER, PARAMETER, PRIVATE :: Pj_mvk = 32
     INTEGER, PARAMETER, PRIVATE :: Pj_etooh = 33
     INTEGER, PARAMETER, PRIVATE :: Pj_prooh = 34
     INTEGER, PARAMETER, PRIVATE :: Pj_onitr = 35
     INTEGER, PARAMETER, PRIVATE :: Pj_acetol = 36
     INTEGER, PARAMETER, PRIVATE :: Pj_glyald = 37
     INTEGER, PARAMETER, PRIVATE :: Pj_hyac = 38
     INTEGER, PARAMETER, PRIVATE :: Pj_mek = 39
     INTEGER, PARAMETER, PRIVATE :: Pj_open = 40
     INTEGER, PARAMETER, PRIVATE :: Pj_gly = 41
     INTEGER, PARAMETER, PRIVATE :: Pj_acetp = 42
     INTEGER, PARAMETER, PRIVATE :: Pj_xooh = 43
     INTEGER, PARAMETER, PRIVATE :: Pj_isooh = 44
     INTEGER, PARAMETER, PRIVATE :: Pj_alkooh = 45
     INTEGER, PARAMETER, PRIVATE :: Pj_mekooh = 46
     INTEGER, PARAMETER, PRIVATE :: Pj_tolooh = 47
     INTEGER, PARAMETER, PRIVATE :: Pj_terpooh = 48
CONTAINS
SUBROUTINE racm_esrlsorg_interface( &
    chem, id, dtstepc,config_flags, &
    p_phy,t_phy,rho_phy,moist, &
    vdrog3, ldrog, vdrog3_vbs, ldrog_vbs, &
             addt, addx, addc, etep, oltp, &
             olip, cslp, limp, hc5p, hc8p, &
             tolp, xylp, apip, isop, hc3p, &
             ethp, o3p, tco3, mo2, o1d, &
             olnn, olnd, rpho, xo2, ketp, &
             xno2, ol2p, oln, macp, hocoo, &
             bzno2_o, bz_o, tbu_o, &
             ph_o31d, ph_o33p, ph_no2, ph_no3o2, ph_no3o, &
             ph_hno2, ph_hno3, ph_hno4, ph_h2o2, ph_ch2or, &
             ph_ch2om, ph_ch3cho, ph_ch3coch3, ph_ch3coc2h5, ph_hcocho, &
             ph_ch3cocho, ph_hcochest, ph_ch3o2h, ph_ch3coo2h, ph_ch3ono2, &
             ph_hcochob, ph_macr, ph_n2o5, ph_o2, ph_pan, &
             ph_acet, ph_mglo, ph_hno4_2, ph_n2o, ph_pooh, &
             ph_mpan, ph_mvk, ph_etooh, ph_prooh, ph_onitr, &
             ph_acetol, ph_glyald, ph_hyac, ph_mek, ph_open, &
             ph_gly, ph_acetp, ph_xooh, ph_isooh, ph_alkooh, &
             ph_mekooh, ph_tolooh, ph_terpooh, &
              ids,ide, jds,jde, kds,kde, &
              ims,ime, jms,jme, kms,kme, &
              its,ite, jts,jte, kts,kte )
    IMPLICIT NONE
    INTEGER, INTENT(IN ) :: &
                      ids,ide, jds,jde, kds,kde, &
                      ims,ime, jms,jme, kms,kme, &
                      its,ite, jts,jte, kts,kte
    INTEGER, INTENT(IN ) :: id
    REAL, INTENT(IN ) :: dtstepc
    TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
         INTENT(INOUT ) :: chem
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
         INTENT(IN ) :: moist
     REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
             INTENT(IN ) :: &
                                                         p_phy, &
                                                         t_phy, &
                                                         rho_phy
    INTEGER, INTENT ( IN ) :: ldrog
    REAL, INTENT(INOUT) :: &
                      vdrog3(ims:ime,kms:kme-0,jms:jme,ldrog)
    INTEGER, INTENT ( IN ) :: ldrog_vbs
    REAL, INTENT(INOUT) :: &
                      vdrog3_vbs(ims:ime,kms:kme-0,jms:jme,ldrog_vbs)
      REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
         INTENT(INOUT ) :: &
               addt, addx, addc, etep, oltp, &
               olip, cslp, limp, hc5p, hc8p, &
               tolp, xylp, apip, isop, hc3p, &
               ethp, o3p, tco3, mo2, o1d, &
               olnn, olnd, rpho, xo2, ketp, &
               xno2, ol2p, oln, macp, hocoo, &
               bzno2_o, bz_o, tbu_o
      REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
         INTENT(INOUT ) :: &
               ph_o31d, ph_o33p, ph_no2, ph_no3o2, ph_no3o, &
               ph_hno2, ph_hno3, ph_hno4, ph_h2o2, ph_ch2or, &
               ph_ch2om, ph_ch3cho, ph_ch3coch3, ph_ch3coc2h5, ph_hcocho, &
               ph_ch3cocho, ph_hcochest, ph_ch3o2h, ph_ch3coo2h, ph_ch3ono2, &
               ph_hcochob, ph_macr, ph_n2o5, ph_o2, ph_pan, &
               ph_acet, ph_mglo, ph_hno4_2, ph_n2o, ph_pooh, &
               ph_mpan, ph_mvk, ph_etooh, ph_prooh, ph_onitr, &
               ph_acetol, ph_glyald, ph_hyac, ph_mek, ph_open, &
               ph_gly, ph_acetp, ph_xooh, ph_isooh, ph_alkooh, &
               ph_mekooh, ph_tolooh, ph_terpooh
    INTEGER, PARAMETER :: njv=48
    REAL(KIND=dp), DIMENSION(njv) :: jv
    REAL(KIND=dp):: TIME_START
    REAL(KIND=dp):: TIME_END
    INTEGER, DIMENSION(20) :: ICNTRL
    REAL(KIND=dp), DIMENSION(20) :: RCNTRL
    INTEGER, DIMENSION(20) :: ISTATUS
    REAL(KIND=dp), DIMENSION(20) :: RSTATUS
    INTEGER :: IERR_U
    REAL(KIND=dp), DIMENSION(NREACT):: RCONST
    REAL(KIND=dp), DIMENSION(NVAR) :: var
    REAL(KIND=dp), DIMENSION(NFIX) :: fix
    REAL(KIND=dp) :: TEMP
    REAL(KIND=dp), DIMENSION(NSPEC) :: ATOL, RTOL
    REAL(KIND=dp) :: conv, oconv
    REAL(KIND=dp) :: C_M
    INTEGER :: i,j,k,n
      REAL(KIND=dp) :: rxylho,rtolho,rcslho,rcslno3,rhc8ho,roliho,rolino3, &
                        rolio3,roltho,roltno3,rolto3,rapiho,rapino3,rapio3, &
                        rlimho,rlimno3,rlimo3
      REAL(KIND=dp) , DIMENSION(ldrog) :: PRDROG
      DO n=1, 20
         ICNTRL(n) = 0
         RCNTRL(n) = 0._dp
      END DO
      DO n=1, NSPEC
         ATOL(n) = REAL(atols, KIND=dp)
         RTOL(n) = REAL(rtols, KIND=dp)
      END DO
      TIME_START = 0.0_dp
      TIME_END = REAL(dtstepc, KIND=dp)
   ICNTRL(1) = 1
   ICNTRL(3) = 2
   RCNTRL(3) = 0.01_dp * TIME_END
    DO j=jts, jte
    DO k=kts, kte
    DO i=its, ite
    FIX(indf_M) = REAL(dens2con_a * rho_phy(i,k,j), KIND=dp)
    C_M = FIX(indf_M)
    FIX(indf_H2O) = REAL(dens2con_w * moist(i,k,j,P_QV) * rho_phy(i,k,j), KIND=dp)
    TEMP = REAL(t_phy(i,k,j), KIND=dp)
     conv=1.E-6_dp*dens2con_a*rho_phy(i,k,j)
     oconv = 1.E0_dp/conv
    jv(Pj_o31d) = REAL(ph_o31d(i,k,j)/60., KIND=dp)
    jv(Pj_o33p) = REAL(ph_o33p(i,k,j)/60., KIND=dp)
    jv(Pj_no2) = REAL(ph_no2(i,k,j)/60., KIND=dp)
    jv(Pj_no3o2) = REAL(ph_no3o2(i,k,j)/60., KIND=dp)
    jv(Pj_no3o) = REAL(ph_no3o(i,k,j)/60., KIND=dp)
    jv(Pj_hno2) = REAL(ph_hno2(i,k,j)/60., KIND=dp)
    jv(Pj_hno3) = REAL(ph_hno3(i,k,j)/60., KIND=dp)
    jv(Pj_hno4) = REAL(ph_hno4(i,k,j)/60., KIND=dp)
    jv(Pj_h2o2) = REAL(ph_h2o2(i,k,j)/60., KIND=dp)
    jv(Pj_ch2or) = REAL(ph_ch2or(i,k,j)/60., KIND=dp)
    jv(Pj_ch2om) = REAL(ph_ch2om(i,k,j)/60., KIND=dp)
    jv(Pj_ch3cho) = REAL(ph_ch3cho(i,k,j)/60., KIND=dp)
    jv(Pj_ch3coch3) = REAL(ph_ch3coch3(i,k,j)/60., KIND=dp)
    jv(Pj_ch3coc2h5) = REAL(ph_ch3coc2h5(i,k,j)/60., KIND=dp)
    jv(Pj_hcocho) = REAL(ph_hcocho(i,k,j)/60., KIND=dp)
    jv(Pj_ch3cocho) = REAL(ph_ch3cocho(i,k,j)/60., KIND=dp)
    jv(Pj_hcochest) = REAL(ph_hcochest(i,k,j)/60., KIND=dp)
    jv(Pj_ch3o2h) = REAL(ph_ch3o2h(i,k,j)/60., KIND=dp)
    jv(Pj_ch3coo2h) = REAL(ph_ch3coo2h(i,k,j)/60., KIND=dp)
    jv(Pj_ch3ono2) = REAL(ph_ch3ono2(i,k,j)/60., KIND=dp)
    jv(Pj_hcochob) = REAL(ph_hcochob(i,k,j)/60., KIND=dp)
    jv(Pj_macr) = REAL(ph_macr(i,k,j)/60., KIND=dp)
    jv(Pj_n2o5) = REAL(ph_n2o5(i,k,j)/60., KIND=dp)
    jv(Pj_o2) = REAL(ph_o2(i,k,j)/60., KIND=dp)
    jv(Pj_pan) = REAL(ph_pan(i,k,j)/60., KIND=dp)
    jv(Pj_acet) = REAL(ph_acet(i,k,j)/60., KIND=dp)
    jv(Pj_mglo) = REAL(ph_mglo(i,k,j)/60., KIND=dp)
    jv(Pj_hno4_2) = REAL(ph_hno4_2(i,k,j)/60., KIND=dp)
    jv(Pj_n2o) = REAL(ph_n2o(i,k,j)/60., KIND=dp)
    jv(Pj_pooh) = REAL(ph_pooh(i,k,j)/60., KIND=dp)
    jv(Pj_mpan) = REAL(ph_mpan(i,k,j)/60., KIND=dp)
    jv(Pj_mvk) = REAL(ph_mvk(i,k,j)/60., KIND=dp)
    jv(Pj_etooh) = REAL(ph_etooh(i,k,j)/60., KIND=dp)
    jv(Pj_prooh) = REAL(ph_prooh(i,k,j)/60., KIND=dp)
    jv(Pj_onitr) = REAL(ph_onitr(i,k,j)/60., KIND=dp)
    jv(Pj_acetol) = REAL(ph_acetol(i,k,j)/60., KIND=dp)
    jv(Pj_glyald) = REAL(ph_glyald(i,k,j)/60., KIND=dp)
    jv(Pj_hyac) = REAL(ph_hyac(i,k,j)/60., KIND=dp)
    jv(Pj_mek) = REAL(ph_mek(i,k,j)/60., KIND=dp)
    jv(Pj_open) = REAL(ph_open(i,k,j)/60., KIND=dp)
    jv(Pj_gly) = REAL(ph_gly(i,k,j)/60., KIND=dp)
    jv(Pj_acetp) = REAL(ph_acetp(i,k,j)/60., KIND=dp)
    jv(Pj_xooh) = REAL(ph_xooh(i,k,j)/60., KIND=dp)
    jv(Pj_isooh) = REAL(ph_isooh(i,k,j)/60., KIND=dp)
    jv(Pj_alkooh) = REAL(ph_alkooh(i,k,j)/60., KIND=dp)
    jv(Pj_mekooh) = REAL(ph_mekooh(i,k,j)/60., KIND=dp)
    jv(Pj_tolooh) = REAL(ph_tolooh(i,k,j)/60., KIND=dp)
    jv(Pj_terpooh) = REAL(ph_terpooh(i,k,j)/60., KIND=dp)
    var(ind_O3) = conv * REAL( MAX(chem(i,k,j,P_o3),0.), KIND=dp)
    var(ind_H2O2) = conv * REAL( MAX(chem(i,k,j,P_h2o2),0.), KIND=dp)
    var(ind_NO) = conv * REAL( MAX(chem(i,k,j,P_no),0.), KIND=dp)
    var(ind_NO2) = conv * REAL( MAX(chem(i,k,j,P_no2),0.), KIND=dp)
    var(ind_NO3) = conv * REAL( MAX(chem(i,k,j,P_no3),0.), KIND=dp)
    var(ind_N2O5) = conv * REAL( MAX(chem(i,k,j,P_n2o5),0.), KIND=dp)
    var(ind_HONO) = conv * REAL( MAX(chem(i,k,j,P_hono),0.), KIND=dp)
    var(ind_HNO3) = conv * REAL( MAX(chem(i,k,j,P_hno3),0.), KIND=dp)
    var(ind_HNO4) = conv * REAL( MAX(chem(i,k,j,P_hno4),0.), KIND=dp)
    var(ind_SO2) = conv * REAL( MAX(chem(i,k,j,P_so2),0.), KIND=dp)
    var(ind_SULF) = conv * REAL( MAX(chem(i,k,j,P_sulf),0.), KIND=dp)
    var(ind_CO) = conv * REAL( MAX(chem(i,k,j,P_co),0.), KIND=dp)
    var(ind_CO2) = conv * REAL( MAX(chem(i,k,j,P_co2),0.), KIND=dp)
    var(ind_CH4) = conv * REAL( MAX(chem(i,k,j,P_ch4),0.), KIND=dp)
    var(ind_ETH) = conv * REAL( MAX(chem(i,k,j,P_eth),0.), KIND=dp)
    var(ind_HC3) = conv * REAL( MAX(chem(i,k,j,P_hc3),0.), KIND=dp)
    var(ind_HC5) = conv * REAL( MAX(chem(i,k,j,P_hc5),0.), KIND=dp)
    var(ind_HC8) = conv * REAL( MAX(chem(i,k,j,P_hc8),0.), KIND=dp)
    var(ind_ETE) = conv * REAL( MAX(chem(i,k,j,P_ete),0.), KIND=dp)
    var(ind_OLT) = conv * REAL( MAX(chem(i,k,j,P_olt),0.), KIND=dp)
    var(ind_OLI) = conv * REAL( MAX(chem(i,k,j,P_oli),0.), KIND=dp)
    var(ind_DIEN) = conv * REAL( MAX(chem(i,k,j,P_dien),0.), KIND=dp)
    var(ind_ISO) = conv * REAL( MAX(chem(i,k,j,P_iso),0.), KIND=dp)
    var(ind_API) = conv * REAL( MAX(chem(i,k,j,P_api),0.), KIND=dp)
    var(ind_LIM) = conv * REAL( MAX(chem(i,k,j,P_lim),0.), KIND=dp)
    var(ind_TOL) = conv * REAL( MAX(chem(i,k,j,P_tol),0.), KIND=dp)
    var(ind_XYL) = conv * REAL( MAX(chem(i,k,j,P_xyl),0.), KIND=dp)
    var(ind_CSL) = conv * REAL( MAX(chem(i,k,j,P_csl),0.), KIND=dp)
    var(ind_HCHO) = conv * REAL( MAX(chem(i,k,j,P_hcho),0.), KIND=dp)
    var(ind_ALD) = conv * REAL( MAX(chem(i,k,j,P_ald),0.), KIND=dp)
    var(ind_KET) = conv * REAL( MAX(chem(i,k,j,P_ket),0.), KIND=dp)
    var(ind_GLY) = conv * REAL( MAX(chem(i,k,j,P_gly),0.), KIND=dp)
    var(ind_MGLY) = conv * REAL( MAX(chem(i,k,j,P_mgly),0.), KIND=dp)
    var(ind_DCB) = conv * REAL( MAX(chem(i,k,j,P_dcb),0.), KIND=dp)
    var(ind_MACR) = conv * REAL( MAX(chem(i,k,j,P_macr),0.), KIND=dp)
    var(ind_UDD) = conv * REAL( MAX(chem(i,k,j,P_udd),0.), KIND=dp)
    var(ind_HKET) = conv * REAL( MAX(chem(i,k,j,P_hket),0.), KIND=dp)
    var(ind_ONIT) = conv * REAL( MAX(chem(i,k,j,P_onit),0.), KIND=dp)
    var(ind_PAN) = conv * REAL( MAX(chem(i,k,j,P_pan),0.), KIND=dp)
    var(ind_TPAN) = conv * REAL( MAX(chem(i,k,j,P_tpan),0.), KIND=dp)
    var(ind_OP1) = conv * REAL( MAX(chem(i,k,j,P_op1),0.), KIND=dp)
    var(ind_OP2) = conv * REAL( MAX(chem(i,k,j,P_op2),0.), KIND=dp)
    var(ind_PAA) = conv * REAL( MAX(chem(i,k,j,P_paa),0.), KIND=dp)
    var(ind_ORA1) = conv * REAL( MAX(chem(i,k,j,P_ora1),0.), KIND=dp)
    var(ind_ORA2) = conv * REAL( MAX(chem(i,k,j,P_ora2),0.), KIND=dp)
    var(ind_HO) = conv * REAL( MAX(chem(i,k,j,P_ho),0.), KIND=dp)
    var(ind_HO2) = conv * REAL( MAX(chem(i,k,j,P_ho2),0.), KIND=dp)
    var(ind_O3P) = conv * REAL( MAX(o3p(i,k,j),0.), KIND=dp)
    var(ind_O1D) = conv * REAL( MAX(o1d(i,k,j),0.), KIND=dp)
    var(ind_MO2) = conv * REAL( MAX(mo2(i,k,j),0.), KIND=dp)
    var(ind_ETHP) = conv * REAL( MAX(ethp(i,k,j),0.), KIND=dp)
    var(ind_HC3P) = conv * REAL( MAX(hc3p(i,k,j),0.), KIND=dp)
    var(ind_HC5P) = conv * REAL( MAX(hc5p(i,k,j),0.), KIND=dp)
    var(ind_HC8P) = conv * REAL( MAX(hc8p(i,k,j),0.), KIND=dp)
    var(ind_ETEP) = conv * REAL( MAX(etep(i,k,j),0.), KIND=dp)
    var(ind_OLTP) = conv * REAL( MAX(oltp(i,k,j),0.), KIND=dp)
    var(ind_OLIP) = conv * REAL( MAX(olip(i,k,j),0.), KIND=dp)
    var(ind_ISOP) = conv * REAL( MAX(isop(i,k,j),0.), KIND=dp)
    var(ind_APIP) = conv * REAL( MAX(apip(i,k,j),0.), KIND=dp)
    var(ind_LIMP) = conv * REAL( MAX(limp(i,k,j),0.), KIND=dp)
    var(ind_PHO) = conv * REAL( MAX(RPHO(i,k,j),0.), KIND=dp)
    var(ind_ADDT) = conv * REAL( MAX(addt(i,k,j),0.), KIND=dp)
    var(ind_ADDX) = conv * REAL( MAX(addx(i,k,j),0.), KIND=dp)
    var(ind_ADDC) = conv * REAL( MAX(addc(i,k,j),0.), KIND=dp)
    var(ind_TOLP) = conv * REAL( MAX(tolp(i,k,j),0.), KIND=dp)
    var(ind_XYLP) = conv * REAL( MAX(xylp(i,k,j),0.), KIND=dp)
    var(ind_CSLP) = conv * REAL( MAX(cslp(i,k,j),0.), KIND=dp)
    var(ind_ACO3) = conv * REAL( MAX(chem(i,k,j,P_aco3),0.), KIND=dp)
    var(ind_TCO3) = conv * REAL( MAX(tco3(i,k,j),0.), KIND=dp)
    var(ind_KETP) = conv * REAL( MAX(ketp(i,k,j),0.), KIND=dp)
    var(ind_OLNN) = conv * REAL( MAX(olnn(i,k,j),0.), KIND=dp)
    var(ind_OLND) = conv * REAL( MAX(olnd(i,k,j),0.), KIND=dp)
    var(ind_XO2) = conv * REAL( MAX(xo2(i,k,j),0.), KIND=dp)
    var(ind_HACE) = conv * REAL( MAX(chem(i,k,j,P_hace),0.), KIND=dp)
    var(ind_ISHP) = conv * REAL( MAX(chem(i,k,j,P_ishp),0.), KIND=dp)
    var(ind_ISON) = conv * REAL( MAX(chem(i,k,j,P_ison),0.), KIND=dp)
    var(ind_MACP) = conv * REAL( MAX(macp(i,k,j),0.), KIND=dp)
    var(ind_MAHP) = conv * REAL( MAX(chem(i,k,j,P_mahp),0.), KIND=dp)
    var(ind_MPAN) = conv * REAL( MAX(chem(i,k,j,P_mpan),0.), KIND=dp)
    var(ind_NALD) = conv * REAL( MAX(chem(i,k,j,P_nald),0.), KIND=dp)
   CALL racm_esrlsorg_Update_Rconst( &
             jv, njv, &
             RCONST, &
             Pj_o31d, Pj_o33p, Pj_no2, Pj_no3o2, Pj_no3o, &
             Pj_hno2, Pj_hno3, Pj_hno4, Pj_h2o2, Pj_ch2or, &
             Pj_ch2om, Pj_ch3cho, Pj_ch3coch3, Pj_ch3coc2h5, Pj_hcocho, &
             Pj_ch3cocho, Pj_hcochest, Pj_ch3o2h, Pj_ch3coo2h, Pj_ch3ono2, &
             Pj_hcochob, Pj_macr, Pj_n2o5, Pj_o2, Pj_pan, &
             Pj_acet, Pj_mglo, Pj_hno4_2, Pj_n2o, Pj_pooh, &
             Pj_mpan, Pj_mvk, Pj_etooh, Pj_prooh, Pj_onitr, &
             Pj_acetol, Pj_glyald, Pj_hyac, Pj_mek, Pj_open, &
             Pj_gly, Pj_acetp, Pj_xooh, Pj_isooh, Pj_alkooh, &
             Pj_mekooh, Pj_tolooh, Pj_terpooh, &
             C_M, FIX(indf_H2O), TEMP &
)
  CALL racm_esrlsorg_INTEGRATE(TIME_START, TIME_END, &
          FIX, VAR, RCONST, ATOL, RTOL, &
          ICNTRL_U=icntrl, RCNTRL_U=rcntrl )
        if(p_nu0.gt.1)then
            rxylho = RCONST(73)
            rtolho = RCONST(72)
            rcslho = RCONST(74)
            rcslno3 = RCONST(96)
            rhc8ho = RCONST(64)
            roliho = RCONST(67)
            rolino3 = RCONST(99)
            rolio3 = RCONST(107)
            roltho = RCONST(66)
            roltno3 = RCONST(98)
            rolto3 = RCONST(106)
            rapiho = RCONST(70)
            rapino3 = RCONST(102)
            rapio3 = RCONST(110)
            rlimho = RCONST(71)
            rlimno3 = RCONST(103)
            rlimo3 = RCONST(111)
            PRDROG(PXYL) = rxylho * var(ind_xyl)*var(ind_ho)
            PRDROG(PTOL) = rtolho * var(ind_tol)*var(ind_ho)
            PRDROG(PCSL1) = rcslho * var(ind_csl)*var(ind_ho)
            PRDROG(PCSL2) = 0.50_dp * rcslno3* var(ind_csl)*var(ind_no3)
            PRDROG(PHC8) = rhc8ho * var(ind_hc8)*var(ind_ho)
            PRDROG(POLI1) = roliho * var(ind_oli)*var(ind_ho)
            PRDROG(POLI2) = rolino3 * var(ind_oli)*var(ind_no3)
            PRDROG(POLI3) = rolio3 * var(ind_oli)*var(ind_o3)
            PRDROG(POLT1) = roltho * var(ind_olt)*var(ind_ho)
            PRDROG(POLT2) = roltno3 * var(ind_olt)*var(ind_no3)
            PRDROG(POLT3) = rolto3 * var(ind_olt)*var(ind_o3)
            PRDROG(PAPI1) = rapiho * var(ind_api)*var(ind_ho)
            PRDROG(PAPI2) = rapino3 * var(ind_api)*var(ind_no3)
            PRDROG(PAPI3) = rapio3 * var(ind_api)*var(ind_o3)
            PRDROG(PLIM1) = rlimho * var(ind_lim)*var(ind_ho)
            PRDROG(PLIM2) = rlimno3 * var(ind_lim)*var(ind_no3)
            PRDROG(PLIM3) = rlimo3 * var(ind_lim)*var(ind_o3)
            DO n = 1, LDROG
               VDROG3( i,k,j, n ) = oconv * PRDROG( n ) * DTSTEPC
               VDROG3( i,k,j,n ) = MAX( 0., VDROG3( i,k,j, n ) )
            ENDDO
        endif
    chem(i,k,j,P_o3) = MAX ( REAL (oconv * var(ind_O3), KIND=sp), 0.)
    chem(i,k,j,P_h2o2) = MAX ( REAL (oconv * var(ind_H2O2), KIND=sp), 0.)
    chem(i,k,j,P_no) = MAX ( REAL (oconv * var(ind_NO), KIND=sp), 0.)
    chem(i,k,j,P_no2) = MAX ( REAL (oconv * var(ind_NO2), KIND=sp), 0.)
    chem(i,k,j,P_no3) = MAX ( REAL (oconv * var(ind_NO3), KIND=sp), 0.)
    chem(i,k,j,P_n2o5) = MAX ( REAL (oconv * var(ind_N2O5), KIND=sp), 0.)
    chem(i,k,j,P_hono) = MAX ( REAL (oconv * var(ind_HONO), KIND=sp), 0.)
    chem(i,k,j,P_hno3) = MAX ( REAL (oconv * var(ind_HNO3), KIND=sp), 0.)
    chem(i,k,j,P_hno4) = MAX ( REAL (oconv * var(ind_HNO4), KIND=sp), 0.)
    chem(i,k,j,P_so2) = MAX ( REAL (oconv * var(ind_SO2), KIND=sp), 0.)
    chem(i,k,j,P_sulf) = MAX ( REAL (oconv * var(ind_SULF), KIND=sp), 0.)
    chem(i,k,j,P_co) = MAX ( REAL (oconv * var(ind_CO), KIND=sp), 0.)
    chem(i,k,j,P_co2) = MAX ( REAL (oconv * var(ind_CO2), KIND=sp), 0.)
    chem(i,k,j,P_ch4) = MAX ( REAL (oconv * var(ind_CH4), KIND=sp), 0.)
    chem(i,k,j,P_eth) = MAX ( REAL (oconv * var(ind_ETH), KIND=sp), 0.)
    chem(i,k,j,P_hc3) = MAX ( REAL (oconv * var(ind_HC3), KIND=sp), 0.)
    chem(i,k,j,P_hc5) = MAX ( REAL (oconv * var(ind_HC5), KIND=sp), 0.)
    chem(i,k,j,P_hc8) = MAX ( REAL (oconv * var(ind_HC8), KIND=sp), 0.)
    chem(i,k,j,P_ete) = MAX ( REAL (oconv * var(ind_ETE), KIND=sp), 0.)
    chem(i,k,j,P_olt) = MAX ( REAL (oconv * var(ind_OLT), KIND=sp), 0.)
    chem(i,k,j,P_oli) = MAX ( REAL (oconv * var(ind_OLI), KIND=sp), 0.)
    chem(i,k,j,P_dien) = MAX ( REAL (oconv * var(ind_DIEN), KIND=sp), 0.)
    chem(i,k,j,P_iso) = MAX ( REAL (oconv * var(ind_ISO), KIND=sp), 0.)
    chem(i,k,j,P_api) = MAX ( REAL (oconv * var(ind_API), KIND=sp), 0.)
    chem(i,k,j,P_lim) = MAX ( REAL (oconv * var(ind_LIM), KIND=sp), 0.)
    chem(i,k,j,P_tol) = MAX ( REAL (oconv * var(ind_TOL), KIND=sp), 0.)
    chem(i,k,j,P_xyl) = MAX ( REAL (oconv * var(ind_XYL), KIND=sp), 0.)
    chem(i,k,j,P_csl) = MAX ( REAL (oconv * var(ind_CSL), KIND=sp), 0.)
    chem(i,k,j,P_hcho) = MAX ( REAL (oconv * var(ind_HCHO), KIND=sp), 0.)
    chem(i,k,j,P_ald) = MAX ( REAL (oconv * var(ind_ALD), KIND=sp), 0.)
    chem(i,k,j,P_ket) = MAX ( REAL (oconv * var(ind_KET), KIND=sp), 0.)
    chem(i,k,j,P_gly) = MAX ( REAL (oconv * var(ind_GLY), KIND=sp), 0.)
    chem(i,k,j,P_mgly) = MAX ( REAL (oconv * var(ind_MGLY), KIND=sp), 0.)
    chem(i,k,j,P_dcb) = MAX ( REAL (oconv * var(ind_DCB), KIND=sp), 0.)
    chem(i,k,j,P_macr) = MAX ( REAL (oconv * var(ind_MACR), KIND=sp), 0.)
    chem(i,k,j,P_udd) = MAX ( REAL (oconv * var(ind_UDD), KIND=sp), 0.)
    chem(i,k,j,P_hket) = MAX ( REAL (oconv * var(ind_HKET), KIND=sp), 0.)
    chem(i,k,j,P_onit) = MAX ( REAL (oconv * var(ind_ONIT), KIND=sp), 0.)
    chem(i,k,j,P_pan) = MAX ( REAL (oconv * var(ind_PAN), KIND=sp), 0.)
    chem(i,k,j,P_tpan) = MAX ( REAL (oconv * var(ind_TPAN), KIND=sp), 0.)
    chem(i,k,j,P_op1) = MAX ( REAL (oconv * var(ind_OP1), KIND=sp), 0.)
    chem(i,k,j,P_op2) = MAX ( REAL (oconv * var(ind_OP2), KIND=sp), 0.)
    chem(i,k,j,P_paa) = MAX ( REAL (oconv * var(ind_PAA), KIND=sp), 0.)
    chem(i,k,j,P_ora1) = MAX ( REAL (oconv * var(ind_ORA1), KIND=sp), 0.)
    chem(i,k,j,P_ora2) = MAX ( REAL (oconv * var(ind_ORA2), KIND=sp), 0.)
    chem(i,k,j,P_ho) = MAX ( REAL (oconv * var(ind_HO), KIND=sp), 0.)
    chem(i,k,j,P_ho2) = MAX ( REAL (oconv * var(ind_HO2), KIND=sp), 0.)
   o3p(i,k,j) = MAX (REAL (oconv * var(ind_O3P) , KIND=sp),0.)
   o1d(i,k,j) = MAX (REAL (oconv * var(ind_O1D) , KIND=sp),0.)
   mo2(i,k,j) = MAX (REAL (oconv * var(ind_MO2) , KIND=sp),0.)
   ethp(i,k,j) = MAX (REAL (oconv * var(ind_ETHP) , KIND=sp),0.)
   hc3p(i,k,j) = MAX (REAL (oconv * var(ind_HC3P) , KIND=sp),0.)
   hc5p(i,k,j) = MAX (REAL (oconv * var(ind_HC5P) , KIND=sp),0.)
   hc8p(i,k,j) = MAX (REAL (oconv * var(ind_HC8P) , KIND=sp),0.)
   etep(i,k,j) = MAX (REAL (oconv * var(ind_ETEP) , KIND=sp),0.)
   oltp(i,k,j) = MAX (REAL (oconv * var(ind_OLTP) , KIND=sp),0.)
   olip(i,k,j) = MAX (REAL (oconv * var(ind_OLIP) , KIND=sp),0.)
   isop(i,k,j) = MAX (REAL (oconv * var(ind_ISOP) , KIND=sp),0.)
   apip(i,k,j) = MAX (REAL (oconv * var(ind_APIP) , KIND=sp),0.)
   limp(i,k,j) = MAX (REAL (oconv * var(ind_LIMP) , KIND=sp),0.)
   RPHO(i,k,j) = MAX (REAL (oconv * var(ind_PHO) , KIND=sp),0.)
   addt(i,k,j) = MAX (REAL (oconv * var(ind_ADDT) , KIND=sp),0.)
   addx(i,k,j) = MAX (REAL (oconv * var(ind_ADDX) , KIND=sp),0.)
   addc(i,k,j) = MAX (REAL (oconv * var(ind_ADDC) , KIND=sp),0.)
   tolp(i,k,j) = MAX (REAL (oconv * var(ind_TOLP) , KIND=sp),0.)
   xylp(i,k,j) = MAX (REAL (oconv * var(ind_XYLP) , KIND=sp),0.)
   cslp(i,k,j) = MAX (REAL (oconv * var(ind_CSLP) , KIND=sp),0.)
    chem(i,k,j,P_aco3) = MAX ( REAL (oconv * var(ind_ACO3), KIND=sp), 0.)
   tco3(i,k,j) = MAX (REAL (oconv * var(ind_TCO3) , KIND=sp),0.)
   ketp(i,k,j) = MAX (REAL (oconv * var(ind_KETP) , KIND=sp),0.)
   olnn(i,k,j) = MAX (REAL (oconv * var(ind_OLNN) , KIND=sp),0.)
   olnd(i,k,j) = MAX (REAL (oconv * var(ind_OLND) , KIND=sp),0.)
   xo2(i,k,j) = MAX (REAL (oconv * var(ind_XO2) , KIND=sp),0.)
    chem(i,k,j,P_hace) = MAX ( REAL (oconv * var(ind_HACE), KIND=sp), 0.)
    chem(i,k,j,P_ishp) = MAX ( REAL (oconv * var(ind_ISHP), KIND=sp), 0.)
    chem(i,k,j,P_ison) = MAX ( REAL (oconv * var(ind_ISON), KIND=sp), 0.)
   macp(i,k,j) = MAX (REAL (oconv * var(ind_MACP) , KIND=sp),0.)
    chem(i,k,j,P_mahp) = MAX ( REAL (oconv * var(ind_MAHP), KIND=sp), 0.)
    chem(i,k,j,P_mpan) = MAX ( REAL (oconv * var(ind_MPAN), KIND=sp), 0.)
    chem(i,k,j,P_nald) = MAX ( REAL (oconv * var(ind_NALD), KIND=sp), 0.)
    END DO
    END DO
    END DO
END SUBROUTINE racm_esrlsorg_interface
END MODULE module_kpp_racm_esrlsorg_interf


        subroutine ocean_test(x1,y1,io1,x2,y2,io2,z,itest)
ccc
ccc
ccc
ccc     DESCRIPTION :   Test whether two locations are connected by ocean
ccc
ccc     PRECISION :     Double
ccc
ccc     INPUT :         x1              longitude of first location
ccc                     y1              latitude of first location
ccc                     io1             ocean of first location
ccc                     x2              longitude of second location
ccc                     y2              latitude of second location
ccc                     io2             ocean of second location
ccc                     z               depth of connection
ccc
ccc     OUTPUT :        itest           success of connection
ccc
ccc
ccc     AUTHOR :        David Jackett
ccc
ccc     CREATED :       June 1994
ccc
ccc     REVISION :      1.1             7/7/94
ccc
ccc
ccc
        implicit double precision (a-h,o-z)

        integer*4 io1,io2

        dimension x_js(3),y_js(3)

        data x_js/129.87, 140.37, 142.83/
        data y_js/ 32.75,  37.38,  53.58/

        y = (y1+y2)/2

ccc
ccc             same ocean talks
ccc

        if(io1.eq.io2) then

          itest = 1
          return

        elseif(y.le.-20.) then

ccc
ccc             land of South America doesn't talk
ccc

          if(y.ge.-48..and.(io1*io2).eq.12) then
            itest = 0

ccc
ccc             everything else south of -20 talks
ccc

          else
            itest = 1
          end if

ccc
ccc             Pacific talks
ccc

        elseif((io1.eq.1.or.io1.eq.2).and.
     &                    (io2.eq.1.or.io2.eq.2)) then
          itest = 1

ccc
ccc             Indian talks
ccc

        elseif((io1.eq.3.or.io1.eq.4).and.
     &                    (io2.eq.3.or.io2.eq.4)) then
          itest = 1

ccc
ccc             Atlantic talks
ccc

        elseif((io1.eq.5.or.io1.eq.6).and.
     &                    (io2.eq.5.or.io2.eq.6)) then
          itest = 1

ccc
ccc             Indonesian throughflow
ccc

        elseif(io1*io2.eq.8.and.z.le.1200..and.
     &                  x1.ge.124..and.x1.le.132..and.
     &                          x2.ge.124..and.x2.le.132.) then
          itest = 1

ccc
ccc             anything else doesn't
ccc
        else
          itest = 0
        end if

ccc
ccc             exclude Japan Sea from talking
ccc

        if( (x_js(1).le.x1.and.x1.le.x_js(3).and.
     &                  y_js(1).le.y1.and.y1.le.y_js(3)) .or.

     &      (x_js(1).le.x2.and.x2.le.x_js(3).and.
     &                  y_js(1).le.y2.and.y2.le.y_js(3)) ) then

          em1 = (y_js(2)-y_js(1))/(x_js(2)-x_js(1))
          c1 = y_js(1)-em1*x_js(1)

          em2 = (y_js(3)-y_js(2))/(x_js(3)-x_js(2))
          c2 = y_js(2)-em2*x_js(2)

          if((y1-em1*x1-c1).ge.0.0.and.(y1-em2*x1-c2).ge.0.0) then
            isj1 = 1
          else
            isj1 = 0
          end if

          if((y2-em1*x2-c1).ge.0.0.and.(y2-em2*x2-c2).ge.0.0) then
            isj2 = 1
          else
            isj2 = 0
          end if

          if(isj1.eq.isj2) then
            itest = 1
          else
            itest = 0
          end if

        end if

ccc
ccc             exclude Antarctic tip
ccc

        if(io1*io2.eq.12.and.y.lt.-60.) itest = 0

        return
        end