#!/usr/bin/perl

#use strict;

# Initial setup of global variables

# read config file to know where atat directory is
my $atatdir;
BEGIN {
    if(defined $ENV{"atatdir"}) #BIOVIA addition
	{
		$atatdir = $ENV{"atatdir"}; #BIOVIA addition
	}
	else
	{
		open(my $cf,"<",join('/',$ENV{"HOME"},".atat.rc")) or die "Can't open ~/.atat.rc\n";
		$atatdir = <$cf>;
		chomp $atatdir;
		$atatdir =~ s/.*atatdir\s*=\s*//g;
	}
    our $libdir = join('',$atatdir,"/src");
}

# load libraries from atat/src/

use lib $libdir;

use Permutor;
use PowerSet;
use PowerSet 'powerset';

#process command line

my %cmdline; #this will contained all command line options, hashed by the option name (e.g. -l, etc.)
for (my $i=0; $i<@ARGV; $i++) {
    my @opt = split /=/, $ARGV[$i];
    if ( @opt == 1 ) {$opt[1]=1}
    $cmdline{$opt[0]}=$opt[1];
}

# end of global var setup
# go the "Main" section below

#subroutine to setup a directory of the SQS database (-mk option)
sub makemanysqs() {
    if (! -e "sqsgen.in") {# if input file does not exist create a template for user to edit
	print qq{
Please create a sqsgen.in file of the form (for example):
level=0	a=1		b=1		[...]
level=1	a=1		b=0.5,0.5	[...] 
level=1	a=0.5,0.5 	b=1		[...]
level=2	a=0.5,0.5	b=0.5,0.5	[...]
[...]
where a,b,... would the wyckoff positions for each site (append a number if two different sites have the same letter)
and where the concentration could have more than two values (e.g. 0.33333,0.33333,0.33333).
You will still need to run mcsqs in each subdirectory created that has fractional occupation.
};
        print join("","See ",$atatdir,"/","data/sqsdb/"," for examples.");
        exit;
    }
    open(my $fh,"<","sqsgen.in") or die "Unable to open gensqs.in"; # to read sqs compositions, one per line
    while (<$fh>) {
	chomp;
	my $dirname=$_; # will contain sqs directory name
	my @cols = split /\s+/, $_ ; # split by whitespace separated columns
	my @levs = split /=/, $cols[0]; # sqs level is in 1st column
	my %siteocc; #will contain concentrations for each site, hashed by site wyckoff name
	for (my $i=1; $i<@cols; $i++) { # loop over sites (i.e. columns 2,3,...) to get concentrations
	    my @rawsite = split /=/, $cols[$i]; # split site=concentration_list
	    my $atom="A"; # atom labels start at A
	    my @allconc = split /,/, $rawsite[1]; # parse coma-separated concentrations
	    @allconc = reverse sort @allconc; # sort from highest to lowest concentration
	    $siteocc{$rawsite[0]}=""; # will contain a string of all occupations (concentrations) for current site
	    for (my $at=0; $at<@allconc; $at++) { #loop over concentrations for current site
		my $com="";              # put comas only between items
		if ($at > 0) {$com=",";} #
		$siteocc{$rawsite[0]}=join('',$siteocc{$rawsite[0]},$com,$rawsite[0],"_",$atom,"=",$allconc[$at]); # append site_atom=conc
		$atom++; # A,B,C,...
	    }
	}
	$dirname =~ s/^\s*level/lev/; #cleanup directory name level->lev
	$dirname =~ s/\s+/_/g;        # whitespaces to _
	$dirname =~ s/^/sqsdb_/;      # sqsdb_ prefix
	print $dirname,"\n"; # report directory being made
	mkdir $dirname;
	{
            # open unit cell structure
	    open(my $sf,"<","rndstr.skel") or die "Can't open rndstr.skel (should contain unit cell of structure in ATAT format with lowercase Wyckoff position as atom names)";
	    open(my $of,">",join('/',$dirname,"rndstr.in")); # will contain the input file for mcsqs
	    while (<$sf>) {
		chomp;
		my @cols = split /\s+/, $_ ; # split each line by whitespace-separated columns
		if ( $cols[3] =~ /^[a-z]/ ) { # if line has an atom label in colunm 4
		    print $of $cols[0]," ",$cols[1]," ",$cols[2]," ",$siteocc{$cols[3]},"\n"; # replace wykoff site name with list of all concentrations for site
		}
		else {
		    print $of $_,"\n"  ; #otherwise copy line as is
		}
	    }
	}
    }
    system("cd sqsdb_lev=0_*; cellcvrt -ro < rndstr.in  >| bestsqs.out"); # special case: for end members no need to generate sqs: just copy unit cell
}

