#include <stdlib.h>
#include <stdio.h>
#include <math.h>
#ifdef _WIN32
    #include "blas.c"
#else
    #include "blas.c"
    // #include <cblas.h>
#endif
#include <moss.h>
#include <objects/string.h>
#include <objects/list.h>
#include <modules/bs.h>
#include <modules/la.h>

double mf_float(mt_object* x, int* e);
extern mt_table* mv_type_array;

void mf_array_delete(mt_array* a){
    if(a->data->refcount==1){
        mf_free(a->data);
    }else{
        a->data->refcount--;
    }
    mf_free(a);
}

void mf_array_dec_refcount(mt_array* a){
    if(a->refcount==1){
        mf_array_delete(a);
    }else{
        a->refcount--;
    }
}

static
mt_array* mf_new_array(long size, int type){
    mt_array* a = mf_malloc(sizeof(mt_array));
    if(type==mv_array_float){
        a->data = mf_malloc(sizeof(mt_array_data)+size*sizeof(double));
    }else{
        abort();
    }
    a->data->refcount = 1;
    a->data->type = type;
    a->base = a->data->a;
    a->refcount = 1;
    a->size = size;
    return a;
}

static
mt_array* mf_array_copy(mt_array* a){
    mt_array* b;
    if(a->n==2){
        if(a->plain){
            goto plain;
        }else{
            unsigned long m=a->shape[0];
            unsigned long n=a->shape[1];
            long si=a->stride[0];
            long sj=a->stride[1];
            b = mf_new_array(m*n,mv_array_float);
            b->n = a->n; b->plain = 1;
            b->shape[0] = m; b->shape[1] = n;
            b->stride[0] = 1; b->stride[1] = m;
            double* pa = (double*)a->base;
            double* pb = (double*)b->base;
            unsigned long i,j,mj;
            long sjj;
            for(j=0; j<n; j++){
                mj=m*j; sjj=sj*j;
                for(i=0; i<m; i++){
                    pb[i+mj]=pa[si*i+sjj];
                }
            }
            return b;
        }
    }else if(a->n==1){
        b = mf_new_array(a->shape[0],mv_array_float);
        b->n = 1;
        b->shape[0] = a->shape[0];
        b->stride[0] = 1;
        cblas_dcopy(a->shape[0],(double*)a->base,a->stride[0],(double*)b->base,1);
        return b;
    }else{
        if(a->plain) goto plain;
        abort();
    }

    plain:
    b = mf_new_array(a->size,mv_array_float);
    b->n = a->n;
    b->plain = 1;
    unsigned long i;
    for(i=0; i<a->n; i++){
        b->shape[i] = a->shape[i];
        b->stride[i] = a->stride[i];
    }
    cblas_dcopy(a->size,(double*)a->base,1,(double*)b->base,1);
    return b;
}

void mf_ensure_plain(mt_array* a){
    if(a->n==2){
        if(a->plain) return;
        mt_array_data* data = mf_malloc(sizeof(mt_array_data)+a->size*sizeof(double));
        data->refcount = 1;
        data->type = mv_array_float;
        double* pa = (double*)a->base;
        double* pb = (double*)data->a;

        unsigned long m = a->shape[0];
        unsigned long n = a->shape[1];
        long si = a->stride[0];
        long sj = a->stride[1];
        unsigned long i,j,mj;
        long sjj;
        for(j=0; j<n; j++){
            mj = m*j; sjj = sj*j;
            for(i=0; i<m; i++){
                pb[i+mj] = pa[si*i+sjj];
            }
        }
        if(a->data->refcount==1){
            mf_free(a->data);
        }else{
            a->data->refcount--;
        }
        a->stride[0] = 1;
        a->stride[1] = m;
        a->data = data;
        a->base = data->a;
        a->plain = 1;
    }else if(a->n==1){
        abort();
    }else{
        if(a->plain) return;
        abort();
    }
}

static
mt_array* mf_array_map_dd(mt_array* a, double(*f)(double)){
    mt_array* b;
    if(a->n==2){
        if(a->plain){
            goto plain;
        }else{
            unsigned long m = a->shape[0];
            unsigned long n = a->shape[1];
            long si = a->stride[0];
            long sj = a->stride[1];
            b = mf_new_array(m*n,mv_array_float);
            b->n = a->n; b->plain = 1;
            b->shape[0] = m; b->shape[1] = n;
            b->stride[0] = 1; b->stride[1] = m;
            double* pa = (double*)a->base;
            double* pb = (double*)b->base;
            unsigned long i,j,mj;
            long sjj;
            for(j=0; j<n; j++){
                mj = m*j; sjj = sj*j;
                for(i=0; i<m; i++){
                    pb[i+mj] = f(pa[si*i+sjj]);
                }
            }
            return b;
        }
    }else if(a->n==1){
        unsigned long n=a->shape[0];
        b = mf_new_array(n,mv_array_float);
        b->n = 1; b->shape[0] = n;
        b->stride[0] = 1;
        long s = a->stride[0];
        unsigned long k;
        double* pa = (double*)a->base;
        double* pb = (double*)b->base;
        for(k=0; k<n; k++){
            pb[k] = f(pa[k*s]);
        }
        return b;
    }else{
        if(a->plain) goto plain;
        abort();
    }

    plain:
    b = mf_new_array(a->size,mv_array_float);
    b->n = a->n;
    b->plain = 1;
    unsigned long i;
    for(i=0; i<a->n; i++){
        b->shape[i] = a->shape[i];
        b->stride[i] = a->stride[i];
    }
    double* pa = (double*)a->base;
    double* pb = (double*)b->base;
    unsigned long size = a->size;
    unsigned long k;
    for(k=0; k<size; k++){
        pb[k] = f(pa[k]);
    }
    return b;
}

long mf_array_size(mt_array* a){
    long p;
    unsigned long k;
    switch(a->n){
    case 1:
        return a->shape[0];
    case 2:
        return a->shape[0]*a->shape[1];
    default:
        p=1;
        for(k=0; k<a->n; k++){
            p = p*a->shape[k];
        }
        return p;
    }
}

mt_array* mf_array(long size, mt_object* v){
    mt_array* a;
    if(size>0 && v[0].type==mv_list){
        long i,j;
        mt_list* list = (mt_list*)v[0].value.p;
        long n = list->size;
        a = mf_new_array(size*n,mv_array_float);
        a->n = 2;
        a->shape[0] = size; a->shape[1] = n;
        a->stride[0] = 1; a->stride[1] = size;
        a->plain = 1;
        double* b = (double*)a->base;
        int e=0;
        for(i=0; i<size; i++){
            if(v[i].type!=mv_list) abort();
            list = (mt_list*)v[i].value.p;
            if(list->size!=n) abort();
            for(j=0; j<n; j++){
                b[i+size*j] = mf_float(list->a+j,&e);
                if(e) abort();
            }
        }
    }else{
        a = mf_new_array(size,mv_array_float);
        a->n = 1;
        a->shape[0] = size;
        a->stride[0] = 1;
        long i;
        double* b = (double*)a->base;
        int e=0;
        for(i=0; i<size; i++){
            b[i] = mf_float(v+i,&e);
        }
    }
    return a;
}

int la_array(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"array");
        return 1;
    }
    if(v[1].type!=mv_list){
        mf_type_error1("in array(a): a (type: %s) is not a list.",v+1);
        return 1;
    }
    mt_list* list = (mt_list*)v[1].value.p;
    mt_array* a = mf_array(list->size, list->a);
    if(a==NULL) return 1;
    x->type = mv_array;
    x->value.p = (mt_basic*)a;
    return 0;
}

int la_vector(mt_object* x, int argc, mt_object* v){
    mt_array* a = mf_array(argc,v+1);
    if(a==NULL) return 1;
    x->type = mv_array;
    x->value.p = (mt_basic*)a;
    return 0;
}

int la_matrix(mt_object* x, int argc, mt_object* v){
    mt_array* a = mf_array(argc,v+1);
    if(a==NULL) return 1;
    if(a->n==1){
        a->n = 2;
        unsigned long size = a->shape[0];
        a->shape[0] = size;
        a->shape[1] = 1;
        a->stride[0] = 1;
        a->stride[1] = size;
        a->plain = 0;
    }
    x->type = mv_array;
    x->value.p = (mt_basic*)a;
    return 0;
}

static
void vector_str(mt_bs* bs, mt_array* T){
    char buffer[100];
    unsigned long i;
    double* a = (double*)T->base;
    unsigned long size = T->shape[0];
    long step = T->stride[0];

    mf_bs_push_cstr(bs,"[");
    for(i=0; i<size; i++){
        snprintf(buffer,100,i==0?"%.4g":", %.4g",a[step*i]);
        mf_bs_push_cstr(bs,buffer);
    }
    mf_bs_push_cstr(bs,"]");
}

static
void matrix_str(mt_bs* bs, mt_array* T){
    char buffer[100];
    unsigned long i,j;
    double* a = (double*)T->base;
    unsigned long m,n,is,js;
    m = T->shape[0];
    n = T->shape[1];
    is = T->stride[0];
    js = T->stride[1];
    int max = 0;
    int size;
    for(i=0; i<m; i++){
        for(j=0; j<n; j++){
            size = snprintf(buffer,100,"%.4g",a[i*is+j*js]);
            if(size>max) max=size;
        }
    }
    mf_bs_push_cstr(bs,"[");
    for(i=0; i<m; i++){
        mf_bs_push_cstr(bs,i==0? "[": ",\n [");
        for(j=0; j<n; j++){
            snprintf(buffer,100,j==0?"%*.4g":", %*.4g",max,a[i*is+j*js]);
            mf_bs_push_cstr(bs,buffer);
        }
        mf_bs_push_cstr(bs,"]");
    }
    mf_bs_push_cstr(bs,"]");
}

static
int array_str(mt_object* x, int argc, mt_object* v){
    if(argc!=0){
        mf_argc_error(argc,0,0,"array.type.str");
        return 1;
    }
    if(v[0].type!=mv_array){
        mf_type_error1("in a.str(): a (type: %s) is not an array.",&v[0]);
        return 1;
    }
    mt_array* T = (mt_array*)v[0].value.p;
    mt_bs bs;
    mf_bs_init(&bs);
    if(T->n==1){
        vector_str(&bs,T);
    }else if(T->n==2){
        matrix_str(&bs,T);
    }else{
        abort();
    }

    x->type = mv_string;
    x->value.p = (mt_basic*)mf_str_new(bs.size,(const char*)bs.a);
    mf_free(bs.a);
    return 0;
}

static
int array_list(mt_object* x, int argc, mt_object* v){
    if(argc!=0){
        mf_argc_error(argc,0,0,"array.type.list");
        return 1;
    }
    if(v[0].type!=mv_array){
        mf_type_error1("in a.list(): a (type: %s) is not an array.",&v[0]);
        return 1;
    }
    mt_array* T = (mt_array*)v[0].value.p;
    mt_list* list = mf_raw_list(T->size);
    unsigned long i;
    double* a = (double*)T->base;
    unsigned long size = T->shape[0];
    long step = T->stride[0];
    for(i=0; i<size; i++){
        list->a[i].type = mv_float;
        list->a[i].value.f = a[step*i];
    }

    x->type = mv_list;
    x->value.p = (mt_basic*)list;
    return 0;
}

double addc;
double add(double x){
    return x+addc;
}
double subc;
double sub(double x){
    return x-subc;
}

static
int array_add(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"Array.add");
        return 1;
    }
    if(v[0].type!=mv_array){
        mf_type_error1("in a+b: a (type: %s) is not an array.",&v[0]);
        return 1;
    }
    mt_array* a = (mt_array*)v[0].value.p;
    mt_array* c;
    if(v[1].type!=mv_array){
        int e = 0;
        addc = mf_float(&v[1],&e);
        if(e){
            mf_type_error1("in a+r: cannot convert r (type: %s) to float.",&v[1]);
            return 1;
        }
        c = mf_array_map_dd(a,add);
        if(c==NULL) return 1;
        x->type = mv_array;
        x->value.p = (mt_basic*)c;
        return 0;
    }
    mt_array* b = (mt_array*)v[1].value.p;
    if(a->n!=b->n){
        mf_value_error("value error in a+b: a and b have unequal order.");
        return 1;
    }
    if(a->n==1){
        unsigned long size=a->shape[0];
        if(size!=b->shape[0]){
            mf_value_error("Value error in a+b: a and b have unequal shape.");
            return 1;
        }
        c = mf_new_array(size,mv_array_float);
        c->n = 1; c->stride[0] = 1;
        c->shape[0] = size;
        cblas_dcopy(size,(double*)a->base,a->stride[0],(double*)c->base,1);
        cblas_daxpy(size,1,(double*)b->base,b->stride[0],(double*)c->base,1);
    }else{
        unsigned long i;
        for(i=0; i<a->n; i++){
            if(a->shape[i]!=b->shape[i]) abort();
        }
        c = mf_array_copy(a);
        mf_ensure_plain(b);
        cblas_daxpy(c->size,1,(double*)b->base,1,(double*)c->base,1);
    }
    x->type = mv_array;
    x->value.p = (mt_basic*)c;
    return 0;
}

