"Fossies" - the Fresh Open Source Software Archive

Member "gretl-2020e/lib/src/genmpi.c" (8 Oct 2020, 9875 Bytes) of package /linux/misc/gretl-2020e.tar.xz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "genmpi.c" see the Fossies "Dox" file reference documentation and the last Fossies "Diffs" side-by-side code changes report: 2020d_vs_2020e.

    1 /*
    2  *  gretl -- Gnu Regression, Econometrics and Time-series Library
    3  *  Copyright (C) 2001 Allin Cottrell and Riccardo "Jack" Lucchetti
    4  *
    5  *  This program is free software: you can redistribute it and/or modify
    6  *  it under the terms of the GNU General Public License as published by
    7  *  the Free Software Foundation, either version 3 of the License, or
    8  *  (at your option) any later version.
    9  *
   10  *  This program is distributed in the hope that it will be useful,
   11  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
   12  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   13  *  GNU General Public License for more details.
   14  *
   15  *  You should have received a copy of the GNU General Public License
   16  *  along with this program.  If not, see <http://www.gnu.org/licenses/>.
   17  *
   18  */
   19 
   20 /* MPI-related functions for "genr" */
   21 
   22 static int node_replace_data (NODE *n, void *data, GretlType type)
   23 {
   24     int err;
   25 
   26     if (n->uv != NULL) {
   27     err = user_var_replace_value(n->uv, data, type);
   28     } else {
   29     fprintf(stderr, "*** replace data: node uv is NULL!\n");
   30     if (type == GRETL_TYPE_MATRIX) {
   31         err = user_matrix_replace_matrix_by_name(n->vname, data);
   32     } else {
   33         err = E_DATA;
   34     }
   35     }
   36 
   37     return err;
   38 }
   39 
   40 static Gretl_MPI_Op real_get_reduce_op (const char *s)
   41 {
   42     if (!strcmp(s, "sum")) {
   43     return GRETL_MPI_SUM;
   44     } else if (!strcmp(s, "prod")) {
   45     return GRETL_MPI_PROD;
   46     } else if (!strcmp(s, "max")) {
   47     return GRETL_MPI_MAX;
   48     } else if (!strcmp(s, "min")) {
   49     return GRETL_MPI_MIN;
   50     } else if (!strcmp(s, "hcat")) {
   51     return GRETL_MPI_HCAT;
   52     } else if (!strcmp(s, "vcat")) {
   53     return GRETL_MPI_VCAT;
   54     } else if (!strcmp(s, "acat")) {
   55     return GRETL_MPI_ACAT;
   56     } else {
   57     return 0;
   58     }
   59 }
   60 
   61 static Gretl_MPI_Op real_get_scatter_op (const char *s)
   62 {
   63     if (!strcmp(s, "bycols")) {
   64     return GRETL_MPI_HSPLIT;
   65     } else if (!strcmp(s, "byrows")) {
   66     return GRETL_MPI_VSPLIT;
   67     } else {
   68     return 0;
   69     }
   70 }
   71 
   72 static Gretl_MPI_Op reduce_op_from_string (const char *s)
   73 {
   74     Gretl_MPI_Op op = real_get_reduce_op(s);
   75 
   76     if (op == 0) {
   77     s = get_string_by_name(s);
   78     if (s != NULL) {
   79         op = real_get_reduce_op(s);
   80     }
   81     }
   82 
   83     return op;
   84 }
   85 
   86 static Gretl_MPI_Op scatter_op_from_string (const char *s)
   87 {
   88     Gretl_MPI_Op op = real_get_scatter_op(s);
   89 
   90     if (op == 0) {
   91     s = get_string_by_name(s);
   92     if (s != NULL) {
   93         op = real_get_scatter_op(s);
   94     }
   95     }
   96 
   97     return op;
   98 }
   99 
  100 static gretl_matrix *get_transfer_matrix (NODE *t, int f,
  101                       int cmplx_ok,
  102                       parser *p)
  103 {
  104     gretl_matrix *m = t->v.m;
  105 
  106     if (m == NULL) {
  107     p->err = E_DATA;
  108     } else if (m->is_complex && !cmplx_ok) {
  109     gretl_errmsg_sprintf("%s: %s", getsymb(f),
  110                  _("complex arguments/operands not supported"));
  111     p->err = E_CMPLX;
  112     }
  113 
  114     return m;
  115 }
  116 
  117 static NODE *mpi_transfer_node (NODE *l, NODE *r, NODE *r2,
  118                 int f, parser *p)
  119 {
  120     NODE *ret = NULL;
  121     GretlType type = 0;
  122     int root = 0;
  123     int id = 0;
  124 
  125     if (!gretl_mpi_initialized()) {
  126     gretl_errmsg_set(_("The MPI library is not loaded"));
  127     p->err = 1;
  128     return NULL;
  129     }
  130 
  131     if (f == F_MPI_SEND) {
  132     /* we need a destination id as second argument */
  133     if (l->t == MAT) {
  134         type = GRETL_TYPE_MATRIX;
  135     } else if (l->t == NUM) {
  136         type = GRETL_TYPE_DOUBLE;
  137     } else if (l->t == BUNDLE) {
  138         type = GRETL_TYPE_BUNDLE;
  139     } else if (l->t == ARRAY) {
  140         type = GRETL_TYPE_ARRAY;
  141     } else if (l->t == STR) {
  142         type = GRETL_TYPE_STRING;
  143     } else if (l->t == LIST) {
  144         type = GRETL_TYPE_LIST;
  145     } else {
  146         p->err = E_TYPES;
  147     }
  148     if (!p->err) {
  149         /* destination id */
  150         id = node_get_int(r, p);
  151     }
  152     } else if (f == F_MPI_RECV) {
  153     /* the single argument is the source id */
  154     id = node_get_int(l, p);
  155     } else if (f == F_BCAST || f == F_REDUCE ||
  156            f == F_ALLREDUCE || f == F_SCATTER) {
  157     /* we need the address of a variable on the left */
  158     if (l->t != U_ADDR) {
  159         p->err = E_TYPES;
  160     } else {
  161         /* switch to 'content' sub-node */
  162         l = l->L;
  163         if (umatrix_node(l)) {
  164         /* matrix: all operations OK */
  165         type = GRETL_TYPE_MATRIX;
  166         } else if (ubundle_node(l) && f == F_BCAST) {
  167         /* bundle: only broadcast OK */
  168         type = GRETL_TYPE_BUNDLE;
  169         } else if (uarray_node(l) && (f == F_REDUCE || f == F_BCAST)) {
  170         /* array: reduce and broadcast OK */
  171         type = GRETL_TYPE_ARRAY;
  172         } else if (ustring_node(l) && f == F_BCAST) {
  173         /* string: only broadcast OK */
  174         type = GRETL_TYPE_STRING;
  175         } else if (ulist_node(l) && f == F_BCAST) {
  176         /* list: only broadcast OK */
  177         type = GRETL_TYPE_LIST;
  178         } else if (uscalar_node(l) && f != F_SCATTER) {
  179         /* scalar: all ops OK apart from scatter */
  180         type = GRETL_TYPE_DOUBLE;
  181         } else {
  182         p->err = E_TYPES;
  183         }
  184     }
  185     if (!p->err && f != F_ALLREDUCE) {
  186         /* optional root specification */
  187         NODE *rootspec = (f == F_BCAST)? r : r2;
  188 
  189         if (!null_node(rootspec)) {
  190         root = node_get_int(rootspec, p);
  191         }
  192     }
  193     if (!p->err) {
  194         /* "self" id */
  195         id = gretl_mpi_rank();
  196     }
  197     }
  198 
  199     if (p->err) {
  200     return NULL;
  201     } else if (f == F_MPI_SEND) {
  202     void *sendp = NULL;
  203 
  204     if (type == GRETL_TYPE_MATRIX) {
  205         sendp = l->v.m;
  206     } else if (type == GRETL_TYPE_BUNDLE) {
  207         sendp = l->v.b;
  208     } else if (type == GRETL_TYPE_ARRAY) {
  209         sendp = l->v.a;
  210     } else if (type == GRETL_TYPE_STRING) {
  211         sendp = l->v.str;
  212     } else if (type == GRETL_TYPE_LIST) {
  213         sendp = l->v.ivec;
  214     } else if (type == GRETL_TYPE_DOUBLE) {
  215         sendp = &l->v.xval;
  216     } else {
  217         p->err = E_TYPES;
  218     }
  219     if (!p->err) {
  220         ret = aux_scalar_node(p);
  221     }
  222     if (!p->err) {
  223         p->err = ret->v.xval = gretl_mpi_send(sendp, type, id);
  224     }
  225     } else if (f == F_MPI_RECV) {
  226     void *recvp;
  227 
  228     recvp = gretl_mpi_receive(id, &type, &p->err);
  229 
  230     if (!p->err) {
  231         if (type == GRETL_TYPE_MATRIX) {
  232         ret = aux_matrix_node(p);
  233         if (!p->err) {
  234             ret->v.m = recvp;
  235         }
  236         } else if (type == GRETL_TYPE_BUNDLE) {
  237         ret = aux_bundle_node(p);
  238         if (!p->err) {
  239             ret->v.b = recvp;
  240         }
  241         } else if (type == GRETL_TYPE_ARRAY) {
  242         ret = aux_array_node(p);
  243         if (!p->err) {
  244             ret->v.a = recvp;
  245         }
  246         } else if (type == GRETL_TYPE_DOUBLE) {
  247         ret = aux_scalar_node(p);
  248         if (!p->err) {
  249             ret->v.xval = *(double *) recvp;
  250         }
  251         } else if (type == GRETL_TYPE_STRING) {
  252         ret = aux_string_node(p);
  253         if (!p->err) {
  254             ret->v.str = recvp;
  255         }
  256         } else if (type == GRETL_TYPE_LIST) {
  257         ret = aux_list_node(p);
  258         if (!p->err) {
  259             ret->v.ivec = recvp;
  260         }
  261         } else if (type == GRETL_TYPE_INT) {
  262         ret = aux_scalar_node(p);
  263         if (!p->err) {
  264             ret->v.xval = *(int *) recvp;
  265         }
  266         }
  267     }
  268     } else if (f == F_BCAST) {
  269     gretl_matrix *m = NULL;
  270     gretl_bundle *b = NULL;
  271     gretl_array *a = NULL;
  272     char *s = NULL;
  273     int *list = NULL;
  274     double x = NADBL;
  275     void *bcastp = NULL;
  276 
  277     if (type == GRETL_TYPE_MATRIX) {
  278         if (id == root) {
  279         m = l->v.m;
  280         }
  281         bcastp = &m;
  282     } else if (type == GRETL_TYPE_BUNDLE) {
  283         if (id == root) {
  284         b = l->v.b;
  285         }
  286         bcastp = &b;
  287     } else if (type == GRETL_TYPE_ARRAY) {
  288         if (id == root) {
  289         a = l->v.a;
  290         }
  291         bcastp = &a;
  292     } else if (type == GRETL_TYPE_STRING) {
  293         if (id == root) {
  294         s = l->v.str;
  295         }
  296         bcastp = &s;
  297     } else if (type == GRETL_TYPE_LIST) {
  298         if (id == root) {
  299         list = l->v.ivec;
  300         }
  301         bcastp = &list;
  302     } else if (type == GRETL_TYPE_DOUBLE) {
  303         x = l->v.xval;
  304         bcastp = &x;
  305     } else {
  306         p->err = E_TYPES;
  307     }
  308 
  309     if (!p->err) {
  310         ret = aux_scalar_node(p);
  311     }
  312     if (!p->err) {
  313         p->err = gretl_mpi_bcast(bcastp, type, root);
  314         if (!p->err && id != root) {
  315         if (type == GRETL_TYPE_DOUBLE) {
  316             p->err = node_replace_scalar(l, x);
  317         } else if (type == GRETL_TYPE_MATRIX) {
  318             p->err = node_replace_data(l, m, type);
  319         } else if (type == GRETL_TYPE_BUNDLE) {
  320             p->err = node_replace_data(l, b, type);
  321         } else if (type == GRETL_TYPE_ARRAY) {
  322             p->err = node_replace_data(l, a, type);
  323         } else if (type == GRETL_TYPE_STRING) {
  324             p->err = node_replace_data(l, s, type);
  325         } else if (type == GRETL_TYPE_LIST) {
  326             p->err = node_replace_data(l, list, type);
  327         }
  328         }
  329         ret->v.xval = p->err;
  330     }
  331     } else if (f == F_REDUCE || f == F_ALLREDUCE) {
  332     ret = aux_scalar_node(p);
  333     if (!p->err) {
  334         Gretl_MPI_Op op = reduce_op_from_string(r->v.str);
  335         gretlopt opt = (f == F_REDUCE)? OPT_NONE : OPT_A;
  336         gretl_matrix *lm = NULL;
  337         gretl_matrix *m = NULL;
  338         gretl_array *a = NULL;
  339         double x = NADBL;
  340 
  341         if (type == GRETL_TYPE_ARRAY) {
  342         p->err = gretl_array_mpi_reduce(l->v.a, &a, op, root);
  343         } else if (type == GRETL_TYPE_MATRIX) {
  344         lm = get_transfer_matrix(l, f, 0, p);
  345         if (!p->err) {
  346             p->err = gretl_matrix_mpi_reduce(lm, &m, op, root, opt);
  347         }
  348         } else {
  349         p->err = gretl_scalar_mpi_reduce(l->v.xval, &x, op, root, opt);
  350         }
  351         if (!p->err && (id == root || f == F_ALLREDUCE)) {
  352         if (type == GRETL_TYPE_ARRAY) {
  353             p->err = node_replace_data(l, a, type);
  354         } else if (type == GRETL_TYPE_MATRIX) {
  355             p->err = node_replace_data(l, m, type);
  356         } else {
  357             p->err = node_replace_scalar(l, x);
  358         }
  359         }
  360         ret->v.xval = p->err;
  361     }
  362     } else if (f == F_SCATTER) {
  363     gretl_matrix *lm = get_transfer_matrix(l, f, 1, p);
  364 
  365     if (!p->err) {
  366         ret = aux_scalar_node(p);
  367     }
  368     if (!p->err) {
  369         Gretl_MPI_Op op = scatter_op_from_string(r->v.str);
  370         gretl_matrix *m = NULL;
  371 
  372         p->err = ret->v.xval = gretl_matrix_mpi_scatter(lm, &m, op, root);
  373         if (!p->err) {
  374         p->err = node_replace_data(l, m, GRETL_TYPE_MATRIX);
  375         }
  376     }
  377     } else {
  378     gretl_errmsg_set("MPI function not yet supported");
  379     p->err = 1;
  380     }
  381 
  382     return ret;
  383 }
  384 
  385 static NODE *mpi_barrier_node (parser *p)
  386 {
  387     NODE *ret = NULL;
  388 
  389     if (!gretl_mpi_initialized()) {
  390     gretl_errmsg_set(_("The MPI library is not loaded"));
  391     p->err = 1;
  392     return NULL;
  393     } else {
  394     ret = aux_scalar_node(p);
  395     if (ret != NULL) {
  396         ret->v.xval = gretl_mpi_barrier();
  397     }
  398     }
  399 
  400     return ret;
  401 }