/* DomSelfAdaptFWD.c

Forward-in-time simulation of an adaptive alleles with dominance and selfing, with linked neutral fragment.

This is the BATCH version - to be used on cluster machine to produce many simulation replicates at once.

Reps program: Reads in pre-calculated tables and introduces neutral mutations based on them. See README for more information.

Simulation uses routines found with the GNU Scientific Library (GSL)
(http://www.gnu.org/software/gsl/)
Since GSL is distributed under the GNU General Public License
(http://www.gnu.org/copyleft/gpl.html), you must download it
separately from this file.

*/

/* Preprocessor statements */
#include <stdio.h>
#include <stdlib.h>
#include <time.h>
#include <math.h>
#include <stddef.h>
#include <string.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <sys/stat.h>
#include <sys/types.h>

/* Function prototypes */
void Wait();
void fitness(unsigned int N, double h, double s, unsigned int *inpop, double *outfit, double *outcf, double *fitsum);
double sumT_UI(unsigned int *Tin, unsigned int nrow);
unsigned int parchoose(unsigned int N, double *culfit, double *fitsum, const gsl_rng *r);
unsigned int bitswitch(unsigned int x);
void rec_sort(double *index, unsigned int nrow);
void generation(unsigned int N, double self, double R, unsigned int *nums, unsigned int *selin, unsigned int *selout, unsigned int **neutin, unsigned int **neutout, double *culfit, double *fitsum, unsigned int npoly, double *polypos, const gsl_rng *r);
void addpoly(unsigned int N, unsigned int **neutin, double *polyloc, unsigned int *npoly, double theta, unsigned int maxsize, const gsl_rng *r);
void reassign(unsigned int **neutin, unsigned int **neutout, unsigned int *selin, unsigned int *selout, unsigned int npoly, unsigned int N);
void reassign2(unsigned int **neutin, unsigned int **neutout, double *posin, double *posout, unsigned int npoly, unsigned int N);
void polyprint(unsigned int **neutin, double *posin, unsigned int npoly, unsigned int N);
void ptrim(unsigned int size, unsigned int **neutin, unsigned int **neutout, double *posin, double *posout, unsigned int npoly, unsigned int *npolyT, double *avpi);
void mutsamp(unsigned int N, unsigned int samps, unsigned int *selin, double *polypos, unsigned int **neutin, unsigned int *nums2, unsigned int npoly, unsigned int ei, unsigned int rep, const gsl_rng *r);
void popread(unsigned int **neutin, double *posin, unsigned int npoly, unsigned int N, unsigned int ei, unsigned int suffix);

void Wait(){
	printf("Press Enter to Continue");
	while( getchar() != '\n' );
	printf("\n");
}

/* Fitness calculation routine */
void fitness(unsigned int N, double h, double s, unsigned int *inpop, double *outfit, double *outcf, double *fitsum){
	unsigned int i;				/* Pop counter */
	unsigned int ac = 0;		/* Allele copies in indv */

	/* Calculating new fitnesses */
    *fitsum = 0;
	for(i = 0; i < N; i++){
		ac = 0;
		ac = (*(inpop + 2*i)) + (*(inpop + 2*i + 1));
		if(ac == 0){
			*(outfit + i) = 1;
		}else if(ac == 1){
			*(outfit + i) = 1 + h*s;
		}else if(ac == 2){
			*(outfit + i) = 1 + s;
		}
		*fitsum += *(outfit + i);
		*(outcf + i) = *fitsum;
    }
}	/* End of fitness routine */

/* Summing entire table (unsigned int) */
double sumT_UI(unsigned int *Tin, unsigned int nrow){
	unsigned int i;
	double res = 0;
	for(i = 0; i < nrow; i++){
		res += (*(Tin + i));
	}
	return res;
}

/* Parent choosing */
unsigned int parchoose(unsigned int N, double *culfit, double *fitsum, const gsl_rng *r){

	double a;					/* Random number */
	unsigned int done = 0;		/* Signal to determine whether selection complete */
	unsigned int cases = 0;		/* Determines whether one should add up or decrease */
	unsigned int choose1 = 0;	/* Chromosome to be selected */
	unsigned int firstgo = 0;	/* First try at choosing progeny */

	done = 0;
	cases = 0;
	choose1 = 0;
	a = gsl_ran_flat(r,0.0,1.0);
	firstgo = (int)N*a;

	/* Choosing case */
	if (((*(culfit + firstgo)/(*(fitsum))) >= a) && firstgo == 0){
		cases = 3;
	} else if (((*(culfit + firstgo)/(*(fitsum))) >= a) && firstgo != 0){
		cases = 2;
	} else {
		cases = 1;
	}

	switch(cases)
	{
		case 1:
			while(done != 1){
				firstgo++;
				if((*(culfit + firstgo)/(*(fitsum))) >= a){
					choose1 = firstgo;
					done = 1;
				}
			}
			break;
		case 2:
			while(done != 1){
				firstgo--;
				if((*(culfit + firstgo)/(*(fitsum))) < a || firstgo == 0){
					choose1 = (firstgo + 1);
					done = 1;
				}
			}
		break;
		case 3:
			choose1 = 0;
			break;
	}

	return choose1;
}

/* Bit-switching routine */
unsigned int bitswitch(unsigned int x){
	unsigned int ret;
	switch(x)
	{
		case 0:
			ret = 1;
			break;
		case 1:
			ret = 0;
			break;
		default:	/* If none of these cases chosen, exit with error message */
			fprintf(stderr,"Error in bitswitch: input is not 0 or 1.\n");
			exit(1);
            break;
	}
	return ret;
}

/* Sorting rec events after choosing them */
void rec_sort(double *index, unsigned int nrow){
	unsigned int j, i;		/* Sorting indices */
	double temp0;		/* For swapping */

	for(j = 1; j < nrow; j++){
		i = j;
		while( (i > 0) && ( *(index + (i - 1) ) > *(index + i) )){
			/* Swapping entries */
			temp0 = *(index + (i - 1));
			*(index + (i - 1)) =  *(index + (i));
			*(index + (i)) = temp0;
			i--;
		}
	}

}

/* Reproduction routine */
void generation(unsigned int N, double self, double R, unsigned int *nums, unsigned int *selin, unsigned int *selout, unsigned int **neutin, unsigned int **neutout, double *culfit, double *fitsum, unsigned int npoly, double *polypos, const gsl_rng *r){
	unsigned int i, j, k;		/* Pop counter, neutral marker counter, rec event counter */
	unsigned int isself = 0;	/* Is this a selfing reproduction? */
	unsigned int choose1 = 0;	/* Chromosome to be selected */
	unsigned int choose2 = 0;	/* Chromosome to be selected (2nd with outcrossing) */
	unsigned int wc1 = 0;		/* Which chrom (parent 1) */
	unsigned int wc2 = 0;		/* Which chrom (parent 2) */
	unsigned int index1 = 0;	/* Index of chosen sample 1 */
	unsigned int index2 = 0;	/* Index of chosen sample 2 */
	unsigned int nself = 0;		/* Number of selfing events */
	unsigned int selfix = 0;	/* Selfing index */
	unsigned int recix1 = 0;	/* Rec index chr 1 */
	unsigned int recix2 = 0;	/* Rec index chr 2 */
	unsigned int nrec1 = 0;		/* Number rec events chr 1 */
	unsigned int nrec2 = 0;		/* Number rec events chr 2 */

	/* First deciding number of selfing events; creating vector of events + choosing */
	nself = gsl_ran_binomial(r, self, N);
	unsigned int *selfev = calloc(nself,sizeof(unsigned int));
	gsl_ran_choose(r, selfev, nself, nums, N, sizeof(unsigned int));

	for(i = 0; i < N; i++){		/* Regenerating population */

    	/* Choosing first parent, and relevant chromosomes */
		choose1 = parchoose(N, culfit, fitsum, r);
		wc1 = gsl_ran_bernoulli(r,0.5);
		wc2 = gsl_ran_bernoulli(r,0.5);
		index1 = 2*choose1 + wc1;

		/* Copying over selected sites, first checking if selfing occurs */
		isself = 0;
		if(nself != 0){
			if(*(selfev + selfix) == i){
				isself = 1;
				selfix++;
			}
		}
		if(isself == 1){
			index2 = 2*choose1 + wc2;
		}else if(isself == 0){
			choose2 = parchoose(N, culfit, fitsum, r);
			index2 = 2*choose2 + wc2;
		}
		(*(selout + 2*i)) = (*(selin + index1));
		(*(selout + 2*i + 1)) = (*(selin + index2));

		/* Now copying over neutral fragment, accounting for recombination */
		if(R != 0){
			/* Choosing number of recombination events on arms 1, 2 */
			recix1 = 0;
			recix2 = 0;
			nrec1 = gsl_ran_poisson(r,R);
			nrec2 = gsl_ran_poisson(r,R);
			double *recev1 = calloc(nrec1 + 1,sizeof(double));
			double *recev2 = calloc(nrec2 + 1,sizeof(double));
			for(k = 0; k < nrec1; k++){
				*(recev1 + k) = gsl_ran_flat(r,0,1);
			}
			for(k = 0; k < nrec2; k++){
				*(recev2 + k) = gsl_ran_flat(r,0,1);
			}
			*(recev1 + nrec1) = 1.01;
			*(recev2 + nrec2) = 1.01;
			rec_sort(recev1,nrec1 + 1);
			rec_sort(recev2,nrec2 + 1);

			for(j = 0; j < npoly; j++){
				if( (*(polypos + j)) >= *(recev1 + recix1)){
					wc1 = bitswitch(wc1);
					index1 = 2*choose1 + wc1;
					recix1++;
				}
				if( (*(polypos + j)) >= *(recev2 + recix2)){
					wc2 = bitswitch(wc2);
					if(isself == 1){
						index2 = 2*choose1 + wc2;
					}else if(isself == 0){
						index2 = 2*choose2 + wc2;
					}
					recix2++;
				}

				*((*(neutout + 2*i)) + j) = *((*(neutin + index1)) + j);
				*((*(neutout + 2*i + 1)) + j) = *((*(neutin + index2)) + j);

			}

			free(recev1);
			free(recev2);

		}else if (R == 0){
			for(j = 0; j < npoly; j++){
				*((*(neutout + 2*i)) + j) = *((*(neutin + index1)) + j);
				*((*(neutout + 2*i + 1)) + j) = *((*(neutin + index2)) + j);
			}
		}
	}

	free(selfev);

}	/* End of reproduction routine */