static
int array_radd(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"Array.radd");
        return 1;
    }
    if(v[1].type!=mv_array){
        mf_type_error1("in r*a: a (type: %s) is not an array.",&v[1]);
        return 1;
    }
    int e = 0;
    addc = mf_float(&v[0],&e);
    if(e){
        mf_type_error1("in r+a: cannot convert r (type: %s) to float.",&v[0]);
        return 1;
    }
    mt_array* a = (mt_array*)v[1].value.p;
    mt_array* y = mf_array_map_dd(a,add);
    if(y==NULL) return 1;
    x->type = mv_array;
    x->value.p = (mt_basic*)y;
    return 0;
}

static
int array_sub(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"Array.sub");
        return 1;
    }
    if(v[0].type!=mv_array){
        mf_type_error1("in a-b: a (type: %s) is not an array.",&v[0]);
        return 1;
    }
    mt_array* a = (mt_array*)v[0].value.p;
    mt_array* c;
    if(v[1].type!=mv_array){
        int e = 0;
        subc = mf_float(&v[1],&e);
        if(e){
            mf_type_error1("in a-r: cannot convert r (type: %s) to float.",&v[1]);
            return 1;
        }
        c = mf_array_map_dd(a,sub);
        if(c==NULL) return 1;
        x->type = mv_array;
        x->value.p = (mt_basic*)c;
        return 0;
    }
    mt_array* b = (mt_array*)v[1].value.p;
    if(a->n==1){
        unsigned long size = a->shape[0];
        if(size!=b->shape[0]){
            mf_value_error("Value error in a-b: a and b have unequal shape.");
            return 1;
        }

        c = mf_new_array(size,mv_array_float);
        c->n = 1;
        c->shape[0] = size;
        c->stride[0] = 1;
        cblas_dcopy(size,(double*)a->base,a->stride[0],(double*)c->base,1);
        cblas_daxpy(size,-1,(double*)b->base,b->stride[0],(double*)c->base,1);
    }else{
        unsigned long i;
        for(i=0; i<a->n; i++){
            if(a->shape[i]!=b->shape[i]) abort();
        }
        c = mf_array_copy(a);
        mf_ensure_plain(b);
        cblas_daxpy(c->size,-1,(double*)b->base,1,(double*)c->base,1);
    }
    x->type = mv_array;
    x->value.p = (mt_basic*)c;
    return 0;
}

static
mt_array* mf_array_scal(double r, mt_array* a){
    mt_array* b;
    if(a->n==1){
        unsigned long size = a->shape[0];
        b = mf_new_array(size,mv_array_float);
        b->n = 1;
        b->shape[0] = size;
        b->stride[0] = 1;
        cblas_dcopy(size,(double*)a->base,a->stride[0],(double*)b->base,1);
    }else{
        b = mf_array_copy(a);
    }
    cblas_dscal(b->size,r,(double*)b->base,1);
    return b;
}

static
mt_array* array_mpy_array(mt_array* a, mt_array* b){
    if(b->n==1){
        unsigned long m = a->shape[0];
        unsigned long n = a->shape[1];
        if(n!=b->shape[0]){
            mf_value_error("Value error in A*x: shape does not match.");
            return NULL;
        }
        if(a->stride[0]!=1){
            mf_ensure_plain(a);
        }
        mt_array* c = mf_new_array(m,mv_array_float);
        c->n = 1;
        c->shape[0] = m;
        c->stride[0] = 1;
        cblas_dgemv(CblasColMajor,CblasNoTrans,m,n,1,
            (double*)a->base, a->stride[1],
            (double*)b->base, b->stride[0],
            0,(double*)c->base,1
        );
        return c;
    }else if(b->n==2){
        if(a->n==2){
            if(a->shape[1]!=b->shape[0]){
                mf_value_error("Value error in A*B: incompatible matrices.");
                return NULL;
            }
            if(a->stride[0]!=1){
                mf_ensure_plain(a);
            }
            if(b->stride[0]!=1){
                mf_ensure_plain(b);
            }

            unsigned long m = a->shape[0];
            unsigned long k = a->shape[1];
            unsigned long n = b->shape[1];
            mt_array* c = mf_new_array(m*n,mv_array_float);
            c->n = 2;
            c->shape[0] = m;
            c->shape[1] = n;
            c->stride[0] = 1;
            c->stride[1] = m;
            c->plain = 1;
            cblas_dgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, m, n, k, 1,
                (double*)a->base, a->stride[1],
                (double*)b->base, b->stride[1],
                0, (double*)c->base, m
            );
            return c;
        }else{
            abort();
        }
    }else{
        abort();
    }
}

static
mt_array* matrix_identity(unsigned long n){
    mt_array* a = mf_new_array(n*n,mv_array_float);
    a->n = 2;
    a->plain = 1;
    a->shape[0] = n;
    a->shape[1] = n;
    a->stride[0] = 1;
    a->stride[1] = n;
    double* b = (double*)a->base;
    unsigned long i,j,nj;
    for(j=0; j<n; j++){
        nj = n*j;
        for(i=0; i<n; i++){
            b[i+nj] = i==j? 1: 0;
        }
    }
    return a;
}

static
mt_array* square_matrix_mpy(mt_array* a, mt_array* b){
    if(a->stride[0]!=1){
        mf_ensure_plain(a);
    }
    if(b->stride[0]!=1){
        mf_ensure_plain(b);
    }
    unsigned long n = a->shape[0];
    mt_array* c = mf_new_array(n*n,mv_array_float);
    c->n = 2;
    c->shape[0] = n;
    c->shape[1] = n;
    c->stride[0] = 1;
    c->stride[1] = n;
    c->plain = 1;
    cblas_dgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, n, n, n, 1,
        (double*)a->base, a->stride[1],
        (double*)b->base, b->stride[1],
        0, (double*)c->base, n
    );
    return c;
}

static
mt_array* square_matrix_pow(mt_array* a, unsigned long n){
    if(n==0){
        return matrix_identity(a->shape[0]);
    }
    mt_array *p,*h;
    p = mf_array_copy(a);
    a = p;
    a->refcount++;
    n--;
    while(n){
        if(n&1){
            h = p;
            p = square_matrix_mpy(p,a);
            mf_array_dec_refcount(h);
        }
        n>>=1;
        if(n==0) break;
        h = a;
        a = square_matrix_mpy(a,a);
        mf_array_dec_refcount(h);
    }
    mf_array_dec_refcount(a);
    return p;
}

static
int array_mul(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"Array.mul");
        return 1;
    }
    if(v[0].type!=mv_array){
        mf_type_error1("in a*b: a (type: %s) is not an array.",&v[0]);
        return 1;
    }
    mt_array* a = (mt_array*)v[0].value.p;
    mt_array* b;
    double r;
    if(v[1].type==mv_array){
        b=(mt_array*)v[1].value.p;
        if(a->n==2){
            if(b->n==2 && a->shape[0]==1 && b->shape[1]==1){
                if(a->shape[1]!=b->shape[0]){
                    mf_value_error("Value error in a*b: incompatible matrices.");
                    return 1;
                }
                // todo: strides
                r = cblas_ddot(a->shape[1],
                    (double*)a->base,a->stride[1],
                    (double*)b->base,b->stride[0]
                );
                x->type = mv_float;
                x->value.f = r;
                return 0;
            }
            mt_array* c = array_mpy_array(a,b);
            if(c==NULL) return 1;
            x->type = mv_array;
            x->value.p = (mt_basic*)c;
            return 0;
        }
        if(a->n!=1){
            mf_value_error("Value error in a*b: a and b have incompatible shape.");
            return 1;
        }
        if(b->n==2){
            mt_array* c = array_mpy_array(b,a);
            if(c==NULL) return 1;
            x->type = mv_array;
            x->value.p = (mt_basic*)c;
            return 0;
        }
        if(a->shape[0]!=b->shape[0]){
            mf_value_error("Value error in a*b: a and b have unequal shape.");
            return 1;
        }
        r = cblas_ddot(a->shape[0],
            (double*)a->base,a->stride[0],
            (double*)b->base,b->stride[0]
        );
        x->type = mv_float;
        x->value.f = r;
        return 0;
    }else{
        int e = 0;
        r = mf_float(&v[1],&e);
        if(e){
            mf_type_error1("in a*r: cannot convert r (type: %s) to float.",&v[1]);
            return 1;
        }
        x->type = mv_array;
        x->value.p = (mt_basic*)mf_array_scal(r,a);
        return 0;
    }
}

static
int array_pow(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"Array.pow");
        return 1;
    }
    if(v[0].type!=mv_array){
        mf_type_error1("in a^n: a (type: %s) is not an array.",&v[0]);
        return 1;
    }
    mt_array* a = (mt_array*)v[0].value.p;

    double r;
    if(a->n!=1){
        if(a->n==2 && v[1].type==mv_int){
            long n = v[1].value.i;
            if(a->shape[0]!=a->shape[1]){
                mf_value_error("Value error in A^n: A is not a square matrix");
                return 1;
            }
            x->type = mv_array;
            x->value.p = (mt_basic*)square_matrix_pow(a,(unsigned long)n);
            return 0;
        }
        mf_value_error("Value error in a^n: a is not a vector.");
        return 1;
    }
    r = cblas_ddot(a->shape[0],
        (double*)a->base,a->stride[0],
        (double*)a->base,a->stride[0]
    );
    x->type = mv_float;
    if(v[1].type==mv_int && v[1].value.i==2){
        x->value.f = r;
    }else{
        int e = 0;
        double n = mf_float(&v[1],&e);
        if(e){
            mf_type_error1("in a^n: cannot convert n (type: %s) to float.",&v[1]);
            return 1;
        }
        x->value.f = pow(r,n);
    }
    return 0;
}

static
int array_rmul(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"Array.rmul");
        return 1;
    }
    if(v[1].type!=mv_array){
        mf_type_error1("in r*a: a (type: %s) is not an array.",&v[1]);
        return 1;
    }
    int e=0;
    double r = mf_float(&v[0],&e);
    if(e){
        mf_type_error1("in r*a: cannot convert r (type: %s) to float.",&v[0]);
        return 1;
    }
    mt_array* a = (mt_array*)v[1].value.p;
    x->type = mv_array;
    x->value.p = (mt_basic*)mf_array_scal(r,a);;
    return 0;
}

static
int array_neg(mt_object* x, int argc, mt_object* v){
    if(argc!=0){
        mf_argc_error(argc,0,0,"Array.neg");
        return 1;
    }
    if(v[0].type!=mv_array){
        mf_type_error1("in -a: a (type: %s) is not an array.",&v[1]);
        return 1;
    }
    mt_array* a = (mt_array*)v[0].value.p;
    x->type = mv_array;
    x->value.p = (mt_basic*)mf_array_scal(-1,a);;
    return 0;
}

static
int array_div(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"Array.div");
        return 1;
    }
    if(v[0].type!=mv_array){
        mf_type_error1("in a/r: a (type: %s) is not an array.",&v[1]);
        return 1;
    }
    int e = 0;
    double r = mf_float(&v[1],&e);
    if(e){
        mf_type_error1("in a/r: cannot convert r (type: %s) to float.",&v[0]);
        return 1;
    }
    mt_array* a = (mt_array*)v[0].value.p;
    x->type = mv_array;
    x->value.p = (mt_basic*)mf_array_scal(1/r,a);;
    return 0;
}

static
int array_T(mt_object* x, int argc, mt_object* v){
    if(argc!=0){
        mf_argc_error(argc,0,0,"array.type.T");
        return 1;
    }
    if(v[0].type!=mv_array){
        mf_type_error1("in a.T(): a (type: %s) is not an array.",&v[0]);
        return 1;
    }
    mt_array* a = (mt_array*)v[0].value.p;
    if(a->n==2){
        mt_array* b = mf_malloc(sizeof(mt_array));
        b->refcount = 1;
        b->n = 2;
        a->data->refcount++;
        b->data = a->data;
        b->base = a->base;
        b->size = a->size;
        b->plain = 0;
        b->shape[0] = a->shape[1];
        b->shape[1] = a->shape[0];
        b->stride[0] = a->stride[1];
        b->stride[1] = a->stride[0];
        x->type = mv_array;
        x->value.p = (mt_basic*)b;
    }else{
        a->refcount++;
        x->type = mv_array;
        x->value.p = (mt_basic*)a;
    }
    return 0;
}

