subroutine read_f

!Loading f in memory
!Checks multiple synth modules for consistency and
!keeps track of the location of each module's fluxes,
!their resolution, type of wavelength scale (linear/log10),
!and which pixels contain photometry

!this routine is to be run serial -- no openmp critical protection provided

use share, only: dp,maxndim,maxsynth,flen,    &
		 siobuffer,liobuffer,xliobuffer,    &
		 rango, minusculo,                  &
		 constant,pcaproject,pcachi,        &
		 npca,meanspca,vpca,wpca,ff,        &
		 nelnpca,totalnpca,nvar,            &
		 n_p,ntot,ntimes,                   &
		 npix,llimits,steps, 	            &
		 nphotpix,photpixels,		    &
		 nsynth,hs,			    &
		 ndim,nov,synthfile,fixfile,        &
		 filterfile,                        &
		 f_format,f_access,nov,cont,        &
		 f,scalef,scaled,badflux,fmtformat, &
		 winter,nfilter,lsf,npca,pcaproject,&
		 transposed,file_data19,file_data20

implicit none

!locals
real(dp), allocatable	:: 	f2(:,:)		!temporary storage for synth grid
real(dp), allocatable   ::  fixratio(:) !flux ratio correction
real(dp),allocatable    ::  record(:)	!dummy array for inquire about the record size
integer 		::  j,i,k,n_of_dim,n_p1(maxndim),npix1,npix2,status
integer			::  ii,jj,offset
integer			::  istat ! allocate status var
integer			::  recordlength ! for unformatted synth files
integer			::  logw=0	!wavelength scale equidistant in log10?
integer			::  vacuum=0 ! wavelength scale in vacuum or std. air
integer			::  modo=-1000 ! synspec imode used
integer, allocatable	::  photpixels2(:)	!temp list of pixels with photometry
integer				::  multi = 0
integer				::  npcasynth = 0 !tracks the number of npca synth modules
character(len=flen)     ::      synthfile_internal = 'Unknown'
character(len=flen)     ::      id = 'Unknown'
character(len=flen)     ::      date = 'Unknown'
character(len=flen)     ::      synthfile_binary
character(len=30)	::	synspec	! synspec version used
character(len=45)	::	label(maxndim),label1(maxndim)
real(dp)			:: 	llimits1(maxndim),steps1(maxndim) !phys. pars synth1
character(len=80)	::	comments1,comments2,comments3,comments4
character(len=80)	::	comments5,comments6,comments7,comments8,comments9,comments10
character(len=80)       ::      comments11,comments12,comments13,comments14
character(len=80)       ::      speclib_vers
real(dp)			:: 	wave(2)= (/0,0/)
real(dp)       	 	::  resolution,original_sampling,continuum(4),precontinuum(4)
real(dp)			:: 	invalid_code=0.0_dp ! signals invalid entries
real(dp)			::  constant_pca=0.0_dp !tracks the value of constant for npca grids
real(dp)			::	rangef		    !range of values in f
real(dp)			::	maximo		    !max value of f
real(dp)			::	minimo		    !min value of f

namelist / synth / multi,synthfile_internal,id,date,n_of_dim,npca,n_p,npix
namelist / synth / label,llimits,steps,wave,logw,vacuum,resolution,original_sampling
namelist / synth / synspec,modo,invalid_code,constant,continuum,precontinuum
namelist / synth / transposed,file_data19,file_data20
namelist / synth / comments1,comments2,comments3,comments4,comments5,comments6
namelist / synth / comments7,comments8,comments9,comments10
namelist / synth / comments11,comments12,comments13,comments14
namelist / synth / speclib_vers

!reading header
!use a small buffer size to read the header
open(1,file=synthfile(1),delim='apostrophe',recl=siobuffer)
read(1,nml=synth)
npix2=0
if (multi == 0 .or. npca(1) > 0) then
	npix2=npix
	write(*,*)'       '
	write(*,*)'read_f       -> date =',date
	write(*,*)'read_f       -> n_p  =',n_p(1:n_of_dim)
	write(*,*)'read_f       -> wave =',wave
	write(*,*)'read_f       -> id   =',id
	write(*,*)'read_f       -> label=',label(1:n_of_dim)
	write(*,*)'read_f       -> npix =',npix
	if (npca(1) > 0) then
		npcasynth=1
		constant_pca=constant
		write(*,'(a39,i1,1a)')'read_f       -> NPCA grid (pcaproject=',pcaproject,')'
		if (winter == 2 .and. pcaproject == 1) then
			write(*,*) 'read_f: ERROR'
			write(*,*) 'This is an NPCA grid, but WINTER=2 (interp. library)'
			write(*,*) 'so the observed spectra should be uncompressed     '
			write(*,*) 'and pcaproject set to 0!'
			stop
		endif
		if (winter == 2 .and. pcaproject == 0) then
			if (pcachi == 0) then
				write(*,*) 'read_f: WARNING'
				write(*,*) 'This is an NPCA grid with WINTER=2 (interp. library)'
				write(*,*) 'and pcaproject=0, so the chi**2 eval. will be done on'
				write(*,*) 'uncompressed spectra'
			else
				write(*,*) 'read_f: ERROR'
				write(*,*) 'pcachi /= 0'
				write(*,*) 'This is an NPCA grid with WINTER=2 (interp. library)'
				write(*,*) 'and pcaproject=0, so the chi**2 eval. should be done on'
				write(*,*) 'uncompressed spectra and pcachi must be 0'
			endif
		endif
		if (winter < 2 .and. nfilter > 1) then
			write(*,*) 'read_f: ERROR'
			write(*,*) 'cannot use nfilter > 1 on an npca grid'
			write(*,*) 'unless interpolating the library (winter=2)'
			stop
		endif
		if (lsf > 0 .and. pcachi == 1) then
			write(*,*) 'read_f: ERROR'
			write(*,*) 'pcachi = ',pcachi,' must be set to 0 when lsf > 0'
			stop
		endif
		if (filterfile .gt. ' ' .and. pcachi == 1) then
			write(*,*) 'read_f: WARNING'
			write(*,*) 'pcachi = ',pcachi,' must be set to 0 when the array'
			write(*,*) 'in filterfile is for fluxes and not PCA components'
		endif
		if(pcachi == 0. .and. pcaproject == 1) then
			write(*,*) 'read_f: ERROR'
			write(*,*) 'pcaproject = ',pcaproject,' must be set to 0 when pcachi = 0'
			stop
		endif
		if(winter == 2 .and. pcachi == 1) then
			write(*,*) 'read_f: ERROR'
			write(*,*) 'pcachi = ',pcachi,' must be set to 0 when winter = 2 with PCA grids'
			stop
		endif
	else
		if (pcachi == 1) then
			write(*,*) 'read_f: ERROR'
			write(*,*) 'pcachi = ',pcachi,' must be set to 0 for non PCA grids'
			stop
		endif
		if (pcaproject == 1) then
			write(*,*) 'read_f: ERROR'
			write(*,*) 'pcaproject = ',pcaproject,' must be set to 0 for non PCA grids'
			stop
		endif
	endif

	!keep to check with other synth modules
	n_p1=n_p
	npix1=npix
	llimits1=llimits
	steps1=steps
	label1=label

	if (npca(1) == 0) then
		!keep track
		nsynth=1
		hs(1)%res=resolution
		hs(1)%pixbegin=1
		hs(1)%pixend=npix
		hs(1)%lambda0=wave(1)
		hs(1)%lambda1=wave(2)
		hs(1)%lws=logw
		hs(1)%lambdamin=wave(1)
		hs(1)%lambdamax=wave(1)+npix*wave(2)
                write(*,*)'lambdamin=',wave(1)
                write(*,*)'npix=',npix
                write(*,*)'wave(2)=',wave(2)
		select case (logw)
			case (1)
				hs(1)%lambdamin=10._dp**hs(1)%lambdamin
				hs(1)%lambdamax=10._dp**hs(1)%lambdamax
			case (2)
				hs(1)%lambdamin=exp(hs(1)%lambdamin)
				hs(1)%lambdamax=exp(hs(1)%lambdamax)
		end select
	endif

endif
do ii=1,multi

	read(1,nml=synth)

	!check that a npca constant value is not overridden
	if (npca(1) > 0 .and. abs(constant-constant_pca) > 1.e3*minusculo) then
			write(*,*) 'read_f: ERROR'
			write(*,*) 'the value of the CONSTANT keyword for an npca grid'
			write(*,*) 'has been modified'
			stop 1
	endif

	if (ii == 1) then

		if (npca(1) == 0) then
			write(*,*)'       '
			write(*,*)'read_f       -> date =',date
			write(*,*)'read_f       -> n_p  =',n_p(1:n_of_dim)
			write(*,*)'read_f       -> wave =',wave
			write(*,*)'read_f       -> id   =',id
			write(*,*)'read_f       -> label=',label(1:n_of_dim)

			!keep to check with other synth modules
			n_p1=n_p
			llimits1=llimits
			steps1=steps
			label1=label

			if (pcachi == 1) then
				write(*,*) 'read_f: ERROR'
				write(*,*) 'pcachi = ',pcachi,' must be set to 0 for non PCA grids'
				stop
			endif

		endif

		!keep track
		nsynth=1
		hs(1)%res=resolution
		hs(1)%pixbegin=1
		hs(1)%pixend=npix
		hs(1)%lambda0=wave(1)
		hs(1)%lambda1=wave(2)
		hs(1)%lws=logw
		hs(1)%lambdamin=wave(1)
		hs(1)%lambdamax=wave(1)+npix*wave(2)
                write(*,*)'lambdamin=',wave(1)
                write(*,*)'npix=',npix
                write(*,*)'wave(2)=',wave(2)
		select case (logw)
			case (1)
				hs(1)%lambdamin=10._dp**hs(1)%lambdamin
				hs(1)%lambdamax=10._dp**hs(1)%lambdamax
			case (2)
				hs(1)%lambdamin=exp(hs(1)%lambdamin)
				hs(1)%lambdamax=exp(hs(1)%lambdamax)
		end select

	else

		!keep track
		nsynth=nsynth+1
		hs(nsynth)%res=resolution
		hs(nsynth)%pixbegin=hs(nsynth-1)%pixend+1
		hs(nsynth)%pixend=hs(nsynth-1)%pixend+npix
		hs(nsynth)%lambda0=wave(1)
		hs(nsynth)%lambda1=wave(2)
		hs(nsynth)%lws=logw
		hs(nsynth)%lambdamin=wave(1)
		hs(nsynth)%lambdamax=wave(1)+npix*wave(2)
		select case (logw)
			case (1)
				hs(nsynth)%lambdamin=10._dp**hs(nsynth)%lambdamin
				hs(nsynth)%lambdamax=10._dp**hs(nsynth)%lambdamax
			case (2)
				hs(nsynth)%lambdamin=exp(hs(nsynth)%lambdamin)
				hs(nsynth)%lambdamax=exp(hs(nsynth)%lambdamax)
		end select

		!consistency checks for dimensions in this and previous synth modules
		do i=1,maxndim
			if (n_p(i).ne.n_p1(i)) then
				write(*,*) 'ERROR in read_f'
				write(*,*)'Inconsistency between the sizes (N_P) of '
				write(*,*)'different synthfiles found when reading ',synthfile(j)
				stop
			endif
			if (abs(llimits(i)-llimits1(i)) > 1e-5) then
				write(*,*) 'ERROR in read_f'
				write(*,*)'Inconsistency between the contents (LLIMITS) of'
				write(*,*)'different synthfiles found when reading ',synthfile(j)
				stop
			endif
			if (abs(steps(i)-steps1(i)) > 1e-5) then
				write(*,*) 'ERROR in read_f'
				write(*,*)'Inconsistency between the contents (STEPS) of'
				write(*,*)'different synthfiles found when reading ',synthfile(j)
				stop
			endif
			if (label(i).ne.label1(i)) then
				write(*,*) 'ERROR in read_f'
				write(*,*)'Inconsistency between the labels (LABEL) of'
				write(*,*)'different synthfiles found when reading ',synthfile(j)
				stop
			endif
		enddo

	endif

	if (npca(1) == 0) then
		npix2=npix2+npix
		write(*,*)'read_f       -> npix =',npix2,'(',ii,')'
	endif

enddo
close(1)

!reset to a custom buffer size to read the data
liobuffer=25*npix2 !npix data x 25 characters/datum
xliobuffer=liobuffer
if (npca(1) > 0) then !npca files contain means, v and w
	nelnpca=count(npca > 0)
	totalnpca=sum(npca(1:nelnpca))
	xliobuffer=25*totalnpca  !meanspca,vpca and wpca require longer rows
endif
open(1,file=synthfile(1),delim='apostrophe',recl=xliobuffer,action='read')
do ii=0,multi
	read(1,nml=synth)
enddo
npix=npix2
npix1=npix2

if (n_of_dim.ne.ndim) then
	write(*,*) 'ERROR in read_f'
	write(*,*) 'Inconsistency between the expected dimension of ',synthfile
	write(*,*) 'and the declared size ndim=',ndim
	stop
endif
if (n_of_dim.lt.nov) then
	write(*,*) 'ERROR in read_f'
	write(*,*) 'Inconsistency between the expected dimension of ',synthfile
	write(*,*) 'and number of free parameters nov=',nov
	stop
endif

allocate(ntimes(ndim),stat=istat)
call checkstat(istat,'ntimes')
ntot=n_p(ndim)
ntimes(ndim)=1
do j=2,ndim
        ntimes(ndim-j+1)=ntot
        ntot=ntot*n_p(ndim-j+1)
enddo

if (npca(1) > 0) then !npca files contain means, v and w

	nvar=npix/nelnpca
	allocate(meanspca(totalnpca),stat=istat)
        call checkstat(istat,'meanspca')
	allocate(vpca(totalnpca),stat=istat)
        call checkstat(istat,'vpca')
	allocate(wpca(totalnpca,nvar),stat=istat)
        call checkstat(istat,'wpca')

	!read
	read(1,*)meanspca
	read(1,*)vpca
	do i=1,nvar
		read(1,*)wpca(:,i)
	enddo

	write(*,'(1x,a45,4(1x,i5))')'read_f       -> totalnpca,npix,nelnpca,nvar =', &
			totalnpca,npix,nelnpca,nvar

	if (pcaproject == 1) then

		!prepare auxiliary array ff
		allocate(ff(nvar,totalnpca),stat=istat)
                call checkstat(istat,'ff')

		k=1
		do ii=1,nelnpca
			offset=0
			if (ii > 1) offset=sum(npca(1:ii-1))
			write(*,*)'ii, offset=',ii,offset
			do i=1,npca(ii)
				do jj=1,nvar
					ff(jj,k)=wpca(k,jj)*vpca(jj+offset)
				enddo
				k=k+1
			enddo
		enddo
	endif

endif

