#' Maximization step using coordinate descent optimization.
#'
#' @param p List of parameters.
#' @param item_data Matrix or data frame of item responses.
#' @param pred_data Matrix or data frame of DIF and/or impact predictors.
#' @param mean_predictors Possibly different matrix of predictors for the mean
#' impact equation.
#' @param var_predictors Possibly different matrix of predictors for the
#' variance impact equation.
#' @param eout E step output, including matrix for item and impact equations,
#' in addition to theta values (possibly adaptive).
#' @param item_type Optional character value or vector indicating the type of
#' item to be modeled.
#' @param pen_type Character value indicating the penalty function to use.
#' @param tau_current A single numeric value of tau that exists within
#' \code{tau_vec}.
#' @param pen Current penalty index.
#' @param alpha Numeric value indicating the alpha parameter in the elastic net
#' penalty function.
#' @param gamma Numeric value indicating the gamma parameter in the MCP
#' function.
#' @param anchor Optional numeric value or vector indicating which item
#' response(s) are anchors (e.g., \code{anchor = 1}).
#' @param final_control Control parameters.
#' @param samp_size Sample size in data set.
#' @param num_responses Number of responses for each item.
#' @param num_items Number of items in data set.
#' @param num_quad Number of quadrature points used for approximating the
#' latent variable.
#' @param num_predictors Number of predictors.
#' @param num_tau Logical indicating whether the minimum tau value needs to be
#' identified during the regDIF procedure.
#' @param max_tau Logical indicating whether to output the maximum tau value
#' needed to remove all DIF from the model.
#'
#' @return a \code{"list"} of estimates obtained from the maximization step using univariate
#' Newton-Raphson (i.e., one step of coordinate descent)
#'
#' @importFrom foreach %dopar%
#' @keywords internal
#'
Mstep_cd <-
  function(p,
           item_data,
           pred_data,
           mean_predictors,
           var_predictors,
           eout,
           item_type,
           pen_type,
           tau_current,
           pen,
           alpha,
           gamma,
           anchor,
           final_control,
           samp_size,
           num_responses,
           num_items,
           num_quad,
           num_predictors,
           num_tau,
           max_tau) {

  # Set under-identified model to FALSE until proven TRUE.
  under_identified <- FALSE

  # Update theta and etable.
  theta <- eout$theta
  etable <- eout$etable

  # Last Mstep
  if(max_tau) id_max_z <- 0

  # Latent mean impact updates.
  for(cov in 1:ncol(mean_predictors)) {
    anl_deriv <- d_alpha(c(p[[num_items+1]],p[[num_items+2]]),
                             etable,
                             theta,
                             mean_predictors,
                             var_predictors,
                             cov=cov,
                             samp_size,
                             num_items,
                             num_quad)
    p[[num_items+1]][[cov]] <-
      p[[num_items+1]][[cov]] - anl_deriv[[1]]/anl_deriv[[2]]
  }

  # Latent variance impact updates.
  for(cov in 1:ncol(var_predictors)) {
    anl_deriv <- d_phi(c(p[[num_items+1]],p[[num_items+2]]),
                           etable,
                           theta,
                           mean_predictors,
                           var_predictors,
                           cov=cov,
                           samp_size,
                           num_items,
                           num_quad)
    p[[num_items+2]][[cov]] <-
      p[[num_items+2]][[cov]] - anl_deriv[[1]]/anl_deriv[[2]]
  }

  # Item response updates.
  if(final_control$parallel[[1]]) {
    parallel::clusterExport(final_control$parallel[[2]],
                            c("num_responses", "pred_data", "item_data",
                               "samp_size", "num_predictors", "num_quad", "num_items",
                               "prox_data", "item_type", "anchor", "pen_type",
                               "num_tau", "pen", "tau_vec", "alpha", "final_control",
                               "max_tau", "d_bernoulli_itemblock", "d_bernoulli_itemblock_proxy",
                               "grp_soft_threshold", "grp_firm_threshold", "soft_threshold",
                               "firm_threshold", "p", "eout", "inv_hess_diag", "tau_current",
                               "under_identified", "id_max_z"),
                            envir=environment())

    p_items <- foreach::foreach(item=1:num_items) %dopar% {
      # Get posterior probabilities.

      # Obtain E-tables for each response category.
      if(item_type[item] != "cfa") {
        etable_item <- lapply(1:num_responses[item], function(x) etable)
        for(resp in 1:num_responses[item]) {
          etable_item[[resp]][which(
            !(item_data[,item] == resp)), ] <- 0
        }
      }

      # Bernoulli responses.
      if(item_type[item] == "2pl") {

        # Intercept updates.
        anl_deriv <- d_bernoulli("c0",
                                 p[[item]],
                                 etable_item,
                                 theta,
                                 pred_data,
                                 cov=0,
                                 samp_size,
                                 num_items,
                                 num_quad)
        p[[item]][[1]] <- p[[item]][[1]] - anl_deriv[[1]]/anl_deriv[[2]]

        # Slope updates.
        if(item_type[item] != "rasch") {
          anl_deriv <- d_bernoulli("a0",
                                   p[[item]],
                                   etable_item,
                                   theta,
                                   pred_data,
                                   cov=0,
                                   samp_size,
                                   num_items,
                                   num_quad)
          p[[item]][[2]] <- p[[item]][[2]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        if(!any(item == anchor)) {

          p2 <- unlist(p)

          # Intercept DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("c1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            anl_deriv <- d_bernoulli("c1",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     cov,
                                     samp_size,
                                     num_items,
                                     num_quad)
            z <- p[[item]][[2+cov]] - anl_deriv[[1]]/anl_deriv[[2]]
            if(max_tau) id_max_z <- c(id_max_z,z)
            p[[item]][[2+cov]] <- ifelse(pen_type == "lasso",
                                         soft_threshold(z,alpha,tau_current),
                                         firm_threshold(z,alpha,tau_current,gamma))
          }

          # Slope DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("a1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            if(item_type[item] != "rasch") {
              anl_deriv <- d_bernoulli("a1",
                                       p[[item]],
                                       etable_item,
                                       theta,
                                       pred_data,
                                       cov,
                                       samp_size,
                                       num_items,
                                       num_quad)
              z <- p[[item]][[2+num_predictors+cov]] -
                anl_deriv[[1]]/anl_deriv[[2]]
              if(max_tau) id_max_z <- c(id_max_z,z)
              p[[item]][[2+num_predictors+cov]] <-
                ifelse(pen_type == "lasso",
                       soft_threshold(z,alpha,tau_current),
                       firm_threshold(z,alpha,tau_current,gamma))
            }

          }

        }

        # Categorical.
      } else {

        # Intercept updates.
        anl_deriv <- d_categorical("c0",
                                   p[[item]],
                                   etable_item,
                                   theta,
                                   pred_data,
                                   thr=-1,
                                   cov=-1,
                                   samp_size,
                                   num_responses[[item]],
                                   num_items,
                                   num_quad)
        p[[item]][[1]] <- p[[item]][[1]] - anl_deriv[[1]]/anl_deriv[[2]]

        # Threshold updates.
        for(thr in 2:(num_responses[item]-1)) {
          anl_deriv <- d_categorical("c0",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     thr=thr,
                                     cov=-1,
                                     samp_size,
                                     num_responses[[item]],
                                     num_items,
                                     num_quad)
          p[[item]][[thr]] <- p[[item]][[thr]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        # Slope updates.
        if(item_type[item] != "rasch") {
          anl_deriv <- d_categorical("a0",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     thr=-1,
                                     cov=-1,
                                     samp_size,
                                     num_responses[[item]],
                                     num_items,
                                     num_quad)
          p[[item]][[num_responses[[item]]]] <-
            p[[item]][[num_responses[[item]]]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        if(!any(item == anchor)){

          p2 <- unlist(p)

          # Intercept DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("c1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            anl_deriv <- d_categorical("c1",
                                       p[[item]],
                                       etable_item,
                                       theta,
                                       pred_data,
                                       thr=-1,
                                       cov,
                                       samp_size,
                                       num_responses[[item]],
                                       num_items,
                                       num_quad)
            z <- p[[item]][[num_responses[[item]]+cov]] -
              anl_deriv[[1]]/anl_deriv[[2]]
            if(max_tau) id_max_z <- c(id_max_z,z)
            p[[item]][[num_responses[[item]]+cov]] <-
              ifelse(pen_type == "lasso",
                     soft_threshold(z,alpha,tau_current),
                     firm_threshold(z,alpha,tau_current,gamma))
          }

          # Slope DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("a1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            if(item_type[item] != "rasch") {
              anl_deriv <- d_categorical("a1",
                                         p[[item]],
                                         etable_item,
                                         theta,
                                         pred_data,
                                         thr=-1,
                                         cov,
                                         samp_size,
                                         num_responses[[item]],
                                         num_items,
                                         num_quad)
              z <- p[[item]][[length(p[[item]])-ncol(pred_data)+cov]] -
                anl_deriv[[1]]/anl_deriv[[2]]
              if(max_tau) id_max_z <- c(id_max_z,z)
              p[[item]][[length(p[[item]])-ncol(pred_data)+cov]] <-
                ifelse(pen_type == "lasso",
                       soft_threshold(z,alpha,tau_current),
                       firm_threshold(z,alpha,tau_current,gamma))
            }
          }
        }

      }
      return(list(unlist(p[item]),id_max_z))
    }

    for(item in 1:num_items) {
      p[[item]] <- p_items[[item]][[1]]
    }

  } else {

    for (item in 1:num_items) {

      # Obtain E-tables for each response category.
      if(item_type[item] != "cfa") {
        etable_item <- lapply(1:num_responses[item], function(x) etable)
        for(resp in 1:num_responses[item]) {
          etable_item[[resp]][which(
            !(item_data[,item] == resp)), ] <- 0
        }
      }

      if(item_type[item] == "cfa") {

        # Intercept updates.
        anl_deriv <- d_mu_gaussian("c0",
                                   p[[item]],
                                   etable,
                                   theta,
                                   item_data[,item],
                                   pred_data,
                                   cov=NULL,
                                   samp_size,
                                   num_items,
                                   num_quad)
        p[[item]][[1]] <- p[[item]][[1]] - anl_deriv[[1]]/anl_deriv[[2]]

        # Slope updates.
        if(item_type[item] != "rasch") {
          a0_parms <- grep(paste0("a0_item",item,"_"),names(p[[item]]),fixed=T)
          anl_deriv <- d_mu_gaussian("a0",
                                     p[[item]],
                                     etable,
                                     theta,
                                     item_data[,item],
                                     pred_data,
                                     cov=NULL,
                                     samp_size,
                                     num_items,
                                     num_quad)
          p[[item]][[2]] <- p[[item]][a0_parms] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        # Residual updates.
        s0_parms <- grep(paste0("s0_item",item,"_"),names(p[[item]]),fixed=T)
        anl_deriv <- d_sigma_gaussian("s0",
                                      p[[item]],
                                      etable,
                                      theta,
                                      item_data[,item],
                                      pred_data,
                                      cov=NULL,
                                      samp_size,
                                      num_items,
                                      num_quad)
        p[[item]][s0_parms][[1]] <- p[[item]][s0_parms][[1]] -
          anl_deriv[[1]]/anl_deriv[[2]]
        if(p[[item]][s0_parms][[1]] < 0) p[[item]][s0_parms][[1]] <- 1

        if(!any(item == anchor)) {

          # Residual DIF updates.
          for(cov in 1:num_predictors) {
            s1_parms <-
              grep(paste0("s1_item",item,"_cov",cov),names(p[[item]]),fixed=T)
            anl_deriv <- d_sigma_gaussian("s1",
                                          p[[item]],
                                          etable,
                                          theta,
                                          item_data[,item],
                                          pred_data,
                                          cov=cov,
                                          samp_size,
                                          num_items,
                                          num_quad)
            p[[item]][s1_parms][[1]] <- p[[item]][s1_parms][[1]] -
              anl_deriv[[1]]/anl_deriv[[2]]
          }

          p2 <- unlist(p)

          # Intercept DIF updates.
          for(cov in 1:num_predictors){

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("c1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            c1_parms <-
              grep(paste0("c1_item",item,"_cov",cov),names(p[[item]]),fixed=T)
            anl_deriv <- d_mu_gaussian("c1",
                                       p[[item]],
                                       etable,
                                       theta,
                                       item_data[,item],
                                       pred_data,
                                       cov,
                                       samp_size,
                                       num_items,
                                       num_quad)
            z <- p[[item]][c1_parms] - anl_deriv[[1]]/anl_deriv[[2]]
            if(max_tau) id_max_z <- c(id_max_z,z)
            p[[item]][c1_parms][[1]] <-
              ifelse(pen_type == "lasso",
                     soft_threshold(z,alpha,tau_current),
                     firm_threshold(z,alpha,tau_current,gamma))
          }

          # Slope DIF updates.
          for(cov in 1:num_predictors){

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("a1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            if(item_type[item] != "rasch"){
              a1_parms <-
                grep(paste0("a1_item",item,"_cov",cov),names(p[[item]]),fixed=T)
              anl_deriv <- d_mu_gaussian("a1",
                                         p[[item]],
                                         etable,
                                         theta,
                                         item_data[,item],
                                         pred_data,
                                         cov,
                                         samp_size,
                                         num_items,
                                         num_quad)
              z <- p[[item]][a1_parms] - anl_deriv[[1]]/anl_deriv[[2]]
              if(max_tau) id_max_z <- c(id_max_z,z)
              p[[item]][a1_parms][[1]] <- ifelse(pen_type == "lasso",
                                                 soft_threshold(z,alpha,tau_current),
                                                 firm_threshold(z,alpha,tau_current,gamma))
            }
          }
        }

        # Bernoulli responses.
      } else if(item_type[item] == "2pl") {

        # Intercept updates.
        anl_deriv <- d_bernoulli("c0",
                                 p[[item]],
                                 etable_item,
                                 theta,
                                 pred_data,
                                 cov=0,
                                 samp_size,
                                 num_items,
                                 num_quad)
        p[[item]][[1]] <- p[[item]][[1]] - anl_deriv[[1]]/anl_deriv[[2]]

        # Slope updates.
        if(item_type[item] != "rasch") {
          anl_deriv <- d_bernoulli("a0",
                                   p[[item]],
                                   etable_item,
                                   theta,
                                   pred_data,
                                   cov=0,
                                   samp_size,
                                   num_items,
                                   num_quad)
          p[[item]][[2]] <- p[[item]][[2]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        if(!any(item == anchor)) {

          p2 <- unlist(p)

          # Intercept DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("c1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            anl_deriv <- d_bernoulli("c1",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     cov,
                                     samp_size,
                                     num_items,
                                     num_quad)
            z <- p[[item]][[2+cov]] - anl_deriv[[1]]/anl_deriv[[2]]
            if(max_tau) id_max_z <- c(id_max_z,z)
            p[[item]][[2+cov]] <- ifelse(pen_type == "lasso",
                                         soft_threshold(z,alpha,tau_current),
                                         firm_threshold(z,alpha,tau_current,gamma))
          }

          # Slope DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("a1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            if(item_type[item] != "rasch") {
              anl_deriv <- d_bernoulli("a1",
                                       p[[item]],
                                       etable_item,
                                       theta,
                                       pred_data,
                                       cov,
                                       samp_size,
                                       num_items,
                                       num_quad)
              z <- p[[item]][[2+num_predictors+cov]] -
                anl_deriv[[1]]/anl_deriv[[2]]
              if(max_tau) id_max_z <- c(id_max_z,z)
              p[[item]][[2+num_predictors+cov]] <-
                ifelse(pen_type == "lasso",
                       soft_threshold(z,alpha,tau_current),
                       firm_threshold(z,alpha,tau_current,gamma))
            }

          }

        }

        # Categorical.
      } else {

        # Intercept updates.
        anl_deriv <- d_categorical("c0",
                                   p[[item]],
                                   etable_item,
                                   theta,
                                   pred_data,
                                   thr=-1,
                                   cov=-1,
                                   samp_size,
                                   num_responses[[item]],
                                   num_items,
                                   num_quad)
        p[[item]][[1]] <- p[[item]][[1]] - anl_deriv[[1]]/anl_deriv[[2]]

        # Threshold updates.
        for(thr in 2:(num_responses[item]-1)) {
          anl_deriv <- d_categorical("c0",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     thr=thr,
                                     cov=-1,
                                     samp_size,
                                     num_responses[[item]],
                                     num_items,
                                     num_quad)
          p[[item]][[thr]] <- p[[item]][[thr]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        # Slope updates.
        if(item_type[item] != "rasch") {
          anl_deriv <- d_categorical("a0",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     thr=-1,
                                     cov=-1,
                                     samp_size,
                                     num_responses[[item]],
                                     num_items,
                                     num_quad)
          p[[item]][[num_responses[[item]]]] <-
            p[[item]][[num_responses[[item]]]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        if(!any(item == anchor)){

          p2 <- unlist(p)

          # Intercept DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("c1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            anl_deriv <- d_categorical("c1",
                                       p[[item]],
                                       etable_item,
                                       theta,
                                       pred_data,
                                       thr=-1,
                                       cov,
                                       samp_size,
                                       num_responses[[item]],
                                       num_items,
                                       num_quad)
            z <- p[[item]][[num_responses[[item]]+cov]] -
              anl_deriv[[1]]/anl_deriv[[2]]
            if(max_tau) id_max_z <- c(id_max_z,z)
            p[[item]][[num_responses[[item]]+cov]] <-
              ifelse(pen_type == "lasso",
                     soft_threshold(z,alpha,tau_current),
                     firm_threshold(z,alpha,tau_current,gamma))
          }

          # Slope DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("a1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            if(item_type[item] != "rasch") {
              anl_deriv <- d_categorical("a1",
                                         p[[item]],
                                         etable_item,
                                         theta,
                                         pred_data,
                                         thr=-1,
                                         cov,
                                         samp_size,
                                         num_responses[[item]],
                                         num_items,
                                         num_quad)
              z <- p[[item]][[length(p[[item]])-ncol(pred_data)+cov]] -
                anl_deriv[[1]]/anl_deriv[[2]]
              if(max_tau) id_max_z <- c(id_max_z,z)
              p[[item]][[length(p[[item]])-ncol(pred_data)+cov]] <-
                ifelse(pen_type == "lasso",
                       soft_threshold(z,alpha,tau_current),
                       firm_threshold(z,alpha,tau_current,gamma))
            }
          }
        }

      }

    }

  }

  if(max_tau) {
    if(final_control$parallel[[1]]) {
      id_max_z <- max(abs(sapply(1:num_items, function(items) p_items[[items]][[2]])))
    } else{
      id_max_z <- max(abs(id_max_z))
    }
    return(id_max_z)
  } else {
    return(list(p=p,
                under_identified=under_identified))
  }

}


      subroutine inmodel
