module feval
   use bl_types, only: dp_t
   use bl_constants_module, only: ZERO, ONE, TWELFTH, FIVE6TH, THIRD
   use network, only: nspec, nspec_advance, aion, zion, ebin
   use network_indices, only: ic12_, io16_, img24_
   use rpar_indices, only: irp_dens, irp_cp, irp_dhdx, irp_o16, irp_rate, &
                           irp_dratedt, irp_sc1212, irp_dsc1212dt, irp_xc12tmp
   implicit none
contains
   subroutine f_rhs_vec(neq, npt, y, t, yd, upar)
      !$acc routine seq
      !$acc routine(screenz) seq

      ! our convention is that y(1:nspec) are the species (in the same
      ! order as defined in network.f90, and y(nspec+1) is the temperature

      integer,         intent(in   ) :: neq, npt
      real(kind=dp_t), intent(in   ) :: y(neq,npt), t
      !real(kind=dp_t), intent(  out) :: yd_out(neq,npt)
      real(kind=dp_t), intent(  out) :: yd(neq,npt)
      real(kind=dp_t), intent(inout) :: upar(:,:)

      integer :: k, n
      real(kind=dp_t) :: ymass(nspec,npt)!, yd(neq,npt)
      real(kind=dp_t) :: dens(npt), c_p(npt), dhdX(nspec,npt), X_O16(npt)
      real(kind=dp_t) :: temp(npt), T9, T9a, dT9dt, dT9adt

      real(kind=dp_t) :: rate, dratedt
      real(kind=dp_t) :: sc1212, dsc1212dt
      real(kind=dp_t) :: xc12tmp

      !real(kind=dp_t), PARAMETER :: &
      !                   one_twelvth = 1.0d0/12.0d0, &
      !                   five_sixths = 5.0d0/ 6.0d0, &
      !                     one_third = 1.0d0/ 3.0d0, &
      !                    two_thirds = 2.0d0/ 3.0d0

      !                   one_twelvth = 1.0d0/12.0d0, & --> TWELFTH
      !                   five_sixths = 5.0d0/ 6.0d0, & --> FIVE6TH
      !                     one_third = 1.0d0/ 3.0d0, & --> THIRD
      !                    two_thirds = 2.0d0/ 3.0d0    --> TWO3RD
      real(kind=dp_t) :: scratch, dscratchdt

      real(kind=dp_t) :: a, b, dadt, dbdt

      do n = 1, npt
         !initialize data
         dens(n) = upar(irp_dens,n)
         temp(n) = y(nspec_advance+1,n)

         c_p(n)  = upar(irp_cp,n)
         do k = 1, nspec
            dhdX(k,n) = upar(irp_dhdX - 1 + k, n)
         end do
         X_O16(n)   = upar(irp_o16,n)

         ! compute the molar fractions -- needed for the screening
         ymass(ic12_,n) = y(1,n)/aion(ic12_)
         ymass(io16_,n) = X_O16(n)/aion(io16_)
         ymass(img24_,n) = (ONE - y(1,n) - X_O16(n))/aion(img24_)

        ! call the screening routine
        call screenz(temp(n),dens(n),6.0d0,6.0d0,12.0d0,12.0d0,ymass(:,n),aion,zion,nspec,sc1212,dsc1212dt)

        ! compute some often used temperature constants
        T9     = temp(n)/1.d9
        dT9dt  = ONE/1.d9
        T9a    = T9/(ONE + 0.0396d0*T9)
        dT9adt = (T9a / T9 - (T9a / (ONE + 0.0396d0*T9)) * 0.0396d0) * dT9dt

        ! compute the CF88 rate
        scratch    = T9a**THIRD
        dscratchdt = THIRD * T9a**(-2.0d0 * THIRD) * dT9adt

        a       = 4.27d26*T9a**FIVE6TH*T9**(-1.5d0)
        dadt    = FIVE6TH * (a/T9a) * dT9adt - 1.5d0 * (a/T9) * dT9dt

        b       = dexp(-84.165d0/scratch - 2.12d-3*T9*T9*T9)
        dbdt    = (84.165d0 * dscratchdt/ scratch**2.0d0                            &
          - 3.0d0 * 2.12d-3 * T9 * T9 * dT9dt) * b

        rate    = a *  b
        dratedt = dadt * b + a * dbdt

        ! The change in number density of C12 is
        ! d(n12)/dt = - 2 * 1/2 (n12)**2 <sigma v>
        !
        ! where <sigma v> is the average of the relative velocity times the cross
        ! section for the reaction, and the factor accounting for the total number
        ! of particle pairs has a 1/2 because we are considering a reaction involving
        ! identical particles (see Clayton p. 293).  Finally, the -2 means that for
        ! each reaction, we lose 2 carbon nuclei.
        !
        ! The corresponding Mg24 change is
        ! d(n24)/dt = + 1/2 (n12)**2 <sigma v>
        !
        ! note that no factor of 2 appears here, because we create only 1 Mg nuclei.
        !
        ! Switching over to mass fractions, using n = rho X N_A/A, where N_A is
        ! Avagadro's number, and A is the mass number of the nucleon, we get
        !
        ! d(X12)/dt = -2 *1/2 (X12)**2 rho N_A <sigma v> / A12
        !
        ! d(X24)/dt = + 1/2 (X12)**2 rho N_A <sigma v> (A24/A12**2)
        !
        ! these are equal and opposite.
        !
        ! The quantity [N_A <sigma v>] is what is tabulated in Caughlin and Fowler.

        ! we will always refer to the species by integer indices that come from
        ! the network module -- this makes things robust to a shuffling of the
        ! species ordering

        xc12tmp = max(y(ic12_,n),0.d0)
        yd(ic12_,n) = -TWELFTH*dens(n)*sc1212*rate*xc12tmp**2

        ! now compute the change in temperature, using the evolution equation
        ! dT/dt = -(1/c_p) sum_k (xi_k + q_k) omega_k
        !
        ! we make use of the fact that omega(Mg24) = - omega(C12), and that
        ! omega(O16) = 0 in our simplified burner
        yd(nspec_advance+1,n) =  ( (dhdx(img24_,n) - dhdx(ic12_,n)) + &
          (ebin(img24_) - ebin(ic12_)) )*yd(ic12_,n)/c_p(n)

        ! for Mr. Jacobian
        upar(irp_rate,n)      = rate
        upar(irp_dratedt,n)   = dratedt
        upar(irp_sc1212,n)    = sc1212
        upar(irp_dsc1212dt,n) = dsc1212dt
        upar(irp_xc12tmp,n)   = xc12tmp
      enddo

      !yd_out(ic12_,:) = yd(ic12_,:)
      !yd_out(nspec_advance+1,:) = yd(nspec_advance+1,:)

   end subroutine f_rhs_vec

   subroutine jac_vec(neq, npt, y, t, pd, upar)
      !$acc routine seq

      integer        , intent(in   ) :: neq, npt
      real(kind=dp_t), intent(in   ) :: y(neq,npt), t
      real(kind=dp_t), intent(  out) :: pd(neq,neq,npt)
      real(kind=dp_t), intent(inout) :: upar(:,:)

      real(kind=dp_t) :: dens(npt), c_p(npt), dhdX(nspec,npt), X_O16(npt)
      real(kind=dp_t) :: rate, dratedt, scorr, dscorrdt, xc12tmp

      integer :: itemp, n, k, nn, kk

      do n=1, npt

        dens(n)    = upar(irp_dens,n)
        c_p(n)     = upar(irp_cp,n)
        do k = 1, nspec
           dhdX(k,n)  = upar(irp_dhdX - 1 + k, n)
        end do
        X_O16(n)   = upar(irp_o16,n)

        rate     = upar(irp_rate,n)
        dratedt  = upar(irp_dratedt,n)
        scorr    = upar(irp_sc1212,n)
        dscorrdt = upar(irp_dsc1212dt,n)
        xc12tmp  = upar(irp_xc12tmp,n)

        ! initialize
        do nn = 1, neq
           do kk = 1, neq
              pd(nn,kk,n) = ZERO
           end do
        end do

        itemp = nspec_advance + 1

        ! carbon jacobian elements
        pd(ic12_, ic12_,n) = -(1.0d0/6.0d0)*dens(n)*scorr*rate*xc12tmp

        ! add the temperature derivatives: df(y_i) / dT
        pd(ic12_,itemp,n) = -(1.0d0/12.0d0)*(dens(n)*rate*xc12tmp**2*dscorrdt    &
                                         + dens(n)*scorr*xc12tmp**2*dratedt)

        ! add the temperature jacobian elements df(T) / df(y)
        pd(itemp,ic12_,n) =  ( (dhdx(img24_,n) - dhdx(ic12_,n)) + &
                             (ebin(img24_) - ebin(ic12_)) )*pd(ic12_,ic12_,n)/c_p(n)

        ! add df(T) / dT
        pd(itemp,itemp,n) = ( (dhdx(img24_,n) - dhdx(ic12_,n)) + &
                            (ebin(img24_) - ebin(ic12_)) )*pd(ic12_,itemp,n)/c_p(n)
      end do
   end subroutine jac_vec
end module feval

!TODO: The below is old, delete it after done using it as development reference
!! VBDF-style vectorized RHS
!subroutine f_rhs_vec(neq, npt, y, t, yd_out, upar)
!  !$acc routine seq
!
!  use bl_types, only: dp_t
!  use bl_constants_module, only: ONE
!  use network
!  use network_indices
!  use rpar_indices
!
!  implicit none
!  !$acc routine(screenz) seq
!
!  ! our convention is that y(1:nspec) are the species (in the same
!  ! order as defined in network.f90, and y(nspec+1) is the temperature
!
!  integer,         intent(in   ) :: neq, npt
!  real(kind=dp_t), intent(in   ) :: y(neq,npt), t
!  real(kind=dp_t), intent(  out) :: yd_out(neq,npt)
!  real(kind=dp_t), intent(inout) :: upar(:,:)
!
!  integer :: k, n
!  real(kind=dp_t) :: ymass(nspec,npt), yd(neq,npt)
!  real(kind=dp_t) :: dens(npt), c_p(npt), dhdX(nspec,npt), X_O16(npt)
!  real(kind=dp_t) :: temp(npt), T9, T9a, dT9dt, dT9adt
!
!  real(kind=dp_t) :: rate, dratedt
!  real(kind=dp_t) :: sc1212, dsc1212dt
!  real(kind=dp_t) :: xc12tmp
!
!  real(kind=dp_t), PARAMETER :: &
!                     one_twelvth = 1.0d0/12.0d0, &
!                     five_sixths = 5.0d0/ 6.0d0, &
!                       one_third = 1.0d0/ 3.0d0, &
!                      two_thirds = 2.0d0/ 3.0d0
!
!  real(kind=dp_t) :: scratch, dscratchdt
!
!  real(kind=dp_t) :: a, b, dadt, dbdt
!
!  dens(:) = upar(irp_dens,:)
!  temp(:) = y(nspec_advance+1,:)
!
!  c_p(:)  = upar(irp_cp,:)
!  dhdX(:,:) = upar(irp_dhdX:irp_dhdX-1+nspec,:)
!  X_O16(:)   = upar(irp_o16,:)
!
!  ! compute the molar fractions -- needed for the screening
!  ymass(ic12_,:) = y(1,:)/aion(ic12_)
!  ymass(io16_,:) = X_O16(:)/aion(io16_)
!  ymass(img24_,:) = (ONE - y(1,:) - X_O16)/aion(img24_)
!
!  do n = 1, npt
!    ! call the screening routine
!    call screenz(temp(n),dens(n),6.0d0,6.0d0,12.0d0,12.0d0,ymass(:,n),aion,zion,nspec,sc1212,dsc1212dt)
!
!    ! compute some often used temperature constants
!    T9     = temp(n)/1.d9
!    dT9dt  = ONE/1.d9
!    T9a    = T9/(1.0d0 + 0.0396d0*T9)
!    dT9adt = (T9a / T9 - (T9a / (1.0d0 + 0.0396d0*T9)) * 0.0396d0) * dT9dt
!
!    ! compute the CF88 rate
!    scratch    = T9a**one_third
!    dscratchdt = one_third * T9a**(-2.0d0 * one_third) * dT9adt
!
!    a       = 4.27d26*T9a**five_sixths*T9**(-1.5d0)
!    dadt    = five_sixths * (a/T9a) * dT9adt - 1.5d0 * (a/T9) * dT9dt
!
!    b       = dexp(-84.165d0/scratch - 2.12d-3*T9*T9*T9)
!    dbdt    = (84.165d0 * dscratchdt/ scratch**2.0d0                            &
!      - 3.0d0 * 2.12d-3 * T9 * T9 * dT9dt) * b
!
!    rate    = a *  b
!    dratedt = dadt * b + a * dbdt
!
!    ! The change in number density of C12 is
!    ! d(n12)/dt = - 2 * 1/2 (n12)**2 <sigma v>
!    !
!    ! where <sigma v> is the average of the relative velocity times the cross
!    ! section for the reaction, and the factor accounting for the total number
!    ! of particle pairs has a 1/2 because we are considering a reaction involving
!    ! identical particles (see Clayton p. 293).  Finally, the -2 means that for
!    ! each reaction, we lose 2 carbon nuclei.
!    !
!    ! The corresponding Mg24 change is
!    ! d(n24)/dt = + 1/2 (n12)**2 <sigma v>
!    !
!    ! note that no factor of 2 appears here, because we create only 1 Mg nuclei.
!    !
!    ! Switching over to mass fractions, using n = rho X N_A/A, where N_A is
!    ! Avagadro's number, and A is the mass number of the nucleon, we get
!    !
!    ! d(X12)/dt = -2 *1/2 (X12)**2 rho N_A <sigma v> / A12
!    !
!    ! d(X24)/dt = + 1/2 (X12)**2 rho N_A <sigma v> (A24/A12**2)
!    !
!    ! these are equal and opposite.
!    !
!    ! The quantity [N_A <sigma v>] is what is tabulated in Caughlin and Fowler.
!
!    ! we will always refer to the species by integer indices that come from
!    ! the network module -- this makes things robust to a shuffling of the
!    ! species ordering
!
!    xc12tmp = max(y(ic12_,n),0.d0)
!    yd(ic12_,n) = -one_twelvth*dens(n)*sc1212*rate*xc12tmp**2
!
!    ! now compute the change in temperature, using the evolution equation
!    ! dT/dt = -(1/c_p) sum_k (xi_k + q_k) omega_k
!    !
!    ! we make use of the fact that omega(Mg24) = - omega(C12), and that
!    ! omega(O16) = 0 in our simplified burner
!    yd(nspec_advance+1,n) =  ( (dhdx(img24_,n) - dhdx(ic12_,n)) + &
!      (ebin(img24_) - ebin(ic12_)) )*yd(ic12_,n)/c_p(n)
!
!    ! for Mr. Jacobian
!    upar(irp_rate,n)      = rate
!    upar(irp_dratedt,n)   = dratedt
!    upar(irp_sc1212,n)    = sc1212
!    upar(irp_dsc1212dt,n) = dsc1212dt
!    upar(irp_xc12tmp,n)   = xc12tmp
!  enddo
!
!
!  yd_out(ic12_,:) = yd(ic12_,:)
!  yd_out(nspec_advance+1,:) = yd(nspec_advance+1,:)
!
!  return
!
!end subroutine f_rhs_vec
!
!! DVODE-style RHS
!subroutine f_rhs(n, t, y, ydot, rpar, ipar)
!
!  use bl_types, only: dp_t
!  use bl_constants_module, only: ONE
!  use network
!  use network_indices
!  use rpar_indices
!
!  implicit none
!
!  ! our convention is that y(1:nspec) are the species (in the same
!  ! order as defined in network.f90, and y(nspec+1) is the temperature
!  integer,         intent(in   ) :: n, ipar(:)
!  real(kind=dp_t), intent(in   ) :: y(n), t
!  real(kind=dp_t), intent(  out) :: ydot(n)
!  real(kind=dp_t), intent(inout) :: rpar(*)  !For DVODE compatibility, use (*) instead of (:)
!
!  integer :: k
!  real(kind=dp_t) :: ymass(nspec)
!
!  real(kind=dp_t) :: dens, c_p, dhdX(nspec), X_O16
!  real(kind=dp_t) :: temp, T9, T9a, dT9dt, dT9adt
!
!  real(kind=dp_t) :: rate, dratedt
!  real(kind=dp_t) :: sc1212, dsc1212dt
!  real(kind=dp_t) :: xc12tmp
!
!  real(kind=dp_t), PARAMETER :: &
!                     one_twelvth = 1.0d0/12.0d0, &
!                     five_sixths = 5.0d0/ 6.0d0, &
!                       one_third = 1.0d0/ 3.0d0, &
!                      two_thirds = 2.0d0/ 3.0d0
!
!  real(kind=dp_t) :: scratch, dscratchdt
!
!  real(kind=dp_t) :: a, b, dadt, dbdt
!
!  dens = rpar(irp_dens)
!  temp = y(nspec_advance+1)
!
!  c_p     = rpar(irp_cp)
!  dhdX(:) = rpar(irp_dhdX:irp_dhdX-1+nspec)
!  X_O16   = rpar(irp_o16)
!
!  ! compute the molar fractions -- needed for the screening
!  ymass(ic12_) = y(1)/aion(ic12_)
!  ymass(io16_) = X_O16/aion(io16_)
!  ymass(img24_) = (ONE - y(1) - X_O16)/aion(img24_)
!
!  ! call the screening routine
!  call screenz(temp,dens,6.0d0,6.0d0,12.0d0,12.0d0,ymass,aion,zion,nspec,     &
!    sc1212, dsc1212dt)
!
!  ! compute some often used temperature constants
!  T9     = temp/1.d9
!  dT9dt  = ONE/1.d9
!  T9a    = T9/(1.0d0 + 0.0396d0*T9)
!  dT9adt = (T9a / T9 - (T9a / (1.0d0 + 0.0396d0*T9)) * 0.0396d0) * dT9dt
!
!  ! compute the CF88 rate
!  scratch    = T9a**one_third
!  dscratchdt = one_third * T9a**(-2.0d0 * one_third) * dT9adt
!
!  a       = 4.27d26*T9a**five_sixths*T9**(-1.5d0)
!  dadt    = five_sixths * (a/T9a) * dT9adt - 1.5d0 * (a/T9) * dT9dt
!
!  b       = dexp(-84.165d0/scratch - 2.12d-3*T9*T9*T9)
!  dbdt    = (84.165d0 * dscratchdt/ scratch**2.0d0                            &
!    - 3.0d0 * 2.12d-3 * T9 * T9 * dT9dt) * b
!
!  rate    = a *  b
!  dratedt = dadt * b + a * dbdt
!
!  ! The change in number density of C12 is
!  ! d(n12)/dt = - 2 * 1/2 (n12)**2 <sigma v>
!  !
!  ! where <sigma v> is the average of the relative velocity times the cross
!  ! section for the reaction, and the factor accounting for the total number
!  ! of particle pairs has a 1/2 because we are considering a reaction involving
!  ! identical particles (see Clayton p. 293).  Finally, the -2 means that for
!  ! each reaction, we lose 2 carbon nuclei.
!  !
!  ! The corresponding Mg24 change is
!  ! d(n24)/dt = + 1/2 (n12)**2 <sigma v>
!  !
!  ! note that no factor of 2 appears here, because we create only 1 Mg nuclei.
!  !
!  ! Switching over to mass fractions, using n = rho X N_A/A, where N_A is
!  ! Avagadro's number, and A is the mass number of the nucleon, we get
!  !
!  ! d(X12)/dt = -2 *1/2 (X12)**2 rho N_A <sigma v> / A12
!  !
!  ! d(X24)/dt = + 1/2 (X12)**2 rho N_A <sigma v> (A24/A12**2)
!  !
!  ! these are equal and opposite.
!  !
!  ! The quantity [N_A <sigma v>] is what is tabulated in Caughlin and Fowler.
!
!  ! we will always refer to the species by integer indices that come from
!  ! the network module -- this makes things robust to a shuffling of the
!  ! species ordering
!
!  xc12tmp = max(y(ic12_),0.d0)
!  ydot(ic12_) = -one_twelvth*dens*sc1212*rate*xc12tmp**2
!
!  ! now compute the change in temperature, using the evolution equation
!  ! dT/dt = -(1/c_p) sum_k (xi_k + q_k) omega_k
!  !
!  ! we make use of the fact that omega(Mg24) = - omega(C12), and that
!  ! omega(O16) = 0 in our simplified burner
!  ydot(nspec_advance+1) =  ( (dhdx(img24_) - dhdx(ic12_)) + &
!    (ebin(img24_) - ebin(ic12_)) )*ydot(ic12_)/c_p
!
!
!  ! for Mr. Jacobian
!  rpar(irp_rate)      = rate
!  rpar(irp_dratedt)   = dratedt
!  rpar(irp_sc1212)    = sc1212
!  rpar(irp_dsc1212dt) = dsc1212dt
!  rpar(irp_xc12tmp)   = xc12tmp
!
!  return
!
!end subroutine f_rhs
!
!! VBDF-style vectorized Jacobian
!subroutine jac_vec(neq, npt, y, t, pd, upar)
!  !$acc routine seq
!  use bl_types
!  use bl_constants_module
!  use network
!  use network_indices
!  use rpar_indices
!
!  implicit none
!
!  integer        , intent(IN   ) :: neq, npt
!  real(kind=dp_t), intent(IN   ) :: y(neq,npt), t
!  real(kind=dp_t), intent(  OUT) :: pd(neq,neq,npt)
!  real(dp_t),      intent(inout) :: upar(:,:)
!
!  real(kind=dp_t) :: dens(npt), c_p(npt), dhdX(nspec,npt), X_O16(npt)
!  real(kind=dp_t) :: rate, dratedt, scorr, dscorrdt, xc12tmp
!
!  integer :: itemp, n
!
!  dens(:)    = upar(irp_dens,:)
!  c_p(:)     = upar(irp_cp,:)
!  dhdX(:,:)  = upar(irp_dhdX:irp_dhdX-1+nspec,:)
!  X_O16(:)   = upar(irp_o16,:)
!
!  do n=1, npt
!    rate     = upar(irp_rate,n)
!    dratedt  = upar(irp_dratedt,n)
!    scorr    = upar(irp_sc1212,n)
!    dscorrdt = upar(irp_dsc1212dt,n)
!    xc12tmp  = upar(irp_xc12tmp,n)
!
!    ! initialize
!    pd(:,:,n)  = ZERO
!
!    itemp = nspec_advance + 1
!
!
!    ! carbon jacobian elements
!    pd(ic12_, ic12_,n) = -(1.0d0/6.0d0)*dens(n)*scorr*rate*xc12tmp
!
!
!    ! add the temperature derivatives: df(y_i) / dT
!    pd(ic12_,itemp,n) = -(1.0d0/12.0d0)*(dens(n)*rate*xc12tmp**2*dscorrdt    &
!                                     + dens(n)*scorr*xc12tmp**2*dratedt)
!
!    ! add the temperature jacobian elements df(T) / df(y)
!    pd(itemp,ic12_,n) =  ( (dhdx(img24_,n) - dhdx(ic12_,n)) + &
!                         (ebin(img24_) - ebin(ic12_)) )*pd(ic12_,ic12_,n)/c_p(n)
!
!
!    ! add df(T) / dT
!    pd(itemp,itemp,n) = ( (dhdx(img24_,n) - dhdx(ic12_,n)) + &
!                        (ebin(img24_) - ebin(ic12_)) )*pd(ic12_,itemp,n)/c_p(n)
!  end do
!
!  return
!end subroutine jac_vec
!
!!
!!
!! DVODE-style Jacobian
!subroutine jac(neq, t, y, ml, mu, pd, nrpd, rpar, ipar)
!
!  use bl_types
!  use bl_constants_module
!  use network
!  use network_indices
!  use rpar_indices
!
!  implicit none
!
!  integer        , intent(IN   ) :: neq, ml, mu, nrpd, ipar(:)
!  real(kind=dp_t), intent(IN   ) :: y(neq), rpar(*), t      !For DVODE compatibility, use (*) instead of (:)
!  real(kind=dp_t), intent(  OUT) :: pd(neq,neq)
!
!  real(kind=dp_t) :: dens, c_p, dhdX(nspec), X_O16
!  real(kind=dp_t) :: rate, dratedt, scorr, dscorrdt, xc12tmp
!
!  integer :: itemp
!
!  dens    = rpar(irp_dens)
!  c_p     = rpar(irp_cp)
!  dhdX(:) = rpar(irp_dhdX:irp_dhdX-1+nspec)
!  X_O16   = rpar(irp_o16)
!
!  rate     = rpar(irp_rate)
!  dratedt  = rpar(irp_dratedt)
!  scorr    = rpar(irp_sc1212)
!  dscorrdt = rpar(irp_dsc1212dt)
!  xc12tmp  = rpar(irp_xc12tmp)
!
!  ! initialize
!  pd(:,:)  = ZERO
!
!  itemp = nspec_advance + 1
!
!
!  ! carbon jacobian elements
!  pd(ic12_, ic12_) = -(1.0d0/6.0d0)*dens*scorr*rate*xc12tmp
!
!
!
!  ! add the temperature derivatives: df(y_i) / dT
!  pd(ic12_,itemp) = -(1.0d0/12.0d0)*(dens*rate*xc12tmp**2*dscorrdt    &
!                                   + dens*scorr*xc12tmp**2*dratedt)
!
!  ! add the temperature jacobian elements df(T) / df(y)
!  pd(itemp,ic12_) =  ( (dhdx(img24_) - dhdx(ic12_)) + &
!                       (ebin(img24_) - ebin(ic12_)) )*pd(ic12_,ic12_)/c_p
!
!
!  ! add df(T) / dT
!  pd(itemp,itemp) = ( (dhdx(img24_) - dhdx(ic12_)) + &
!                      (ebin(img24_) - ebin(ic12_)) )*pd(ic12_,itemp)/c_p
!
!
!  return
!end subroutine jac
!


      SUBROUTINE NF01BD( CJTE, NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU,
     $                   E, J, LDJ, JTE, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To calculate the Jacobian dy/dX of the Wiener system
C
C        x(t+1) = A*x(t) + B*u(t)
C        z(t)   = C*x(t) + D*u(t),
C
C        y(t,i) = sum( ws(k, i)*f(w(k, i)*z(t) + b(k,i)) ) + b(k+1,i),
C
C     where t = 1, 2, ...,  NSMP,
C           i = 1, 2, ...,  L,
C           k = 1, 2, ...,  NN.
C
C     NN is arbitrary eligible and has to be provided in IPAR(2), and
C     X = ( wb(1), ..., wb(L), theta ) is described below.
C
C     Denoting y(j) = y(1:NSMP,j), the Jacobian J has the block form
C
C       dy(1)/dwb(1)       0         .....       0         dy(1)/dtheta
C            0        dy(2)/dwb(2)   .....       0         dy(2)/dtheta
C          .....         .....       .....     .....          .....
C            0           .....         0    dy(L)/dwb(L)   dy(L)/dtheta
C
C     but it will be returned without the zero blocks, in the form
C
C     dy(1)/dwb(1)    dy(1)/dtheta
C                  ...
C     dy(L)/dwb(L)    dy(L)/dtheta.
C
C     dy(i)/dwb(i) depends on f and is calculated by the routine NF01BY;
C     dy(i)/dtheta is computed by a forward-difference approximation.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     CJTE    CHARACTER*1
C             Specifies whether the matrix-vector product J'*e should be
C             computed or not, as follows:
C             = 'C' :  compute J'*e;
C             = 'N' :  do not compute J'*e.
C
C     Input/Output Parameters
C
C     NSMP    (input) INTEGER
C             The number of training samples.  NSMP >= 0.
C
C     M       (input) INTEGER
C             The length of each input sample.  M >= 0.
C
C     L       (input) INTEGER
C             The length of each output sample.  L >= 0.
C
C     IPAR    (input/output) INTEGER array, dimension (LIPAR)
C             On entry, the first entries of this array must contain
C             the integer parameters needed; specifically,
C             IPAR(1)  must contain the order of the linear part, N;
C                      actually, N = abs(IPAR(1)), since setting
C                      IPAR(1) < 0 has a special meaning (see below);
C             IPAR(2)  must contain the number of neurons for the
C                      nonlinear part, NN, NN >= 0.
C             On exit, if IPAR(1) < 0 on entry, then no computations are
C             performed, except the needed tests on input parameters,
C             but the following values are returned:
C             IPAR(1) contains the length of the array J, LJ;
C             LDJ     contains the leading dimension of array J.
C             Otherwise, IPAR(1) and LDJ are unchanged on exit.
C
C     LIPAR   (input) INTEGER
C             The length of the array IPAR.  LIPAR >= 2.
C
C     X       (input) DOUBLE PRECISION array, dimension (LX)
C             The leading LPAR entries of this array must contain the
C             set of system parameters, where
C                LPAR = (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M.
C             X has the form (wb(1), ..., wb(L), theta), where the
C             vectors wb(i) have the structure
C              (w(1,1), ..., w(1,L), ..., w(NN,1), ..., w(NN,L),
C                ws(1), ..., ws(NN), b(1), ..., b(NN+1) ),
C             and the vector theta represents the matrices A, B, C, D
C             and x(1), and it can be retrieved from these matrices
C             by SLICOT Library routine TB01VD and retranslated by
C             TB01VY.
C
C     LX      (input) INTEGER
C             The length of X.
C             LX >= (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M.
C
C     U       (input) DOUBLE PRECISION array, dimension (LDU, M)
C             The leading NSMP-by-M part of this array must contain the
C             set of input samples,
C             U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ).
C
C     LDU     INTEGER
C             The leading dimension of array U.  LDU >= MAX(1,NSMP).
C
C     E       (input) DOUBLE PRECISION array, dimension (NSMP*L)
C             If CJTE = 'C', this array must contain a vector e, which
C             will be premultiplied with J', e = vec( Y - y ), where
C             Y is set of output samples, and vec denotes the
C             concatenation of the columns of a matrix.
C             If CJTE = 'N', this array is not referenced.
C
C     J       (output) DOUBLE PRECISION array, dimension (LDJ, *)
C             The leading NSMP*L-by-NCOLJ part of this array contains
C             the Jacobian of the error function stored in a compressed
C             form, as described above, where
C             NCOLJ = NN*(L + 2) + 1 + N*(M + L + 1) + L*M.
C
C     LDJ     INTEGER
C             The leading dimension of array J.  LDJ >= MAX(1,NSMP*L).
C             Note that LDJ is an input parameter, except for
C             IPAR(1) < 0 on entry, when it is an output parameter.
C
C     JTE     (output) DOUBLE PRECISION array, dimension (LPAR)
C             If CJTE = 'C', this array contains the matrix-vector
C             product J'*e.
C             If CJTE = 'N', this array is not referenced.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N +
C                                       MAX( N*(N + L), N + M + L ) )
C                                                              if M > 0;
C             LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N +
C                                       MAX( N*(N + L), L ) ), if M = 0.
C             A larger value of LDWORK could improve the efficiency.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     BLAS routines are used for the matrix-vector multiplications, and
C     the SLICOT Library routine TB01VY is called for the conversion of
C     the output normal form parameters to an LTI-system; the routine
C     NF01AD is then used for the simulation of the system with given
C     parameters, and the routine NF01BY is called for the (analytically
C     performed) calculation of the parts referring to the parameters
C     of the static nonlinearity.
C
C     CONTRIBUTORS
C
C     A. Riedel, R. Schneider, Chemnitz University of Technology,
C     Mar. 2001, during a stay at University of Twente, NL.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001,
C     Dec. 2001.
C
C     KEYWORDS
C
C     Jacobian matrix, nonlinear system, output normal form, simulation,
C     state-space representation, Wiener system.
C
C     ******************************************************************
C
C     .. Parameters ..
C     .. EPSFCN is related to the error in computing the functions ..
C     .. For EPSFCN = 0.0D0, the square root of the machine precision
C     .. is used for finite difference approximation of the derivatives.
      DOUBLE PRECISION  ZERO, ONE, EPSFCN
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, EPSFCN = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         CJTE
      INTEGER           INFO, L, LDJ, LDU, LDWORK, LX, LIPAR, M, NSMP
C     .. Array Arguments ..
      INTEGER           IPAR(*)
      DOUBLE PRECISION  DWORK(*), E(*), J(LDJ, *), JTE(*), U(LDU,*),
     $                  X(*)
C     .. Local Scalars ..
      LOGICAL           WJTE
      DOUBLE PRECISION  EPS, H, PARSAV
      INTEGER           AC, BD, BSN, I, IX, IY, JW, K, KCOL, LDAC, LPAR,
     $                  LTHS, N, NN, NSML, NTHS, Z
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH
      LOGICAL           LSAME
      EXTERNAL          DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMV, NF01AD, NF01AY, NF01BY, TB01VY,
     $                  TF01MX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, MIN, SQRT
C     ..
C     .. Executable Statements ..
C
      N    = IPAR(1)
      NN   = IPAR(2)
      BSN  = NN*( L + 2 ) + 1
      NSML = NSMP*L
      NTHS = BSN*L
      LTHS = N*( M + L + 1 ) + L*M
      LPAR = NTHS + LTHS
      WJTE = LSAME( CJTE, 'C' )
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN
         INFO = -1
      ELSEIF ( NSMP.LT.0 ) THEN
         INFO = -2
      ELSEIF ( M.LT.0 ) THEN
         INFO = -3
      ELSEIF ( L.LT.0 ) THEN
         INFO = -4
      ELSEIF ( NN.LT.0 ) THEN
         INFO = -5
      ELSEIF ( LIPAR.LT.2 ) THEN
         INFO = -6
      ELSEIF ( IPAR(1).LT.0 ) THEN
         IF( INFO.NE.0 ) THEN
            CALL XERBLA( 'NF01BD', -INFO )
         ELSE
            IPAR(1) = NSML*( ABS( N )*( M + L + 1 ) + L*M + BSN )
            LDJ     = MAX( 1, NSML )
         ENDIF
         RETURN
      ELSEIF ( LX.LT.LPAR ) THEN
         INFO = -8
      ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN
         INFO = -10
      ELSEIF ( LDJ.LT.MAX( 1, NSML ) ) THEN
         INFO = -13
      ELSE
         LDAC = N + L
         IF ( M.GT.0 ) THEN
            JW = MAX( N*LDAC, N + M + L )
         ELSE
            JW = MAX( N*LDAC, L )
         END IF
         IF ( LDWORK.LT.2*NSML + MAX( 2*NN, LDAC*( N + M ) + 2*N + JW ))
     $      INFO = -16
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'NF01BD', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( MIN( NSMP, L ).EQ.0 ) THEN
         IF ( WJTE .AND. LPAR.GE.1 ) THEN
            JTE(1) = ZERO
            CALL DCOPY( LPAR, JTE(1), 0, JTE(1), 1 )
         END IF
         RETURN
      END IF
C
C     Compute the output of the linear part.
C     Workspace: need  2*NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1).
C     (2*NSMP*L locations are reserved for computing two times the
C     output of the linear part.)
C
      IY = 1
      Z  = IY + NSML
      AC = Z  + NSML
      BD = AC + LDAC*N
      IX = BD + LDAC*M
      JW = IX + N
C
      CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC,
     $             DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N),
     $             LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO )
C
C     Workspace: need   2*NSMP*L + (N + L)*(N + M) + 3*N + M + L,
C                                                             if M > 0;
C                       2*NSMP*L + (N + L)*N + 2*N + L,       if M = 0;
C                prefer larger.
C
      CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX),
     $             DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO )
C
C     Fill the blocks dy(i)/dwb(i) and the corresponding parts of JTE,
C     if needed.
C
      JW = AC
      IF ( WJTE ) THEN
C
         DO 10 I = 0, L - 1
            CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1),
     $                   BSN, DWORK(Z), NSMP, E(I*NSMP+1),
     $                   J(I*NSMP+1,1), LDJ, JTE(I*BSN+1), DWORK(JW),
     $                   LDWORK-JW+1, INFO )
   10    CONTINUE
C
      ELSE
C
         DO 20 I = 0, L - 1
            CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1),
     $                   BSN, DWORK(Z), NSMP, DWORK, J(I*NSMP+1,1), LDJ,
     $                   DWORK, DWORK(JW), LDWORK-JW+1, INFO )
   20    CONTINUE
C
      END IF
C
C     Compute the output of the system with unchanged parameters.
C     Workspace: need   2*NSMP*L + 2*NN;
C                prefer larger.
C
      CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z),
     $             NSMP, DWORK(IY), NSMP, DWORK(JW), LDWORK-JW+1,
     $             INFO )