/* Adding neutral polymorphism routine */
void addpoly(unsigned int N, unsigned int **neutin, double *polyloc, unsigned int *npoly, double theta, unsigned int maxsize, const gsl_rng *r){
	unsigned int i, j;
	int k;
	unsigned int newpoly = 0;			/* Number of new polymorphisms added */
	unsigned int pchr = 0;				/* Chromosome of appearance */
	unsigned int pfound = 0;			/* Flag to denote if right index found */
	double ploc = 0;					/* Location of polymorphism */
/*	FILE *ofp_poly;				 Pointer for polymorphisms output */

	newpoly = gsl_ran_poisson(r,(0.5*theta));
/*	printf("Add %d new polymorphisms\n",newpoly);*/

	for(j = 0; j < newpoly; j++){
		ploc = gsl_ran_flat(r,0.0,1.0);
/*		printf("ploc is %lf\n",ploc);		*/
		pchr = gsl_rng_uniform_int(r,2*N);
/*		printf("pchr is %d\n",pchr);		*/

		/* Inserting new polymorphism */
		if(*(npoly) == 0){
/*			printf("zero entry here\n");	*/
			*(polyloc + 0) = ploc;
				for(i = 0; i < 2*N; i++){
					*((*(neutin + i)) + 0) = 0;
				}
			*((*(neutin + pchr)) + 0) = 1;
		}else if(*(npoly) > 0){
/*			printf("non-zero entry here\n");		*/
			pfound = 0;
			for(k = (*(npoly) - 1); k >= 0; k--){
/*				printf("k is %d\n",k);*/
				if(*(polyloc + k) > ploc){
/*					printf("is here 1\n");*/
					*(polyloc + k + 1) = *(polyloc + k);
					for(i = 0; i < 2*N; i++){
						*((*(neutin + i)) + k + 1) = *((*(neutin + i)) + k);
					}
				}else if(*(polyloc + k) <= ploc){
/*					printf("is here 2\n");				*/
					pfound = 1;
					*(polyloc + k + 1) = ploc;
					for(i = 0; i < 2*N; i++){
						*((*(neutin + i)) + k + 1) = 0;
					}
					*((*(neutin + pchr)) + k + 1) = 1;
					break;
				}
			}

			if(pfound == 0){		/* In this case polymorphism is inserted at the start */
				*(polyloc + 0) = ploc;
				for(i = 0; i < 2*N; i++){
					*((*(neutin + i)) + 0) = 0;
				}
				*((*(neutin + pchr)) + 0) = 1;
			}

		}

		*(npoly) += 1;
/*		printf("n poly is %d\n",*(npoly));			*/
		if(*(npoly) == maxsize){
			fprintf(stderr,"Too many neutral polymorphisms.\n");
			exit(1);
		}

	}
}

/* Reassigning new population routine */
void reassign(unsigned int **neutin, unsigned int **neutout, unsigned int *selin, unsigned int *selout, unsigned int npoly, unsigned int N){
	unsigned int i, j;		/* pop counter, poly counter */

	for(i = 0; i < 2*N; i++){
		*(selout + i) = *(selin + i);
		for(j = 0; j < npoly; j++){
			*((*(neutout + i)) + j) = *((*(neutin + i)) + j);
		}
	}

}	/* End of reassignment routine */

/* Reassigning new population routine (after trimming) */
void reassign2(unsigned int **neutin, unsigned int **neutout, double *posin, double *posout, unsigned int npoly, unsigned int N){
	unsigned int i, j;		/* pop counter, poly counter */

	for(i = 0; i < 2*N; i++){
		for(j = 0; j < npoly; j++){
			*((*(neutout + i)) + j) = *((*(neutin + i)) + j);
			if(i == 0){
				*(posout + j) = *(posin + j);
			}
		}
	}

}	/* End of reassignment routine */

/* Printing polymorphism routines */
void polyprint(unsigned int **neutin, double *posin, unsigned int npoly, unsigned int N){
	unsigned int i, j;		/* pop counter, poly counter */

	for(j = 0; j < npoly; j++){
		printf("%lf ",*(posin + j));
		for(i = 0; i < 2*N; i++){
			printf("%d ",*((*(neutin + i)) + j));
		}
		printf("\n");
	}
	Wait();

}	/* End of reassignment routine */

/* Cutting out non-polymorphic sites */
void ptrim(unsigned int size, unsigned int **neutin, unsigned int **neutout, double *posin, double *posout, unsigned int npoly, unsigned int *npolyT, double *avpi){
	unsigned int i, j;
	unsigned int newp = 0;		/* New number of polymorphisms */
	unsigned int count = 0;		/* Polymorphism count */
	double cumpi = 0;			/* Cumulative pi (diversity) */

/*	printf("Trimming routine activated\n");	*/
	for(j = 0; j < npoly; j++){
		count = 0;
		*(posout + newp) = *(posin + j);
		for(i = 0; i < size; i++){
			*((*(neutout + i)) + newp) = *((*(neutin + i)) + j);
			count += *((*(neutin + i)) + j);
		}
/*		printf("For poly %d, count is %d\n",j,count);*/
		if((count > 0) && (count < size)){
/*			printf("Keeping poly %d\n",j);	*/
			newp++;
			cumpi += ((count*(size-count))/(1.0*size*size));
/*			printf("Count is %d, freq is %lf, cumulative value is %lf\n",count,count/(1.0*size),cumpi);	*/
		}
	}

	*npolyT = newp;
	*avpi = (cumpi/(1.0*newp));
}

/* Producing mutational samples */
void mutsamp(unsigned int N, unsigned int samps, unsigned int *selin, double *polypos, unsigned int **neutin, unsigned int *nums2, unsigned int npoly, unsigned int ei, unsigned int rep, const gsl_rng *r){

	unsigned int a, j, x;
	unsigned int currsamp;
	unsigned int npolyT;
	double avpi;
	char Mout[32];				 /* String to hold filename in (Mutations) */
	FILE *ofp_mut = NULL;		 /* Pointer for data output */

	for(x = 0; x < rep; x++){

		double *polyposF = calloc(npoly,sizeof(double));						/* Position of neutral mutations (final for polymorphism sampling) */
		unsigned int *selsamp = calloc(samps,sizeof(unsigned int *));			/* State of selected locus after sim stops */
		unsigned int **nsamp = calloc(samps,sizeof(unsigned int *));			/* Table of neutral markers per individual (final for sampling) */
		unsigned int **nsampT = calloc(samps,sizeof(unsigned int *));			/* Table of neutral markers per individual (final for sampling) AFTER TRIMMING */
		for(a = 0; a < samps; a++){
			nsamp[a] = calloc(npoly,sizeof(unsigned int));
			nsampT[a] = calloc(npoly,sizeof(unsigned int));
		}

		npolyT = npoly;

		/* Choosing which haplotypes to sample */
		unsigned int *thesamp = calloc(samps,sizeof(unsigned int));
		gsl_ran_choose(r, thesamp, samps, nums2, 2*N, sizeof(unsigned int));

		for(a = 0; a < samps; a++){
			currsamp = *(thesamp + a);
			*(selsamp + a) = *(selin + currsamp);
			for(j = 0; j < npoly; j++){
				*((*(nsamp + a)) + j) = *((*(neutin + currsamp)) + j);
			}
		}

		/* Check, then include code to ONLY print out polymorphic sites in table? */
		ptrim(samps, nsamp, nsampT, polypos, polyposF, npoly, &npolyT, &avpi);

		/* Printing out sample table */
		sprintf(Mout,"Mutations/Muts_%d.dat",ei*rep + x);
		ofp_mut = fopen(Mout,"w");

		/* State of selected site */
		fprintf(ofp_mut,"0 ");
		for(a = 0; a < samps; a++){
			fprintf(ofp_mut,"%d ",*(selsamp + a));
		}
		fprintf(ofp_mut,"\n");

		for(j = 0; j < npolyT; j++){
			fprintf(ofp_mut,"%lf ",*(polyposF + j));
			for(a = 0; a < samps; a++){
				fprintf(ofp_mut,"%d ",*((*(nsampT + a)) + j));
			}
			fprintf(ofp_mut,"\n");
		}
		fclose(ofp_mut);

		for(a = 0; a < samps; a++){
			free(nsampT[a]);
			free(nsamp[a]);
		}
		free(nsampT);
		free(nsamp);
		free(thesamp);
		free(selsamp);
		free(polyposF);

	}
}

/* Reading population state from file */
void popread(unsigned int **neutin, double *posin, unsigned int npoly, unsigned int N, unsigned int ei, unsigned int suffix){
	unsigned int i, j;		/* pop counter, poly counter */
	char Pin[32];				 /* String to hold filename in (Mutations) */
	FILE *ifp_poly = NULL;		 /* Pointer for data output */

	/* Printing out polymorphism table */
	sprintf(Pin,"Pop_%d.dat",ei + suffix);
	ifp_poly = fopen(Pin,"r");
	for(j = 0; j < npoly; j++){
		/* Is this the right way of reading in the first column of file? */
		for(i = 0; i < (2*N + 1); i++){
			if(i == 0){
				fscanf(ifp_poly,"%lf",&(posin[j]));
			}else if(i > 0){
				fscanf(ifp_poly,"%d",&(neutin[(i-1)][j]));
			}
		}
		fprintf(ifp_poly,"\n");
	}
	fclose(ifp_poly);

}	/* End of population reading routine */

