/************************** monte.c *******************************/
/* Kennedy-Pendleton quasi heat bath on SU(2) subgroups */
/* MIMD version 3 */
/* T. DeGrand March 1991 */
/* modified by K.R 97 & 2002 */

#include "lattice.h"

#define Nc 3

/* Generic definitions - could be useful elsewhere */

typedef struct { complex e[2][2]; } su2_matrix;

/* #pragma inline ( mult_su2_mat_vec_elem_n, left_su2_hit_n ) */

INLINE void mult_su2_mat_vec_elem_n(u,x0,x1)
     su2_matrix *u;
     complex *x0, *x1;
{
  /* Multiplies the complex column spinor (x0, x1) by the SU(2) matrix u */
  /* and puts the result in (x0,x1).  */
  /* Thus x <- u * x          */
  /* C. DeTar 3 Oct 1990 */
  
  complex z0, z1, t0, t1;

  t0 = *x0; t1 = *x1;

  CMUL(u->e[0][0], t0, z0);
  CMUL(u->e[0][1], t1, z1);
  CADD(z0, z1, *x0);
  CMUL(u->e[1][0], t0, z0);
  CMUL(u->e[1][1], t1, z1);
  CADD(z0, z1, *x1);

} /* mult_su2_mat_vec_elem_n */



/* void dumpsu2(u) su2_matrix *u; {
 *  int i,j;
 *  for(i=0;i<2;i++){
 *    for(j=0;j<2;j++)printf("(%.2e,%.2e)\t",
 *			  (double)u->e[i][j].real,(double)u->e[i][j].imag);
 *    printf("\n");
 *  }
 *  printf("\n");
 *}
 */

INLINE void left_su2_hit_n(su2_matrix *u, int p, int q, su3_matrix *link)
{
  /* link <- u * link */
  /* The 0 row of the SU(2) matrix u matches row p of the SU(3) matrix */
  /* The 1 row of the SU(2) matrix u matches row q of the SU(3) matrix */
  /* C. DeTar 18 Oct 1990 */
  
  register int m;

  for (m = 0; m < 3; m++)
    mult_su2_mat_vec_elem_n(u, &(link->e[p][m]), &(link->e[q][m]));

} /* left_su2_hit_n */