C
C     Compute dy/dtheta numerically by forward-difference approximation.
C     Workspace: need   2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N +
C                                       MAX( N*(N + L), N + M + L ) ),
C                                                              if M > 0;
C                       2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N +
C                                       MAX( N*(N + L), L ) ), if M = 0;
C                prefer larger.
C
      JW  = Z
      EPS = SQRT( MAX( EPSFCN, DLAMCH( 'Epsilon' ) ) )
C
      DO 40 K = NTHS + 1, LPAR
         KCOL   = K - NTHS + BSN
         PARSAV = X(K)
         IF ( PARSAV.EQ.ZERO ) THEN
            H = EPS
         ELSE
            H = EPS*ABS( PARSAV )
         END IF
         X(K) = X(K) + H
         CALL NF01AD( NSMP, M, L, IPAR, LIPAR, X, LPAR, U, LDU,
     $                J(1,KCOL), NSMP, DWORK(JW), LDWORK-JW+1,
     $                INFO )
         X(K) = PARSAV
C
         DO 30 I = 1, NSML
            J(I,KCOL) = ( J(I,KCOL) - DWORK(I) ) / H
   30    CONTINUE
C
   40 CONTINUE
C
      IF ( WJTE ) THEN
C
C        Compute the last part of J'e in JTE.
C
         CALL DGEMV( 'Transpose', NSML, LTHS, ONE, J(1,BSN+1), LDJ, E,
     $               1, ZERO, JTE(NTHS+1), 1 )
      END IF
C
      RETURN
C
C *** Last line of NF01BD ***
      END


c###prbmuf.for
      FUNCTION PRBMUF(FMHZ,FGO,FSET,IL)
C--------------------------------
C
C     THIS ROUTINE IS THE STANDARD PROBABILITY EVALUATION FOR THE
C     PROGRAM. THE DISTRIBUTIONS ARE SET IN SUBROUTINE CURMUF
C
C
C  EVALUATE THE PROBABILITY THAT THE OPERATING FREQUENCY IS GREATER
C THAN THE FOT, MUF OR HPF FOR A GIVEN LAYER USING THE MUF DISTRIBUTIONS
C     PRBMUF = 1. - FNORML(Z)
C
C  FMHZ IS THE OPERATING FREQUENCY
C  FGO IS THE MUF AT A SET ANGLE FOR A PARTICULAR LAYER, FOR ONE HOP
C      (IT MAY NOT BE THE CIRCUIT MUF)
C  FSET IS WHERE MEDIAN OF DISTRIBUTION IS PLACED (=FOT, MUF OR HPF)
C  IL IS LAYER (E, F1, F2 OR ES)
C  SIGL(IL) IS THE LOWER DECILE
C  SIGU(IL) IS THE UPPER DECILE
C
      COMMON / MUFS / EMUF(24),F1MUF(24),F2MUF(24),ESMUF(24),ALLMUF(24),
     A FOT(24),XLUF(24),HPF(24),ANGMUF(24),MODMUF,SIGL(4),SIGU(4),
     B DELMUF(4),HPMUF(4),HTMUF(4),FVMUF(4),AFMUF(4),NHOPMF(4),YFOT(4),
     C YHPF(4),YMUF(4)