c******************************************************************************
c     This subroutine reads in the model
c******************************************************************************

      implicit real*8 (a-h,o-z)
      include 'Atmos.com'
      include 'Linex.com'
      include 'Mol.com'
      include 'Quants.com'
      include 'Factor.com'
      include 'Dummy.com'
      include 'Pstuff.com'
      real*8 element(95), logepsilon(95)
      real*8 kaprefmass(100)
      real*8 bmol(110)
      integer nel(7)
      character list*80, list2*70
      integer append
      data (nel(i),i=1,7)/  1,  2,  6, 12, 13, 14, 26/

c*****Read in the key word to define the model type
      modelnum = modelnum + 1
      rewind nfmodel
      read (nfmodel,2001) modtype
      write (nf1out,1010) modtype
      if (modtype .eq. 'begn      ' .or.  modtype .eq. 'BEGN      ')
     .   write (nf1out,1011)

c*****Read a comment line (usually describing the model)
      read (nfmodel,2002) moditle

c*****Read the number of depth points
      read (nfmodel,2002) list
      list2 = list(11:)
      read (list2,*) ntau
      if (ntau .gt. 100) then
         write (array,1012)
         call prinfo (10)
         stop
      endif

c*****EITHER: Read in a model from the output of the experimental new
c     MARCS code.  This modtype is called "NEWMARCS".  On each line
c     the numbers are:
c     tau(5000), t, pe, pgas, rho,  model microtrubulent velocity,
c     and mean opacity (cm^2/gm) at the reference wavelength (5000A).
      if (modtype .eq. 'NEWMARCS  ') then
         read (nfmodel,*) wavref
         do i=1,ntau
            read (nfmodel,*) tauref(i),t(i),ne(i),pgas(i),rho(i),
     .                         vturb(1),kaprefmass(i)
         enddo
c*****OR: Read in a model from the output of the on-line new
c     MARCS code.  This modtype is called "WEBMARCS".  On each line
c     the numbers are:
c     layer number (not needed), log{tau(Rosseland)} (not needed),
c     log{tau(5000)}, depth, t, pe, pgas, prad (not read in) and
c     pturb (not read in)
      elseif (modtype .eq. 'WEBMARCS') then
         read (nfmodel,*) wavref
         do i=1,ntau
            read (nfmodel,*) k, dummy1(k), tauref(i), dummy2(k), t(i),
     .                       ne(i), pgas(i)
         enddo
c*****OR: Read in a model from an alternative form of on-line new
c     MARCS code.  This modtype is called "WEB2MARC".  On each line
c     the numbers are:
c     atmospheric layer number (not needed), log{tau(5000)}, t,
c     log(Pe), log(Pgas), rhox
      elseif (modtype .eq. 'WEB2MARC') then
         read (nfmodel,*) wavref
         do i=1,ntau
            read (nfmodel,*) k,tauref(i),t(i),ne(i),pgas(i),rhox(i)
         enddo
c     OR: Read in a model from the output of the ATLAS code.  This
c     modtype is called "KURUCZ".  On each line the numbers are:
c     rhox, t, pgas, ne, and Rosseland mean opacity (cm^2/gm), and
c     two numbers not used by MOOG.
      elseif (modtype .eq. 'KURUCZ    ') then
         do i=1,ntau
            read (nfmodel,*) rhox(i),t(i),pgas(i),ne(i),kaprefmass(i)
         enddo
c     OR: Read in a model from the output of the NEXTGEN code.  This
c     modtype is called "NEXTGEN".  These models have tau scaled at a
c     specific wavelength that is read in before the model. MOOG will
c     need to generate the opacities internally.On each line the numbers
c     are: tau, t, pgas, pe, density, mean molecular weight, two numbers
c     not used by MOOG, and Rosseland mean opacity (cm^2/gm).
      elseif (modtype .eq. 'NEXTGEN   ') then
         read (nfmodel,*) wavref
         do i=1,ntau
            read (nfmodel,*) tauref(i),t(i),pgas(i),ne(i), rho(i),
     .                       molweight(i), x2, x3, kaprefmass(i)
         enddo
c     OR: Read in a model from the output of the MARCS code.  This modtype
c     type is called "BEGN".  On each line the numbers are:
c     tauross, t, log(pg), log(pe), mol weight, and kappaross.
      elseif (modtype .eq. 'BEGN      ') then
         do i=1,ntau
            read (nfmodel,*) tauref(i),t(i),pgas(i),ne(i),
     .                          molweight(i),  kaprefmass(i)
         enddo
c     OR: Read in a model generated from ATLAS, but without accompanying
c     opacities.  MOOG will need to generate the opacities internally,
c     using a reference wavelength that it reads in before the model.
      elseif (modtype .eq. 'KURTYPE') then
         read (nfmodel,*) wavref
         do i=1,ntau
            read (nfmodel,*) rhox(i),t(i),pgas(i),ne(i)
         enddo
