/* hc.f -- translated by f2c (version 20020208).
   You must link the resulting object file with the libraries:
	-lf2c -lm   (in that order)
*/

#include "f2c.h"

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C */
/*                                                            C */
/*  HIERARCHICAL CLUSTERING using (user-specified) criterion. C */
/*                                                            C */
/*  Parameters:                                               C */
/*                                                            C */
/*  DISS(LEN)         dissimilarities in lower half diagonal  C */
/*                    storage; LEN = N.N-1/2,                 C */
/*  IOPT              clustering criterion to be used,        C */
/*  IA, IB, CRIT      history of agglomerations; dimensions   C */
/*                    N, first N-1 locations only used,       C */
/*  MEMBR, NN, DISNN  vectors of length N, used to store      C */
/*                    cluster cardinalities, current nearest  C */
/*                    neighbour, and the dissimilarity assoc. C */
/*                    with the latter.                        C */
/*  FLAG              boolean indicator of agglomerable obj./ C */
/*                    clusters.                               C */
/*                                                            C */
/*  F. Murtagh, ESA/ESO/STECF, Garching, February 1986.       C */
/*                                                            C */
/* ------------------------------------------------------------C */
/* Subroutine */ int hc_(n, len, iopt, ia, ib, crit, membr, nn, disnn, flag__,
	 diss)
integer *n, *len, *iopt, *ia, *ib;
doublereal *crit, *membr;
integer *nn;
doublereal *disnn;
logical *flag__;
doublereal *diss;
{
    /* Initialized data */

    static doublereal inf = 1e20;

    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1, d__2;

    /* Local variables */
    static doublereal dmin__;
    static integer i__, j, k;
    static doublereal x;
    static integer i2, j2, jj, im, jm;
    static doublereal xx;
    static integer ind, ncl;
    extern integer ioffset_();
    static integer ind1, ind2, ind3;

    /* Parameter adjustments */
    --flag__;
    --disnn;
    --nn;
    --membr;
    --crit;
    --ib;
    --ia;
    --diss;

    /* Function Body */

/*  Initializations */

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	membr[i__] = (float)1.;
	flag__[i__] = TRUE_;
    }
    ncl = *n;
    if (*iopt == 1) {
	i__1 = *n * (*n - 1) / 2;
	for (ind = 1; ind <= i__1; ++ind) {
	    diss[ind] /= (float)2.;
	}
    }
/*     (Above is done for the case of the min. var. method */
/*     where merging criteria are defined in terms of variances */
/*     rather than distances.) */

/*  Carry out an agglomeration - first create list of NNs */

    i__1 = *n - 1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	dmin__ = inf;
	i__2 = *n;
	for (j = i__ + 1; j <= i__2; ++j) {
	    ind = ioffset_(n, &i__, &j);
	    if (diss[ind] >= dmin__) {
		goto L500;
	    }
	    dmin__ = diss[ind];
	    jm = j;
L500:
	    ;
	}
	nn[i__] = jm;
	disnn[i__] = dmin__;
    }

L400:
/*     Next, determine least diss. using list of NNs */
    dmin__ = inf;
    i__1 = *n - 1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (! flag__[i__]) {
	    goto L600;
	}
	if (disnn[i__] >= dmin__) {
	    goto L600;
	}
	dmin__ = disnn[i__];
	im = i__;
	jm = nn[i__];
L600:
	;
    }
    --ncl;

/*  This allows an agglomeration to be carried out. */

    i2 = min(im,jm);
    j2 = max(im,jm);
    ia[*n - ncl] = i2;
    ib[*n - ncl] = j2;
    crit[*n - ncl] = dmin__;
    ind1 = ioffset_(n, &i2, &j2);
/*      write(6,*) "agglom: ",i2,j2,dmin,diss(ind1) */

/*  Update dissimilarities from new cluster. */

    flag__[j2] = FALSE_;
    dmin__ = inf;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	if (! flag__[k]) {
	    goto L800;
	}
	if (k == i2) {
	    goto L800;
	}
	x = membr[i2] + membr[j2] + membr[k];
	if (i2 < k) {
	    ind1 = ioffset_(n, &i2, &k);
	} else {
	    ind1 = ioffset_(n, &k, &i2);
	}
	if (j2 < k) {
	    ind2 = ioffset_(n, &j2, &k);
	} else {
	    ind2 = ioffset_(n, &k, &j2);
	}
	ind3 = ioffset_(n, &i2, &j2);
	xx = diss[ind3];