/* Main program */
int main(int argc, char *argv[]){

	/* Declare variables here */
	unsigned int a, i, x;		/* Counters */
	unsigned int N = 0;			/* Population Size */
	unsigned int initp = 0;		/* Initial location of mutant (individual) */
	unsigned int done = 0;		/* Is simulation done or not? */
	unsigned int dcopies = 0;	/* Number of copies of derived allele */
	unsigned int afix = 0;		/* Has allele fixed? */
	unsigned int npoly = 0;		/* Number of neutral alleles */
	unsigned int npolyB = 0;	/* BASELINE number of neutral alleles at simulation initiation */
	unsigned int npolyT = 0;	/* Number of neutral alleles (after cutting out fixed sites) */
	unsigned int nowsel = 0;	/* If derived allele selected for? */
	unsigned int samps = 0;		/* Number of samples to take */
	unsigned int suffix = 0;	/* Number of times to subsample from population */
	unsigned int base = 0;		/* Number of baseline forward-in-time simulations */
	unsigned int rps = 0;		/* Samples taken per baseline simulation */
	unsigned int INITTS = 0;	/* Initial size of mutation array */
/*	unsigned int n = 0;			sprintf counter */
	double s = 0;				/* Strength of selection */
	double h = 0;				/* Dominance level */
	double self = 0;			/* Selfing rate */
	double Rin = 0;				/* Recombination rate (input) */
	double R = 0;				/* Recombination rate (at a time) */
	double x0 = 0;				/* Initial allele frequency */
	double xfix = 0;			/* Final allele frequency (i.e. stop when allele reaches this frequency) */
	double theta = 0;			/* Rate of neutral mutation */
	double fitsum = 0;			/* Summed Fitness */
	double scurr = 0;			/* Current fitness of mutant (to account for initial neutrality) */
	double avpi = 0;
	char Pout[32];				/* String to hold filename in (Mutations) */
	char Sout[32];				/* String to hold filename in (Seed) */
	FILE *ofp_sd;				/* Pointer for seed output */
	FILE *ofp_poly;				/* Pointer for polymorphisms output */

	/* GSL random number definitions */
	const gsl_rng_type * T;
	gsl_rng * r;

	/* Reading in data from command line */
	if(argc != 14){
		fprintf(stderr,"Not enough inputs (need: N s h self R x0 xfix theta basereps reps-per-sim samples suffix npoly).\n");
		exit(1);
	}

	N = atoi(argv[1]);
	if(N <= 0){
		fprintf(stderr,"Total Population size N is zero or negative, not allowed.\n");
		exit(1);
	}

	s = strtod(argv[2],NULL);
	if(s < 0){
		fprintf(stderr,"Allele strength s is negative, not allowed.\n");
		exit(1);
	}

	h = strtod(argv[3],NULL);
	if(h < 0 || h > 1){
		fprintf(stderr,"Dominance value must lie between 0 and 1.\n");
		exit(1);
	}

	self = strtod(argv[4],NULL);
	if(self < 0 || self > 1){
		fprintf(stderr,"Selfing rate must lie between 0 and 1 (inclusive).\n");
		exit(1);
	}

	Rin = strtod(argv[5],NULL);
	if(Rin < 0){
		fprintf(stderr,"Recombination rate must be positive or zero.\n");
		exit(1);
	}
	Rin /= 2.0*N;

	x0 = strtod(argv[6],NULL);
	if(x0 < (1.0/(2.0*N)) || x0 > 1.0-(1.0/(2.0*N)) ){
		fprintf(stderr,"Initial mutant frequency must lie between 1/2N and 1-1/2N.\n");
		exit(1);
	}

	xfix = strtod(argv[7],NULL);
	if(xfix < 0 || xfix > 1.0 ){
		fprintf(stderr,"Final mutant frequency must lie between 0 and 1.\n");
		exit(1);
	}
	if(xfix <= x0){
		fprintf(stderr,"Final mutant frequency must be greater than initial mutant frequency.\n");
		exit(1);
	}

	theta = strtod(argv[8],NULL);
	if(theta <= 0){
		fprintf(stderr,"Mutation rate must be a positive value.\n");
		exit(1);
	}

	base = atoi(argv[9]);
	if(base <= 0){
		fprintf(stderr,"Number of baseline simulations must be greater than zero.\n");
		exit(1);
	}

	rps = atoi(argv[10]);
	if(rps <= 0){
		fprintf(stderr,"Number of reps per simulation must be > 0.\n");
		exit(1);
	}

	samps = atoi(argv[11]);
	if(samps <= 0){
		fprintf(stderr,"Number of samples taken must be > 0.\n");
		exit(1);
	}

	suffix = atoi(argv[12]);
	if(argv[12] < 0){
		fprintf(stderr,"File index must be greater than or equal to zero.\n");
		exit(1);
	}

	npolyB = atoi(argv[13]);
	INITTS = 2*npolyB;

	/* create a generator chosen by the
    environment variable GSL_RNG_TYPE */

    mkdir("SeedsRep/", 0777);
	gsl_rng_env_setup();
	if (!getenv("GSL_RNG_SEED")) gsl_rng_default_seed = time(0);
	T = gsl_rng_default;
	r = gsl_rng_alloc(T);
	sprintf(Sout,"SeedsRep/Seed_%d.dat",suffix);
	ofp_sd = fopen(Sout,"w");
	fprintf(ofp_sd,"%lu\n",gsl_rng_default_seed);
	fclose(ofp_sd);

	mkdir("Polymorphisms/", 0777);
	mkdir("Mutations/", 0777);

	/* Vector of 0 to (N-1) for sampling random numbers */
	unsigned int *nums = calloc(N,sizeof(unsigned int));
	unsigned int *nums2 = calloc(2*N,sizeof(unsigned int));
	for(a = 0; a < 2*N; a++){
		*(nums2 + a) = a;
		if(a < N){
			*(nums + a) = a;
		}
	}

	/* Executing simulation */
	for(i = 0; i < base; i++){

/*		printf("Starting run %d\n",i);*/

		afix = 0;
		R = Rin;
		while(afix != 1){

			/* Setting up selection, neutral tables per individual */
			double *fit = calloc(N,sizeof(double));									/* Fitness of each individual */
			double *cumfit = calloc(N,sizeof(double));								/* Cumulative fitness of each individual */
			double *polypos = calloc(INITTS,sizeof(double));						/* Position of neutral mutations */
			double *polyposF = calloc(INITTS,sizeof(double));						/* Position of neutral mutations (final for polymorphism sampling) */
			unsigned int *selindvP = calloc(2*N,sizeof(unsigned int));				/* Table of derived allele states per individual (parents) */
			unsigned int *selindvO = calloc(2*N,sizeof(unsigned int));				/* Table of derived allele states per individual (offspring) */
			unsigned int **neutindvP = calloc(2*N,sizeof(unsigned int *));			/* Table of neutral markers per individual (parents) */
			unsigned int **neutindvO = calloc(2*N,sizeof(unsigned int *));			/* Table of neutral markers per individual (offspring) */
			unsigned int **neutindvF = calloc(2*N,sizeof(unsigned int *));			/* Table of neutral markers per individual (final for sampling) */
			for(a = 0; a < 2*N; a++){
				neutindvP[a] = calloc(INITTS,sizeof(unsigned int));
				neutindvO[a] = calloc(INITTS,sizeof(unsigned int));
				neutindvF[a] = calloc(INITTS,sizeof(unsigned int));
			}

			/* Reassigning ancestral polymorphism state */
			npoly = npolyB;
			popread(neutindvP, polypos, npoly, N, i, suffix);
/*
			polyprint(neutindvP, polypos, npoly, N);
			exit(1);
*/
			/* Assigning initial mutant, calculating fitness */
			initp = gsl_rng_uniform_int(r,2*N);
			*(selindvP + initp) = 1;

			if(x0 == 1.0/(2.0*N)){
				scurr = s;
				nowsel = 1;
			}else if(x0 > 1.0/(2.0*N)){
				scurr = 0;
				nowsel = 0;
			}
	/*		printf("scurr is %lf\n",scurr);	*/
			fitness(N, h, scurr, selindvP, fit, cumfit, &fitsum);

			done = 0;
			while(done != 1){

				/* Generating new population */
				generation(N,self,R,nums,selindvP,selindvO,neutindvP,neutindvO,cumfit,&fitsum,npoly,polypos,r);

				/* Neutral Mutation phase */
				addpoly(N, neutindvO, polypos, &npoly, theta, INITTS, r);

				/* Reassigning matrices */
				reassign(neutindvO, neutindvP, selindvO, selindvP, npoly, N);

				/* Garbage collection of non-polymorphic sites */
				ptrim(2*N, neutindvP, neutindvF, polypos, polyposF, npoly, &npolyT,&avpi);
				npoly = npolyT;
				reassign2(neutindvF, neutindvP, polyposF, polypos, npoly, N);

				/* Checking derived allele copies and whether it has fixed or lost */
				dcopies = sumT_UI(selindvP, 2.0*N);
				/*
				printf("Dcopies are %d\n",dcopies);
				printf("copies are %d, npoly are %d\n",dcopies,npoly);
				*/
				if(dcopies == 0){
					done = 1;
/*					printf("Selected allele lost\n");*/
				}
				if(dcopies >= (int)(2.0*N*xfix)){
					done = 1;
					afix = 1;
				}

				/* Deciding if derived allele becomes selected for, then updating fitness */
				if(((dcopies/(2.0*N)) >= x0) && nowsel == 0){
					nowsel = 1;
					scurr = s;
/*					printf("scurr is %lf\n",scurr);	*/
				}
				fitness(N, h, scurr, selindvP, fit, cumfit, &fitsum);
			}

			/* Routine to print out polymorphisms if allele fixed */
			if(afix == 1){

				printf("Selected allele fixed\n");

				/* First, remove non-polymorphic sites */
				ptrim(2*N, neutindvP, neutindvF, polypos, polyposF, npoly, &npolyT,&avpi);
				npoly = npolyT;

				/* Printing out polymorphism table */
				sprintf(Pout,"Polymorphisms/Poly_%d.dat",i + suffix);
				ofp_poly = fopen(Pout,"w");

				/* State of selected site */
				fprintf(ofp_poly,"0 ");
				for(x = 0; x < 2*N; x++){
					fprintf(ofp_poly,"%d ",*(selindvP + x));
				}
				fprintf(ofp_poly,"\n");

				/* State of neutral sites */
				for(a = 0; a < npoly; a++){
					fprintf(ofp_poly,"%lf ",*(polyposF + a));
					for(x = 0; x < 2*N; x++){
						fprintf(ofp_poly,"%d ",*((*(neutindvF + x)) + a));
					}
					fprintf(ofp_poly,"\n");
				}
				fclose(ofp_poly);

				/* Then, sample from this table to produce pseudo-coalescent results */
				mutsamp(N, samps, selindvP, polyposF, neutindvF, nums2, npoly, i + suffix, rps, r);

			}

			/* End of run; freeing memory */
			for(a = 0; a < 2*N; a++){
				free(neutindvF[a]);
				free(neutindvO[a]);
				free(neutindvP[a]);
			}
			free(neutindvF);
			free(neutindvO);
			free(neutindvP);
			free(selindvO);
			free(selindvP);
			free(polyposF);
			free(polypos);
			free(cumfit);
			free(fit);
		}

	}

	free(nums2);
	free(nums);
	gsl_rng_free(r);
	return 0;

}	/* End of main program */

/* End of File */


#include <stdio.h>
#include <stdlib.h>
#include <math.h>
#include <string.h>

#include <gsl/gsl_integration.h>
#include <gsl/gsl_interp.h>
#include <gsl/gsl_spline.h>
#include <gsl/gsl_errno.h>

#include "ccl.h"

/*
 * Spline the linear power spectrum for mu-Sigma MG cosmologies.
 * @param cosmo Cosmological parameters
 ^ @param psp The linear power spectrum to spline.
 * @param status, integer indicating the status
 */
