Logo Search packages:      
Sourcecode: fastlink version File versions  Download package

ilink.c

/* This file contains the main routines in */
/* a modified version of the ILINK program*/
/* The modifications are described in the papers: */
/* R. W. Cottingham, Jr., R. M. Idury, and A. A. Schaffer, */
/* Faster Sequential Genetic Linkage Computations */
/* American Journal of Human Genetics, 53(1993), pp. 252-263*/
/* and A. A. Schaffer, S. K. Gupta, K. Shriram, and R. W. Cottingham, Jr.,*/
/* Avoiding Recomputation in Linkage Analysis */
/* Human Heredity 44(1994), pp. 225-237.*/

#include "commondefs.h"
#if !defined(DOS)
#include "checkpointdefs.h"
#endif
#include "gemdefs.h"
#include "ildefs.h"
#ifndef LESSMEMORY
#include "moddefs.h"
#endif

#if PARALLEL
#include "compar.h"
#endif  /* if PARALLEL */

static Void outcontrol(z)
double *z;
{
  int i, j;

  j = 0;
  for (i = 0; i < n; i++) {
    fprintf(outfile, "% .5e", z[i]);
    j++;
    if (j == 4) {
      putc('\n', outfile);
      j = 0;
    }
  }
  if (j != 0)
    putc('\n', outfile);
}


/*saveparams saves the parameter values at the beginning of
gforward or gcentral, so we capture the optimal thetas*/
Local Void saveparams()
{
  int i;

  for (i=0; i < nall; i++)
       outsavex[i] = x[i];
}

static void fun(f, x)
double *f;
double *x;
{
  int i, k;
#if PARALLEL
#if FUNTIMES
  struct timeval starttime, endtime;
  double time;

  gettimeofday(&starttime, NULL); /*Get start time*/
#endif /*FUNTIMES*/
#endif /*PARALLEL */

#if PARALLEL
  accumfamilytime = 0;
  infun = 1;
  if (!parallelThetas) {
    OneMaster();
#if BARRIER_OUTPUT
    barnum++;
    printf("(%d) Full barrier (!parallelThetas) at beginning of fun\n",barnum);
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM
   BARRIER(gMem->full_barrier,Tmk_nprocs); 
#else
   Tmk_barrier(Tmk_mask);
#endif /*IS_SHMEM*/
  }
#endif /*PARALLEL*/

  k = 0;
  /*Test code inserted by A. A. Schaffer
  for (i = 0; i < nall; i++) {
    printf("%lf ", x[i]);
  } 
  printf("\n");*/
  for (i = 0; i < nall; i++) {
    if (itp[i] == 1) {
      k++;
      xall[i] = x[k - 1];
    }
  }
  setparam();
  recombination();
  if (penalty) {
    *f = 1.5 * penlike;
    return;
  }
  for (i = 1; i <= totperson; i++) {
    person[i]->done = false;
    person[i]->firstpass = true;
  }
  alike = 0.0;
  thisc = minint;
#if LOOPSPEED /*Dylan added*/
  open_loop_file();
#endif
  for (i = 1; i <= nuped; i++) {
#if LOOPSPEED
    read_loop_file(i);
#endif
    likelihood(i, proband[i - 1]);
    likebyped[i-1] = like; /*Store likelihood for later*/
    alike += like;
  }
#if LOOPSPEED
  close_loop_file();
#endif
  if (firsttime) {
    if (thisc < maxcensor)
      printf("Maxcensor can be reduced to %12d\n", thisc);
    else {
      if (thisc > maxcensor)
      printf("You may gain efficiency by increasing maxcensor\n");
    }
  }

#if PARALLEL
  funfinished[Tmk_proc_id]++;
  infun = 0;
  if((*slavesPerGroup) > 1) {
#if BARRIER_OUTPUT
    barnum++;
    printf("(%d) Group barrier at end of fun\n",barnum);
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM
    BARRIER(partial_barrier[mymaster]->barrier,*slavesPerGroup);
#else
    Tmk_barrier(MakeMask(mymaster,mymaster+(*slavesPerGroup)-1));
#endif /*IS_SHMEM*/
  }
  if(!parallelThetas) {
#if BARRIER_OUTPUT
    barnum++;
    printf("(%d) Full barrier (!parallelThetas) at end of fun\n",barnum);
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM
    BARRIER(gMem->full_barrier,Tmk_nprocs);
#else
    Tmk_barrier(Tmk_mask);
#endif /*IS_SHMEM*/
  }

  if(*secondfe) {
    for(i=0;i<1000;i++)
      for(k=0;k<Tmk_nprocs;k++) {
        (*rowfence)[i][k] = (*temprowfence)[i][k];
        (*qfence)[i][k] = (*tempqfence)[i][k];
      }
    *secondfe = 0;
  }
#endif /*PARALLEL*/

/*  exit(EXIT_SUCCESS); exitramana*/
  firsttime = false;
  *f = -2 * alike;
  penlike = *f;
  firsttime = false;

#if PARALLEL
#if FUNTIMES
  gettimeofday(&endtime, NULL);  /* Get end time */
  if(!parallelThetas) {
    time = (endtime.tv_sec - starttime.tv_sec)
         + (endtime.tv_usec - starttime.tv_usec)/1000000.0;
    printf("Execution time (all processors working together) = %7.3f\n",time);
    fflush(stdout);
  }
  else
#if PARALLEL_GCENTRAL
    executionTimes[eTimeIndex] =
#else /* !PARALLEL_GCENTRAL */
    executionTimes[eTimeIndex][fe] =
#endif /* PARALLEL_GCENTRAL */
                          (endtime.tv_sec - starttime.tv_sec)
                          + (endtime.tv_usec - starttime.tv_usec)/1000000.0;
#endif /*FUNTIMES*/
#endif /*PARALLEL*/

}


/* Local variables for outf: */
struct LOC_outf {
  double lods;
  double thisval[maxped];
} ;

Local Void getlods(f, x, LINK)
double *f;
double *x;
struct LOC_outf *LINK;
{
  int i, k;

  firstapprox = true;
  k = 0;
  for (i = 0; i < nall; i++) {
    if (itp[i] == 1) {
      k++;
      xall[i] = x[k - 1];
    }
  }
  for (i = 0; i < nuped; i++)
    LINK->thisval[i] = 0.0;
  setparam();

#if PARALLEL
/*  infun = 1;
  if(!parallelThetas) {
    OneMaster(); */
#if BARRIER_OUTPUT
/*    barnum++;
    printf("(%d) Full barrier at beginning of getlods\n",barnum);*/
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM
/*    BARRIER(gMem->full_barrier,Tmk_nprocs);*/
#else
/*    Tmk_barrier(Tmk_mask);*/
#endif /*IS_SHMEM*/
/*  } */
#endif /*PARALLEL*/

  if (!penalty) {
    if (byfamily) {
      for (i = 1; i <= 35; i++)
      putc('-', final);
      fprintf(final, "\nPEDIGREE | LN LIKE | LOG 10 LIKE\n");
      for (i = 1; i <= 35; i++)
      putc('-', final);
      putc('\n', final);
    }
    if (byfamily)   {  /*Then need to redo likelihoods on a by-family basis*/
      for (i = 1; i <= totperson; i++) {
        person[i]->done = false;
        person[i]->firstpass = true;
      }
      recombination();
      thisc = minint;
#if LOOPSPEED
      open_loop_file();
#endif
      for (i = 1; i <= nuped; i++) {
#if LOOPSPEED
        read_loop_file(i);
#endif
      likelihood(i, proband[i - 1]);
      LINK->thisval[i - 1] = like;
      }
#if LOOPSPEED
      close_loop_file();
#endif
    }
  }                     /* Shriram: reindented */

#if PARALLEL
/*  funfinished[0]++;
  infun = 0;
  if((*slavesPerGroup) > 1) { */
#if BARRIER_OUTPUT
/*    barnum++;
    printf("(%d) Group barrier at middle of getlods\n",barnum);*/
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM
/*    BARRIER(partial_barrier[mymaster]->barrier,*slavesPerGroup); */
#else
/*    Tmk_barrier(MakeMask(mymaster,mymaster+(*slavesPerGroup)-1));*/
#endif /*IS_SHMEM*/
/*  }*/
/*  if(!parallelThetas) { */
#if BARRIER_OUTPUT
/*    barnum++;
    printf("(%d) Full barrier (!parallelThetas) at middle of getlods\n",barnum);*/
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM
/*    BARRIER(gMem->full_barrier,Tmk_nprocs);*/
#else
/*    Tmk_barrier(Tmk_mask);*/
#endif /*IS_SHMEM*/
/*  } */

#endif /*PARALLEL*/

  firsttime = true;
  for (i = 0; i < mlocus; i++) {
    maletheta->theta[i] = 0.5;
    femaletheta->theta[i] = 0.5;
  }
  if (penalty) {
    *f = 1.5 * penlike;
    return;
  }

#if PARALLEL
  infun = 1;
  if(!parallelThetas) {
    OneMaster();
#if BARRIER_OUTPUT
    barnum++;
    printf("(%d) Full barrier (!parallelThetas) at middle of getlods\n",barnum);
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM
    BARRIER(gMem->full_barrier,Tmk_nprocs);
#else
    Tmk_barrier(Tmk_mask);
#endif /*IS_SHMEM*/
  }
#endif /*PARALLEL*/


  dolod = true;
  for (i = 1; i <= totperson; i++) {
    person[i]->done = false;
    person[i]->firstpass = true;
  }
  recombination();
  alike = 0.0;
  thisc = minint;
#if LOOPSPEED
  open_loop_file();
#endif
  for (i = 0; i < nuped; i++) {
#if LOOPSPEED
    read_loop_file(i+1);
#endif
    likelihood(i + 1, proband[i]);
    alike += like;
    if (byfamily) {
      fprintf(final, "%9d %9d %12.6f",
            i + 1, proband[i]->ped, LINK->thisval[i] - like);
      fprintf(final, "%12.6f", (LINK->thisval[i] - like) / log10_);
      if (like == zerolike)
      fprintf(final, " inconsistent data\n");
      else
      putc('\n', final);
      if (byfamily)  /*Need to compute family lodscore*/
        if (like != zerolike)
        LINK->thisval[i] -= like;
    }
  }

#if PARALLEL
  funfinished[0]++;
  infun = 0;
  if((*slavesPerGroup) > 1) {
#if BARRIER_OUTPUT
    barnum++;
    printf("(%d) Group barrier at end of getlods\n",barnum);
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM
    BARRIER(partial_barrier[mymaster]->barrier,*slavesPerGroup);
#else
    Tmk_barrier(MakeMask(mymaster,mymaster+(*slavesPerGroup)-1));
#endif /*IS_SHMEM*/
  }
  if(!parallelThetas) {
#if BARRIER_OUTPUT
    barnum++;
    printf("(%d) Full barrier (!parallelThetas) at end of getlods\n",barnum);
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM
    BARRIER(gMem->full_barrier,Tmk_nprocs);
#else
    Tmk_barrier(Tmk_mask);
#endif /*IS_SHMEM*/
  }
#endif /*PARALLEL*/

#if LOOPSPEED
  close_loop_file();
#endif
  *f = -2 * alike;
  penlike = *f;
  dolod = false;
}