C
      DIMENSION C(4)
      DATA C/.196854, .115194, .000344, .019527/
C
      Z = FMHZ - FGO
      IF(FSET.gt.0.) go to 95
      IF(Z.le.0.) then
         QX = 1.
      else
         QX = 0.0
      end if
      GO TO 145
   95 IF(Z.le.0.) then
         SIG = FGO * SIGL(IL) / FSET
      else
         SIG = FGO * SIGU(IL) / FSET
      end if
      SIG = AMAX1(SIG,0.001)
      Z = Z / SIG
C.....KEEP WITHIN 32 BIT WORD MACHINES
C.....NOTE PRBMUF = 1. - FNORML(Z)
      YP = Z
      YPX = Z
      IF(YPX.lt.0.) YP=-YPX
      YP = AMIN1(5.0, YP)
      QX = 1. + YP * (C(1) + YP * (C(2) + YP* (C(3) + YP * C(4))))
      QX = QX * QX * QX * QX
      QX = 1. / QX
      QX = .5 * QX
      IF(YPX.lt.0.) then
         PX = QX
         QX = 1. - PX
      else
         PX = 1. - QX
      end if
  145 PRBMUF = QX
      RETURN
      END
CC*****************************************************************


        subroutine intcrv( npts, nsd, s, b, t, sint, r, dr, mpts )

        implicit real*8 (a-h,o-z)
        dimension s(mpts), b(mpts,nsd), t(mpts,nsd), r(nsd), dr(nsd)

        klo = 1
        khi = npts
 10     if ( khi-klo .gt. 1 ) then
          k = (khi+klo)/2
          if (s(k) .gt. sint) then
            khi=k
          else
            klo=k
          end if
          goto 10
        end if

        u  = (sint - s(klo))

        ub = (s(khi) - s(klo))

        do j = 1, nsd
          ba = b(klo,j)
          bb = b(khi,j)
          ta = t(klo,j)
          tb = t(khi,j)

          c1 = -(2.0*ub*(bb-ta*ub-ba) - ub**2*(tb-ta))/ub**4

          c2 = -(ub**3*(tb-ta) - 3.0*ub**2*(bb-ta*ub-ba))/ub**4

          r(j)  = c1 * u**3 + c2 * u**2 + u*ta + ba
          dr(j) = 3.0 * c1 * u**2 + 2.0 * c2 * u + ta
        end do

        return
        end


      double complex function qlI2fin(p1sq,m0s,m1s,musq)
C---- Implementation of the formulae of Denner and Dittmaier
C----%\cite{Denner:2005nn}
C----\bibitem{Denner:2005nn}
C----  A.~Denner and S.~Dittmaier,
C----  %``Reduction schemes for one-loop tensor integrals,''
C----  Nucl.\ Phys.\  B {\bf 734}, 62 (2006)
C----  [arXiv:hep-ph/0509141].
C----  %%CITATION = NUPHA,B734,62;%%
      implicit none
      include 'qlconstants.f'
      double precision p1sq,m0s,m1s,m0sq,m1sq,musq
      double complex xp,xm,b,rt,arg,arg1,qlfndd,cln
      logical qlzero

      m0sq=min(m0s,m1s)
      m1sq=max(m0s,m1s)

      if ((qlzero(abs(p1sq/musq)))
     . .and. (qlzero(abs(m0sq/musq)))
     . .and. (qlzero(abs(m1sq/musq)))) then
      write(6,*) 'setting psq=m0sq=m1sq=0  self-energy to zero'
      write(6,*) 'p1sq,m0sq,m1sq=',p1sq,m0sq,m1sq
      qlI2fin=czip
      return

      elseif (qlzero(m0sq/musq)) then
      arg=dcmplx(1d0-m1sq/p1sq)
      arg1=dcmplx((m1sq-p1sq)/musq)

C---deal with special cases for m0sq=0
C----- (a,0,a)  p1sq=m1sq, DD(4.13)
      if (qlzero(abs(arg1))) then
      qlI2fin=dcmplx(log(musq/m1sq))+ctwo
C----- (0,0,a)
      elseif (qlzero(abs(p1sq/musq))) then
      qlI2fin=dcmplx(log(musq/m1sq))+cone
C----- (a,0,0)
      elseif (qlzero(abs(m1sq/musq))) then
      qlI2fin=-cln(arg1,-1d0)+ctwo
      else
C----- (a,0,c)
      qlI2fin=-cln(arg1,-1d0)+cone-qlfndd(0,arg,1d0)
      endif
      return
      elseif (qlzero(abs(p1sq/musq))) then
C---deal with special case, p1sq=0
      if (qlzero(abs((m1sq-m0sq)/musq))) then    ! (m1sq = m0sq)
      qlI2fin=dcmplx(log(musq/m0sq))
      else
      xp=dcmplx(m0sq/(m0sq-m1sq))  ! other root is formally infinite
      qlI2fin=dcmplx(log(musq/m0sq))-qlfndd(0,xp,1d0)
      endif
      else
C----general case, DD (4.8)
      b=dcmplx(m1sq-m0sq-p1sq)
      rt=sqrt(dcmplx((m1sq-m0sq-p1sq)**2-4d0*p1sq*m0sq))
      xp=0.5d0*(-b+rt)/p1sq
      xm=0.5d0*(-b-rt)/p1sq

      qlI2fin=dcmplx(log(musq/m0sq))-qlfndd(0,xp,1d0)-qlfndd(0,xm,-1d0)

      endif
      return

      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! DESCRIPTION:                                                       !
! MCMA simulation of the 1D Ising Model. Computes <E>, <M>, C (heat  !
! capacity), and X (magnetic susceptibility). Note: b=1, and Kb=1    !
!                                                                    !
! AUTHOR INFO:                                                       !
! Author: Michael Conroy                                             !
! Email: sietekk@gmail.com                                           !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program isingparamagnet
implicit none

!DECLARE VARIABLES
integer, dimension(12) :: seed !Seed variable for the random number generator
integer :: s
integer :: N !Number of sites/spins
integer :: Nequil !Number of equlibrium phase steps
integer :: Nmeasure !Number of measurement phase steps
INTEGER :: Nskip !Number of skip sweeps between measurements
integer :: tempstep !Number of iterations to run MCMA
integer :: anglestep !Number of divisions of angle
real :: Tmax, Tmin !Temp values
real :: gamma !Angle changein rads; adjustable to so the Metropolis acceptance rate is about 50%
INTEGER :: sweep, Nskipcount, Nmeasurecount, tempcount, Nequilcount
integer :: t !Counter
real :: dT !Interval change in temperature
real :: beta !Beta value; 1/T
real :: d_theta !Interval change in angle
integer :: thetacount !Counter
real, parameter :: pi = 3.141592653589793239
real :: new_spin_angle, current_spin_angle !Spin values to calculate change in energy
INTEGER :: currentspin !index to identify spin in lattice(:)
real :: energy, magnetization
real :: deltaH
real :: sinF
real :: accept = 0., reject = 0.
integer :: runs = 0 !Acceptance ratio
integer :: ecount, mcount
real, allocatable :: Tarray(:) !Temp values across 'tempstep' intervals
real, allocatable :: lattice(:), coslattice(:) !Spin configuration and cos value array
real, allocatable :: EnergyArray(:,:,:) !For each T(n), holds Energies (n,1,:) and Energies^2 (n,2,:)
real, allocatable :: MagArray(:,:,:) !For each T(n), holds Magnetizations (n,1,:) and Magnetizations^2 (n,2,:)
real, allocatable :: DataArray(:,:) !T (n,1), <E>/N (n,2), <M>/N (n,3), C(n,4), X (n,5)
real, allocatable :: AngleArray(:) !Angle values across 'anglestep' intervals
real, allocatable :: AcceptArray(:) !Holds acceptance ratio of each run

!I/O DATA ENTRY
!Pulls input data from external text file in same directory as executable
open (unit=1, file='input.dat', status='old', action='read')
read(1, *), N, Nequil, Nmeasure, Nskip, Tmin, Tmax, tempstep, anglestep, gamma
close(1)

ALLOCATE(Tarray(tempstep),lattice(N),coslattice(N),EnergyArray(tempstep,2,Nmeasure),&
        MagArray(tempstep,2,Nmeasure),DataArray(tempstep,11), &
        AngleArray(0:anglestep),AcceptArray(Nskip*Nmeasure*N))

!SEED RANDOM NUMBER GENERATOR
!Pull from same pseudo-random number pool each time program is run
seed = (/(12345678, s=1,12)/) !Seed var must be 1x12; given 12345678 for each value
call random_seed(put = seed) !Seed the random number generator

!CONSTRUCT TEMPERATURE ARRAY
dT = (Tmax - Tmin)/(tempstep)
Tarray(:) = (/( Tmax-(t*dT), t=1,tempstep )/) !Populate temperature array

!CONSTRUCT ANGLE ARRAY
d_theta = pi/anglestep
AngleArray(:) = (/( thetacount*d_theta, thetacount=1,anglestep )/)!Populate angle array

!SPIN CONFIGURATION
CALL spin_configuration

!MC ALGORITHM
do tempcount=1,tempstep !Loop through each temperature in Tarray, which also is total # runs for MCMA
    !CALCULATE BETA
    beta = 1. / Tarray(tempcount)

    !EQUILIBRATION PHASE
    DO Nequilcount=1,Nequil
        DO sweep=1,N
            CALL spin_update
            !print *,'Equil phase:',Nequilcount,sweep, runs
        END DO
    END DO

    !MEASUREMENT PHASE
    DO Nmeasurecount=1,Nmeasure
        runs = runs + 1
        DO Nskipcount=1,Nskip
            runs = runs + 1
            DO sweep=1,N
                CALL spin_update
                runs = runs + 1
                !print*,'runs',runs
                !Calculate and Print Acceptance Ratio
                !AcceptArray(runs) = accept/(accept+reject)

                !print*,'Acceptances: ', accept,'Rejections: ',reject
                !print *,'Meas phase:',Nmeasurecount,Nskipcount,sweep, runs
            END DO
        END DO

        !MEASUREMENT
        DO ecount=1,N
             coslattice(ecount) = COS(lattice(ecount))
        END DO
        energy = -(sum(coslattice(:)))
        !print *,'Energy: ',energy
        EnergyArray(tempcount,1,Nmeasurecount) = energy !Stores MCMA energy for a temperature
        EnergyArray(tempcount,2,Nmeasurecount) = energy**2 !Stores the square of that energy (for calculating Cv)
        magnetization = abs(sum(coslattice(:)))
        !print *,'magnetization: ',magnetization
        MagArray(tempcount,1,Nmeasurecount) = magnetization
        MagArray(tempcount,2,Nmeasurecount) = magnetization**2

    END DO

    !print*,'Run: ',tempcount

    !AVERAGES OF OBSERVABLES
    !Temperature
    DataArray(tempcount,1) = Tarray(tempcount)
    !print*,DataArray(tempcount,1),Tarray(tempcount)
    !<E>
    DataArray(tempcount,2) = sum( EnergyArray(tempcount,1,:) ) / Nmeasure
    !print*,DataArray(tempcount,2), sum( EnergyArray(tempcount,1,:) ) / Nmeasure
    !<E^2>
    DataArray(tempcount,3) = sum( EnergyArray(tempcount,2,:) ) / Nmeasure
    !print*,DataArray(tempcount,3), sum( EnergyArray(tempcount,2,:) ) / Nmeasure
    !<E>^2
    DataArray(tempcount,4) = (DataArray(tempcount,2))**2
    !print*, DataArray(tempcount,4), (DataArray(tempcount,1))**2
    !<M>
    DataArray(tempcount,5) = sum( MagArray(tempcount,1,:) ) / Nmeasure
    !print*,DataArray(tempcount,5),sum( MagArray(tempcount,1,:) ) / Nmeasure
    !<M^2>
    DataArray(tempcount,6) = sum( MagArray(tempcount,2,:) ) / Nmeasure
    !print*,DataArray(tempcount,6),sum( MagArray(tempcount,2,:) ) / Nmeasure
    !<M>^2
    DataArray(tempcount,7) = (DataArray(tempcount,5))**2
    !print*,DataArray(tempcount,7),(DataArray(tempcount,5))**2
    !C
    DataArray(tempcount,8) = (DataArray(tempcount,3) - DataArray(tempcount,4)) /(N * Tarray(tempcount)**2)
    !print*,DataArray(tempcount,8), (beta**2 / N) * (DataArray(tempcount,3) - DataArray(tempcount,4))
    !X
    DataArray(tempcount,9) = (beta / N) * (DataArray(tempcount,6) - DataArray(tempcount,7))
    !print*,DataArray(tempcount,9), (beta / N) * (DataArray(tempcount,6) - DataArray(tempcount,7))
    !<E>/N
    DataArray(tempcount,10) = DataArray(tempcount,2) / N
    !print*,DataArray(tempcount,10),DataArray(tempcount,2) / N
    !<M>/N
    DataArray(tempcount,11) = DataArray(tempcount,5) / N
    !print*,DataArray(tempcount,11), DataArray(tempcount,5) / N