void ccl_rescale_musigma_s8(ccl_cosmology* cosmo, ccl_f2d_t *psp,
                            int mg_rescale, int* status) {

  int do_mg = mg_rescale && (fabs(cosmo->params.mu_0) > 1e-14);
  int do_s8 = isfinite(cosmo->params.sigma8) && (!isfinite(cosmo->params.A_s));

  if (!do_mg && !do_s8)
    return;

  size_t na;
  double *aa;
  double rescale_extra_musig = 1;
  double *rescale_factor = NULL;

  if (*status == 0) {
    // Get array of scale factors
    if(psp->fa != NULL) {
      na = psp->fa->size;
      aa = psp->fa->x;
    }
    else if(psp->fka != NULL) {
      na = psp->fka->interp_object.ysize;
      aa = psp->fka->yarr;
    }
    else {
      *status = CCL_ERROR_SPLINE;
      ccl_cosmology_set_status_message(cosmo,
             "ccl_musigma.c: ccl_rescale_musigma_s8(): "
             "input pk2d has no splines.\n");
    }
  }

  // Alloc rescale_factor
  if(*status == 0) {
    rescale_factor = malloc(na * sizeof(double));
    if(rescale_factor == NULL) {
      *status = CCL_ERROR_MEMORY;
      ccl_cosmology_set_status_message(cosmo,
             "ccl_musigma.c: ccl_rescale_musigma_s8(): memory allocation\n");
    }
  }

  // set to 1 by default
  if(*status == 0) {
    for(int i=0; i<na; i++)
      rescale_factor[i]=1;
  }

  // If scale-independent mu / Sigma modified gravity is in use
  // and mu ! = 0 : get the unnormalized growth factor in MG and for
  // corresponding GR case, to rescale CLASS power spectrum
  if(do_mg) {
    // Set up another cosmology which is exactly the same as the
    // current one but with mu_0 and Sigma_0=0, for scaling P(k)

    // Get a list of the three neutrino masses already calculated
    double norm_pk;
    double mnu_list[3] = {0, 0, 0};
    ccl_parameters params_GR;
    params_GR.m_nu = NULL;
    params_GR.z_mgrowth = NULL;
    params_GR.df_mgrowth = NULL;
    ccl_cosmology * cosmo_GR = NULL;

    for (int i=0; i< cosmo->params.N_nu_mass; i=i+1)
      mnu_list[i] = cosmo->params.m_nu[i];

    if (isfinite(cosmo->params.A_s)) {
      norm_pk = cosmo->params.A_s;
    }
    else if (isfinite(cosmo->params.sigma8)) {
      norm_pk = cosmo->params.sigma8;
    }
    else {
      *status = CCL_ERROR_PARAMETERS;
      ccl_cosmology_set_status_message(cosmo,
             "ccl_musigma.c: ccl_rescale_musigma_s8(): "
             "neither A_s nor sigma8 defined.\n");
    }

    if (*status == 0) {
      params_GR = ccl_parameters_create(
        cosmo->params.Omega_c, cosmo->params.Omega_b, cosmo->params.Omega_k,
        cosmo->params.Neff, mnu_list, cosmo->params.N_nu_mass,
        cosmo->params.w0, cosmo->params.wa, cosmo->params.h,
        norm_pk, cosmo->params.n_s,
        cosmo->params.bcm_log10Mc, cosmo->params.bcm_etab,
        cosmo->params.bcm_ks, 0., 0., cosmo->params.nz_mgrowth,
        cosmo->params.z_mgrowth, cosmo->params.df_mgrowth, status);

      if (*status) {
        *status = CCL_ERROR_PARAMETERS;
        ccl_cosmology_set_status_message(cosmo,
               "ccl_musigma.c: ccl_rescale_musigma_s8(): "
               "could not make MG params.\n");
      }
    }

    if (*status == 0) {
      cosmo_GR = ccl_cosmology_create(params_GR, cosmo->config);

      if (cosmo_GR == NULL) {
        *status = CCL_ERROR_MEMORY;
        ccl_cosmology_set_status_message(cosmo,
               "ccl_musigma.c: ccl_rescale_musigma_s8(): "
               "error initializing cosmology\n");
      }
    }

    if (*status == 0) {
      ccl_cosmology_compute_growth(cosmo_GR, status);

      if (*status) {
        *status = CCL_ERROR_PARAMETERS;
        ccl_cosmology_set_status_message(cosmo,
               "ccl_musigma.c: ccl_rescale_musigma_s8(): "
               "could not init GR growth.\n");
      }
    }

    // Populate rescale_factor
    if (*status == 0) {
      for (int i=0; i<na; i++) {
        double D_mu = ccl_growth_factor_unnorm(cosmo, aa[i], status);
        double D_GR = ccl_growth_factor_unnorm(cosmo_GR, aa[i], status);
        double renorm = D_mu/D_GR;
        rescale_factor[i] *= renorm*renorm;
      }
      rescale_extra_musig = rescale_factor[na-1];

      if (*status) {
        *status = CCL_ERROR_PARAMETERS;
        ccl_cosmology_set_status_message(cosmo,
               "ccl_musigma.c: ccl_rescale_musigma_s8(): "
               "could not make MG and GR growth.\n");
      }
    }

    ccl_parameters_free(&params_GR);
    ccl_cosmology_free(cosmo_GR);
  }

  if(do_s8) {
    if (*status == 0) {
      double renorm = cosmo->params.sigma8/ccl_sigma8(cosmo, psp, status);
      renorm *= renorm;
      renorm /= rescale_extra_musig;

      for (int i=0; i<na; i++)
        rescale_factor[i] *= renorm;
    }
  }

  if (*status == 0) {
    size_t nk=0;
    if (psp->fka != NULL)
      nk=psp->fka->interp_object.xsize;

    // Rescale
    for (int i=0; i<na; i++) {
      if (psp->fa != NULL) {
        if(psp->is_log)
          psp->fa->y[i] += log(rescale_factor[i]);
        else
          psp->fa->y[i] *= rescale_factor[i];
      }
      else {
        for(int j=0; j<nk; j++) {
          if(psp->is_log)
            psp->fka->zarr[i*nk+j] += log(rescale_factor[i]);
          else
            psp->fka->zarr[i*nk+j] *= rescale_factor[i];
        }
      }
    }

    //Respline
    if(psp->fa != NULL) {
      gsl_spline *fa = gsl_spline_alloc(gsl_interp_cspline,
                                        psp->fa->size);
      if(fa == NULL) {
        *status = CCL_ERROR_MEMORY;
        ccl_cosmology_set_status_message(cosmo,
                                         "ccl_musigma.c: ccl_rescale_musigma_s8(): "
                                         "memory allocation\n");
      }
      if(*status==0) {
        int spstatus = gsl_spline_init(fa, psp->fa->x,
                                       psp->fa->y, psp->fa->size);
        if(spstatus) {
          *status = CCL_ERROR_MEMORY;
          ccl_cosmology_set_status_message(cosmo,
                                           "ccl_musigma.c: ccl_rescale_musigma_s8(): "
                                           "Error initializing spline\n");
        }
      }
      if(*status==0) {
        gsl_spline_free(psp->fa);
        psp->fa=fa;
      }
    }
    else {
      gsl_spline2d *fka = gsl_spline2d_alloc(gsl_interp2d_bicubic,
                                             psp->fka->interp_object.xsize,
                                             psp->fka->interp_object.ysize);
      if(fka == NULL) {
        *status = CCL_ERROR_MEMORY;
        ccl_cosmology_set_status_message(cosmo,
                                         "ccl_musigma.c: ccl_rescale_musigma_s8(): "
                                         "memory allocation\n");
      }
      if(*status==0) {
        int spstatus = gsl_spline2d_init(fka, psp->fka->xarr,
                                         psp->fka->yarr, psp->fka->zarr,
                                         psp->fka->interp_object.xsize,
                                         psp->fka->interp_object.ysize);
        if(spstatus) {
          *status = CCL_ERROR_MEMORY;
          ccl_cosmology_set_status_message(cosmo,
                                           "ccl_musigma.c: ccl_rescale_musigma_s8(): "
                                           "Error initializing spline\n");
        }
      }
      if(*status==0) {
        gsl_spline2d_free(psp->fka);
        psp->fka=fka;
      }
    }
  }

  free(rescale_factor);
}


/**
 *
 * @file core_zpemv.c
 *
 *  PLASMA core_blas kernel
 *  PLASMA is a software package provided by Univ. of Tennessee,
 *  Univ. of California Berkeley and Univ. of Colorado Denver
 *
 * @version 2.6.0
 * @author Dulceneia Becker
 * @date 2011-06-29
 * @precisions normal z -> c d s
 *
 **/
#include <cblas.h>
#include <lapacke.h>
#include "common.h"

/***************************************************************************//**
 *
 * @ingroup CORE_PLASMA_Complex64_t
 *
 *  CORE_zpemv  performs one of the matrix-vector operations
 *
 *     y = alpha*op( A )*x + beta*y
 *
 *  where  op( A ) is one of
 *
 *     op( A ) = A   or   op( A ) = A**T   or   op( A ) = A**H,
 *
 *  alpha and beta are scalars, x and y are vectors and A is a
 *  pentagonal matrix (see further details).
 *
 *
 *  Arguments
 *  ==========
 *
 * @param[in] storev
 *
 *         @arg PlasmaColumnwise :  array A stored columwise
 *         @arg PlasmaRowwise    :  array A stored rowwise
 *
 * @param[in] trans
 *
 *         @arg PlasmaNoTrans   :  y := alpha*A*x    + beta*y.
 *         @arg PlasmaTrans     :  y := alpha*A**T*x + beta*y.
 *         @arg PlasmaConjTrans :  y := alpha*A**H*x + beta*y.
 *
 * @param[in] M
 *         Number of rows of the matrix A.
 *         M must be at least zero.
 *
 * @param[in] N
 *         Number of columns of the matrix A.
 *         N must be at least zero.
 *
 * @param[in] L
 *         Order of triangle within the matrix A (L specifies the shape
 *         of the matrix A; see further details).
 *
 * @param[in] ALPHA
 *         Scalar alpha.
 *
 * @param[in] A
 *         Array of size LDA-by-N.  On entry, the leading M by N part
 *         of the array A must contain the matrix of coefficients.
 *
 * @param[in] LDA
 *         Leading dimension of array A.
 *
 * @param[in] X
 *         On entry, the incremented array X must contain the vector x.
 *
 * @param[in] INCX
 *         Increment for the elements of X. INCX must not be zero.
 *
 * @param[in] BETA
 *         Scalar beta.
 *
 * @param[in,out] Y
 *         On entry, the incremented array Y must contain the vector y.
 *
 * @param[out] INCY
 *         Increment for the elements of Y. INCY must not be zero.
 *
 * @param[out] WORK
 *         Workspace array of size at least L.
 *
 *  Further Details
 *  ===============
 *
 *               |     N    |
 *            _   ___________   _
 *               |          |
 *     A:        |          |
 *          M-L  |          |
 *               |          |  M
 *            _  |.....     |
 *               \    :     |
 *            L    \  :     |
 *            _      \:_____|  _
 *
 *               |  L | N-L |
 *
 *
 *******************************************************************************
 *
 * @return
 *          \retval PLASMA_SUCCESS successful exit
 *          \retval <0 if -i, the i-th argument had an illegal value
 *
 ******************************************************************************/