c     OR: Read in a model generated from ATLAS, with output generated
c     in Padova.  The columns are in somewhat different order than normal
      elseif (modtype .eq. 'KUR-PADOVA') then
         read (nfmodel,*) wavref
         do i=1,ntau
            read (nfmodel,*) tauref(i),t(i),kaprefmass(i),
     .                         ne(i),pgas(i),rho(i)
         enddo
c     OR: Read in a generic model that has a tau scale at a specific
c     wavelength that is read in before the model.
c     MOOG will need to generate the opacities internally.
      elseif (modtype .eq. 'GENERIC   ') then
         read (nfmodel,*) wavref
         do i=1,ntau
            read (nfmodel,*) tauref(i),t(i),pgas(i),ne(i)
         enddo
c     OR: quit in utter confusion if those model types are not specified
      else
         write (*,1001)
         stop
      endif

c*****Compute other convenient forms of the temperatures
      do i=1,ntau
          theta(i) = 5040./t(i)
          tkev(i) = 8.6171d-5*t(i)
          tlog(i) = dlog(t(i))
      enddo

c*****Convert from logarithmic Pgas scales, if needed
      if (pgas(ntau)/pgas(1) .lt. 10.) then
         do i=1,ntau
            pgas(i) = 10.0**pgas(i)
         enddo
      endif

c*****Convert from logarithmic Ne scales, if needed
      if(ne(ntau)/ne(1) .lt. 20.) then
         do i=1,ntau
            ne(i) = 10.0**ne(i)
         enddo
      endif

c*****Convert from Pe to Ne, if needed
      if(ne(ntau) .lt. 1.0e7) then
         do i=1,ntau
            ne(i) = ne(i)/1.38054d-16/t(i)
         enddo
      endif

c*****compute the atomic partition functions
      do j=1,95
         elem(j) = dble(j)
         call partfn (elem(j),j)
      enddo

c*****Read the microturbulence (either a single value to apply to
c     all layers, or a value for each of the ntau layers).
c     Conversion to cm/sec from km/sec is done if needed
      read (nfmodel,2003) (vturb(i),i=1,6)
      if (vturb(2) .ne. 0.) then
         read (nfmodel,2003) (vturb(i),i=7,ntau)
      else
         do i=2,ntau
            vturb(i) = vturb(1)
         enddo
      endif
      if (vturb(1) .lt. 100.) then
         write (moditle(55:62),1008) vturb(1)
         do i=1,ntau
            vturb(i) = 1.0e5*vturb(i)
         enddo
      else
         write (moditle(55:62),1008) vturb(1)/1.0e5
      endif

c*****Read in the abundance data, storing the original abundances in xabu
c*****The abundances not read in explicity are taken from the default
c*****solar ones contained in array xsolar.
      read (nfmodel,2002) list
      list2 = list(11:)
      read (list2,*) natoms,abscale
      write (moditle(63:73),1009) abscale
      if(natoms .ne. 0)
     .         read (nfmodel,*) (element(i),logepsilon(i),i=1,natoms)
      xhyd = 10.0**xsolar(1)
      xabund(1) = 1.0
      xabund(2) = 10.0**xsolar(2)/xhyd
      do i=3,95
         xabund(i) = 10.0**(xsolar(i)+abscale)/xhyd
         xabu(i) = xabund(i)
      enddo
      if (natoms .ne. 0) then
         do i=1,natoms
            xabund(idint(element(i))) = 10.0**logepsilon(i)/xhyd
            xabu(idint(element(i))) = 10.0**logepsilon(i)/xhyd
         enddo
      endif

c*****Compute the mean molecular weight, ignoring molecule formation
c     in this approximation (maybe make more general some day?)
      wtnum = 0.
      wtden = 0.
      do i=1,95
         wtnum = wtnum + xabund(i)*xam(i)
         wtden = wtden + xabund(i)
      enddo
      wtmol = wtnum/(xam(1)*wtden)
      nomolweight = 0
      if (modtype .eq. 'BEGN      ' .or. modtype .eq. 'NEXTGEN   ') then
         nomolweight = 1
      endif
      if (nomolweight .ne. 1) then
         do i=1,ntau
             molweight(i) = wtmol
         enddo
      endif

c*****Compute the density
      if (modtype .ne. 'NEXTGEN   ') then
         do i=1,ntau
            rho(i) = pgas(i)*molweight(i)*1.6606d-24/(1.38054d-16*t(i))
         enddo
      endif

c*****Calculate the fictitious number density of hydrogen
c     Note:  ph = (-b1 + dsqrt(b1*b1 - 4.0*a1*c1))/(2.0*a1)
      iatom = 1
      call partfn (dble(iatom),iatom)
      do i=1,ntau
         th = 5040.0/t(i)
         ah2 = 10.0**(-(12.7422+(-5.1137+(0.1145-0.0091*th)*th)*th))
         a1 = (1.0+2.0*xabund(2))*ah2
         b1 = 1.0 + xabund(2)
         c1 = -pgas(i)
         ph = (-b1/2.0/a1)+dsqrt((b1**2/(4.0*a1*a1))-(c1/a1))
         nhtot(i) = (ph+2.0*ph*ph*ah2)/(1.38054d-16*t(i))
      enddo

c*****Molecular equilibrium called here.
c     First, a default list of ions and molecules is considered. Then the
c     user's list is read in. A check is performed to see if any of these
c     species need to be added. If so, then they are appended to the
c     default list. The molecular equilibrium routine is then called.
c     Certain species are important for continuous opacities and damping
c     calculations - these are read from the equilibrium solution and
c     saved.

c*****Set up the default molecule list
      if (molset .eq. 0) then
         nmol = 30
      else
         nmol = 59
      endif
      if     (molset .eq. 0) then
         do i=1,110
            amol(i) = smallmollist(i)
         enddo
      elseif (molset .eq. 1) then
         do i=1,110
            amol(i) = largemollist(i)
         enddo
      else
         array = 'molset = 0 or 1 only; I quit!'
         call putasci (29,6)
         stop
      endif

c*****Read in the names of additional molecules to be used in
c     molecular equilibrium if needed.
      read (nfmodel,2002,end=101) list
      list2 = list(11:)
      read (list2,*) moremol
      if (moremol .ne. 0) then
         read (nfmodel,*) (bmol(i),i=1,moremol)
         append = 1
         do k=1,moremol
            do l=1,nmol
               if (nint(bmol(k)) .eq. nint(amol(l)))
     .         append = 0
            enddo
            if (append .eq. 1) then
               nmol = nmol + 1
               amol(nmol) = bmol(k)
            endif
            append = 1
         enddo
      endif

c*****do the general molecular equilibrium
101   call eqlib
      call resetmol

c     In the number density array "numdens", the elements denoted by
c     the first subscripts are named in at the ends of the assignment
c     lines; at present these are the only ones needed for continuous
c     opacities
c     the desired elements are H, He, C, Mg, Al, Si, Fe, along
c     with the H_2 molecule
c     first do the neutrals
      do j=1,7
         do k=1,neq
            if (nel(j) .eq. iorder(k)) then
               do i=1,ntau
                  numdens(j,1,i) = xamol(k,i)
               enddo
               exit
            endif
         enddo
      enddo
c     then do the ions
      do j=1,7
         ispec10 = nint(dble(10*nel(j)+1))
         do k=1,nmol
            kmol10 = nint(10.*amol(k))
            if (ispec10 .eq. kmol10) then
               do i=1,ntau
                  numdens(j,2,i) = xmol(k,i)
               enddo
               exit
            endif
         enddo
      enddo
c     finally add in H_2
      do k=1,nmol
         ispec = 101
         if (ispec .eq. nint(amol(k))) then
            do i=1,ntau
               numdens(8,1,i) = xmol(k,i)
            enddo
            exit
         endif
      enddo

c*****compute partitiion functions for H_2O and CO_2;
      do i=1,ntau
         h2olog = 0.
         co2log = 0.
         if (t(i) .gt. 5000.) then
            uh2o(i) = 1.d8
            uco2(i) = 1.d8
         else
            do j=1,5
               h2olog = h2olog + h2ocoeff(j)*t(i)**(j-1)
               co2log = co2log + co2coeff(j)*t(i)**(j-1)
            enddo
            uh2o(i) = 10**h2olog
            uco2(i) = 10**co2log
         endif
      enddo

c*****transfer H_2O and CO_2 number densities from the molecular
c     equilibrium output
c     note:  HITRAN partition functions are given only for T < 5000K
      do j=1,nmol
         if (nint(amol(j)) .eq. 10108) ih2o = j
         if (nint(amol(j)) .eq. 60808) ico2 = j
      enddo
      do i=1,ntau
         xnh2o(i) = xmol(ih2o,i)
         xnco2(i) = xmol(ico2,i)
      enddo

c*****SPECIAL NEEDS: for NEWMARCS models, to convert kaprefs to our units
      if (modtype .eq. 'NEWMARCS  ') then
         do i=1,ntau
            kapref(i) = kaprefmass(i)*rho(i)
         enddo
c     SPECIAL NEEDS: for KURUCZ models, to create the optical depth array,
c     and to convert kaprefs to our units
      elseif (modtype .eq. 'KURUCZ    ') then
         first = rhox(1)*kaprefmass(1)
         tottau = rinteg(rhox,kaprefmass,tauref,ntau,first)
         tauref(1) = first
         do i=2,ntau
            tauref(i) = tauref(i-1) + tauref(i)
         enddo
         do i=1,ntau
            kapref(i) = kaprefmass(i)*rho(i)
         enddo
c     SPECIAL NEEDS: for NEXTGEN models, to convert kaprefs to our units
      elseif (modtype .eq. 'NEXTGEN   ') then
         do i=1,ntau
            kapref(i) = kaprefmass(i)*rho(i)
         enddo
c     SPECIAL NEEDS: for BEGN models, to convert kaprefs to our units
      elseif (modtype .eq. 'BEGN      ') then
         do i=1,ntau
            kapref(i) = kaprefmass(i)*rho(i)
         enddo
c     SPECIAL NEEDS: for KURTYPE models, to create internal kaprefs,
c     and to compute taurefs from the kaprefs converted to mass units
      elseif (modtype .eq. 'KURTYPE   ') then
         call opacit (1,wavref)
         do i=1,ntau
            kaprefmass(i) = kapref(i)/rho(i)
         enddo
         first = rhox(1)*kaprefmass(1)
         tottau = rinteg(rhox,kaprefmass,tauref,ntau,first)
         tauref(1) = first
         do i=2,ntau
            tauref(i) = tauref(i-1) + tauref(i)
         enddo
c     SPECIAL NEEDS: for NEWMARCS models, to convert kaprefs to our units
      elseif (modtype .eq. 'KUR-PADOVA') then
         do i=1,ntau
            kapref(i) = kaprefmass(i)*rho(i)
         enddo
c     SPECIAL NEEDS: for generic models, to create internal kaprefs,
      elseif (modtype .eq. 'GENERIC   ' .or.
     .        modtype .eq. 'WEBMARCS  ' .or.
     .        modtype .eq. 'WEB2MARC  ') then
         call opacit (1,wavref)
      endif

c*****Convert from logarithmic optical depth scales, or vice versa.
c     xref will contain the log of the tauref
      if(tauref(1) .lt. 0.) then
         do i=1,ntau
            xref(i) = tauref(i)
            tauref(i) = 10.0**xref(i)
         enddo
      else
         do i=1,ntau
            xref(i) = dlog10(tauref(i))
         enddo
      endif