!if synthfile access is through a file, we don't load it in memory
!but open the file for direct access and leave it open
!for the interpolation routines
if (f_access == 1) then

	!check that no more than one synthfile is used
	do j=2,maxsynth
		if (synthfile(j).gt.' ') &
			write(*,*)'read_f       -> WARNING: access-mode is direct, only 1 synthfile is used'
	enddo

	!no fscale or fixratio can be applied in direct-access mode
	write(*,*)'read_f       -> WARNING: access-mode is direct, scalef is not applied'
	if (fixfile(1).gt.' ') &
			write(*,*)'read_f       -> WARNING: access-mode is direct, fixfile will be ignored'

	!close the ascii file
	close(1)

	!open direct-access synth file
	if (f_format == 1) then

		!allocate record and calculate recordlength
		allocate (record(npix),stat=istat)
                call checkstat(istat,'record')
		inquire (iolength=recordlength) record
    	        deallocate(record)

		!compose name for binary synth file
		ii=len_trim(synthfile(1))
		synthfile_binary=synthfile(1)
		synthfile_binary=synthfile_binary(1:ii-3)
		synthfile_binary(ii-2:ii)='unf'

		open(10,file=synthfile_binary,access='direct',action='read', &
           form='unformatted',status='old',recl=recordlength)

    else

		!set recordlength and format for reading the formatted direct-access file
		recordlength=npix*12
		write(fmtformat,*) npix
		fmtformat = '(' // fmtformat(2:23) // 'ES12.5' // ')'

		!compose name for ascii synth file
		ii=len_trim(synthfile(1))
		synthfile_binary=synthfile(1)
		synthfile_binary=synthfile_binary(1:ii-3)
		synthfile_binary(ii-2:ii)='fmt'

		open(10,file=synthfile_binary,access='direct',action='read', &
           form='formatted',status='old',recl=recordlength)

    endif

    !return control to main
    return

endif

allocate (f(npix,ntot),stat=istat)	!allocate f
call checkstat(istat,'f')

!if the synth file is binary we close the ascii version
!and open the binary one, then read
!otherwise, we just read the open ascii version
if (f_format == 1) then

	close(1)

	!calculate recordlength
	if (transposed == 0) then
		inquire (iolength=recordlength) f(:,1)
    else
    	inquire (iolength=recordlength) f(1,:)
    endif

    !compose name for binary synth file
	ii=len_trim(synthfile(1))
	synthfile_binary=synthfile(1)
	synthfile_binary=synthfile_binary(1:ii-3)
	synthfile_binary(ii-2:ii)='unf'

	open(1,file=synthfile_binary,access='direct', &
           form='unformatted',status='old',recl=recordlength)

	if (transposed == 0) then
		do ii=1,ntot
			read(1,rec=ii) f(:,ii)
		enddo
	else
		do ii=1,npix
			read(1,rec=ii) f(ii,:)
		enddo
	endif

else

	if (transposed == 0) then
		do ii=1,ntot
			!i=(ii-1)/n_p(4)/n_p(3)/n_p(2)+1
			!j=(ii-(i-1)*n_p(4)*n_p(3)*n_p(2)-1)/n_p(4)/n_p(3)+1
			!k=(ii-(i-1)*n_p(4)*n_p(3)*n_p(2)-(j-1)*n_p(4)*n_p(3)-1)/n_p(4)+1
			!l=ii-(i-1)*n_p(4)*n_p(3)*n_p(2)-(j-1)*n_p(4)*n_p(3)-(k-1)*n_p(4)
			!write(*,*)i,j,k,l
			read(1,*) f(:,ii)
		enddo
	else
		do ii=1,npix
			!i=(ii-1)/n_p(4)/n_p(3)/n_p(2)+1
			!j=(ii-(i-1)*n_p(4)*n_p(3)*n_p(2)-1)/n_p(4)/n_p(3)+1
			!k=(ii-(i-1)*n_p(4)*n_p(3)*n_p(2)-(j-1)*n_p(4)*n_p(3)-1)/n_p(4)+1
			!l=ii-(i-1)*n_p(4)*n_p(3)*n_p(2)-(j-1)*n_p(4)*n_p(3)-(k-1)*n_p(4)
			!write(*,*)i,j,k,l
			read(1,*) f(ii,:)
		enddo
	endif

endif

close(1)

!check if there is a fix file ratio array to be multiplied by the synth grid
if (fixfile(1).gt.' ') then

	!fixfile cannot be used when npca>0
	if (npca(1) > 0) then
		write(*,*) 'ERROR in read_f'
		write(*,*) 'fixfile cannot be used with PCA grids (filterfile can)'
		stop
	else
		allocate(fixratio(npix),stat=istat)
                call checkstat(istat,'fixratio')
		open(1,file=fixfile(1),delim='apostrophe',recl=liobuffer)
		read(1,*) fixratio
		close(1)
		do ii=1,ntot
			f(:,ii)=f(:,ii)*fixratio
		enddo
		deallocate(fixratio)
	endif
endif

if (abs(resolution-0._dp) < 1e-6_dp) then 	!we deal with photometry
	allocate (photpixels(npix1),stat=istat)
	call checkstat(istat,'photpixels')
	do j=1,npix1
		photpixels(j)=j
	enddo
	nphotpix=npix1
endif

do j=2,maxsynth

	if(synthfile(j).gt.' ') then

		write(*,*)synthfile(j)

		!reading header
		!use a small buffer size to read the header
		open(1,file=synthfile(j),delim='apostrophe',recl=siobuffer)
		read(1,nml=synth)
		npix2=0
		if (multi == 0 .or. npca(1) > 0) then
			npix2=npix
			write(*,*)'       '
			write(*,*)'read_f       -> date =',date
			write(*,*)'read_f       -> n_p  =',n_p(1:n_of_dim)
			write(*,*)'read_f       -> wave =',wave
			write(*,*)'read_f       -> id   =',id
			write(*,*)'read_f       -> label=',label(1:n_of_dim)
			write(*,*)'read_f       -> npix =',npix
			if (npca(1) > 0) then
				npcasynth=npcasynth+1
				write(*,*)'read_f       -> NPCA grid (pcaproject=',pcaproject,')'
				if (winter == 2 .and. pcaproject == 1) then
					write(*,*) 'read_f: ERROR'
					write(*,*) 'This is an NPCA grid, but WINTER=2 (interp. library)'
					write(*,*) 'so the observed spectra should be uncompressed     '
					write(*,*) 'and pcaproject set to 0!'
					stop
				endif
				if (winter == 2 .and. pcaproject == 0) then
					if (pcachi == 0) then
						write(*,*) 'read_f: WARNING'
						write(*,*) 'This is an NPCA grid with WINTER=2 (interp. library)'
						write(*,*) 'and pcaproject=0, so the chi**2 eval. will be done on'
						write(*,*) 'uncompressed spectra'
					else
						write(*,*) 'read_f: ERROR'
						write(*,*) 'pcachi /= 0'
						write(*,*) 'This is an NPCA grid with WINTER=2 (interp. library)'
						write(*,*) 'and pcaproject=0, so the chi**2 eval. should be done on'
						write(*,*) 'uncompressed spectra and pcachi must be 0'
					endif
				endif
				if (winter < 2 .and. nfilter > 1) then
					write(*,*) 'read_f: ERROR'
					write(*,*) 'cannot use nfilter > 1 on an npca grid'
					write(*,*) 'unless interpolating the library (winter=2)'
					stop
				endif
 	   			if (lsf > 0 .and. pcachi == 1) then
					write(*,*) 'read_f: ERROR'
					write(*,*) 'pcachi = ',pcachi,' must be set to 0 when lsf > 0'
					stop
				endif
				if (filterfile .gt. ' ' .and. pcachi == 1) then
					write(*,*) 'read_f: WARNING'
					write(*,*) 'pcachi = ',pcachi,' must be set to 0 when the array'
					write(*,*) 'in filterfile is for fluxes and not PCA components'
				endif
				if(pcachi == 0. .and. pcaproject == 1) then
					write(*,*) 'read_f: ERROR'
					write(*,*) 'pcaproject = ',pcaproject,' must be set to 0 when pcachi = 0'
					stop
				endif
				if(winter == 2 .and. pcachi == 1) then
					write(*,*) 'read_f: ERROR'
					write(*,*) 'pcachi = ',pcachi,' must be set to 0 when winter = 2 with PCA grids'
					stop
				endif
			else
				if (pcachi == 1) then
					write(*,*) 'read_f: ERROR'
					write(*,*) 'pcachi = ',pcachi,' must be set to 0 for non PCA grids'
					stop
				endif
				if (pcaproject == 1) then
					write(*,*) 'read_f: ERROR'
					write(*,*) 'pcaproject = ',pcaproject,' must be set to 0 for non PCA grids'
					stop
				endif
			endif

			!consistency checks for dimensions in this and previous synth modules
			do ii=1,maxndim
				if (n_p(ii).ne.n_p1(ii)) then
					write(*,*) 'ERROR in read_f'
					write(*,*)'Inconsistency between the sizes (N_P) of '
					write(*,*)'different synthfiles found when reading ',synthfile(j)
					stop
				endif
				if (abs(llimits(ii)-llimits1(ii)) > 1e-5) then
					write(*,*) 'ERROR in read_f'
					write(*,*)'Inconsistency between the contents (LLIMITS) of'
					write(*,*)'different synthfiles found when reading ',synthfile(j)
					stop
				endif
				if (abs(steps(ii)-steps1(ii)) > 1e-5) then
					write(*,*) 'ERROR in read_f'
					write(*,*)'Inconsistency between the contents (STEPS) of'
					write(*,*)'different synthfiles found when reading ',synthfile(j)
					stop
				endif
				if (label(ii).ne.label1(ii)) then
					write(*,*) 'ERROR in read_f'
					write(*,*)'Inconsistency between the labels (LABEL) of'
					write(*,*)'different synthfiles found when reading ',synthfile(j)
					stop
				endif
			enddo

			if (multi == 0 .and. npca(1) == 0) then
				!keep track
				nsynth=nsynth+1
				hs(nsynth)%res=resolution
				hs(nsynth)%pixbegin=hs(nsynth-1)%pixend+1
				hs(nsynth)%pixend=hs(nsynth-1)%pixend+npix
				hs(nsynth)%lambda0=wave(1)
				hs(nsynth)%lambda1=wave(2)
				hs(nsynth)%lws=logw
				hs(nsynth)%lambdamin=wave(1)
				hs(nsynth)%lambdamax=wave(1)+npix*wave(2)
				select case (logw)
					case (1)
						hs(nsynth)%lambdamin=10._dp**hs(nsynth)%lambdamin
						hs(nsynth)%lambdamax=10._dp**hs(nsynth)%lambdamax
					case (2)
						hs(nsynth)%lambdamin=exp(hs(nsynth)%lambdamin)
						hs(nsynth)%lambdamax=exp(hs(nsynth)%lambdamax)
				end select

			endif

		endif

		do ii=1,multi

			read(1,nml=synth)

			!consistency checks for dimensions in this and previous synth modules
			do i=1,maxndim
				if (n_p(i).ne.n_p1(i)) then
					write(*,*) 'ERROR in read_f'
					write(*,*)'Inconsistency between the sizes (N_P) of '
					write(*,*)'different synthfiles found when reading ',synthfile(j)
					stop
				endif
				if (abs(llimits(i)-llimits1(i)) > 1e-5) then
					write(*,*) 'ERROR in read_f'
					write(*,*)'Inconsistency between the contents (LLIMITS) of'
					write(*,*)'different synthfiles found when reading ',synthfile(j)
					stop
				endif
				if (abs(steps(i)-steps1(i)) > 1e-5) then
					write(*,*) 'ERROR in read_f'
					write(*,*)'Inconsistency between the contents (STEPS) of'
					write(*,*)'different synthfiles found when reading ',synthfile(j)
					stop
				endif
				if (label(i).ne.label1(i)) then
					write(*,*) 'ERROR in read_f'
					write(*,*)'Inconsistency between the labels (LABEL) of'
					write(*,*)'different synthfiles found when reading ',synthfile(j)
					stop
				endif
			enddo

			!keep track
			nsynth=nsynth+1
			hs(nsynth)%res=resolution
			hs(nsynth)%pixbegin=hs(nsynth-1)%pixend+1
			hs(nsynth)%pixend=hs(nsynth-1)%pixend+npix
			hs(nsynth)%lambda0=wave(1)
			hs(nsynth)%lambda1=wave(2)
			hs(nsynth)%lws=logw
			hs(nsynth)%lambdamin=wave(1)
			hs(nsynth)%lambdamax=wave(1)+npix*wave(2)
			select case (logw)
				case (1)
					hs(nsynth)%lambdamin=10._dp**hs(nsynth)%lambdamin
					hs(nsynth)%lambdamax=10._dp**hs(nsynth)%lambdamax
				case (2)
					hs(nsynth)%lambdamin=exp(hs(nsynth)%lambdamin)
					hs(nsynth)%lambdamax=exp(hs(nsynth)%lambdamax)
			end select

			if (npca(1) == 0) then
				npix2=npix2+npix
				write(*,*)'read_f       -> npix =',npix2,'(',ii,')'
			endif

		enddo
		close(1)

		!reset to a custom buffer size to read the data
		liobuffer=25*npix2 !npix data x 25 characters/datum
		if (npca(1) > 0) then !npca files contain means, v and w
			nelnpca=count(npca > 0)
			totalnpca=sum(npca(1:nelnpca))
			xliobuffer=25*totalnpca  !meanspca,vpca and wpca require longer rows
			open(1,file=synthfile(1),delim='apostrophe',recl=xliobuffer,action='read')
		else
			open(1,file=synthfile(1),delim='apostrophe',recl=liobuffer,action='read')
		endif
		do ii=0,multi
			read(1,nml=synth)
		enddo
		npix=npix2

		!write(*,*)'at this point, npix1,npix=',npix1,npix
		!write(*,*)'nsynth=',nsynth

		if (n_of_dim.ne.ndim) then
			write(*,*) 'ERROR in read_f'
			write(*,*) 'Inconsistency between the expected dimension of ',synthfile
			write(*,*) 'and the declared size ndim=',ndim
			stop
		endif
		if (n_of_dim.lt.nov) then
			write(*,*) 'ERROR in read_f'
			write(*,*) 'Inconsistency between the expected dimension of ',synthfile
			write(*,*) 'and number of free parameters nov=',nov
			stop
		endif

		if (npca(1) > 0) then !npca files contain means, v and w

			if (npcasynth > 1) then
				write(*,*) 'ERROR in read_f'
				write(*,*) 'We are not ready yet for mixing more than one npca file!!'
				stop
			endif

			nvar=npix/nelnpca
			allocate(meanspca(totalnpca),stat=istat)
                        call checkstat(istat,'meanspca')
			allocate(vpca(totalnpca),stat=istat)
                        call checkstat(istat,'vpca')
			allocate(wpca(totalnpca,nvar),stat=istat)
       			call checkstat(istat,'wpca')

			!read
			read(1,*)meanspca
			read(1,*)vpca
			do i=1,nvar
				read(1,*)wpca(:,i)
			enddo

	   write(*,'(1x,a45,4(1x,i5))')'read_f       -> totalnpca,npix,nelnpca,nvar =', &
		totalnpca,npix,nelnpca,nvar

			if (pcaproject == 1) then

				!build auxiliary array ff
				allocate(ff(nvar,totalnpca),stat=istat)
 				call checkstat(istat,'ff')

				k=1
				do ii=1,totalnpca
					offset=0
					if (ii > 0) offset=sum(npca(1:ii))
					do i=1,npca(ii)
						do jj=1,nvar
							ff(jj,k)=wpca(k,jj)*vpca(jj+offset)
						enddo
						k=k+1
					enddo
				enddo

			endif

		endif

		allocate(f2(npix1,ntot),stat=istat)!allocate f2
                call checkstat(istat,'f2')
		f2=f

		if (abs(resolution-0._dp) < 1e-6_dp) then  	!we deal with photometry
			if (nphotpix.gt.0) then
				allocate (photpixels2(nphotpix),stat=istat)
                                call checkstat(istat,'photpixels2')
				photpixels2=photpixels
				deallocate(photpixels)
				allocate (photpixels(npix+nphotpix),stat=istat)
                         	call checkstat(istat,'photpixels')
				photpixels(1:nphotpix)=photpixels2
				deallocate (photpixels2,stat=status)
				do ii=1,npix
					photpixels(nphotpix+ii)=npix1+ii
				enddo
			else
				allocate (photpixels(npix),stat=istat)
  				call checkstat(istat,'photpixels')
				do ii=1,npix
					photpixels(ii)=npix1+ii
				enddo
			endif
			nphotpix=nphotpix+npix
		endif

		npix=npix1+npix

		deallocate(f)
		allocate(f(npix,ntot),stat=istat)!allocate newf
 		call checkstat(istat,'f')

		!if the synth file is binary we close the ascii version
		!and open the binary one, then read
		!otherwise, we just read the open ascii version
		if (f_format == 1) then

			close(1)

	    	        !calculate recordlength
	    	        if (transposed == 0) then
				inquire (iolength=recordlength) f(npix1+1:npix,1)
			else
				inquire (iolength=recordlength) f(1,:)
			endif

		        !compose name for binary synth file
			ii=len_trim(synthfile(j))
			synthfile_binary=synthfile(j)
			synthfile_binary=synthfile_binary(1:ii-3)
			synthfile_binary(ii-2:ii)='unf'

			open(1,file=synthfile_binary,access='direct', &
           	   form='unformatted',status='old',recl=recordlength)

			if (transposed == 0) then
				do ii=1,ntot
					f(1:npix1,ii)=f2(:,ii)
					read(1,rec=ii) f(npix1+1:npix,ii)
				enddo
			else
				do ii=1,npix1
					f(ii,1:ntot)=f2(ii,1:ntot)
				enddo
				do ii=npix+1,npix
					read(1,rec=ii) f(ii,1:ntot)
				enddo
			endif

		else

			close(1)

			open(1,file=synthfile(j),delim='apostrophe',recl=xliobuffer,action='read')
			npix2=npix
			do ii=0,multi
				read(1,nml=synth)
			enddo
			npix=npix2

			if (transposed == 0) then
				do ii=1,ntot
					f(1:npix1,ii)=f2(:,ii)
					read(1,*) f(npix1+1:npix,ii)
				enddo
			else
				do ii=1,npix1
					f(ii,1:ntot)=f2(ii,1:ntot)
				enddo
				do ii=npix+1,npix
					read(1,*) f(ii,1:ntot)
				enddo
			endif

		endif

		close(1)
		deallocate(f2,stat=status)

		!check if there is a fix file ratio array to be multiplied by the synth grid
		if (fixfile(j).gt.' ') then

			!fixfile cannot be used when npca>0
			if (npca(1) > 0) then
				write(*,*) 'ERROR in read_f'
				write(*,*) 'fixfile cannot be used with PCA grids (filterfile can)'
				stop
			else

				allocate(fixratio(npix-npix1),stat=istat)
 				call checkstat(istat,'fixratio')
				open(1,file=fixfile(j),delim='apostrophe',recl=liobuffer)
				read(1,*)fixratio
				close(1)
				do ii=1,ntot
					f(npix1+1:npix,ii)=f(npix1+1,ii)*fixratio
				enddo
				deallocate(fixratio)

			endif

		endif

		npix1=npix

	endif