Local Void streamout(LINK)
struct LOC_outf *LINK;
{
  int i, j, k, l;
  double deriv[3];
  thetarray oldtheta;
  double dist;
  int FORLIM;
  locusvalues *WITH;
  int FORLIM1, FORLIM2;
  thetavalues *WITH1;
  double TEMP;

  inconsistent = false;
  setparam();
  recombination();
  firstapprox = true;
  /*Start stream*/
  fprintf(stream, "@\n");
  fprintf(stream, "ILINK\n");

  /*Gemini information*/
  fprintf(stream, "% .5e %12d % .5e %12d %12d %12d\n",
        f, nit, ptg, idg, nall, n);
  /*Valid or not*/
  if ((nit > 1 && fabs(ptg) < 0.001) || n == 0)
    fprintf(stream, " 2\n");
  else {
    if (nit > 1 && fabs(ptg) < 0.1)
      fprintf(stream, " 1\n");
    else
      fprintf(stream, " 0\n");
  }
  for (i = 0; i < nall; i++)
    fprintf(stream, " % .5e\n", xall[i]);
  putc('\n', stream);
  for (i = 0; i < nall; i++)
    fprintf(stream, " %2d\n", itp[i]);
  putc('\n', stream);
  for (i = 0; i < n; i++)
    fprintf(stream, " % .5e\n", g[i]);
  putc('\n', stream);
  /*Variance-covariance calculated if ivar=1 and icall=0*/
  if (ivar == 1 && icall == 0)
    fprintf(stream, "1\n");
  else
    fprintf(stream, "0\n");

  if (inconsistent)
    fprintf(stream, "1\n");
  else
    fprintf(stream, "0\n");

  /*Control parameters for sexlink,interference and sex difference*/
  if (sexlink)
    fprintf(stream, "1\n");
  else
    fprintf(stream, "0\n");
  if (interfer)
    fprintf(stream, "1 ");
  else
    fprintf(stream, "0 ");
  if (mapping)
    fprintf(stream, "1\n");
  else
    fprintf(stream, "0\n");
  if (sexdif && readfemale)
    fprintf(stream, "2 ");
  else {
    if (sexdif)
      fprintf(stream, "1\n");
    else
      fprintf(stream, "0\n");
  }

  /*Genetic information*/
  fprintf(stream, "%12d\n", mlocus);
  for (i = 1; i <= mlocus; i++) {
    j = 0;
    do {
      j++;
    } while (order[j - 1] != i);
    fprintf(stream, " %12d", j);
  }
  putc('\n', stream);

  /*Iterated locus*/
  if (itsys != 0)
    fprintf(stream, "%12d\n", order[itsys - 1]);
  else
    fprintf(stream, " 0\n");
  if (itsys != 0) {
    WITH = thislocus[itsys - 1];
    if (disequi) {
      fprintf(stream, "1 %12d %12d\n", WITH->nallele, nuhap);
      for (i = 0; i < nuhap; i++)
      fprintf(stream, "%9.6f", hapfreq->genarray[i]);
    } else {
      fprintf(stream, "0 %12d\n", WITH->nallele);
      FORLIM = WITH->nallele;
      for (i = 0; i < FORLIM; i++)
      fprintf(stream, "%9.6f", WITH->freq[i]);
    }
    putc('\n', stream);

    WITH = thislocus[itsys - 1];
    if (WITH->which == binary_ && WITH->format == 3)
      fprintf(stream, " 3\n");
    else {
      if (WITH->which == binary_ && WITH->format == 2)
      fprintf(stream, " 2\n");
      else {
      if (WITH->which == quantitative) {
        fprintf(stream, "0 %12ld\n", WITH->UU.U1.ntrait);
        invert(WITH->UU.U1.vmat, WITH->UU.U1.ntrait, &WITH->UU.U1.det);
        FORLIM = WITH->UU.U1.ntrait;
        for (i = 0; i < FORLIM; i++) {
          FORLIM1 = WITH->nallele;
          for (j = 1; j <= FORLIM1; j++) {
            FORLIM2 = WITH->nallele;
            for (k = j - 1; k < FORLIM2; k++)
            fprintf(stream, "%6.3f ", WITH->UU.U1.pm[j][k][i]);
          }
          putc('\n', stream);
        }
        FORLIM = WITH->UU.U1.ntrait;
        for (i = 0; i < FORLIM; i++) {
          FORLIM1 = WITH->UU.U1.ntrait;
          for (j = i; j < FORLIM1; j++)
            fprintf(stream, "%6.3f ", WITH->UU.U1.vmat[i][j]);
          putc('\n', stream);
        }
      } else {
        if (WITH->which == affection) {
          fprintf(stream, "1 %12ld\n", WITH->UU.U0.nclass);
          FORLIM = WITH->UU.U0.nclass;
          for (l = 0; l < FORLIM; l++) {
            FORLIM1 = WITH->nallele;
            for (i = 1; i <= FORLIM1; i++) {
            FORLIM2 = WITH->nallele;
            for (j = i - 1; j < FORLIM2; j++)
              fprintf(stream, " %5.3f", WITH->UU.U0.pen[i][j][2][l]);
            }
            putc('\n', stream);
            if (sexlink) {
            FORLIM1 = WITH->nallele;
            for (i = 0; i < FORLIM1; i++)
              fprintf(stream, "%5.3f ", WITH->UU.U0.pen[0][i][2][l]);
            }
            putc('\n', stream);
          }
        }
      }
      }
    }
  }
  if (interfer && !mapping) {
    WITH1 = maletheta;
    memcpy(oldtheta, WITH1->theta, sizeof(thetarray));
    WITH1->theta[0] =
      (oldtheta[0] + oldtheta[mlocus - 1] - oldtheta[mlocus - 2]) / 2.0;
    WITH1->theta[mlocus - 2] =
      (oldtheta[mlocus - 2] + oldtheta[mlocus - 1] - oldtheta[0]) / 2.0;
    WITH1->theta[mlocus - 1] =
      (oldtheta[0] + oldtheta[mlocus - 2] - oldtheta[mlocus - 1]) / 2.0;
    for (i = 0; i < mlocus; i++)
      fprintf(stream, " %5.3f", WITH1->theta[i]);
    putc('\n', stream);
    memcpy(WITH1->theta, oldtheta, sizeof(thetarray));
    if (sexdif) {
      WITH1 = femaletheta;
      memcpy(oldtheta, WITH1->theta, sizeof(thetarray));
      WITH1->theta[0] =
      (oldtheta[0] + oldtheta[mlocus - 1] - oldtheta[mlocus - 2]) / 2.0;
      WITH1->theta[mlocus - 2] =
      (oldtheta[mlocus - 2] + oldtheta[mlocus - 1] - oldtheta[0]) / 2.0;
      WITH1->theta[mlocus - 1] =
      (oldtheta[0] + oldtheta[mlocus - 2] - oldtheta[mlocus - 1]) / 2.0;
      for (i = 0; i < mlocus; i++)
      fprintf(stream, " %5.3f", WITH1->theta[i]);
      putc('\n', stream);
      memcpy(WITH1->theta, oldtheta, sizeof(thetarray));
    }
    if (ivar == 1 && icall == 0) {
      for (i = 0; i <= 2; i++) {
      TEMP = 1 + exp(xall[nall - i - 1]);
      deriv[i] = exp(xall[nall - i - 1]) / (TEMP * TEMP);
      }
      k = -1;
      for (i = 0; i <= 2; i++) {
      if (itp[nall - i - 1] == 1) {
        k++;
        l = -1;
        for (j = 0; j <= 2; j++) {
          if (itp[nall - j - 1] == 1) {
            l++;
            bmat[n - k - 1][n - l - 1] *= deriv[j] * deriv[i];
          }
        }
        if (l == -1)
          l = 0;
        for (j = n - l - 1; j >= 0; j--) {
          bmat[j][n - k - 1] *= deriv[i];
          bmat[n - k - 1][j] = bmat[j][n - k - 1];
        }
      }
      }
    }
  }

  WITH1 = maletheta;
  FORLIM = mlocus - 2;
  /*Recombination*/
  for (i = 0; i <= FORLIM; i++)
    fprintf(stream, " %5.3f", WITH1->theta[i]);
  if (interfer)
    fprintf(stream, " %5.3f\n", maletheta->theta[mlocus - 1]);
  else
    putc('\n', stream);
  if (sexdif) {
    WITH1 = femaletheta;
    FORLIM = mlocus - 2;
    for (i = 0; i <= FORLIM; i++)
      fprintf(stream, " %5.3f", WITH1->theta[i]);
    if (interfer)
      fprintf(stream, " %5.3f\n", femaletheta->theta[mlocus - 1]);
    else
      putc('\n', stream);
    if (readfemale) {
      FORLIM = mlocus - 2;
      for (i = 0; i <= FORLIM; i++) {
      dist = getdist(&maletheta->theta[i]);
      if (dist != 0.0)
        dist = getdist(&femaletheta->theta[i]) / dist;
      else
        dist = 0.0;
      fprintf(stream, " %5.3f\n", dist);
      }
      if (interfer) {
      dist = getdist(&maletheta->theta[mlocus - 1]);
      if (dist != 0.0)
        dist = getdist(&femaletheta->theta[mlocus - 1]) / dist;
      else
        dist = 0.0;
      fprintf(stream, " %5.3f\n", dist);
      }
    } else
      fprintf(stream, "%5.3f\n", distratio);
  }

  /*Valid parameters or not*/
  /*Lod scores are valid only if penalty is false*/
  if (penalty)
    fprintf(stream, "1\n");
  else
    fprintf(stream, "0\n");
  /*Number of pedigrees*/
  fprintf(stream, "%12d\n", nuped);
  for (i = 0; i < nuped; i++)
    fprintf(stream, "%12d % .5e % .5e\n",
          proband[i]->ped, outsavelike[i], outsavelike[i] / log10_);
  /*Total lod-score*/
  fprintf(stream, "% .5e\n", (LINK->lods - f) / (2 * log10_));
  if (ivar == 1 && icall == 0) {
    for (i = 0; i < n; i++) {
      for (j = i; j < n; j++)
      fprintf(stream, " % .5e\n", 2.0 * bmat[i][j]);
      putc('\n', stream);
    }
  }
  /*Stop stream*/
  fprintf(stream, "~\n");

  /*sexdif=true and readfemale=false*/
}