c*****Write information to output files
      if (modprintopt .lt. 1) return
      write (nf1out,1002) moditle
      do i=1,ntau
         dummy1(i) = dlog10(pgas(i))
         dummy2(i) = dlog10(ne(i)*1.38054d-16*t(i))
      enddo
      write (nf1out,1003) wavref,(i,xref(i),tauref(i),t(i),dummy1(i),
     .                    pgas(i),dummy2(i),ne(i),vturb(i),i=1,ntau)
      write (nf1out,1004)
      do i=1,95
         dummy1(i) = dlog10(xabund(i)) + 12.0
      enddo
      write (nf1out,1005) (names(i),i,dummy1(i),i=1,95)
      write (nf1out,1006) modprintopt, molopt, linprintopt, fluxintopt
      write (nf1out,1007) (kapref(i),i=1,ntau)
      return

c*****format statements
2001  format (a10)
2002  format (a80)
2003  format (6d13.0)
1001  format('permitted model types are:'/'KURUCZ, BEGN, ',
     .       'KURTYPE, KUR-PADOVA, NEWMARCS, WEBMARCS, NEXTGEN, ',
     .       'WEB2MARC, or GENERIC'/ 'MOOG quits!')
1002  format (/'MODEL ATMOSPHERE HEADER:'/a80/)
1003  format ('INPUT ATMOSPHERE QUANTITIES', 10x,
     .        '(reference wavelength =',f10.2,')'/3x, 'i', 2x, 'xref',
     .        3x, 'tauref', 7x, 'T', 6x, 'logPg', 4x, 'Pgas',
     .        6x, 'logPe', 5x, 'Ne', 9x, 'Vturb'/
     .        (i4, 0pf6.2, 1pd11.4, 0pf9.1, f8.3, 1pd11.4, 0pf8.3,
     .        1pd11.4, d11.2))
1004  format (/'INPUT ABUNDANCES: (log10 number densities, log H=12)'/
     .       '      Default solar abundances: Asplund et al. 2009')
1005  format (5(3x,a2, '(',i2,')=', f5.2))
1006  format (/'OPTIONS: atmosphere = ', i1, 5x, 'molecules  = ', i1/
     .        '         lines      = ', i1, 5x, 'flux/int   = ', i1)
1007  format (/'KAPREF ARRAY:'/(6(1pd12.4)))
1008  format ('vt=', f5.2)
1009  format (' M/H=', f5.2)
1010  format (13('-'),'MOOG OUTPUT FILE', 10('-'),
     .        '(MOOG version from 01/28/09)', 13('-')//
     .        'THE MODEL TYPE: ', a10)
1011  format ('   The Rosseland opacities and optical depths have ',
     .        'been read in')
1012  format ('HOUSTON, WE HAVE MORE THAN 100 DEPTH POINTS! I QUIT!')

      end


#The simulation script includes three aims.
#when pi=0, to estimate the utility of detecting invers-axis in cases only.
#when pi!=0, to estimate the power of detecting invers-axis in cases only.
#simulations to compare the OR of disease risk between LEV and cSEV-PB

#disease risk model setting
#LTM (liability threshold model)
#logit model

#genetric architecture setting
# a=Infinitesimal architecture
# b=with negative selection
# c=LD-adjusted kinship

args=commandArgs(TRUE)  #subjob id
subjob_id=as.numeric(args[1]) #subjob id

N_simulation=500  #simulation times

#subjobs
run_i=1
run_array=list()
for (h2_p in c(0.1,0.2,0.3,0.4,0.5)){ #h2 poly
  for (N_causal_SNPs in c(95593)){ #N of causal SNPs
    for (vr in c(0.01,0.02,0.03,0.05,0.10)){ #h2 rare (var rare)
      for (freq_r in c(1e-4,0.001,0.005,0.01,0.05)){ #freq rare
        for (k in c(0.001,0.005,0.01,0.02,0.05)){ #prevalence
          for (genetic_model in c(1,2,3)){ #genetic architecture
            for (pi0 in c(0,0.1,0.3,0.5,0.7,0.9)[1]){  #pi0, proportion of causal variants pi0=0: utility; pi0!=0: power
              run_array[[run_i]]=c(h2_p,N_causal_SNPs,vr,freq_r,k,genetic_model,pi0)
              run_i=run_i+1
            }
          }
        }
      }
    }
  }
}

run_array<-run_array[[subjob_id]]
h2_p=run_array[1]
#N_causal_SNPs=run_array[2]
vr=run_array[3]
freq_r=run_array[4]
k=run_array[5]
N_samples=run_array[6]
genetic_model=switch(run_array[6],'a','b','c')
# a=Infinitesimal architecture
# b=with negative selection
# c=LD-adjusted kinship
pi0=run_array[7]

#load LDsc
ldsc<-read.table('/data/c***/z***/projects/prslev/geno/ldsc/ldsc.simulation_all_snps',header = T,stringsAsFactors = F)

#load common snp table
common_all<-read.table('/data/c***/z***/projects/prslev/common/common_all.bim',header = F,stringsAsFactors = F)
common_all<-data.frame(rsid=common_all$V2,counted_allele=common_all$V5,effect=NA,stringsAsFactors = F)

#load MAF for all the common variants (used for maf-dependent genetic architectures)
maf_all<-read.table('/data/c***/z***/projects/prslev/geno/geno_copies/common_all.frq',header = T,stringsAsFactors = F)

#n of causal common variants
N_causal_SNPs=nrow(common_all)

#load rare snps
rare_dosage<-readRDS('/data/c***/z***/data/biovu/geno/23k/prslev_simulation_rare.rds')
colnames(rare_dosage)[-1]<-sapply(colnames(rare_dosage)[-1], function(x) strsplit(x,"[_]")[[1]][1])
rare_all<-data.frame(rsid=colnames(rare_dosage)[-1],effect=NA,stringsAsFactors = F)

#load rare variant info (freq)
rare_info<-read.table(paste0('/data/c***/z***/data/biovu/geno/chr/rare/rare.list'),header = T,stringsAsFactors = F)
rare_info$SNP=paste0('X',sub(':','.',rare_info$SNP)) #match variants name with dosage data
rare_info<-rare_info[rare_info$maf==freq_r,]

rare=rare_all[which(rare_all$rsid %in% rare_info$SNP),]

#allele frequency for rare variants (the actual number of freq, close to the setting)
freq_snp=sapply(rare$rsid,function(x) rare_info[which(rare_info$SNP==x),'maf'])
#calculate the effect size for rare vatiants
rare$effect=(vr/2/freq_snp/(1-freq_snp))^0.5
#sample N rare variants for simulation (N= number of simulation times)
set.seed(2019)
rare<-rare[sample(nrow(rare),N_simulation,replace = T),]

#simulation
N_samples=10000;i=1 #for testing

for (N_samples in c(500,1000,2000,3000,5000,10000)){
  print(N_samples)

  #output dataframe (liability-threshold model (LTM), probit)
  output_p<-data.frame(h2_p=h2_p,N_causal_SNPs=N_causal_SNPs,vr=vr,freq_r=freq_r,N_samples=N_samples,k=k,pi0=pi0,seed=seq(1,N_simulation),model=genetic_model)

  #output dataframe (logit)
  output_l<-data.frame(h2_p=h2_p,N_causal_SNPs=N_causal_SNPs,vr=vr,freq_r=freq_r,N_samples=N_samples,k=k,pi0=pi0,seed=seq(1,N_simulation),model=genetic_model)

  for (i in 1:N_simulation){
    print(i)

    #---generate effect sizes for common variants according to different genetic architectures---
    df<-common_all
    # a Infinitesimal architecture
    #   beta_poly~(0,h2_p/N_caucal_SNPs)
    if(genetic_model=='a'){
      set.seed(i)
      df$effect=(1-pi0)*rnorm(N_causal_SNPs,0,(h2_p/N_causal_SNPs)^0.5)

      # b Negative selection
      #   beta_poly~N(O,k_constant([f(1-f)]^(1+alpha)))
    }else if(genetic_model=='b'){
      set.seed(i)
      df$effect=df[,'effect']<-sapply(maf_all$MAF,function(f) rnorm(1,mean=0,sd=((f*(1-f))^0.63)^0.5))
      #find k constant
      k_constant=(h2_p/N_causal_SNPs/var(df[,'effect']))
      #multiply by k constant
      df[,'effect']<-df[,'effect']*k_constant^0.5*(1-pi0)

      # c LD-adjusted kinship
      #   beta_poly~N(O,k_constant([f(1-f)]^(1+alpha)*(1/(1+ldsc))))
    }else if(genetic_model=='c'){
      set.seed(i)
      df$effect=df[,'effect']<-mapply(function(f,ld) rnorm(1,mean=0,sd=(((f*(1-f))^0.75)*1/(1+ld))^0.5), maf_all$MAF, ldsc$ldscore)
      #find k constant
      k_constant=(h2_p/N_causal_SNPs/var(df[,'effect']))
      #multiply by k constant
      df[,'effect']<-df[,'effect']*k_constant^0.5*(1-pi0)
    }

    #write weight file
    write.table(df,paste0('/data/g***/z***/prslev/tmp/',subjob_id,'.weight'),row.names = F,col.names = F,sep='\t',quote = F)

    #use plink to calculate the PB (PRS of common variants)
    #if(i %in% c(1,101,201,301,401)){
    cmd=paste0('/home/zhoud2/tools/plink2/plink2 --bfile /data/c***/z***/projects/prslev/common/common_all --score /data/g***/z***/prslev/tmp/',subjob_id,'.weight variance-standardize  --out /data/g***/z***/prslev/tmp/',subjob_id,'.score')
    system(cmd,wait = T,ignore.stdout=T,ignore.stderr=T)
    #}

    #load PB results (A)
    PB=read.table(paste0('/data/g***/z***/prslev/tmp/',subjob_id,'.score.sscore'),stringsAsFactors = F)
    PB$IID=PB$V1;PB$A=PB$V5*2*nrow(common_all)
    PB<-PB[,c('IID','A')]

    #LEV (R)
    rare_id=rare[i,'rsid']
    rare_effect=rare[i,'effect']
    R=as.numeric(rare_dosage[,rare_id]*rare_effect)
    LEV<-data.frame(IID=rare_dosage$FID,R=R)

    #merge A and R
    combined<-merge(PB,LEV,by='IID')

    #---sampling subjects---
    set.seed(i)
    combined<-combined[sample(seq(1,nrow(combined)),N_samples,replace = F),]

    #x=A+R
    combined$x=combined$A+combined$R

    #h2_e
    h2_e=1-h2_p-vr

    #probability of disease (same with LTM)
    set.seed(i)
    combined$L=combined$x+rnorm(nrow(combined),0,h2_e^0.5)
    t=quantile(combined$L,1-k)[[1]]
    combined$prob=pnorm(-(t-combined$x)/h2_e^0.5)

    #--------logit model---start-------
    set.seed(i)
    combined$y_binary<-sapply(combined$prob,function(x) rbinom(1,1,x))
    combined$R<-ifelse(combined$R!=0,1,0)

    #test inverse axis in cases only
    if(length(which(combined$y_binary==1 & combined$R==1))>0 & length(which(combined$y_binary==1 & combined$R==0))>0){
      cases<-combined[combined$y_binary==1,]
      #test inverse axis
      ans_inverse<-wilcox.test(cases[cases$R==1,'A'],cases[cases$R==0,'A'],alternative = c("less"))
      output_l[i,'case_inverse_wilcox_p']<-ans_inverse$p.value
    }else{
      output_l[i,'case_inverse_wilcox_p']<-1
    }

    #test inverse axis in controls only
    if(length(which(combined$y_binary==0 & combined$R==1))>0 & length(which(combined$y_binary==0 & combined$R==0))>0){
      controls<-combined[combined$y_binary==0,]
      #test inverse axis
      ans_inverse<-wilcox.test(controls[controls$R==1,'A'],controls[controls$R==0,'A'],alternative = c("less"))
      output_l[i,'control_inverse_wilcox_p']<-ans_inverse$p.value
    }else{
      output_l[i,'control_inverse_wilcox_p']<-1
    }

    #--OR comparision between LEV and PB--
    for (top_p in c(0.01,0.05,0.1)){
      cut_off=quantile(combined$A,1-top_p)[[1]]
      combined$A_binary<-ifelse(combined$A>cut_off,1,0)

      A_check=table(combined$y_binary,combined$A_binary)
      R_check=table(combined$y_binary,combined$R)

      if(length(A_check)==4 & min(A_check)>0 & length(R_check)==4 & min(R_check)>0){
        ans_A<-summary(glm(combined$y_binary~combined$A_binary,family = 'binomial'))
        ans_R<-summary(glm(combined$y_binary~combined$R,family = 'binomial'))

        output_l[i,paste0('A_top_',top_p,'_beta')]<-ans_A$coefficients['combined$A_binary','Estimate']
        output_l[i,paste0('A_top_',top_p,'_se')]<-ans_A$coefficients['combined$A_binary','Std. Error']
        output_l[i,paste0('R_beta')]<-ans_R$coefficients['combined$R','Estimate']
        output_l[i,paste0('R_se')]<-ans_R$coefficients['combined$R','Std. Error']
      }
    }
    #--------logit model---end-------

    #------liability-threshold model (probit) ---start-----
    combined$y_binary<-ifelse(combined$L>t,1,0)
    table_check<-table(combined$y_binary,combined$R)

    #test inverse axis in cases only
    if(length(which(combined$y_binary==1 & combined$R==1))>0 & length(which(combined$y_binary==1 & combined$R==0))>0){
      cases<-combined[combined$y_binary==1,]
      #test inverse axis
      ans_inverse<-wilcox.test(cases[cases$R==1,'A'],cases[cases$R==0,'A'],alternative = c("less"))
      output_p[i,'case_inverse_wilcox_p']<-ans_inverse$p.value
    }else{
      output_p[i,'case_inverse_wilcox_p']<-1
    }

    #test inverse axis in controls only
    if(length(which(combined$y_binary==0 & combined$R==1))>0 & length(which(combined$y_binary==0 & combined$R==0))>0){
      controls<-combined[combined$y_binary==0,]
      #test inverse axis
      ans_inverse<-wilcox.test(controls[controls$R==1,'A'],controls[controls$R==0,'A'],alternative = c("less"))
      output_p[i,'control_inverse_wilcox_p']<-ans_inverse$p.value
    }else{
      output_p[i,'control_inverse_wilcox_p']<-1
    }

    #--OR comparision between LEV and PB--
    for (top_p in c(0.01,0.05,0.1)){
      cut_off=quantile(combined$A,1-top_p)[[1]]
      combined$A_binary<-ifelse(combined$A>cut_off,1,0)

      A_check=table(combined$y_binary,combined$A_binary)
      R_check=table(combined$y_binary,combined$R)

      if(length(A_check)==4 & min(A_check)>0 & length(R_check)==4 & min(R_check)>0){
        ans_A<-summary(glm(combined$y_binary~combined$A_binary,family = 'binomial'))
        ans_R<-summary(glm(combined$y_binary~combined$R,family = 'binomial'))

        output_p[i,paste0('A_top_',top_p,'_beta')]<-ans_A$coefficients['combined$A_binary','Estimate']
        output_p[i,paste0('A_top_',top_p,'_se')]<-ans_A$coefficients['combined$A_binary','Std. Error']
        output_p[i,paste0('R_beta')]<-ans_R$coefficients['combined$R','Estimate']
        output_p[i,paste0('R_se')]<-ans_R$coefficients['combined$R','Std. Error']
      }
    }

    #------liability-threshold model (probit) ---end-----

  }

  #write result liability-threshold (probit)
  write.table(output_p,paste0('/data/g***/z***/prslev/result/probit_',genetic_model,'/h2p_',h2_p,'_nsnp_','all_snps','_vr_',vr,'_freqr_',freq_r,'_k_',k,'_Nsample_',N_samples,'_pi0_',pi0),quote = F,row.names = F,sep='\t')

  #write result logit model
  write.table(output_l,paste0('/data/g***/z***/prslev/result/logit_',genetic_model,'/h2p_',h2_p,'_nsnp_','all_snps','_vr_',vr,'_freqr_',freq_r,'_k_',k,'_Nsample_',N_samples,'_pi0_',pi0),quote = F,row.names = F,sep='\t')

}