#if defined(PLASMA_HAVE_WEAK)
#pragma weak CORE_zpemv = PCORE_zpemv
#define CORE_zpemv PCORE_zpemv
#endif
int CORE_zpemv(PLASMA_enum trans, int storev,
               int M, int N, int L,
               PLASMA_Complex64_t ALPHA,
               const PLASMA_Complex64_t *A, int LDA,
               const PLASMA_Complex64_t *X, int INCX,
               PLASMA_Complex64_t BETA,
               PLASMA_Complex64_t *Y, int INCY,
               PLASMA_Complex64_t *WORK)
{

   /*
    *  y = alpha * op(A) * x + beta * y
    */

    int K;
    static PLASMA_Complex64_t zzero = 0.0;

    /* Check input arguments */
    if ((trans != PlasmaNoTrans) && (trans != PlasmaTrans) && (trans != PlasmaConjTrans)) {
        coreblas_error(1, "Illegal value of trans");
        return -1;
    }
    if ((storev != PlasmaColumnwise) && (storev != PlasmaRowwise)) {
        coreblas_error(2, "Illegal value of storev");
        return -2;
    }
    if (!( ((storev == PlasmaColumnwise) && (trans != PlasmaNoTrans)) ||
           ((storev == PlasmaRowwise) && (trans == PlasmaNoTrans)) )) {
        coreblas_error(2, "Illegal values of trans/storev");
        return -2;
    }
    if (M < 0) {
        coreblas_error(3, "Illegal value of M");
        return -3;
    }
    if (N < 0) {
        coreblas_error(4, "Illegal value of N");
        return -4;
    }
    if (L > min(M ,N)) {
        coreblas_error(5, "Illegal value of L");
        return -5;
    }
    if (LDA < max(1,M)) {
        coreblas_error(8, "Illegal value of LDA");
        return -8;
    }
    if (INCX < 1) {
        coreblas_error(10, "Illegal value of INCX");
        return -10;
    }
    if (INCY < 1) {
        coreblas_error(13, "Illegal value of INCY");
        return -13;
    }

    /* Quick return */
    if ((M == 0) || (N == 0))
        return PLASMA_SUCCESS;
    if ((ALPHA == zzero) && (BETA == zzero))
        return PLASMA_SUCCESS;

    /* If L < 2, there is no triangular part */
    if (L == 1) L = 0;

    /* Columnwise */
    if (storev == PlasmaColumnwise) {
        /*
         *        ______________
         *        |      |     |    A1: A[ 0 ]
         *        |      |     |    A2: A[ M-L ]
         *        |  A1  |     |    A3: A[ (N-L) * LDA ]
         *        |      |     |
         *        |______| A3  |
         *        \      |     |
         *          \ A2 |     |
         *            \  |     |
         *              \|_____|
         *
         */

        /* Columnwise / NoTrans */
        if (trans == PlasmaNoTrans) {
            coreblas_error(1, "The case PlasmaNoTrans / PlasmaColumnwise is not yet implemented");
            return -1;
        }
        /* Columnwise / [Conj]Trans */
        else {

            /* L top rows of y */
            if (L > 0) {

                /* w = A_2' * x_2 */
                cblas_zcopy(
                            L, &X[INCX*(M-L)], INCX, WORK, 1);
                cblas_ztrmv(
                            CblasColMajor, (CBLAS_UPLO)PlasmaUpper,
                            (CBLAS_TRANSPOSE)trans,
                            (CBLAS_DIAG)PlasmaNonUnit,
                            L, &A[M-L], LDA, WORK, 1);

                if (M > L) {

                    /* y_1 = beta * y_1 [ + alpha * A_1 * x_1 ] */
                    cblas_zgemv(
                                CblasColMajor, (CBLAS_TRANSPOSE)trans,
                                M-L, L, CBLAS_SADDR(ALPHA), A, LDA,
                                X, INCX, CBLAS_SADDR(BETA), Y, INCY);

                    /* y_1 = y_1 + alpha * w */
                    cblas_zaxpy(L, CBLAS_SADDR(ALPHA), WORK, 1, Y, INCY);

                } else {

                    /* y_1 = y_1 + alpha * w */
                    if (BETA == zzero) {
                        cblas_zscal(L, CBLAS_SADDR(ALPHA), WORK, 1);
                        cblas_zcopy(L, WORK, 1, Y, INCY);
                    } else {
                        cblas_zscal(L, CBLAS_SADDR(BETA), Y, INCY);
                        cblas_zaxpy(L, CBLAS_SADDR(ALPHA), WORK, 1, Y, INCY);
                    }
                }
            }

            /* N-L bottom rows of Y */
            if (N > L) {
                K = N - L;
                cblas_zgemv(
                            CblasColMajor, (CBLAS_TRANSPOSE)trans,
                            M, K, CBLAS_SADDR(ALPHA), &A[LDA*L], LDA,
                            X, INCX, CBLAS_SADDR(BETA), &Y[INCY*L], INCY);
            }
        }
    }
    /* Rowwise */
    else {
        /*
         * --------------
         * |            | \           A1:  A[ 0 ]
         * |    A1      |   \         A2:  A[ (N-L) * LDA ]
         * |            | A2  \       A3:  A[ L ]
         * |--------------------\
         * |        A3          |
         * ----------------------
         *
         */

        /* Rowwise / NoTrans */
        if (trans == PlasmaNoTrans) {
            /* L top rows of A and y */
            if (L > 0) {

                /* w = A_2 * x_2 */
                cblas_zcopy(
                            L, &X[INCX*(N-L)], INCX, WORK, 1);
                cblas_ztrmv(
                            CblasColMajor, (CBLAS_UPLO)PlasmaLower,
                            (CBLAS_TRANSPOSE)PlasmaNoTrans,
                            (CBLAS_DIAG)PlasmaNonUnit,
                            L, &A[LDA*(N-L)], LDA, WORK, 1);

                if (N > L) {

                    /* y_1 = beta * y_1 [ + alpha * A_1 * x_1 ] */
                    cblas_zgemv(
                                CblasColMajor, (CBLAS_TRANSPOSE)PlasmaNoTrans,
                                L, N-L, CBLAS_SADDR(ALPHA), A, LDA,
                                X, INCX, CBLAS_SADDR(BETA), Y, INCY);

                    /* y_1 = y_1 + alpha * w */
                    cblas_zaxpy(L, CBLAS_SADDR(ALPHA), WORK, 1, Y, INCY);

                } else {

                    /* y_1 = y_1 + alpha * w */
                    if (BETA == zzero) {
                        cblas_zscal(L, CBLAS_SADDR(ALPHA), WORK, 1);
                        cblas_zcopy(L, WORK, 1, Y, INCY);
                    } else {
                        cblas_zscal(L, CBLAS_SADDR(BETA), Y, INCY);
                        cblas_zaxpy(L, CBLAS_SADDR(ALPHA), WORK, 1, Y, INCY);
                    }
                }
            }

            /* M-L bottom rows of Y */
            if (M > L) {
                cblas_zgemv(
                        CblasColMajor, (CBLAS_TRANSPOSE)PlasmaNoTrans,
                        M-L, N, CBLAS_SADDR(ALPHA), &A[L], LDA,
                        X, INCX, CBLAS_SADDR(BETA), &Y[INCY*L], INCY);
            }
        }
        /* Rowwise / [Conj]Trans */
        else {
            coreblas_error(1, "The case Plasma[Conj]Trans / PlasmaRowwise is not yet implemented");
            return -1;
        }
    }

    return PLASMA_SUCCESS;
}


/* specfunc/transport.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 3 of the License, or (at
 * your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

/* Author:  G. Jungman */

#include <config.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_sf_transport.h>

#include "error.h"
#include "check.h"

#include "chebyshev.h"
#include "cheb_eval.c"

static double transport2_data[18] = {
   1.671760446434538503,
  -0.147735359946794490,
   0.148213819946936338e-01,
  -0.14195330326305613e-02,
   0.1306541324415708e-03,
  -0.117155795867579e-04,
   0.10333498445756e-05,
  -0.901911304223e-07,
   0.78177169833e-08,
  -0.6744565684e-09,
   0.579946394e-10,
  -0.49747619e-11,
   0.425961e-12,
  -0.36422e-13,
   0.3111e-14,
  -0.265e-15,
   0.23e-16,
  -0.19e-17
};
static cheb_series transport2_cs = {
  transport2_data,
  17,
  -1, 1,
  9
};

static double transport3_data[18] = {
   0.762012543243872007,
  -0.105674387705058533,
   0.119778084819657810e-01,
  -0.12144015203698307e-02,
   0.1155099769392855e-03,
  -0.105815992124423e-04,
   0.9474663385302e-06,
  -0.836221212858e-07,
   0.73109099278e-08,
  -0.6350594779e-09,
   0.549118282e-10,
  -0.47321395e-11,
   0.4067695e-12,
  -0.348971e-13,
   0.29892e-14,
  -0.256e-15,
   0.219e-16,
  -0.19e-17
};
static cheb_series transport3_cs = {
  transport3_data,
  17,
  -1, 1,
  9
};

static double transport4_data[18] = {
  0.4807570994615110579,
 -0.8175378810321083956e-01,
  0.1002700665975162973e-01,
 -0.10599339359820151e-02,
  0.1034506245030405e-03,
 -0.96442705485899e-05,
  0.8745544408515e-06,
 -0.779321207981e-07,
  0.68649886141e-08,
 -0.5999571076e-09,
  0.521366241e-10,
 -0.45118382e-11,
  0.3892159e-12,
 -0.334936e-13,
  0.28767e-14,
 -0.2467e-15,
  0.211e-16,
 -0.18e-17
};
static cheb_series transport4_cs = {
  transport4_data,
  17,
  -1, 1,
  9
};

static double transport5_data[18] = {
   0.347777777133910789,
  -0.66456988976050428e-01,
   0.8611072656883309e-02,
  -0.9396682223755538e-03,
   0.936324806081513e-04,
  -0.88571319340833e-05,
   0.811914989145e-06,
  -0.72957654233e-07,
   0.646971455e-08,
  -0.568490283e-09,
   0.49625598e-10,
  -0.4310940e-11,
   0.373100e-12,
  -0.32198e-13,
   0.2772e-14,
  -0.238e-15,
   0.21e-16,
  -0.18e-17
};
static cheb_series transport5_cs = {
  transport5_data,
  17,
  -1, 1,
  9
};

static
double
transport_sumexp(const int numexp, const int order, const double t, double x)
{
  double rk = (double)numexp;
  double sumexp = 0.0;
  int k;
  for(k=1; k<=numexp; k++) {
    double sum2 = 1.0;
    double xk  = 1.0/(rk*x);
    double xk1 = 1.0;
    int j;
    for(j=1; j<=order; j++) {
      sum2 = sum2*xk1*xk + 1.0;
      xk1 += 1.0;
    }
    sumexp *= t;
    sumexp += sum2;
    rk -= 1.0;
  }
  return sumexp;
}

/*-*-*-*-*-*-*-*-*-*-*-* Functions with Error Codes *-*-*-*-*-*-*-*-*-*-*-*/

int
gsl_sf_transport_2_e(const double x, gsl_sf_result * result)
{
  const double val_infinity = 3.289868133696452873;

  /* CHECK_POINTER(result) */

  if(x < 0.0) {
    DOMAIN_ERROR(result);
  }
  else if(x < 3.0*GSL_SQRT_DBL_EPSILON) {
    result->val = x;
    result->err = GSL_DBL_EPSILON*fabs(x) + x*x/2.0;
    return GSL_SUCCESS;
  }
  else if(x <= 4.0) {
    double t = (x*x/8.0 - 0.5) - 0.5;
    gsl_sf_result result_c;
    cheb_eval_e(&transport2_cs, t, &result_c);
    result->val  = x * result_c.val;
    result->err  = x * result_c.err;
    result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else if(x < -GSL_LOG_DBL_EPSILON) {
    const int    numexp = (int)((-GSL_LOG_DBL_EPSILON)/x) + 1;
    const double sumexp = transport_sumexp(numexp, 2, exp(-x), x);
    const double t = 2.0 * log(x) - x + log(sumexp);
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val  = val_infinity;
      result->err  = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + fabs(t) * et);
    }
    return GSL_SUCCESS;
  }
  else if(x < 2.0/GSL_DBL_EPSILON) {
    const int    numexp = 1;
    const double sumexp = transport_sumexp(numexp, 2, 1.0, x);
    const double t = 2.0 * log(x) - x + log(sumexp);
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val = val_infinity;
      result->err = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + (fabs(t)+1.0) * et);
    }
    return GSL_SUCCESS;
  }
  else {
    const double t = 2.0 * log(x) - x;
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val = val_infinity;
      result->err = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + (fabs(t)+1.0) * et);
    }
    return GSL_SUCCESS;
  }
}