static
int array_plain(mt_object* x, int argc, mt_object* v){
    if(v[0].type!=mv_array) abort();
    mt_array* a = (mt_array*)v[0].value.p;
    mf_ensure_plain(a);
    a->refcount++;
    x->type = mv_array;
    x->value.p = (mt_basic*)a;
    return 0;
}

static
int array_copy(mt_object* x, int argc, mt_object* v){
    if(v[0].type!=mv_array) abort();
    mt_array* a = (mt_array*)v[0].value.p;
    x->type = mv_array;
    x->value.p = (mt_basic*)mf_array_copy(a);
    return 0;
}

static
mt_array* vector_slice(mt_array* a, mt_range* r){
    long i,j;
    if(r->a.type!=mv_int || r->b.type!=mv_int){
        mf_type_error("Type error in a[r]: r is not an integer range.");
        return NULL;
    }
    i = r->a.value.i;
    j = r->b.value.i;
    unsigned long n = a->shape[0];
    if(i<0 || j<0){
        mf_value_error("Value error in a[r]: range with negative values.");
        return NULL;
    }
    if((unsigned long)i>=n || (unsigned long)j>=n){
        mf_value_error("Value error in a[r]: range is out of bounds.");
        return NULL;
    }
    mt_array* b = mf_malloc(sizeof(mt_array));
    b->refcount = 1;
    b->size = a->size;
    a->data->refcount++;
    b->data = a->data;
    a->data = b->data;
    b->n = 1;
    b->base = (unsigned char*)((double*)a->base+a->stride[0]*i);
    b->shape[0] = j-i+1;
    b->stride[0] = a->stride[0];
    return b;
}

static
int array_get(mt_object* x, int argc, mt_object* v){
    if(v[0].type!=mv_array){
        mf_type_error1("in a[i]: a (type: %s) is not an array.",&v[0]);
        return 1;
    }
    mt_array* a = (mt_array*)v[0].value.p;
    if(argc==1){
        if(a->n!=1){
            mf_value_error("Value error in a[i]: a is not a vector.");
            return 1;
        }
        if(v[1].type!=mv_int){
            if(v[1].type==mv_range){
                 mt_array* b = vector_slice(a,(mt_range*)v[1].value.p);
                 if(b==NULL) return 1;
                 x->type = mv_array;
                 x->value.p = (mt_basic*)b;
                 return 0;
            }
            mf_type_error1("in a[i]: i (type: %s) is not an integer.",&v[1]);
            return 1;
        }
        long index = v[1].value.i;
        unsigned long n = a->shape[0];
        if(index<0 || (unsigned long)index>=n){
            mf_value_error("Value error in a[i]: i is out of bounds.");
            return 1;
        }
        double* b = (double*)a->base;
        double t = b[index*a->stride[0]];
        x->type = mv_float;
        x->value.f = t;
        return 0;
    }else{
        mf_argc_error(argc,1,1,"Array.get");
        return 1;
    }
}

static
int la_idm(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"idm");
        return 1;
    }
    if(v[1].type!=mv_int){
        mf_type_error1("in idm(n): n (type: %s) is not an integer.",v+1);
        return 1;
    }
    long n = v[1].value.i;
    x->type = mv_array;
    x->value.p = (mt_basic*)matrix_identity(n);
    return 0;
}

static
mt_array* diag(mt_array* v){
    if(v->n!=1){
        mf_value_error("Value error in diag(v): v is not a vector.");
        return NULL;
    }
    unsigned long n = v->shape[0];
    mt_array* a = mf_new_array(n*n,mv_array_float);
    a->n = 2;
    a->plain = 1;
    a->shape[0] = n;
    a->shape[1] = n;
    a->stride[0] = 1;
    a->stride[1] = n;
    double* b = (double*)a->base;
    double* vb = (double*)v->base;
    long vs = v->stride[0];
    unsigned long i,j,nj;
    for(j=0; j<n; j++){
        nj = n*j;
        for(i=0; i<n; i++){
            b[i+nj] = i==j? vb[i*vs]: 0;
        }
    }
    return a;
}

static
int la_diag(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"diag");
        return 1;
    }
    if(v[1].type!=mv_array){
        mf_type_error1("in diag(a): a is not an array.",v+1);
        return 1;
    }
    mt_array* u = (mt_array*)v[1].value.p;
    mt_array* a = diag(u);
    if(a==NULL) return 1;
    x->type = mv_array;
    x->value.p = (mt_basic*)a;
    return 0;
}

static
mt_array* diag_slice(mt_array* a){
    if(a->n!=2 || a->shape[0]!=a->shape[1]){
        mf_value_error("Value error in a.diag(): a is not an quadratic matrix.");
        return NULL;
    }
    if(a->stride[1]!=1){
        mf_ensure_plain(a);
    }
    mt_array* v = mf_malloc(sizeof(mt_array));
    v->refcount = 1;
    v->n = 1;
    a->data->refcount++;
    v->data = a->data;
    v->base = a->base;
    v->shape[0] = a->shape[0];
    v->stride[0] = (a->shape[0]+1)*a->stride[0];
    return v;
}

static
int array_diag(mt_object* x, int argc, mt_object* v){
    if(argc!=0){
        mf_argc_error(argc,0,0,"diag");
        return 1;
    }
    if(v[0].type!=mv_array){
        mf_type_error1("in a.diag(): a (type: %s) is not an array.",&v[0]);
        return 1;
    }
    mt_array* a = (mt_array*)v[0].value.p;
    mt_array* u = diag_slice(a);
    if(u==NULL) return 1;
    x->type = mv_array;
    x->value.p = (mt_basic*)u;
    return 0;
}

int mf_array_map(mt_array* a, mt_function* f){
    mt_object argv[2];
    argv[0].type = mv_null;
    double* ba = (double*)a->base;
    long size = a->size;
    long i;
    mt_object x;
    int e = 0;
    for(i=0; i<size; i++){
        argv[1].type = mv_float;
        argv[1].value.f = ba[i];
        if(mf_call(f,&x,1,argv)){
            mf_traceback("map");
            return 1;
        }
        ba[i] = mf_float(&x,&e);
        if(e){
            mf_type_error1("in a.map(f): cannot convert f(a[k]) (type: %s) to float.",&x);
            return 1;
        }
    }
    return 0;
}

static
int array_map(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"map");
        return 1;
    }
    if(v[0].type!=mv_array){
        mf_type_error1("in a.map(f): a (type: %s) is not an array.",&v[0]);
        return 1;
    }
    if(v[1].type!=mv_function){
        mf_type_error1("in a.map(f): f (type: %s) is not a function.",&v[1]);
        return 1;
    }
    mt_array* a = (mt_array*)v[0].value.p;
    mt_function* f = (mt_function*)v[1].value.p;
    mt_array* b = mf_array_copy(a);
    if(mf_array_map(b,f)) return 1;
    x->type = mv_array;
    x->value.p = (mt_basic*)b;
    return 0;
}

static
int mf_trace(mt_object* x, mt_array* a){
    if(a->n!=2 || a->shape[0]!=a->shape[1]){
        mf_value_error("Value error in trace(a): a is not a quadratic matrix.");
        return 1;
    }
    double s = 0;
    long n = a->shape[0];
    double* ba = (double*)a->base;
    long i,m;
    m = a->stride[0]+a->stride[1];
    for(i=0; i<n; i++){
        s+=ba[i*m];
    }
    x->type = mv_float;
    x->value.f = s;
    return 0;
}

static
int la_trace(mt_object* x, int argc, mt_object* v){
    if(argc!=1){
        mf_argc_error(argc,1,1,"trace");
        return 1;
    }
    if(v[1].type!=mv_array){
        mf_type_error1("in la.trace(a): a (type: %s) is not an array.",&v[1]);
        return 1;
    }
    mt_array* a = (mt_array*)v[1].value.p;
    if(mf_trace(x,a)) return 1;
    return 0;
}

mt_table* mf_la_load(){
    mt_map* m = mv_type_array->m;
    mf_insert_function(m,0,0,"str",array_str);
    mf_insert_function(m,0,0,"list",array_list);
    mf_insert_function(m,1,1,"add",array_add);
    mf_insert_function(m,1,1,"radd",array_radd);
    mf_insert_function(m,1,1,"sub",array_sub);
    mf_insert_function(m,1,1,"mul",array_mul);
    mf_insert_function(m,1,1,"rmul",array_rmul);
    mf_insert_function(m,0,0,"neg",array_neg);
    mf_insert_function(m,1,1,"div",array_div);
    mf_insert_function(m,1,1,"pow",array_pow);
    mf_insert_function(m,1,-1,"get",array_get);
    mf_insert_function(m,0,0,"T",array_T);
    mf_insert_function(m,0,0,"plain",array_plain);
    mf_insert_function(m,0,0,"copy",array_copy);
    mf_insert_function(m,0,0,"diag",array_diag);
    mf_insert_function(m,1,1,"map",array_map);

    mt_table* la = mf_table(NULL);
    la->name = mf_cstr_to_str("module la");
    la->m = mf_empty_map();
    m = la->m;
    mf_insert_function(m,1,1,"array",la_array);
    mf_insert_function(m,1,1,"vector",la_vector);
    mf_insert_function(m,1,1,"matrix",la_matrix);
    mf_insert_function(m,1,1,"idm",la_idm);
    mf_insert_function(m,1,1,"diag",la_diag);
    mf_insert_function(m,1,1,"trace",la_trace);
    m->frozen = 1;
    return la;
}


/*
 * Licensed to the Apache Software Foundation (ASF) under one
 * or more contributor license agreements.  See the NOTICE file
 * distributed with this work for additional information
 * regarding copyright ownership.  The ASF licenses this file
 * to you under the Apache License, Version 2.0 (the
 * "License"); you may not use this file except in compliance
 * with the License.  You may obtain a copy of the License at
 *
 *   http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing,
 * software distributed under the License is distributed on an
 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
 * KIND, either express or implied.  See the License for the
 * specific language governing permissions and limitations
 * under the License.
 */

#ifndef _libmatrixmult_h
#define _libmatrixmult_h

#define MAX(x, y) (((x) > (y)) ? (x) : (y))
#define MIN(x, y) (((x) < (y)) ? (x) : (y))

// *****************************************************************
// We support Intel MKL (recommended) or OpenBLAS.
// These flags are used for conditional compilation with mkl and openblas
// #define USE_INTEL_MKL
// #define USE_GNU_THREADING
// #define USE_OPEN_BLAS
// *****************************************************************

//#ifdef __cplusplus
//extern "C" {
//#endif
//#ifdef __cplusplus
//}
//#endif

// Since we call cblas_dgemm in openmp for loop,
// we call "extension" APIs for setting number of threads of the given API.
// For example: for OpenBLAS we use openblas_set_num_threads and
// for MKL we use mkl_set_num_threads. This avoids performance degradation due to overprovisioning.
#ifdef USE_OPEN_BLAS
#include <cblas.h>
// extern "C" void openblas_set_num_threads(int numThreads);
#elif defined USE_INTEL_MKL
#include <mkl.h>
#include <mkl_service.h>
#endif

void setNumThreadsForBLAS(int numThreads);

// Multiplies two matrices m1Ptr and m2Ptr in row-major format of shape
// (m1rlen, m1clen) and (m1clen, m2clen)
void matmult(double* m1Ptr, double* m2Ptr, double* retPtr, int m1rlen,
             int m1clen, int m2clen, int numThreads);

void tsmm(double* m1Ptr, double* retPtr, int m1rlen, int m1clen, bool isLeftTranspose,  int numThreads);

#endif


 /**
 *
 * @file core_dormqr.c
 *
 *  PLASMA core_blas kernel
 *  PLASMA is a software package provided by Univ. of Tennessee,
 *  Univ. of California Berkeley and Univ. of Colorado Denver
 *
 * @version 2.6.0
 * @author Hatem Ltaief
 * @author Mathieu Faverge
 * @author Jakub Kurzak
 * @date 2010-11-15
 * @generated d Tue Jan  7 11:44:46 2014
 *
 **/
#include <lapacke.h>
#include "common.h"