Void outf()
{
  struct LOC_outf V;
  int i, j, k, l;
  double deriv[3];
  thetarray oldtheta;
  double dist;
  int FORLIM;
  locusvalues *WITH;
  int FORLIM1, FORLIM2;
  thetavalues *WITH1;
  double TEMP;
#if PARALLEL
  long finalnfe;
#endif /*PARALLEL*/

#if !defined(DOS)
  /* Shriram: begin */
  if ( normalRun == checkpointStatus )
  {
    funCallPath = fCP_outf ;
    performCheckpoint ( functionLocation , funCallPath , 0 ) ;

    fclose ( final ) ;
    copyFile ( "final.dat" , OutfILINKFinalDat ) ;
#ifdef vms
    final = fopen ( "final.dat" , "a", "ctx=rec","shr=get,put,upd" ) ;
#else
    final = fopen ( "final.dat" , "a" ) ;
#endif

    if ( dostream )
    {
      fclose ( stream ) ;
      copyFile ( "stream.dat" , OutfILINKStreamDat ) ;
#ifdef vms
      stream = fopen ( "stream.dat" , "a", "ctx=rec","shr=get,put,upd" ) ;
#else
      stream = fopen ( "stream.dat" , "a" ) ;
#endif
    }
  }
  else
  {
    if ( functionLocation == ckptTuple . ckptLocation )
    {
      recoverCheckpoint ( NULL ) ;

      fclose ( final ) ;
      copyFile ( OutfILINKFinalDat , "final.dat" ) ;
#ifdef vms
      final = fopen ( "final.dat" , "a", "ctx=rec","shr=get,put,upd" ) ;
#else
      final = fopen ( "final.dat" , "a" ) ;
#endif
      
      if ( dostream )
      {
        fclose ( stream ) ;
      copyFile ( OutfILINKStreamDat , "stream.dat" ) ;
#ifdef vms
        stream = fopen ( "stream.dat" , "a", "ctx=rec","shr=get,put,upd" ) ;
#else
        stream = fopen ( "stream.dat" , "a" ) ;
#endif
      }
    }
  }
  /* Shriram: end */
#endif

  firstapprox = true;
  lasttime = true;
  /*recover optimal x and f values, put x value into xall*/
  f = outsavefvalue;
  k = 0;
  for (i = 0; i < nall; i++) {
    if (itp[i] == 1) {
      k++;
      xall[i] = outsavex[k - 1];
    }
  }
  /*recover xall values into maletheta and femaletheta*/
  setparam();
  fprintf(final, "CHROMOSOME ORDER OF LOCI : \n");
  for (i = 1; i <= mlocus; i++) {
    j = 0;
    do {
      j++;
    } while (order[j - 1] != i);
    fprintf(final, "%3d", j);
  }
  putc('\n', final);
  if (itsys != 0) {
    fprintf(final, "****************** FINAL VALUES **********************\n");
    fprintf(final, "PROVIDED FOR LOCUS %3d (CHROMOSOME ORDER)\n",
          order[itsys - 1]);
    fprintf(final, "******************************************************\n");
    WITH = thislocus[itsys - 1];
    if (disequi) {
      fprintf(final, "HAPLOTYPE FREQUENCIES:\n");
      for (i = 0; i < nuhap; i++)
      fprintf(final, "%9.6f", hapfreq->genarray[i]);
    } else {
      fprintf(final, "GENE FREQUENCIES :\n");
      FORLIM = WITH->nallele;
      for (i = 0; i < FORLIM; i++)
      fprintf(final, "%9.6f", WITH->freq[i]);
      if (disfreqs && (binary_ == WITH->which)) {
      fprintf(final, "\nCONDITIONAL (on disease allele) GENE FREQUENCIES :\n");
      FORLIM = WITH->nallele;
      for (i = 0; i < FORLIM; i++)
        fprintf(final, "%9.6f", WITH->freqcond[i]);
      }
    }
    putc('\n', final);
    if (WITH->which == quantitative) {
      fprintf(final, "VALUES FOR GENOTYPE MEANS:\n");
      invert(WITH->UU.U1.vmat, WITH->UU.U1.ntrait, &WITH->UU.U1.det);
      FORLIM = WITH->UU.U1.ntrait;
      for (i = 0; i < FORLIM; i++) {
      FORLIM1 = WITH->nallele;
      for (j = 1; j <= FORLIM1; j++) {
        FORLIM2 = WITH->nallele;
        for (k = j - 1; k < FORLIM2; k++)
          fprintf(final, "%6.3f ", WITH->UU.U1.pm[j][k][i]);
      }
      putc('\n', final);
      }
      fprintf(final, "COVARIANCE MATRIX:\n");
      FORLIM = WITH->UU.U1.ntrait;
      for (i = 1; i <= FORLIM; i++) {
      for (j = 0; j < i; j++)
        fprintf(final, "%6.3f ", WITH->UU.U1.vmat[i - 1][j]);
      putc('\n', final);
      }
    } else {
      if (WITH->which == affection) {
      fprintf(final, "PENETRANCES:\n");
      FORLIM = WITH->UU.U0.nclass;
      for (l = 0; l < FORLIM; l++) {
        FORLIM1 = WITH->nallele;
        for (i = 1; i <= FORLIM1; i++) {
          FORLIM2 = WITH->nallele;
          for (j = i - 1; j < FORLIM2; j++)
            fprintf(final, "%5.3f ", WITH->UU.U0.pen[i][j][2][l]);
        }
        putc('\n', final);
        if (sexlink) {
          FORLIM1 = WITH->nallele;
          for (i = 0; i < FORLIM1; i++)
            fprintf(final, "%5.3f ", WITH->UU.U0.pen[0][i][2][l]);
        }
        putc('\n', final);
      }
      }
    }
  }
  fprintf(final, "******************************************************\n");
  if (interfer && !mapping) {
    fprintf(final, "P VALUES:\n");
    WITH1 = maletheta;
    memcpy(oldtheta, WITH1->theta, sizeof(thetarray));
    WITH1->theta[0] =
      (oldtheta[0] + oldtheta[mlocus - 1] - oldtheta[mlocus - 2]) / 2.0;
    WITH1->theta[mlocus - 2] =
      (oldtheta[mlocus - 2] + oldtheta[mlocus - 1] - oldtheta[0]) / 2.0;
    WITH1->theta[mlocus - 1] =
      (oldtheta[0] + oldtheta[mlocus - 2] - oldtheta[mlocus - 1]) / 2.0;
    for (i = 0; i < mlocus; i++)
      fprintf(final, " %5.3f", WITH1->theta[i]);
    putc('\n', final);
    memcpy(WITH1->theta, oldtheta, sizeof(thetarray));
    if (sexdif) {
      WITH1 = femaletheta;
      memcpy(oldtheta, WITH1->theta, sizeof(thetarray));
      WITH1->theta[0] =
      (oldtheta[0] + oldtheta[mlocus - 1] - oldtheta[mlocus - 2]) / 2.0;
      WITH1->theta[mlocus - 2] =
      (oldtheta[mlocus - 2] + oldtheta[mlocus - 1] - oldtheta[0]) / 2.0;
      WITH1->theta[mlocus - 1] =
      (oldtheta[0] + oldtheta[mlocus - 2] - oldtheta[mlocus - 1]) / 2.0;
      fprintf(final, "FEMALE: \n");
      for (i = 0; i < mlocus; i++)
      fprintf(final, " %5.3f", WITH1->theta[i]);
      putc('\n', final);
      memcpy(WITH1->theta, oldtheta, sizeof(thetarray));
    }
    if (ivar == 1 && icall == 0) {
      for (i = 0; i <= 2; i++) {
      TEMP = 1 + exp(xall[nall - i - 1]);
      deriv[i] = exp(xall[nall - i - 1]) / (TEMP * TEMP);
      }
      k = -1;
      for (i = 0; i <= 2; i++) {
      if (itp[nall - i - 1] == 1) {
        k++;
        l = -1;
        for (j = 0; j <= 2; j++) {
          if (itp[nall - j - 1] == 1) {
            l++;
            bmat[n - k - 1][n - l - 1] *= deriv[j] * deriv[i];
          }
        }
        if (l == -1)
          l = 0;
        for (j = n - l - 1; j >= 0; j--) {
          bmat[j][n - k - 1] *= deriv[i];
          bmat[n - k - 1][j] = bmat[j][n - k - 1];
        }
      }
      }
    }
  }
  fprintf(final, "THETAS:\n");
  WITH1 = maletheta;
  FORLIM = mlocus - 2;
  for (i = 0; i <= FORLIM; i++)
    fprintf(final, " %5.3f", WITH1->theta[i]);
  if (interfer)
    fprintf(final, " %5.3f\n", maletheta->theta[mlocus - 1]);
  else
    putc('\n', final);
  if (sexdif) {
    fprintf(final, "FEMALE:\n");
    WITH1 = femaletheta;
    FORLIM = mlocus - 2;
    for (i = 0; i <= FORLIM; i++)
      fprintf(final, " %5.3f", WITH1->theta[i]);
    if (interfer)
      fprintf(final, " %5.3f\n", femaletheta->theta[mlocus - 1]);
    else
      putc('\n', final);
    if (readfemale) {
      fprintf(final, "FEMALE/MALE DIST RATIO :\n");
      FORLIM = mlocus - 2;
      for (i = 0; i <= FORLIM; i++) {
      dist = getdist(&maletheta->theta[i]);
      if (dist != 0.0)
        dist = getdist(&femaletheta->theta[i]) / dist;
      else
        dist = 0.0;
      fprintf(final, " %5.3f", dist);
      }
      if (interfer) {
      dist = getdist(&maletheta->theta[mlocus - 1]);
      if (dist != 0.0)
        dist = getdist(&femaletheta->theta[mlocus - 1]) / dist;
      else
        dist = 0.0;
      fprintf(final, " %5.3f", dist);
      }
      putc('\n', final);
    } else {
      fprintf(final, "CONSTANT FEMALE/MALE DIST RATIO :\n");
      fprintf(final, "%5.3f\n", distratio);
    }
  }
  fprintf(final, "******************************************************\n");
  fprintf(final, "-2 LN(LIKE) = % .5e\n", f);
  getlods(&V.lods, x, &V);
  if (mlocus != 2)
    fprintf(final, "OTTS GENERALIZED LOD SCORE =% .5e\n",
          (V.lods - f) / (2 * log10_));
  else
    fprintf(final, "LOD SCORE =% .5e\n", (V.lods - f) / (2 * log10_));
  fprintf(final, "NUMBER OF ITERATIONS = %5d\n", nit);

#if PARALLEL
  finalnfe = nfe;
  for(i=0;i<maxn;i++)
    finalnfe +=gnfe[i];
  fprintf(final, "NUMBER OF FUNCTION EVALUATIONS = %5ld\n", finalnfe);
#else
  fprintf(final, "NUMBER OF FUNCTION EVALUATIONS = %5d\n", nfe);
#endif /*PARALLEL*/
  fprintf(final, "PTG = % .5e\n", ptg);
  idg++;
  fprintf(outfile, "EXIT CONDITION%12d\n", idg);
  switch (idg) {

  case 1:
    fprintf(outfile, "Maximum possible accuracy reached\n");
    break;

  case 2:
    fprintf(outfile, "Search direction no longer downhill\n");
    break;

  case 3:
    fprintf(outfile,
          "Accumulation of rounding error prevents further progress\n");
    break;

  case 4:
    fprintf(outfile,
      "All significant differences lost through cancellation in conditioning\n");
    break;

  case 5:
    fprintf(outfile, "Specified tolerance on normalized gradient met\n");
    break;

  case 6:
    fprintf(outfile, "Specified tolerance on gradient met\n");
    break;

  case 7:
    fprintf(outfile, "Maximum number of iterations reached\n");
    break;

  case 8:
    fprintf(outfile, "Excessive cancellation in gradient\n");
    break;
  }
  if (ivar == 1 && icall == 0) {
    fprintf(final, "VARIANCE-COVARIANCE OF THE ESTIMATES\n");
    if (interfer && !mapping)
      fprintf(final, "VALUES GIVEN FOR P VALUES\n");
    for (i = 0; i < n; i++) {
      for (j = 0; j < n; j++)
      fprintf(final, "% .5e ", 2.0 * bmat[i][j]);
      putc('\n', final);
    }
  }
  fprintf(final, "******************************************************\n");
  fprintf(final, "******************************************************\n");
  if (dostream)
    streamout(&V);
}