#subroutine to copy sqs from database to current directory
sub copysqs {
    my ($sqsdatafolder) = @_; #BIOVIA addition
    #find where to get sqs from (from -l command-line option )
    my $sqsdbdir=join("",$atatdir,"/","data/sqsdb/",$cmdline{"-l"});
    $sqsdbdir = join("",$sqsdatafolder,"/",$cmdline{"-l"}) if(defined $sqsdatafolder); #BIOVIA addition

    #if a master species.in file is given in current directory, read it
    my $masterspecies="";
    {
	if (-e "species.in") {
	    open(my $sh,"<","species.in");
	    $masterspecies=<$sh>;
	    chomp $masterspecies;
	}
    }
    if (exists $cmdline{"-sp"}) {
	$masterspecies=$cmdline{"-sp"};
	if (! -e "species.in") {
	    open(my $sh,">","species.in");
	    print $sh $masterspecies . "\n";
	}
    }

    if (! $masterspecies eq "") {
	print "Using species: ",$masterspecies,"\n";
    }

    #make a string with list of (Wyckoff) sites in sqs, each followed with "=" and master list of species (elements)
    my $specskel;
    {
	open(my $fh,"<",join("",$sqsdbdir,"/sqsgen.in")) or die "can't open sqsgen.in \n";
	$specskel=<$fh>;
	$specskel =~ s/^level[^\s]*[\s]*//g;
	$specskel =~ s/=[0-9.,+-]*/=$masterspecies/g;
    }
    
    #create directory and template species.in file if nonexistant and exit.
    if (!chdir($cmdline{"-l"})) {
	mkdir($cmdline{"-l"});
	chdir($cmdline{"-l"});
	open(my $sf,">","species.in");
	print $sf $specskel;
	print "Edit the file ",$cmdline{"-l"},"/species.in (if needed) and rerun the same command.\n";
	exit;
    }

    #read the species.in file (were now are in the subdirectory given by -l option)
    my @sites; #will contain array of all sites (a site is a sublattice in CALPHAD nomenclature)
    my %spec;  #each entry (hashed by site name from @sites) will contain a reference to an array of the species on each site
    my %perm;  #each entry (hashed by site name from @sites) will point to an object that generates all permutation on species on a site
    {
	my @rawsite ;
	open(my $sf,"<","species.in") or die "can't open species.in";
	@rawsite = split /\s+/, <$sf>;   # the different sites are whitespace separated
	for (my $s=0; $s<@rawsite; $s++) {  # for each site, parse the species
	    my @asitespec = split /=/ , $rawsite[$s] ; #split site=species
	    my $site=$asitespec[0];
	    @sites=(@sites,$site); #grow array of sites
	    $spec{$site} = [ split /,/ , $asitespec[1] ]; #record the array of species for current site
	    $perm{$site} = new List::Permutor @{$spec{$site}}; #make permuter object for current site
	}
    }
    #read the multiplicities from sqsdb of each site and place them in mult.in
    {
        open(my $mh,">","mult.in");
        foreach my $s ( @sites ) { #loop over sites
	    open(my $sh,join('',$sqsdbdir,"/rndstr.skel")); #this file contains all sites (with equivalent sites repeated)
            my $m=0;
	    while (<$sh>) {
		my @cols=split /\s+/, $_;
		if ($cols[3] eq $s) {$m++;} #count number of time site $s appears
	    }
            print $mh $s,"=",$m,"\t";
        }
        print $mh "\n";
    }
    
    #read in the wyckoff sites of the sqs that are equivalent by symmetry (only happens in simple structures, e.g. B2)
    my @equivsite; #this will contain an array of statements of equivalence between wyckoff positions, e.g. a=b,c=b
    {
	if (-e "$sqsdbdir/equiv.in") {
	    open(my $eh,"<","$sqsdbdir/equiv.in");
	    while (<$eh>) {
		chomp;
		push @equivsite,$_; #add new entry to array
	    }
	}
    }

    #read the different sqs in the db
    my @sqslist=(); #this will contain names of all unique sqs
    # this file list all available sqs compositions
    open(my $fh,"<",join("",$sqsdbdir,"/sqsgen.in")) or die "can't open sqsgen.in \n";
    while (<$fh>) { #loop over sqs
	chomp;
	# each line contain sqs level followed by site=compo,compo,... (repeated for each site)
	my $dirdbname=$_; # will contain the sqs directory name to copy form the database
	my @cols = split /\s+/, $_ ; #level and sites are whitespace separated
	my @levs = split /=/, @cols[0]; # split level=number
	if ($levs[1] <= $cmdline{"-lv"}) { # if level is below what specified by -lv command line option
	    my %siteocc; # this will contain references to arrays of the occupations (compositions) for each site, hashed by site name
	    for (my $i=1; $i<@cols; $i++) { # loop over all sites
		my @arawsite = split /=/, @cols[$i]; #split into site name and composition list
		my @allconc = split /,/, @arawsite[1]; #parse composition list and put into array
		@allconc = reverse sort @allconc; # by convention list higher composition first
		$siteocc{@arawsite[0]}=[ @allconc ]; # record all occupations for this site
	    }
	    #cleanup and make directory name
	    $dirdbname =~ s/^\s*level/lev/;
	    $dirdbname =~ s/\s+/_/g;
	    $dirdbname =~ s/^/sqsdb_/;
	    
	    #check if the current sqs does not have too many possible occupations for the given number of species, at each site
	    my $nbok=1;
	    foreach my $site ( @sites ) {
		if ( @{$spec{$site}} < @{$siteocc{$site}}) {$nbok=0; last;}
	    }
	    #if the nb of occupation and species are ok
	    if ($nbok) {
		while (1) { #loop over permutations of the species on each site
		    #        this is needed if the number of species in the database sqs is smaller than the nb of species desired
		    #        example: A,B,C alloy with binary sqs => need sqs for A,B and B,C and A,C
		    #make sqs name in the calculation directory
		    my $sqsname=""; # will contain the name of the sqs calc directory
		    foreach my $site (@sites) {
			my @aspec=$perm{$site}->peek; # get all species for that site in the current permutation order
			my @speclist=();
			for (my $i=0; $i<@{$siteocc{$site}}; $i++) {
			    # add an entry of the form site_specie=occupation
			    @speclist = (@speclist,join('',$site,"_",$aspec[$i],"=",@{$siteocc{$site}}[$i]));
			}
			@speclist = sort @speclist; #put wyckoff sites in alphabetical order
			$sqsname=join(',',$sqsname,join(',',@speclist));
		    }
		    $sqsname =~ s/^,//; # remove extra , in front
		    #sqsname now completed, except for prefix

		    my $onespeconly=1; # flag that will indicate if it is an end member that might reduce to a simpler parent lattice
		    my $onespecname=""; # will contain name of species on simpler parent lattice
		    if (@sites==1) {$onespeconly=0;} # if only one sublattice cannot be equivalent to higher symmetry phase
		    else {
			foreach my $site (@sites) {
			    my @aspec=$perm{$site}->peek; # get all species for that site in the current permutation order
			    # this block checks if the end member reduces to a simpler known parent lattice
			    if (@{$siteocc{$site}}>1) { # only one specie one sublattice?
				$onespeconly=0; #no: cannot be simple lat
			    }
			    else {
				if ( $onespecname eq "" ) {
				    $onespecname=$aspec[0]; # first time around, store specie name on 1st sublattice
				}
				else { # next time around, check if the same specie is on the other sublattices
				    if ( $onespecname ne $aspec[0] ) {$onespeconly=0;} # if not, cannot reduce to simpler lattice
				}
			    }
			}
		    }

		    # now check if that sqs is not equivalent to another one under permutation of equivalent sites
		    my $alreadylisted=0; #flag to indicate the sqs is redundant
		    my $sqspermname=""; #will contain various sqs with sites permuted
		    my $equivpowset = new Data::PowerSet(@equivsite); #we will select arbitrary subsets of site equivalence relations
		    while (my $equivon= $equivpowset->next) { #loop over subset of site equiv relations
			my %mapsite; # will contain how each wyckoff site is mapped onto another
			for my $s (@sites) {$mapsite{$s}=$s;} #initialize identity mapping
			for my $ss (@$equivon) { # loop over equivalences
			    my $a=$ss;
			    $a =~ s/=.*//g; # site a is before =
			    my $b=$ss;
			    $b =~ s/.*=//g; # site b is after =
			   $mapsite{$a}=$b; # record permutation of those sites
			   $mapsite{$b}=$a; 
			}
			$sqspermname=""; # will contain sqs name with permuted sites
			foreach my $oldsite (@sites) { #loop over sites before permutation
			    my $site=$mapsite{$oldsite}; #permuted site name
			    my @aspec=$perm{$site}->peek; #get species for that site
			    my @speclist=(); #construct sqs name as before
			    for (my $i=0; $i<@{$siteocc{$site}}; $i++) {
				@speclist = (@speclist,join('',$oldsite,"_",$aspec[$i],"=",@{$siteocc{$site}}[$i])); #use old site label with occupations of permuted site
			    }
			    @speclist = sort @speclist; # wyckoff sites in alphabet order
			    $sqspermname=join(',',$sqspermname,join(',',@speclist));
			}
			$sqspermname =~ s/^,//;
			#sqspermname now completed
			#print  $sqspermname,"\n";
			if ( grep(/^$sqspermname$/, @sqslist) == 1 ) {$alreadylisted=1; last;} # if permuted site sqs was already in list
		    }
		    #print $alreadylisted,"\n";
		    #print "list=\n",join("\n",@sqslist),"\nend\n";
		    if ( grep(/^$sqsname$/, @sqslist) == 0 ) { #if (unpermuted) sqs is not in list
			push @sqslist,$sqsname; # add to list
			my %subatom; # will contain which to put in which site (hashed by wyckoff_x where x=A,B,C,... the generic atom names in sqs db)
			foreach my $site (@sites) { #loop over sites
			    my @aspec=$perm{$site}->peek; # species for current permutation
			    for (my $atom="A", my $i=0; $i < @{$siteocc{$site}}; $atom++, $i++) {
				$subatom{join("_",$site,$atom)}=$aspec[$i]; #set, e.g., subatom{"b_A"}="Cu"
			    }
			}
			# put prefix and create dir
			$sqsname = "sqs_lev=" . $levs[1] . "_" . $sqsname;
			mkdir($sqsname);
			if ( $alreadylisted == 1 ) { #if equivalent to permuted sqs, write a link to it
			    open(my $lh,">","$sqsname/link");
			    print $lh "sqs_lev=" . $levs[1] . "_" . $sqspermname . "\n";
			}
			else { #otherwise copy all files needed for calc
			    if ( ! -e "$sqsname/str.out" ) { #only do if didn't exist before
				print "Preparing ",$sqsname," directory\n";
				{
				    open(my $sqsf,">",join("",$sqsname,"/str.in")) or die "Can't open str.in\n"; #destination file
				    open(my $dbf,"<",join("",$sqsdbdir,"/",$dirdbname,"/bestsqs.out")) or die "Can't open bestsqs.out file.\n"; #origin file from database
				    while (<$dbf>) { #loop over lines in origin file
					chomp;
					my @cols = split /\s/, $_ ; #split into columns
					if ( $cols[3] =~ /^[a-z]/ ) { #if 4th column contains a site, replace it by the correct atom from subatom
					    print $sqsf $cols[0]," ",$cols[1]," ",$cols[2]," ",$subatom{$cols[3]},"\n";
					}
					else { # otherwise copy as is
					    print $sqsf $_,"\n";
					}
				    }
				}
				# check if structure has higher symmetry after sites are decorated
				my $hisym=0;
				{
				    open(my $osf,join("","cellcvrt -sym < ",$sqsdbdir,"/",$dirdbname,"/bestsqs.out | head -n 1 |"));
				    my $osym=<$osf>;
				    chomp $osym;
				    open(my $fsf,join("","cellcvrt -sym < ",$sqsname,"/str.in |& grep -v Warning | head -n 1 |"));
				    my $fsym=<$fsf>;
				    chomp $fsym;
				    if ( $osym < $fsym ) {
					print "Equivalent to another high-symmetry structure: ",$sqsname,"\n";
					$hisym=1;
				    }
				    #print "sym= ",$osym," ",$fsym," ",$hisym,"\n";
                                }
				if ($hisym) {
				    open(my $bf,">",$sqsname ."/bump");
                                    print $bf "";
				}
				# isotropically stretch str.in so that atoms just touch and put in str.out
				my $cmd=join("","nntouch -l=",$sqsname,"/str.in -r=",$atatdir,"/data/radii.in >| ",$sqsname,"/str.out");
				system($cmd);
				# copy files needed for CVM SRO correction
				{								
				    open(my $latf,">",join("",$sqsname,"/lat.in")) or die "Can't open lat.in\n"; #destination file
				    open(my $dbf,"<",join("",$sqsdbdir,"/",$dirdbname,"/rndstr.in")) or die "Can't open rndstr.in file.\n"; #origin file from database
				    while (<$dbf>) { #loop over lines in original file
					chomp;
					my @cols = split /\s/, $_ ; #split into columns
					if ( $cols[3] =~ /^[a-z]/ ) { #if 4th column contains a site, replace it by the correct atom from subatom
					    $cols[3] =~ s/=[^,]*,/,/g; #remove =concentation pieces
					    $cols[3] =~ s/=[^,]*$//g;
					    my @atomlist=split /,/, $cols[3]; #get line of atoms
					    print $latf $cols[0]," ",$cols[1]," ",$cols[2]," ",join(",",sort(map($subatom{$_},@atomlist))),"\n";
					}
					else { # otherwise copy as is
					    print $latf $_,"\n";
					}
				    }
				}
				if ( -e "$sqsdbdir/$dirdbname/clusters_fit.out" ) { #the clusters needed for fitting ECIs
				    $cmd="cp $sqsdbdir/clusters_fit.out $sqsname/";
				    system($cmd);
				}
				if ( -e "$sqsdbdir/$dirdbname/maxclus.in" ) { #the maximal cluster(s) needed for the CVM
				    $cmd="cp $sqsdbdir/maxclus.in $sqsname/";
				    system($cmd);
				}
				if ($levs[1]==0) {  # for end members also write "endmem" file as a flag
				    open (my $emf,">",join("",$sqsname,"/endmem"));
				    print $emf "";
				}
				if ($onespeconly == 1) { # if this end member can be reduced to a simpler lattice
				    if (open(my $plf,"<",$sqsdbdir . "/" . "parentlat.in")) { #check if this simpler lattice is known in the sqs db
					my $linkto=<$plf>; # read lattice and partial structure name (e.g. FCC_A1/sqs_lev=0_a_)
					chomp $linkto;     
					$linkto = $linkto . $onespecname . "=1"; # add specie name to partial structure name
					open(my $lf,">",$sqsname ."/link"); # write a suitable link file
					print $lf $linkto . "\n";
					print "link to parent lattice: " . $linkto . "\n"; # notify user
				    }
				}
				else { # if not known, then needs to be computed
				    open (my $wf,">",join("",$sqsname,"/wait")); #write "wait" file as a flag to mark as "to be computed"
				    print $wf "";
				}
			    }
			}
		    }
		    # increment to the next permutation of species
		    my $doneperm=1;
		    foreach my $a ( @sites ) { #try to permute one site at the time
			my @set = $perm{$a}->next ;
			if ( $perm{$a}->peek ) {$doneperm=0; last;} #stop as soon as one permutation was possible
			$perm{$a}->reset; #if reach end of permutation, restart at first permutation for that site
		    }
		    if ( $doneperm ) {last;} #if all sites reached their last permutation, we're at the end
		}
	    }
	}
    }
}