/***************************************************************************//**
 *
 * @ingroup CORE_double
 *
 *  CORE_dormqr overwrites the general complex M-by-N tile C with
 *
 *                    SIDE = 'L'     SIDE = 'R'
 *    TRANS = 'N':      Q * C          C * Q
 *    TRANS = 'C':      Q**T * C       C * Q**T
 *
 *  where Q is a complex unitary matrix defined as the product of k
 *  elementary reflectors
 *
 *    Q = H(1) H(2) . . . H(k)
 *
 *  as returned by CORE_dgeqrt. Q is of order M if SIDE = 'L' and of order N
 *  if SIDE = 'R'.
 *
 *******************************************************************************
 *
 * @param[in] side
 *         @arg PlasmaLeft  : apply Q or Q**T from the Left;
 *         @arg PlasmaRight : apply Q or Q**T from the Right.
 *
 * @param[in] trans
 *         @arg PlasmaNoTrans   :  No transpose, apply Q;
 *         @arg PlasmaTrans :  Transpose, apply Q**T.
 *
 * @param[in] M
 *         The number of rows of the tile C.  M >= 0.
 *
 * @param[in] N
 *         The number of columns of the tile C.  N >= 0.
 *
 * @param[in] K
 *         The number of elementary reflectors whose product defines
 *         the matrix Q.
 *         If SIDE = PlasmaLeft,  M >= K >= 0;
 *         if SIDE = PlasmaRight, N >= K >= 0.
 *
 * @param[in] IB
 *         The inner-blocking size.  IB >= 0.
 *
 * @param[in] A
 *         Dimension:  (LDA,K)
 *         The i-th column must contain the vector which defines the
 *         elementary reflector H(i), for i = 1,2,...,k, as returned by
 *         CORE_dgeqrt in the first k columns of its array argument A.
 *
 * @param[in] LDA
 *         The leading dimension of the array A.
 *         If SIDE = PlasmaLeft,  LDA >= max(1,M);
 *         if SIDE = PlasmaRight, LDA >= max(1,N).
 *
 * @param[in] T
 *         The IB-by-K triangular factor T of the block reflector.
 *         T is upper triangular by block (economic storage);
 *         The rest of the array is not referenced.
 *
 * @param[in] LDT
 *         The leading dimension of the array T. LDT >= IB.
 *
 * @param[in,out] C
 *         On entry, the M-by-N tile C.
 *         On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
 *
 * @param[in] LDC
 *         The leading dimension of the array C. LDC >= max(1,M).
 *
 * @param[in,out] WORK
 *         On exit, if INFO = 0, WORK(1) returns the optimal LDWORK.
 *
 * @param[in] LDWORK
 *         The dimension of the array WORK.
 *         If SIDE = PlasmaLeft,  LDWORK >= max(1,N);
 *         if SIDE = PlasmaRight, LDWORK >= max(1,M).
 *
 *******************************************************************************
 *
 * @return
 *          \retval PLASMA_SUCCESS successful exit
 *          \retval <0 if -i, the i-th argument had an illegal value
 *
 ******************************************************************************/
#if defined(PLASMA_HAVE_WEAK)
#pragma weak CORE_dormqr = PCORE_dormqr
#define CORE_dormqr PCORE_dormqr
#endif
int CORE_dormqr(PLASMA_enum side, PLASMA_enum trans,
                int M, int N, int K, int IB,
                const double *A, int LDA,
                const double *T, int LDT,
                double *C, int LDC,
                double *WORK, int LDWORK)
{
    int i, kb;
    int i1, i3;
    int nq, nw;
    int ic = 0;
    int jc = 0;
    int ni = N;
    int mi = M;

    /* Check input arguments */
    if ((side != PlasmaLeft) && (side != PlasmaRight)) {
        coreblas_error(1, "Illegal value of side");
        return -1;
    }
    /*
     * NQ is the order of Q and NW is the minimum dimension of WORK
     */
    if (side == PlasmaLeft) {
        nq = M;
        nw = N;
    }
    else {
        nq = N;
        nw = M;
    }

    if ((trans != PlasmaNoTrans) && (trans != PlasmaTrans)) {
        coreblas_error(2, "Illegal value of trans");
        return -2;
    }
    if (M < 0) {
        coreblas_error(3, "Illegal value of M");
        return -3;
    }
    if (N < 0) {
        coreblas_error(4, "Illegal value of N");
        return -4;
    }
    if ((K < 0) || (K > nq)) {
        coreblas_error(5, "Illegal value of K");
        return -5;
    }
    if ((IB < 0) || ( (IB == 0) && ((M > 0) && (N > 0)) )) {
        coreblas_error(6, "Illegal value of IB");
        return -6;
    }
    if ((LDA < max(1,nq)) && (nq > 0)) {
        coreblas_error(8, "Illegal value of LDA");
        return -8;
    }
    if ((LDC < max(1,M)) && (M > 0)) {
        coreblas_error(12, "Illegal value of LDC");
        return -12;
    }
    if ((LDWORK < max(1,nw)) && (nw > 0)) {
        coreblas_error(14, "Illegal value of LDWORK");
        return -14;
    }

    /* Quick return */
    if ((M == 0) || (N == 0) || (K == 0))
        return PLASMA_SUCCESS;

    if (((side == PlasmaLeft) && (trans != PlasmaNoTrans))
        || ((side == PlasmaRight) && (trans == PlasmaNoTrans))) {
        i1 = 0;
        i3 = IB;
    }
    else {
        i1 = ( ( K-1 ) / IB )*IB;
        i3 = -IB;
    }

    for(i = i1; (i >- 1) && (i < K); i+=i3 ) {
        kb = min(IB, K-i);

        if (side == PlasmaLeft) {
            /*
             * H or H' is applied to C(i:m,1:n)
             */
            mi = M - i;
            ic = i;
        }
        else {
            /*
             * H or H' is applied to C(1:m,i:n)
             */
            ni = N - i;
            jc = i;
        }
        /*
         * Apply H or H'
         */
        LAPACKE_dlarfb_work(LAPACK_COL_MAJOR,
            lapack_const(side),
            lapack_const(trans),
            lapack_const(PlasmaForward),
            lapack_const(PlasmaColumnwise),
            mi, ni, kb,
            &A[LDA*i+i], LDA,
            &T[LDT*i], LDT,
            &C[LDC*jc+ic], LDC,
            WORK, LDWORK);
    }
    return PLASMA_SUCCESS;
}


#ifndef __ESTIMATE_INC_
#define __ESTIMATE__INC_

#include <gsl/gsl_matrix.h>
#include <gsl/gsl_vector.h>

double getLogLikelyhood(gsl_matrix *cinverse, double det_cmatrix,  gsl_matrix *xmodel,
												gsl_vector *trainingvector, gsl_vector *thetas, gsl_matrix *h_matrix, int nmodel_points,
												int nthetas, int nparams, int nregression_fns,
												void (*makeHVector)(gsl_vector *, gsl_vector*, int));

#endif


#ifndef _ROTATION_H__
#define _ROTATION_H__

#include <mpi.h>
#include <omp.h>
#include <blas.h>
#include <vector>
#include <stdlib.h>
#include <math.h>

/* ************************************************** */
// interface for FORTRAN CODE
#define FORTRAN(MYFUN) (MYFUN##_)
extern "C" {
	void FORTRAN(idd_random_transf_init)(int *nsteps, int *n, double *w, int *keep);
	void FORTRAN(idd_random_transf)(double *x, double *y, double *w);
	void FORTRAN(idd_random_transf_inverse)(double *x, double *y, double *w);
}
#define RROT_INIT FORTRAN(idd_random_transf_init)
#define RROT FORTRAN(idd_random_transf)
#define RROT_INV FORTRAN(idd_random_transf_inverse)
/* ************************************************** */

using namespace std;

void generateRotation(int dim, vector<double> &w );

void generateRotation(int dim, vector<double> &w, MPI_Comm comm);

void rotatePoints(const double *points, int numof_points, int dim,
				  vector<double> &w,
				  // output
				  double *newPoints);

void inverseRotatePoints(const double *points, int numof_points, int dim,
				  vector<double> &w,
				  // output
				  double *newPoints);

void newRotatePoints(double *points, int numof_points, int dim, vector<double> &w);

void newInverseRotatePoints(double *points, int numof_points, int dim, vector<double> &w);

/*
void generateRotation(int dim, double *R);

void generateRotation(int dim, double *R, MPI_Comm comm);

void rotatePoints(double *points, int numof_points, int dim,
				  double *MatRotation,
				  // output
				  double *newPoints);

void inverseRotatePoints(double *points, int numof_points, int dim,
				  double *MatRotation,
				  // output
				  double *newPoints);
*/

#endif


#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <math.h>
#include <string.h>
#include "cconfigspace_internal.h"
#include "distribution_internal.h"

struct _ccs_distribution_multivariate_data_s {
	_ccs_distribution_common_data_t  common_data;
	size_t                           num_distributions;
	ccs_distribution_t              *distributions;
	size_t                          *dimensions;
	ccs_interval_t                  *bounds;
};
typedef struct _ccs_distribution_multivariate_data_s _ccs_distribution_multivariate_data_t;

static ccs_result_t
_ccs_distribution_multivariate_del(ccs_object_t o) {
	struct _ccs_distribution_multivariate_data_s *data =
		(struct _ccs_distribution_multivariate_data_s *)(((ccs_distribution_t)o)->data);
	for (size_t i = 0; i < data->num_distributions; i++) {
		ccs_release_object(data->distributions[i]);
	}
	return CCS_SUCCESS;
}

static ccs_result_t
_ccs_distribution_multivariate_get_bounds(_ccs_distribution_data_t *data,
                                          ccs_interval_t           *interval_ret);

static ccs_result_t
_ccs_distribution_multivariate_samples(_ccs_distribution_data_t *data,
                                       ccs_rng_t                 rng,
                                       size_t                    num_values,
                                       ccs_numeric_t            *values);

static ccs_result_t
_ccs_distribution_multivariate_strided_samples(_ccs_distribution_data_t *data,
                                               ccs_rng_t                 rng,
                                               size_t                    num_values,
                                               size_t                    stride,
                                               ccs_numeric_t            *values);

static ccs_result_t
_ccs_distribution_multivariate_soa_samples(_ccs_distribution_data_t  *data,
                                           ccs_rng_t                  rng,
                                           size_t                     num_values,
                                           ccs_numeric_t            **values);

static _ccs_distribution_ops_t _ccs_distribution_multivariate_ops = {
	{ &_ccs_distribution_multivariate_del },
	&_ccs_distribution_multivariate_samples,
	&_ccs_distribution_multivariate_get_bounds,
	&_ccs_distribution_multivariate_strided_samples,
	&_ccs_distribution_multivariate_soa_samples
};