reshape_res = function(out, nn = names(inits),
		       cl = dimnames(Y)$country,
		       n_years = hyp$Time,
		       n_countries = hyp$N_countries,
		       n_clust = hyp$H,  pG = 2) {

	# I primi sono a posto così. Gli altri serve un po' di reshape manuale
	# prendiamo quelli bidimensionali
	nn_red = grep("^drift_|s_", nn,invert=T,value=T)
	res = list()

	# actual Parameters, [nit x countries x years] format
	for(i in 1:length(nn_red)) {
		tmp = out[,grep(paste0("^",nn_red[i],"\\["), colnames(out) )]
		res[[nn_red[i]]] = drop(array(tmp, dim = c(NROW(tmp), ncol(tmp)/n_years,n_years )))
	}

	# multivariate components: drift
	nn_dr = grep("drift", nn,value=T)
	for(i in 1:length(nn_dr)){
		tmp = out[,grep(paste0("^",nn_dr[i],"\\["), colnames(out) )]
		res[[nn_dr[i]]] = drop(array(tmp, dim = c(NROW(tmp), ncol(tmp)/n_countries,n_countries )))
	}
	nn_s = grep("s_", nn,value=T)
	for(i in 1:length(nn_dr)){
		tmp = out[,grep(paste0("^",nn_s[i],"\\["), colnames(out) )]
		res[[nn_s[i]]] = drop(array(tmp, dim = c(NROW(tmp), ncol(tmp)/n_countries,n_countries )))
	}

	return(res)
}

## We use a different parametrisation
add_w = function(pl) {
	w0=w1=w2=array(NA, dim = dim(pl$eta1))
	for(j in 1:dim(pl$eta1)[2]){
	for(k in 1:dim(pl$eta1)[3]){
		tmp = t(apply(cbind(pl$eta1[,j,k], pl$eta2[,j,k]), 1, function(r) eta_to_w(eta1 = r[1], eta2 = r[2])))
		w2[,j,k] = tmp[,3]
		w1[,j,k] = tmp[,2]
		w0[,j,k] = tmp[,1]
	}
	}
	return(c(pl, list("w0" = w0,"w1" = w1,"w2" = w2)))
}

add_skew_moments = function(pl) {
	# computes sn moments
	a2d = function(a) a / sqrt( 1 + a^2 )
	m = function(xi, omega, d) xi + omega * d * sqrt(2/pi)
	v = function(omega, d) omega^2 * (1 - 2 * d^2 / pi )

	sn_mean=sn_sd=array(NA, dim = dim(pl$xi))
	for(j in 1:dim(pl$xi)[2]){
	for(k in 1:dim(pl$xi)[3]){
		sn_mean[,j,k] = m(pl$xi[,j,k],sqrt(exp(pl$lomega[,j,k])), a2d(pl$alpha[,j,k]))
		sn_sd[,j,k] = sqrt(v(sqrt(exp(pl$lomega[,j,k])), a2d(pl$alpha[,j,k])))
	}}
	return(c(pl, list("sn_mean"  = sn_mean, "sn_sd" = sn_sd)))

}

eta_to_w = function(eta1,eta2) {
	expit = function(x) exp(x) / (1 + exp(x) )
		c(expit(-eta1) * expit(-eta2), expit(eta2) * expit(-eta1), expit(eta1))
}

# This function obtains predictions recursively
get_rec_pred = function(nyears = 10,  pl, hyp)
{
	obj_size = c(NROW(pl$xi),hyp$N_countries, nyears)

	tmp = list()
	tmp$xi     =  array(NA, dim = obj_size)
	tmp$lomega =  array(NA, dim = obj_size)
	tmp$alpha =  array(NA, dim = obj_size)

	tmp$mu     =  array(NA, dim = obj_size)
	tmp$lsigma =  array(NA, dim = obj_size)

	tmp$eta1   =  array(NA, dim = obj_size)
	tmp$eta2   =  array(NA, dim = obj_size)

	for(it in 1:NROW(pl$mu)){
		for(nc in 1:obj_size[2]) { # loop across countries

			tmp$xi[it,nc,1]     = pl$xi[it,nc,hyp$Time] + pl$drift_xi[it,nc]
			tmp$lomega[it,nc,1] = pl$lomega[it,nc,hyp$Time] + pl$drift_lomega[it,nc]
			tmp$alpha[it,nc,1]  = pl$alpha[it,nc,hyp$Time] + pl$drift_alpha[it,nc]

			tmp$mu[it,nc,1]     = pl$mu[it,nc,hyp$Time] + pl$drift_mu[it,nc]
			tmp$lsigma[it,nc,1] = pl$lsigma[it,nc,hyp$Time] + pl$drift_lsigma[it,nc]

			tmp$eta1[it,nc,1]   = pl$eta1[it,nc,hyp$Time] + pl$drift_eta1[it,nc]
			tmp$eta2[it,nc,1]   = pl$eta2[it,nc,hyp$Time] + pl$drift_eta2[it,nc]

			# Now loop in time
			for(tt in 2:obj_size[3]) { # loop in time and get recursive predictions
				tmp$xi[it,nc,tt]     = tmp$xi[it,nc,tt-1] + pl$drift_xi[it,nc]
				tmp$lomega[it,nc,tt] = tmp$lomega[it,nc,tt-1] + pl$drift_lomega[it,nc]
				tmp$alpha[it,nc,tt]  = tmp$alpha[it,nc,tt-1] + pl$drift_alpha[it,nc]

				tmp$mu[it,nc,tt]     = tmp$mu[it,nc,tt-1] + pl$drift_mu[it,nc]
				tmp$lsigma[it,nc,tt] = tmp$lsigma[it,nc,tt-1] + pl$drift_lsigma[it,nc]

				tmp$eta1[it,nc,tt]   = tmp$eta1[it,nc,tt-1] + pl$drift_eta1[it,nc]
				tmp$eta2[it,nc,tt]   = tmp$eta2[it,nc,tt-1] + pl$drift_eta2[it,nc]
			}
			}

		if(it %% 50 == 0) cat(it, " over ", obj_size[1], "\n")
	}
	return(tmp)
}