/*  WARD'S MINIMUM VARIANCE METHOD - IOPT=1. */

	if (*iopt == 1) {
	    diss[ind1] = (membr[i2] + membr[k]) * diss[ind1] + (membr[j2] + 
		    membr[k]) * diss[ind2] - membr[k] * xx;
	    diss[ind1] /= x;
	}

/*  SINGLE LINK METHOD - IOPT=2. */

	if (*iopt == 2) {
/* Computing MIN */
	    d__1 = diss[ind1], d__2 = diss[ind2];
	    diss[ind1] = min(d__1,d__2);
	}

/*  COMPLETE LINK METHOD - IOPT=3. */

	if (*iopt == 3) {
/* Computing MAX */
	    d__1 = diss[ind1], d__2 = diss[ind2];
	    diss[ind1] = max(d__1,d__2);
	}

/*  AVERAGE LINK (OR GROUP AVERAGE) METHOD - IOPT=4. */

	if (*iopt == 4) {
	    diss[ind1] = (membr[i2] * diss[ind1] + membr[j2] * diss[ind2]) / (
		    membr[i2] + membr[j2]);
	}

/*  MCQUITTY'S METHOD - IOPT=5. */

	if (*iopt == 5) {
	    diss[ind1] = diss[ind1] * (float).5 + diss[ind2] * (float).5;
	}

/*  MEDIAN (GOWER'S) METHOD - IOPT=6. */

	if (*iopt == 6) {
	    diss[ind1] = diss[ind1] * (float).5 + diss[ind2] * (float).5 - xx 
		    * (float).25;
	}

/*  CENTROID METHOD - IOPT=7. */

	if (*iopt == 7) {
	    diss[ind1] = (membr[i2] * diss[ind1] + membr[j2] * diss[ind2] - 
		    membr[i2] * membr[j2] * xx / (membr[i2] + membr[j2])) / (
		    membr[i2] + membr[j2]);
	}

	if (i2 > k) {
	    goto L800;
	}
	if (diss[ind1] >= dmin__) {
	    goto L800;
	}
	dmin__ = diss[ind1];
	jj = k;
L800:
	;
    }
    membr[i2] += membr[j2];
    disnn[i2] = dmin__;
    nn[i2] = jj;

/*  Update list of NNs insofar as this is required. */

    i__1 = *n - 1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (! flag__[i__]) {
	    goto L900;
	}
	if (nn[i__] == i2) {
	    goto L850;
	}
	if (nn[i__] == j2) {
	    goto L850;
	}
	goto L900;
L850:
/*        (Redetermine NN of I:) */
	dmin__ = inf;
	i__2 = *n;
	for (j = i__ + 1; j <= i__2; ++j) {
	    ind = ioffset_(n, &i__, &j);
	    if (! flag__[j]) {
		goto L870;
	    }
	    if (i__ == j) {
		goto L870;
	    }
	    if (diss[ind] >= dmin__) {
		goto L870;
	    }
	    dmin__ = diss[ind];
	    jj = j;
L870:
	    ;
	}
	nn[i__] = jj;
	disnn[i__] = dmin__;
L900:
	;
    }

/*  Repeat previous steps until N-1 agglomerations carried out. */

    if (ncl > 1) {
	goto L400;
    }


    return 0;
} /* hc_ */



integer ioffset_(n, i__, j)
integer *n, *i__, *j;
{
    /* System generated locals */
    integer ret_val;

/*  Map row I and column J of upper half diagonal symmetric matrix */
/*  onto vector. */
    /*ret_val = *j + (*i__ - 1) * *n - *i__ * (*i__ + 1) / 2;*/
    if (*j > *i__) {
      ret_val = (*j - 1) * (*j - 2) / 2 + *i__;
    } else {
      ret_val = (*i__ - 1) * (*i__ - 2) / 2 + *j;
    }
    return ret_val;
} /* ioffset_ */