ccs_result_t
ccs_create_multivariate_distribution(size_t              num_distributions,
                                     ccs_distribution_t *distributions,
                                     ccs_distribution_t *distribution_ret) {
	CCS_CHECK_ARY(num_distributions, distributions);
	CCS_CHECK_PTR(distribution_ret);
	if (!num_distributions || num_distributions > INT64_MAX)
		return -CCS_INVALID_VALUE;

	ccs_result_t err;
	size_t       i = 0;
	size_t       dimension = 0;
	ccs_distribution_t distrib;
	_ccs_distribution_multivariate_data_t *distrib_data;

        for (i = 0; i < num_distributions; i++) {
		size_t dim;
		CCS_VALIDATE(ccs_distribution_get_dimension(distributions[i], &dim));
		dimension += dim;
	}

	uintptr_t mem, cur_mem;
	mem = (uintptr_t)calloc(1,
		sizeof(struct _ccs_distribution_s) +
		sizeof(_ccs_distribution_multivariate_data_t) +
		sizeof(ccs_distribution_t)*num_distributions +
		sizeof(size_t)*num_distributions +
		sizeof(ccs_interval_t)*dimension +
		sizeof(ccs_numeric_type_t)*dimension);

	if (!mem)
		return -CCS_OUT_OF_MEMORY;
        cur_mem = mem;

	distrib = (ccs_distribution_t)cur_mem;
	cur_mem += sizeof(struct _ccs_distribution_s);
	_ccs_object_init(&(distrib->obj), CCS_DISTRIBUTION, (_ccs_object_ops_t *)&_ccs_distribution_multivariate_ops);
	distrib_data = (_ccs_distribution_multivariate_data_t *)(cur_mem);
	cur_mem += sizeof(_ccs_distribution_multivariate_data_t);
	distrib_data->common_data.type        = CCS_MULTIVARIATE;
	distrib_data->common_data.dimension   = dimension;
	distrib_data->num_distributions       = num_distributions;
	distrib_data->distributions           = (ccs_distribution_t *)(cur_mem);
	cur_mem += sizeof(ccs_distribution_t)*num_distributions;
	distrib_data->dimensions              = (size_t *)(cur_mem);
	cur_mem += sizeof(size_t)*num_distributions;
	distrib_data->bounds                  = (ccs_interval_t *)(cur_mem);
	cur_mem += sizeof(ccs_interval_t)*dimension;
	distrib_data->common_data.data_types  = (ccs_numeric_type_t *)(cur_mem);
	cur_mem += sizeof(ccs_numeric_type_t)*dimension;

	dimension = 0;
        for (i = 0; i < num_distributions; i++) {
		size_t dim;
		CCS_VALIDATE_ERR_GOTO(err,
		  ccs_distribution_get_data_types(distributions[i], distrib_data->common_data.data_types + dimension),
		  errmemory);
		CCS_VALIDATE_ERR_GOTO(err,
		  ccs_distribution_get_bounds(distributions[i], distrib_data->bounds + dimension),
		  errmemory);
		CCS_VALIDATE_ERR_GOTO(err, ccs_distribution_get_dimension(distributions[i], &dim), errmemory);
		distrib_data->dimensions[i] = dim;
		dimension += dim;
	}

	for (i = 0; i < num_distributions; i++) {
		CCS_VALIDATE_ERR_GOTO(err, ccs_retain_object(distributions[i]), distrib);
		distrib_data->distributions[i] = distributions[i];
	}
	distrib->data = (_ccs_distribution_data_t *)distrib_data;
	*distribution_ret = distrib;

	return CCS_SUCCESS;
distrib:
	for (i = 0; i < num_distributions; i++) {
		if (distrib_data->distributions[i])
			ccs_release_object(distributions[i]);
	}
errmemory:
	free((void *)mem);
	return err;
}

static ccs_result_t
_ccs_distribution_multivariate_get_bounds(_ccs_distribution_data_t *data,
                                     ccs_interval_t           *interval_ret) {
	_ccs_distribution_multivariate_data_t *d =
		(_ccs_distribution_multivariate_data_t *)data;
	memcpy(interval_ret, d->bounds, d->common_data.dimension*sizeof(ccs_interval_t));
	return CCS_SUCCESS;
}

static inline _ccs_distribution_ops_t *
ccs_distribution_get_ops(ccs_distribution_t distribution) {
	return (_ccs_distribution_ops_t *)distribution->obj.ops;
}

static ccs_result_t
_ccs_distribution_multivariate_samples(_ccs_distribution_data_t *data,
                                       ccs_rng_t                 rng,
                                       size_t                    num_values,
                                       ccs_numeric_t            *values) {
	_ccs_distribution_multivariate_data_t *d =
		(_ccs_distribution_multivariate_data_t *)data;

	for (size_t i = 0; i < d->num_distributions; i++) {
		CCS_VALIDATE(ccs_distribution_get_ops(d->distributions[i])->strided_samples(
			d->distributions[i]->data, rng, num_values,
			d->common_data.dimension, values));
		values += d->dimensions[i];
	}
	return CCS_SUCCESS;
}

static ccs_result_t
_ccs_distribution_multivariate_strided_samples(_ccs_distribution_data_t *data,
                                               ccs_rng_t                 rng,
                                               size_t                    num_values,
                                               size_t                    stride,
                                               ccs_numeric_t            *values) {
	_ccs_distribution_multivariate_data_t *d =
		(_ccs_distribution_multivariate_data_t *)data;

	for (size_t i = 0; i < d->num_distributions; i++) {
		CCS_VALIDATE(ccs_distribution_get_ops(d->distributions[i])->strided_samples(
			d->distributions[i]->data, rng, num_values,
			stride, values));
		values += d->dimensions[i];
	}
	return CCS_SUCCESS;
}

static ccs_result_t
_ccs_distribution_multivariate_soa_samples(_ccs_distribution_data_t  *data,
                                           ccs_rng_t                  rng,
                                           size_t                     num_values,
                                           ccs_numeric_t            **values) {
	_ccs_distribution_multivariate_data_t *d =
		(_ccs_distribution_multivariate_data_t *)data;

	for (size_t i = 0; i < d->num_distributions; i++) {
		CCS_VALIDATE(ccs_distribution_get_ops(d->distributions[i])->soa_samples(
			d->distributions[i]->data, rng, num_values, values));
		values += d->dimensions[i];
	}
	return CCS_SUCCESS;
}

ccs_result_t
ccs_multivariate_distribution_get_num_distributions(ccs_distribution_t  distribution,
                                               size_t             *num_distributions_ret) {
	CCS_CHECK_DISTRIBUTION(distribution, CCS_MULTIVARIATE);
	CCS_CHECK_PTR(num_distributions_ret);
	_ccs_distribution_multivariate_data_t * data = (_ccs_distribution_multivariate_data_t *)distribution->data;
	*num_distributions_ret = data->num_distributions;
	return CCS_SUCCESS;
}

ccs_result_t
ccs_multivariate_distribution_get_distributions(ccs_distribution_t  distribution,
                                           size_t              num_distributions,
                                           ccs_distribution_t *distributions,
                                           size_t             *num_distributions_ret) {
	CCS_CHECK_DISTRIBUTION(distribution, CCS_MULTIVARIATE);
	CCS_CHECK_ARY(num_distributions, distributions);
	if (!distributions && !num_distributions_ret)
		return -CCS_INVALID_VALUE;
	_ccs_distribution_multivariate_data_t * data = (_ccs_distribution_multivariate_data_t *)distribution->data;
	if (distributions) {
		if (num_distributions < data->num_distributions)
			return -CCS_INVALID_VALUE;
		for (size_t i = 0; i < data->num_distributions; i++)
			distributions[i] = data->distributions[i];
		for (size_t i = data->num_distributions; i < num_distributions; i++)
			distributions[i] = NULL;
	}
	if (num_distributions_ret)
		*num_distributions_ret = data->num_distributions;
	return CCS_SUCCESS;
}


#ifndef AMICI_MODEL_DIMENSIONS_H
#define AMICI_MODEL_DIMENSIONS_H

#include <gsl/gsl-lite.hpp>
#include <vector>

namespace amici {

/**
 * @brief Container for model dimensions.
 *
 * Holds number of states, observables, etc.
 */
struct ModelDimensions {
    /** Default ctor */
    ModelDimensions() = default;

    /**
     * @brief Constructor with model dimensions
     * @param nx_rdata Number of state variables
     * @param nxtrue_rdata Number of state variables of the non-augmented model
     * @param nx_solver Number of state variables with conservation laws applied
     * @param nxtrue_solver Number of state variables of the non-augmented model
     * with conservation laws applied
     * @param nx_solver_reinit Number of state variables with conservation laws
     * subject to reinitialization
     * @param np Number of parameters
     * @param nk Number of constants
     * @param ny Number of observables
     * @param nytrue Number of observables of the non-augmented model
     * @param nz Number of event observables
     * @param nztrue Number of event observables of the non-augmented model
     * @param ne Number of events
     * @param nJ Number of objective functions
     * @param nw Number of repeating elements
     * @param ndwdx Number of nonzero elements in the `x` derivative of the
     * repeating elements
     * @param ndwdp Number of nonzero elements in the `p` derivative of the
     * repeating elements
     * @param ndwdw Number of nonzero elements in the `w` derivative of the
     * repeating elements
     * @param ndxdotdw Number of nonzero elements in the \f$ w\f$ derivative of \f$ xdot\f$
     * @param ndJydy Number of nonzero elements in the \f$ y\f$ derivative of \f$ dJy\f$ (shape `nytrue`)
     * @param nnz Number of nonzero elements in Jacobian
     * @param ubw Upper matrix bandwidth in the Jacobian
     * @param lbw Lower matrix bandwidth in the Jacobian
     */
    ModelDimensions(
            const int nx_rdata, const int nxtrue_rdata, const int nx_solver,
            const int nxtrue_solver, const int nx_solver_reinit, const int np,
            const int nk, const int ny,
            const int nytrue, const int nz, const int nztrue, const int ne,
            const int nJ, const int nw, const int ndwdx, const int ndwdp,
            const int ndwdw, const int ndxdotdw, std::vector<int> ndJydy,
            const int nnz, const int ubw, const int lbw)
        : nx_rdata(nx_rdata), nxtrue_rdata(nxtrue_rdata), nx_solver(nx_solver),
          nxtrue_solver(nxtrue_solver), nx_solver_reinit(nx_solver_reinit),
          np(np), nk(nk),
          ny(ny), nytrue(nytrue), nz(nz), nztrue(nztrue),
          ne(ne), nw(nw), ndwdx(ndwdx), ndwdp(ndwdp), ndwdw(ndwdw),
          ndxdotdw(ndxdotdw), ndJydy(std::move(ndJydy)),
          nnz(nnz), nJ(nJ), ubw(ubw), lbw(lbw) {
        Expects(nxtrue_rdata >= 0);
        Expects(nxtrue_rdata <= nx_rdata);
        Expects(nxtrue_solver >= 0);
        Expects(nx_solver <= nx_rdata);
        Expects(nxtrue_solver <= nx_solver);
        Expects(nx_solver_reinit >= 0);
        Expects(nx_solver_reinit <= nx_solver);
        Expects(np >= 0);
        Expects(nk >= 0);
        Expects(nytrue <= ny);
        Expects(nytrue >= 0);
        Expects(nztrue >= 0);
        Expects(nztrue <= nz);
        Expects(ne >= 0);
        Expects(nw >= 0);
        Expects(ndwdx >= 0);
        Expects(ndwdx <= nw * nx_solver);
        Expects(ndwdp >= 0);
        Expects(ndwdp <= nw * np);
        Expects(ndwdw >= 0);
        Expects(ndwdw <= nw * nw);
        Expects(ndxdotdw >= 0);
        Expects(nnz >= 0);
        Expects(nJ >= 0);
        Expects(ubw >= 0);
        Expects(lbw >= 0);
    }

    /** Number of states */
    int nx_rdata{0};

    /** Number of states in the unaugmented system */
    int nxtrue_rdata{0};

    /** Number of states with conservation laws applied */
    int nx_solver{0};

    /**
     * Number of states in the unaugmented system with conservation laws
     * applied
     */
    int nxtrue_solver{0};

    /** Number of solver states subject to reinitialization */
    int nx_solver_reinit{0};

    /** Number of parameters */
    int np{0};

    /** Number of constants */
    int nk{0};

    /** Number of observables */
    int ny{0};

    /** Number of observables in the unaugmented system */
    int nytrue{0};

    /** Number of event outputs */
    int nz{0};

    /** Number of event outputs in the unaugmented system */
    int nztrue{0};

    /** Number of events */
    int ne{0};

    /** Number of common expressions */
    int nw{0};

    /**
     * Number of nonzero elements in the `x` derivative of the
     * repeating elements
     */
    int ndwdx {0};

    /**
     * Number of nonzero elements in the `p` derivative of the
     * repeating elements
     */
    int ndwdp {0};

    /**
     * Number of nonzero elements in the `w` derivative of the
     * repeating elements
     */
    int ndwdw {0};

    /** Number of nonzero elements in the \f$ w \f$ derivative of \f$ xdot \f$ */
    int ndxdotdw {0};

    /**
     * Number of nonzero elements in the \f$ y \f$ derivative of
     * \f$ dJy \f$ (dimension `nytrue`)
     */
    std::vector<int> ndJydy;

    /** Number of nonzero entries in Jacobian */
    int nnz{0};

    /** Dimension of the augmented objective function for 2nd order ASA */
    int nJ{0};

    /** Upper bandwidth of the Jacobian */
    int ubw{0};

    /** Lower bandwidth of the Jacobian */
    int lbw{0};
};

} // namespace amici

#endif // AMICI_MODEL_DIMENSIONS_H


/*
 * Copyright (c) 2011-2018 The University of Tennessee and The University
 *                         of Tennessee Research Foundation.  All rights
 *                         reserved.
 * Copyright (c) 2013      Inria. All rights reserved.
 *
 * @precisions normal z -> c d s
 *
 */

#include <lapacke.h>
#include "dplasma.h"
#include "dplasmatypes.h"
#include "parsec/data_dist/matrix/sym_two_dim_rectangle_cyclic.h"
#include "parsec/data_dist/matrix/two_dim_rectangle_cyclic.h"

/**
 *******************************************************************************
 *
 *  Generic case
 *
 *******************************************************************************
 */