int
gsl_sf_transport_3_e(const double x, gsl_sf_result * result)
{
  const double val_infinity = 7.212341418957565712;

  /* CHECK_POINTER(result) */

  if(x < 0.0) {
    DOMAIN_ERROR(result);
  }
  else if(x == 0.0) {
    result->val = 0.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else if(x < 3.0*GSL_SQRT_DBL_EPSILON) {
    result->val = 0.5*x*x;
    result->err = 2.0 * GSL_DBL_EPSILON * result->val;
    CHECK_UNDERFLOW(result);
    return GSL_SUCCESS;
  }
  else if(x <= 4.0) {
    const double x2 = x*x;
    const double t = (x2/8.0 - 0.5) - 0.5;
    gsl_sf_result result_c;
    cheb_eval_e(&transport3_cs, t, &result_c);
    result->val  = x2 * result_c.val;
    result->err  = x2 * result_c.err;
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else if(x < -GSL_LOG_DBL_EPSILON) {
    const int    numexp = (int)((-GSL_LOG_DBL_EPSILON)/x) + 1;
    const double sumexp = transport_sumexp(numexp, 3, exp(-x), x);
    const double t = 3.0 * log(x) - x + log(sumexp);
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val = val_infinity;
      result->err = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + fabs(t) * et);
    }
    return GSL_SUCCESS;
  }
  else if(x < 3.0/GSL_DBL_EPSILON) {
    const int    numexp = 1;
    const double sumexp = transport_sumexp(numexp, 3, 1.0, x);
    const double t = 3.0 * log(x) - x + log(sumexp);
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val = val_infinity;
      result->err = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + (fabs(t)+1.0) * et);
    }
    return GSL_SUCCESS;
  }
  else {
    const double t = 3.0 * log(x) - x;
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val = val_infinity;
      result->err = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + (fabs(t)+1.0) * et);
    }
    return GSL_SUCCESS;
  }
}

int
gsl_sf_transport_4_e(const double x, gsl_sf_result * result)
{
  const double val_infinity = 25.97575760906731660;

  /* CHECK_POINTER(result) */

  if(x < 0.0) {
    DOMAIN_ERROR(result);
  }
  else if(x == 0.0) {
    result->val = 0.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else if(x < 3.0*GSL_SQRT_DBL_EPSILON) {
    result->val = x*x*x/3.0;
    result->err = 3.0 * GSL_DBL_EPSILON * result->val;
    CHECK_UNDERFLOW(result);
    return GSL_SUCCESS;
  }
  else if(x <= 4.0) {
    const double x2 = x*x;
    const double t = (x2/8.0 - 0.5) - 0.5;
    gsl_sf_result result_c;
    cheb_eval_e(&transport4_cs, t, &result_c);
    result->val  = x2*x * result_c.val;
    result->err  = x2*x * result_c.err;
    result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else if(x < -GSL_LOG_DBL_EPSILON) {
    const int    numexp = (int)((-GSL_LOG_DBL_EPSILON)/x) + 1;
    const double sumexp = transport_sumexp(numexp, 4, exp(-x), x);
    const double t = 4.0 * log(x) - x + log(sumexp);
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val = val_infinity;
      result->err = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + (fabs(t)+1.0) * et);
    }
    return GSL_SUCCESS;
  }
  else if(x < 3.0/GSL_DBL_EPSILON) {
    const int    numexp = 1;
    const double sumexp = transport_sumexp(numexp, 4, 1.0, x);
    const double t = 4.0 * log(x) - x + log(sumexp);
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val = val_infinity;
      result->err = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + (fabs(t)+1.0) * et);
    }
    return GSL_SUCCESS;
  }
  else {
    const double t = 4.0 * log(x) - x;
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val = val_infinity;
      result->err = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + (fabs(t)+1.0) * et);
    }
    return GSL_SUCCESS;
  }
}

int
gsl_sf_transport_5_e(const double x, gsl_sf_result * result)
{
  const double val_infinity = 124.4313306172043912;

  /* CHECK_POINTER(result) */

  if(x < 0.0) {
    DOMAIN_ERROR(result);
  }
  else if(x == 0.0) {
    result->val = 0.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else if(x < 3.0*GSL_SQRT_DBL_EPSILON) {
    result->val = x*x*x*x/4.0;
    result->err = 4.0 * GSL_DBL_EPSILON * result->val;
    CHECK_UNDERFLOW(result);
    return GSL_SUCCESS;
  }
  else if(x <= 4.0) {
    const double x2 = x*x;
    const double t = (x2/8.0 - 0.5) - 0.5;
    gsl_sf_result result_c;
    cheb_eval_e(&transport5_cs, t, &result_c);
    result->val  = x2*x2 * result_c.val;
    result->err  = x2*x2 * result_c.err;
    result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else if(x < -GSL_LOG_DBL_EPSILON) {
    const int    numexp = (int)((-GSL_LOG_DBL_EPSILON)/x) + 1;
    const double sumexp = transport_sumexp(numexp, 5, exp(-x), x);
    const double t = 5.0 * log(x) - x + log(sumexp);
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val = val_infinity;
      result->err = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + (fabs(t)+1.0) * et);
    }
    return GSL_SUCCESS;
  }
  else if(x < 3.0/GSL_DBL_EPSILON) {
    const int    numexp = 1;
    const double sumexp = transport_sumexp(numexp, 5, 1.0, x);
    const double t = 5.0 * log(x) - x + log(sumexp);
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val = val_infinity;
      result->err = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + (fabs(t)+1.0) * et);
    }
    return GSL_SUCCESS;
  }
  else {
    const double t = 5.0 * log(x) - x;
    if(t < GSL_LOG_DBL_EPSILON) {
      result->val = val_infinity;
      result->err = 2.0 * GSL_DBL_EPSILON * val_infinity;
    }
    else {
      const double et = exp(t);
      result->val = val_infinity - et;
      result->err = 2.0 * GSL_DBL_EPSILON * (val_infinity + (fabs(t)+1.0) * et);
    }
    return GSL_SUCCESS;
  }
}

/*-*-*-*-*-*-*-*-*-* Functions w/ Natural Prototypes *-*-*-*-*-*-*-*-*-*-*/

#include "eval.h"

double gsl_sf_transport_2(const double x)
{
  EVAL_RESULT(gsl_sf_transport_2_e(x, &result));
}

double gsl_sf_transport_3(const double x)
{
  EVAL_RESULT(gsl_sf_transport_3_e(x, &result));
}

double gsl_sf_transport_4(const double x)
{
  EVAL_RESULT(gsl_sf_transport_4_e(x, &result));
}

double gsl_sf_transport_5(const double x)
{
  EVAL_RESULT(gsl_sf_transport_5_e(x, &result));
}


/*
 * Copyright (c) 1997-1999 Massachusetts Institute of Technology
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *
 */

/* This file was automatically generated --- DO NOT EDIT */
/* Generated on Sun Nov  7 20:44:26 EST 1999 */

#include <fftw-int.h>
#include <fftw.h>

/* Generated by: ./genfft -magic-alignment-check -magic-twiddle-load-all -magic-variables 4 -magic-loopi -hc2real 15 */

/*
 * This function contains 64 FP additions, 31 FP multiplications,
 * (or, 47 additions, 14 multiplications, 17 fused multiply/add),
 * 36 stack variables, and 30 memory accesses
 */
static const fftw_real K1_118033988 = FFTW_KONST(+1.118033988749894848204586834365638117720309180);
static const fftw_real K1_902113032 = FFTW_KONST(+1.902113032590307144232878666758764286811397268);
static const fftw_real K1_175570504 = FFTW_KONST(+1.175570504584946258337411909278145537195304875);
static const fftw_real K500000000 = FFTW_KONST(+0.500000000000000000000000000000000000000000000);
static const fftw_real K866025403 = FFTW_KONST(+0.866025403784438646763723170752936183471402627);
static const fftw_real K2_000000000 = FFTW_KONST(+2.000000000000000000000000000000000000000000000);
static const fftw_real K1_732050807 = FFTW_KONST(+1.732050807568877293527446341505872366942805254);

/*
 * Generator Id's :
 * $Id: exprdag.ml,v 1.41 1999/05/26 15:44:14 fftw Exp $
 * $Id: fft.ml,v 1.43 1999/05/17 19:44:18 fftw Exp $
 * $Id: to_c.ml,v 1.25 1999/10/26 21:41:32 stevenj Exp $
 */