# This function obtains predictions recursively
get_pred_ppd = function(nyears = 10,  pl, hyp, seed = 1)
{
	set.seed(seed)
	obj_size = c(NROW(pl$xi),hyp$N_countries, nyears)

	tmp = list()
	tmp$xi     =  array(NA, dim = obj_size)
	tmp$lomega =  array(NA, dim = obj_size)
	tmp$alpha =  array(NA, dim = obj_size)

	tmp$mu     =  array(NA, dim = obj_size)
	tmp$lsigma =  array(NA, dim = obj_size)

	tmp$eta1   =  array(NA, dim = obj_size)
	tmp$eta2   =  array(NA, dim = obj_size)

	for(it in 1:NROW(pl$mu)){
		for(nc in 1:obj_size[2]) { # loop across countries
			tmp$xi[it,nc,1]     = rnorm(1, mean = pl$xi[it,nc,hyp$Time] + pl$drift_xi[it,nc], sd         = sqrt(pl$s_xi[it,nc]))
			tmp$lomega[it,nc,1] = rnorm(1, mean = pl$lomega[it,nc,hyp$Time] + pl$drift_lomega[it,nc], sd = sqrt(pl$s_lomega[it,nc]))
			tmp$alpha[it,nc,1]  = rnorm(1, mean = pl$alpha[it,nc,hyp$Time] + pl$drift_alpha[it,nc], sd   = sqrt(pl$s_alpha[it,nc]))

			tmp$mu[it,nc,1]     = rnorm(1, mean = pl$mu[it,nc,hyp$Time] + pl$drift_mu[it,nc], sd         = sqrt(pl$s_mu[it,nc]))
			tmp$lsigma[it,nc,1] = rnorm(1, mean = pl$lsigma[it,nc,hyp$Time] + pl$drift_lsigma[it,nc], sd = sqrt(pl$s_lsigma[it,nc]))

			tmp$eta1[it,nc,1]   = rnorm(1, mean = pl$eta1[it,nc,hyp$Time] + pl$drift_eta1[it,nc], sd     = sqrt(pl$s_eta1[it,nc]))
			tmp$eta2[it,nc,1]   = rnorm(1, mean = pl$eta2[it,nc,hyp$Time] + pl$drift_eta2[it,nc], sd     = sqrt(pl$s_eta2[it,nc]))

			# Now loop in time
			for(tt in 2:obj_size[3]) { # loop in time and get recursive predictions
				tmp$xi[it,nc,tt]     = rnorm(1, mean = tmp$xi[it,nc,tt-1] + pl$drift_xi[it,nc], sd         = sqrt(pl$s_xi[it,nc]))
				tmp$lomega[it,nc,tt] = rnorm(1, mean = tmp$lomega[it,nc,tt-1] + pl$drift_lomega[it,nc], sd = sqrt(pl$s_lomega[it,nc]))
				tmp$alpha[it,nc,tt]  = rnorm(1, mean = tmp$alpha[it,nc,tt-1] + pl$drift_alpha[it,nc], sd   = sqrt(pl$s_alpha[it,nc]))

				tmp$mu[it,nc,tt]     = rnorm(1, mean = tmp$mu[it,nc,tt-1] + pl$drift_mu[it,nc], sd         = sqrt(pl$s_mu[it,nc]))
				tmp$lsigma[it,nc,tt] = rnorm(1, mean = tmp$lsigma[it,nc,tt-1] + pl$drift_lsigma[it,nc], sd = sqrt(pl$s_lsigma[it,nc]))

				tmp$eta1[it,nc,tt]   = rnorm(1, mean = tmp$eta1[it,nc,tt-1] + pl$drift_eta1[it,nc], sd     = sqrt(pl$s_eta1[it,nc]))
				tmp$eta2[it,nc,tt]   = rnorm(1, mean = tmp$eta2[it,nc,tt-1] + pl$drift_eta2[it,nc], sd     = sqrt(pl$s_eta2[it,nc]))
			}

		}
		if(it %% 50 == 0) cat(it, " over ", obj_size[1], "\n")
	}
	return(tmp)
}

get_df_summ = function(pl,pred, countries = dimnames(dd$y)[[1]],
		       log_scale = T, w = F,
		       moments = F,
		       func = "mean", ...) {
	df_pl = list()

	for(p in 1:length(countries)){
		cur_c = countries[p]
		tmp = data.frame(x=1:(hyp$Time+dim(pred$xi)[3]))

		if(w) {
			tmp$w0 = c(apply(pl$w0[,p,],2,get(func), ...), apply(pred$w0[,p,],2,get(func), ...))
			tmp$w1 = c(apply(pl$w1[,p,],2,get(func), ...), apply(pred$w1[,p,],2,get(func), ...))
			tmp$w2 = c(apply(pl$w2[,p,],2,get(func), ...), apply(pred$w2[,p,],2,get(func), ...))
		} else {
			tmp$eta1 = c(apply(pl$eta1[,p,],2,get(func), ...), apply(pred$eta1[,p,],2,get(func), ...))
			tmp$eta2 =c( apply(pl$eta2[,p,],2,get(func), ...),  apply(pred$eta2[,p,],2,get(func), ...))
		}

		tmp$mu =c( apply(pl$mu[,p,],2,get(func), ...),  apply(pred$mu[,p,],2,get(func), ...))

		if(log_scale){
			tmp$sigma =c( apply((pl$lsigma[,p,]),2,get(func), ...),  apply((pred$lsigma[,p,]),2,get(func), ...))
			tmp$omega =c( apply((pl$lomega[,p,]),2,get(func), ...),  apply((pred$lomega[,p,]),2,get(func), ...))
		} else {
			tmp$sigma =c( apply(exp(pl$lsigma[,p,]),2,get(func), ...),  apply(exp(pred$lsigma[,p,]),2,get(func), ...))
			tmp$omega =c( apply(exp(pl$lomega[,p,]),2,get(func), ...),  apply(exp(pred$lomega[,p,]),2,get(func), ...))
		}

		tmp$xi =c( apply(pl$xi[,p,],2,get(func), ...),  apply(pred$xi[,p,],2,get(func), ...))
		tmp$alpha =c( apply(pl$alpha[,p,],2,get(func), ...),  apply(pred$alpha[,p,],2,get(func), ...))

		if(moments) {
			tmp$sn_mean =c( apply(pl$sn_mean[,p,],2,get(func), ...),  apply(pred$sn_mean[,p,],2,get(func), ...))
			tmp$sn_sd =c( apply(pl$sn_sd[,p,],2,get(func), ...),  apply(pred$sn_sd[,p,],2,get(func), ...))
			tmp$xi = NULL
			tmp$omega = NULL
		}

		df_pl[[cur_c]] = tmp

	}
	return(df_pl)
}

get_df_ic = function(pl,pred,
		     countries = dimnames(dd$y)[[1]],
		     log_scale = T,
		     w = F,
		     moments = F,
		     level = 0.05) {
	df_pl = list()

	for(p in 1:length(countries)){
		cur_c = countries[p]
		tmp = data.frame(x=1:(hyp$Time+dim(pred$xi)[3]))

		if(w) {
			tmp$w0 = c(apply(pl$w0[,p,],2,quantile, level), apply(pred$w0[,p,],2,quantile, level))
			tmp$w1 = c(apply(pl$w1[,p,],2,quantile, level), apply(pred$w1[,p,],2,quantile, level))
			tmp$w2 = c(apply(pl$w2[,p,],2,quantile, level), apply(pred$w2[,p,],2,quantile, level))
		} else {
			tmp$eta1 = c(apply(pl$eta1[,p,],2,quantile, level), apply(pred$eta1[,p,],2,quantile, level))
			tmp$eta2 = c(apply(pl$eta2[,p,],2,quantile, level),  apply(pred$eta2[,p,],2,quantile, level))
		}

		tmp$mu =c( apply(pl$mu[,p,],2,quantile, level),  apply(pred$mu[,p,],2,quantile, level))

		if(log_scale){
			tmp$sigma =c( apply((pl$lsigma[,p,]),2,quantile, level),  apply((pred$lsigma[,p,]),2,quantile, level))
			tmp$omega =c( apply((pl$lomega[,p,]),2,quantile, level),  apply((pred$lomega[,p,]),2,quantile, level))
		} else {
			tmp$sigma =c( apply(exp(pl$lsigma[,p,]),2,quantile, level),  apply(exp(pred$lsigma[,p,]),2,quantile, level))
			tmp$omega =c( apply(exp(pl$lomega[,p,]),2,quantile, level),  apply(exp(pred$lomega[,p,]),2,quantile, level))
		}

		tmp$xi =c( apply(pl$xi[,p,],2,quantile, level),  apply(pred$xi[,p,],2,quantile, level))
		tmp$alpha =c( apply(pl$alpha[,p,],2,quantile, level),  apply(pred$alpha[,p,],2,quantile, level))
		if(moments) {
			tmp$sn_mean =c( apply(pl$sn_mean[,p,],2,quantile, level),  apply(pred$sn_mean[,p,],2,quantile, level))
			tmp$sn_sd =c( apply(pl$sn_sd[,p,],2,quantile, level),  apply(pred$sn_sd[,p,],2,quantile, level))
			tmp$xi = NULL
			tmp$omega = NULL
		}

		df_pl[[cur_c]] = tmp
	}
	return(df_pl)
}

get_df_ic_h = function(pl,pred,
		       countries = dimnames(dd$y)[[1]],
		       log_scale = T, w = F, moments = F,
		       level = 0.95, upper = T){
	df_pl = list()

	emp_hpd = function(x, level) TeachingDemos::emp.hpd(x, level)[ifelse(upper,2,1)]

	for(p in 1:length(countries)){
		cur_c = countries[p]
		tmp = data.frame(x=1:(hyp$Time+dim(pred$xi)[3]))

		if(w) {
			tmp$w0 = c(apply(pl$w0[,p,],2,emp_hpd, level), apply(pred$w0[,p,],2,emp_hpd, level))
			tmp$w1 = c(apply(pl$w1[,p,],2,emp_hpd, level), apply(pred$w1[,p,],2,emp_hpd, level))
			tmp$w2 = c(apply(pl$w2[,p,],2,emp_hpd, level), apply(pred$w2[,p,],2,emp_hpd, level))
		} else {
			tmp$eta1 = c(apply(pl$eta1[,p,],2,emp_hpd, level), apply(pred$eta1[,p,],2,emp_hpd, level))
			tmp$eta2 = c(apply(pl$eta2[,p,],2,emp_hpd, level),  apply(pred$eta2[,p,],2,emp_hpd, level))
		}

		tmp$mu =c( apply(pl$mu[,p,],2,emp_hpd, level),  apply(pred$mu[,p,],2,emp_hpd, level))

		if(log_scale){
			tmp$sigma =c( apply((pl$lsigma[,p,]),2,emp_hpd, level),  apply((pred$lsigma[,p,]),2,emp_hpd, level))
			tmp$omega =c( apply((pl$lomega[,p,]),2,emp_hpd, level),  apply((pred$lomega[,p,]),2,emp_hpd, level))
		} else {
			tmp$sigma =c( apply(exp(pl$lsigma[,p,]),2,emp_hpd, level),  apply(exp(pred$lsigma[,p,]),2,emp_hpd, level))
			tmp$omega =c( apply(exp(pl$lomega[,p,]),2,emp_hpd, level),  apply(exp(pred$lomega[,p,]),2,emp_hpd, level))
		}

		tmp$xi =c( apply(pl$xi[,p,],2,emp_hpd, level),  apply(pred$xi[,p,],2,emp_hpd, level))
		tmp$alpha =c( apply(pl$alpha[,p,],2,emp_hpd, level),  apply(pred$alpha[,p,],2,emp_hpd, level))

		if(moments) {
			tmp$sn_mean =c( apply(pl$sn_mean[,p,],2,emp_hpd, level),  apply(pred$sn_mean[,p,],2,emp_hpd, level))
			tmp$sn_sd =c( apply(pl$sn_sd[,p,],2,emp_hpd, level),  apply(pred$sn_sd[,p,],2,emp_hpd, level))
			tmp$xi = NULL
			tmp$omega = NULL
		}

		df_pl[[cur_c]] = tmp
	}
	return(df_pl)
}


####################################################

#This is the wrapper for running the LCM model for
# Crozier, Burke, Chasco, Widener and Zabel 2020
# Iconic salmon populations face perilous challenges from climate change across their life cycle
# published in Communications Biology

####################################################
####################################################

set.seed(10000)
library(plyr)

# Model control parameters---------
#1.Select which model you want to run. Models are defined by which freshwater and marine covariates they include
      #e.g., Model 1:
          # FW: p2TsuFfall
          # In-river: ersstArc.win + ersstWAcoast.sum
          # Transport: ersstArc.win

        model<-"Model1";filename<-"p2TsuFfall"; Fname="F.S3.ParrF"; FW.name="Ffall"
          # model<-"Model2"; filename<-"p2Fsu"; Fname="F.S2.ParrSu"; FW.name="Fsu"
          # model<-"Model3"; filename<-"p2TsuFfall"; Fname="F.S3.ParrF"; FW.name="Ffall"
                arrayname<-paste0(model,".array")
              load(file=paste("Input files/param",arrayname,sep="."),verbose=T) #param.array.1K