enddo

!write(*,*)'nsynth=',nsynth
write(*,*)''
write(*,*)'final value: npix=',npix
write(*,*)''
write(*,*)'synthfile summary'
write(*,*)'*******************************************************************'
write(*,*)'   #      R     start-pix  end-pix    start-lambda      end-lambda'
do i=1,nsynth
	write(*,'(i5,x,f9.1,i8,x,i8,x,f16.3,x,f16.3)')i,hs(i)%res, &
          hs(i)%pixbegin,hs(i)%pixend, &
	  !hs(i)%lambda0,hs(i)%lambda1,hs(i)%lws,  &
	  hs(i)%lambdamin,hs(i)%lambdamax
enddo
write(*,*)'*******************************************************************'

!reset xliobuffer for ffile/sffile
xliobuffer=25*npix !npix data x 25 characters/datum
if (npca(1) > 0) then !npca files contain means, v and w
	nelnpca=count(npca > 0)
	totalnpca=sum(npca(1:nelnpca))
	xliobuffer=25*totalnpca  !meanspca,vpca and wpca require longer rows
endif

!scaling to avoid extreme numbers
scaled=1
if (f_access == 1 .or. npca(1) > 0 .or. nov == 0 .or. cont > 0) scaled=0
if (scaled == 1) then
	scalef=sum(f)/real(ntot)/real(npix)
	write(*,*)'scaling ...'
	f=f/scalef
else
	scalef=1.0_dp
endif

!define badflux value
maximo=maxval(f)
minimo=minval(f)
rangef=maximo-minimo

!basic checks for over/underflow
rango=range(f)
minusculo=tiny(f)
if (maximo > 10._dp**rango) then
	write(*,*) 'ERROR in read_f'
	write(*,*) 'over-flow: f exceeds its allowed range'
	stop
endif
if (abs(minimo) < minusculo) then
        write(*,*) 'WARNING in read_f'
        write(*,*) 'under-flow risk: f contains values < tiny'
endif

badflux=minimo-2._dp*rangef
if (badflux > -1000._dp) badflux=-1000._dp
write(*,*)'read_f       -> scalef  =',scalef
write(*,*)'read_f       -> rangef  =',rangef
write(*,*)'read_f       -> badflux =',badflux

end subroutine read_f


! SPDX-Identifier: MIT
!
! Copyright 1999 J.C. Matthewman, P.J. Brown
! With contributions from W.I.F. David, J.B. Forsyth and J.H. Matthewman.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
!*****************************************************************************
!
      SUBROUTINE GENMAG(H,NOMORE,MUL,SMAX,NFLAG)
!
! *** GENMAG updated by JCM 6 May 92 ***
!
!X
!C 17C
!H Generates the next set of magnetic h,k,l, scanning the asymmetric unit.
!A On entry NFLAG=-9999 if this is the very first entry
!A    if IPROP is non-zero this entry makes a magnetic asymmetric unit
!A    and sets things up for subsequent calls.
!A    otherwise NFLAG is left severely alone and just presented again
!A    on each subsequent entry.
!A On exit H is a real 1x3 array holding the next h,k,l (unless none)
!A         NOMORE is a LOGICAL saying whether or not no more generated
!A         MUL is the multiplicity of H
!P PROPER must have been called to fill in /SATELL/
!
      LOGICAL NOMORE
      DIMENSION H(3), HT(3)
      COMMON /SATELL/ PROP(3), KPROP(3), KSTAB(24), NKSTAR, IPROP,      &
     &                FKSTAR, NKC, KCENT, INCOM, KOM21
      LOGICAL INCOM
      COMMON /TEMGEN/ HF(3)

      INTEGER         IBMBER
      COMMON /CCSLER/ IBMBER

      IF (NFLAG.EQ.-9999) THEN
! INITIAL ENTRY:
        IF (NKSTAR.GT.1) THEN
          CALL SUBSYM(KSTAB)
          CALL SYMUNI
          IF (IBMBER .NE. 0) RETURN
        ENDIF
!  INCREASE SINTHETA LIMIT TO ALLOW FOR PROPAGATION VECTOR
        SDIF = VCTMOD(0.5,PROP,2)
        SLIM = SMAX + SDIF
        CALL SETGEN(SLIM)
! FIRST PRESENT 0,0,0 AS FUNDAMENTAL:
        CALL GMZER(HF,1,3)
        NOMORE = .FALSE.
! ENTRIES OTHER THAN INITIAL - EXPECT NFLAG SET:
      ELSEIF (NFLAG.EQ.0) THEN
        CALL GETGEN(HF,NOMORE)
        IF (NOMORE) RETURN
      ELSE
        CALL GMSUB(HF,PROP,H,3,1)
        NFLAG = 0
        GOTO 3
      ENDIF
!  ADD STAR VECTOR TO FUNDAMENTAL
      CALL GMADD(HF,PROP,H,3,1)
!  TAKE CARE OF SPECIAL CASES WHEN PROP IS HALF A RLV
      IF (IABS(IPROP).EQ.2) THEN
        CALL GMADD(H,PROP,HT,3,1)
        M = MULBOX(HT)
        IF (M.NE.0) NFLAG = 0
      ENDIF
      NFLAG = 1
    3 CALL ASUNIT(H,HT,N,MUL)
      CALL GMEQ(HT,H,3,1)

      END SUBROUTINE GENMAG
!
!*****************************************************************************
!
      LOGICAL FUNCTION MAGABS(H,IK)

      USE ATMVAR
!
! *** MAGABS modified by PJB Jan 91 ***
!X
!C 17B
!H Tests for systematic absence of magnetic reflections.
!A On entry H is a 1x3 array holding h,k,l
!A On exit MAGABS = .TRUE. if absent, .FALSE. if present
!A         IK is +1 if the indices correspond to a r.l.v + the
!A            propagation vector ie h=g+k
!A         IK is -1 if h=g-k
!A         IK is 0 if this is irrelevant.
!P The space group symmetry should have been set up by SYMOP
!P The propagation vector PROP should have been set up by DOMAG
!
      DIMENSION H(3), TEST(3)
      LOGICAL M, LATABS
      COMMON /MAGDAT/ NMAG, MAGAT(MaxAtm_3), JMAGAT(10), NMFORM(10),         &
     &                ANGM(4,10), KANGM(4,10), SMOD(2,10), KSMOD(2,10), &
     &                PHIH(4,10), KPHIH(4,10), LPHI(4,10), NPHI(10),    &
     &                TPTAB(25,10), IPTAB(25,10), SPIND(3,3,2,10), KOM19
      COMMON /SATELL/ PROP(3), KPROP(3), KSTAB(24), NKSTAR, IPROP,      &
     &                FKSTAR, NKC, KCENT, INCOM, KOM21
      LOGICAL INCOM
!
      IK = 0
      IF (IPROP.EQ.0) THEN
        M = LATABS(H)
      ELSE
        CALL GMADD(H,PROP,TEST,3,1)
        M = LATABS(TEST)
        IF (M) THEN
          CALL GMSUB(H,PROP,TEST,3,1)
          M = LATABS(TEST)
          IF (.NOT.M) IK = 1
        ELSE
          IK = -1
        ENDIF
      ENDIF
      MAGABS = M
      RETURN
      END FUNCTION MAGABS
!
!*****************************************************************************
!
      SUBROUTINE MAGCNC

      USE ATMVAR
!
! *** MAGCNC uodated by PJB 17-Jan-95 ***
!
!X
!C 17A
!H To find magnetic constraints in a non-least squares calculation.
!P The magnetic symmetry must have been set up by calls to SYMOP and
!P DOMAG
!
      DIMENSION IPSFIX(4)
      LOGICAL LMFIX(3), FIRST
      COMMON /MAGDAT/ NMAG, MAGAT(MaxAtm_3), JMAGAT(10), NMFORM(10),         &
     &                ANGM(4,10), KANGM(4,10), SMOD(2,10), KSMOD(2,10), &
     &                PHIH(4,10), KPHIH(4,10), LPHI(4,10), NPHI(10),    &
     &                TPTAB(25,10), IPTAB(25,10), SPIND(3,3,2,10), KOM19
      COMMON /SYMMAG/ MTSYM(25), MSTAB(24), NMSYM, NFAC, OTRSYM(3,3,25),&
     &                MTYP, NDOM, FERO, FERA, HELI, AMOD, ANTI, MODUL,  &
     &                KOM20
      LOGICAL FERO, FERA, HELI, AMOD, ANTI, MODUL
      FIRST = .TRUE.
      DO MAT = 1, NMAG
! IF FERROMAGNETIC NO CONSTRAINTS
        IF (.NOT.(FERO.OR.FERA)) CALL MAGCON(MAT,LMFIX,FIRST)
! SET UP SPHERICAL POLARS:
        CALL SPHPOL(ANGM(1,MAT),ANGM(2,MAT),SPIND(1,1,1,MAT),1)
        IF (MODUL) THEN
          CALL PSICON(MAT,IPSFIX)
          IF (HELI) THEN
            CALL SPHPOL(ANGM(3,MAT),ANGM(4,MAT),SPIND(1,1,2,MAT),1)
            CALL SPHELI(MAT,0)
          ENDIF
        ENDIF
      ENDDO
      RETURN
      END SUBROUTINE MAGCNC
!
!*****************************************************************************
!
      SUBROUTINE MAGCON(IATO,LMFIX,FIRST)

      USE ATMVAR
!
! *** MAGCON corrected by PJB 4 30-Nov-1994 ***
!
!X
!C 17A
!H Finds and reports the symmetry constraints on magnetic parameters.
!A IATO is the number of the magnetic atom in question
!A LMFIX(I) is set to TRUE if parameter I for this atom is fixed by symmetry
!A FIRST is TRUE if no constraints have yet been found
!
      EXTERNAL DUMMY
      LOGICAL FIRST, LMFIX(3), NONE
      DIMENSION RMAT(3,3), NFIX(3), FIX(3), IATAB(24), RX(3), SCON(3), SOLD(3)
      DIMENSION VEC(3), TVEC(3,2)
      COMMON /ATNAM / ATNAME(MaxAtm_3), ATNA(MaxAtm_3,9)
      CHARACTER*4 ATNA, ATNAME
      REAL            PI, RAD, DEG, TWOPI, FOURPI, PIBY2, ALOG2, SQL2X8, VALMUB
      COMMON /CONSTA/ PI, RAD, DEG, TWOPI, FOURPI, PIBY2, ALOG2, SQL2X8, VALMUB
      INTEGER         LPT, LUNI
      COMMON /IOUNIT/ LPT, LUNI
      COMMON /MAGDAT/ NMAG, MAGAT(MaxAtm_3), JMAGAT(10), NMFORM(10),         &
     &                ANGM(4,10), KANGM(4,10), SMOD(2,10), KSMOD(2,10), &
     &                PHIH(4,10), KPHIH(4,10), LPHI(4,10), NPHI(10),    &
     &                TPTAB(25,10), IPTAB(25,10), SPIND(3,3,2,10), KOM19
      COMMON /NSYM  / NOP, NCENT, NOPC, NLAT, NGEN, CENTRC, KOM13
      LOGICAL CENTRC
      INTEGER         NATOM
      REAL                   X
      INTEGER                          KX
      REAL                                        AMULT,      TF
      INTEGER         KTF
      REAL                      SITE
      INTEGER                              KSITE,      ISGEN
      REAL            SDX,        SDTF,      SDSITE
      INTEGER                                             KOM17
      COMMON /POSNS / NATOM, X(3,MaxAtm_3), KX(3,MaxAtm_3), AMULT(MaxAtm_3), TF(MaxAtm_3),  &
     &                KTF(MaxAtm_3), SITE(MaxAtm_3), KSITE(MaxAtm_3), ISGEN(3,MaxAtm_3),    &
     &                SDX(3,MaxAtm_3), SDTF(MaxAtm_3), SDSITE(MaxAtm_3), KOM17
      COMMON /SATELL/ PROP(3), KPROP(3), KSTAB(24), NKSTAR, IPROP,      &
     &                FKSTAR, NKC, KCENT, INCOM, KOM21
      LOGICAL INCOM
      COMMON /SCRACH/ MESSAG, NAMFIL
      CHARACTER*80 ICARD, MESSAG*100, NAMFIL*100
      EQUIVALENCE (ICARD,MESSAG)
      COMMON /SYMDA / SYM(3,3,24), TRANS(3,24), ALAT(3,4), ORIGIN(3),   &
     &                KOM26
      COMMON /SYMMAG/ MTSYM(25), MSTAB(24), NMSYM, NFAC, OTRSYM(3,3,25),&
     &                MTYP, NDOM, FERO, FERA, HELI, AMOD, ANTI, MODUL,  &
     &                KOM20
      LOGICAL FERO, FERA, HELI, AMOD, ANTI, MODUL
      COMMON /SYMTAB/ MULTAB(24,24), INVERS(24), NORD(24), IGEN(3),     &
     &                KOM22