void fftw_hc2real_15(const fftw_real *real_input, const fftw_real *imag_input, fftw_real *output, int real_istride, int imag_istride, int ostride)
{
     fftw_real tmp3;
     fftw_real tmp30;
     fftw_real tmp18;
     fftw_real tmp37;
     fftw_real tmp61;
     fftw_real tmp62;
     fftw_real tmp45;
     fftw_real tmp40;
     fftw_real tmp23;
     fftw_real tmp31;
     fftw_real tmp42;
     fftw_real tmp28;
     fftw_real tmp32;
     fftw_real tmp8;
     fftw_real tmp13;
     fftw_real tmp14;
     ASSERT_ALIGNED_DOUBLE;
     {
	  fftw_real tmp17;
	  fftw_real tmp1;
	  fftw_real tmp2;
	  fftw_real tmp15;
	  fftw_real tmp16;
	  ASSERT_ALIGNED_DOUBLE;
	  tmp16 = imag_input[5 * imag_istride];
	  tmp17 = K1_732050807 * tmp16;
	  tmp1 = real_input[0];
	  tmp2 = real_input[5 * real_istride];
	  tmp15 = tmp1 - tmp2;
	  tmp3 = tmp1 + (K2_000000000 * tmp2);
	  tmp30 = tmp15 - tmp17;
	  tmp18 = tmp15 + tmp17;
     }
     {
	  fftw_real tmp4;
	  fftw_real tmp39;
	  fftw_real tmp5;
	  fftw_real tmp6;
	  fftw_real tmp7;
	  fftw_real tmp22;
	  fftw_real tmp38;
	  fftw_real tmp9;
	  fftw_real tmp44;
	  fftw_real tmp10;
	  fftw_real tmp11;
	  fftw_real tmp12;
	  fftw_real tmp27;
	  fftw_real tmp43;
	  fftw_real tmp19;
	  fftw_real tmp24;
	  ASSERT_ALIGNED_DOUBLE;
	  {
	       fftw_real tmp20;
	       fftw_real tmp21;
	       fftw_real tmp25;
	       fftw_real tmp26;
	       ASSERT_ALIGNED_DOUBLE;
	       tmp4 = real_input[3 * real_istride];
	       tmp39 = imag_input[3 * imag_istride];
	       tmp5 = real_input[7 * real_istride];
	       tmp6 = real_input[2 * real_istride];
	       tmp7 = tmp5 + tmp6;
	       tmp20 = imag_input[7 * imag_istride];
	       tmp21 = imag_input[2 * imag_istride];
	       tmp22 = K866025403 * (tmp20 - tmp21);
	       tmp38 = tmp20 + tmp21;
	       tmp9 = real_input[6 * real_istride];
	       tmp44 = imag_input[6 * imag_istride];
	       tmp10 = real_input[4 * real_istride];
	       tmp11 = real_input[real_istride];
	       tmp12 = tmp10 + tmp11;
	       tmp25 = imag_input[4 * imag_istride];
	       tmp26 = imag_input[imag_istride];
	       tmp27 = K866025403 * (tmp25 + tmp26);
	       tmp43 = tmp25 - tmp26;
	  }
	  tmp37 = K866025403 * (tmp5 - tmp6);
	  tmp61 = tmp39 - tmp38;
	  tmp62 = tmp44 - tmp43;
	  tmp45 = (K500000000 * tmp43) + tmp44;
	  tmp40 = (K500000000 * tmp38) + tmp39;
	  tmp19 = tmp4 - (K500000000 * tmp7);
	  tmp23 = tmp19 - tmp22;
	  tmp31 = tmp19 + tmp22;
	  tmp42 = K866025403 * (tmp10 - tmp11);
	  tmp24 = tmp9 - (K500000000 * tmp12);
	  tmp28 = tmp24 - tmp27;
	  tmp32 = tmp24 + tmp27;
	  tmp8 = tmp4 + tmp7;
	  tmp13 = tmp9 + tmp12;
	  tmp14 = tmp8 + tmp13;
     }
     output[0] = tmp3 + (K2_000000000 * tmp14);
     {
	  fftw_real tmp63;
	  fftw_real tmp65;
	  fftw_real tmp60;
	  fftw_real tmp64;
	  fftw_real tmp58;
	  fftw_real tmp59;
	  ASSERT_ALIGNED_DOUBLE;
	  tmp63 = (K1_175570504 * tmp61) - (K1_902113032 * tmp62);
	  tmp65 = (K1_902113032 * tmp61) + (K1_175570504 * tmp62);
	  tmp58 = tmp3 - (K500000000 * tmp14);
	  tmp59 = K1_118033988 * (tmp8 - tmp13);
	  tmp60 = tmp58 - tmp59;
	  tmp64 = tmp59 + tmp58;
	  output[12 * ostride] = tmp60 - tmp63;
	  output[3 * ostride] = tmp60 + tmp63;
	  output[6 * ostride] = tmp64 - tmp65;
	  output[9 * ostride] = tmp64 + tmp65;
     }
     {
	  fftw_real tmp51;
	  fftw_real tmp29;
	  fftw_real tmp50;
	  fftw_real tmp55;
	  fftw_real tmp57;
	  fftw_real tmp53;
	  fftw_real tmp54;
	  fftw_real tmp56;
	  fftw_real tmp52;
	  ASSERT_ALIGNED_DOUBLE;
	  tmp51 = K1_118033988 * (tmp23 - tmp28);
	  tmp29 = tmp23 + tmp28;
	  tmp50 = tmp18 - (K500000000 * tmp29);
	  tmp53 = tmp40 - tmp37;
	  tmp54 = tmp45 - tmp42;
	  tmp55 = (K1_175570504 * tmp53) - (K1_902113032 * tmp54);
	  tmp57 = (K1_902113032 * tmp53) + (K1_175570504 * tmp54);
	  output[5 * ostride] = tmp18 + (K2_000000000 * tmp29);
	  tmp56 = tmp51 + tmp50;
	  output[11 * ostride] = tmp56 - tmp57;
	  output[14 * ostride] = tmp56 + tmp57;
	  tmp52 = tmp50 - tmp51;
	  output[2 * ostride] = tmp52 - tmp55;
	  output[8 * ostride] = tmp52 + tmp55;
     }
     {
	  fftw_real tmp35;
	  fftw_real tmp33;
	  fftw_real tmp34;
	  fftw_real tmp47;
	  fftw_real tmp49;
	  fftw_real tmp41;
	  fftw_real tmp46;
	  fftw_real tmp48;
	  fftw_real tmp36;
	  ASSERT_ALIGNED_DOUBLE;
	  tmp35 = K1_118033988 * (tmp31 - tmp32);
	  tmp33 = tmp31 + tmp32;
	  tmp34 = tmp30 - (K500000000 * tmp33);
	  tmp41 = tmp37 + tmp40;
	  tmp46 = tmp42 + tmp45;
	  tmp47 = (K1_175570504 * tmp41) - (K1_902113032 * tmp46);
	  tmp49 = (K1_902113032 * tmp41) + (K1_175570504 * tmp46);
	  output[10 * ostride] = tmp30 + (K2_000000000 * tmp33);
	  tmp48 = tmp35 + tmp34;
	  output[ostride] = tmp48 - tmp49;
	  output[4 * ostride] = tmp48 + tmp49;
	  tmp36 = tmp34 - tmp35;
	  output[7 * ostride] = tmp36 - tmp47;
	  output[13 * ostride] = tmp36 + tmp47;
     }
}

fftw_codelet_desc fftw_hc2real_15_desc =
{
     "fftw_hc2real_15",
     (void (*)()) fftw_hc2real_15,
     15,
     FFTW_BACKWARD,
     FFTW_HC2REAL,
     345,
     0,
     (const int *) 0,
};


#include <string.h>
#include <mpi.h>
#include <math.h>
#include <alloca.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_integration.h>

#include <fastpm/libfastpm.h>
#include <fastpm/logging.h>
#include <fastpm/string.h>

#include "pmpfft.h"

void
fastpm_powerspectrum_init(FastPMPowerSpectrum * ps, const size_t size)
{
    fastpm_funck_init(&ps->base, size);
    ps->pm = NULL;
    ps->edges = malloc(sizeof(ps->edges[0]) * (ps->base.size + 1));
    ps->Nmodes = malloc(sizeof(ps->Nmodes[0]) * ps->base.size);
}

void
fastpm_powerspectrum_init_from(FastPMPowerSpectrum * ps, const FastPMPowerSpectrum * other)
{
    fastpm_powerspectrum_init(ps, other->base.size);
    memcpy(ps->base.k, other->base.k, sizeof(ps->base.k[0]) * ps->base.size);
    memcpy(ps->base.f, other->base.f, sizeof(ps->base.f[0]) * ps->base.size);
    memcpy(ps->edges, other->edges, sizeof(ps->edges[0]) * (ps->base.size + 1));
    memcpy(ps->Nmodes, other->Nmodes, sizeof(ps->Nmodes[0]) * ps->base.size);
}

void
fastpm_powerspectrum_init_from_delta(FastPMPowerSpectrum * ps, PM * pm, const FastPMFloat * delta1_k, const FastPMFloat * delta2_k)
{
    /* This function measures powerspectrum from two overdensity or 1+overdensity fields */
    /* normalize them with fastpm_apply_normalize_transfer if needed before using this function.*/
    /* N is used to store metadata -- the shot-noise level. */
    fastpm_powerspectrum_init(ps, pm_nmesh(pm)[0] / 2);

    ps->pm = pm;
    double Volume = 1.0;
    int d;
    double k0 = 2 * M_PI / pm_boxsize(ps->pm)[0];
    for (d = 0; d < 3; d ++) {
        Volume *= pm_boxsize(pm)[d];
    }
    ps->Volume = Volume;
    ps->k0 = k0;

    memset(ps->base.f, 0, sizeof(ps->base.f[0]) * ps->base.size);
    memset(ps->base.k, 0, sizeof(ps->base.k[0]) * ps->base.size);
    memset(ps->edges, 0, sizeof(ps->edges[0]) * (ps->base.size + 1));
    memset(ps->Nmodes, 0, sizeof(ps->Nmodes[0]) * ps->base.size);

    int i;
    for(i = 0; i < ps->base.size + 1; i ++) {
        ps->edges[i] = i * k0;
    }

#pragma omp parallel
    {
        PMKIter kiter;
        for(pm_kiter_init(ps->pm, &kiter);
            !pm_kiter_stop(&kiter);
            pm_kiter_next(&kiter)) {
            int d;
            ptrdiff_t kk = 0.;
            for(d = 0; d < 3; d++) {
                double ik = kiter.iabs[d];
                if(ik > pm->Nmesh[d] / 2) ik -= pm->Nmesh[d];
                kk += ik * ik;
            }

            ptrdiff_t ind = kiter.ind;

            ptrdiff_t bin = ((ptrdiff_t)floor(sqrt(kk))) - 2;
            if(bin < 0) bin = 0;
            while((bin + 1) * (bin + 1) <= kk) {
                bin ++;
            }

            double k = sqrt(kk) * k0;

            if(bin >= 0 && bin < ps->base.size) {
                double real1 = delta1_k[ind + 0];
                double imag1 = delta1_k[ind + 1];
                double real2 = delta2_k[ind + 0];
                double imag2 = delta2_k[ind + 1];
                double value = real1 * real2 + imag1 * imag2;
                int w = 2;

                if(kiter.i[2] == 0 || kiter.i[2] == pm->Nmesh[2] / 2) w = 1;

                if(kiter.iabs[0] == 0 &&
                   kiter.iabs[1] == 0 &&
                   kiter.iabs[2] == 0) {

                } else {
                    #pragma omp atomic
                    ps->Nmodes[bin] += w;
                    #pragma omp atomic
                    ps->base.f[bin] += w * value; /// cic;
                    #pragma omp atomic
                    ps->base.k[bin] += w * k;
                }
            }
        }
    }

    MPI_Allreduce(MPI_IN_PLACE, ps->base.f, ps->base.size, MPI_DOUBLE, MPI_SUM, ps->pm->Comm2D);
    MPI_Allreduce(MPI_IN_PLACE, ps->Nmodes, ps->base.size, MPI_DOUBLE, MPI_SUM, ps->pm->Comm2D);
    MPI_Allreduce(MPI_IN_PLACE, ps->base.k, ps->base.size, MPI_DOUBLE, MPI_SUM, ps->pm->Comm2D);

    ptrdiff_t ind;
    for(ind = 0; ind < ps->base.size; ind++) {
        if(ps->Nmodes[ind] == 0) continue;
        ps->base.k[ind] /= ps->Nmodes[ind];
        ps->base.f[ind] /= ps->Nmodes[ind];
        ps->base.f[ind] *= ps->Volume;
    }
}

void
fastpm_transferfunction_init(FastPMPowerSpectrum * ps, PM * pm, FastPMFloat * src_k, FastPMFloat * dest_k)
{
    FastPMPowerSpectrum * ps2 = alloca(sizeof(*ps2));

    fastpm_powerspectrum_init_from_delta(ps, pm, src_k, src_k);
    fastpm_powerspectrum_init_from_delta(ps2, pm, dest_k, dest_k);

    ptrdiff_t i;
    for(i = 0; i < ps->base.size; i ++) {
        ps->base.f[i] = sqrt(ps2->base.f[i] / ps->base.f[i]);
    }

    fastpm_powerspectrum_destroy(ps2);
}

void
fastpm_powerspectrum_destroy(FastPMPowerSpectrum * ps) {
    free(ps->edges);
    free(ps->Nmodes);
    fastpm_funck_destroy(&ps->base);
}