static int
dplasma_zlatms_operator( parsec_execution_stream_t *es,
                         const parsec_tiled_matrix_dc_t *descA,
                         void *_A,
                         PLASMA_enum uplo, int m, int n,
                         void *args )
{
    int tempmm, tempnn, ldam, i;
    double            *cond = (double*)args;
    parsec_complex64_t *A    = (parsec_complex64_t*)_A;
    (void)es;

    tempmm = ((m)==((descA->mt)-1)) ? ((descA->m)-(m*(descA->mb))) : (descA->mb);
    tempnn = ((n)==((descA->nt)-1)) ? ((descA->n)-(n*(descA->nb))) : (descA->nb);
    ldam = BLKLDD( descA, m );

    if (m == n) {
        LAPACKE_zlaset_work(
            LAPACK_COL_MAJOR, lapack_const( uplo ), tempmm, tempnn,
            0., 0., A, ldam);

        /* D(i) = 1 - (i-1)/(N-1)*(1 - 1/COND) */
        if ( m == 0 ) {
            A[0] = 1.;
            i = 1;
        }
        else {
            i = 0;
        }
        if ( descA->n > 1 ) {
            double tmp = 1. / (*cond);
            double alp = ( 1. - tmp ) / ((double)( descA->n - 1 ));
            int minmn = dplasma_imin( tempmm, tempnn );
            for(; i < minmn; i++){
                A[i+i*ldam] = (parsec_complex64_t)( (double)(descA->n-(descA->nb*n+i+1)) * alp + tmp );
            }
        }
    } else {
        LAPACKE_zlaset_work(
            LAPACK_COL_MAJOR, 'A', tempmm, tempnn,
            0., 0., A, ldam);
    }
    return 0;
}

/**
 *******************************************************************************
 *
 * @ingroup dplasma_complex64
 *
 * dplasma_zpltmg - Generates a special test matrix by tiles.
 *
 *******************************************************************************
 *
 * @param[in,out] parsec
 *          The parsec context of the application that will run the operation.
 *
 * @param[in] mtxtype
 *           - PlasmaGeneral:   Generate a general matrix
 *           - PlasmaSymmetric: Generate a symmetric matrix
 *
 * @param[in,out] A
 *          Descriptor of the distributed matrix A to generate. Any tiled matrix
 *          descriptor can be used.
 *          On exit, the matrix A generated.
 *
 * @param[in] seed
 *          The seed used in the random generation.
 *
 *******************************************************************************
 *
 * @return
 *          \retval -i if the ith parameters is incorrect.
 *          \retval 0 on success.
 *
 *******************************************************************************
 *
 * @sa dplasma_cpltmg
 * @sa dplasma_dpltmg
 * @sa dplasma_spltmg
 *
 ******************************************************************************/
int
dplasma_zlatms( parsec_context_t *parsec,
                PLASMA_enum mtxtype, double cond,
                parsec_tiled_matrix_dc_t *A,
                unsigned long long int seed)
{
    two_dim_block_cyclic_t Q, T;
    int nodes, rank, mb, nb, m, n, mt, nt, P;
    int rc;

    /* Init the diagonal of A */
    {
        parsec_taskpool_t *tp;
        double *condptr = malloc(sizeof( double ));
        *condptr = cond;
        tp = parsec_apply_New( PlasmaUpperLower, A, dplasma_zlatms_operator, condptr );
        if ( tp != NULL ) {
            rc = parsec_context_add_taskpool(parsec, tp);
            rc = parsec_context_start( parsec );
            rc = parsec_context_wait( parsec );
            parsec_apply_Destruct(tp);
        }
        else {
            return -1;
        }
    }

    nodes = A->super.nodes;
    rank  = A->super.myrank;
    mb    = A->mb;
    nb    = A->nb;
    m     = A->m;
    n     = A->n;
    mt    = A->mt;
    nt    = A->nt;

    if ( A->dtype & two_dim_block_cyclic_type ) {
        P = ((two_dim_block_cyclic_t*)A)->grid.rows;
    }
    else if ( A->dtype & sym_two_dim_block_cyclic_type ) {
        P = ((sym_two_dim_block_cyclic_t*)A)->grid.rows;
    }
    else {
        P = 1;
    }

    /* Init the random matrix R */
    two_dim_block_cyclic_init( &Q, matrix_ComplexDouble, matrix_Tile,
                               nodes, rank, mb, nb, m, n, 0, 0, m, n, 1, 1, P );
    Q.mat = parsec_data_allocate((size_t)Q.super.nb_local_tiles *
                                (size_t)Q.super.bsiz *
                                (size_t)parsec_datadist_getsizeoftype(Q.super.mtype));
    parsec_data_collection_set_key((parsec_data_collection_t*)&Q, "Q");

    /* Init the T matrix */
    two_dim_block_cyclic_init( &T, matrix_ComplexDouble, matrix_Tile,
                               nodes, rank, 32, nb, mt*32, n, 0, 0, mt*32, n, 1, 1, P );
    T.mat = parsec_data_allocate((size_t)T.super.nb_local_tiles *
                                (size_t)T.super.bsiz *
                                (size_t)parsec_datadist_getsizeoftype(T.super.mtype));
    parsec_data_collection_set_key((parsec_data_collection_t*)&T, "T");

    if ( mtxtype == PlasmaGeneral ) {
        if ( m >= n ) {
            parsec_tiled_matrix_dc_t *subA = tiled_matrix_submatrix( A, 0, 0, n, n );
            parsec_tiled_matrix_dc_t *subQ = tiled_matrix_submatrix( (parsec_tiled_matrix_dc_t *)&Q,
                                                                0, 0, n, n );
            parsec_tiled_matrix_dc_t *subT = tiled_matrix_submatrix( (parsec_tiled_matrix_dc_t *)&T,
                                                                0, 0, nt*32, n );

            /* Multiply on the right by an unitary matrix */
            dplasma_zplrnt( parsec, 0, subQ, seed + 1 );
            dplasma_zgeqrf( parsec, subQ, subT );
            dplasma_zunmqr( parsec, PlasmaRight, PlasmaNoTrans,
                            subQ, subT, subA );

            /* Multiply on the left by an unitary matrix */
            dplasma_zplrnt( parsec, 0,
                            (parsec_tiled_matrix_dc_t *)&Q, seed );
            dplasma_zgeqrf( parsec,
                            (parsec_tiled_matrix_dc_t*)&Q,
                            (parsec_tiled_matrix_dc_t*)&T );
            dplasma_zunmqr( parsec, PlasmaLeft, PlasmaNoTrans,
                            (parsec_tiled_matrix_dc_t*)&Q,
                            (parsec_tiled_matrix_dc_t*)&T, A );

            free(subA); free(subQ); free(subT);
        }
        else {
            parsec_tiled_matrix_dc_t *subA = tiled_matrix_submatrix( A, 0, 0, m, m );
            parsec_tiled_matrix_dc_t *subQ = tiled_matrix_submatrix( (parsec_tiled_matrix_dc_t *)&Q,
                                                                0, 0, m, m );
            parsec_tiled_matrix_dc_t *subT = tiled_matrix_submatrix( (parsec_tiled_matrix_dc_t *)&T,
                                                                0, 0, mt*32, m );

            /* Multiply on the left by an unitary matrix */
            dplasma_zplrnt( parsec, 0, subQ, seed );
            dplasma_zgeqrf( parsec, subQ, subT );
            dplasma_zunmqr( parsec, PlasmaLeft, PlasmaNoTrans,
                            subQ, subT, subA );

            /* Multiply on the right by an unitary matrix */
            dplasma_zplrnt( parsec, 0,
                            (parsec_tiled_matrix_dc_t *)&Q, seed );
            dplasma_zgeqrf( parsec,
                            (parsec_tiled_matrix_dc_t*)&Q,
                            (parsec_tiled_matrix_dc_t*)&T );
            dplasma_zunmqr( parsec, PlasmaRight, PlasmaNoTrans,
                            (parsec_tiled_matrix_dc_t*)&Q,
                            (parsec_tiled_matrix_dc_t*)&T, A );
            free(subA); free(subQ); free(subT);
        }
    }
    else {
        assert( mtxtype == PlasmaHermitian );

        /* Init the unitary matrix */
        dplasma_zplrnt( parsec, 0,
                        (parsec_tiled_matrix_dc_t *)&Q, seed );
        dplasma_zgeqrf( parsec,
                        (parsec_tiled_matrix_dc_t*)&Q,
                        (parsec_tiled_matrix_dc_t*)&T );

        dplasma_zunmqr( parsec, PlasmaLeft, PlasmaNoTrans,
                        (parsec_tiled_matrix_dc_t*)&Q,
                        (parsec_tiled_matrix_dc_t*)&T, A );
        dplasma_zunmqr( parsec, PlasmaRight, PlasmaConjTrans,
                        (parsec_tiled_matrix_dc_t*)&Q,
                        (parsec_tiled_matrix_dc_t*)&T, A );
    }

    free(Q.mat);
    parsec_tiled_matrix_dc_destroy( (parsec_tiled_matrix_dc_t*)&Q );
    free(T.mat);
    parsec_tiled_matrix_dc_destroy( (parsec_tiled_matrix_dc_t*)&T );

    return 0;
}


/*
 * Copyright (c) 2010-2018 The University of Tennessee and The University
 *                         of Tennessee Research Foundation.  All rights
 *                         reserved.
 * Copyright (c) 2013      Inria. All rights reserved.
 *
 * @precisions normal z -> c d s
 *
 */

#include <lapacke.h>
#include "dplasma.h"
#include "dplasmatypes.h"

#include "map2.h"

static int
dplasma_zlacpy_trim_operator( parsec_execution_stream_t *es,
                              const parsec_tiled_matrix_dc_t *descA,
                              const parsec_tiled_matrix_dc_t *descB,
                              const void *_A, void *_B,
                              PLASMA_enum uplo, int m, int n,
                              void *args )
{
    int tempmm, tempnn, ldam, ldbm;
    const parsec_complex64_t *A = (const parsec_complex64_t*)_A;
    parsec_complex64_t       *B = (parsec_complex64_t*)_B;
    (void)es;
    (void)args;
    (void)uplo;

    tempmm = ((m)==((descB->mt)-1)) ? ((descB->m)-(m*(descB->mb))) : (descB->mb);
    tempnn = ((n)==((descB->nt)-1)) ? ((descB->n)-(n*(descB->nb))) : (descB->nb);
    ldam = BLKLDD( descA, m );
    ldbm = BLKLDD( descB, m );

    LAPACKE_zlacpy_work(
        LAPACK_COL_MAJOR, lapack_const( PlasmaUpperLower ), tempmm, tempnn, A, ldam, B, ldbm);

    return 0;
}

/**
 *******************************************************************************
 *
 * @ingroup dplasma_complex64
 *
 * dplasma_zlacpy_New - Generates an object that performs a copy of the matrix A
 * into the matrix B.
 *
 * See dplasma_map2_New() for further information.
 *
 * WARNING: The computations are not done by this call.
 *
 *******************************************************************************
 *
 * @param[in] uplo
 *          Specifies which part of matrix A is copied:
 *          = PlasmaUpperLower: All matrix is referenced.
 *          = PlasmaUpper:      Only upper part is refrenced.
 *          = PlasmaLower:      Only lower part is referenced.
 *
 * @param[in] A
 *          Descriptor of the distributed original matrix A. Any tiled matrix
 *          descriptor can be used. However, if the data is stored in column
 *          major, the tile distribution must match the one of the matrix B.
 *
 * @param[in,out] B
 *          Descriptor of the distributed destination matrix B. Any tiled matrix
 *          descriptor can be used, with no specific storage.
 *
 *******************************************************************************
 *
 * @return
 *          \retval NULL if incorrect parameters are given.
 *          \retval The PaRSEC object describing the operation that can be
 *          enqueued in the runtime. It, then, needs to be
 *          destroy with the corresponding _destruct function.
 *
 *******************************************************************************
 *
 * @sa dplasma_zlacpy
 * @sa dplasma_zlacpy_Destruct
 * @sa dplasma_clacpy_New
 * @sa dplasma_dlacpy_New
 * @sa dplasma_slacpy_New
 *
 ******************************************************************************/
parsec_taskpool_t*
dplasma_zlacpy_trim_New( PLASMA_enum uplo,
                         const parsec_tiled_matrix_dc_t *A,
                         parsec_tiled_matrix_dc_t *B)
{
    parsec_taskpool_t* tp;

    tp = dplasma_map2_New(uplo, PlasmaNoTrans, A, B,
                          dplasma_zlacpy_trim_operator, NULL );
    return tp;
}