#2. Decide how many simulations,populations and climate scenarios you want to run and build list of scenarios
        runs = 10
        years = 75 #2015:2089
        pop<-creeks<-"bearvalley"
#       pop<-creeks<-c("bearvalley","big","camas","loon","marsh","secesh","sulphur","valley")

            climate =c("stationary","4.5" , "8.5"   )
            climateshort =c("1","45" , "85"   )
            quant = c("25", "50", "75")

        nsim<-length(pop)*length(model)*length(climate)*length(quant)#;nsim
        scenario<-length(model)*length(climate)*length(quant);scenario
        scenario.name<-vector("character",length=scenario)
     cnt.scenario=0
        for(l in 1:length(model)){
            for(cc in 1:length(climate)){
            for(qq in 1:length(quant)){
                 cnt.scenario=cnt.scenario+1
               scenario.name[cnt.scenario]=paste(climate[cc],quant[qq],model[l],sep=".");scenario.name
            }}}

#Input files-------------------
    #FW
        source("LCM.fxn.r") #functions for model relationships
        popinit<-read.csv("Input files/Ninit.csv", header = T, row.names = 1)
        hydro<-read.csv(file="Input files/climategrid_survival_80yr_2020_PA.csv",header=TRUE,row.names = NULL);hydro$gridYear<-rep(1:80,length=nrow(hydro))
        FW<-read.csv(file="Input files/SALM.Qflow.csv",header=TRUE,row.names = NULL)#;head(FW)
            FW<-FW[FW$year>=2015,]
            scalefactors<-read.csv(file="Input files/scalefactors.corrected.May2019.csv",row.names=1)#;scalefactors
        su<-read.csv("Input files/AprilJuneAndSurv_LoopsTransport.csv",row.names = NULL,header=TRUE)#;head(su)
            su$LGRtemp<-round_any(su$LGrTempAJ,0.5)#;simtemp
            su$LGRflow<-round_any(su$LGrFlowAJ,20)#;simflow

    #SARs
        if(model=="Model3") sarfile<-"Model3.SAR100.Rdata"  else sarfile<-"Model1.Model2.SAR100.Rdata"
            print(sarfile)
               load(paste0("Input files/",sarfile),verbose=TRUE)

      #collect parameters used in each run
            param.marT<-as.data.frame(t(sarcoefT_rqvs["stationary","50",,]))
                  names(param.marT)<-paste("T",names(param.marT),sep=".")
            param.marI<-as.data.frame(t(sarcoefI_rqvs["stationary","50",,]))
                  names(param.marI)<-paste("I",names(param.marI),sep=".")

# Set up temporary arrays to store data during model runs-----------
    N.new = N = array(0,5)
    surv.s1=surv.trib=surv.inriver=pt=pt.sar=pt.sup=surv.main=surv.s2=surv.s3=surv.sar=surv.sarI=surv.sarT=surv.sup=sup.spr.inriver=sup.spr.transport=sup.sum.inriver=sup.sum.transport=sup.spring=sup.summer=Spawners = Recruits = array(0,years) #indiv years within a run

    # Arrays to save output-----------
      spawner.array<-parrsmolt.array<-recruit.array<-array(0,dim=c(years,runs,length(pop),scenario),dimnames=list(2015:2089,paste0("sim",1:runs),pop,scenario.name))#;dim(spawner.array)
      response<-c("yrQET50","Mean2020","Mean2040","Mean2060","Mean2080","Meanallyears")
            allparam<-c( names(param.marI),names(param.marT),dimnames(param.array.1K)[[2]],response)# ;allparam
      param.array<-array(0,dim=c(runs,length(allparam),length(pop),scenario),dimnames=list(paste0("sim",1:runs),allparam,pop,scenario.name))#;dim(param.array)

#START LOOPING THROUGH SIMULATIONS ========================
    print(Sys.time())
#k=1;l=1;m=1;cc=1;p=1;j=1;qq=1
cnt=0
for(k in 1:length(pop)){ # loop across populations
    cnt.scenario=0
  print(paste("Pop",k,pop[k],Sys.time()))
  ha= popinit[pop[k],"ha"]
  for(cc in 1:length(climate)){
  for(qq in 1:length(quant)){ #loop across quantiles of each climate scenario
     cnt.scenario=cnt.scenario+1;print(scenario.name[cnt.scenario])
  for (j in 1:runs){
   jj<-sample(length(param.array.1K[,1,1]),1)
   jj.sar<-sample(length(sarI_rqys[1,1,1,]),1)
        param<-as.list(param.array.1K[jj,,pop[k]])#;unlist(param)

        #collect parameters used in each run
            param.marT<-as.data.frame(t(sarcoefT_rqvs[climate[cc],quant[qq],,jj.sar]))  #;unlist(param.marT) #dimnames(sarcoefT_rqvs)
            param.marI<-as.data.frame(t(sarcoefI_rqvs[climate[cc],quant[qq],,jj.sar])) #dimnames(sarBeta_frqvs)[[1]][2]
            param.array[j,paste("T",names(param.marT),sep="."),k,scenario.name[cnt.scenario]]<-unlist(param.marT)
            param.array[j,paste("I",names(param.marI),sep="."),k,scenario.name[cnt.scenario]]<-unlist(param.marI)
            param.array[j,names(param),k,scenario.name[cnt.scenario]]<-unlist(param)

        #Load raw T and F projections from TMB model
              T1<- sc_envProj_rqvys[climate[cc],quant[qq],"T.S2.ParrSu",,jj.sar]#*env_sc["T.S2.ParrSu"]+env_mu["T.S2.ParrSu"]
              F1<- sc_envProj_rqvys[climate[cc],quant[qq],Fname,,jj.sar]#*env_sc[Fname]+env_mu[Fname]
          #Add trends
               if(cc>1) T1<-T1+FW[,paste0("Tsu.Q",quant[qq],".RCP",climate[cc])]
               if(cc>1) F1<-F1+FW[,paste0(FW.name,quant[qq],".RCP",climateshort[cc])]
          #Scale for gompertz model coefficients
               T1<-(T1-scalefactors["mean","T.S2.ParrSu"])/scalefactors["sd","T.S2.ParrSu"]
               F1<-(F1-scalefactors["mean",Fname])/scalefactors["sd",Fname]

#Initialize all age classes
     N[1:5] = c(0,0,0,0,0)
        for (i in 1:5){
          xx<-sample(1:dim(envProj_rqvys)[5],1)
          N.new[1] = popinit[pop[k],"stationaryMeanSp"]*exp(param$p1+param$c1*log(popinit[pop[k],"stationaryMeanSp"]/ha))
          if(filename=="p2Fsu")        surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BF*F1[i])
          if(length(grep("p2Tsu",filename))>0)   {surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BT*T1[i]+param$BF*F1[i])}
          if(length(grep("c2",filename))>0)   {surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BT*T1[i]*log(max(N[1]/ha,1))+param$BF*F1[i]*log(max(N[1]/ha,1)))}
          surv.inriver[i]=  hydro[hydro$gridYear==envProj_rqvys[climate[cc],quant[qq],"gridYear",i,xx] &
                    hydro$flow==envProj_rqvys[climate[cc],quant[qq],"gridFlow",i,xx]
                  & hydro$temp==envProj_rqvys[climate[cc],quant[qq],"gridTemp",i,xx],"surv"]
          pt[i]=hydro[hydro$gridYear==envProj_rqvys[climate[cc],quant[qq],"gridYear",i,xx] &
                  hydro$flow==envProj_rqvys[climate[cc],quant[qq],"gridFlow",i,xx]
                & hydro$temp==envProj_rqvys[climate[cc],quant[qq],"gridTemp",i,xx],"proptrans"]
          surv.main[i] =S2.mainstem(pt=pt[i], s.inriver=surv.inriver[i])
          pt.sar[i]<-pt[i]*0.98/((1-pt[i])*surv.inriver[i]+pt[i]*0.98)
          N.new[2] = N[1]*surv.trib[i]*surv.main[i]
          N.new[3] = N[2]*s3.fxn(pt=pt.sar[i],sarI=plogis(sarI_rqys[climate[cc],quant[qq],i,xx]),sarT=plogis(sarT_rqys[climate[cc],quant[qq],i,xx]),b3=param$b3,b4=param$b4,So=param$s0)$s3
          N.new[4] = N[3]*(1-param$b3)*param$s0
          N.new[5] = N[4]*(1-param$b4)*param$s0
          N = N.new
        };N

             for (i in 1:years){
          # Calculate effective spawners for recruit calculations
          #In the first year, we do not have pt.sup yet, so we are just using the average survival of upstream migrants
              if(i==1){
                      myvar="aprmayjunetempLGR";lgrtemp<-sc_envProj_rqvys[climate[cc],quant[qq],myvar,i,jj.sar]#*env_sc[myvar]+env_mu[myvar]
                      myvar="aprmayjuneflowLGR";lgrflow<-sc_envProj_rqvys[climate[cc],quant[qq],myvar,i,jj.sar]#*env_sc[myvar]+env_mu[myvar]
                      simtemp<-round_any(lgrtemp,0.5)#;simtemp
                      simflow<-round_any(lgrflow,20)#;simflow
                      su.Temp.matches<-su[which(abs(simtemp-(su$LGRtemp))==min(abs(simtemp-(su$LGRtemp)))),]#;su.Temp.matches
                      su.Flow.matches<-su.Temp.matches[which(abs(simflow-(su.Temp.matches$LGRflow))==min(abs(simflow-(su.Temp.matches$LGRflow)))),]#;su.Flow.matches
                      surv.sup[i]<-sample(su.Flow.matches$SpringSurv_BoToLG,1)
                      if(k %in% c(6,8)) surv.sup[i]<-sample(su.Flow.matches$SummerSurv_BoToLG,1)

                      spawners = (param$b4*N[4] + param$f5*N[5])*surv.sup[i]*0.9
              }

          #In subsequent years, we use output from SARs in the previous year to determine the precent of upstream migrants that were transported as juveniles
            if(i>1){    spawners = (param$b4*N[4] + param$f5*N[5])*surv.sup[i-1]*0.9 }

    #Survival in each age class
          surv.s1[i]=exp(param$p1+param$c1*log(spawners/ha))
                 if(filename=="p2Fsu")        surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BF*F1[i])
                 if(length(grep("p2Tsu",filename))>0)   {surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BT*T1[i]+param$BF*F1[i])}
                 if(length(grep("c2",filename))>0)   {surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BT*T1[i]*log(max(N[1]/ha,1))+param$BF*F1[i]*log(max(N[1]/ha,1)))}
          surv.inriver[i]=  hydro[hydro$gridYear==envProj_rqvys[climate[cc],quant[qq],"gridYear",i,jj.sar] &
                                  hydro$flow==envProj_rqvys[climate[cc],quant[qq],"gridFlow",i,jj.sar] &
                                  hydro$temp==envProj_rqvys[climate[cc],quant[qq],"gridTemp",i,jj.sar],"surv"]
          pt[i]=  hydro[hydro$gridYear==envProj_rqvys[climate[cc],quant[qq],"gridYear",i,jj.sar] &
                        hydro$flow==envProj_rqvys[climate[cc],quant[qq],"gridFlow",i,jj.sar] &
                        hydro$temp==envProj_rqvys[climate[cc],quant[qq],"gridTemp",i,jj.sar],"proptrans"]
          surv.main[i] =S2.mainstem(pt=pt[i], s.inriver=surv.inriver[i])
          pt.sar[i]<-pt[i]*0.98/((1-pt[i])*surv.inriver[i]+pt[i]*0.98)
          surv.s2[i] =surv.trib[i]*surv.main[i]
                s3 = s3.fxn(pt=pt.sar[i],sarI=plogis(sarI_rqys[climate[cc],quant[qq],i,jj.sar]),sarT=plogis(sarT_rqys[climate[cc],quant[qq],i,jj.sar]),b3=param$b3,b4=param$b4,So=param$s0)
          surv.s3[i]   = s3$s3
          surv.sarI[i] = s3$sarI
          surv.sarT[i] = s3$sarT
          surv.sar[i]  = s3$sar
      #tracking in-river and transported fish separately for upstream migration survival
          pt.sup[i]<-pt.sar[i]*surv.sarT[i]/surv.sar[i]

              myvar="aprmayjunetempLGR";lgrtemp<-sc_envProj_rqvys[climate[cc],quant[qq],myvar,i,jj.sar]#*env_sc[myvar]+env_mu[myvar]
              myvar="aprmayjuneflowLGR";lgrflow<-sc_envProj_rqvys[climate[cc],quant[qq],myvar,i,jj.sar]#*env_sc[myvar]+env_mu[myvar]
              simtemp<-round_any(lgrtemp,0.5)#;simtemp
              simflow<-round_any(lgrflow,20)#;simflow
              su.Temp.matches<-su[which(abs(simtemp-(su$LGRtemp))==min(abs(simtemp-(su$LGRtemp)))),]#;su.Temp.matches
              su.Flow.matches<-su.Temp.matches[which(abs(simflow-(su.Temp.matches$LGRflow))==min(abs(simflow-(su.Temp.matches$LGRflow)))),]#;su.Flow.matches
                          xx<-sample(1:nrow(su.Flow.matches),size=1);xx
                  sup.spr.inriver[i]<-su.Flow.matches$Spr_Pred_BOLG_inriver[xx]
                  sup.spr.transport[i]<-su.Flow.matches$Spr_Pred_BOLG_transport[xx]
                  sup.sum.inriver[i]<-su.Flow.matches$Sum_Pred_BOLG_inriver[xx]
                  sup.sum.transport[i]<-su.Flow.matches$Sum_Pred_BOLG_transport[xx]

                  sup.spring[i]<-pt.sup[i]* sup.spr.transport[i]+(1-pt.sup[i])* sup.spr.inriver[i]
                  sup.summer[i]<-pt.sup[i]* sup.sum.transport[i]+(1-pt.sup[i])* sup.sum.inriver[i]
          surv.sup[i]<-sup.spring[i]
          if(k %in% c(6,8)) surv.sup[i]<-sup.summer[i]
          #Note that surv.sup[i] will be used in next year's calculation of spawners, not this year's N[1]

          N.new[1] = spawners*surv.s1[i]
          N.new[2] = N[1]*surv.s2[i]
          N.new[3] = N[2]*surv.s3[i]
          N.new[4] = N[3]*(1-param$b3)*param$s0
          N.new[5] = N[4]*(1-param$b4)*param$s0

          N = N.new

      # calculate spawners
          Spawners[i] = (param$b4*N[4] + N[5])*surv.sup[i]*0.9
          # calculate recruits referenced to brood year
          if (i > 4 && i <= (years-1))
               Recruits[i-4] = param$b4*N[4]*surv.sup[i]*0.9
          if (i > 5)
               Recruits[i-5] = Recruits[i-5] + N[5]*surv.sup[i]*0.9
        } #end years
        Spawners2<-Spawners[5:years]

        spawner.array[,j,k,cnt.scenario]<-Spawners
        parrsmolt.array[,j,k,cnt.scenario]<-surv.trib
        recruit.array[,j,k,cnt.scenario]<-Recruits
  }  #end runs