/* Local variables for step: */
struct LOC_step {             /* If this structure is changed,    */
  enum {                      /* some code may have to be altered */
    go_, exit1, exit2, exit3        /* in performCheckpoint() and       */
  } cont;                     /* recoverCheckpoint ().            */
} ;                           /*                        --Shriram */

Local Void firststep(LINK)
struct LOC_step *LINK;
{
  int i;

#if !defined(DOS)
  /* Shriram: begin */
  if ( normalRun == checkpointStatus )
  {
    funCallPath = fCP_gem_iter_st_first ;
    performCheckpoint ( functionLocation , funCallPath , LINK -> cont ) ;
  }
  else
  {
    if ( ( functionLocation == ckptTuple . ckptLocation )
        && ( fCP_gem_iter_st_first == ckptTuple . ckptAttribute ) )
    {
      recoverCheckpoint ( & LINK -> cont ) ;
      funCallPath = ckptTuple . ckptAttribute ;
    }
  }
  /* Shriram: end */
#endif

  sumt = 0.0;
  idg = 0;
  for (i = 0; i < n; i++) {
   /*printf("first %lf %lf %lf %lf\n", xt[i], x[i], t, p[i]);*/ /*Alex*/
    xt[i] = x[i] + t * p[i];
  }
  fun(&ft, xt);
  /*save likelihood values for later*/
  for (i=0; i < nuped; i++)
    outsavelike[i] = likebyped[i];
  nfe++;
}

Local Void decreaset(LINK)
struct LOC_step *LINK;
{
  int i;

#if !defined(DOS)
  /* Shriram: begin */
  if ( normalRun == checkpointStatus )
  {
    funCallPath = fCP_gem_iter_st_decr ;
    performCheckpoint ( functionLocation , funCallPath , LINK -> cont ) ;
  }
  else
  {
    if ( ( functionLocation == ckptTuple . ckptLocation )
        && ( fCP_gem_iter_st_decr == ckptTuple . ckptAttribute ) )
    {
      recoverCheckpoint ( & LINK -> cont ) ;
      funCallPath = ckptTuple . ckptAttribute ;
    }
  }
  /* Shriram: end */
#endif

  /*Modified by M. Lathrop 29/04/86 to trap tmin=0 problem*/
  if (tmin < small)
    tmin = small;
  LINK->cont = go_;
  while (LINK->cont == go_) {
    if (f - fsave == 0.0 && idif == 2)
      idg = 2;
    if (t < tmin) {
      LINK->cont = exit3;
      break;
    }
    t = 0.5 * t;
    for (i = 0; i < n; i++)
      xt[i] = x[i] + t * p[i];
    fun(&ft2, xt);
    nfe++;
    if (ft2 < f) {
      sumt += t;
      f = ft2;
      idg = 0;
      memcpy(x, xt, sizeof(vector));
      /*save likelihood values for later*/
      for (i=0; i < nuped; i++)
        outsavelike[i] = likebyped[i];
      if (sumt < tmin)
      LINK->cont = exit3;
      else
      LINK->cont = exit2;
      continue;
    }
    if (ft + f - ft2 - ft2 <= 0.0)
      scal = 0.1;
    else {
      scal = 1.0 + 0.5 * (f - ft) / (f + ft - ft2 - ft2);
      if (scal < 0.1)
      scal = 0.1;
    }
    t = scal * t;
    for (i = 0; i < n; i++)
      xt[i] = x[i] + t * p[i];
    fun(&ft, xt);
    nfe++;
    if (f <= ft)
      continue;
    sumt += t;
    idg = 0;
    f = ft;
    memcpy(x, xt, sizeof(vector));
    /*save likelihood values for later*/
    for (i=0; i < nuped; i++)
      outsavelike[i] = likebyped[i];
    if (t < tmin)
      LINK->cont = exit3;
    else
      LINK->cont = exit2;
  }
}

Local Void increaset(LINK)
struct LOC_step *LINK;
{
  int i, j;

#if !defined(DOS)
  /* Shriram: begin */
  if ( normalRun == checkpointStatus )
  {
    funCallPath = fCP_gem_iter_st_incr ;
    performCheckpoint ( functionLocation , funCallPath , LINK -> cont ) ;
  }
  else
  {
    if ( ( functionLocation == ckptTuple . ckptLocation )
        && ( fCP_gem_iter_st_incr == ckptTuple . ckptAttribute ) )
    {
      recoverCheckpoint ( & LINK -> cont ) ;
      funCallPath = ckptTuple . ckptAttribute ;
    }
  }
  /* Shriram: end */
#endif

  sumt += t;
  LINK->cont = go_;
  while (LINK->cont == go_) {
    twot = t + t;
    if (ibnd > 0 && tbnd >= 0.0 && twot > tbnd) {
      f = ft;
      memcpy(x, xt, sizeof(vector));
      fprintf(outfile, "****** ACTIVE BOUNDARY CONSTRAINT *****\n");
      LINK->cont = exit1;
      continue;
    }
    memcpy(x, xt, sizeof(vector));
    for (i = 0; i < n; i++)
      xt[i] = x[i] + t * p[i];
    fun(&f2t, xt);
    nfe++;
    if (f2t > ft) {
      f = ft;
      LINK->cont = exit2;
      break;
    }
    if (f2t + f - ft - ft < 0.0 || ft - f2t + curv * (ft - f) >= 0.0) {
      sumt += t;
      t += t;
      ft = f2t;
    } else {
      sumt += t;
      f = f2t;
      memcpy(x, xt, sizeof(vector));
      /*save likelihood values for later*/
      for (j=0; j < nuped; j++)
        outsavelike[i] = likebyped[i];
      LINK->cont = exit2;
    }
  }
}

static Void step()
{
  struct LOC_step V;

#if !defined(DOS)
  /* Shriram: begin */
  int    ckptFunCallPath = ckptTuple . ckptAttribute ;

  if ( ( checkpointedRun == checkpointStatus ) &&
      ( functionLocation == ckptTuple . ckptLocation ) )
  {
    if ( fCP_gem_iter_st_first == ckptFunCallPath )
      goto FunRecover3 ;
    else if ( fCP_gem_iter_st_decr == ckptFunCallPath )
      goto FunRecover4 ;
    else if ( fCP_gem_iter_st_incr == ckptFunCallPath )
      goto FunRecover5 ;
  }
  /* Shriram: end */
#endif
  firstapprox = true;
#if !defined(DOS)  /* cgh -- gcc */
 FunRecover3:
#endif  /* !defined(DOS) */
  firststep(&V);
  if (f > ft)
#if !defined(DOS)  /* cgh -- gcc */
 FunRecover5:
#endif  /* !defined(DOS) */
    increaset(&V);
  else
#if !defined(DOS)  /* cgh -- gcc */
 FunRecover4:
#endif  /* !defined(DOS) */
    decreaset(&V);
  if (V.cont == exit2)
    t = sumt;
  if (V.cont == exit3) {
    iret = 1;
    return;
  }
  memcpy(gsave, g, sizeof(vector));
  isw = 0;
  iret = 2;
}


/* Local variables for update: */
struct LOC_update {
  int j, jm1;
  boolean cont, dfp;
} ;

Local Void prep(LINK)
struct LOC_update *LINK;
{
  int i, k;

  iswup = 1;
  wtil[0] = -gsave[0];
  ztil[0] = y[0];
  for (k = 2; k <= n; k++) {
    wtil[k - 1] = -gsave[k - 1];
    ztil[k - 1] = y[k - 1];
    for (i = 0; i <= k - 2; i++) {
      tl[i][k - 1] = tl[k - 1][i];
      wtil[k - 1] -= tl[k - 1][i] * wtil[i];
      ztil[k - 1] -= tl[k - 1][i] * ztil[i];
    }
  }
  sb = 0.0;
  sc = 0.0;
  sd = 0.0;
  for (i = 0; i < n; i++) {
    sb += t * ztil[i] * wtil[i] / d[i];
    sc += t * t * wtil[i] * wtil[i] / d[i];
    sd += ztil[i] * ztil[i] / d[i];
  }
}

Local Void sr1update(LINK)
struct LOC_update *LINK;
{
  alpha = -1.0;
  if (sc - sb == 0.0 || sb - sd == 0.0 || sd - 2.0 * sb + sc == 0.0) {
    idg = 3;
    return;
  }
  sa = 1.0 / (sqrt(fabs(sc - sb)) * sqrt(fabs(sb - sd)));
  thet1 = ((sd - sb) * sa + 1.0) / (2.0 * sb - sd - sc);
  thet2 = sa + (sa * (sb - sc) + 1.0) / (sd - 2.0 * sb + sc);
}

Local Void sr2update(LINK)
struct LOC_update *LINK;
{
  aa = sb / sc - 2.0 * (sd / sb) + sd / sc;
  bb = sb / sc - 1.0;
  cc = 1.0 - sb / sd;
  del2 = bb * bb - aa * cc;
  LINK->dfp = true;
  if (del2 > 0.00000001) {
    LINK->dfp = false;
    del = sqrt(del2);
    alph1 = (del - bb) / aa;
    alph2 = (-bb - del) / aa;
    if (fabs(alph1) < fabs(alph2))
      alpha = alph1;
    else
      alpha = alph2;
    if (fabs(alpha) < 0.00001)
      LINK->dfp = true;
    else {
      sa = (alpha + 1.0) * (alpha + 1.0) + sc / sb -
         alpha * alpha * (sc / sb) * (sd / sb) - 1.0 + alpha * alpha * sd / sb;
      if (sa <= 0.0)
      sa = 0.0;
      else {
      sa = sqrt(sa);
      sa = 1.0 / (sa * sb);
      }
      rdiv = 1.0 / (alpha * alpha * sd + 2.0 * alpha * sb + sc);
      thet1 = -(sa * alpha * (alpha * sd + sb) + 1.0) * rdiv;
      thet2 = sa + (alpha * sa * (sc + alpha * sb) - alpha) * rdiv;
    }
  }
  if (!LINK->dfp)
    return;
  alpha = 0.0;
  sa = 1.0 / (sqrt(sb) * sqrt(sc));
  thet1 = -1.0 / sc;
  thet2 = sa;
}