void monte(int dir,int parity,
	   su3_matrix *link[NDIM], su3_matrix *staple
#ifdef HIGGS
	   , su3_matrix *a_uncmpr
#endif
	   )
{
  /* Do K-P quasi-heat bath by SU(2) subgroups */
  int Nhit, index1, ina, inb,ii,cb;
  int gahit,gatry,utry,uhit;
  double xr1,xr2,xr3,xr4;
  double a0,a1,a2,a3;
  double v0,v1,v2,v3, vsq;
  double h0,h1,h2,h3;
  double r,r2,rho,z;
  double al,d, xl,xd;
  int  k, nacd, test;
  double b3;
  register int i;
  su3_matrix action;  
  su2_matrix h;

  Nhit = 3;

  b3=betag/3.0;

  gahit = gatry = 0; utry = uhit = 1;

  /* now for the qhb updating */
  for(index1=0;index1<Nhit;index1++) {
    /*  pick out an SU(2) subgroup */
    ina=(index1+1) % Nc;
    inb=(index1+2) % Nc;
    if(ina > inb) { ii=ina; ina=inb; inb=ii;}
    
    forparity(i,parity){
      mult_su3_na( &link[dir][i], &staple[i], &action );

      /* decompose the action into SU(2) subgroups using 
       * Pauli matrix expansion 
       * The SU(2) hit matrix is represented as 
       * a0 + i * Sum j (sigma j * aj)
       */
      v0 =  action.e[ina][ina].real + action.e[inb][inb].real;
      v3 =  action.e[ina][ina].imag - action.e[inb][inb].imag;
      v1 =  action.e[ina][inb].imag + action.e[inb][ina].imag;
      v2 =  action.e[ina][inb].real - action.e[inb][ina].real;
	    
      vsq = v0*v0 + v1*v1 + v2*v2 + v3*v3;

      if (vsq <= 0.0) {
	printf("monte: vsq error! node %d, vsq %g\n",this_node,vsq);
	fflush(stdout);
	terminate(0);
      }
	      
      z = sqrt(vsq );
      /* Normalize   u */
      v0 = v0/z; v1 = v1/z; v2 = v2/z; v3 = v3/z;
      /* end norm check--trial SU(2) matrix is a0 + i a(j)sigma(j)*/
/* test 
if(this_node == 0)printf("v= %e %e %e %e\n",v0,v1,v2,v3);
if(this_node == 0)printf("z= %e\n",z);
*/
      /* now begin qhb */
      /* get four random numbers */

      xr1 = log(1.0 - dran());
      xr2 = log(1.0 - dran());
      xr3 = dran();
      xr4 = dran();

      xr3 = cos(pi2*xr3);

/*
  if(this_node == 0)printf("rand= %e %e %e %e\n",xr1,xr2,xr3,xr4); 
*/

      /*
	generate a0 component of su3 matrix
	
	first consider generating an su(2) matrix h
	according to exp(bg/3 * re tr(h*s))
	rewrite re tr(h*s) as re tr(h*v)z where v is
	an su(2) matrix and z is a real normalization constant 
	let v = z*v. (z is 2*xi in k-p notation)
	v is represented in the form v(0) + i*sig*v (sig are pauli)
	v(0) and vector v are real
	
	let a = h*v and now generate a
	rewrite beta/3 * re tr(h*v) * z as al*a0
	a0 has prob(a0) = n0 * sqrt(1 - a0**2) * exp(al * a0)
      */
      al = b3*z;
/*if(this_node == 0)printf("al= %e\n",al);*/

      /*
	let a0 = 1 - del**2
	get d = del**2
	such that prob2(del) = n1 * del**2 * exp(-al*del**2)
      */

      d = -(xr2  + xr1*xr3*xr3)/al;

      /* monte carlo prob1(del) = n2 * sqrt(1 - 0.5*del**2)
	 then prob(a0) = n3 * prob1(a0)*prob2(a0)
      */

      /* now  beat each  site into submission */
      nacd = 0;
      if ((1.00 - 0.5*d) > xr4*xr4) nacd=1;
      if(nacd == 0 && al > 2.0) { /* k-p algorithm */
	test=0;
	for(k=0; k<20 && !test;k++) {
	  /*  get four random numbers */
	  xr1 = log(1.0 - dran());
	  xr2 = log(1.0 - dran());
	  xr3 = dran();
	  xr4 = dran();

	  xr3 = cos(pi2*xr3);

	  d = -(xr2 + xr1*xr3*xr3)/al;
	  if ((1.00 - 0.5*d) > xr4*xr4) test = 1;
	}
	utry += k;
	uhit++;

	if (this_node == 0 && test != 1)
	  printf("site  took 20 kp hits\n");
      } /* endif nacd */

      if(nacd == 0 && al <= 2.0) {
	/* creutz algorithm */
	xl=exp((double)(-2.0*al));
	xd= 1.0 - xl;
	test=0;
	for(k=0;k<20 && test == 0  ;k++) {
	  /*        get two random numbers */
	  xr1=dran();
	  xr2=dran();

	  r = xl + xd*xr1; 
	  a0 = 1.00 + log((double)r)/al;
	  if((1.0 -a0*a0) > xr2*xr2) test = 1;
	}
	d = 1.0 - a0;
	utry += k;
	uhit++;
	
	if(this_node == 0 && test !=1) 
	  printf("site  took 20 creutz hits\n");
      } /* endif nacd */

      /*  generate full su(2) matrix and update link matrix*/

      /* find a0  = 1 - d*/
      a0 = 1.0 - d;
      /* compute r */
      r2 = 1.0 - a0*a0;
      r2 = fabs(r2);
      r  = sqrt(r2);

      /* compute a3 */
      a3=(2.0*dran() - 1.0)*r;

      prefetch_matrix(&a_uncmpr[i] );
      prefetch_adjoint(&ahiggs[nb(dir,i)]);

      /* compute a1 and a2 */
      rho = r2 - a3*a3;
      rho = fabs(rho);
      rho = sqrt(rho);

      /*xr2 is a random number between 0 and 2*pi */
      xr2 = pi2*dran();
      a1 = rho*cos((double)xr2);
      a2 = rho*sin((double)xr2);

      /* now do the updating.  h = a*v^dagger, new u = h*u */
      h0 = a0*v0 + a1*v1 + a2*v2 + a3*v3;
      h1 = a1*v0 - a0*v1 + a2*v3 - a3*v2;
      h2 = a2*v0 - a0*v2 + a3*v1 - a1*v3;
      h3 = a3*v0 - a0*v3 + a1*v2 - a2*v1;

      /* Elements of SU(2) matrix */

      h.e[0][0] = cmplx( h0, h3);
      h.e[0][1] = cmplx( h2, h1);
      h.e[1][0] = cmplx(-h2, h1);
      h.e[1][1] = cmplx( h0,-h3);

      /* update the link */

#ifdef HIGGS
      action = link[dir][i];
      left_su2_hit_n(&h,ina,inb,&action);

      /* remember: tmpmat contains uncompressed local adj. */
      
      a1 = act_gauge_adj(&a_uncmpr[i],&link[dir][i],&ahiggs[nb(dir,i)]); 
      a2 = act_gauge_adj(&a_uncmpr[i],&action,      &ahiggs[nb(dir,i)]); 

      prefetch_matrix(&link[dir][i+1]);
      prefetch_matrix(&staple[i+1]);

      if (exp(a1-a2) >= dran()) {
	link[dir][i] = action;
	gahit++;
      }      
      gatry++;

#else

      left_su2_hit_n(&h,ina,inb,&link[dir][i]);

#endif

    } /* site */
  } /*  hits */
  
#ifdef HIGGS
  nhitua++;
  ahitua += 1.0*gahit/gatry;
#endif

  nhitu++;
  ahitu += 1.0*uhit/utry;  

} /* monte */





