field-smob.c

麻省理工的计算光子晶体的程序

/* Copyright (C) 1999, 2000, 2001, 2002, 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
 */

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

#include "../src/config.h"

#include <check.h>
#include <mpiglue.h>
#include <mpi_utils.h>

#include "field-smob.h"

#include "mpb.h"

/* null mark function, for smobs containing no SCM objects */
static SCM mark_null(SCM obj) { (void) obj; return SCM_BOOL_F; }

/*************************************************************************/

long scm_tc16_smob_field_smob = 0;

static SCM field_p(SCM obj)
{
     return gh_bool2scm(FIELD_P(obj));
}

static SCM rscalar_field_p(SCM obj)
{
     return gh_bool2scm(RSCALAR_FIELD_P(obj));
}

static SCM cvector_field_p(SCM obj)
{
     return gh_bool2scm(CVECTOR_FIELD_P(obj));
}

static int print_field_smob(SCM obj, SCM port, scm_print_state *pstate)
{
     char buf[256];
     field_smob *pf = FIELD(obj);
     (void) pstate; /* unused argument */

     scm_puts("#<field ", port);
     sprintf(buf, "%dx%dx%d", pf->nx, pf->ny, pf->nz);
     scm_puts(buf, port);
     switch (pf->type) {
	 case RSCALAR_FIELD_SMOB:
	      scm_puts(" real scalar field", port);
	      break;
	 case CVECTOR_FIELD_SMOB:
	      scm_puts(" complex vector field", port);
	      break;
     }
     if (pf->local_ny < pf->ny) {
	  sprintf(buf, ", y=%d-%d local", 
		  pf->local_y_start, pf->local_y_start + pf->local_ny - 1);
	  scm_puts(buf, port);
     }
     scm_putc('>', port);
     return 1;
}

static size_t free_field_smob(SCM obj)
{
     field_smob *pf = FIELD(obj);
     free(pf->f.rs);
     free(pf);
     return 0;
}

#define mark_field_smob mark_null

SCM field2scm(field_smob *pf)
{
     SCM obj;
     NEWCELL_SMOB(obj, field_smob, pf);
     return obj;
}

/*************************************************************************/

void register_field_smobs(void)
{
#ifdef HAVE_SCM_MAKE_SMOB_TYPE
     scm_tc16_smob_field_smob = scm_make_smob_type("field", 0);
     scm_set_smob_free(scm_tc16_smob_field_smob, free_field_smob);
     scm_set_smob_print(scm_tc16_smob_field_smob, print_field_smob);
#else /* old way to register smobs */
     MAKE_SMOBFUNS(field_smob);
     REGISTER_SMOBFUNS(field_smob);
#endif

     gh_new_procedure("field?", field_p, 1, 0, 0);
     gh_new_procedure("rscalar-field?", rscalar_field_p, 1, 0, 0);
     gh_new_procedure("cvector-field?", cvector_field_p, 1, 0, 0);
}

/*************************************************************************/

static field_smob curfield_smob;

field_smob *update_curfield_smob(void)
{
     CHECK(mdata, "init-params must be called before manipulating fields");
     curfield_smob.nx = mdata->nx;
     curfield_smob.ny = mdata->ny;
     curfield_smob.nz = mdata->nz;
     curfield_smob.N = mdata->fft_output_size;
     curfield_smob.local_ny = mdata->local_ny;
     curfield_smob.local_y_start = mdata->local_y_start;
     curfield_smob.last_dim = mdata->last_dim;
     curfield_smob.last_dim_size = mdata->last_dim_size;
     curfield_smob.other_dims = mdata->other_dims;
     curfield_smob.type_char = curfield_type;
     if (strchr("dhecv", curfield_type)) { /* complex vector field */
	  curfield_smob.type = CVECTOR_FIELD_SMOB;
	  curfield_smob.f.cv = curfield;
     }
     else if (strchr("DHnR", curfield_type)) { /* real scalar field */
	  curfield_smob.type = RSCALAR_FIELD_SMOB;
	  curfield_smob.f.rs = (real *) curfield;
     }
     else {
	  curfield_smob.type = RSCALAR_FIELD_SMOB; /* arbitrary */
	  curfield_smob.f.rs = (real *) curfield;
	  if (!curfield_smob.f.rs)
	       curfield_smob.f.rs = (real *) mdata->fft_data;
	  return 0;
     }	  
     return &curfield_smob;
}