Local Void getwzs(LINK)
struct LOC_update *LINK;
{
  int i, k;

  for (i = 0; i < n; i++) {
    w[i] = t * wtil[i] + alpha * ztil[i];
    z[i] = t * thet1 * wtil[i] + thet2 * ztil[i];
  }
  s[n - 1] = 0.0;
  for (k = 1; k < n; k++) {
    LINK->j = n - k + 1;
    LINK->jm1 = LINK->j - 1;
    s[LINK->jm1 - 1] = s[LINK->j - 1] +
                   w[LINK->j - 1] * w[LINK->j - 1] / d[LINK->j - 1];
  }
  nu = 1.0;
  eta = 0.0;
}

Local Void recur(LINK)
struct LOC_update *LINK;
{
  int i, k;

  LINK->cont = true;
  while (LINK->cont) {
    LINK->cont = false;
    if (iswup < 2) {
      for (i = 0; i < n; i++)
      wtjp1[i] = -gsave[i];
      memcpy(ztjp1, y, sizeof(vector));
    } else {
      for (i = 0; i < n; i++) {
      wtil[i] = alpha * y[i] - t * g[i];
      ztil[i] = thet2 * y[i] - t * thet1 * g[i];
      }
    }
    LINK->j = 0;
    lambj2 = 0.0;
    while (LINK->j < n - 1) {
      LINK->j++;
      if (iswup < 2) {
      for (k = LINK->j; k < n; k++) {
        wtjp1[k] -= wtil[LINK->j - 1] * tl[k][LINK->j - 1];
        ztjp1[k] -= ztil[LINK->j - 1] * tl[k][LINK->j - 1];
      }
      } else {
      for (k = LINK->j; k < n; k++) {
        wtjp1[k] = wtil[k] - w[LINK->j - 1] * tl[k][LINK->j - 1];
        ztjp1[k] = ztil[k] - z[LINK->j - 1] * tl[k][LINK->j - 1];
      }
      }
      aj = nu * z[LINK->j - 1] - eta * w[LINK->j - 1];
      thj = 1.0 + aj * w[LINK->j - 1] / d[LINK->j - 1];
      lambj2 = thj * thj + aj * aj * s[LINK->j - 1] / d[LINK->j - 1];
      if (iswup < 2) {
      if (lambj2 > 10.0) {
        LINK->cont = true;
        iswup = 2;
        for (k = 2; k <= n; k++) {
          for (i = 0; i <= k - 2; i++)
            tl[k - 1][i] = tl[i][k - 1];
        }
        LINK->j = n;
      }
      }
      if (LINK->cont)
      continue;
      dp[LINK->j - 1] = d[LINK->j - 1] * lambj2;
      lambj = sqrt(lambj2);
      if (thj > 0.0)
      lambj = -lambj;
      muj = thj - lambj;
      bj = thj * w[LINK->j - 1] + aj * s[LINK->j - 1];
      gamlj = bj * nu / (lambj2 * d[LINK->j - 1]);
      betlj = (aj - bj * eta) / (lambj2 * d[LINK->j - 1]);
      nu = -(nu / lambj);
      eta = -((eta + aj * aj / (muj * d[LINK->j - 1])) / lambj);
      if (iswup < 2) {
      for (k = LINK->j; k < n; k++)
        tl[k][LINK->j - 1] += t * (betlj + thet1 * gamlj) * wtjp1[k] +
                        (alpha * betlj + thet2 * gamlj) * ztjp1[k];
      } else {
      for (k = LINK->j; k < n; k++) {
        tl[k][LINK->j - 1] = tl[k][LINK->j - 1] / lambj2 + betlj * wtil[k] +
                         gamlj * ztil[k];
        wtil[k] = wtjp1[k];
        ztil[k] = ztjp1[k];
      }
      }
    }
  }
  aj = nu * z[n - 1] - eta * w[n - 1];
  lambj = 1.0 + aj * w[n - 1] / d[n - 1];
  dp[n - 1] = d[n - 1] * lambj * lambj;
  memcpy(d, dp, sizeof(vector));
}


/*UPDATE*/
static Void update()
{
  struct LOC_update V;

  prep(&V);
  if (sb < sc)
    fbcd = sb;
  else
    fbcd = sc;
  if (sd < fbcd)
    fbcd = sd;
  if (fbcd > small) {
    fbcd = 2.0 * sc * (sd / sb) / (sc + sd);
    if (fbcd < 1.0)
      sr1update(&V);
    else
      sr2update(&V);
  } else
    sr1update(&V);
  if (idg != 3) {
    getwzs(&V);
    recur(&V);
  }
}


Local Void bldlt(b)
vector *b;
{
  int i, j, ic, k;
  double su, tlic, ff, hh, temp, temp1;
  matrix s;
  vector tu, xvec;

  firstapprox = true;
  ff = f;
  if (icall > 0 && ihess <= 0) {
    memcpy(xvec, xall, sizeof(vector));
    hh = 10 * h;
    for (i = 0; i < n; i++) {
      temp = x[i];
      x[i] += hh;
      fun(&f, x);
      tu[i] = f;
      for (j = 0; j < i + 1; j++) {
      temp1 = x[j];
      x[j] += hh;
      fun(&f, x);
      b[i][j] = f;
      b[j][i] = b[i][j];
      x[j] = temp1;
      }
      x[i] = temp;
    }
    memcpy(xall, xvec, sizeof(vector));
    for (i = 0; i < n; i++) {
      for (j = 0; j < i + 1; j++) {
      b[i][j] = (ff + b[i][j] - tu[i] - tu[j]) / (hh * hh);
      b[j][i] = b[i][j];
      }
    }
  }
  ic = 1;
  while (b[ic - 1][ic - 1] > 0.0 && ic <= n) {
    temp = b[ic - 1][ic - 1];
    d[ic - 1] = b[ic - 1][ic - 1];
    tl[ic - 1][ic - 1] = 1.0;
    if (ic != n) {
      for (k = ic; k < n; k++)
      tl[k][ic - 1] = b[k][ic - 1] / temp;
      for (i = ic; i < n; i++) {
      tlic = tl[i][ic - 1];
      for (k = i; k < n; k++)
        b[k][i] -= tlic * tl[k][ic - 1] * temp;
      }
    }
    ic++;
  }
  if (ic > n) {
    icall--;
    fprintf(outfile, "FACTORIZATION SUCCEEDED\n");
  } else {
    icall++;
    fprintf(outfile, "FACTORIZATION FAILED\n");
  }
  if (icall != 0)
    return;
  s[0][0] = 1.0;
  for (i = 2; i <= n; i++) {
    for (k = 0; k <= i - 2; k++) {
      su = 0.0;
      for (j = k; j <= i - 2; j++)
      su += tl[i - 1][j] * s[j][k];
      s[i - 1][k] = -su;
    }
    s[i - 1][i - 1] = 1.0;
  }
  for (i = 0; i < n; i++) {
    for (j = i; j < n; j++) {
      su = 0.0;
      for (k = j; k < n; k++)
      su += s[k][i] * s[k][j] / d[k];
      b[i][j] = su;
      b[j][i] = su;
    }
  }
  fprintf(outfile, "B-MATRIX\n");
  for (i = 1; i <= n; i++) {
    for (j = 0; j < i; j++)
      fprintf(outfile, "% .5e", b[i - 1][j]);
    putc('\n', outfile);
  }
  if (ivar != 1)
    return;
  k = 0;
  for (i = 0; i < nall; i++) {
    se[i] = 0.0;
    if (itp[i] == 1) {
      k++;
      se[i] = sqrt(b[k - 1][k - 1]);
    }
  }
}

Local Void inib()
{
  int i, j;
  FILE *in1;

  in1 = NULL;
  if (icall != 1 && ihess > 1) {
    if (in1 != NULL)
      in1 = freopen("in1.dat", "r", in1);
    else
      in1 = fopen("in1.dat", "r");
    if (in1 == NULL)
      exit(FileNotFound);
    for (i = 1; i <= n; i++) {
      for (j = 0; j < i; j++)
      fscanf(in1, "%lf", &bmat[i - 1][j]);
    }
    for (i = 0; i < n; i++) {
      for (j = 0; j < i + 1; j++)
      bmat[j][i] = bmat[i][j];
    }
  }
  bldlt(bmat);
  if (icall == 1) {
    for (i = 0; i < n; i++) {
      for (j = 0; j < i + 1; j++)
      tl[i][j] = 0.0;
      tl[i][i] = 1.0;
      d[i] = 1.0;
    }
  }
  if (in1 != NULL)
    fclose(in1);
}

Local Void initilink()
{
  int i, j;

#if !defined(DOS)
  /* Shriram: begin */
  if ( normalRun == checkpointStatus )
  {
    funCallPath = fCP_gem_init ;
    performCheckpoint ( functionLocation , funCallPath , 0 ) ;
  }
  else
  {
    if ( ( functionLocation == ckptTuple . ckptLocation )
        && ( fCP_gem_init == ckptTuple . ckptAttribute ) )
    {
      recoverCheckpoint ( NULL ) ;
      funCallPath = ckptTuple . ckptAttribute ;
    }
  }
  /* Shriram: end */
#endif
  firstapprox = true;
  fprintf(outfile, "DIFFER INTER = % .5e TRUNC UPPER = % .5e\n",
        h, trupb);
  nit = 0;  /*Number of iterations*/
  idg = 0;  /*Exit condition*/
  idif = 1;
  t = 0.1;
  tmin = 0.0;
  fsmf = 0.0;

#if PARALLEL
  temprowfence = (fencearray *) Malloc(sizeof(fencearray));
  tempqfence = (fencearray *) Malloc(sizeof(fencearray));

  *secondfe = 0;
  *numNuclear = 0;
  *firstfe = 1;
#endif

  fun(&f, x);

#if PARALLEL
  /*If there are too many nuclear families (usually due to
  multiple loops), then dynamic load balancing should not be enabled*/
  if ((*numNuclear) <= MAXNUMFAM)
    *firstfe = 0;
  else
    *numNuclear = 0;
#endif
  /*save likelihood values for later*/
  for (i=0; i < nuped; i++)
    outsavelike[i] = likebyped[i];
  nfe = 1;
  for (i = 0; i < n; i++) {
    for (j = 0; j < i + 1; j++)
      tl[i][j] = 0.0;
    tl[i][i] = 1.0;
    d[i] = 1.0;
  }
  if (ihess <= 0)
    return;
  icall = 0;
  inib();
  icall = 1;
  t = 1.0;
}

#if PARALLEL