#subroutines to simplify the mathematical expression of a linear combination
#utility routine, don't call
sub simplify_lincomb_recur {
    my %prefac;
    if ($_[0] =~ m/^([0-9]*\.?[0-9]|[0-9]+\.?[0-9]*)([eE][-+]?[0-9]+)?$/) {
	$prefac{"1"}=$_[0];
	return %prefac;
    }
    my @allterms = ( @_[0] =~ /([-+]?(?:[^()+-]|(?>[(](?:[^()]*|(?R))*[)]))+)/g );
    foreach my $term (@allterms) {
	my $acc=1.;
	my %curprefac;
	my @allfactors = ( $term =~ /[*]?((?:[^()*]|(?>[(](?:[^()]*|(?R))*[)]))+)/g );
	foreach my $factor (@allfactors) {
	    if ($factor =~ m/^-/) {
		$acc*=-1.;
	    };
	    $factor =~ s/^[+-]//;
	    if ($factor =~ m/^[(].*[)]$/ ) {
		$factor =~ s/^[(]//g;
		$factor =~ s/[)]$//g;
		my %newprefac=simplify_lincomb_recur($factor);
		if (scalar keys %newprefac == 1 && exists $newprefac{"1"}) {
		    $acc*=$newprefac{"1"};
		}
		else {
		    my @kcur=keys %curprefac;
		    if (@kcur == 0) {
			%curprefac=%newprefac;
		    }
		    else {
			my %newcurprefac;
                        foreach $kold (@kcur) {
                            foreach $knew (keys %newprefac) {
                                my $clnkey=($kold eq "1" ? $knew : ($knew eq "1" ? $kold : $kold . "*" . $knew));
                                $newcurprefac{$clnkey}=$curprefac{$kold}*$newprefac{$knew};
                            }
                        }
                        %curprefac=%newcurprefac;
		    }
		}
	    }
	    else {
		if (scalar keys %curprefac == 0) {
		    $curprefac{$factor}=1.;
		}
		else {
		    if (scalar keys %curprefac > 1) {die("too many non constant terms in " . $term);}
		    my @kcur=keys %curprefac;
		    my $cfac=$curprefac{$kcur[0]};
		    %curprefac=();
		    $curprefac{$kcur[0]."*".$factor}=$cfac;
		}
	    }
	}
	if (scalar keys %curprefac == 0) {
	    $curprefac{"1"}=1.;
	}
	foreach my $base (keys %curprefac) {
	    $curprefac{$base}*=$acc;
	}
	foreach my $base (keys %curprefac) {
	    if (! exists $prefac{$base}) {
		$prefac{$base}=$curprefac{$base};
	    }
	    else {
		$prefac{$base}+=$curprefac{$base};
	    }
	}
    }
    return %prefac;
}