!END MC ALGORITHM
END DO

CALL save_data
print*,'runs ', runs
!print*,'accept ratio ', sum(AcceptArray(:))/size(AngleArray)
print*,'Acceptance Ratio: ',accept/(accept+reject)

CONTAINS
!------------------------------------------------------------------------!
    SUBROUTINE spin_configuration
    INTEGER :: count, spincount
    REAL :: randomangle, rand, scaled
    DO spincount=1,N !Loop through lattice
        CALL random_number(rand)
        scaled = rand * anglestep !Scales to number of sites
        DO count=1,(anglestep+1) !Picks spin corresponding to scaled random number
            IF (scaled>=(count-1) .AND. scaled<count) THEN
                randomangle = AngleArray((count-1))
            !ELSE
            !	print *,'scaled, count, randomangle: ',scaled, count, randomangle
            !    STOP 'ERROR: spin_configuration randomangle generation.'
            END IF
        END DO
        lattice(spincount) = randomangle
    END DO
    END SUBROUTINE spin_configuration
!------------------------------------------------------------------------!
    SUBROUTINE spin_update
    REAL :: rand, compare, new_theta
    !Current spin identification and angle
    currentspin = randomspin(N)
    current_spin_angle = lattice(currentspin)

    !Propose change in spin angle
    CALL random_number(rand)
    new_theta = (rand-0.5)*gamma + current_spin_angle
    !print*,'new_theta: ',new_theta

    !Test if theta is in bounds: 0<=theta<=pi
     IF (new_theta <= pi .AND. new_theta >= 0.) THEN !Add temp, if addition is less than pi
        new_spin_angle = new_theta
    	!print*,'< pi: ', new_spin_angle
    ELSE IF (new_theta > pi .AND. new_theta < 2.0*pi) THEN !Subtract temp, if adding is greater than pi
         new_spin_angle = 2.0*pi - new_theta
    	!print*,'> pi: ', new_spin_angle
    ELSE IF (new_theta < 0. .AND. new_theta > -pi) THEN
        new_spin_angle = ABS(new_theta)
    ELSE
        STOP 'Theta bounding test failed!'
    END IF

    !Change in energy
    deltaH =  -(COS(new_spin_angle) - COS(current_spin_angle))

    !Spin angle acceptance/rejections
    CALL random_number(rand)
    sinF = SIN(new_spin_angle)/SIN(current_spin_angle)
    compare = sinF * exp(-(beta * deltaH))
    IF (rand <= compare) THEN !Accept
         lattice(currentspin) = new_spin_angle
         accept = accept + 1.
    ELSE
        reject = reject + 1.
    END IF
    END SUBROUTINE spin_update
!------------------------------------------------------------------------!
    SUBROUTINE save_data
    INTEGER :: i,j,k,l,m,n
    !<E>-------------------------------------------------------------
    OPEN(unit=99,file='e_average.dat',status='replace')
        DO i=1,tempstep
            WRITE(99,*) DataArray(i,1), ' ', DataArray(i,2)
        END DO
    CLOSE(unit=99)
    PRINT *, '<E> data has been saved!'
    !<M>-------------------------------------------------------------
    OPEN(unit=99,file='m_average.dat',status='replace')
        DO j=1,tempstep
            WRITE(99,*) DataArray(j,1), ' ', DataArray(j,5)
        END DO
    CLOSE(unit=99)
    PRINT *, '<M> data has been saved!'
    !Specific Heat-----------------------------------------------------
    OPEN(unit=99,file='specificheat.dat',status='replace')
        DO k=1,tempstep
            WRITE(99,*) DataArray(k,1), ' ', DataArray(k,8)
        END DO
    CLOSE(unit=99)
    PRINT *, 'Specific heat data has been saved!'
    !Magnetization-----------------------------------------------------
    OPEN(unit=99,file='magnetization.dat',status='replace')
        DO l=1,tempstep
            WRITE(99,*) DataArray(l,1), ' ', DataArray(l,9)
        END DO
    CLOSE(unit=99)
    PRINT *, 'Magnetization data has been saved!'
    !<E>/N-------------------------------------------------------------
    OPEN(unit=99,file='e_avg_per_site.dat',status='replace')
        DO m=1,tempstep
            WRITE(99,*) DataArray(m,1), ' ', DataArray(m,10)
        END DO
    CLOSE(unit=99)
    PRINT *, '<E>/N data has been saved!'
    !<M>/N-------------------------------------------------------------
    OPEN(unit=99,file='m_avg_per_site.dat',status='replace')
        DO n=1,tempstep
            WRITE(99,*) DataArray(n,1), ' ', DataArray(n,11)
        END DO
    CLOSE(unit=99)
    PRINT *, '<M>/N data has been saved!'
    END SUBROUTINE save_data
!------------------------------------------------------------------------!
    FUNCTION randomspin(N)
    INTEGER :: N, count, randomspin
    REAL :: rand, scaled
    CALL random_number(rand)
    scaled = rand * N !Scales to number of sites
    DO count=1,(N+1) !Picks spin corresponding to scaled random number
        IF (scaled>=(count-1) .AND. scaled<count) randomspin = count
    END DO
    END FUNCTION randomspin
!------------------------------------------------------------------------!

!DEALLOCATE(Tarray)
!DEALLOCATE(lattice)
!DEALLOCATE(EnergyArray)
!DEALLOCATE(MagArray)
!DEALLOCATE(DataArray)

!END OF PROGRAM
end program isingparamagnet


      subroutine polar(iseed,
     &                 sector_radius,
     &                 solar_galactocentric_distance,
     &                 scale_length)
C     solar_galactocentric_distance: galactocentric distance of the Sun
      implicit none

      external ran
      real :: ran

C     TODO: this is numberOfStars, take it up as const for all functions
      integer, parameter ::  MAX_STARS_COUNT = 6000000
      real, parameter :: PI = 4.0 * atan(1.0),
     &                   TAU = 2.0 * PI,
     &                   ALPHA_CENTAURI_DISTANCE = 1.5e-6,
C                        Value from "Simulating Gaia performances on
C                        white dwarfs" by Torres et al. 2005
     &                   HALO_CORE_RADIUS = 5.0

      integer :: numberOfWDs,
     &           iseed,
     &           wd_index
      real :: minimum_sector_radius,
     &        maximum_sector_radius,
     &        angle_covering_sector,
     &        sector_radius,
     &        scale_length,
     &        squared_sector_radius,
     &        dist,
     &        squared_minimum_sector_radius,
     &        squared_maximum_sector_radius,
     &        radius_try,
     &        radius_try_distrib,
     &        radial_distrib_random,
     &        random_value,
     &        xc,
     &        yc,
     &        squared_radii_difference,
     &        sector_diameter,
     &        radial_distrib_max,
     &        min_atan,
     &        max_atan,
     &        random_angle
      double precision :: solar_galactocentric_distance

      double precision :: coordinate_R(MAX_STARS_COUNT),
     &                    coordinate_Theta(MAX_STARS_COUNT),
     &                    coordinate_Zcylindr(MAX_STARS_COUNT)
      real :: x(MAX_STARS_COUNT),
     &        y(MAX_STARS_COUNT)
      integer :: disk_belonging(MAX_STARS_COUNT),
     &           flagOfWD(MAX_STARS_COUNT)

      common /coorcil/ coordinate_R,
     &                 coordinate_Theta,
     &                 coordinate_Zcylindr
C     TODO: find out what reference frame is used for x, y
      common /plano/ x, y
      common /index/ flagOfWD,
     &               numberOfWDs,
     &               disk_belonging

      squared_sector_radius = sector_radius * sector_radius
      minimum_sector_radius = real(solar_galactocentric_distance)
     &                        - sector_radius
      maximum_sector_radius = real(solar_galactocentric_distance)
     &                        + sector_radius
      sector_diameter = maximum_sector_radius - minimum_sector_radius
      squared_maximum_sector_radius = maximum_sector_radius
     &                                * maximum_sector_radius
      squared_minimum_sector_radius = minimum_sector_radius
     &                                * minimum_sector_radius
      squared_radii_difference = squared_maximum_sector_radius
     &                           - squared_minimum_sector_radius
      angle_covering_sector = 2. * asin(
     &    sector_radius / real(solar_galactocentric_distance))
      radial_distrib_max = exp(-minimum_sector_radius / scale_length)

      do wd_index = 1, numberOfWDs
          do
              coordinate_Theta(wd_index) = (
     &            angle_covering_sector * ran(iseed)
     &            - angle_covering_sector / 2)

              if (coordinate_Theta(wd_index) < 0.0) then
                  coordinate_Theta(wd_index) = (
     &                coordinate_Theta(wd_index) + TAU)
              end if

              if (disk_belonging(wd_index) == 3) then
C                 Inverse transform sampling for halo distribution.
C                 See (4) at "Simulating Gaia performances on white
C                 dwarfs" by Torres et al. 2005
                  min_atan = atan(minimum_sector_radius
     &                            / HALO_CORE_RADIUS)
                  max_atan = atan(maximum_sector_radius
     &                            / HALO_CORE_RADIUS)
                  radius_try = HALO_CORE_RADIUS * tan(
     &                min_atan + ran(iseed) * (max_atan - min_atan))
              else
C                 Accepting-rejecting method
                  do
                      radius_try = minimum_sector_radius
     &                             + sector_diameter * ran(iseed)
                      radius_try_distrib = exp(-radius_try
     &                                         / scale_length)
                      radial_distrib_random = radial_distrib_max
     &                                        * ran(iseed)
                      if (radial_distrib_random
     &                        <= radius_try_distrib) then
                          exit
                      end if
                  end do
              end if

C             Inverse transform sampling method for generating stars
C             uniformly in a circle sector in polar coordinates
              random_value = (radius_try - minimum_sector_radius)
     &                       / sector_diameter
              coordinate_R(wd_index) = sqrt(
     &            squared_minimum_sector_radius
     &            + squared_radii_difference * random_value)

              if (disk_belonging(wd_index) == 3) then
                  random_angle = (angle_covering_sector * ran(iseed)
     &                            - angle_covering_sector / 2)
                  coordinate_Zcylindr(wd_index) = (
     &                coordinate_R(wd_index) * sin(random_angle))
              end if

              xc = real(coordinate_R(wd_index)
     &                  * cos(coordinate_Theta(wd_index)))
              yc = real(coordinate_R(wd_index)
     &                  * sin(coordinate_Theta(wd_index)))
C             TODO: find out the meanng of dist
              dist = real((xc - solar_galactocentric_distance)
     &                    * (xc - solar_galactocentric_distance)
     &                    + yc * yc)

              if (dist <= squared_sector_radius
     &                .and. dist >= ALPHA_CENTAURI_DISTANCE) then
                  exit
              end if
          end do

C         TODO: find out the meanng of x and y
          x(wd_index) = xc
          y(wd_index) = yc
      end do
      end subroutine


      DOUBLE PRECISION FUNCTION slARMS (ZD)
*+
*     - - - - - - -
*      A R M S
*     - - - - - - -
*
*  Air mass at given zenith distance (double precision)
*
*  Given:
*     ZD     d     Observed zenith distance (radians)
*
*  The result is an estimate of the air mass, in units of that
*  at the zenith.
*
*  Notes:
*
*  1)  The "observed" zenith distance referred to above means "as
*      affected by refraction".
*
*  2)  Uses Hardie's (1962) polynomial fit to Bemporad's data for
*      the relative air mass, X, in units of thickness at the zenith
*      as tabulated by Schoenberg (1929). This is adequate for all
*      normal needs as it is accurate to better than 0.1% up to X =
*      6.8 and better than 1% up to X = 10. Bemporad's tabulated
*      values are unlikely to be trustworthy to such accuracy
*      because of variations in density, pressure and other
*      conditions in the atmosphere from those assumed in his work.
*
*  3)  The sign of the ZD is ignored.
*
*  4)  At zenith distances greater than about ZD = 87 degrees the
*      air mass is held constant to avoid arithmetic overflows.
*
*  References:
*     Hardie, R.H., 1962, in "Astronomical Techniques"
*        ed. W.A. Hiltner, University of Chicago Press, p180.
*     Schoenberg, E., 1929, Hdb. d. Ap.,
*        Berlin, Julius Springer, 2, 268.
*
*  Original code by P.W.Hill, St Andrews
*
*  P.T.Wallace   Starlink   18 March 1999
*
*  Copyright (C) 1999 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION ZD

      DOUBLE PRECISION SECZM1

      SECZM1 = 1D0/(COS(MIN(1.52D0,ABS(ZD))))-1D0
      slARMS = 1D0 + SECZM1*(0.9981833D0
     :             - SECZM1*(0.002875D0 + 0.0008083D0*SECZM1))

      END