/*Figure out which processors will be masters for which theta evaluations*/
void AssignThetas()
{
    int i,j;
    int procNum;

    if((n >= Tmk_nprocs) || (continue_ == quit)) {  /* At least as many thetas as processors */
        *slavesPerGroup = 1;
      *numGroups = Tmk_nprocs;
    }
    else {                 /* More processors than thetas */
      for(i=2;i<=Tmk_nprocs;i++) {
          if((Tmk_nprocs % i) != 0)
            continue;
          if((Tmk_nprocs/i) <= n)
            break;
      }
      *slavesPerGroup = i;
      *numGroups = Tmk_nprocs/i;
    }
    *thetasPerGroup = n/(*numGroups);
    *nextTheta = (*numGroups) * (*thetasPerGroup);

    for(i=0, procNum=0; i<(*numGroups); i++)
      for(j=0; j<(*slavesPerGroup); j++, procNum++) {
        whoIsMyMaster[procNum] = i*(*slavesPerGroup);
        if(j == 0) {
          iAmAMaster[procNum] = true;
          thetanumbase[procNum] = i*(*thetasPerGroup);
          thetanumfence[procNum] = thetanumbase[procNum] + (*thetasPerGroup);
        }
        else
          iAmAMaster[procNum] = false;
      }
}

#endif

Void gforward()
{
  int i, k, FORLIM;
#if PARALLEL
  int j;
#endif
  /*The following declaration was introduced by A. A. Schaffer 7/27/94
  to fix a bug where the wrong xall was being used to move to the
  next theta*/
  double xallsave[maxn]; /*Save value of xall to recover it later*/

  firstapprox = true;
  outsavefvalue = f;
  saveparams();
  k = 0;
  for (i = 0; i < maxn; i++) {
    if (itp[i] == 1) {
      k++;
      xallsave[i] = outsavex[k - 1];
    }
    else
      xallsave[i] = xall[i];
  }

#if PARALLEL
#if DO_PARALLELTHETAS
  parallelThetas = 1;       /* Turn on parallel thetas */
  if(Tmk_proc_id == 0) {   /* If master, assign thetas, and setup global info */
      AssignThetas();
      if (continue_ == quit)
        *slavesPerGroup = 1;
      for(i=0;i<maxn;i++) {
        (*gx)[i] = x[i];
        (*gxall)[i] = xall[i];
          (*gitp)[i] = itp[i];
      }
      *gf = f;
      *checkmaster = 1;
#if BARRIER_OUTPUT
      barnum++;
      printf("(%d) Full barrier at beginning of gforward\n",barnum);
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM
      BARRIER(gMem->full_barrier,Tmk_nprocs);
#else
      Tmk_barrier(Tmk_mask);
#endif /*IS_SHMEM*/
  }
      firstapprox = false;

  for(j=0;j<maxn;j++) {        /* Make global info local */
      itp[j] = (*gitp)[j];
      x[j] = (*gx)[j];
      xall[j] = (*gxall)[j];
    }

/* Iterate over each theta */
  FORLIM = thetanumfence[Tmk_proc_id];
  for (i = thetanumbase[Tmk_proc_id]; i < FORLIM; i++) {
    eTimeIndex = i;
    /* schaffer && cgh -- indexing bugfix */
    if ((*slavesPerGroup) == Tmk_nprocs)
      currentthetanum = 0;
    else
      currentthetanum = i;
    thischild = gMem->gthischild[mymaster];
    pnonzgens = gpnonzgens[currentthetanum];
    qnonzgens = gqnonzgens[currentthetanum];
    hx = h;
    if (ihx == 1) {
      if (fabs(x[i]) < 0.1)
      hx = h * 0.1;
      else
      hx = h * fabs(x[i]);
    }

#if !PARALLEL_GCENTRAL
    fe = 0;
#endif /* !PARALLEL_GCENTRAL */

    x[i] += hx;
    if (continue_ != quit) {
      fun(&fxph, x);
      gnfe[i]++;
    }
    firstapprox = false;
    (*gg)[i] = (fxph - (*gf)) / hx;  /* Store slope value globally */
    for(j=0;j<maxn;j++) {
        x[j] = (*gx)[j];
        xall[j] = (*gxall)[j];
    }
  }

  parallelThetas = 0;   /* Turn off parallelthetas */
#else /*DO_PARALLELTHETAS*/
  *nextTheta = 0;
#endif /*DO_PARALLELTHETAS*/

  if(Tmk_proc_id == 0) {  /* Finish rest of thetas sequentially */
#if DO_PARALLELTHETAS
#if BARRIER_OUTPUT
    barnum++;
    printf("(%d) Full barrier at end of gforward\n",barnum);
#endif
#if IS_SHMEM
    BARRIER(gMem->full_barrier,Tmk_nprocs);
#else
    Tmk_barrier(Tmk_mask);/* Wait for everybody to finish */
#endif /*IS_SHMEM*/
#endif /*DO_PARALLELTHETAS*/
#if DO_PARALLELTHETAS
#if FUNTIMES
    if (continue_ != quit) {
      for(i=0;i<*nextTheta;i++) {
#if PARALLEL_GCENTRAL
      printf("Execution time (likelihood evaluation done by %d processor(s)) for %d = %7.3f\n", *(slavesPerGroup),i,executionTimes[i]);
#else /* !PARALLEL_GCENTRAL */
      printf("Execution time (likelihood evaluation done by %d processor(s)) for %d = %7.3f\n", *(slavesPerGroup),i,executionTimes[i][0]);
#endif /* PARALLEL_GCENTRAL */
      fflush(stdout);
      }
    }
#endif /*FUNTIMES*/
#endif /*DO_PARALLELTHETAS*/
    if(*nextTheta < n) {
      for (i = *nextTheta; i < n; i++) {
        hx = h;
        if (ihx == 1) {
          if (fabs(x[i]) < 0.1)
          hx = h * 0.1;
          else
          hx = h * fabs(x[i]);
        }

        x[i] += hx;
      if (continue_ != quit) {
        fun(&fxph, x);
        gnfe[i]++;
      }
        firstapprox = false;
        (*gg)[i] = (fxph - f) / hx;
        x[i] -= hx;

/*        for(j=0;j<maxn;j++) {
          x[j] = (*gx)[j];
            xall[j] = (*gxall)[j];
        }*/
      }
    }
    for(j=0;j<maxn;j++)
      g[j] = (*gg)[j];
  }
#else /*!PARALLEL*/

  for (i = 0; i < n; i++) {
#if !defined(DOS)
    /* Shriram: begin */
    if ( normalRun == checkpointStatus )
    {
      if ( fCP_gem_iter_ == funCallPath )
        funCallPath = fCP_gem_iter_gfor ;
      else if ( fCP_gem_ == funCallPath )
        funCallPath = fCP_gem_gfor ;
      performCheckpoint ( functionLocation , funCallPath , i ) ;
    }
    else if ( ( functionLocation == ckptTuple . ckptLocation ) &&
             ( ( fCP_gem_iter_gfor == ckptTuple . ckptAttribute ) ||
              ( fCP_gem_gfor == ckptTuple . ckptAttribute ) ) )
    {
      recoverCheckpoint ( & i ) ;
      if ( i >= n )
        break ;
      funCallPath = ckptTuple . ckptAttribute ;
    }
    /* Shriram: end */
#endif
    hx = h;
    if (ihx == 1) {
      if (fabs(x[i]) < 0.1)
      hx = h * 0.1;
      else
      hx = h * fabs(x[i]);
    }
    xsave = x[i];
    x[i] += hx;
    if (continue_ != quit) {
      fun(&fxph, x);
      savedf[i] = fxph;
    }
    else
      fxph = savedf[i];
    firstapprox = false;
    g[i] = (fxph - f) / hx;
    x[i] = xsave;
  }
  if (continue_ != quit)
    nfe += n;
#endif /*PARALLEL*/
  for (i = 0; i < maxn; i++)
    xall[i] = xallsave[i];

}