# call this one to simplify a linear combination
sub simplify_lincomb {
    my $eqn=@_[0];
    $eqn =~ s/\*\*/\^/g;
    #$eqn =~ s/(([0-9]*\.?[0-9]|[0-9]+\.?[0-9]*)([eE][-+]?[0-9]+)?)/(\1)/g;
    $eqn =~ s/(([0-9]+\.?[0-9]*|[0-9]*\.[0-9]+)([eE][-+]?[0-9]+)?)/(\1)/g;
    $eqn =~ s/[+][-]/-/g;
    $eqn =~ s/[-][-]/+/g;
    $eqn =~ s/[*]-/*(-1)*/g;
    $eqn =~ s/\^-\(/\^\(-/g;
    #print $eqn,"\n";
    my %prefac=simplify_lincomb_recur($eqn);
    my $simpli;
    my $skip=1;
    foreach $term (sort keys %prefac) {
        $simpli=$simpli . ($skip || $prefac{$term}<0 ? "":"+") . $prefac{$term} . ($term eq "1" ? "" : "*" . $term);
	$skip=0;
    }
    $simpli =~ s/\^/\*\*/g;
    $simpli =~ s/[(](([0-9]+\.?[0-9]*|[0-9]*\.[0-9]+)([eE][-+]?[0-9]+)?)[)]/\1/g;
    return $simpli;
}

#subroutine to fit ab initio data, combine with sgte and create tdb file for one phase
sub fittdb() {
    # SECTION 1: read all input files
    my @sites; # will contain names of each Wyckoff site (a site is a sublattice in CALPHAD nomenclature)
    my %spec; # will contain reference to array of possible species sitting on site, for each site (hashed by Wyckoff site)
    {
	my @rawsite ;
	open(my $sf,"<","species.in") or die "Can't open species.in"; #read from species.in for one lattice
	@rawsite = split /\s+/, <$sf>; #sites are whitespace separated
	for (my $s=0; $s<@rawsite; $s++) {
	    my @asitespec = split /=/ , $rawsite[$s] ; # format is site=specie,specie
	    my $site=$asitespec[0]; #first site name
	    @sites=(@sites,$site); #add to list of sites
	    $spec{$site} = [ split /,/ , $asitespec[1] ]; #parse comma separated list of species and record it for that site
	}
    }

    my %mult; #will contain multiplicity of each site per unit cell (hashed by Wyckoff site)
    my $totsite; #will contain total numer of site per unit cell
    {
	open (my $mh,"<","mult.in") or die "can't open mult.in";
	my @cols = split /\s+/ , <$mh>;  #sites are whitespace separated
	foreach my $m (@cols) { #loop over sites
	    my @tok = split /=/, $m; #parse site=mult
	    $mult{$tok[0]}=$tok[1]; # record multiplicity for that site
	    $totsite+=$tok[1]; # increment total number of site
	}
    }
    my @terms; #will contain all types of interaction terms as a 3d array
    # The first index is the type of interaction (i.e. which line of the terms.in file)
    # The second index is the site (as an integer, not a wyckoff symbol)
    # the last index is 0 or 1, with [0] giving the order (1: linear in composition, 2: binary interaction, etc.)
    #                            and [1] giving the level (e.g. order of polynomial in a binary interaction)
    {
	if (! -e "terms.in") { # if terms.in file does not exist, make a default one and output some help
	    open(my $tf,">","terms.in");
	    print $tf join(':',map { "1,0" } @sites) . "\n";
	    print qq{Please edit the file terms.in
Each entry on one line has the form order,level:order,level:...
in which sublattices are separated by :
and where order has the following meaning: 1: linear in composition 2: binary interaction, 3: ternary interaction, etc.
and where level is the maximum value of the additional parameter in a tdb file specifying the order of the polynomial used.
In a binary interaction, level can be 0,1,2,3,...
In a ternary interaction, level can be 0,1
In higher order interaction level can only be 0
(These are limitations of the tdb format.)
};
	    exit;
	}
	open(my $tf,"<","terms.in") or die "Can't open terms.in";
	my $l=0;
        while (<$tf>) {
	    chomp;
	    my @atermraw = split /[:]+/, $_  ; # each site is separated by :
	    @atermraw = ( @atermraw , map { "0,0" } @sites  ); # pad with 0,0 for all sites that the user did not specify
	    my @aterm = map { [ split /,+/ ] } @atermraw ; # split each order,level pair into two array entries
	    $terms[$l]=[ @aterm[0..@sites-1] ]; # cut extraneous 0,0 that were padded and record cleanup terms in $terms for line $l
	    $l++; # next line in file
	}
    }

    my %stablephase; # will contain the stable room temperature phase of each element, hashed by element name
    {
        open(my $sh,"<",$atatdir . "/data/sgte_elements.tdb"); #fetch from atat data directory
        while (<$sh>) {
          chomp;
          my @col=split /\s+/, $_;
          $col[1] =~ s/ELEM_//g;
          $stablephase{$col[1]}=$col[2];
       }
    }

    # SECTION 2: create input file for least squares fit
    my @tdbparam; # will contain all interaction terms of the tdb file, each in the form specie,specie,...:specie,specie,...:...;level
    my $bumpval=5e-3; # energy shift to avoid degeneracies between low symmetry end members and high symmetry ones.
    if ($cmdline{"-bv"} != 0) {
        $bumpval=$cmdline{"-bv"};
    }
    my $largeweight=5; # increased weight for fitting endmembersl
    if ($cmdline{"-ew"} != 0) {
        $largeweight=$cmdline{"-ew"};
    }

    my @propname=("func","energy","svib_ht"); # input files that we will fit
    my @propsuf=("","","*T"); #suffix they need in tdb file
    my @ffrmt=("%s","%.1f","%.4f"); #corresponding output precision
    my $idealgas=8.3144621;
    my @propnum=(1.,1.60217653e-19*6.02214078e23,-$idealgas); #conversion factor from ab initio units to tdb units: eV/atom -> J/mol and k_B -> J/(K mol)
    for my $aprop (@propname) { # loop over properties
	open(my $dh,"ls -d sqs_* |"); # list all sqs directories  - we'll read them from handle dh
	open(my $mh,">","x_" . $aprop . ".in");        # file will contain regressors for least-squared fit
	open(my $eh,">","y_" . $aprop . ".in");        # file will contain dependent variable for least-squared fit
	open(my $wh,">","w_" . $aprop . ".in");        # file will contain the weights for least-squared fit
	open(my $mn,">","strname_" . $aprop . ".out"); # file will contain structures included in fit of this property
	open(my $ch,">","conc_" . $aprop . ".out");    # file will contain overall concentrations of structures included in fit of this property
	my $founddata=0;
	while (<$dh>) { # loop over sqs directories
	    chomp;
	    my $dirname=$_; # get directory name
            my $olddirname=$dirname; # name before redirection
            if ( -e "$dirname/link" ) { # if find a link to another directory, use that directory instead
                 open(my $lh,"<","$dirname/link");
                 print $dirname,"  mapped to ";
                 $dirname=<$lh>;
                 chomp $dirname;
                 if ( ! -e $dirname ) {
                    $dirname = "../" . $dirname;
                 }
                 print $dirname,"\n";
            }
	    my $concname=$_; # start to extract concentrations from sqs name
	    $concname =~ s/sqs_//g; # trim prefixes
	    $concname =~ s/lev=[^_]+_//g;
	    
	    my %conc; # this will contain all concentrations for this sqs (hashed by Wyckoff site and then hashed by species)
	    my %overconc; # this will contain overall concentration for this sqs (hashed by species)
	    foreach my $s (@sites) { #initialize all concentrations to 0
		$conc{$s}={};
		for my $sp ( @{$spec{$s}} ) {
		    ${$conc{$s}}{$sp}=0;
                    $overconc{$sp}=0;
		}
	    }
	    
	    my $badconc=0;
	    my @rawcs=split /,/ , $concname ; # concentrations are coma separated and have the form site_specie=number
	    foreach my $rawc (@rawcs) {
		my @piece=split /=/ , $rawc; # parse so that piece[0]=site_specie and piece[1]=number
		my @lab=split /_/, $piece[0]; # parse so that lab[0]=site and lab[1]=specie
		if (! exists ${$conc{$lab[0]}}{$lab[1]}) {$badconc=1;} #can't find such a composition
		${$conc{$lab[0]}}{$lab[1]}=$piece[1]; #record the site composition
                $overconc{$lab[1]}+=$piece[1]*$mult{$lab[0]}/$totsite; # increment overall composition
	    }
	    if ( ! -e join('',$dirname,"/",$aprop)) { # check if property aprop is available for current sqs
		$badconc=1;
	    }
	    
	    if ($badconc) { # if anything went wrong, skip
		print $dirname," skipped for property " . $aprop . "\n";
	    }
	    else { # otherwise process
		$founddata=1; # we have found at least one data point
		print $dirname,"\n"; # report structure used
		print $mn $dirname,"\n";
		{
		    open(my $es,"<",join('',$dirname,"/str.out")) or die "can't open " . $dirname . "/str.out\n"; #read structure file
		    my $totsitesup=0; # will contain total number of atoms (i.e. site)
		    while (<$es>) { # loop over lines
			my @cols=split /\s+/, $_; # split in columns
			if ( $cols[3] =~ /^[a-zA-Z]/ ) { # if line contain atom label, count it
			    $totsitesup++;
			}
		    }
		    open(my $ef,"<",join('',$dirname,"/",$aprop)); # read property (e.g. energy)
		    my $energy=<$ef>;
                    chomp $energy;
                    # if directory contains file bump, bump energies by bumpval per atom (to avoid degeneracies at end members);
		    if ( -e join('',$olddirname,"/bump") ) {
			if ( $aprop eq "energy" ) { # check for bump in dir before redirection
			    $energy+=$bumpval*$totsitesup;
			}
			elsif ($aprop eq "func" && ( exists $cmdline{"-jf"} || ! -e join('',$dirname,"/energy") ) ) {
			    $energy=($bumpval*$totsitesup) . "+" . $energy;
			}
		    }
		    my $energypercell;
		    if ($aprop eq "func") {
			$energypercell="(" . ($totsite/$totsitesup) . ")*(" . $energy .")";
		    }
		    else {
			$energypercell=($energy*$totsite/$totsitesup); # convert per unit cell
		    }
		    print $eh $energypercell,"\n"; # record property value in dependent variable file for fitting
		    if ( -e ($dirname . "/endmem") || -e ($olddirname . "/endmem") ) {
			print $wh $largeweight,"\n";
		    }
		    else {
			print $wh 1,"\n";
		    }
                    for my $el ( sort keys %overconc ) {print $ch $overconc{$el},"\t";}
                    print $ch "\n";
                    open(my $eo,">",join('',$dirname,"/",$aprop,"_cell")); # record in a *_cell file too
		    print $eo $energypercell,"\n";
		}
		
		@tdbparam=(); # clear thermo database param (from previous interaction calculation )
		my %doneterm; # to keep track of terms already processed
		foreach my $rterm (@terms) { # loop over possible interaction terms
		    #print "rterm="; #
		    #foreach my $tt (@{$rterm}) {print @{$tt}[0],":";} #
		    #print "\n"; #
		    my $perm = new List::Permutor @{$rterm}; # will consider all assignements of terms to sublattices (i.e. sites)
		    while (my @term=$perm->next) { # loop over permutation of terms
			my $hiord=0; # will contain highest level of interaction
                        # sanity checks
			for (my $s=0; $s<@term; $s++) {
			    if ($term[$s][0]==3 && $term[$s][1]>0) { $term[$s][1]=2; } # higher order param for ternaries are indexed by 0,1,2 so 2 is higher limit
                            # check if only one higher order param
			    if ($term[$s][1]>0 && $hiord>0) {die "TDB format only allows one higher order parameter.\n";}
			    if ($term[$s][1]>0) {$hiord=$term[$s][1];}
			}
			my @nterm; # will contain the number of components for each term (1=one component, 2=binary, 3=ternary, etc.) indexed by site number
			my %ordterm; # will contain the level for each interaction, indexed by site (ord=level in this section of the code)
			my $ns=0; # to loop over site number
			my $toohi=0; # flag if interaction involves more components than there are on the site
			foreach my $s (@sites) { # loop over sites
			    $nterm[$ns]=@{$term[$ns]}[0]; #copy nb of component
			    if (@{$term[$ns]}[0]>@{$spec{$s}}) {$toohi=1;} # flag if too many components
			    $ordterm{$s}=@{$term[$ns]}[1]; # copy level of interaction
			    $ns++; # next site
			}
			my $kterm=join('_',@nterm); #create label to check if done
			if (! $toohi==1 && ! exists $doneterm{$kterm}) { # if not flagged and not done
			    $doneterm{$kterm}=1; # mark as done
			    
			    my %powset; # will contain objects to find all subset of a set of species on a site, hashed by site name
			    my $ns=0; # site number
			    foreach my $s (@sites) { # loop over sites
				$powset{$s} = new Data::PowerSet ({min=>$nterm[$ns], max=>$nterm[$ns]}, @{$spec{$s}}); # find all subsets of $nterm[$ns] species
				$ns++; # next site
			    }
			    while (1) { # loop over subsets of species
				for (my $ord=0; $ord<=$hiord; $ord++) { # loop over levels of interactions
				    my $acc=1.; # to accumulate the product of compositions
				    my @atdbparam; # will contain the label of the interaction as specie,specie,...:specie,specie,...:...
				    foreach my $s ( @sites ) { # loop over sites
					my $elem=$powset{$s}->peek; # which species (elements) take part in that interaction
					$atdbparam[@atdbparam]=(@{$elem}==0 ? "*" : join(',',@{$elem})); # add elem,elem,...  at the end of the label or * if no element
					foreach my $e ( @{$elem} ) { # do the product of compositions of all elements $e involved on site $s
					    $acc*=${$conc{$s}}{$e};
					}
                                        # handle higher level interaction
					if (@{$elem}==2 && $ordterm{$s}>0) { # for binary interactions include terms of the form (X_A-X_B)^$ord
					    $acc*=(${$conc{$s}}{@{$elem}[0]}-${$conc{$s}}{@{$elem}[1]})**$ord;
					}
					if (@{$elem}==3 && $ordterm{$s}>0) { # for ternary interactions, use CALPHAD convention
					    my $comp=0;
					    for (my $i=0; $i<3; $i++) { # sum all compositions involved (may be <1 for higher-order systems)
						$comp+=${$conc{$s}}{@{$elem}[$i]}
					    }
					    my $v=${$conc{$s}}{@{$elem}[$ord]}+(1-$comp)/3.; # contribution is X_{A,B or C} + (1-sum composition)/3
					    $acc*=$v; #accumulate product
					}
				    }
				    $tdbparam[@tdbparam]=join('',join(':',@atdbparam),';',$ord); # record interaction name as specie,specie,...:specie,specie,...:...;level
				    print $mh $acc,"\t"; # record regressor for this interaction
				}
                                # find next subset
				my $donepower=1;
				foreach my $s ( @sites ) { # try for each site
				    $powset{$s}->next; # go to next subset for this site
				    if ( $powset{$s}->peek ) {$donepower=0; last;} # if possible, we have found next subset choice
				    $powset{$s}->reset; # if not possible restart at first subset for this site and try next site
				}
				if ( $donepower ) {last;} # if all sites are at their last subset, we are done with exploring interactions
			    }
			}
		    }
		}
		print $mh "\n"; # put next interaction on the next line
            }
	}
        if ($founddata==1) { # if we have some data, do the fit
	    if ( $aprop eq "func" ) {
		system("lsfit -mat -w=w_". $aprop . ".in -x=x_" . $aprop . ".in -colin >| fitmat_${aprop}.in ; sleep 1");
		open(my $yh,"<","y_${aprop}.in");
		my @yfunc=<$yh>;
		chomp @yfunc;
		open(my $ph,">","param_${aprop}.out");
		open(my $mh,"<","fitmat_${aprop}.in") or die ("Unable to open fitmat_${aprop}.in");
		while (<$mh>) {
		    chomp;
		    my @weight=split /\s+/, $_;  # split in columns
		    my $sum="";
		    for (my $i=0; $i<@yfunc; $i++) {
			$sum=$sum . ($i==0 ? "" : "+") . "(" . $weight[$i] . ")*" . $yfunc[$i];
		    }
		    print $ph $sum . "\n";
		}
	    }
	    else {
		system("lsfit -w=w_". $aprop . ".in -x=x_" . $aprop . ".in -y=y_" . $aprop . ".in -colin >| param_" . $aprop . ".out; sleep 1"); # least square fit of parameters in param_[property].out
		# report some quality measures in fit_[property].out
		system("lsfit -w=w_". $aprop . ".in -x=x_" . $aprop . ".in -y=y_" . $aprop . ".in -colin -p -ty -e | sed 's/ /\t/g' >| fit.tmp");
		system("paste conc_" . $aprop . ".out fit.tmp strname_" . $aprop . ".out >| fit_" . $aprop . ".out; rm fit.tmp ; sleep 1");
		#  and cv_[property].out
		system("lsfit -w=w_". $aprop . ".in -x=x_" . $aprop . ".in -y=y_" . $aprop . ".in -colin -cv >| cv_" . $aprop . ".out");
	    }
	}
	else { # if have no data
	    print "Found no data for " . $aprop . "\n";
            # create a param_[propery].out file with as many 0 as there are parameters
	    open(my $ph,">","param_" . $aprop . ".out");
	    print $ph map {"0\n"} @tdbparam;
        }
        if (exists $cmdline{"-jf"}) {
	    last;
        }
    }

    # concatenate (by columns) all the param_[property].out files into allparam.out
    system("paste " . join(' ',map {"param_" . $_ . ".out"} @propname) . " >| allparam.out");

    # SECTION 3: Create tdb file
    {
	my $Tmin="298.15"; # default lowest and highest temperature cutoffs
	my $Tmax="10000";
        if ( exists $cmdline{"-Tu"} ) {
	    $Tmax=$cmdline{"-Tu"};
	}
        if ( exists $cmdline{"-Tl"} ) {
	    $Tmin=$cmdline{"-Tl"};
	}
	my $phase=`pwd`; # create phase name from current directory name without upper directory name
	chomp($phase);
	$phase =~ s/.*\///g;
	
        my @exphase; # will contain which phases should not be loaded from SGTE
        if (-e "../exfromsgte.in") { # this optional file lists the phases to not load from SGTE
            open(my $xh,"<","../exfromsgte.in");
            @exphase=<$xh>;
            chomp(@exphase);
            print "SGTE Phases excluded: ",join(' ',@exphase),"\n";
        }

	my $volden=1; #to nomalize all properties per cell
        my $issgtephase=0; #flag
	if (system(join('',"grep -q \'^PHASE ",$phase," \' ",$atatdir,"/data/sgte_phases.tdb"))==0) { # check if phase is in SGTE database
	    $volden=$totsite; # for sgte phase there is always one atom per cell (even for hcp...)
            $issgtephase=1;
	}
	
	my @endfunc;  # will contain gibb free energy functions for end members in tdb format
	my %elemfunc; # will contain free energy reference shifter (to make elemental free energy match sgte), hashed by REF_phase_element
	my @xsparam;  # will contain excess quantities of mixing terms
        my @ratiocoef=(1,-2,1.5,-0.5);
        my $sroterm="";
        my $coord=0;
        {
          if (open(my $zh,"<",$atatdir . "/data/sqsdb/" . (uc $phase) . "/coord.in")) {
             $coord=<$zh>;
          }
          else {
            print "No SRO included.\n";
          }
        }
        my %paramall;
        {
	  open(my $pf,"<","allparam.out"); # read in fitted numerical parameters
	  foreach my $termord (@tdbparam) { # loop over terms
            my $allp=<$pf>; #read in all parameters for that term
	    chomp $allp;
            $paramall{$termord}=$allp;
          }
        }

	foreach my $termord (@tdbparam) { # loop over terms
	    my $term=$termord; # get term 
	    $term =~ s/;.*//g; # without the level
            my $ord=$termord; # get level
            $ord =~ s/.*;//g; # without the term
	    my $allp=$paramall{$termord}; #fetch all parameters for that term
	    my @p=split /\s+/, $allp; # put white space-separated parameters in array p
	    my $pdb=""; # will contain the function corresponding to that term
            my $needtoaddord2=0;
	    for (my $i=0; $i<@propname; $i++) { # loop over properties (energy, entropy)
		my $coef;
		if ( $propname[$i] eq "func" ) {
		    if (length($p[$i])>0) {
			$coef=simplify_lincomb("(" . ($propnum[$i]/$volden) . ")*(" . $p[$i] .")"); # convert units and normalize per cell
			$pdb=$pdb . ($i==0 ? "" : "+") . $coef . $propsuf[$i]; # make function expression +coef*suffix and append to pdb
		    }
		}
		else {
		    $coef=$p[$i]*$propnum[$i]/$volden; # convert units and normalize per cell
		    $pdb=$pdb . ($coef !=0 || $i==0 ? ($coef >= 0 ? "+" : "") . sprintf($ffrmt[$i],($coef)) . $propsuf[$i] : ""); # make function expression +coef*suffix and append to pdb
		}
                if ( $cmdline{"-sro"}>0 &&  $propname[$i] eq "energy" && $coord != 0 && ($term =~ s/,/,/g)==1 ) {
                   if ($ord==0) {
                     my $Gab;
                     {
                       my @coef2=split /\s+/,$paramall{"$term;2"};
                       $coef2[0]*=$propnum[$i]/$volden;
                       $Gab=abs($coef-$coef2[0])*$cmdline{"-sro"};
                     }
                     my $c=$Gab/($coord*$idealgas);
                     my @tmpsroterm;
                     for (my $s=0; $s<=2; $s+=2) {
                       for (my $n=0; $n<4; $n++) {
                         $tmpsroterm[$s] = $tmpsroterm[$s] . "+" . sprintf($ffrmt[0],(($s-1)*$ratiocoef[$n]*$Gab/2.0)) . ($n==0 ? "" : "*EXP(" . sprintf($ffrmt[0],(-$n*$c)) . "*T**(-1))");
                       }
                       $tmpsroterm[$s] =~ s/\+-/-/g;
                     }
                     $pdb = $pdb . $tmpsroterm[0];
                     $sroterm=$tmpsroterm[2];
                     #if ( ("$term;2" ~~ @tdbparam)==0 ) {
                     if ( ! grep(/^$term;2$/, @tdbparam) ) {
                        $needtoaddord2=1;
                     }
                   }
                   elsif ($ord==2) {
                     $pdb = $pdb . $sroterm;
                   }
                }
	    }
	    if ($term =~ /,/ || $term =~ /\*/) { # if it is an excess term
		push @xsparam,join('',"PARAMETER L(",uc $phase,",",uc $termord,") ",$Tmin," ",$pdb," ; ",$Tmax," N REF888 !"); #create parameter tdb command
                if ($needtoaddord2) {
   		   push @xsparam,join('',"PARAMETER L(",uc $phase,",",uc $term,";2) ",$Tmin," ",$sroterm," ; ",$Tmax," N REF888 !"); #create parameter tdb command
                }
	    }
	    else { # if it is an end member term (no coupling between atoms)
		my @elem=split /:/, $term; #parse species (elements) from : separated list
		my %conc; # will contain overall concentration of each species (not site-specific)
		for (my $n=0; $n<@sites; $n++) { # loop over sites
		    $conc{$elem[$n]}+=$mult{$sites[$n]}/$volden; # add to concentration (accounting for multiplicity of site and per cell normalization)
		}
		my $fname=join('',"ABIN_",$phase,"_",$term); # make function name for ab initio end member data: ABIN_phase_elementlist
		$fname =~ s/://g; # remove : from list
		#print $fname; # DEBUG
		push @endfunc,join('',"FUNCTION ",uc $fname," ",$Tmin," ",$pdb," ; ",$Tmax," N !"); #create function tdb command
		
		my $line=join('',"PARAMETER G(",uc $phase,",",uc $termord,") ",$Tmin," ",uc $fname); # will contain parameter tdb command for current term
                # now shift with reference states (so that elemental free energies match sgte)
		foreach my $e (sort keys %conc) { # loop over species (elements) involved in this term
		    my $elemref=join('',"REF_",uc $phase,"_",uc $e); # create label of reference free energy shifter for element
                    my $curstabphase; # will contain the stable phase used as a shifter
		    my $elemsgte=join('',"SGTE_",uc $phase,"_",uc $e); # create label of sgte free energy for element
                    if (($issgtephase==1 || $cmdline{"-os"}) && ! grep {/^$elemsgte$/} @exphase) { # if (current phase in sgte or -os specified) and not excluded by user
                       $curstabphase=$phase; # use current phase as shifter
                    }
                    else {                                                                         # otherwise
                      if ($issgtephase==1) {print "Exclude SGTE data for: ",$elemsgte,"\n";} # notify sgte not used for current phase
		      $curstabphase=$stablephase{uc $e}; # use instead the stable phase of this element as reference
                    }
                    my $elemabin=join('',"ABIN_",uc $curstabphase,"_",uc $e); # make label for ab initio free energy for reference phase
		    $elemsgte=join('',"SGTE_",uc $curstabphase,"_",uc $e);    # make label for sgte free energy for reference phase
		    $line=join('',$line,"-",$conc{$e},"*",$elemref); # subtract reference free energy shifter for current element weighted by concentration
		    $elemfunc{$elemref}=join('',"FUNCTION ",$elemref, " ",$Tmin," ",$elemabin," - ",$elemsgte," ; ",$Tmax," N !"); # add this element reference free energy shifter to list
		}
		$line=join('',$line," ; ",$Tmax," N REF888 !"); # finish tdb command
		push @xsparam,($line); # record current line to tdb file
	    }
	}
	open(my $tf,">","$phase.tdb"); # now write tdb file for current phase
	my %allelem; # will contain all elements regardless of their sublattice
	map(map($allelem{uc $_}=1,@{$_}),%spec); # make list of all elements involved in this phase
#	print "grep 'TYPE_DEFINITION . GES A_P_D ${phase}' ${atatdir}/data/sgte_freee.tdb | grep -q " . join(" -e ELEM_",("",keys %allelem));
	my $isnotmag=system("grep 'TYPE_DEFINITION . GES A_P_D ${phase}' ${atatdir}/data/sgte_freee.tdb | grep -q " . join(" -e ELEM_",("",keys %allelem)) ) >> 8; # check element magnetic
	print $tf "PHASE ",$phase," %",($isnotmag==1 ? "":substr($phase,0,1))," ",scalar(keys %mult)," "; # write PHASE tdb command with number of sublattice
#	print $tf "PHASE ",$phase," %"," ",scalar(keys %mult)," "; # write PHASE tdb command with number of sublattice
	foreach my $s (@sites) {
	    print $tf $mult{$s}/$volden," "  # output multiplicity per cell of each sublattice
	}
	print $tf " !\n"; # finish tdb command
	print $tf "CONSTITUENT ",$phase," :"; # write CONSTITUENT tdb command for current phase
	foreach my $s (@sites) { # look over sublattices
	    my $frst=1;
	    foreach my $at (@{$spec{$s}}) { # loop of species (elements)
		if (!$frst) {print $tf ",";} # comma separated, except before first element
		$frst=0;
		print $tf uc $at; # list atom
	    }
	    print $tf ":"; # sublattice are : separated
	}
	print $tf "!\n"; # finish tdb command
	print $tf join("\n",@endfunc),"\n"; # output all ab initio free energies for end members
	print $tf join("\n",values %elemfunc),"\n"; # output all end member reference free energy shifters
	print $tf join("\n",@xsparam),"\n"; # output all excess free energy terms
    }
}

# subroutine to combine multiple phases into a single tdb file
sub comb_phases() {
    system('echo \$ File created with sqs2tdb by Axel van de Walle >| tmp.tdb');
    my $mysed=" | grep -v -e '^#' -e '^\$' | sed -e 's/<NL>/\\n/g' -e 's/ELEM_//g' "; # filter to create valid tdb file (eliminate comments expand newlines remove ELEM_)

    open(my $eh,"grep -H '^CONSTITUENT ' */*.tdb | sed -e 's/^[^:]*:[^:]*://g' -e 's/: *!//g' -e 's/[:,]/\\n/g' | sort -u |"); #list all unique elements found in files */*.tdb
    my @allelem=<$eh>; # slurp all lines into array of element names
    chomp @allelem;
    @allelem = map uc,@allelem; # cleanup: no newline and uppercase
    print "Found elements ",join(' ',@allelem),"\n"; # report elements found
    my $togrepe="grep " . join('',(map {"-e \'ELEM_" . $_ . " \' "} @allelem)). $atatdir . "/data/sgte_elements.tdb"; # command to fetch elemental data from sgte database
    system($togrepe . "$mysed >> tmp.tdb"); # copy to our tdb file after cleanup filter

    open(my $ph,"cat */*.tdb | grep SGTE_ | sed 's/.*SGTE_\\([^ ]*_\\)\\([^ _]*\\) .*/\\1ELEM_\\2/g' | sort -u |"); # list all unique phase needing sgte data in */*.tdb
    my @allsgtephase=<$ph>; # slurp all phases into array
    chomp @allsgtephase;
    @allsgtephase = map uc,@allsgtephase; # cleanup: no newline and uppercase
    my $phaselist = join(' ',@allsgtephase); #make phase list to report to user
    $phaselist =~ s/ELEM_//g;
    print "Phases found in SGTE database: ",$phaselist,"\n";
    my $togrepp="grep " . join('',(map {"-e \'" . $_ . " \' "} @allsgtephase)). $atatdir . "/data/sgte_freee.tdb"; # fetch sgte free energy functions for each phase
    #print $togrepp;
    system($togrepp . $mysed . " >> tmp.tdb"); # append to tdb file

    $togrepp =~ s/_ELEM_([^ ]*) /,ELEM_\1/g; # fetch additional sgte type_definition data if any (for magnetic and gas phases)
    $togrepp = $togrepp . " | sed 's/!.*/!/g'"; # remove extra tokens beyond terminating !
    system($togrepp . " | grep TYPE_DEFINITION " . $mysed . " >> tmp.tdb");
    
    #system(\qq{echo " TYPE_DEFINITION % SEQ *!" >> tmp.tdb});  #perhaps needed

    print "Using:\n";
    system("ls -1 */*.tdb"); # report which files are being used
    system("cat */*.tdb >> tmp.tdb"); # catenate all */*.tdb available files

    # fetch additional sgte data, not type_definition, if any (for magnetic and gas phases)
    system($togrepp . " | grep -v TYPE_DEFINITION " . $mysed . " >> tmp.tdb");

    my $bibref=qq{ LIST_OF_REFERENCES
 NUMBER  SOURCE
   REF888 'A. van de Walle, R. Sun, Q.-J. Hong, and S. Kadkhodaei,
          Software tools for high-throughput calphad from
          first-principles data,
          Calphad, 58:70, 2017.
          https://dx.doi.org/10.1016/j.calphad.2017.05.005'
  !
};
    open(my $tf,'>>','tmp.tdb');
    print $tf $bibref;

    my $tdbfile=join('',join('_',@allelem),".tdb"); # make final tdb file name
    if (-e "subref.sed") { # if user-defined substitution rules exist
	system(join('',"sed -f subref.sed tmp.tdb >| ",$tdbfile)); # apply them to file
    }
    else {
	system(join('',"mv tmp.tdb ",$tdbfile)); # otherwise just move
    }
    if ($cmdline{"-oc"}) { # make open calphad compliant if -oc specified
	system("mv " . $tdbfile . " tmp.tdb");
	system(q{grep FUNCTION tmp.tdb | awk 'BEGIN {n=0;} {s=sprintf("s/%s/FUNC%04i/g",$2,n); print length(s)"::"s; n++}' | sort -n -r | sed 's/[0-9]*:://g' > func.sed});
        system(q{cat tmp.tdb | awk '/^ELEMENT/ {printf " ELEMENT %-2s   %-24s %f %f %f !\n",$2,$3,$4,$5,$6;} ! /^ELEMENT/ {print $0;}' | sed -e 's/^PHASE/ PHASE/g' -e 's/^FUNCTION/ FUNCTION/g' -e 's/^CONSTITUENT/    CONSTITUENT/g' | sed -f func.sed |
          awk '{maxlen=77;
          line =$0;
          while (length(line)>maxlen) {
            cut=maxlen;
            while (1) {
              while (index(" -+",substr(line,cut,1)) == 0) {cut--;}
              if(substr(line,cut-1,1)!="E") break;
              cut--;
            }
            print substr(line,1,cut-1);
            line="    " substr(line,cut);
          }
          print line;
          }' > } . $tdbfile);
	system("rm tmp.tdb func.sed");
    }
}

# help
sub print_help() {
    my $version;
    {
	open(my $vh,"grep define.MAPS_VERSION $atatdir/src/version.hh |");
	$version = <$vh>;
	chomp $version;
	$version =~ s/.*\"(.*)\".*/\1/g;
    }
    print "sqs2tdb version " . $version;
    print qq{ by Axel van de Walle and with contributions to the SQS database
        from Ruoshi Sun, Qijun Hong and Sara Kadkhodaei.

Usage: sqs2tdb [options]    where the available options are:
-h   : More help.
-cp  : Copy SQS from the database to the current directory. Must specify:
       -lv=[level]
           level indicates how fine of composition mesh to use (0: only end members, 1: mid points, etc.)
       -l=[lattice]
          Available lattices
};
    system("ls ${atatdir}/data/sqsdb/ | sed 's/^/           /g'");
    print qq{
        Optional: -sp=Element,Element,...  to indicate which elements to consider
                      (otherwise read from species.in if it exists).
-fit : Fit solution model from SQS energies (to be run within the desired lattice directory)
       The -sro option can also be specified (with -fit) to include short-range order effects.
       The -ew=[real] option (default: 5) lets you set the increased weight given to endmembers in the fit.
-tdb : Combine solution models from one or multiple lattices into a single .tdb file.
       add the -oc (Open Calphad) option to generate a more portable tdb file.
-mk  : Generate input file for SQS generation with mcsqs. (Usually not needed - only for experts.)
       To be run in the SQS database directory:
};
    print "       ",join("",$atatdir,"/","data/sqsdb/","[lattice name]\n");
    print qq{Note that -h,-mk,-cp,-fit,-tdb are mutually exclusive.
};
    print qq{

For more information see user guide published in:
  A. van de Walle, R. Sun, Q.-J. Hong, and S. Kadkhodaei.
  Software tools for high-throughput calphad from first-principles data.
  Calphad, 58:70, 2017.
  https://doi.org/10.1016/j.calphad.2017.05.005
(Also, this paper should be cited in any publication resulting from this code's use.)
};
    if ($cmdline{"-h"}) {
	print q{
EXAMPLES

-> A simple session of sqs2tdb could be:

cp ~/atat/example/vasp.wrap .
emacs vasp.wrap   #edit as needed

echo Al,Ni > species.in

sqs2tdb -cp -l=FCC_A1 -lv=1
sqs2tdb -cp -l=FCC_A1 -lv=1

cd FCC_A1
foreachfile wait pwd \; runstruct_vasp

sqs2tdb -fit

Edit the file terms.in to read
1,0
2,0

sqs2tdb -fit

cd ..

(repeat the above for other lattices if necessary)

sqs2tdb -tdb

The file AL_NI.tdb would contain a valid .tdb file.

-> In a more advanced example, the runstruct_vasp command could be replaced
by a job script submission containing the runstruct_vasp command.

-> When there are lattice instabilities, the runstruct_vasp could be replaced by 
robustrelax_vasp -mk  #this is to be run only once (see robustrelax_vasp -h for instructions)
robustrelax_vasp -id

-> If phonons are to be included (for end members) one could do:
foreachfile endmem pwd \; fitfc -si=str_relax.out -ernn=4 -ns=1 -nrr
foreachfile -d 3 wait \; runstruct_vasp -lu -w vaspf.wrap
   where vaspf.wrap contains parameters for a static run to calculate forces.
foreachfile endmem pwd \; fitfc -si=str_relax.out -f -frnn=2
foreachfile endmem pwd \; robustrelax_vasp -vib

sqs2tdb -fit

OPTIONAL input files (to placed in the topmost directory):

    exfromsgte.in : specify which phases should NOT be copied from SGTE database
                    (by default all phases for each relevant element are included,
                    but you may want to use ab initio data for virtual phase).
                    Phases are specified in the form: SGTE_[lattice]_[element]
                    e.g. SGTE_BCC_A2_AL
    subref.sed    : substitution rule (sed command to be applied to final tdb file)

OUTPUT FILES
    In addition to the *.tdb files, there is some diagnostic info available in the files fit_[property].out where property could be 
    energy, svib_ht, etc.

ADVANCED FEATURES
    In each sqs subdirectory created, there may be a file called link that contains the path to
    another directory where energy data can be found. This is useful if another structure is
    known be equivalent by symmetry. This file is created by default for equivalence within a
    given structure type can even find symmetries across structure types.
    You can also create the file yourself and the code will follow your link.

    There may also be a file called bump which indicates that a structure must be moved up in energy by the
    amount specified by the -bv option (or 5e-3 by default) to avoid degeneracy with an equivalent higher symmetry structure.
    This file is created by default (during the -cp step) when the code detects higher symmetry (e.g. a GAMMA_L12 phase with all sites occupied
    with the same type of atom is just FCC). You can delete this file if the higher-symmetry structure is not in your
    set of structures. This file is read during the -fit step.

    In summary, if you see a bump file, ask yourself if you have that structure elsewhere and put an appropriate link file.
    If you don't have that structure elsewhere, you can delete the bump file.
    The code will still work and give the right answer if you don't do this, but it will spend  more computer time.

    During the -fit step, one can specify the -sro option to include a low-order CVM approximation to the short range order.
    One can also specify the weights used to enforce better fit of the end members with the -ew option (a weight of 10 is the default).

    The default lower and upper temperature limits of 298.15K and 10000K can be changed with the -Tl=... and -Tu=... options, respectively.
    
    This code now allows for the input free energies to general CALPHAD-compatible T-dependent functions. To use this feature, place your functions
    in 'func' files and do not specify th 'energy' or 'svib_ht' files
    (or specify the -jf option to force the code to ignore the 'energy' and 'svib_ht' files).
};
    }
}

#Main

#parse one of the 5 main modes in which the code is operating:
if (@ARGV == 0 || $cmdline{"-h"}) {
    print_help();
}
elsif ($cmdline{"-mk"}) {
    makemanysqs();
    print "Directories setup\n";
}
elsif ($cmdline{"-cp"}) {
    my $sqsdatafolder; #BIOVIA addition
    $sqsdatafolder=$cmdline{"-df"} if($cmdline{"-df"}); #BIOVIA addition

	copysqs($sqsdatafolder);
    print "Copied SQSs\n";
}
elsif ($cmdline{"-fit"}) {
    fittdb();
    print "Fit completed\n";
}
elsif ($cmdline{"-tdb"}) {
    comb_phases();
    print "TDB file created\n";
}
else {
    print "Please specify at least one of -mk -cp -fit -tdb or -h for help\n";
}