!***********************************/
!	Name:Roeスキームによって中心差分の流束を計算するプログラム
!	Alias:GetGeneralFlux
!	Description:計算結果はRoe流束の第1項に相当する
!	Type:RoeAverage
!	Input:Geometory,RoeAverage
!	Output:RoeAverage
!	Note:
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2017.11.09
!	Other:1次元と2次元に対応
!***********************************/
subroutine GetGeneralFlux(Geom,RA)
    use StructVar_Mod
    use ConstantVar_Mod, Gamma => SpecificOfHeatRatio, Epsilon => EntropyCorrection
    implicit none
    type(Geometry), intent(in) :: Geom
    type(RoeAverage), intent(inout) :: RA

        if(Geom%Dimension == 1) then !次元1のとき
            RA%GeneralFlux(1,1,:) = RA%SideQuantity(2,:)

            RA%GeneralFlux(2,1,:) = RA%SideQuantity(2,:)**2/RA%SideQuantity(1,:) &
                &   + Gmin1*(RA%SideQuantity(3,:)-0.5d0*RA%SideQuantity(2,:)**2/RA%SideQuantity(1,:))

            RA%GeneralFlux(3,1,:) = RA%SideQuantity(2,:)/RA%SideQuantity(1,:) &
                &   * (Gamma*RA%SideQuantity(3,:)-0.5d0*Gmin1*RA%SideQuantity(2,:)**2/RA%SideQuantity(1,:))

        else if(Geom%Dimension == 2) then !次元2のとき
            if(RA%Direction == 1) then !x方向流束
                RA%GeneralFlux(1,1,:) = RA%SideQuantity(2,:)

                RA%GeneralFlux(2,1,:) = RA%SideQuantity(2,:)**2/RA%SideQuantity(1,:) &
                    &   + Gmin1*(RA%SideQuantity(4,:) &
                    &   - 0.5d0*(RA%SideQuantity(2,:)**2 + RA%SideQuantity(3,:)**2)/RA%SideQuantity(1,:))

                RA%GeneralFlux(3,1,:) = RA%SideQuantity(2,:)*RA%SideQuantity(3,:)/RA%SideQuantity(1,:)

                RA%GeneralFlux(4,1,:) = RA%SideQuantity(2,:)/RA%SideQuantity(1,:) &
                    &   * (Gamma*RA%SideQuantity(4,:) &
                    &   - 0.5d0*Gmin1*(RA%SideQuantity(2,:)**2 + RA%SideQuantity(3,:)**2)/RA%SideQuantity(1,:))

            else if(RA%Direction == 2) then !y方向流束
                RA%GeneralFlux(1,1,:) = RA%SideQuantity(3,:)

                RA%GeneralFlux(2,1,:) = RA%SideQuantity(2,:)*RA%SideQuantity(3,:)/RA%SideQuantity(1,:)

                RA%GeneralFlux(3,1,:) = RA%SideQuantity(3,:)**2/RA%SideQuantity(1,:) &
                    &   + Gmin1*(RA%SideQuantity(4,:) &
                    &   - 0.5d0*(RA%SideQuantity(2,:)**2 + RA%SideQuantity(3,:)**2)/RA%SideQuantity(1,:))

                RA%GeneralFlux(4,1,:) = RA%SideQuantity(3,:)/RA%SideQuantity(1,:) &
                    &   * (Gamma*RA%SideQuantity(4,:) &
                    &   - 0.5d0*Gmin1*(RA%SideQuantity(2,:)**2 + RA%SideQuantity(3,:)**2)/RA%SideQuantity(1,:))
            end if
        !else if(Geom%Dimension == 3) then !次元3のとき
        end if

    return
end subroutine GetGeneralFlux


C*****************************************************************
C
C     Subroutine FFTT
C
C     Purpose:  To compute 1-D ffts using RFT2CH instead of
C     FFTT.   It will accept and return the assumed formats.
C     MD comes in with  -1 = direct  +1 = inverse.
C
C        1 JULY 1993   PORTED TO UNIX  (T. L. TRUONG)
C        9-88  SP      MODIFIED BECAUSE DIV HAS BEEN RENAMED TO DIVV.
C*****************************************************************
C
	SUBROUTINE FFTT(IPOW,MD,COM)
	REAL*4 BUF(1026),COM(2050)
C
C ...Where    IPOW is the input size = 2**power elements
C             MD   is +1 for inverse transform
C                     -1 for direct transform
C             COM  is a complex*8 data array
C             BUF  is a buffer containing data to be processed
C
        M=1
	N= 2**IPOW
	MODE = -MD          !CHANGE TO -1 = INVERSE
	IF(MODE .EQ. -1) GO TO 10
C
C------------------------------------
C    FORWARD
C------------------------------------
	CALL MVE(7,N,COM,BUF,2,1)    !STRIP REALS OUT OF COMPLEX
	CALL RFT2CH(BUF,M,N,MODE)    !RETURNED AS COMPLEX
        CALL MVE(7,N+2,buf,com,1,1)
        RETURN
C
C------------------------------------
C    INVERSE
C------------------------------------
10	CALL MVE(7,N+2,COM,BUF,1,1)
	CALL RFT2CH(BUF,M,N,MODE)    !PROCESS COMPLEX DATA
	CALL ZIA(COM,2*N)
	S = 2 * N                    !SCALING FACTOR
	CALL DIVV(7,N,S,BUF,0,1)      !GET VALUES TO PROPER SCALE
	CALL MVE(7,N,BUF,COM,1,2)    !STICK REALS INTO COMPLEX C
        RETURN
C
        END


*> \brief  ZGGLSE solves overdetermined or underdetermined systems for OTHER matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGGLSE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK,
*                          INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, LDB, LWORK, M, N, P
*       ..
*       .. Array Arguments ..
*       COMPLEX*16         A( LDA, * ), B( LDB, * ), C( * ), D( * ),
*      $                   WORK( * ), X( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZGGLSE solves the linear equality-constrained least squares (LSE)
*> problem:
*>
*>         minimize || c - A*x ||_2   subject to   B*x = d
*>
*> where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
*> M-vector, and d is a given P-vector. It is assumed that
*> P <= N <= M+P, and
*>
*>          rank(B) = P and  rank( (A) ) = N.
*>                               ( (B) )
*>
*> These conditions ensure that the LSE problem has a unique solution,
*> which is obtained using a generalized RQ factorization of the
*> matrices (B, A) given by
*>
*>    B = (0 R)*Q,   A = Z*T*Q.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*>          P is INTEGER
*>          The number of rows of the matrix B. 0 <= P <= N <= M+P.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          On entry, the M-by-N matrix A.
*>          On exit, the elements on and above the diagonal of the array
*>          contain the min(M,N)-by-N upper trapezoidal matrix T.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is COMPLEX*16 array, dimension (LDB,N)
*>          On entry, the P-by-N matrix B.
*>          On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
*>          contains the P-by-P upper triangular matrix R.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B. LDB >= max(1,P).
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*>          C is COMPLEX*16 array, dimension (M)
*>          On entry, C contains the right hand side vector for the
*>          least squares part of the LSE problem.
*>          On exit, the residual sum of squares for the solution
*>          is given by the sum of squares of elements N-P+1 to M of
*>          vector C.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*>          D is COMPLEX*16 array, dimension (P)
*>          On entry, D contains the right hand side vector for the
*>          constrained equation.
*>          On exit, D is destroyed.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is COMPLEX*16 array, dimension (N)
*>          On exit, X is the solution of the LSE problem.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK. LWORK >= max(1,M+N+P).
*>          For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
*>          where NB is an upper bound for the optimal blocksizes for
*>          ZGEQRF, CGERQF, ZUNMQR and CUNMRQ.
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit.
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*>          = 1:  the upper triangular factor R associated with B in the
*>                generalized RQ factorization of the pair (B, A) is
*>                singular, so that rank(B)
                solution could not be computed.
*>          = 2:  the (N-P) by (N-P) part of the upper trapezoidal factor
*>                T associated with A in the generalized RQ factorization
*>                of the pair (B, A) is singular, so that
*>                rank( (A) ) < N; the least squares solution could not
*>                    ( (B) )
*>                be computed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex16OTHERsolve
*
*  =====================================================================
      SUBROUTINE ZGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK,
     $                   INFO )
*
*  -- LAPACK driver routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, P
*     ..
*     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( * ), D( * ),
     $                   WORK( * ), X( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         CONE
      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            LOPT, LWKMIN, LWKOPT, MN, NB, NB1, NB2, NB3,
     $                   NB4, NR
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZGEMV, ZGGRQF, ZTRMV,
     $                   ZTRTRS, ZUNMQR, ZUNMRQ
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      MN = MIN( M, N )
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
         INFO = -7
      END IF
*
*     Calculate workspace
*
      IF( INFO.EQ.0) THEN
         IF( N.EQ.0 ) THEN
            LWKMIN = 1
            LWKOPT = 1
         ELSE
            NB1 = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
            NB2 = ILAENV( 1, 'ZGERQF', ' ', M, N, -1, -1 )
            NB3 = ILAENV( 1, 'ZUNMQR', ' ', M, N, P, -1 )
            NB4 = ILAENV( 1, 'ZUNMRQ', ' ', M, N, P, -1 )
            NB = MAX( NB1, NB2, NB3, NB4 )
            LWKMIN = M + N + P
            LWKOPT = P + MN + MAX( M, N )*NB
         END IF
         WORK( 1 ) = LWKOPT
*
         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
            INFO = -12
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGGLSE', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Compute the GRQ factorization of matrices B and A:
*
*            B*Q**H = (  0  T12 ) P   Z**H*A*Q**H = ( R11 R12 ) N-P
*                        N-P  P                     (  0  R22 ) M+P-N
*                                                      N-P  P
*
*     where T12 and R11 are upper triangular, and Q and Z are
*     unitary.
*
      CALL ZGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ),
     $             WORK( P+MN+1 ), LWORK-P-MN, INFO )
      LOPT = WORK( P+MN+1 )
*
*     Update c = Z**H *c = ( c1 ) N-P
*                       ( c2 ) M+P-N
*
      CALL ZUNMQR( 'Left', 'Conjugate Transpose', M, 1, MN, A, LDA,
     $             WORK( P+1 ), C, MAX( 1, M ), WORK( P+MN+1 ),
     $             LWORK-P-MN, INFO )
      LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) )
*
*     Solve T12*x2 = d for x2
*
      IF( P.GT.0 ) THEN
         CALL ZTRTRS( 'Upper', 'No transpose', 'Non-unit', P, 1,
     $                B( 1, N-P+1 ), LDB, D, P, INFO )
*
         IF( INFO.GT.0 ) THEN
            INFO = 1
            RETURN
         END IF
*
*        Put the solution in X
*
         CALL ZCOPY( P, D, 1, X( N-P+1 ), 1 )
*
*        Update c1
*
         CALL ZGEMV( 'No transpose', N-P, P, -CONE, A( 1, N-P+1 ), LDA,
     $               D, 1, CONE, C, 1 )
      END IF
*
*     Solve R11*x1 = c1 for x1
*
      IF( N.GT.P ) THEN
         CALL ZTRTRS( 'Upper', 'No transpose', 'Non-unit', N-P, 1,
     $                A, LDA, C, N-P, INFO )
*
         IF( INFO.GT.0 ) THEN
            INFO = 2
            RETURN
         END IF
*
*        Put the solutions in X
*
         CALL ZCOPY( N-P, C, 1, X, 1 )
      END IF
*
*     Compute the residual vector:
*
      IF( M.LT.N ) THEN
         NR = M + P - N
         IF( NR.GT.0 )
     $      CALL ZGEMV( 'No transpose', NR, N-M, -CONE, A( N-P+1, M+1 ),
     $                  LDA, D( NR+1 ), 1, CONE, C( N-P+1 ), 1 )
      ELSE
         NR = P
      END IF
      IF( NR.GT.0 ) THEN
         CALL ZTRMV( 'Upper', 'No transpose', 'Non unit', NR,
     $               A( N-P+1, N-P+1 ), LDA, D, 1 )
         CALL ZAXPY( NR, -CONE, D, 1, C( N-P+1 ), 1 )
      END IF
*
*     Backward transformation x = Q**H*x
*
      CALL ZUNMRQ( 'Left', 'Conjugate Transpose', N, 1, P, B, LDB,
     $             WORK( 1 ), X, N, WORK( P+MN+1 ), LWORK-P-MN, INFO )
      WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) )
*
      RETURN
*
*     End of ZGGLSE
*
      END


*
*     -------------------------------------------------------------
*      S I X J 3 5
*     -------------------------------------------------------------
*
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT         *
*                                                                  *
*     | J/2  K/2  L/2 |                                            *
*     | M/2  N/2  3/2 |             [B.M.X. 75]                    *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville             October 1996   *
*
*
      SUBROUTINE SIXJ35(J,K,L,M,N,ITIK,SI)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      SI=ZERO
      IF(ITIK.NE.0) THEN
C
C     CHESKED TRIANGULAR CONDITIONS
C
        IF(IXJTIK(J,K,L,M,N,3).EQ.0)RETURN
      ENDIF
      I1=(J+K+L)/2
      AS=DBLE(I1)
      A=DBLE(L)
      B=DBLE(J)
      C=DBLE(K)
      AKA=ONE
      IF(MOD(I1,2).NE.0)AKA=-AKA
      IF(J-N.EQ.3) THEN
* -3
        IF(K-M.EQ.3) THEN