void gcentral()
{  /* B+1*/
  int i, k, FORLIM;
  double xallsave[maxn]; /*see similar declaration in gforward, above*/
#if PARALLEL
  int j;
#endif

  firstapprox = true;
  outsavefvalue = f;
  saveparams();
  k = 0;
  for (i = 0; i < maxn; i++) { /*B+2*/
    if (itp[i] == 1) { /*B + 3*/
      k++;
      xallsave[i] = outsavex[k - 1];
    } /*B+2*/
    else
      xallsave[i] = xall[i];
  } /*B+1*/

#if PARALLEL
#if DO_PARALLELTHETAS
  parallelThetas = 1;        /* Turn on parallel thetas */
  *usecentral = 1;

  if(Tmk_proc_id == 0) { /*B+2*/
#if PARALLEL_GCENTRAL
      n=n*2;                 /* Double number of fun calls */
#endif /* PARALLEL_GCENTRAL */
      AssignThetas();
      if (continue_ == quit)
      /* cgh -- gcc found this: used to be *slavesPerGroup == 1 */
      *slavesPerGroup = 1;
#if PARALLEL_GCENTRAL
      n=n/2;                 /* Fix value of n */
#endif /* PARALLEL_GCENTRAL */
      for(i=0;i<maxn;i++) {      /* Setup global variables */ /*B+3*/
          (*gx)[i] = x[i];
          (*gxall)[i] = xall[i];
          (*gitp)[i] = itp[i];
      } /*B+2*/
      *gf = f;
      *checkmaster = 1;
#if BARRIER_OUTPUT
      barnum++;
      printf("(%d) Full barrier at beginning of gcentral\n",barnum);
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM 
      BARRIER(gMem->full_barrier,Tmk_nprocs);
#else /*!IS_SHMEM*/
      Tmk_barrier(Tmk_mask);
#endif /*IS_SHMEM*/
      firstapprox = true;
  } /*B+1*/
  else
      firstapprox = false;

  for(j=0;j<maxn;j++) { /*B+2*/
      itp[j] = (*gitp)[j];
      x[j] = (*gx)[j];
      xall[j] = (*gxall)[j];
  } /*B+2*/

/* Make fun call for each assigned theta */
  FORLIM = thetanumfence[Tmk_proc_id];
  for (i = thetanumbase[Tmk_proc_id]; i < FORLIM; i++) { /*B+2*/
    eTimeIndex = i;
    /* schaffer && cgh -- indexing bugfix */
    if ((*slavesPerGroup) == Tmk_nprocs)
      currentthetanum = 0;
    else
      currentthetanum = i;

    thischild = gMem->gthischild[mymaster];
    pnonzgens = gpnonzgens[currentthetanum];
    qnonzgens = gqnonzgens[currentthetanum];
    hx = h;
    if (ihx == 1) { /*B+3*/
#if PARALLEL_GCENTRAL
      if (fabs(x[i/2]) < 0.1)
#else /* !PARALLEL_GCENTRAL */
      if (fabs(x[i]) < 0.1)
#endif /* PARALLEL_GCENTRAL */
      hx = h * 0.1;
      else
#if PARALLEL_GCENTRAL
      hx = h * fabs(x[i/2]);
#else /* !PARALLEL_GCENTRAL */
      hx = h * fabs(x[i]);
#endif /* PARALLEL_GCENTRAL */
    } /*B+2*/
#if PARALLEL_GCENTRAL
    if((i%2) == 0) { /* doing first fe */ /*B+3*/
      x[i/2] += hx;
      if (continue_ != quit) {
      fun(&fxph, x);
      gcentralf[i/2][0] = fxph;      /* Store fun value */
      gnfe[i/2]+=2;
      }
    } /*B+2*/
    else { /* fe == 1, doing second fe */ /*B+3*/
      firstapprox = false;
      x[i/2] -= hx;
      if (continue_ != quit) {
      fun(&fxmh, x);
      gcentralf[i/2][1] = fxmh;     /* Store fun value */
      }
    } /*B+2*/
       
#else /* !PARALLEL_GCENTRAL */
    xsave = x[i];
    x[i] += hx;
    fe = 0;
    if (continue_ != quit) {
      fun(&fxph, x);
      gnfe[i]++;
    }
    firstapprox = false;
    x[i] = xsave - hx;
    fe = 1;
    if (continue_ != quit) {
      fun(&fxmh, x);
      gnfe[i]++;
      (*gg)[i] = (fxph - fxmh) / (hx + hx);
    }
#endif /* PARALLEL_GCENTRAL */
    for(j=0;j<maxn;j++) { /*B+3*/
      x[j] = (*gx)[j];
      xall[j] = (*gxall)[j];
    } /*B+2*/
  } /*B+1*/

  parallelThetas = 0;       /* Turn off parallel thetas */
#else /*!DO_PARALLELTHETAS*/
  *nextTheta = 0;
#endif

  if(Tmk_proc_id == 0) {  /* Finish rest of thetas sequentially */ /*B+2*/
#if DO_PARALLELTHETAS
    *usecentral = 0;
#if BARRIER_OUTPUT
    barnum++;
    printf("(%d) Full barrier at end of gcentral\n",barnum);
#endif /*BARRIER_OUTPUT*/
#if IS_SHMEM
    BARRIER(gMem->full_barrier,Tmk_nprocs);
#else
    Tmk_barrier(Tmk_mask);/* Wait for everybody to finish */
#endif /*IS_SHMEM*/
#endif /*DO_PARALLELTHETAS*/
#if DO_PARALLELTHETAS
#if FUNTIMES
    if (continue_ != quit) {
      for(i=0;i<*nextTheta;i++) { /*B+3*/
#if PARALLEL_GCENTRAL
      printf("Execution time (likelihood evaluation done by %d processor(s)) for %d,%d = %7.3f\n",*(slavesPerGroup),i/2,(i%2)+1,executionTimes[i]);
#else /* !PARALLEL_GCENTRAL */
      printf("Execution time (likelihood evaluation done by %d processor(s)) for %d,1 = %7.3f\n",*(slavesPerGroup),i,executionTimes[i][0]);
      printf("Execution time (likelihood evaluation done by %d processor(s)) for %d,2 = %7.3f\n",*slavesPerGroup,i,executionTimes[i][1]);
#endif /* PARALLEL_GCENTRAL */
      fflush(stdout);
      } /*B+3*/
    }
#endif /*FUNTIMES*/
#endif /*DO_PARALLELTHETAS*/
#if PARALLEL_GCENTRAL
    if(*nextTheta < 2*n) { /*B+3*/
      for (i = *nextTheta; i < (2*n); i++) { /*B+4*/
#else /* !PARALLEL_GCENTRAL */
    if(*nextTheta < n) { /*B+3*/
      for (i = *nextTheta; i < n; i++) { /*B+4*/
#endif /* PARALLEL_GCENTRAL */
        hx = h;
        if (ihx == 1) { /*B+5*/
#if PARALLEL_GCENTRAL
          if (fabs(x[i/2]) < 0.1)
#else /* !PARALLEL_GCENTRAL */
          if (fabs(x[i]) < 0.1)
#endif /* PARALLEL_GCENTRAL */
            hx = h * 0.1;
          else
#if PARALLEL_GCENTRAL
            hx = h * fabs(x[i/2]);
#else /* !PARALLEL_GCENTRAL */
            hx = h * fabs(x[i]);
#endif /* PARALLEL_GCENTRAL */
        } /*B+5*/

#if PARALLEL_GCENTRAL
        if((i%2) == 0) { /* doing first fe */ /*B+5*/
          x[i/2] += hx;
          if (continue_ != quit) {
          fun(&fxph, x);
          gcentralf[i/2][0] = fxph;
          gnfe[i/2]+=2;
        }
          x[i/2] -= hx;
        } /*B+5 */
        else { /* fe == 1 */ /*B+5*/
          firstapprox = false;
          x[i/2] -= hx;
          if (continue_ != quit) {
          fun(&fxmh, x);
          gcentralf[i/2][1] = fxmh;
        }
          x[i/2] += hx;
        } /*B+5*/
#else /* !PARALLEL_GCENTRAL */
        xsave = x[i];
        x[i] += hx;
        if (continue_ != quit) {
        fun(&fxph, x);
        gnfe[i]++;
        }
        firstapprox = false;
        x[i] = xsave - hx;
        if (continue_ != quit) {
        fun(&fxmh, x);
        gnfe[i]++;
        (*gg)[i] = (fxph - fxmh) / (hx + hx);
        }
        x[i] = xsave;
#endif /* PARALLEL_GCENTRAL */
/*        for(j=0;j<maxn;j++) {
            x[j] = (*gx)[j];
            xall[j] = (*gxall)[j];
        }*/
      } /*B+4*/
    } /*B+3*/
#if PARALLEL_GCENTRAL
/* Calculate slopes from global fs */
    for(j=0;j<maxn;j++) { /*B+3*/
      hx = h;
      if (ihx == 1) { /*B+4*/
        if (fabs(x[j]) < 0.1)
          hx = h * 0.1;
        else
          hx = h * fabs(x[j]);
      } /*B+4*/
      g[j] = (gcentralf[j][0] - gcentralf[j][1]) / (hx + hx);
    } /*B+3*/
#else /* !PARALLEL_GCENTRAL */
    for(j=0;j<maxn;j++)
      g[j] = (*gg)[j];
#endif /* PARALLEL_GCENTRAL */
  } /*B+2*/
#else /*!PARALLEL*/
  for (i = 0; i < n; i++) { /*B+2*/
#if !defined (DOS)
    /* Shriram: begin */
    if ( normalRun == checkpointStatus ) 
    { /*B+3*/
      if ( fCP_gem_iter_gcen1_ == funCallPath )
        funCallPath = fCP_gem_iter_gcen1 ;
      else if ( fCP_gem_iter_gcen2_ == funCallPath )
        funCallPath = fCP_gem_iter_gcen2 ;
      performCheckpoint ( functionLocation , funCallPath, i ) ;
    } /*B+4*/
    else if ( ( functionLocation == ckptTuple . ckptLocation ) &&
             ( ( fCP_gem_iter_gcen1 == ckptTuple . ckptAttribute ) ||
              ( fCP_gem_iter_gcen2 == ckptTuple . ckptAttribute ) ) )
    { /*B+3*/
      recoverCheckpoint ( & i ) ;
      if ( i >= n )
        break ;
      funCallPath = ckptTuple . ckptAttribute ;
    } /*B+3*/
    /* Shriram: end */
#endif
    hx = h;
    if (ihx == 1) { /*B+3*/
      if (fabs(x[i]) < 0.1)
      hx = h * 0.1;
      else
      hx = h * fabs(x[i]);
    } /*B+3*/
    xsave = x[i];
    x[i] += hx;
    if (continue_ != quit) { /*B+3*/
       fun(&fxph, x);
       savedf[2*i] = fxph;
    } /*B+3*/
    else
      fxph = savedf[2*i];
    firstapprox = false;
    x[i] = xsave - hx;
    if (continue_ != quit) { /*B+3*/
       fun(&fxmh, x);
       savedf[2 * i + 1] = fxmh;
    } /*B+3*/
    else
      fxmh = savedf[2 * i + 1];
    g[i] = (fxph - fxmh) / (hx + hx);
    x[i] = xsave;
  } /*B+2*/
  if (continue_ != quit)
    nfe += 2 * n ;                  /* Shriram */
#endif
  for (i = 0; i < maxn; i++)
     xall[i] = xallsave[i];
}

Local Void getp()
{
  int i, nmj, j;
#if PARALLEL
  int currentnfe;
#endif

  nit++;
  fsav2 = fsave;
  fsave = f;

#if PARALLEL
  currentnfe = nfe;
  for(i=0;i<maxn;i++)
    currentnfe += gnfe[i];
#endif

#if PARALLEL
  fprintf(outfile, "\nITERATION %5d T = %10.3f NFE = %5d F = % .5e\n",
        nit, t, currentnfe, f);
  printf("ITERATION %5d T = %10.3f NFE = %5d F = % .5e\n",
       nit, t, currentnfe, f);
#else
  fprintf(outfile, "\nITERATION %5d T = %10.3f NFE = %5d F = % .5e\n",
        nit, t, nfe, f);
  printf("ITERATION %5d T = %10.3f NFE = %5d F = % .5e\n",
       nit, t, nfe, f);
#endif
  fflush(stdout);
  if (nit > maxit) {
    idg = 6;
    return;
  }
  if (n < 20) {
    fprintf(outfile, "X= ");
    outcontrol(x);
    fprintf(outfile, "G= ");
    outcontrol(g);
  }
  if (n == 1)
    p[0] = -(g[0] / d[0]);
  else {
    v[0] = -g[0];
    for (i = 2; i <= n; i++) {
      v[i - 1] = -g[i - 1];
      for (j = 0; j <= i - 2; j++)
      v[i - 1] -= tl[i - 1][j] * v[j];
    }
    p[n - 1] = v[n - 1] / d[n - 1];
    for (j = 1; j < n; j++) {
      nmj = n - j;
      p[nmj - 1] = v[nmj - 1] / d[nmj - 1];
      for (i = nmj; i < n; i++)
      p[nmj - 1] -= tl[i][nmj - 1] * p[i];
    }
  }
  fprintf(outfile, "P= ");
  outcontrol(p);
  if (ibnd == 1) {
    for (i = 0; i < n; i++) {
      if (p[i] == 0.0)
      idg = 7;
    }
  }
  if (idg == 7)
    return;
  ptg = 0.0;
  for (i = 0; i < n; i++)
    ptg += p[i] * g[i];
  if (ptg >= 0.0) {
    idg = 1;
    return;
  }
  if (fabs(ptg) < tol) {
    idg = 4;
    fsmf = fsav2 - f;
    fprintf(outfile, "FSMF = % .5e PTG = % .5e TMIN = % .5e\n",
          fsmf, ptg, tmin);
    return;
  }
  xpm = xpmcon;
  if (nit == 1)
    return;
  for (i = 0; i < n; i++) {
    if (ihx == 1) {
      xp = fabs(x[i]);
      if (xp < 0.1)
      xp = 0.1;
      xp /= fabs(p[i]);
      if (xp < xpm)
      xpm = xp;
    } else {
      if (xpm > fabs(1.0 / p[i]))
      xpm = fabs(1.0 / p[i]);
    }
  }
  tmin = 0.5 * xpm * h / trupb;
  if (idif == 2)
    t = 1.0;
  else {
    t = -2.0 * fsmf / ptg;
    if (t <= 0.0)
      t = 1.0;
    else {
      if (1.0 < t)
      t = 1.0;
    }
  }
  fprintf(outfile, "FSMF = % .5e PTG =% .5e TMIN=% .5e\n",
        fsmf, ptg, tmin);
  fprintf(outfile, "INITIAL T = % .5e\n", t);
}

Local Void getytp()
{
  int i;

  ytp = 0.0;
  fsmf = fsave - f;
  for (i = 0; i < n; i++) {
    y[i] = g[i] - gsave[i];
    ytp += y[i] * p[i];
  }
}

Local Void chkbnd()
{
  /*This procedure modified by M. Lathrop 29/04/86
    with the introduction of continue and repeat*/
  int i, j, k, ik, ii, jk;
  boolean continue_;

  /* cgh -- gcc warning fix */
  ii = ik = jk = 0;
  
  do {
    clb = clbcon;
    for (j = 1; j <= 2; j++) {
      k = 0;
      for (i = 1; i <= nall; i++) {
      if (itp[i - 1] == 1) {
        k++;
        check = fabs(x[k - 1] - bnd[i - 1][j - 1]);
        if (check <= clb) {
          clb = check;
          ik = k;
          ii = i;
          jk = j;
        }
      }
      }
    }
    if (clb < 0.1 * h) {
      ihess = 0;
      if (jk == 2)
      eh = -h - h;
      else
      eh = h + h;
      x[ik - 1] = bnd[ii - 1][jk - 1] + eh;
      xall[ii - 1] = x[ik - 1];
      itp[ii - 1] = 0;
      /*slide down saved x*/
      for(k = ik; k < nall; k++)
        outsavex[k-1] = outsavex[k];
      k = 0;
      for (i = 0; i < nall; i++) {
      if (itp[i] == 1) {
        k++;
        x[k - 1] = xall[i];
      }
      }
      n = k;
      tol = tolconst;
      /*      tol:=tolconst*sqrt(n);*/
      continue_ = true;
      fprintf(outfile, "******* A VARIABLE WAS SET TO A BOUND ***********\n");
    } else {
      tbnd = tbndcon;
      for (j = 0; j <= 1; j++) {
      k = 0;
      for (i = 0; i < nall; i++) {
        if (itp[i] == 1) {
          k++;
          teq = (bnd[i][j] - x[k - 1]) / p[k - 1];
          if (teq < tbnd && teq > 0.0)
            tbnd = teq;
        }
      }
      }
      continue_ = false;
      if (t * (2.0 + h) >= tbnd)
      t = tbnd * (0.5 - h);
      fprintf(outfile, "TBND = % .5e RESET T = % .5e\n", tbnd, t);
    }
  } while (continue_);
}

Local Void iterate()
{
#if !defined(DOS)
  /* Shriram: begin */
  int  ckptFunCallPath = ckptTuple . ckptAttribute ;

  if ( normalRun == checkpointStatus )
    funCallPath = fCP_gem_iter_ ;
  /* Shriram: end */
#endif

#if PARALLLEL
#if DO_LOADBALANCE
  if (0 == (*firstfe))  /*changes by AAS to handle multiple loops*/
    *secondfe = 1;
#endif /*DO_LOADBALANCE*/
#endif /*PARALLEL*/
  while (continue_ == go) {
    active = false;
#if !defined(DOS)
    /* Shriram: begin */
    if ( checkpointedRun == checkpointStatus )
    {
      if ( iterationLocation == ckptTuple . ckptLocation )
        checkpointStatus = normalRun ;
      else      /* checkpointedRun AND functionLocation */
      {
        if ( ( fCP_gem_iter_st_first == ckptFunCallPath ) ||
            ( fCP_gem_iter_st_decr == ckptFunCallPath ) ||
            ( fCP_gem_iter_st_incr == ckptFunCallPath ) )
          goto FunRecover345 ;
        else if ( fCP_gem_iter_gcen1 == ckptFunCallPath )
          goto FunRecover6 ;
        else if ( fCP_gem_iter_gfor == ckptFunCallPath )
          goto FunRecover7 ;
        else if ( fCP_gem_iter_gcen2 == ckptFunCallPath )
          goto FunRecover9 ;
      }
    }
    else
      performCheckpoint ( iterationLocation , nit , 0 ) ;
#endif
    getp();
    /* Shriram: end */
    if (idg != 0)
      continue_ = quit;
    else  {   /*idg == 0*/          /*Shriram*/
      iret = 2;
      if (ibnd == 1)
      chkbnd();
      if (n == 0)
      continue_ = quit;
      if (!active)
      {
#if !defined(DOS)
      FunRecover345:
#endif
      step();
#if !defined(DOS)
      funCallPath = fCP_gem_iter_ ;
#endif
      }
    }
    /* THE NEXT IS NOT TRUE IF ACTIVE */
    if (iret != 2) {
      if (idif != 1) {
      continue_ = quit;
      break;
      }
      idif = 2;
      isw = 1;
#if !defined(DOS)
    FunRecover9:
      funCallPath = fCP_gem_iter_gcen2_ ;
#endif
      gcentral();
#if !defined(DOS)
      funCallPath = fCP_gem_iter_ ;
#endif
      fprintf(outfile, "***** SWITCHING TO CENTRAL DIFFERERENCE*****\n");
      continue;
    }
    if (active) {
      continue_ = restart;
      break;
    }
    if (idif == 1)
    {
#if !defined(DOS)
    FunRecover7:
      funCallPath = fCP_gem_iter_gfor ;
#endif
#if PARALLEL
    *usecentral = 0;
#endif
      gforward();
#if !defined(DOS)
      funCallPath = fCP_gem_iter_ ;
#endif
    }
    else
    {
#if !defined(DOS)
    FunRecover6:
      funCallPath = fCP_gem_iter_gcen1_ ;
#endif
      gcentral();
#if !defined(DOS)
      funCallPath = fCP_gem_iter_ ;
#endif
    }
    if (isw != 0)
      continue;
    getytp();
    if (ytp <= 0.0)
      continue;
    if (n == 1)
      d[0] = -(y[0] * d[0] / (t * gsave[0]));
    else
      update();
    if (idg == 3)
      continue_ = quit;
  }
}


/*START GEMINI*/
Void gemini()
{
#if !defined(DOS)
  /* Shriram: begin */
  int  ckptFunCallPath = ckptTuple . ckptAttribute ;
  
  if ( normalRun == checkpointStatus )
    funCallPath = fCP_gem_ ;
  /* Shriram: end */
#endif

  continue_ = go;
  while (continue_ != quit) {
#if !defined(DOS)
    /* Shriram: begin */
    if ( ( checkpointedRun == checkpointStatus ) &&
         ( iterationLocation == ckptTuple . ckptLocation ) )
      recoverCheckpoint ( NULL ) ;
    else
    {
      if ( checkpointedRun == checkpointStatus )
      {
        /* must be a functionLocation checkpoint, but which? */
        if ( fCP_gem_init == ckptFunCallPath )
          goto FunRecover2 ;
        else if ( ( fCP_gem_iter_st_first == ckptFunCallPath ) ||
                  ( fCP_gem_iter_st_decr == ckptFunCallPath ) ||
                  ( fCP_gem_iter_st_incr == ckptFunCallPath ) ||
                  ( fCP_gem_iter_gcen1 == ckptFunCallPath ) ||
                  ( fCP_gem_iter_gcen2 == ckptFunCallPath ) ||
                  ( fCP_gem_iter_gfor == ckptFunCallPath ) )
          goto FunRecover34567 ;
        else if ( fCP_gem_gfor == ckptFunCallPath )
          goto FunRecover8 ;
      }
    FunRecover2:
#endif
      initilink();
#if !defined(DOS)
      funCallPath = fCP_gem_ ;
    FunRecover8:
#endif
      isw = 0;
      gforward();
#if !defined(DOS)
      funCallPath = fCP_gem_ ;
    }
#endif
    /* Shriram: end */
    continue_ = go;
#if !defined(DOS)
  FunRecover34567:
#endif
    iterate();
#if !defined(DOS)
    funCallPath = fCP_gem_ ;
#endif
  }
  if (ivar == 1)
    inib();
}


main(argc, argv)
int argc;
char *argv[];
{
#if PARALLEL  /* cgh */
  parStartup(argc, argv);
#else
  seqStartup(argc, argv);
#endif /* if PARALLEL -- cgh */

  init_ped_loc_all(); /* dwix */
#if LOOPSPEED  /*Dylan*/
  ever_read_loopfile = false;
#endif
  openFiles();
  
#if !defined(DOS)
  ckptInit();
#endif  /* !defined(DOS) */

#if PARALLEL
#if !IS_SHMEM
  if (reportMemStats == false)
    gMemAndBarrierAlloc();
#endif  /* !IS_SHMEM */
  allocthetas();    /* this must be done before inputdata() */
#endif  /* PARALLEL */
  
  inputdata();
  initParams();

#if PARALLEL  /* cgh */
  if (Tmk_proc_id == 0)
    checkNotImplemented();
#endif  /* if PARALLEL -- cgh */
  
#if !defined(DOS)
  ckptEnsureFileContents();
#endif  /* !defined(DOS) */

  miscInit();
#if !ALLELE_SPEED
  allocategenetables();
  getlocations();
#endif
  getgeneindices(); /* R. M. Idury */
  allocate_loopbreaker_vectors(); /*A. A. Schaffer*/
  closeInputFiles();
#if PARALLEL
  if (0 == maxworkingset) {   /*number was not input by user*/
    maxworkingset = maxw_estimation();
    if (Tmk_proc_id == 0)
      printf("\nEstimating %d for maxworkingset\n", maxworkingset);
  }
  else 
    printf("\nOverriding computed value of maxworkingset with input value %d\n",maxworkingset);
#endif

#if PARALLEL  
  if (Tmk_proc_id == 0) {
    initParLib(argc, argv);

#if IS_SHMEM  
    gMemAndBarrierAlloc();
#endif  /* IS_SHMEM */

    allocgen();  /*Added by Alex*/
#if PRECOMPUTE
    allocprob();
#endif  /* PRECOMPUTE */
    parThetaSetup();
  }
#endif /*PARALLEL*/

#if !defined(DOS)
  /* Shriram: begin */
  if ((checkpointedRun != checkpointStatus) ||
      (functionLocation != ckptTuple.ckptLocation) ||
      (fCP_outf != ckptTuple.ckptAttribute)) {
    ; /* just in case PARALLEL is set, we can't have
       an if with no body -- cgh */
  /* Shriram: end */
#endif
#if !PARALLEL
    gemini();
#endif  /* !PARALLEL */
#if !defined(DOS)
  }
#endif  /* !defined(DOS) */
#if !PARALLEL
  outf();
#endif  /* !PARALLEL */

#if PARALLEL
  childLoop();
  if (Tmk_proc_id == 0)
#endif /*PARALLEL*/
    closeOutputFiles();

#if !defined(DOS)
  ckptCleanup();
#endif  /* !defined(DOS) */

#if PARALLEL  /* cgh */
  parFinish();
#endif  /* if PARALLEL -- cgh */

  exit(EXIT_SUCCESS);
}


/* End. */




Generated by  Doxygen 1.6.0   Back to index