static void update_curfield(field_smob *pf)
{
     if (pf == &curfield_smob) {
	  curfield_type = curfield_smob.type_char;
	  curfield = curfield_smob.f.cv;
     }
}

boolean cur_fieldp(SCM obj)
{
     if (SCM_NIMP(obj) && SCM_SYMBOLP(obj)) {
	  char *s = gh_symbol2newstr(obj, NULL);
	  int ret = !strcmp(s, "cur-field");
	  free(s);
	  return ret;
     }
     return 0;
}

/*************************************************************************/

field_smob *assert_field_smob(SCM fo)
{
     field_smob *f = SAFE_FIELD(fo);
     CHECK(f, "wrong type argument: expecting field");
     return f;
}

/*************************************************************************/

SCM rscalar_field_make(SCM f0)
{
     int i;
     field_smob *pf;
     field_smob *pf0 = assert_field_smob(f0);
     CHK_MALLOC(pf, field_smob, 1);
     *pf = *pf0;
     pf->type = RSCALAR_FIELD_SMOB;
     pf->type_char = 'R';
     CHK_MALLOC(pf->f.rs, real, pf->N);
     for (i = 0; i < pf->N; ++i)
	  pf->f.rs[i] = 0.0;
     return field2scm(pf);
}

SCM cvector_field_make(SCM f0)
{
     int i;
     field_smob *pf;
     field_smob *pf0 = assert_field_smob(f0);
     CHECK(mdata, "init-params must be called before rscalar-field-make");
     CHK_MALLOC(pf, field_smob, 1);
     *pf = *pf0;
     pf->type = CVECTOR_FIELD_SMOB;
     pf->type_char = 'c';
     CHK_MALLOC(pf->f.cv, scalar_complex, 3 * pf->N);
     for (i = 0; i < pf->N * 3; ++i)
	  CASSIGN_ZERO(pf->f.cv[i]);
     return field2scm(pf);
}

void cvector_field_nonblochB(SCM f)
{
     field_smob *pf = assert_field_smob(f);
     pf->type_char = 'v';
     update_curfield(pf);
}

SCM field_make(SCM f0)
{
     field_smob *pf0 = assert_field_smob(f0);
     switch (pf0->type) {
	 case RSCALAR_FIELD_SMOB:
	      return rscalar_field_make(f0);
	 case CVECTOR_FIELD_SMOB:
	      return cvector_field_make(f0);
     }
     return SCM_UNDEFINED;
}

static boolean fields_conform(field_smob *f1, field_smob *f2)
{
#define EQF(field) (f1->field == f2->field)
     return (EQF(nx) && EQF(ny) && EQF(nz) &&
	     EQF(N) && EQF(local_ny) && EQF(local_y_start) &&
	     EQF(last_dim) && EQF(last_dim_size) && EQF(other_dims));
#undef EQF
}

boolean fields_conformp(SCM f1o, SCM f2o)
{
     field_smob *f1 = assert_field_smob(f1o);
     field_smob *f2 = assert_field_smob(f2o);
     return fields_conform(f1, f2);
}

static void field_set(field_smob *fd, field_smob *fs)
{
     int i;
     
     CHECK(fd->type == fs->type && fields_conform(fd, fs),
	   "fields for field-set! must conform");
     switch (fs->type) {
         case RSCALAR_FIELD_SMOB:
	      CHECK(fs->type_char != '-', "must load field for field-set!");
	      for (i = 0; i < fs->N; ++i)
		   fd->f.rs[i] = fs->f.rs[i];
	      break;
         case CVECTOR_FIELD_SMOB:
	      CHECK(fs->type_char != '-', "must load field for field-set!");
	      for (i = 0; i < fs->N * 3; ++i)
		   fd->f.cv[i] = fs->f.cv[i];
	      break;
     }
     fd->type_char = fs->type_char;
     update_curfield(fd);
}

void field_setB(SCM dest, SCM src)
{
     field_smob *fd = assert_field_smob(dest);
     field_smob *fs = assert_field_smob(src);
     field_set(fd, fs);
}

void field_load(SCM src)
{
     field_smob *fs = assert_field_smob(src);
     CHECK(mdata, "init-params must be called before field-load");
     update_curfield_smob();
     CHECK(fields_conform(fs, &curfield_smob),
	   "argument for field-load must conform to current size");
     curfield_smob.type = fs->type;
     field_set(&curfield_smob, fs);
}