C  I                      -3/2  -3/2
      SI=AKA*DSQRT((AS-ONE)*AS*(AS+ONE)*(AS-A-TWO)*(AS-A-ONE)*(AS-A)/
     :((B-TWO)*(B-ONE)*B*(B+ONE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
	ELSEIF(M-K.EQ.3) THEN
C  IV  P(12)              3/2   -3/2
      SI=AKA*DSQRT((AS-C-TWO)*(AS-C-ONE)*(AS-C)*(AS-B+ONE)*(AS-B+TWO)*
     :(AS-B+THREE)/
     :((C+1)*(C+TWO)*(C+THREE)*(C+FOUR)*(B-TWO)*(B-ONE)*B*(B+ONE)))
        ELSEIF(K-M.EQ.1) THEN
C  II  P(12)             -1/2   -3/2
      SI=AKA*DSQRT(THREE*AS*(AS+ONE)*(AS-A-ONE)*(AS-A)*(AS-C)*
     :(AS-B+ONE)/
     :((C-ONE)*C*(C+ONE)*(C+TWO)*(B-TWO)*(B-ONE)*B*(B+ONE)))
        ELSEIF(M-K.EQ.1) THEN
C  III P(12)              1/2   -3/2
      SI=AKA*DSQRT(THREE*(AS+ONE)*(AS-A)*(AS-C-ONE)*(AS-C)*
     :(AS-B+ONE)*(AS-B+TWO)/
     :(C*(C+ONE)*(C+TWO)*(C+THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)))
        ENDIF
      ELSEIF(N-J.EQ.3) THEN
*  3
        IF(K-M.EQ.3) THEN
C  IV                     -3/2   3/2
      SI=AKA*DSQRT((AS-B-TWO)*(AS-B-ONE)*(AS-B)*(AS-C+ONE)*(AS-C+TWO)*
     :(AS-C+THREE)/
     :((B+ONE)*(B+TWO)*(B+THREE)*(B+FOUR)*(C-TWO)*(C-ONE)*C*(C+ONE)))
	ELSEIF(M-K.EQ.3) THEN
C  2       pataisyta               3/2   3/2
      SI=-AKA*DSQRT((AS+TWO)*(AS+THREE)*(AS+FOUR)*(AS-A+ONE)*
     :(AS-A+TWO)*(AS-A+THREE)/
     :((B+ONE)*(B+TWO)*(B+THREE)*(B+FOUR)*(C+ONE)*(C+TWO)*(C+THREE)*
     :(C+FOUR)))
        ELSEIF(K-M.EQ.1) THEN
C  1   P(12)   pataisytas          -1/2    3/2
      SI=-AKA*DSQRT(THREE*(AS+TWO)*(AS-A+ONE)*(AS-C+ONE)*
     : (AS-C+TWO)*(AS-B-ONE)*(AS-B)/
     :((C-ONE)*C*(C+ONE)*(C+TWO)*(B+ONE)*(B+TWO)*(B+THREE)*(B+FOUR)))
        ELSEIF(M-K.EQ.1) THEN
C  3  P(12)     taisyta           1/2    3/2
      SI=AKA*DSQRT(THREE*(AS+TWO)*(AS+THREE)*(AS-A+ONE)*(AS-A+TWO)*
     :(AS-B)*(AS-C+ONE)/
     :(C*(C+ONE)*(C+TWO)*(C+THREE)*(B+ONE)*(B+TWO)*(B+THREE)*(B+FOUR)))
        ENDIF
* -1
      ELSEIF(J-N.EQ.1) THEN
        IF(K-M.EQ.3) THEN
C  II                   -3/2   -1/2
      SI=AKA*DSQRT((THREE*AS*(AS+ONE)*(AS-A-ONE)*(AS-A)*(AS-B)*
     :(AS-C+ONE))/
     :((B-ONE)*B*(B+ONE)*(B+TWO)*(C-TWO)*(C-ONE)*C*(C+ONE)))
        ELSEIF(M-K.EQ.3) THEN
C  1                     3/2   -1/2
      SI=-AKA*DSQRT(THREE*(AS+TWO)*(AS-A+ONE)*(AS-B+ONE)*
     : (AS-B+TWO)*(AS-C-ONE)*(AS-C)/
     :((B-ONE)*B*(B+ONE)*(B+TWO)*(C+ONE)*(C+TWO)*(C+THREE)*(C+FOUR)))
        ELSEIF(K-M.EQ.1) THEN
C  V                    -1/2   -1/2
      SI=AKA*(TWO*(AS-B)*(AS-C)-(AS+TWO)*(AS-A-ONE))*
     :DSQRT((AS+ONE)*(AS-A)/
     :((B-ONE)*B*(B+ONE)*(B+TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
        ELSEIF(M-K.EQ.1) THEN
C  VI P(12)              1/2   -1/2
      SI=AKA*((AS-B+TWO)*(AS-C+ONE)-TWO*(AS-A+ONE)*(AS+ONE))*
     :DSQRT((AS-C)*(AS-B+ONE)/
     :(C*(C+ONE)*(C+TWO)*(C+THREE)*(B-ONE)*B*(B+ONE)*(B+TWO)))
        ENDIF
* 1
      ELSEIF(N-J.EQ.1) THEN
        IF(K-M.EQ.3) THEN
C  III                  -3/2    1/2
      SI=AKA*DSQRT(THREE*(AS+ONE)*(AS-A)*(AS-B-ONE)*(AS-B)*(AS-C+ONE)*
     :(AS-C+TWO)/
     :(B*(B+ONE)*(B+TWO)*(B+THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
        ELSEIF(M-K.EQ.3) THEN
C  3              pataisyta       3/2    1/2
      SI=AKA*DSQRT(THREE*(AS+TWO)*(AS+THREE)*(AS-A+ONE)*(AS-A+TWO)*
     :(AS-B+ONE)*(AS-C)/
     :(B*(B+ONE)*(B+TWO)*(B+THREE)*(C+ONE)*(C+TWO)*(C+THREE)*(C+FOUR)))
        ELSEIF(K-M.EQ.1) THEN
C  VI                   -1/2    1/2
      SI=AKA*((AS-C+TWO)*(AS-B+ONE)-TWO*(AS-A+ONE)*(AS+ONE))*
     :DSQRT((AS-B)*(AS-C+ONE)/
     :(B*(B+ONE)*(B+TWO)*(B+THREE)*(C-ONE)*C*(C+ONE)*(C+TWO)))
        ELSEIF(M-K.EQ.1) THEN
C  4      pataisyta               1/2    1/2
      SI=-AKA*(TWO*(AS-B)*(AS-C)-(AS+THREE)*(AS-A))*
     :DSQRT((AS+TWO)*(AS-A+ONE)/
     :(B*(B+ONE)*(B+TWO)*(B+THREE)*C*(C+ONE)*(C+TWO)*(C+THREE)))
      ENDIF
      ENDIF
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine e_c3d_us3(co,kon,lakonl,p1,p2,omx,bodyfx,nbody,s,sm,
     &  ff,nelem,nmethod,elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,
     &  ielmat,ielorien,norien,orab,ntmat_,
     &  t0,t1,ithermal,vold,iperturb,nelemload,
     &  sideload,xload,nload,idist,sti,stx,iexpl,plicon,
     &  nplicon,plkcon,nplkcon,xstiff,npmat_,dtime,
     &  matname,mi,ncmat_,mass,stiffness,buckling,rhsi,intscheme,
     &  ttime,time,istep,iinc,coriolis,xloadold,reltime,
     &  ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,veold,
     &  ne0,ipkon,thicke,
     &  integerglob,doubleglob,tieset,istartset,iendset,ialset,ntie,
     &  nasym,ielprop,prop)
!
!     computation of the element matrix and rhs for the user element
!     of type u1
!
!     This is a beam type element. Reference:
!     Yunhua Luo, An Efficient 3D Timoshenko Beam Element with
!     Consistent Shape Functions, Adv. Theor. Appl. Mech., Vol. 1,
!     2008, no. 3, 95-106
!
!     special case for which the beam axis goes through the
!     center of gravity of the cross section and the 1-direction
!     corresponds with a principal axis
!
!
!     INPUT:
!
!     co(1..3,i)         coordinates of node i
!     kon(*)             contains the topology of all elements. The
!                        topology of element i starts at kon(ipkon(i)+1)
!                        and continues until all nodes are covered. The
!                        number of nodes depends on the element label
!     lakonl             label of current element nelem (character*8)
!     p1(1..3)           coordinates of a point on the rotation axis
!                        (if applicable)
!     p2(1..3)           unit vector on rotation axis (if applicable)
!     omx                rotational speed square
!     bodyfx(1..3)       acceleration vector
!     nbody              number of body loads
!     nelem              element number
!     nmethod            procedure:
!                        1: static analysis
!                        2: frequency analysis
!                        3: buckling analysis
!                        4: (linear or nonlinear) dynamic analysis
!                        5: steady state dynamics analysis
!                        6: Coriolis frequency calculation
!                        7: flutter frequency calculation
!                        8:  magnetostatics
!                        9:  magnetodynamics
!                        10: electromagnetic eigenvalue problems
!                        11: superelement creation or Green function
!                            calculation
!                        12: sensitivity analysis
!     elcon              elastic constants (cf. List of variables and
!                        their meaning in the User's Manual)
!     nelcon             integers describing the elastic constant fields
!                        (cf. User's Manual)
!     rhcon              density constants (cf. User's Manual)
!     nrhcon             integers describing the density constant fields
!                        (cf. User's Manual)
!     alcon              thermal expansion constants (cf. User's Manual)
!     nalcon             integers describing the thermal expansion
!                        constants (cf. User's Manual)
!     alzero             thermal expansion reference values (cf. User's Manual)
!     ielmat(i)          material for element i
!     ielorien(i)        orientation for element i
!     norien             number of orientations
!     orab(7,*)          description of all local coordinate systems.
!                        (cf. List of variables and their meaning in the
!                        User's manual)
!     ntmat_             maximum number of material temperature points
!     t0(i)              temperature in node i at start of calculation
!     t1(i)              temperature in node i at the end of the current
!                        increment
!     ithermal           cf. ithermal(1) in the List of variables and
!                        their meaning in the User's Manual
!     vold(0..mi(2),i)   value of the variables in node i at the end
!                        of the previous iteration
!     iperturb(*)        describes the kind of nonlinearity of the
!                        calculation, cf. User's Manual
!     nelemload          field describing facial distributed load (cf.
!                        User's Manual)
!     sideload           field describing facial distributed load (cf.
!                        User's Manual)
!     xload              facial distributed load values (cf.
!                        User's Manual)
!     nload              number of facial distributed loads
!     idist              0: no distributed forces in the model
!                        1: distributed forces are present in the model
!                        (body forces or thermal loads or residual
!                        stresses or distributed facial loads)
!     sti(i,j,k)         stress component i in integration point j
!                        of element k at the end of the previous step
!     stx(i,j,k)         stress component i in integration point j
!                        of element k at the end of a static step
!                        describing a reference buckling load
!     iexpl              0: structure: implicit dynamics,
!                           fluid: incompressible
!     iexpl              1: structure: implicit dynamics,
!                           fluid: compressible
!     iexpl              2: structure: explicit dynamics,
!                           fluid: incompressible
!     iexpl              3: structure: explicit dynamics,
!                           fluid: compressible
!     plicon,nplicon     fields describing isotropic hardening of
!                        a plastic material or spring constants of
!                        a nonlinear spring (cf. User's Manual)
!     plkcon,nplkcon     fields describing kinematic hardening of
!                        a plastic material or gap conductance
!                        constants (cf. User's Manual)
!     xstiff(i,j,k)      stiffness (i=1...21) and conductivity
!                        (i=22..27) constants in integration point j
!                        of element k
!     npmat_             maximum number of plastic constants
!     dtime              length of present time increment
!     matname(i)         name of material i
!     mi(1)              max # of integration points per element (max
!                        over all elements)
!     mi(2)              max degree of freedom per node (max over all
!                        nodes) in fields like v(0:mi(2))...
!     mi(3)              max number of layers in the structure
!     ncmat_             max number of elastic constants
!     mass(1)            if 1: mass matrix needed, else not
!     mass(2)            if 1: heat capacity matrix needed, else not
!     stiffness          if 1: stiffness matrix needed, else not
!     buckling           if 1: linear buckling calculation, else not
!     rhsi               if 1: right hand side needed, else not
!     intscheme          1: integration point scheme for the calculation
!                           of the initial acceleration in a dynamic
!                           step
!                        0: any other case
!     ttime              total time at the start of the present increment
!     time               step time at the end of the present increment
!     istep              current step number
!     iinc               current increment number within the actual step
!     coriolis           if 1: Coriolis forces are taken into account,
!                              else not
!     xloadold           load at the end of the previous increment
!                        (cf. User's Manual)
!     reltime            relative step time (between 0 and 1)
!     ipompc(i)          pointer into field nodempc and coefmpc for
!                        MPC i
!     nodempc            field containing the nodes and dof's of all
!                        MPC's (cf. User's Manual)
!     coefmpc            field containing the coefficients of all
!                        MPC's  (cf. User's Manual)
!     nmpc               number of MPC's in the model
!     ikmpc(i)           field containing an integer code number
!                        describing the dependent dof of some MPC:
!                        ikmpc(i)=8*(node-1)+dir, where the dependent
!                        dof is applied in direction dir of node "node"
!                        ikmpc is sorted in ascending order
!     ilmpc(i)           MPC number corresponding to ikmpc(i) (cf.
!                        User's manual)
!     veold(j,i)         time rate of variable j in node i at the end
!                        of the previous iteration
!     ne0                element number before the first contact element;
!                        contact elements are appended after ne0
!     ipkon(i)           points to the location in field kon preceding
!                        the topology of element i
!     thicke(j,i)        thickness of layer j in node i
!     integerglob        integer field needed for determining the
!                        interface loading of a submodel
!     doubleglob         real field needed for determining the
!                        interface loading of a submodel
!     tieset(1..3,*)     tie character information for tie i (cf.
!                        User's Manual)
!     istartset          integer describing set information (cf.
!                        User's Manual)
!     iendset            integer describing set information (cf.
!                        User's Manual)
!     ialset             integer describing set information (cf.
!                        User's Manual)
!     ntie               number of ties in the model
!     nasym              1: asymmetric contributions, else purely
!                        symmetric
!     ielprop(i)         points to the location in field prop preceding
!                        the properties of element i
!     prop(*)            contains the properties and some beam
!                        elements (cf. User's Manual)
!
!
!     OUTPUT:
!
!     s                  element stiffness matrix
!     sm                 element mass matrix
!     ff                 element load vector
!     xload              facial distributed load values (cf.
!                        User's Manual)
!     nmethod            may be changed by the user, e.g. a
!                        change to 0 for negative Jacobians leads
!                        to a program exit in the calling program
!                        for the other value: cf. above
!
      implicit none
!
      integer mass,stiffness,buckling,rhsi,coriolis
!
      character*8 lakonl
      character*20 sideload(*)
      character*80 matname(*),amat
      character*81 tieset(3,*)
!
      integer konl(26),nelemload(2,*),nbody,nelem,mi(*),kon(*),
     &  ielprop(*),index,mattyp,ithermal(*),iperturb(*),nload,idist,
     &  i,j,k,i1,nmethod,kk,nelcon(2,*),nrhcon(*),nalcon(2,*),
     &  ielmat(mi(3),*),ielorien(mi(3),*),ipkon(*),indexe,
     &  ntmat_,nope,norien,ihyper,iexpl,kode,imat,iorien,istiff,
     &  ncmat_,intscheme,istep,iinc,ipompc(*),nodempc(3,*),
     &  nmpc,ikmpc(*),ilmpc(*),ne0,ndof,istartset(*),iendset(*),
     &  ialset(*),ntie,integerglob(*),nasym,nplicon(0:ntmat_,*),
     &  nplkcon(0:ntmat_,*),npmat_,jjj,id,ig
!
      real*8 co(3,*),xl(3,26),veold(0:mi(2),*),rho,s(60,60),bodyfx(3),
     &  ff(60),elconloc(21),coords(3),p1(3),elcon(0:ncmat_,ntmat_,*),
     &  p2(3),eth(6),rhcon(0:1,ntmat_,*),reltime,prop(*),tm(3,3),
     &  alcon(0:6,ntmat_,*),alzero(*),orab(7,*),t0(*),t1(*),
     &  xloadold(2,*),vold(0:mi(2),*),xload(2,*),omx,e,un,um,tt,
     &  sm(60,60),sti(6,mi(1),*),stx(6,mi(1),*),t0l,t1l,coefmpc(*),
     &  elas(21),thicke(mi(3),*),doubleglob(*),dl,e2(3),e3(3),h,
     &  plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*),
     &  xstiff(27,mi(1),*),plconloc(802),dtime,ttime,time,xg(3,3),
     &  x(3,3),Ds(2,2),Qs(2,2),Qin(3,3),Dm(3,3),Db(3,3),Dc(3,3),
     &  Kp(18,18),Km(18,18),tmg(18,18),Kshell(18,18),dett,dettt,
     &  Mshell(18,18),Dmi(3,3),Dbi(3,3),Dsi(2,2),di,gpthick(3,2),
     &  pres,fpres(18),Ae
      !
      gpthick(1,1) = +1.d0
      gpthick(2,1) =  0.d0
      gpthick(3,1) = -1.d0
      gpthick(1,2) = 2.d0/6.d0
      gpthick(2,2) = 8.d0/6.d0
      gpthick(3,2) = 2.d0/6.d0
      !
      di = 1.d0/3.d0
      !
      indexe = ipkon(nelem)
      index=ielprop(nelem)
      !
      nope = 3
      !
      !   properties of the cross section
      !
      h     = prop(index+1)	  ! user section porp.
      dett  = h/2.d0
      dettt = h**3/8.d0
      !
      !   coordinates
      !
      do i = 1,nope
         konl(i) = kon(indexe+i)
         do j = 1,3
            xl(i,j) = co(j,konl(i))
            xg(i,j) = co(j,konl(i)) ! xg(node,xi)
         enddo
      enddo
      !
      call us3_csys(xg,tm,tmg) ! e0-frame
      !call us3_csys_cr(xg,tm,tmg) !e0-frame
      !
      ! nodal coordinates in e0-frame
      !
      x(:,:) = 0.d0
      x(1,:) = matmul(tm,xg(1,:))
      x(2,:) = matmul(tm,xg(2,:))
      x(3,:) = matmul(tm,xg(3,:))
      !
      !     displacements for 2nd order static and modal theory
      !
      if(((iperturb(1).eq.1).or.(iperturb(2).eq.1)).and.
     &          (stiffness.eq.1).and.(buckling.eq.0)) then
         write(*,*) '*ERROR in e_c3d_US3: no second order'
         write(*,*) '       calculation for this type of element'
         call exit(201)
      endif
      !
      if((buckling.eq.1).or.(coriolis.eq.1)) then
         write(*,*) '*ERROR in e_c3d_US3: no buckling'
         write(*,*) '       calculation for this type of element'
         call exit(201)
      endif
      !
      !     material and orientation
      !
      imat = ielmat(1,nelem)
      amat = matname(imat)
      if(norien.gt.0) then
         iorien=max(0,ielorien(1,nelem))
      else
         iorien=0
      endif
      !
      if(nelcon(1,imat).lt.0) then
         ihyper=1
      else
         ihyper=0
      endif
      !
      kode = nelcon(1,imat)
      !
      if(kode.eq.2) then
         mattyp=1
      else
         mattyp=0
      endif
      !
      Dm(:,:) = 0.d0
      Db(:,:) = 0.d0
      Ds(:,:) = 0.d0
      do jjj = 1,3  ! workaround for thermals
        istiff = 1
!
!     in materialdata_me the following data are calculated:
!     - the tangent stiffness, taken from resultsmech.f
!     - the density. For solid calculations this is the density in the undeformed
!       state. Any temperature effect due to loading is taken into account by
!       the Jacobian, and not by temperature interpolation. Therefore, the
!       temperature can be set to zero here.
!
        t0l=0.d0
        t1l=0.d0
        call materialdata_me(elcon,nelcon,rhcon,nrhcon,alcon,nalcon,
     &     imat,amat,iorien,coords,orab,ntmat_,elas,rho,
     &     nelem,ithermal,alzero,mattyp,t0l,t1l,
     &     ihyper,istiff,elconloc,eth,kode,plicon,
     &     nplicon,plkcon,nplkcon,npmat_,
     &     plconloc,mi(1),dtime,jjj,
     &     xstiff,ncmat_)
        !
        e   = elas(1)
        un  = elas(2)
        !
        call us3_linel_Qi(e,un,Qin,Qs)
        Dm = Dm+Qin*gpthick(jjj,2)*dett
        Db = Db+Qin*((gpthick(jjj,1))**2)*gpthick(jjj,2)*dettt
        Ds = Ds+Qs*gpthick(jjj,2)*dett
      enddo
      !
      !   stiffness matirx (6 dofs 3 nodes -> 18x18)
      !
      call us3_Kp(x,Db,Ds,Kp) ! plate part (CS-DSG)   - in e0-frame
      call us3_Km(x,Km,Qin,h) ! membrane part (ANDES) - in e0-frame
      Kshell = Km + Kp
      !
      call us3_M(x,h,rho,Mshell)
      !
      Kshell = matmul(matmul(transpose(tmg),Kshell),tmg)
      Mshell = matmul(matmul(transpose(tmg),Mshell),tmg)
      !
      do i=1,18
        do j=1,18
            sm(i,j) = Mshell(i,j)
            s(i,j)  = Kshell(i,j)
        enddo
      enddo
      !
      ! pressure loads defined y/n
      !
      if(nload.gt.0) then ! idlist=1 distributed loads defined
        !
        call nident2(nelemload,nelem,nload,id)
        !
        ! *SURFACE arg (sideload 1 NEG, 2 POS):
        !
        ff(:) = 0.d0
        if(sideload(id)(1:2).eq.'P2') then
          pres = -xload(1,id)
        elseif(sideload(id)(1:2).eq.'P1') then
          pres = +xload(1,id)
        endif
        !
        call us3_ae(x,Ae) ! element area
        ff(3)  = di*Ae*pres
        ff(9)  = di*Ae*pres
        ff(15) = di*Ae*pres
        !
      endif
      !
      return
      end


c=======================================================================
c
c     subroutine NAVEM
c
c     Expectation-Maximization (EM) algorithm
c     -> recover missing observations in time series
c
c     NAV data structure
c
c           n : number of points
c           p : number of assets
c
c     NAV(n,p) = | x(1,1), ..., x(1,p) |
c                | x(2,1), ...,  miss  |
c                | x(3,1), ..., x(3,p) |
c                |   .   , ...,   .    |
c                |   .   , ...,   .    |
c                | x(n,1), ..., x(n,p) |
c
c     where x(2,p) = miss denote a missing NAV
c
c-----------------------------------------------------------------------
      SUBROUTINE navem ( n, p, NAV, miss, iwork, dwork, NAVc, info )
c-----------------------------------------------------------------------
c
c     INPUT
c        n      : max. number of values (n > 1)                  integer
c        p      : number of assets (p > 0)                       integer
c        NAV    : NAV values (n*p)                                double
c        miss   : missing value (<= -1)                           double
c
c     WORKSPACE
c        iwork  : 2*p                                            integer
c        dwork  : p*(13*p + 5*n + 10)                             double
c
c     OUTPUT
c        NAVc   : EM-recoved NAV values (n*p)                     double
c        info   : diagnostic argument                            integer
c
c     CALL
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, info
      DOUBLE PRECISION miss, NAV(n,*), NAVc(n,*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, j, h, nh
      INTEGER piem, pdem, pdnav, pdR, pdRc
      DOUBLE PRECISION missret, r
c
c     external subroutines
      EXTERNAL YM, LOGRLACK, RETEM
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
      CALL YV(n*p, NAV, NAVc)
      missret = -1000
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      piem = 1
c     piem : pointer for RETEM (2*p)
c
c     Total size of iwork array  = 2*p
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdnav  = 1
c     pdnav  : pointer for NAV (n*p)
      pdR    = pdnav + ( n*p )
c     pdR    : pointer for log-returns (n*p)
      pdRc   = pdR + ( n*p )
c     pdRc   : pointer for corrected log-returns (n*p)
      pdem   = pdRc + ( n*p )
c     pdem   : pointer for RETEM (p*(13*p + 2*n + 10))
c
c     Total size of dwork array  = p*(13*p + 5*n + 10)
c
c-----------------------------------------------------------------------
c
c     test if last date is not missing
      DO j = 1,p
        IF (NAV(n,j) .LE. miss) THEN
            info = -9004
            RETURN
        ENDIF
      ENDDO
c
c     copy NAV -> NAVtmp
      CALL YV (n*p, NAV, dwork(pdnav))
      DO i = 1,n
        DO j = 1,p
            IF (NAV(i,j) .LE. miss)
c             dwork(pdnav + p*(i-1) + j - 1) = missret
     &      dwork(pdnav + n*(j-1)+i-1) = missret
        ENDDO
      ENDDO
c
c     compute log-returns: log[NAV(t+h)/NAV(t)]
      h = 1
      nh = n - 1
      CALL logrlack ( n, p, dwork(pdnav), h, dwork(pdR), info )
c
c     EM-recover log-returns
      CALL retem ( nh, p, dwork(pdR), missret,
     &             iwork(piem), dwork(pdem), dwork(pdRc), info )
      IF (info .LT. 0) RETURN
c
c     construct EM-recover NAV's
      DO i = 2,n
        DO j = 1,p
            IF (NAV(n - i + 1, j) .LE. miss) THEN
                r = dwork(pdRc + nh*(j-1) + nh - i + 1) ! returns
c                NAVc(n - i + 1,j) = NAVc(n - i + 2,j)/(1.0 + r)
                 NAVc(n - i + 1,j) = NAVc(n - i + 2,j)*EXP(-r)
            ENDIF
        ENDDO
      ENDDO
      RETURN
      END


      SUBROUTINE loop100_F77(N, a, b, c, d, x, u, v, w, z)
      INTEGER i, N
      REAL*8 a(N), b(N), c(N), d(N), x(N), u, v, w, z

      DO i=1,N
          x(i)=(1.0-c(i)*c(i))/((4*w)*sin(1.0+c(i)*c(i)-2*v*c(i)))*a(i
     !)*b(i)*u*exp(-z*d(i));
      END DO
      RETURN
      END

      SUBROUTINE loop100_F77Overhead(N, a, b, c, d, x, u, v, w, z)
      INTEGER i, N
      REAL*8 a(N), b(N), c(N), d(N), x(N), u, v, w, z
      RETURN
      END