!
      IAT = JMAGAT(IATO)
!  CHECK THAT STRUCTURE AND SYMMETRY ARE COMPATIBLE WITH THE
!  PROPAGATION VECTOR
      CALL MAKGRP(ISGEN(1,IAT),IATAB,0,DUMMY)
      DO N = 2, NOPC
        IF (IABS(KSTAB(N)).NE.1 .AND. IATAB(N).EQ.0) THEN
          WRITE (LPT,2800) N
          CALL BMBOUT
          RETURN
        ENDIF
      ENDDO
      CANG1 = ANGM(1,IATO)
      CANG2 = ANGM(2,IATO)
      DO J = 1, 3
        LMFIX(J) = .FALSE.
        NFIX(J) = 9999
      ENDDO
      N = ISGEN(1,IAT)
!  JUMP IF NOT SPECIAL
      NONE = N.EQ.1
      IF (NONE) GOTO 17
      IF (N.LT.0 .AND. MSTAB(1).LT.0) THEN
! CENTRE OF SYMMETRY PRESENT: IF NOT AT ORIGIN WHAT
! LATTICE VECTOR IS INVOLVED
        CALL GMREV(X(1,IAT),TVEC,1,3)
        CALL GMADD(X(1,IAT),TVEC,VEC,3,1)
        PH = SCALPR(PROP,VEC)
!  CHECK THE THE PHASE SHIFT IS n*PI
        IF (ABS(FLOAT(NINT(2.*PH))-2.*PH).GT..001) THEN
          CALL ERRCH2(ATNAME(IATO),1,                                   &
     &       'The centre of symmetry is not consistent with a moment on'&
     &       ,'for this propagation vector')
!  CHECK ALSO THAT IT IS NON-REVERSING
        ELSE
          IF (NINT(COS(TWOPI*PH)).NE.MTSYM(25)) THEN
!  CAN HAVE NO MOMENT:
            NFIXED = 3
            DO I = 1, 3
              LMFIX(I) = .TRUE.
            ENDDO
            SMOD(1,IATO) = 0.
            CANG1 = 0.
            CANG2 = 0.
            GOTO 17
          ENDIF
        ENDIF
      ENDIF
!  LOOK TO SEE WHICH ELEMENTS OF THE ATOM SUB-GROUP ARE
!  IN THE MAGNETIC SYMMETRY GROUP
      DO K = 2, NOPC
        IF (IATAB(K).EQ.0) GOTO 3
        CALL GMEQ(OTRSYM(1,1,K),RMAT,3,3)
!  REVERSE THE MATRIX IF OPERATION IS COMBINED WITH INVERSION, AND
!  THE INVERSION IS TIME-REVERSING
        IF (IATAB(K).LT.0 .AND. MTSYM(25).LT.0)                         &
     &      CALL GMREV(RMAT,RMAT,3,3)
! IN CASE OF SHIFT BY A LATTICE VECTOR:
        IF (IPROP.NE.0) THEN
          CALL ROTSYM(X(1,IAT),RX,K,1)
          CALL GMADD(RX,TRANS(1,K),RX,3,1)
          CALL GMSUB(RX,X(1,IAT),RX,3,1)
          PH = SCALPR(PROP,RX)