void
fastpm_powerspectrum_write(FastPMPowerSpectrum * ps, char * filename, double N)
{
    FILE * fp = fopen(filename, "w");
    int i;
    fprintf(fp, "# k p N \n");
    for(i = 0; i < ps->base.size; i ++) {
        fprintf(fp, "%g %g %g\n", ps->base.k[i], ps->base.f[i], ps->Nmodes[i]);
    }
    double * BoxSize = pm_boxsize(ps->pm);
    fprintf(fp, "# metadata 7\n");
    fprintf(fp, "# volume %g float64\n", ps->Volume);
    fprintf(fp, "# shotnoise %g float64\n", ps->Volume / N);
    fprintf(fp, "# N1 %g int\n", N);
    fprintf(fp, "# N2 %g int\n", N);
    fprintf(fp, "# Lz %g float64\n", BoxSize[2]);
    fprintf(fp, "# Lx %g float64\n", BoxSize[0]);
    fprintf(fp, "# Ly %g float64\n", BoxSize[1]);
    fclose(fp);
}

double
fastpm_powerspectrum_large_scale(FastPMPowerSpectrum * ps, int Nmax)
{
    double kmax = Nmax * ps->k0;
    ptrdiff_t i;
    double Plin = 0;
    double Nmodes = 0;
    /* ignore zero mode ! */
    for(i = 0; (i == 0) || (i < ps->base.size && ps->base.k[i] <= kmax); i ++) {
        Plin += ps->base.f[i] * ps->Nmodes[i];
        Nmodes += ps->Nmodes[i];
    }
    Plin /= Nmodes;
    return Plin;
}

/* inverted calling signature for callbacks */
double
fastpm_powerspectrum_eval2(double k, FastPMPowerSpectrum * ps)
{
    return fastpm_powerspectrum_eval(ps, k);
}

double
fastpm_powerspectrum_eval(FastPMPowerSpectrum * ps, double k)
{
    return fastpm_funck_eval(&ps->base, k);
}

double
fastpm_powerspectrum_get(FastPMPowerSpectrum * ps, double k)
{
    if(k == 0) return 1;

    /* ignore the 0 mode */

    int l = 0;
    int r = ps->base.size;

    while(r - l > 1) {
        int m = (r + l) / 2;
        /* if we are on the exact k, return value from there.*/
        if(k <= ps->edges[m])
            r = m;
        else
            l = m;
    }

    return ps->base.f[l];
}

double
fastpm_powerspectrum_get2(double k, FastPMPowerSpectrum * ps)
{
    return fastpm_powerspectrum_get(ps, k);
}

struct sigma2_int {
    FastPMPowerSpectrum * ps;
    double R;
};
static
double sigma2_int(double k, struct sigma2_int * param)
{
    double kr, kr3, kr2, w, x;
    double r_tophat = param->R;

    kr = r_tophat * k;
    kr2 = kr * kr;
    kr3 = kr2 * kr;

    if(kr < 1e-8)
        return 0;

    w = 3 * (sin(kr) / kr3 - cos(kr) / kr2);
    x = 4 * M_PI * k * k * w * w * fastpm_powerspectrum_eval(param->ps, k);

    return x / pow(2 * M_PI, 3);
}

double
fastpm_powerspectrum_sigma(FastPMPowerSpectrum * ps, double R)
{
    const int WORKSIZE = 81920;

    double result, abserr;
    gsl_integration_workspace *workspace;
    gsl_function F;

    struct sigma2_int param;
    param.ps = ps;
    param.R = R;

    workspace = gsl_integration_workspace_alloc(WORKSIZE);

    F.function = (void*) &sigma2_int;
    F.params = &param;

    void * handler = gsl_set_error_handler_off ();
    //
    // note: 500/R is here chosen as (effectively) infinity integration boundary
    gsl_integration_qag(&F, 0, 500.0 * 1 / R,
            0, 1.0e-4, WORKSIZE, GSL_INTEG_GAUSS41, workspace, &result, &abserr);

    // high precision caused error
    gsl_integration_workspace_free(workspace);
    gsl_set_error_handler (handler);

    return sqrt(result);
}

void
fastpm_powerspectrum_scale(FastPMPowerSpectrum * ps, double factor)
{
    ptrdiff_t i;
    /* neglect the zero mode */
    for(i = 1; i < ps->base.size; i ++) {
        ps->base.f[i] *= factor;
    }
}

void
fastpm_powerspectrum_rebin(FastPMPowerSpectrum * ps, size_t newsize)
{
    /* this doesn't work */
    double * k1 = malloc(newsize * sizeof(k1[0]));
    double * p1 = malloc(newsize * sizeof(p1[0]));
    double * Nmodes1 = malloc(newsize * sizeof(Nmodes1[0]));
    double * edges1 = malloc((newsize + 1) * sizeof(edges1[0]));

    ptrdiff_t i;

    for(i = 0; i < newsize; i ++) {
        ptrdiff_t j1 = (i    ) * ps->base.size / newsize;
        ptrdiff_t j2 = (i + 1) * ps->base.size / newsize;
        ptrdiff_t j;
        k1[i] = 0;
        p1[i] = 0;
        Nmodes1[i] = 0;
        edges1[i] = ps->edges[j1];
        edges1[i + 1] = ps->edges[j2];
        for(j = j1; j < j2; j ++) {
            k1[i] += ps->base.k[j] * ps->Nmodes[j];
            p1[i] += ps->base.f[j] * ps->Nmodes[j];
            Nmodes1[i] += ps->Nmodes[j];
        }
        if(Nmodes1[i] > 0) {
            k1[i] /= Nmodes1[i];
            p1[i] /= Nmodes1[i];
        }
    }
    free(ps->base.k);
    free(ps->base.f);
    free(ps->Nmodes);
    free(ps->edges);
    ps->base.k = k1;
    ps->base.f = p1;
    ps->Nmodes = Nmodes1;
    ps->edges = edges1;
    ps->base.size = newsize;
}

int
fastpm_powerspectrum_init_from_string(FastPMPowerSpectrum * ps, const char * string)
{
    int r = fastpm_funck_init_from_string(&ps->base, string);
    ps->edges = malloc(sizeof(ps->edges[0]) * (ps->base.size + 1));
    ps->Nmodes = malloc(sizeof(ps->Nmodes[0]) * ps->base.size);
    return r;
}

void
fastpm_funck_init(FastPMFuncK * fk, const size_t size)
{
    fk->size = size;
    fk->k = malloc(sizeof(fk->k[0]) * fk->size);
    fk->f = malloc(sizeof(fk->f[0]) * fk->size);
}

int
fastpm_funck_init_from_string(FastPMFuncK * fk, const char * string)
{
    char ** list = fastpm_strsplit(string, "\n");
    char ** line;
    ptrdiff_t i;
    int pass = 0;
    /* two pass parsing, first pass for counting */
    /* second pass for assignment */
    while(pass < 2) {
        i = 0;
        for (line = list; *line; line++) {
            double k, f;
            if(2 == sscanf(*line, "%lg\t%lg", &k, &f)) {   // note tab. Could make more general?
                if(pass == 1) {
                    fk->k[i] = k;
                    fk->f[i] = f;
                }
                i ++;
            }
        }
        if(pass == 0) {
            fastpm_funck_init(fk, i);
        }
        pass ++;
    }

    free(list);
    if(fk->size == 0) {
        /* Nothing is savagable in the file.*/
        return 0;
    }
    return 0;
}

/* inverted calling signature for callbacks */
double
fastpm_funck_eval2(double k, FastPMFuncK * fk)
{
    return fastpm_funck_eval(fk, k);
}

double
fastpm_funck_eval(FastPMFuncK * fk, double k)
{

    /* ignore the 0 mode */
    if(k == 0) return 1;

    int l = 0;
    int r = fk->size - 1;

    /* determine the right and left values around k */
    while(r - l > 1) {
        int m = (r + l) / 2;
        if(k < fk->k[m])
            r = m;
        else
            l = m;
    }
    double k2 = fk->k[r],
           k1 = fk->k[l];
    double f2 = fk->f[r],
           f1 = fk->f[l];

    if(l == r) {
        return fk->f[l];
    }

    if(f1 <= 0 || f2 <= 0 || k1 == 0 || k2 == 0) {
        /* if any of the f is zero, or negative, use linear interpolation */
        double f = (k - k1) * f2 + (k2 - k) * f1;
        f /= (k2 - k1);
        return f;
    } else {
        k = log(k);
        f1 = log(f1);
        f2 = log(f2);
        k1 = log(k1);
        k2 = log(k2);
        double f = (k - k1) * f2 + (k2 - k) * f1;
        f /= (k2 - k1);
        return exp(f);
    }
}

void
fastpm_funck_destroy(FastPMFuncK * fk)
{
    free(fk->f);
    free(fk->k);
}


#ifndef UTILS_H
#define UTILS_H

#include <stdio.h>
#include <stdlib.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <unistd.h>
#include <dirent.h>
#include <memory.h>
#include <time.h>

#include <math.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <gsl/gsl_permutation.h>
#include <gsl/gsl_sf_psi.h>
#include <gsl/gsl_sf_gamma.h>

#include <vector>
using namespace std;

double log_sum(double log_a, double log_b);
double log_normalize(double * array, int nlen);
double log_normalize(vector<double> & vec, int nlen);
double log_subtract(double log_a, double log_b);
double log_factorial(int n, double a);
double similarity(const int* v1, const int* v2, int n);

bool   file_exists(const char * filename);
bool   dir_exists(const char * directory);

template <typename T> void free_vec_ptr(vector <T* > & v)
{
    int size = v.size();
    T* p = NULL;
    for (int i = 0; i < size; i ++)
    {
        p = v[i];
        delete [] p;
    }
    v.clear();
}

// find the max and argmax in an array
template <typename T> T max(const T * x, int n, int* argmax)
{
    *argmax = 0;
    T max_val = x[0];
    for (int i = 1; i < n; i++)
        if (x[i] > max_val)
        {
            max_val = x[i];
            *argmax = i;
        }
    return max_val;
}

// find the max and argmax in an vector
template <typename T> T max_vec(vector<T> & v, int n, int* argmax)
{
    *argmax = 0;
    T max_val = v[0];
    for (int i = 1; i < n; i++)
        if (v[i] > max_val)
        {
            max_val = v[i];
            *argmax = i;
        }
    return max_val;
}

// set a value to the entire array
template <typename T> void set_array(T * array, int size, T value)
{
    for (int i = 0; i < size; i++) array[i] = value;
}

// swap two elements in an array
template < typename T > void swap_array_element(T * array, int i, int j)
{
    if (i == j) return;
    T a = array[i];
    array[i] = array[j];
    array[j] = a;
}

// set a value to a entrie vector
template <typename T> void set_vector(vector<T> & v, T value)
{
    int size = v.size();
    for (int i = 0; i < size; i++) v[i] = value;
}

// swap two elements in vector
template < typename T > void swap_vec_element(vector<T> & v, int i, int j)
{
    if (i == j) return; // no need to swap
    T a = v[i];
    v[i] = v[j];
    v[j] = a;
}

/// gsl_wrappers
//double lgamma(double x); // linux has this
unsigned int rmultinomial(const double* p, int n, double tot_p=-1);
double rgamma(double a, double b);
double rbeta(double a, double b);
unsigned int rbernoulli(double p);
double runiform();
void rshuffle (void* base, size_t n, size_t size);
unsigned long int runiform_int(unsigned long int n);

#endif