#Store spawner and recruit matrices and name them by scenario
      save(spawner.array,file=paste("output/spawner",filename,arrayname,sep="."))
      save(param.array,file=paste("output/param",filename,arrayname,sep="."))
      save(parrsmolt.array,file=paste("output/parrsmolt",filename,arrayname,sep="."))
      save(recruit.array,file=paste("output/recruit",filename,arrayname,sep="."))

      cnt=cnt+1

    }   #end quantiles qq
    }   #end climate cc
}    #end populations

#Add response metrics to param.array-------------
            years<-2015:2089 #dimnames(spawner.array)[[1]]
            runs<-dim(spawner.array)[[2]]
            pop<-dimnames(spawner.array)[[3]]
            scenarios<-dimnames(spawner.array)[[4]]
            spQET<-spawner.array
                spQET[1:3,,,]<-NA
                for(k in 1:length(pop)){
                    for(ss in 1:length(scenarios)){
                     for ( j in 1:runs){
                        spawners<-spawner.array[,j,k,scenarios[ss]];spawners
                        for (i in 4:75){ifelse (sum(spawners[(i-3):i]) < 200,spQET[i,j,k,ss]<-1,spQET[i,j,k,ss]<-0) }
                        param.array[j,"yrQET50",k,scenarios[ss]]<-ifelse(max(spQET[,j,k,scenarios[ss]],na.rm=TRUE)>0.5  ,
                                    years[min(which(spQET[,j,k,scenarios[ss]]>0.5))]  ,  2115)
                        param.array[j,"Mean2020",k,scenarios[ss]]<-exp(mean(log(spawners[6:15])))
                        param.array[j,"Mean2040",k,scenarios[ss]]<-exp(mean(log(spawners[26:35])))
                        param.array[j,"Mean2060",k,scenarios[ss]]<-exp(mean(log(spawners[46:55])))
                        param.array[j,"Mean2080",k,scenarios[ss]]<-exp(mean(log(spawners[66:75])))
                        param.array[j,"Meanallyears",k,scenarios[ss]]<-exp(mean(log(spawners)))
                        } #end runs
                      }#end scenarios
                    }#end pop

      save(param.array,file=paste("output/param",filename,arrayname,sep="."))


#' Train HMM with model specificaiton provided in `model`
#'
#' @param x vector or matrix of data
#' @param model model specification created by hmmspec.gen(..)
#' @param lock.transition boolean, whether to fix the transition matrix
#' @param tol numeric tolerance for convergence evaluation
#' @param maxit maximum number of EM iterations
#' @param verbose boolean, whether to print diagnostics
#' @return list with elements that describe the trained model
#' @details See example
#' @export
hextfit = function(x, model, lock.transition=FALSE, tol=1e-01, maxit=1000, verbose=TRUE) {
  K = model$K
  D = model$D  # size of the alphabet sets, this is a vector!
  M = model$M  # no. of gaussian mixtures
  if ( class(x)=="numeric" | class(x)=="integer") {
     warning('x is a primitive vector. Assuming single sequence.')
     TT = NROW(x)
     Nseq = 1
  } else {
    TT = x$TT
    Nseq = length(TT)
    x = x$x
  }
  mtype = model$mtype
  if ( length(mtype) != NCOL(x) ) stop("length of mtype differs from no of columns in x.")
  if ( K < 2 ) stop("K must be larger than one.")
  if( any(dim(model$ltransition)!=K) )  stop("dimensions of ltransition incorrect!")
  if( length(model$linit)!=K ) stop("dimensions of linit incorrect!")
  if( NROW(x)!=sum(TT) )  stop("no. of rows in x not equal sum(TT) !")

  mstep = model$mstep
  # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  Emit.Prob.Func = model$dens.emission
  # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  loglik1 = numeric(maxit)
  loglik1[] = NA
  loglik1[1] = -1000
  loglik2 = numeric(maxit)
  loglik2[] = NA
  loglik2[1] = -1000

  # initialize gamma ===========
  lgam = rep(-1.0e100, K*sum(TT))
  # ============================
  lAlpha = rep(-1.0e300, (K+1)*sum(TT))
  lBeta = rep(-1.0e300, K*sum(TT))

  ll = c(0.0, 0.0)
  mu.it = rep(list(list()), maxit)

  for(i in 1:maxit) {
    if (verbose == TRUE) cat("\niter:",i," ====")
    # calculate emission prob by state given model >>>>>>>>>>>>>>>>>>>>>>>>>>>>
    emit.p = sapply(1:K, fn <- function(state) Emit.Prob.Func(x, state, model))
    # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    # E-step <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    result = .C("mo_estep_hmm_ln",
        lA=as.double(t(model$ltransition)),
        lPi=as.double(t(model$linit)),
        lP=as.double(t(emit.p)),
        TT=as.integer(TT),
        nsequences=as.integer(Nseq),
        K=as.integer(K),
        forward_p=lAlpha,
        backward_p=lBeta,
        lgam=lgam,
        ll=as.double(ll),
        PACKAGE='Hext')

    loglik1[i] = result$ll[1]
    loglik2[i] = result$ll[2]
    if (verbose == TRUE) {
      cat("loglikelihood(alpha) ", result$ll[1])
      cat(".....(beta)", result$ll[2])
    }
    if ( i > 1 ) {
      if(abs(loglik1[i]-loglik1[i-1]) < tol) {
        if (verbose == TRUE) cat("\nConverged.\n")
        break
      }
    }
    # M-step >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    gam = matrix(exp(result$lgam), ncol=K)
    # simple check on gamma
    gamsum = rowSums(gam)

    model$parms.emission = mstep(x, gam, model)

    # write the optimized parameters back to model
    if(!lock.transition) {
      model$ltransition = matrix(result$lA, nrow=K, byrow=TRUE)
      model$linit = result$lPi
    }
    # save the means vector for output
    mu.it[[i]] = model$parms.emission$M5$mu.ll
  }

  LL = loglik1[i]    # last iteration
  # Calculate no of parameters in the model >>>>>>>>>>>>>>>>>>>>>>>>>
  # 1 = discrete
  ix1 = which(mtype == 1)
  if ( length(ix1) > 0 ) {
    n.par1 = K*length(ix1)*(D - 1)
  } else {
    n.par1 = 0
  }
  # 2 = normal/multivariate
  ix2 = which(mtype == 2)
  if ( length(ix2) > 0 ) {
    # Zucchini & MacDonald (2009), p.186
    # K*p(p+3)/2, where p is the dimension of the observation, and is equal
    # the number of 2s in mtype.
    n.par2 = K*length(ix2)*(length(ix2) + 3)/2
  } else {
    n.par2 = 0
  }
  # 3 = gamma
  ix3 = which(mtype == 3)
  if ( length(ix3) > 0 ) {
    # two free parameters for each component obeying the gamma distribution
    n.par3 = K * length(ix3) * 2
  } else {
    n.par3 = 0
  }
  # 4 = beta
  ix4 = which(mtype == 4)
  if ( length(ix4) > 0 ) {
    # two free parameters for each component obeying the beta distribution
    n.par4 = K * length(ix4) * 2
  } else {
    n.par4 = 0
  }
  # 5 = gaussian mixture
  ix5 = which(mtype == 5)
  if ( length(ix5) > 0 ) {
    # for each multivariate component, there are M mixtures, and each mixture
    # has p(p+3)/2 parameters, thus total :
    n.par5 = K * length(ix5)* M * (length(ix5) + 3) / 2
  } else {
    n.par5 = 0
  }
  np.trans = K * ( K - 1 )
  # Total number of parameters in the HMM
  N.param = np.trans + n.par1 + n.par2 + n.par3 + n.par4 + n.par5
  # Akaike information criterion (Ref : wiki on AIC)
  Aic = - 2*LL + 2*N.param
  # AIC with finite sample correction (see wiki on AIC)
  # Burnham, Anderson (2002) Model selection and multimodel inference: A Practical
  #   Information-Theoretic Approach, 2nd ed, Springer.
  Aicc = Aic + 2*N.param*(N.param + 1)/(sum(TT) - N.param - 1)
  Bic = - 2*LL + N.param*log(sum(TT))

  ret = list(model=model,mstep=mstep, gam=gam, lgam=result$lgam, last.it=i,
         loglik1=loglik1, loglik2=loglik2, TT=TT, yhat=apply(gam,1,which.max),
         Aic=Aic, Aicc=Aicc, Bic=Bic, mu.it=mu.it)
  class(ret) <- "Hext"
  return(ret)
}