/**
 *******************************************************************************
 *
 * @ingroup dplasma_complex64
 *
 *  dplasma_zlacpy_Destruct - Free the data structure associated to an object
 *  created with dplasma_zlacpy_New().
 *
 *******************************************************************************
 *
 * @param[in,out] o
 *          On entry, the object to destroy.
 *          On exit, the object cannot be used anymore.
 *
 *******************************************************************************
 *
 * @sa dplasma_zlacpy_New
 * @sa dplasma_zlacpy
 *
 ******************************************************************************/
void
dplasma_zlacpy_trim_Destruct( parsec_taskpool_t *tp )
{
    parsec_taskpool_free(tp);
}

/**
 *******************************************************************************
 *
 * @ingroup dplasma_complex64
 *
 * dplasma_zlacpy - Generates an object that performs a copy of the matrix A
 * into the matrix B.
 *
 * See dplasma_map2() for further information.
 *
 *******************************************************************************
 *
 * @param[in,out] dague
 *          The dague context of the application that will run the operation.
 *
 * @param[in] uplo
 *          Specifies which part of matrix A is copied:
 *          = PlasmaUpperLower: All matrix is referenced.
 *          = PlasmaUpper:      Only upper part is refrenced.
 *          = PlasmaLower:      Only lower part is referenced.
 *
 * @param[in] A
 *          Descriptor of the distributed original matrix A. Any tiled matrix
 *          descriptor can be used. However, if the data is stored in column
 *          major, the tile distribution must match the one of the matrix B.
 *
 * @param[in,out] B
 *          Descriptor of the distributed destination matrix B. Any tiled matrix
 *          descriptor can be used, with no specific storage.
 *
 *******************************************************************************
 *
 * @return
 *          \retval -i if the ith parameters is incorrect.
 *          \retval 0 on success.
 *
 *******************************************************************************
 *
 * @sa dplasma_zlacpy_New
 * @sa dplasma_zlacpy_Destruct
 * @sa dplasma_clacpy
 * @sa dplasma_dlacpy
 * @sa dplasma_slacpy
 *
 ******************************************************************************/
int
dplasma_zlacpy_trim( parsec_context_t *parsec,
                     PLASMA_enum uplo,
                     const parsec_tiled_matrix_dc_t *A,
                     parsec_tiled_matrix_dc_t *B)
{
    parsec_taskpool_t *parsec_zlacpy_trim = NULL;

    if ((uplo != PlasmaUpperLower) &&
        (uplo != PlasmaUpper)      &&
        (uplo != PlasmaLower))
    {
        dplasma_error("dplasma_zlacpy_trim", "illegal value of uplo");
        return -2;
    }

    parsec_zlacpy_trim = dplasma_zlacpy_trim_New(uplo, A, B);

    if ( parsec_zlacpy_trim != NULL )
    {
        parsec_context_add_taskpool(parsec, parsec_zlacpy_trim);
        dplasma_wait_until_completion(parsec);
        dplasma_zlacpy_trim_Destruct( parsec_zlacpy_trim );
    }
    return 0;
}


// Copyright (c) 2017, Lawrence Livermore National Security, LLC. Produced at
// the Lawrence Livermore National Laboratory. LLNL-CODE-734707. All Rights
// reserved. See files LICENSE and NOTICE for details.
//
// This file is part of CEED, a collection of benchmarks, miniapps, software
// libraries and APIs for efficient high-order finite element and spectral
// element discretizations for exascale applications. For more information and
// source code availability see http://github.com/ceed.
//
// The CEED research is supported by the Exascale Computing Project 17-SC-20-SC,
// a collaborative effort of two U.S. Department of Energy organizations (Office
// of Science and the National Nuclear Security Administration) responsible for
// the planning and preparation of a capable exascale ecosystem, including
// software, applications, hardware, advanced system engineering and early
// testbed platforms, in support of the nation's exascale computing imperative.

#ifndef setup_h
#define setup_h

#include <stdbool.h>
#include <string.h>

#include <petsc.h>
#include <petscdmplex.h>
#include <petscksp.h>
#include <petscfe.h>

#include <ceed.h>

#if PETSC_VERSION_LT(3,14,0)
#  define DMAddBoundary(a,b,c,d,e,f,g,h,i,j,k,l) DMAddBoundary(a,b,c,d,e,f,g,h,j,k,l)
#endif

#ifndef PHYSICS_STRUCT
#define PHYSICS_STRUCT
typedef struct Physics_private *Physics;
struct Physics_private {
  CeedScalar   nu;      // Poisson's ratio
  CeedScalar   E;       // Young's Modulus
};
#endif

// -----------------------------------------------------------------------------
// Command Line Options
// -----------------------------------------------------------------------------
// Problem options
typedef enum {
  ELAS_LIN = 0, ELAS_HYPER_SS = 1, ELAS_HYPER_FS = 2
} problemType;
static const char *const problemTypes[] = {"linElas",
                                           "hyperSS",
                                           "hyperFS",
                                           "problemType","ELAS_",0
                                          };
static const char *const problemTypesForDisp[] = {"Linear elasticity",
                                                  "Hyper elasticity small strain",
                                                  "Hyper elasticity finite strain"
                                                 };

// Forcing function options
typedef enum {
  FORCE_NONE = 0, FORCE_CONST = 1, FORCE_MMS = 2
} forcingType;
static const char *const forcingTypes[] = {"none",
                                           "constant",
                                           "mms",
                                           "forcingType","FORCE_",0
                                          };
static const char *const forcingTypesForDisp[] = {"None",
                                                  "Constant",
                                                  "Manufactured solution"
                                                 };

// Multigrid options
typedef enum {
  MULTIGRID_LOGARITHMIC = 0, MULTIGRID_UNIFORM = 1, MULTIGRID_NONE = 2
} multigridType;
static const char *const multigridTypes [] = {"logarithmic",
                                              "uniform",
                                              "none",
                                              "multigridType","MULTIGRID",0
                                             };
static const char *const multigridTypesForDisp[] = {"P-multigrid, logarithmic coarsening",
                                                    "P-multigrind, uniform coarsening",
                                                    "No multigrid"
                                                   };

typedef PetscErrorCode BCFunc(PetscInt, PetscReal, const PetscReal *, PetscInt,
                              PetscScalar *, void *);
// Note: These variables should be updated if additional boundary conditions
//         are added to boundary.c.
BCFunc BCMMS, BCZero, BCClamp;

// MemType Options
static const char *const memTypes[] = {"host","device","memType",
                                       "CEED_MEM_",0
                                      };

// -----------------------------------------------------------------------------
// Structs
// -----------------------------------------------------------------------------
// Units
typedef struct Units_private *Units;
struct Units_private {
  // Fundamental units
  PetscScalar meter;
  PetscScalar kilogram;
  PetscScalar second;
  // Derived unit
  PetscScalar Pascal;
};

// Application context from user command line options
typedef struct AppCtx_private *AppCtx;
struct AppCtx_private {
  char          ceedResource[PETSC_MAX_PATH_LEN];     // libCEED backend
  char          meshFile[PETSC_MAX_PATH_LEN];         // exodusII mesh file
  PetscBool     testMode;
  PetscBool     viewSoln;
  PetscBool     viewFinalSoln;
  problemType   problemChoice;
  forcingType   forcingChoice;
  multigridType multigridChoice;
  PetscScalar   nuSmoother;
  PetscInt      degree;
  PetscInt      qextra;
  PetscInt      numLevels;
  PetscInt      *levelDegrees;
  PetscInt      numIncrements;                        // Number of steps
  PetscInt      bcClampCount;
  PetscInt      bcClampFaces[16];
  PetscScalar   bcClampMax[16][7];
  PetscInt      bcTractionCount;
  PetscInt      bcTractionFaces[16];
  PetscScalar   bcTractionVector[16][3];
  PetscScalar   forcingVector[3];
  PetscBool     petscHaveCuda, setMemTypeRequest;
  CeedMemType   memTypeRequested;
};

// Problem specific data
// *INDENT-OFF*
typedef struct {
  CeedInt           qdatasize;
  CeedQFunctionUser setupgeo, apply, jacob, energy, diagnostic;
  const char        *setupgeofname, *applyfname, *jacobfname, *energyfname,
                    *diagnosticfname;
  CeedQuadMode      qmode;
} problemData;
// *INDENT-ON*

// Data specific to each problem option
extern problemData problemOptions[3];

// Forcing function data
typedef struct {
  CeedQFunctionUser setupforcing;
  const char        *setupforcingfname;
} forcingData;

extern forcingData forcingOptions[3];

// Data for PETSc Matshell
typedef struct UserMult_private *UserMult;
struct UserMult_private {
  MPI_Comm        comm;
  DM              dm;
  Vec             Xloc, Yloc, NBCs;
  CeedVector      Xceed, Yceed;
  CeedOperator    op;
  CeedQFunction   qf;
  Ceed            ceed;
  PetscScalar     loadIncrement;
  CeedQFunctionContext ctxPhys, ctxPhysSmoother;
  CeedMemType     memType;
  int (*VecGetArray)(Vec, PetscScalar **);
  int (*VecGetArrayRead)(Vec, const PetscScalar **);
  int (*VecRestoreArray)(Vec, PetscScalar **);
  int (*VecRestoreArrayRead)(Vec, const PetscScalar **);
};

// Data for Jacobian setup routine
typedef struct FormJacobCtx_private *FormJacobCtx;
struct FormJacobCtx_private {
  UserMult     *jacobCtx;
  PetscInt     numLevels;
  SNES         snesCoarse;
  Mat          *jacobMat, jacobMatCoarse;
  Vec          Ucoarse;
};

// Data for PETSc Prolongation/Restriction Matshell
typedef struct UserMultProlongRestr_private *UserMultProlongRestr;
struct UserMultProlongRestr_private {
  MPI_Comm     comm;
  DM           dmC, dmF;
  Vec          locVecC, locVecF;
  CeedVector   ceedVecC, ceedVecF;
  CeedOperator opProlong, opRestrict;
  Ceed         ceed;
  CeedMemType   memType;
  int (*VecGetArray)(Vec, PetscScalar **);
  int (*VecGetArrayRead)(Vec, const PetscScalar **);
  int (*VecRestoreArray)(Vec, PetscScalar **);
  int (*VecRestoreArrayRead)(Vec, const PetscScalar **);
};

// libCEED data struct for level
typedef struct CeedData_private *CeedData;
struct CeedData_private {
  Ceed                ceed;
  CeedBasis           basisx, basisu, basisCtoF, basisEnergy, basisDiagnostic;
  CeedElemRestriction Erestrictx, Erestrictu, Erestrictqdi,
                      ErestrictGradui, ErestrictEnergy, ErestrictDiagnostic,
                      ErestrictqdDiagnostici;
  CeedQFunction       qfApply, qfJacob, qfEnergy, qfDiagnostic;
  CeedOperator        opApply, opJacob, opRestrict, opProlong, opEnergy,
                      opDiagnostic;
  CeedVector          qdata, qdataDiagnostic, gradu, xceed, yceed, truesoln;
};

// -----------------------------------------------------------------------------
// Process command line options
// -----------------------------------------------------------------------------
// Process general command line options
PetscErrorCode ProcessCommandLineOptions(MPI_Comm comm, AppCtx appCtx);

// Process physics options
PetscErrorCode ProcessPhysics(MPI_Comm comm, Physics phys, Units units);

// -----------------------------------------------------------------------------
// Setup DM
// -----------------------------------------------------------------------------
PetscErrorCode CreateBCLabel(DM dm, const char name[]);

// Create FE by degree
PetscErrorCode PetscFECreateByDegree(DM dm, PetscInt dim, PetscInt Nc,
                                     PetscBool isSimplex, const char prefix[],
                                     PetscInt order, PetscFE *fem);

// Read mesh and distribute DM in parallel
PetscErrorCode CreateDistributedDM(MPI_Comm comm, AppCtx appCtx, DM *dm);

// Setup DM with FE space of appropriate degree
PetscErrorCode SetupDMByDegree(DM dm, AppCtx appCtx, PetscInt order,
                               PetscBool boundary, PetscInt ncompu);

// -----------------------------------------------------------------------------
// libCEED Functions
// -----------------------------------------------------------------------------
// Destroy libCEED objects
PetscErrorCode CeedDataDestroy(CeedInt level, CeedData data);

// Utility function - essential BC dofs are encoded in closure indices as -(i+1)
PetscInt Involute(PetscInt i);