!  CHECK THE THE PHASE SHIFT IS n*PI
          IF (ABS(FLOAT(NINT(2.*PH))-2.*PH).GT..001) THEN
            CALL ERRIN2(K,-1,'Operator','is not consistent with a moment on'//          &
     &                  ATNAME(IATO)//'for this propagation vector')
!  IF AN ODD MULTIPLE OF PI REVERSE THE MATRIX
            IF (ABS(FLOAT(NINT(PH))-PH).GT..3) CALL GMREV(RMAT,RMAT,3,3)
          ENDIF
        ENDIF
        CALL RELSM3(RMAT,NFIX,FIX)
    3 ENDDO
!  NOW CONVERT XYZ CONSTRAINTS TO SPHERICAL POLAR ONES
!  COUNT FIXED PARS
      NFIXED = 0
      NREL = 0
      DO I = 1, 3
        IF (NFIX(I).EQ.0) THEN
          NFIXED = NFIXED + 1
        ELSE
! CHECK THAT THIS 9999 IS STILL OK:
          IF (NFIX(I).LT.9999) NREL = NREL + 1
        ENDIF
      ENDDO
      GOTO (10,11,12,13), NFIXED + 1
! ALL FIXED
   13 DO I = 1, 3
        LMFIX(I) = .TRUE.
      ENDDO
      GOTO 17
!  TWO FIXED - FIND WHICH
   12 IF (NFIX(1).EQ.0 .AND. NFIX(2).EQ.0) THEN
        CANG1 = 0.
      ELSE
        CANG1 = 90.
      ENDIF
      LMFIX(1) = .TRUE.
    7 IF (NFIX(1).EQ.0) CANG2 = 90.
      IF (NFIX(2).EQ.0) CANG2 = 0.
      LMFIX(2) = .TRUE.
      GOTO 10
!  ONE FIXED
   11 IF (NFIX(3).NE.0) GOTO 7
      CANG1 = 90.
      LMFIX(1) = .TRUE.
!  NOW RELATIONSHIPS
   10 GOTO (8,8,15,16), NREL + 1
! NONE
    8 NONE = NFIXED.EQ.0
      GOTO 17
!  ALL THREE RELATED - FIX BOTH ANGLES
   16 CANG2 = ATAN2(FIX(1),FIX(2))
      CANG1 = DEGREE(ATAN2(FIX(1)*COS(CANG2),FIX(3)))
      LMFIX(1) = .TRUE.
      GOTO 14
!  IF TWO PARS RELATED THEY SHOULD BE 1 AND 2 IF THE THIRD IS FREE
   15 IF (NFIX(3).NE.9999 .AND. NFIXED.NE.1) THEN
        WRITE (LPT,3000) NFIX
        CALL BMBOUT
        RETURN
      ENDIF
      GOTO (20,17,21,20), NFIX(1) + 1
   21 CANG2 = ATAN2(FIX(1),FIX(2))
   14 LMFIX(2) = .TRUE.
      CANG2 = DEGREE(CANG2)
      GOTO 17
   20 CANG1 = DEGREE(ATAN2(FIX(3),FIX(NFIX(3))))
      LMFIX(1) = .TRUE.
!
   17 IF (FIRST) CALL MESS(LPT,1,                                       &
     &                     'Symmetry constraints on magnetic moments:')
      FIRST = .FALSE.
      WRITE (ICARD,2001) ATNAME(IAT)
 2001 FORMAT (1X,A4,' None')
      IF (.NOT.NONE) THEN
!
!  CHOOSE BEST DIRECTION
        CALL SPHPOL(CANG1,CANG2,SOLD,1)
        CALL SPHPOL(ANGM(1,IATO),ANGM(2,IATO),SCON,1)
        IF (SCALPR(SCON,SOLD).LT.0.) THEN
          ANGM(1,IATO) = ARANGE(180.-CANG1,180.,-180.)
          ANGM(2,IATO) = ARANGE(180.+CANG2,180.,-180.)
        ELSE
          ANGM(1,IATO) = CANG1
          ANGM(2,IATO) = CANG2
        ENDIF
        J = 6
        IF (LMFIX(3)) THEN
          WRITE (ICARD(J:),2003) 'MU', SMOD(1,IATO)
 2003     FORMAT (1X,A4,' =',F9.4)
          J = J + 16
        ENDIF
        IF (LMFIX(1)) THEN
          WRITE (ICARD(J:),2002) 'THET', ANGM(1,IATO)
          J = J + 16
        ENDIF
        IF (LMFIX(2)) THEN
          WRITE (ICARD(J:),2002) 'PHI', ANGM(2,IATO)
          J = J + 16
        ENDIF
      ENDIF
      CALL MESS(LPT,0,ICARD)
!  THE CONSTRAINTS ARE THE SAME FOR BOTH COMPONENTS OF A HELIX
      IF (HELI) THEN
        IF (LMFIX(1)) ANGM(3,IATO) = ANGM(1,IATO)
        IF (LMFIX(2)) ANGM(4,IATO) = ANGM(2,IATO)
        IF (LMFIX(3)) SMOD(2,IATO) = SMOD(1,IATO)
      ENDIF
      RETURN
 2800 FORMAT (/' ERROR ** Structure symmetry is reduced by ',           &
     &        'that of the propagation vector (operator #',I2,          &
     &        ').'/' **** Change S cards ****')
 3000 FORMAT (' *** PROGRAM ERROR IN MAGCON ***'/' NFIX =',             &
     &        3I5/' I thought this couldn''t happen! PJB')
 2002 FORMAT (1X,A4,' =',F9.2)
      END SUBROUTINE MAGCON
!
!*****************************************************************************
!
      SUBROUTINE MAGDOM(H,HK,IOP,SKIP)
!
! *** MAGDOM by PJB Apr 87 ***
!
!X
!C 17B
!H In Least Squares refinement with magnetic scattering, forms the matrix
!H needed for derivatives of Q with respect to a spin direction.
!A On entry H is the scattering vector
!A          IOP is the symmetry operator to be used on H
!A On exit the 3x3 matrix HK contains the required matrix.
!A         LOGICAL SKIP is set to indicate
!P MTYP must indicate the type of magnetic structure.
!P NORD, MSTAB and KSTAB entries for IOP must be set.
!D  HK is formed, such that Q=KxSxK=S[HK]
!
      DIMENSION H(3), RH(3), OH(3), HK(3,3)
      LOGICAL SKIP
      COMMON /SATELL/ PROP(3), KPROP(3), KSTAB(24), NKSTAR, IPROP,      &
     &                FKSTAR, NKC, KCENT, INCOM, KOM21
      LOGICAL INCOM
      COMMON /SYMMAG/ MTSYM(25), MSTAB(24), NMSYM, NFAC, OTRSYM(3,3,25),&
     &                MTYP, NDOM, FERO, FERA, HELI, AMOD, ANTI, MODUL,  &
     &                KOM20
      LOGICAL FERO, FERA, HELI, AMOD, ANTI, MODUL
      COMMON /SYMTAB/ MULTAB(24,24), INVERS(24), NORD(24), IGEN(3),     &
     &                KOM22
!
!  FOR FERROMAGNETIC USE THE WHOLE GROUP
      IF (FERO) GOTO 2
!
      IF (IOP.NE.1 .AND. (MSTAB(IOP).NE.1.OR.KSTAB(IOP).NE.1)) THEN
        SKIP = .TRUE.
        GOTO 100
      ENDIF
    2 SKIP = .FALSE.
!
      CALL ROTSYM(H,RH,IOP,2)
!  REVERSE IF IMPROPER ROTATION
      IF (NORD(IOP).LT.0) CALL GMREV(RH,RH,3,1)
      CALL ORTHO(RH,OH,2)
      CALL UNIVEC(OH,D)
      J = 2
      K = 3
      DO I = 1, 3
        HK(I,I) = OH(J)*OH(J) + OH(K)*OH(K)
        HK(I,J) = -OH(I)*OH(J)
        HK(I,K) = -OH(I)*OH(K)
        J = K
        K = I
      ENDDO
!
  100 RETURN
      END SUBROUTINE MAGDOM
!
!*****************************************************************************
!
      SUBROUTINE MAGSYM(MODE)
!
! *** MAGSYM updated by PJB 31-May-1994 ***
!
!X
!C 17B
!H Routine with 4 named entry points, MAGSYM, MELIN, NELIN and ROTMAG, to deal
!H generally with magnetic symmetry.  MAGSYM sets magnetic symmetry, MELIN puts
!H in an operator for a generator, NELIN puts in non-symmetric rotation and
!H ROTMAG rotates with a magnetic operator.
!A On entry to MAGSYM MODE = 0 to initialise
!A                           1 to generate the remaining operators and the
!A                             orthogonal spin rotations in OTRSYM
!A On entry to MELIN  IOP = which operator
!A                    VAL = + or - 1, its value
!A On entry to ROTMAG S is the 3x3 array to be rotated
!A                    IOP = which operator
!A On exit from ROTMAG RS is the 3x3 rotated array
!A On entry to NELIN  IOP = which operator
!                     SROT = the rotation matrix for the spin
!
      EXTERNAL MTPROD
      DIMENSION S(3,3), RS(3,3), TEMP(3,3), SROT(3,3), MGEN(3)
      DIMENSION NSTAB(25), MJTAB(24)
      COMMON /CELPAR/ CELL(3,3,2), V(2), ORTH(3,3,2), CPARS(6,2),       &
     &                KCPARS(6), CELESD(6,6,2), CELLSD(6,6), KOM4
      INTEGER         LPT, LUNI
      COMMON /IOUNIT/ LPT, LUNI
      COMMON /NSYM  / NOP, NCENT, NOPC, NLAT, NGEN, CENTRC, KOM13
      LOGICAL CENTRC
      COMMON /SYMDA / SYM(3,3,24), TRANS(3,24), ALAT(3,4), ORIGIN(3), KOM26
      COMMON /SYMMAG/ MTSYM(25), MSTAB(24), NMSYM, NFAC, OTRSYM(3,3,25),&
     &                MTYP, NDOM, FERO, FERA, HELI, AMOD, ANTI, MODUL, KOM20
      LOGICAL FERO, FERA, HELI, AMOD, ANTI, MODUL
      COMMON /SYMTAB/ MULTAB(24,24), INVERS(24), NORD(24), IGEN(3), KOM22

      INTEGER         IBMBER
      COMMON /CCSLER/ IBMBER

      IF (MODE.EQ.1) GOTO 20
!  INITIALISE
      CALL JGMZER(MTSYM,1,NOPC)
      CALL JGMZER(MSTAB,1,NOPC)
      GOTO 100
!  ENTRY TO PUT IN ONE MAGNETIC SYMMETRY OPERATOR
      ENTRY MELIN(IOP,VAL)
      IO = IABS(IOP)
      IF (ABS(VAL).LT..0001) THEN
        CALL ERRIN2(IOP,1,'Zero value for magnetic symmetry operator',' ')
        GOTO 100
      ENDIF
!  RECORD WHETHER THE OPERATOR INVOLVED INVERSION
      IF (IOP.LT.0) THEN
        MSTAB(IO) = ISIGN(2,IFIX(VAL))
      ELSE
        MSTAB(IO) = ISIGN(1,IFIX(VAL))
      ENDIF
      GOTO 100
!  ENTRY TO ADD A NON-SYMMETRIC ROTATION
      ENTRY NELIN(IOP,SROT)
      IO = IOP
      IF (IOP.EQ.-1) IO = 25
      CALL GMEQ(SROT,OTRSYM(1,1,IO),3,3)
!  MARK NON-SYMMETRIC OPERATORS
      IF (IOP.EQ.-1) IOP = 1
      MSTAB(IOP) = 100
      GOTO 100
! FORM THE REST OF THE MAGNETIC OPERATORS FROM THE MULTIPLICATION TABLE
   20 DO IO = 1, NOPC
        IF (MSTAB(IO).EQ.100) THEN
          NSTAB(IO) = 1
          MSTAB(IO) = 0
        ELSE
          NSTAB(IO) = 0
        ENDIF
      ENDDO
      IF (FERO .OR. FERA) THEN
        CALL GMUNI(OTRSYM(1,1,25),3)
        GOTO 100
      ENDIF
      IF (CENTRC) THEN
        IF (MSTAB(1).EQ.0) THEN
          CALL MESS(LPT,1,'No centre of symmetry in the magnetic group')
          IF (NSTAB(1).EQ.0) THEN
            CALL ERRMES(1,2,'No spin rotation given for centrosymmetrically related atoms')
          ELSE
            WRITE (LPT,2031) ((OTRSYM(I,J,25),I=1,3),J=1,3)
 2031       FORMAT (/' Spin rotation for centro-symmetrically related',' atoms is: ',3F6.2,2(/58X,3F6.2))
          ENDIF
        ELSE
          CALL GMUNI(OTRSYM(1,1,25),3)
          MSTAB(1) = ISIGN(1,MSTAB(1))
          IF (MSTAB(1).LT.0) CALL GMREV(OTRSYM(1,1,25),OTRSYM(1,1,25),3,3)
          MTSYM(25) = MSTAB(1)
        ENDIF
      ENDIF
! CONSTRUCT THE MAGNETIC SUB-GROUP
      MGEN(1) = -1
      IF (MSTAB(1).EQ.0) MGEN(1) = 1
      NGEN = 1
      DO I = 2, NOPC
        IF (MSTAB(I).EQ.0) GOTO 40
        NGEN = NGEN + 1
        MGEN(NGEN) = (3-2*(IABS(MSTAB(I))))*I
        MTSYM(I) = ISIGN(1,MSTAB(I))
        IF (NGEN.EQ.3) GOTO 41
   40 ENDDO
      MGEN(3) = 1
      IF (NGEN.EQ.1) MGEN(2) = 1
   41 CALL MAKGRP(MGEN,MJTAB,1,MTPROD)
      NMSYM = (MGEN(1))
! NUMBER OF ORIENTATION DOMAINS
      NDOM = NOPC/NMSYM
      MJTAB(1) = MSTAB(1)
      WRITE (LPT,2001) (I,MTSYM(I),I=1,NOPC)
 2001 FORMAT (/' Magnetic symmetry operators: ',12(I3,' =',I3)/31X,12(I3,' =',I3))
      IF (CENTRC) WRITE (LPT,2002) MSTAB(1)
 2002 FORMAT (/31X,' Centre of symmetry =',I3)
!
!  PUT SPIN ROTATIONS ONTO ORTHOGONAL AXES
! USE OTRSYM(,,1) TEMPORARILY FOR TRANSPOSE:
      CALL GMEQ(ORTH(1,1,1),OTRSYM(1,1,1),3,3)
      CALL TRANSQ(OTRSYM(1,1,1),3)
      DO NO = 2, NOPC
        IF (MTSYM(NO).EQ.0) GOTO 27
        CALL MultiplyMatrices(SYM(1,1,NO),ORTH(1,1,2),TEMP,3,3,3)
        IF (MTSYM(NO)*NORD(NO).LT.0.) CALL GMREV(TEMP,TEMP,3,3)
        CALL MultiplyMatrices(OTRSYM(1,1,1),TEMP,OTRSYM(1,1,NO),3,3,3)
   27 ENDDO
      CALL GMUNI(OTRSYM(1,1,1),3)
      CALL FACTGP(MJTAB,MSTAB,NFAC)
      WRITE (LPT,2003) (I,MSTAB(I),I=1,NOPC)
 2003 FORMAT (/' Magnetic symmetry table : ',12(I3,' =',I3)/28X,12(I3,' =',I3))
!
!  NOW DEAL WITH NON-SYMMETRIC ROTATIONS
      DO NO = 2, NOPC
        IOPP = IABS(MSTAB(NO))
        IF (IOPP.EQ.1) GOTO 43
        IF (IOPP.EQ.NO) THEN
          IF (NSTAB(NO).NE.1) THEN
            CALL ERRIN2(NO,1,'Missing non-symmetric spin rotation for element number',' ')
          ELSE
            WRITE (LPT,2004) NO, ((OTRSYM(I,J,NO),I=1,3),J=1,3)
 2004       FORMAT (/' Non-symmetric spin rotation for element number', &
     &              I3,' is:  ',3F6.2,2(/56X,3F6.2))
          ENDIF
        ELSE
          IX = MULTAB(NO,INVERS(IOPP))
          IF (MSTAB(IX).EQ.0) THEN
            CALL ERRMES(-1,0,'Logical error in MAGSYM - bad tables')
            IF (IBMBER .NE. 0) RETURN
          ENDIF
          CALL MultiplyMatrices(OTRSYM(1,1,IX),OTRSYM(1,1,IOPP),OTRSYM(1,1,NO),3,3,3)
        ENDIF
        IF (MSTAB(NO).LT.0) CALL GMREV(OTRSYM(1,1,NO),OTRSYM(1,1,NO),3,3)
   43 ENDDO
      GOTO 100
!  ENTRY TO OPERATE WITH MAGNETIC SYMMETRY
      ENTRY ROTMAG(S,RS,IOP)
!  DONT ROTATE IF FERROMAGNETIC
      IF (FERO .OR. FERA) THEN
        CALL GMEQ(S,RS,3,3)
      ELSE
        DO I = 1, 3
          CALL MultiplyMatrices(OTRSYM(1,1,IOP),S(1,I),RS(1,I),3,3,1)
        ENDDO
      ENDIF
  100 RETURN
      END SUBROUTINE MAGSYM
!
!*****************************************************************************
!
      SUBROUTINE MF5ADD(ISPC,IG,IS,N)

      USE ATMVAR
!
! *** MF5ADD by JCM 13 Jun 88 ***
!
!X
!C 18B
!H A specialist routine to deal with the refinement of multipoles.
!H Converts each type of LSQ family 5 (multipoles) addressing to the other.
!A On entry N=1  requests "give answer in in ISPC genus 1 from IG,IS"
!A          N=-1 requests "give answers as IG, IS from species ISPC"
!A So for N=1 IG, IS are set on entry to genus and species
!A    for N=-1, ISPC is set on entry to contain "species" in one long genus.
!P Table MPNAM must have been set up to contain species names, and
!P       MPTAB to point in it for each genus of family 5.
!
      COMMON /MPODA / NMPAT, NMPOL, MPATAB(20), MPNMTB(MaxAtm_3), NCLUMP,    &
     &                KCLUMP(100), MPTAB(21), POLAMP(200,6), KPOLMP(200)&
     &                , NCMAT, CONMAT(600,2)
!
      IF (N.LT.0) GOTO 1
! IG, IS GIVEN ; SET ISPC:
      ISPC = MPTAB(IG) + IS
      GOTO 100
!
! ISPC GIVEN; SET IS,IG:
    1 DO I = 1, NMPAT
        IF (MPTAB(I+1).GT.ISPC) GOTO 3
      ENDDO
!
!>> JCC      STOP 'ERROR ** IN MF5ADD'
      CALL BMBOUT
      RETURN
    3 IG = I
      IS = ISPC - MPTAB(I) + 1
  100 RETURN
      END SUBROUTINE MF5ADD
!
!*****************************************************************************
!
      SUBROUTINE PROPAG(MODE,INOUT)
!
! 17B
! *** PROPAG new by PJB 28-Sept-93 ***
!
!H Multiple entry subroutine for propagation vector refinement
!A MODE indicates what function is required
!A MODE = 1 Read a Q PROP card if present and if so call PROPER
!A          on exit INOUT is 1 id found 0 if not
!A      = 2 Set the symmetry constraints on the magnetic propagation vector
!A          INOUT is set on input to the offset of the propagation vector in
!A          the family 1 genus 1 parameters
!A      = 3 Apply a shift to the INOUTth component
!A      = 4 Write new Q PROP card on unit INOUT
!A      = 0 all components fixed
!A      = negative integer set the variable number of the -MODEth component to
!A       be INOUT
!
      DIMENSION ITAB(24), JGEN(3), NFIX3(3), RMAT(3,3), FIX3(3),        &
     &          NCOUNT(3)
!
      COMMON /NSYM  / NOP, NCENT, NOPC, NLAT, NGEN, CENTRC, KOM13
      LOGICAL CENTRC
      COMMON /SATELL/ PROP(3), KPROP(3), KSTAB(24), NKSTAR, IPROP,      &
     &                FKSTAR, NKC, KCENT, INCOM, KOM21
      LOGICAL INCOM
      COMMON /SYMDA / SYM(3,3,24), TRANS(3,24), ALAT(3,4), ORIGIN(3),   &
     &                KOM26
      COMMON /SYMTAB/ MULTAB(24,24), INVERS(24), NORD(24), IGEN(3),     &
     &                KOM22
      COMMON /SCRACH/ MESSAG, NAMFIL
      CHARACTER*80 ICARD, MESSAG*100, NAMFIL*100
      EQUIVALENCE (ICARD,MESSAG)
!
      IF (MODE.LE.0) GOTO 60
      GOTO (10,20,30,40), MODE
!
! READ Q PROP CARD
   10 CALL FINDCD('Q','PROP',4,0,LCD)
      IF (LCD.GT.0) THEN
        CALL RDNUMS(FIX3,7,3,NUM,IER)
        IF (IER.NE.0 .OR. NUM.NE.3) CALL ERRMES(1,1,'reading propagation vector')
        CALL PROPER(FIX3)
        INOUT = 1
      ELSE
        INOUT = -1
      ENDIF
      GOTO 100
! SET SYMMETRY CONSTRAINTS
   20 IPOFF = INOUT
! CLEAR OUT ALL FIX/RELA INFO
      DO K = 1, 3
        NFIX3(K) = 9999
      ENDDO
      IF (IPROP.LE.0 .OR. IPROP.EQ.2) GOTO 23
      CALL JGMZER(ITAB,1,NOPC)
      ITAB(1) = 1
      JGEN(1) = 1
      DO I = 2, NOPC
        IF (KSTAB(I).NE.1) GOTO 21
        ITAB(I) = IABS(NORD(I))
        JGEN(1) = JGEN(1) + 1
   21 ENDDO
! Find generators of subgroup
      CALL GENELM(ITAB,JGEN)
! JUMP IF NOT SPECIAL:
      IF (JGEN(1).EQ.1) GOTO 26
! JUMP IF NOT ON A CENTRE OF SYMMETRY:
      IF (JGEN(1).GT.0) GOTO 24
! FIX ALL COMPONENTS:
   23 DO I = 1, 3
        CALL FIXPAR(I,NFIX3)
      ENDDO
      GOTO 26
! TAKE FIRST (OF POSSIBLE 2) SYMMETRY ELEMENTS MAKING THIS POSITION SPECIAL:
   24 DO I = 2, 3
        K = IABS(JGEN(I))
        CALL GMEQ(SYM(1,1,K),RMAT,3,3)
        IF (JGEN(I).LT.0) CALL GMREV(RMAT,RMAT,3,3)
        CALL RELSM3(RMAT,NFIX3,FIX3)
! IS THERE A SECOND GENERATOR OF THE SUB-GROUP WHICH MAKES THIS ATOM SPECIAL?
        IF (JGEN(3).EQ.0) GOTO 26
      ENDDO
! ALL COMPONENT RELATIONS COLLECTED IN TEMPORARY SPACE - USE:
   26 DO I = 1, 3
        NCOUNT(I) = KPAK(1,1,IPOFF+I,JPHASE,1)
      ENDDO
      CALL FIXREL(3,NFIX3,FIX3,NCOUNT,5)
      GOTO 100
! APPLY SHIFT
   30 IF (INOUT.GT.3) GOTO 100
      CALL ADJUST(PROP(INOUT))
      GOTO 100
! WRITE NEW Q PROP CARD
   40 IF (ICARD(3:6).NE.'PROP') THEN
        L = LENGT(ICARD)
        WRITE (INOUT,4001) (ICARD(I:I),I=1,L)
 4001   FORMAT (80A1)
      ELSE
        WRITE (INOUT,4000) PROP
 4000   FORMAT ('Q PROP',3F10.4)
      ENDIF
      GOTO 100
! TO SET ALL COMPONENTS FIXED, OR VARY ONE:
   60 N = IABS(MODE)
      IF (N.EQ.0) THEN
        DO I = 1, 3
          KPROP(I) = 0
        ENDDO
      ELSE
        IF (N.GT.3) GOTO 100
        KPROP(N) = INOUT
      ENDIF
  100 RETURN
      END SUBROUTINE PROPAG
!
!*****************************************************************************
!
      SUBROUTINE PROPER(AKVEC)
!
! *** PROPER updated by PJB 14-Dec-1994 ***
!
!X
!C 17A
!H Determines whether the satellites generated by the propagation vector
!H PROP have integer indices, and generates its "star".
!
!A On entry AKVEC is the 1X3 propagation vector copied to PROP
!A There is an ENTRY KSTAR(AKVEC,BKSTAR) to return the vectors AKSTAR
!A of the star in BKSTAR as well as filling in the common /SATELL/
!P SYMOP should have been obeyed to read the space group symmetry
!D On exit  IPROP in /SATELL/ is zero if PROP is 0 0 0
!D                negative for other integer indices
!D                and positive for non-integer values.
!D        IABS(IPROP) is set to 2 if twice PROP is a reciprocal
!D                lattice vector.
!D On exit the symmetry table of the star is in KSTAB.
!D NKSTAR holds the number of vectors in the star,
!D INCOM is .TRUE. if the propagation vector is fixed on a symmetry point
!D and FKSTAR is a scale for structure factors assuming a mono-k domain.
!D The ENTRY KSTAR not only writes the common /SATELL/ but also returns the
!D vectors AKSTAR of the star.
!O Writes its findings on unit LPT
!
      DIMENSION AKVEC(3), AKSTAR(3,24), RPROP(3), BKSTAR(1)
      LOGICAL KSTARS
      INTEGER         LPT, LUNI
      COMMON /IOUNIT/ LPT, LUNI
      COMMON /SYMMAG/ MTSYM(25), MSTAB(24), NMSYM, NFAC, OTRSYM(3,3,25),&
     &                MTYP, NDOM, FERO, FERA, HELI, AMOD, ANTI, MODUL,  &
     &                KOM20
      LOGICAL FERO, FERA, HELI, AMOD, ANTI, MODUL
      COMMON /NSYM  / NOP, NCENT, NOPC, NLAT, NGEN, CENTRC, KOM13
      LOGICAL CENTRC
      COMMON /SATELL/ PROP(3), KPROP(3), KSTAB(24), NKSTAR, IPROP,      &
     &                FKSTAR, NKC, KCENT, INCOM, KOM21
      LOGICAL INCOM
      KSTARS = .FALSE.
      GOTO 2
      ENTRY KSTAR(AKVEC,BKSTAR)
      KSTARS = .TRUE.
    2 CALL GMEQ(AKVEC,PROP,3,1)
      IPROP = 0
      IF (ABS(PROP(1))+ABS(PROP(2))+ABS(PROP(3)).LT..00001) GOTO 3
      IPROP = 1
      DO I = 1, 3
        IF (PROP(I)-AINT(PROP(I)).GT..00001) GOTO 3
      ENDDO
      IPROP = -1
!
! THIS PART USED TO BE KSTAR:
    3 CALL GMEQ(PROP,AKSTAR(1,1),3,1)
      MN = 1
      KSTAB(1) = 1
      DO I = 2, NOPC
        IF (IPROP.EQ.0) THEN
          KSTAB(I) = 1
        ELSE
          ISIG = 1
          CALL ROTSYM(PROP,RPROP,I,2)
          CALL EQRLV(AKSTAR,RPROP,MN,M,NOPC)
          IF (M.GT.MN) THEN
            CALL GMREV(RPROP,RPROP,3,1)
            CALL EQRLV(AKSTAR,RPROP,MN,M,0)
            IF (M.GT.MN) THEN
              MN = M
            ELSE
              ISIG = -1
            ENDIF
          ENDIF
          KSTAB(I) = M*ISIG
        ENDIF
      ENDDO
      NKC = MN
!  CHECK CENTRE OF SYMMETRY
      KCENT = 1
      CALL GMREV(PROP,RPROP,3,1)
      CALL EQRLV(AKSTAR,RPROP,MN,M,0)
! DOES CENTRE OF SYMMETRY PRODUCE A NEW VECTOR
      IF (M.GT.MN) THEN
        KSTAB(1) = -MN
        KCENT = 2
      ELSE
        KSTAB(1) = MN
      ENDIF
      WRITE (LPT,2000) (KSTAB(I),I=1,NOPC)
 2000 FORMAT (' Group of K :',24I4)
      WRITE (LPT,2001) ((AKSTAR(I,J),I=1,3),J=1,NKC)
 2001 FORMAT (' Vectors in the star: ',3F10.4/(22X,3F10.4))
! CASE WHERE CENTRE OF SYMMETRY PRODUCES NEW VECTORS:
      NKSTAR = KCENT*NKC
      FKSTAR = 1.
      IPROP = (3-KCENT)*IPROP
      FKSTAR = FKSTAR/FLOAT(KCENT)
      INCOM = (KCENT.EQ.2)
      IF (KSTARS) CALL GMEQ(AKSTAR,BKSTAR,3,NKC)

      END SUBROUTINE PROPER
!
!*****************************************************************************
!
      SUBROUTINE PSICON(MGAT,IPSFIX)

      USE ATMVAR
!
! *** PSICON corrected by PJB/JBF 13-Jan-1995 ***
!
!X
!C 17A
!H Determines the constraints on the phase factors in helimagnets.
!A MGAT identifies the magnetic atom in question.
!A On exit the vector IPSFIX indicates the constraints
!A         IPSFIX(i)=0 if the ith phase factor is fixed (or not required)
!A         IPSFIX(i)=j if the ith phase factor is coupled to the jth.
!D The table LPHI in common MAGDAT holds the number of the symmetry element
!D which generates the sub-lattice, and PHIH the corresponding phase factor.
!D The table IPTAB held in common MAGDAT has an entry for each symmetry
!D operator and each magnetic atom. IPTAB(J,MGAT) holds the number labelling the
!D sublattice which is generated by the operation of J on MGAT. The fundamental
!D sublattice has the label 1.
!D
!D For elements which are the product of one in the magnetic group: I and one
!D not in it: J the sub-lattice number is that belonging to J.
!D A parallel table TPTAB holds the phase shifts introduced by transforming
!D the coordinates of the sub-lattices produced by the symmetry operations
!D back into the original unit cell.
!D
!D Information for the centre of symmetry is in IPTAB(NOPC+1,MGAT). If this
!D is negative the centre of symmetry generates new sublattices, and the entries
!D for such sub-lattices in LPHI are negative.
!
      DIMENSION XEQ(3,24), IPSFIX(4), TPHI(4), LTPHI(4)
      DIMENSION XR(3), XT(3), CELLT(3)
      COMMON /ATNAM / ATNAME(MaxAtm_3), ATNA(MaxAtm_3,9)
      CHARACTER*4 ATNA, ATNAME
      REAL            PI, RAD, DEG, TWOPI, FOURPI, PIBY2, ALOG2, SQL2X8, VALMUB
      COMMON /CONSTA/ PI, RAD, DEG, TWOPI, FOURPI, PIBY2, ALOG2, SQL2X8, VALMUB
      COMMON /MAGDAT/ NMAG, MAGAT(MaxAtm_3), JMAGAT(10), NMFORM(10),         &
     &                ANGM(4,10), KANGM(4,10), SMOD(2,10), KSMOD(2,10), &
     &                PHIH(4,10), KPHIH(4,10), LPHI(4,10), NPHI(10),    &
     &                TPTAB(25,10), IPTAB(25,10), SPIND(3,3,2,10), KOM19
      COMMON /NSYM  / NOP, NCENT, NOPC, NLAT, NGEN, CENTRC, KOM13
      LOGICAL CENTRC
      INTEGER         NATOM
      REAL                   X
      INTEGER                          KX
      REAL                                        AMULT,      TF
      INTEGER         KTF
      REAL                      SITE
      INTEGER                              KSITE,      ISGEN
      REAL            SDX,        SDTF,      SDSITE
      INTEGER                                             KOM17
      COMMON /POSNS / NATOM, X(3,MaxAtm_3), KX(3,MaxAtm_3), AMULT(MaxAtm_3), TF(MaxAtm_3),  &
     &                KTF(MaxAtm_3), SITE(MaxAtm_3), KSITE(MaxAtm_3), ISGEN(3,MaxAtm_3),    &
     &                SDX(3,MaxAtm_3), SDTF(MaxAtm_3), SDSITE(MaxAtm_3), KOM17
      COMMON /SATELL/ PROP(3), KPROP(3), KSTAB(24), NKSTAR, IPROP,      &
     &                FKSTAR, NKC, KCENT, INCOM, KOM21
      LOGICAL INCOM
      COMMON /SYMDA / SYM(3,3,24), TRANS(3,24), ALAT(3,4), ORIGIN(3),   &
     &                KOM26
      COMMON /SYMMAG/ MTSYM(25), MSTAB(24), NMSYM, NFAC, OTRSYM(3,3,25),&
     &                MTYP, NDOM, FERO, FERA, HELI, AMOD, ANTI, MODUL,  &
     &                KOM20
      LOGICAL FERO, FERA, HELI, AMOD, ANTI, MODUL
      DATA NPSI/4/
!
      IAT = JMAGAT(MGAT)
!
!  COPY DATA READ TO TEMPORARY STORAGE
      CALL JGMEQ(LPHI(1,MGAT),LTPHI,1,NPSI)
      CALL GMEQ(PHIH(1,MGAT),TPHI,1,NPSI)
!  AND CLEAR LPHI
      CALL JGMZER(LPHI(1,MGAT),1,NPSI)
!
      CALL GMEQ(X(1,IAT),XEQ(1,1),3,1)
      CALL GMEQ(X(1,IAT),XT,3,1)
      DO I = 1, NOPC + 1
        IPTAB(I,MGAT) = 1
      ENDDO
      CALL JGMZER(IPSFIX,NPSI,1)
      ICENT = 1
      IF (CENTRC .AND. MSTAB(1).GT.0) ICENT = 2
! LOOP OVER ELEMENTS NOT IN THE MAGNETIC GROUP
      N = 1
      ISIG = 1
      IPTAB(1,MGAT) = 1
      TPTAB(1,MGAT) = 0
      DO NO = 2, NOPC + 1
! LOGIC MODIFIED PJB/JBF 12 JAN 95
        IF (NO.EQ.NOPC+1) THEN
! JUMP OUT IF NON-CENTRIC OR IF CENTRE IS IN THE MAGNETIC GROUP
          IF (MSTAB(1).LT.0) GOTO 2
          CALL GMREV(XT,XR,3,1)
        ELSE
          IF (ABS(MSTAB(NO)).NE.NO) GOTO 2
          CALL ROTSYM(XT,XR,NO,1)
          IF (MSTAB(NO).LT.0) CALL GMREV(XR,XR,3,1)
          CALL GMADD(XR,TRANS(1,NO),XR,3,1)
        ENDIF
        CALL EQPPOS(XEQ,XR,N,M,24)
        IF (M.GT.N) THEN
          CALL ERRCHK(1,M,NPSI,1,'non-equivalent sublattices for'//ATNAME(IAT))
        ENDIF
        CALL GMSUB(XEQ(1,M),XR,CELLT,3,1)
! Caution this is in radians!
        T = TWOPI*SCALPR(CELLT,PROP)
! Be careful about the sign of T
        IF (NO.EQ.NOPC+1) THEN
          TPTAB(NOPC+1,MGAT) = T
          IF (M.GT.N) THEN
            N = 2*N
            CALL ERRCHK(1,N,NPSI,1,'non-equivalent sublattices for'//ATNAME(IAT))
          ENDIF
! SET IPTAB(NOPC+1) TO GIVE THE OFFSET OF THE SUBLATTICE NUMBERS
! OF THE CENTROSYMMETRIC OPERATORS
          IPTAB(NOPC+1,MGAT) = M - IPTAB(1,MGAT)
        ELSE
          N = M
          DO NNO = 2, NOPC
            IF (MSTAB(NNO).EQ.NO) THEN
              IPTAB(NNO,MGAT) = M
              TPTAB(NNO,MGAT) = T
            ENDIF
          ENDDO
        ENDIF
    2 ENDDO
      NPHI(MGAT) = N
! NOW AMALGAMATE INFORMATION READ WITH THESE RELATIONSHIPS
      DO I = 1, NPSI
! FIND THE OPERATOR NUMBER
        NO = LTPHI(I)
! WAS THE PHASE FOR THIS OPERATOR GIVEN
        IF (NO.NE.0) THEN
          DO J = 1, I - 1
            IF (NO.EQ.LTPHI(J)) THEN
              CALL ERRIN2(NO,-1,'Phase given for sublattice generated by operator',' is redundant')
              GOTO 10
            ENDIF
          ENDDO
          IPSI = IPTAB(IABS(NO),MGAT)
          IF (NO.LT.0) IPSI = IPSI + IPTAB(NOPC+1,MGAT)
          LPHI(IPSI,MGAT) = NO
          PHIH(IPSI,MGAT) = TPHI(I)
          IPSFIX(IPSI) = IPSI
        ENDIF
   10 ENDDO

      END SUBROUTINE PSICON
!
!*****************************************************************************
!
      SUBROUTINE SETFCM(MAGSET)
!
! *** SETFCM by PJB 31-May-1994 ***
!
!X
!C 17A
!H Calls the routines needed to set up magnetic structure factor
!H calculations (or non-magnetic also).
!A On entry MAGSET is the name of a subroutine to do the specific magnetic
!A                setting up.  MAGSET is therefore DOMAG if actually a
!A magnetic structure, or DUMMY if non-magnetic.
!D Like SETFC it calls:
!D   INPUTN, SYMOP, OPSYM(1), RECIP, ATOPOS, SETFOR and SETANI to set
!D   data in the COMMON blocks /SYMDA/, /SYMTAB/, /NSYM/, /CELLDA/, /ATNAM/,
!D   /POSNS, /FORNAM/, /FORMDA/, possibly /ANSCAT/ and /ANISO/
!D If MAGSET=DOMAG, calls DOMAG(1) to read the magnetic data from "Q"  cards
!D and write the COMMON blocks /MAGDAT/, /SATTEL/ and  /SYMMAG/.
!I Causes all the crystallographic and structure cards to be read from
!I the copy of the Crystal Data File on unit IO10.
!O If any of the constituent routines sets the error flag IERR in /CARDRC,
!O prints an error message and stops.
!
      EXTERNAL MAGSET
      INTEGER         ICRYDA, NTOTAL,    NYZ, NTOTL, INREA,       ICDN,       IERR, IO10
      LOGICAL                                                                             SDREAD
      COMMON /CARDRC/ ICRYDA, NTOTAL(9), NYZ, NTOTL, INREA(26,9), ICDN(26,9), IERR, IO10, SDREAD
      DIMENSION INREAD(26), ICDNO(26)
      EQUIVALENCE (INREAD(1),INREA(1,1))
      EQUIVALENCE (ICDNO(1),ICDN(1,1))
      INTEGER         LPT, LUNI
      COMMON /IOUNIT/ LPT, LUNI
      COMMON /REFINE/ IREF, NCYC, NCYC1, LASTCY, ICYC, MODERR(5),       &
     &                MODEOB(5), IPRNT(20), MAXCOR, IONLY(9), SIMUL,    &
     &                MAG, MPL, FIXED, DONE, CONV
      LOGICAL SIMUL, MAG, MPL, FIXED, DONE
      EQUIVALENCE (MODER,MODERR(1))

      INTEGER         IBMBER
      COMMON /CCSLER/ IBMBER

      CALL INPUTN(LPT)
      CALL SYMOP
      IF (IBMBER .NE. 0) RETURN
      CALL OPSYM(1)
      CALL RECIP
      IF (IBMBER .NE. 0) RETURN
      CALL ATOPOS
! TO BE RESET IF MULTIPOLE ROUTINES ARE USED:
      MPL = .FALSE.
! TO BE RESET IF MAGSET ACTUALLY=DOMAG:
      MAG = .FALSE.
      CALL MAGSET(1)
      CALL SETFOR
      CALL SETANI
      IF (IERR.NE.0) CALL ERRMES(1,0,'in SETFCM')

      END SUBROUTINE SETFCM
!
!*****************************************************************************
!
      SUBROUTINE SPHELI(IM,MODE)

      USE ATMVAR
!
! *** SPHELI updated by PJB 30-May-95 ***
!
!X
!C 17B
!H Imposes perpendicularity on the two components of a helix.
!A On entry IM labels the magnetic atom in question
!A MODE = 0  For the setting up entry
!A MODE = 1  First least squares entry
!A MODE = 2  On entries after least squares cycles
!
      DIMENSION C(4), KK(4), PERP(3)
      LOGICAL TESTOV
      COMMON /ATNAM / ATNAME(MaxAtm_3), ATNA(MaxAtm_3,9)
      CHARACTER*4 ATNA, ATNAME
      COMMON /MAGDAT/ NMAG, MAGAT(MaxAtm_3), JMAGAT(10), NMFORM(10),         &
     &                ANGM(4,10), KANGM(4,10), SMOD(2,10), KSMOD(2,10), &
     &                PHIH(4,10), KPHIH(4,10), LPHI(4,10), NPHI(10),    &
     &                TPTAB(25,10), IPTAB(25,10), SPIND(3,3,2,10), KOM19
      DATA NPSI/4/
!
      IF (MODE.LT.2) THEN
! CHECK PERPENDICULARITY
        TEST = SCALPR(SPIND(1,1,1,IM),SPIND(1,1,2,IM))
        IF (ABS(TEST).GT..0005) THEN
          CALL ERRRE2(TEST,-1,'Axes of '//ATNAME(JMAGAT(IM))            &
     &                //' helix not perpendicular:'//                   &
     &                ' scalar product =',' ')
! FORCE SECOND AXIS TO BE PERPENDICULAR TO FIRST
          CALL VECPRD(SPIND(1,1,1,IM),SPIND(1,1,2,IM),PERP)
          CALL UNIVEC(PERP,D)
          CALL VECPRD(PERP,SPIND(1,1,1,IM),SPIND(1,1,2,IM))
          ANGM(3,IM) = DEGREE(ACOS(SPIND(3,1,2,IM)))
          ANGM(4,IM) = DEGREE(ATAN2(SPIND(2,1,2,IM),SPIND(1,1,2,IM)))
        ENDIF
      ENDIF
      IF (MODE.GT.0) THEN
! CALCULATE THE COEFFICIENTS C(N) OF THE PERPENDICULARITY CONSTRAINT
        N = 0
        M = 0
        DO II = 1, 2
          JJ = II + 1
          IF (JJ.GT.2) JJ = 1
          DO J = 2, 3
            N = N + 1
            CC = 0
!  GET THE PARAMETER SPECS
            DO I = 1, 3
              CC = CC + SPIND(I,1,JJ,IM)*SPIND(I,J,II,IM)
            ENDDO
            IF (TESTOV(1.,CC)) GOTO 1
            M = M + 1
            C(M) = CC
            KK(M) = KPAK(2,IM,12+NPSI+N,1,1)
    1     ENDDO
        ENDDO
        IF (M.LE.1) GOTO 100
! SCALED SHIFTS MUST ADD TO ZERO
        C(1) = -C(1)
!  ADD NEW OR REPLACE THE EXISTING CONSTRAINT
        IF (MODE.EQ.1) THEN
          CALL ADDCON(M,KK,C,4)
        ELSE
          CALL RELCON(M,KK,C,4)
        ENDIF
      ENDIF
  100 RETURN
      END SUBROUTINE SPHELI
!
!*****************************************************************************
!
      SUBROUTINE SPHPOL(ANG1,ANG2,SD,MODE)
!
! *** SPHPOL by PJB 24 Jan 89 ***
!
!X
!C 17A
!H Sets up spherical polar spin directions for magnetic structures.
!A On entry ANG1 holds the first spherical polar angle (with Z) in degrees
!A          ANG2 holds the second spherical polar angle (with X) in degrees
!A          MODE is 1 if the 3 directions alone are wanted,
!A                  3 if the derivative directions are also wanted.
!
!A On exit  SD always holds in its first 3 elements the components of the
!A             spin direction on the X, Y, Z (standard orthogonal) axes.
!A             If MODE=3 it also holds elements for the LSQ derivatives in
!A             columns 2 and 3.
!
      DIMENSION SD(3,MODE)

      SA1 = SIN(RADIAN(ANG1))
      SA2 = SIN(RADIAN(ANG2))
      CA1 = COS(RADIAN(ANG1))
      CA2 = COS(RADIAN(ANG2))
      SD(1,1) = SA1*CA2
      SD(2,1) = SA1*SA2
      SD(3,1) = CA1
!  AND THE DIFFERENTIALS
      IF (MODE.EQ.3) THEN
        SD(1,2) = RADIAN(CA1*CA2)
        SD(2,2) = RADIAN(CA1*SA2)
        SD(3,2) = RADIAN(-SA1)
        SD(1,3) = RADIAN(-SA1*SA2)
        SD(2,3) = RADIAN(SA1*CA2)
        SD(3,3) = 0.
      ENDIF

      END SUBROUTINE SPHPOL


      SUBROUTINE PHO_REGFLA(Jm1,Jm2,Iflr1,Iflr2,Irej)
C**********************************************************************
C
C     selection of reggeon flavours
C
C     input:    JM1,JM2      position index of mother hadrons
C
C     output:   IFLR1,IFLR2  valence flavours according to
C                            PDG conventions and JM1,JM2
C               IREJ         0  reggeon possible
C                            1  reggeon impossible
C
C**********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION DEPS , e1 , EPS
      INTEGER ifla1 , ifla2 , iflb1 , iflb2 , Iflr1 , Iflr2 , Irej ,
     &        iter , Jm1 , Jm2
      SAVE

      PARAMETER (EPS=0.1D0,DEPS=1.D-15)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INCLUDE 'inc/pohdfl'

C  standard particle data interface

      INCLUDE 'inc/poevt1'
C  extension to standard particle data interface (PHOJET specific)
      INCLUDE 'inc/poevt2'

      IF ( Jm1.GT.0 ) THEN
         Irej = 0
         iter = 0
C  available energy
         e1 = SQRT((PHEp(4,Jm1)+PHEp(4,Jm2))
     &        **2-(PHEp(1,Jm1)+PHEp(1,Jm2))**2-(PHEp(2,Jm1)+PHEp(2,Jm2))
     &        **2-(PHEp(3,Jm1)+PHEp(3,Jm2))**2)/2.D0
 50      iter = iter + 1
         IF ( iter.GT.50 ) THEN
            Irej = 1
C  debug output
            IF ( LPRi.GT.4 .AND. IDEb(41).GE.2 )
     &            WRITE (LO,'(/1X,A,2I7,1P,E12.4)')
     &            'PHO_REGFLA: rejection, no reggeon found for' ,
     &           IDHep(Jm1) , IDHep(Jm2) , e1
            RETURN
         END IF

         CALL PHO_VALFLA(Jm1,ifla1,ifla2,e1,e1)
         CALL PHO_VALFLA(Jm2,iflb1,iflb2,e1,e1)
         IF ( ifla1.EQ.-iflb1 ) THEN
            Iflr1 = ifla2
            Iflr2 = iflb2
         ELSE IF ( ifla1.EQ.-iflb2 ) THEN
            Iflr1 = ifla2
            Iflr2 = iflb1
         ELSE IF ( ifla2.EQ.-iflb1 ) THEN
            Iflr1 = ifla1
            Iflr2 = iflb2
         ELSE IF ( ifla2.EQ.-iflb2 ) THEN
            Iflr1 = ifla1
            Iflr2 = iflb1
         ELSE
C  debug output
            IF ( LPRi.GT.4 .AND. IDEb(41).GE.25 )
     &            WRITE (LO,'(/1X,A,3I4)')
     &            'PHO_REGFLA: int.rejection JM1,JM2,ITRY' , Jm1 , Jm2 ,
     &           iter
            GOTO 50
         END IF
C  debug output
         IF ( LPRi.GT.4 .AND. IDEb(41).GE.10 )
     &         WRITE (LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
     &         'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS' , Jm1 , Jm2 ,
     &        IDHep(Jm1) , IDHep(Jm2) , Iflr1 , Iflr2 , e1
      ELSE IF ( Jm1.EQ.-1 ) THEN
C  initialization
      ELSE IF ( Jm1.NE.-2 ) THEN
C  output of statistics
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I10)')
     &         'PHO_REGFLA: invalid mother particle (JM1)' , Jm1
         CALL PHO_ABORT
      END IF

      END SUBROUTINE


      subroutine szlz (ispin, ecv, nph, nat, rgrd, nohole, rfms2, lfms2,
     2           lmaxph, edens, edenvl, dmag, vtot, vvalgs, rmt, rnrm,
     2           ixc, rhoint, vint, xmu, jumprm,
     3           xnval, iorb, x0, dx, xion, iunf, iz,
     5           adgc, adpc, dgc, dpc, ihole, rat, iphat, corr)

c     Finds new Fermi level (xmu), electron counts

      implicit double precision (a-h, o-z)
      include '../HEADERS/dim.h'
      include '../HEADERS/const.h'
      integer ispin

c     input
      dimension dmagx(nrptx), dmag(251,0:nphx+1)
      dimension vtot (251,0:nphx), vvalgs (251,0:nphx)
      dimension rmt(0:nphx),rnrm(0:nphx)
      dimension xnval (30,0:nphx), iorb (-4:3,0:nphx)
      dimension ri(nrptx)
      dimension iz(0:nphx), xion(0:nphx), lmaxph(0:nphx)
      dimension rat(3,natx),iphat(natx)
      real  rfms, rfms2
c     input and output
      dimension edens(251,0:nphx), edenvl(251,0:nphx)

c     work space
      dimension xnmues(3,0:lx,0:nphx)
      complex*16 fl(3,0:lx,0:nphx), fr(3,0:lx,0:nphx)
      complex gtr(2,2, 3,0:lx, 0:nphx)
      real amat(-lx:lx,2,2, 3,0:lx), gctr(2,2, 3,0:lx,0:nphx)
      dimension dum(nrptx), vtotph(nrptx),vvalph(nrptx)
      dimension dgc(251,30,0:nphx+1), dpc(251,30,0:nphx+1)
      dimension adgc(10,30,0:nphx+1), adpc(10,30,0:nphx+1)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      complex*16 xrhoce(-4:3, -4:3, 0:nphx), xrhole(-4:3, -4:3, 0:nphx)
      complex*16 ph(lx+1, 0:nphx)
      integer iph
c     complex energy grid emg is decomposed into em and eref
      parameter (negx = 80)
      complex*16 emg(negx), em, eref, ee, ep, cchi, de
c     nflrx should be odd and defines the max of Im energy for
c     the countour
      parameter (nflrx = 17)
      dimension step(nflrx)
      character*512 slog

      call setkap(ihole, kinit, linit)

      if (ispin.eq.0) then
        write (slog,8)
   8    format('              N_l, N_j- and N_j+ calculation')
        write (slog,9)
   9    format('              ONLY central atom contribution! ')
      elseif (abs(ispin).le.1) then
        write (slog,10)
  10    format('              S_z, L_z and t_z calculation')
      else
        write (slog,11)
  11    format('              S_z, N_l and N_j calculation')
      endif
      call wlog(slog)

      call wlog (' Calculating energy and space dependent l-DOS.')
      call wlog (' It takes time ...')

c     calculate energy independent matrix of angular coefficients
      call acoef(ispin, amat)

      call grids (ecv, xmu, negx, neg, emg, step, nflrx)

c     ie - is number of energy points calculated
      ie = 0
      ee = emg(1)
      ep = dble(ee)
      do 22 iph=0,nphx
      do 22 il=0,lx
      do 22 i=1,3
        xnmues(i, il,iph) = 0
  22  continue

c     Start the cycle over energy points (ie)
  25  continue
      ie = ie + 1

      if (ie.eq.1 .or. mod(ie,20).eq.0) then
         write(slog,30) ie, dble(ee)*hart
   30    format('     point # ', i3, '  energy = ', f7.3)
         call wlog(slog)
      endif

      do 100  iph = 0, nph

         call fixvar (rmt(iph),edens(1,iph),vtot(1,iph),dmag(1,iph),
     1                vint, rhoint, dx, rgrd, jumprm,
     2                vjump, ri, vtotph, dum, dmagx)
         if (mod(ixc,10) .ge.5) then
            if (jumprm .gt. 0) jumprm = 2
            call fixvar (rmt(iph), edenvl(1,iph), vvalgs(1,iph),
     1                dmag(1,iph), vint, rhoint, dx, rgrd , jumprm,
     2                vjump, ri, vvalph, dum, dmagx)
            if (jumprm .gt. 0) jumprm = 1
         endif

         call fixdsx (iph, dx, rgrd , dgc, dpc, dgcn, dpcn)
        jri = int((log(rmt(iph)) + x0) / rgrd) + 2
        jri1 = jri+1
        eref = vtotph(jri1)
        do 40 i = 1, jri1
  40    vtotph(i) = vtotph(i) - eref
        if (ixc.ge.5) then
           do 50 i = 1, jri1
  50       vvalph(i) = vvalph(i) - eref
        else
           do 60 i = 1, jri1
  60       vvalph(i) = vtotph(i)
        endif

         itmp = 0
c        icount=1 for Renormalized atom counts
c        icount=2 for Mulliken counts
         icount = 0
         if (iph.eq.0 .and. nohole.lt.0) itmp = ihole
         if (icount.gt.0) then
            call rholat( icount, rgrd, x0, ri, ee,
     2           ixc, rmt(iph), rnrm(iph),
     3           vtotph, vvalph, xnval(1,iph), iorb(-4,iph),
     3           dgcn, dpcn, eref,
     4           adgc(1,1,iph), adpc(1,1,iph), xrhole(-4,-4,iph),
     5           xrhoce(-4,-4,iph), ph(1,iph),
     6           iz(iph), xion(iph), iunf, itmp,3)
         else
            call rholsz( rgrd, x0, ri, ee,
     2           ixc, rmt(iph), rnrm(iph),
     3           vtotph, vvalph, xnval(1,iph), dgcn, dpcn, eref,
     4           adgc(1,1,iph), adpc(1,1,iph), xrhole(-4,-4,iph),
     5           xrhoce(-4,-4,iph), ph(1,iph),
     6           iz(iph), xion(iph), iunf, itmp,3)
         endif
  100 continue

c     Write out phases for fmssz
c     transform neg,emg to em,ne,eref first
      em= dble(ee)
      eref=dble(eref)-coni*dimag(ee)

cc    call fms for a cluster around central atom
      do 195 iph0 = 0,nph
      do 195 il = 0, lx
      do 195 i = 1, 3
      do 195 i2= 1, 2
      do 195 i1= 1, 2
         gtr( i1,i2, i, il, iph0) = 0
         gctr(i1,i2, i, il, iph0) = 0
  195 continue

      rfms = 0
c     only central atom contribution for ispin = 0
ctemp if (ispin.ne.0)  rfms = rfms2
      rfms = rfms2

      if (lfms2 .ne. 0) then
        iph0 = 0
        call fmssz( iph0, ie,  em, eref, ph, nph,
     1        rfms, lfms2, nat, iphat, rat, amat, lmaxph, gctr, gtr)
      else
        do 190 iph0 = 0, nph
  190   call fmssz( iph0,  ie, em, eref, ph, nph,
     1        rfms, lfms2, nat, iphat, rat, amat, lmaxph, gctr, gtr)
      endif

      de = ee-ep
      do 300 iph = 0,nph
      do 300 lpp = 0,lx
      do 300 iop = 1,3
c       calculate density and integrated number of electrons in each
c       channel for each type of atoms density, etc.
        if (ie.gt.1) fl(iop,lpp,iph) = fr( iop,lpp,iph)
        fr( iop,lpp,iph) = 0
        call kfromi (1, lpp, j1, kk1)
        call kfromi (2, lpp, j1, kk2)
        do 200 i1=1,2
        do 200 i2=1,2
          call kfromi (i1, lpp, j1, k1)
          call kfromi (i2, lpp, j1, k2)
          if (k1.eq.0 .or. k2.eq.0) goto 200

          cchi =  dble( real( gtr(i1,i2, iop,lpp,iph) )) +
     1           coni* dble(aimag( gtr(i1,i2, iop,lpp,iph) ))
c         fr( iop,lpp,iph) = fr( iop,lpp,iph) + cchi * xrhole(k1,k2,iph)
c         use above kk1,kk1 for j- value, kk2,kk2 for j+ value
          if (ispin.ne.0 .or. iop.eq.1) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph) + cchi*xrhole(k1,k2,iph)
          elseif(iop.eq.2) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph)+cchi*xrhole(kk1,kk1,iph)
          elseif(iop.eq.3) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph)+cchi*xrhole(kk2,kk2,iph)
          endif

c         add central atom part
          cchi =  dble(  gctr(i1,i2, iop,lpp,iph) )
          if (ispin.ne.0 .or. iop.eq.1) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph) + cchi*xrhoce(k1,k2,iph)
c           use above k1,k1 for j- value, k2,k2 for j+ value
          elseif(iop.eq.2) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph)+cchi*xrhoce(kk1,kk1,iph)
          elseif(iop.eq.3) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph)+cchi*xrhoce(kk2,kk2,iph)
          endif
 200    continue

c       do integral over energy with trapezoidal rule
        if (ie.eq.1)  fl( iop,lpp,iph) = fr( iop,lpp,iph)
        xnmues(iop,lpp,iph) =  xnmues(iop,lpp,iph) +
     1  dimag((fl(iop,lpp,iph) + fr(iop,lpp,iph)) * de /2)
        if (ie.eq.neg) then
c          end point correction
           xnmues(iop,lpp,iph) =  xnmues(iop,lpp,iph) +
     1     dimag( fr(iop,lpp,iph) * (dble(ee)-ee) )
        endif

  300 continue

c     next energy point
      if (ie.lt.neg) then
         ep = ee
         ee = emg(ie+1)
         goto 25
      endif

c     report configuration; repeat iteration if found bad counts.
      call wlog('  Electronic configuration')
      call wlog('  Electronic configuration:Mulliken counts')
      if (ispin.eq.0) then
         call wlog('   iph    il      N_l   N_j-  N_j+')
      elseif (abs(ispin).eq.1) then
         call wlog('   iph    il      S_z   L_z   T_z')
      else
         call wlog('   iph    il      S_z   N_l   N_j')
      endif
 310  format (2i6, 3f9.4)
      do 320 ip= 0,nph
      do 320 il = 0,lx
         write (slog,310) ip,il,(xnmues(i,il,ip), i=1,3)
         call wlog(slog)
 320  continue
      corr = 1.d0
      if (ispin.eq.0 .and. kinit.ne.-1) then