// Utility function to create local CEED restriction from DMPlex
PetscErrorCode CreateRestrictionFromPlex(Ceed ceed, DM dm, CeedInt P,
    CeedInt height, DMLabel domainLabel, CeedInt value,
    CeedElemRestriction *Erestrict);

// Utility function to get Ceed Restriction for each domain
PetscErrorCode GetRestrictionForDomain(Ceed ceed, DM dm, CeedInt height,
                                       DMLabel domainLabel, PetscInt value, CeedInt P, CeedInt Q, CeedInt qdatasize,
                                       CeedElemRestriction *restrictq, CeedElemRestriction *restrictx,
                                       CeedElemRestriction *restrictqdi);

// Set up libCEED for a given degree
PetscErrorCode SetupLibceedFineLevel(DM dm, DM dmEnergy, DM dmDiagnostic,
                                     Ceed ceed, AppCtx appCtx,
                                     CeedQFunctionContext physCtx,
                                     CeedData *data, PetscInt fineLevel,
                                     PetscInt ncompu, PetscInt Ugsz,
                                     PetscInt Ulocsz, CeedVector forceCeed,
                                     CeedVector neumannCeed);

// Set up libCEED multigrid level for a given degree
PetscErrorCode SetupLibceedLevel(DM dm, Ceed ceed, AppCtx appCtx,
                                 CeedData *data, PetscInt level,
                                 PetscInt ncompu, PetscInt Ugsz,
                                 PetscInt Ulocsz, CeedVector fineMult);

// Setup context data for Jacobian evaluation
PetscErrorCode SetupJacobianCtx(MPI_Comm comm, AppCtx appCtx, DM dm, Vec V,
                                Vec Vloc, CeedData ceedData, Ceed ceed,
                                CeedQFunctionContext ctxPhys,
                                CeedQFunctionContext ctxPhysSmoother,
                                UserMult jacobianCtx);

// Setup context data for prolongation and restriction operators
PetscErrorCode SetupProlongRestrictCtx(MPI_Comm comm, AppCtx appCtx, DM dmC,
                                       DM dmF, Vec VF, Vec VlocC, Vec VlocF,
                                       CeedData ceedDataC, CeedData ceedDataF,
                                       Ceed ceed,
                                       UserMultProlongRestr prolongRestrCtx);

// -----------------------------------------------------------------------------
// Jacobian setup
// -----------------------------------------------------------------------------
PetscErrorCode FormJacobian(SNES snes, Vec U, Mat J, Mat Jpre, void *ctx);

// -----------------------------------------------------------------------------
// Solution output
// -----------------------------------------------------------------------------
PetscErrorCode ViewSolution(MPI_Comm comm, Vec U, PetscInt increment,
                            PetscScalar loadIncrement);

PetscErrorCode ViewDiagnosticQuantities(MPI_Comm comm, DM dmU,
                                        UserMult user, Vec U,
                                        CeedElemRestriction ErestrictDiagnostic);

// -----------------------------------------------------------------------------
// libCEED Operators for MatShell
// -----------------------------------------------------------------------------
// This function uses libCEED to compute the local action of an operator
PetscErrorCode ApplyLocalCeedOp(Vec X, Vec Y, UserMult user);

// This function uses libCEED to compute the non-linear residual
PetscErrorCode FormResidual_Ceed(SNES snes, Vec X, Vec Y, void *ctx);

// This function uses libCEED to apply the Jacobian for assembly via a SNES
PetscErrorCode ApplyJacobianCoarse_Ceed(SNES snes, Vec X, Vec Y, void *ctx);

// This function uses libCEED to compute the action of the Jacobian
PetscErrorCode ApplyJacobian_Ceed(Mat A, Vec X, Vec Y);

// This function uses libCEED to compute the action of the prolongation operator
PetscErrorCode Prolong_Ceed(Mat A, Vec X, Vec Y);

// This function uses libCEED to compute the action of the restriction operator
PetscErrorCode Restrict_Ceed(Mat A, Vec X, Vec Y);

// This function returns the computed diagonal of the operator
PetscErrorCode GetDiag_Ceed(Mat A, Vec D);

// This function calculates the strain energy in the final solution
PetscErrorCode ComputeStrainEnergy(DM dmEnergy, UserMult user,
                                   CeedOperator opEnergy, Vec X,
                                   PetscReal *energy);

// -----------------------------------------------------------------------------
// Boundary Functions
// -----------------------------------------------------------------------------
// Note: If additional boundary conditions are added, an update is needed in
//         elasticity.h for the boundaryOptions variable.

// BCMMS - boundary function
// Values on all points of the mesh is set based on given solution below
// for u[0], u[1], u[2]
PetscErrorCode BCMMS(PetscInt dim, PetscReal loadIncrement,
                     const PetscReal coords[], PetscInt ncompu,
                     PetscScalar *u, void *ctx);

// BCClamp - fix boundary values with affine transformation at fraction of load
//   increment
PetscErrorCode BCClamp(PetscInt dim, PetscReal loadIncrement,
                       const PetscReal coords[], PetscInt ncompu,
                       PetscScalar *u, void *ctx);

#endif //setup_h


//g++ open_blas_measure.cpp -I /include/ -L/lib/ -lopenblas -lpthread
// #include <cblas.h>
#include <stdio.h>
#include <iostream>

#ifndef OPEN_BLAS
#define OPEN_BLAS

extern "C"{
  int dgemm_(char *, char *, int *, int *, int *, double *, double *, int *,
              double *, int *, double *, double *, int *);
}

/* Assuming row major order of matrices.

    This function is used to call open_blas multiplication. It takes the paramters given and
    puts the result of multiplication in *C.

    To be used in multiplication by open_blas
*/
void call_open_blas(double *A, int rowA, double *B, int colB, int commonSide, double *C) {
    char t = 'N';
    double alpha =1.0;
    double beta = 0.0;
    dgemm_(&t, &t, &rowA, &colB, &commonSide, &alpha, A, &rowA, B, &commonSide, &beta, C, &rowA);
}

#endif


/*
 * Copyright (c) 2010-2018 The University of Tennessee and The University
 *                         of Tennessee Research Foundation.  All rights
 *                         reserved.
 * Copyright (c) 2013      Inria. All rights reserved.
 *
 * @precisions normal z -> c d s
 *
 */

#include <lapacke.h>
#include "dplasma.h"
#include "dplasmatypes.h"

#include "map2.h"

static int
dplasma_zlacpy_operator( parsec_execution_stream_t *es,
                         const parsec_tiled_matrix_dc_t *descA,
                         const parsec_tiled_matrix_dc_t *descB,
                         const void *_A, void *_B,
                         PLASMA_enum uplo, int m, int n,
                         void *args )
{
    int tempmm, tempnn, ldam, ldbm;
    const parsec_complex64_t *A = (const parsec_complex64_t*)_A;
    parsec_complex64_t       *B = (parsec_complex64_t*)_B;
    (void)es;
    (void)args;

    tempmm = ((m)==((descA->mt)-1)) ? ((descA->m)-(m*(descA->mb))) : (descA->mb);
    tempnn = ((n)==((descA->nt)-1)) ? ((descA->n)-(n*(descA->nb))) : (descA->nb);
    ldam = BLKLDD( descA, m );
    ldbm = BLKLDD( descB, m );

    LAPACKE_zlacpy_work(
        LAPACK_COL_MAJOR, lapack_const( uplo ), tempmm, tempnn, A, ldam, B, ldbm);

    return 0;
}

/**
 *******************************************************************************
 *
 * @ingroup dplasma_complex64
 *
 * dplasma_zlacpy_New - Generates an taskpool that performs a copy of the matrix A
 * into the matrix B.
 *
 * See dplasma_map2_New() for further information.
 *
 * WARNING: The computations are not done by this call.
 *
 *******************************************************************************
 *
 * @param[in] uplo
 *          Specifies which part of matrix A is copied:
 *          = PlasmaUpperLower: All matrix is referenced.
 *          = PlasmaUpper:      Only upper part is refrenced.
 *          = PlasmaLower:      Only lower part is referenced.
 *
 * @param[in] A
 *          Descriptor of the distributed original matrix A. Any tiled matrix
 *          descriptor can be used. However, if the data is stored in column
 *          major, the tile distribution must match the one of the matrix B.
 *
 * @param[in,out] B
 *          Descriptor of the distributed destination matrix B. Any tiled matrix
 *          descriptor can be used, with no specific storage.
 *
 *******************************************************************************
 *
 * @return
 *          \retval NULL if incorrect parameters are given.
 *          \retval The parsec taskpool describing the operation that can be
 *          enqueued in the runtime with parsec_context_add_taskpool(). It, then, needs to be
 *          destroy with dplasma_zlacpy_Destruct();
 *
 *******************************************************************************
 *
 * @sa dplasma_zlacpy
 * @sa dplasma_zlacpy_Destruct
 * @sa dplasma_clacpy_New
 * @sa dplasma_dlacpy_New
 * @sa dplasma_slacpy_New
 *
 ******************************************************************************/
parsec_taskpool_t*
dplasma_zlacpy_New( PLASMA_enum uplo,
                    const parsec_tiled_matrix_dc_t *A,
                    parsec_tiled_matrix_dc_t *B)
{
    parsec_taskpool_t* tp;

    tp = dplasma_map2_New(uplo, PlasmaNoTrans, A, B,
                          dplasma_zlacpy_operator, NULL );

    return tp;
}

/**
 *******************************************************************************
 *
 * @ingroup dplasma_complex64
 *
 *  dplasma_zlacpy_Destruct - Free the data structure associated to an taskpool
 *  created with dplasma_zlacpy_New().
 *
 *******************************************************************************
 *
 * @param[in,out] taskpool
 *          On entry, the taskpool to destroy.
 *          On exit, the taskpool cannot be used anymore.
 *
 *******************************************************************************
 *
 * @sa dplasma_zlacpy_New
 * @sa dplasma_zlacpy
 *
 ******************************************************************************/
void
dplasma_zlacpy_Destruct( parsec_taskpool_t *tp )
{
    dplasma_map2_Destruct(tp);
}

/**
 *******************************************************************************
 *
 * @ingroup dplasma_complex64
 *
 * dplasma_zlacpy - Generates an taskpool that performs a copy of the matrix A
 * into the matrix B.
 *
 * See dplasma_map2() for further information.
 *
 *******************************************************************************
 *
 * @param[in,out] parsec
 *          The parsec context of the application that will run the operation.
 *
 * @param[in] uplo
 *          Specifies which part of matrix A is copied:
 *          = PlasmaUpperLower: All matrix is referenced.
 *          = PlasmaUpper:      Only upper part is refrenced.
 *          = PlasmaLower:      Only lower part is referenced.
 *
 * @param[in] A
 *          Descriptor of the distributed original matrix A. Any tiled matrix
 *          descriptor can be used. However, if the data is stored in column
 *          major, the tile distribution must match the one of the matrix B.
 *
 * @param[in,out] B
 *          Descriptor of the distributed destination matrix B. Any tiled matrix
 *          descriptor can be used, with no specific storage.
 *
 *******************************************************************************
 *
 * @return
 *          \retval -i if the ith parameters is incorrect.
 *          \retval 0 on success.
 *
 *******************************************************************************
 *
 * @sa dplasma_zlacpy_New
 * @sa dplasma_zlacpy_Destruct
 * @sa dplasma_clacpy
 * @sa dplasma_dlacpy
 * @sa dplasma_slacpy
 *
 ******************************************************************************/
int
dplasma_zlacpy( parsec_context_t *parsec,
                PLASMA_enum uplo,
                const parsec_tiled_matrix_dc_t *A,
                parsec_tiled_matrix_dc_t *B)
{
    parsec_taskpool_t *parsec_zlacpy = NULL;

    if ((uplo != PlasmaUpperLower) &&
        (uplo != PlasmaUpper)      &&
        (uplo != PlasmaLower))
    {
        dplasma_error("dplasma_zlacpy", "illegal value of uplo");
        return -2;
    }

    if ( (A->m > B->m) || (A->n > B->n) ) {
        dplasma_error("dplasma_zlacpy", "illegal matrix A (B is smaller than A)");
        return -3;
    }

    parsec_zlacpy = dplasma_zlacpy_New(uplo, A, B);

    if ( parsec_zlacpy != NULL )
    {
        parsec_context_add_taskpool(parsec, (parsec_taskpool_t*)parsec_zlacpy);
        dplasma_wait_until_completion(parsec);
        dplasma_zlacpy_Destruct( parsec_zlacpy );
    }
    return 0;
}