c       calculation  changes in counts due to spin-orbit interaction
        ip = 2
        if (kinit.lt.0) ip = 3
        il = linit + 1
        if (linit.eq.3) il = linit - 1
        corr = xnmues(1,il,0) /xnmues (ip,il, 0)
      endif

      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     setsto3: Define GTO expansion values for 3 gaussians for EHT basis
!
!     part of QMDFF
!
subroutine setsto3(nprim,n,l,zeta,expo,cont)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
dimension expo(*),cont(*)
dimension ALLC(3,5,3),ALLZ(3,5,3)
integer::iam,nprim
real(kind=8)::DEX(-1:96)

nprim=3

PI=4.D0*ATAN(1.D0)
DO I=-1,10
   DEX(I)=DEX2(I)
ENDDO
!     1s: first three: alpha, second three d
ALLZ(1,1,1) =2.227660584D00
ALLZ(2,1,1) =4.057711562D-01
ALLZ(2,1,1) =4.057711562D-01
ALLZ(3,1,1) =1.098175104D-01
ALLC(1,1,1) =1.543289673D-01
ALLC(2,1,1) =5.353281423D-01
ALLC(3,1,1) =4.446345422D-01
!     2s
ALLZ(1,2,1) =2.581578398D00
ALLZ(2,2,1) =1.567622104D-01
ALLZ(3,2,1) =6.018332272D-02
ALLC(1,2,1) =-5.994474934D-02
ALLC(2,2,1) =5.960385398D-01
ALLC(3,2,1) =4.581786291D-01
!     2p
ALLZ(1,2,2) =9.192379002D-01
ALLZ(2,2,2) =2.359194503D-01
ALLZ(3,2,2) =8.009805746D-02
ALLC(1,2,2) =1.623948553D-01
ALLC(2,2,2) =5.661708862D-01
ALLC(3,2,2) =4.223071752D-01
!     3s
ALLZ(1,3,1) =5.641487709D-01
ALLZ(2,3,1) =6.924421391D-02
ALLZ(3,3,1) =3.269529097D-02
ALLC(1,3,1) =-1.782577972D-01
ALLC(2,3,1) =8.612761663D-01
ALLC(3,3,1) =2.261841969D-01
!     3p
ALLZ(1,3,2) =2.692880368D00
ALLZ(2,3,2) =1.489359592D-01
ALLZ(3,3,2) =5.739585040D-02
ALLC(1,3,2) =-1.061945788D-02
ALLC(2,3,2) =5.218564264D-01
ALLC(3,3,2) =5.450015143D-01
!     4s
ALLZ(1,4,1) =2.267938753D-01
ALLZ(2,4,1) =4.448178019D-02
ALLZ(3,4,1) =2.195294664D-02
ALLC(1,4,1) =-3.349048323D-01
ALLC(2,4,1) =1.056744667D00
ALLC(3,4,1) =1.256661680D-01
!     4p
ALLZ(1,4,2) =4.859692220D-01
ALLZ(2,4,2) =7.430216918D-02
ALLZ(3,4,2) =3.653340923D-02
ALLC(1,4,2) =-6.147823411D-02
ALLC(2,4,2) =6.604172234D-01
ALLC(3,4,2) =3.932639495D-01
!     5s
ALLZ(1,5,1) =1.080198458D-01
ALLZ(2,5,1) =4.408119382D-02
ALLZ(3,5,1) =2.610811810D-02
ALLC(1,5,1) =-6.617401158D-01
ALLC(2,5,1) =7.467595004D-01
ALLC(3,5,1) =7.146490945D-01
!     5p
ALLZ(1,5,2) =2.127482317D-01
ALLZ(2,5,2) =4.729648620D-02
ALLZ(3,5,2) =2.604865324D-02
ALLC(1,5,2) =-1.389529695D-01
ALLC(2,5,2) =8.076691064D-01
ALLC(3,5,2) =2.726029342D-01
!     3d
ALLZ(1,3,3) =5.229112225D-1
ALLZ(2,3,3) =1.639595876D-1
ALLZ(3,3,3) =6.386630021D-2
ALLC(1,3,3) =1.686596060D-1
ALLC(2,3,3) =5.847984817D-1
ALLC(3,3,3) =4.056779520D-1
!     4d
ALLZ(1,4,3) =1.777717219D-1
ALLZ(2,4,3) =8.040647350D-2
ALLZ(3,4,3) =3.949855551D-2
ALLC(1,4,3) =2.308552718D-1
ALLC(2,4,3) =6.042409177D-1
ALLC(3,4,3) =2.595768926D-1
!     5d
ALLZ(1,5,3) =4.913352950D-1
ALLZ(2,5,3) =7.329090601D-2
ALLZ(3,5,3) =3.594209290D-2
ALLC(1,5,3) =-2.010175008D-2
ALLC(2,5,3) =5.899370608D-1
ALLC(3,5,3) =4.658445960D-1

iam=l-1
!
!     set parameters into functional expression
!
DO J=1,nprim
   cont(J)=ALLC(J,N,L)
   expo(J)=ALLZ(J,N,L)*zeta**2
   XNORM=(2.D0*EXPO(J)/PI)**0.75D0*(4.D0*EXPO(J))**(IAM/2.D0)/ &
     &  SQRT(DEX(2*IAM-1))
   cont(j)=cont(j)*xnorm
ENDDO

end subroutine setsto3


#include "../defines.inc"
!--------------------------------------------------------------
!
!     subroutine mc_cylinder
!
!     Determine if moved beads intersect old beads.
!     Written by Quinn MacPherson, Dec 2017
!--------------------------------------------------------------
subroutine mc_cylinder(collide, IB1, IB2, IT1, IT2, MCTYPE, forward)
! values from wlcsim_data
   use params, only: wlc_R_period, wlc_R, wlc_bin, wlc_RP

   use params, only: dp, wlcsim_params
   use binning, only: binType, find_neighbors, countBeads
   use polydispersity, only: is_right_end, rightmost_from

   implicit none
   integer, intent(in) :: IB1               ! Test bead position 1
   integer, intent(in) :: IT1               ! Index of test bead 1
   integer, intent(in) :: IB2               ! Test bead position 2
   integer, intent(in) :: IT2               ! Index of test bead 2
   integer, intent(in) :: MCTYPE            ! MC move type
   logical, intent(in) :: forward           ! direction of reptation move
   logical, intent(out) :: collide   ! Change in ECOM
   logical cylinders ! function for collision checking

   integer, parameter  :: maxNeighbors = WLC_P__NT ! equal length of lists
   integer nNeighbors !number of neighbors found (so far)
   integer neighbors(maxNeighbors) ! list of bead ID's
   real(dp) distances(maxNeighbors) ! list of |r-r| values
   integer II, jj
   real(dp) radius
   real(dp) R_11(3), R_12(3), R_21(3), R_22(3), new_origin(3), R_test(3), R_test2(3)
   integer ix, iy, iz
   integer left, right
   integer leftExclude, rightExclude
   radius = 1.0_dp*WLC_P__CHAIN_D + 2.2_dp*WLC_P__L0

! slide move moves all beads from IT1-IT2
! crank shaft donesn't translate IT2 and IT2
! pivot translates one bead but not the other
! all segments will be kept track of by the bead at their left end
! left = bead to left that doesn't move
! right = right most bead that does move
! left/right-exclude don't check collision with this range of beads
   if (MCTYPE == 4 .or. MCTYPE == 7 .or. MCTYPE == 8 .or. MCTYPE == 9) then
      collide = .FALSE.
      return
   elseif (MCTYPE == 1 .or. MCTYPE == 3) then ! Crank-shaft or pivot
      if (IT1 == IT2) then
         collide = .FALSE. ! Bead only rotated
         return
      endif
      left = IT1
      right = IT2 - 1
      if (IB1 == 1) then
         leftExclude = left
      else
         leftExclude = left - 1
      endif
      if (is_right_end(IT2)) then
         rightExclude = right
      else
         rightExclude = right + 1
      endif
   elseif (MCTYPE == 2) then ! Slide
      if (IB1 == 1) then
         left = IT1
      else
         left = IT1 - 1
         wlc_RP(:, IT1 - 1) = wlc_R(:, IT1 - 1) ! need to extend RP
      endif
      if (IB1 <= 2) then
         leftExclude = left
      else
         leftExclude = left - 1
      endif

      if (IB2 == WLC_P__NB) then
         right = IT2 - 1
      else
         right = IT2
         wlc_RP(:, IT2 + 1) = wlc_R(:, IT2 + 1) ! need to extend RP
      endif
      if (IB2 >= rightmost_from(IT2) - 1) then
         rightExclude = right
      else
         rightExclude = right + 1
      endif
   elseif (MCTYPE == 5 .or. MCTYPE == 6) then ! Full chain move
      left = IT1
      right = IT2 - 1
      leftExclude = left
      rightExclude = right
   elseif (MCTYPE == 10 .or. MCTYPE == 11) then ! reptation or super rep.
      if (forward) then
         left = IT2 - 1
      else
         left = IT1
      endif
      leftExclude = left ! Only exclude self
      rightExclude = left
      right = left
   else
      print *, "cylinder collision not set up for this movetype ", MCTYPE
      stop
   endif

   print *, "Not working!"
   print *, "the excluded region is wrong"
   print *, "beads from within the region can hit eachother on slide"
   print *, "need to correctly choose between R and RP"
   print *, "perhapse only exclude one to either side of each bead"
   print *, "rather then findneighbors for beads that are moved just use brute force for them"
   print *, "may need to create a has_moved logical vector"
   print *, "Make sure you replace NB with polydispersity"
   stop

   do ii = left, right
      nNeighbors = 0 ! Clear list of neighbors

      if (WLC_P__CONFINETYPE == 'excludedShpereInPeriodic') then
         R_test(1) = modulo(wlc_RP(1, II), WLC_P__LBOX_X)
         R_test(2) = modulo(wlc_RP(2, II), WLC_P__LBOX_Y)
         R_test(3) = modulo(wlc_RP(3, II), WLC_P__LBOX_Z)
         ! Loop over current an nearest periods to check for neighbors
         do ix = -1, 1
            if (ix == -1 .and. R_test(1) > radius) cycle
            if (ix == 1 .and. R_test(1) < WLC_P__LBOX_X - radius) cycle
            do iy = -1, 1
               if (iy == -1 .and. R_test(2) > radius) cycle
               if (iy == 1 .and. R_test(2) < WLC_P__LBOX_Y - radius) cycle
               do iz = -1, 1
                  if (iz == -1 .and. R_test(3) > radius) cycle
                  if (iz == 1 .and. R_test(3) < WLC_P__LBOX_Y - radius) cycle
                  R_test2(1) = R_test(1) + (real(ix, dp)*WLC_P__LBOX_X)
                  R_test2(2) = R_test(2) + (real(iy, dp)*WLC_P__LBOX_Y)
                  R_test2(3) = R_test(3) + (real(iz, dp)*WLC_P__LBOX_Z)
                  call find_neighbors(wlc_bin, R_test2, radius, wlc_R_period, &
                                      WLC_P__NT, maxNeighbors, neighbors, distances, nNeighbors)

               enddo
            enddo
         enddo
      else
         print *, "you need to decide whether to use R or R_period"
         print *, "make sure you use the same in other files that call binning functions"
         stop
      endif

      if (WLC_P__CONFINETYPE == 'excludedShpereInPeriodic') then
         !Put one end of one segment at the center of the repeating box
         !The other end translated from the first
         new_origin(1) = wlc_RP(1, ii) - WLC_P__LBOX_X/2.0_DP
         new_origin(2) = wlc_RP(2, ii) - WLC_P__LBOX_Y/2.0_DP
         new_origin(3) = wlc_RP(3, ii) - WLC_P__LBOX_Z/2.0_DP
         R_11(1) = modulo(wlc_RP(1, ii), new_origin(1))
         R_11(2) = modulo(wlc_RP(2, ii), new_origin(2))
         R_11(3) = modulo(wlc_RP(3, ii), new_origin(3))
         R_12 = R_11 + wlc_RP(:, ii + 1) - wlc_RP(:, ii)
      endif
      do jj = 1, nNeighbors
         ! Exclude self interactions
         if (neighbors(jj) >= leftExclude .and. neighbors(jj) <= rightExclude) cycle

         if (WLC_P__RING) then
            print *, "Warning, cyclinders not working for ring"
         endif

         if (WLC_P__CONFINETYPE == 'excludedShpereInPeriodic') then
            if (neighbors(jj) == WLC_P__NT) cycle ! no cylinder comming out of last bead

            !Choose one end of the other segment that is in the same repeat
            !Translate to get the other end (which may be in a different repeat
            !This methode only works if segments are <1/4 of box size
            R_21(1) = modulo(wlc_R(1, neighbors(jj)), new_origin(1))
            R_21(2) = modulo(wlc_R(2, neighbors(jj)), new_origin(2))
            R_21(3) = modulo(wlc_R(3, neighbors(jj)), new_origin(3))
            R_22 = R_21 + wlc_R(:, neighbors(jj) + 1) - wlc_R(:, neighbors(jj))

            collide = cylinders(R_11, R_12, R_21, R_22)
         elseif (WLC_P__CONFINETYPE == 'none') then
            collide = cylinders(wlc_RP(:, ii), wlc_RP(:, ii + 1), &
                                wlc_R(:, neighbors(jj)), &
                                wlc_R(:, neighbors(jj) + 1))
         else
            print *, "you need to decide whether to use R or R_period"
            stop
         endif
         if (collide) return
      enddo
   enddo
   collide = .FALSE.
   RETURN
END

!---------------------------------------------------------------*