subroutine trace(ndime,tensor,res)
 use typre
 implicit none
 integer(ip), intent(in) :: ndime
 real(rp)   , intent(in) :: tensor(ndime,ndime)
 real(rp)   , intent(out):: res
 integer(ip)             :: idime

 res = 0.0_rp

 do idime = 1,ndime
     res = res + tensor(idime,idime)
 enddo

end subroutine trace

subroutine get2ndIITensor_voigt(ndime,sz,ii)
 use typre
 implicit none
 integer(ip), intent(in) :: ndime,sz
 real(rp), intent(inout) :: ii(sz)

 if (ndime.eq.2) then

     ii =  reshape([ 1.0_rp, 1.0_rp, 0.0_rp], &
         [sz])

 elseif (ndime.eq.3) then

     ii =  reshape([ 1.0_rp, 1.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp], &
         [sz])

 endif

end subroutine get2ndIITensor_voigt

subroutine get2ndIITensor(ndime,ii)
 use typre
 implicit none
 integer(ip), intent(in)    :: ndime
 real(rp)   , intent(inout) :: ii(ndime,ndime)

 ii = 0.0_rp
 ii(1,1)=1.0_rp
 ii(2,2)=1.0_rp

 if (ndime.eq.3) then
     ii(3,3)=1.0_rp
 end if

end subroutine get2ndIITensor

subroutine getDiagTensor(ndime,sz,ii)
 use typre
 implicit none
 integer(ip), intent(in)    :: ndime,sz
 real(rp)   , intent(inout) :: ii(sz,sz)

 if (ndime.eq.2) then

      ii =  reshape([ 1.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 1.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 1.0_rp], &
             [3,3])

 elseif (ndime.eq.3) then

      ii =  reshape([ 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 1.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 1.0_rp], &
             [6,6])

     endif
end subroutine getDiagTensor

subroutine getDiagTensor2Txy(ndime,sz,ii)
 use typre
 implicit none
 integer(ip), intent(in)    :: ndime,sz
 real(rp)   , intent(inout) :: ii(sz,sz)

 if (ndime.eq.2) then

      ii =  reshape([ 1.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 1.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 2.0_rp], &
             [3,3])

 elseif (ndime.eq.3) then

      ii =  reshape([ 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 2.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 2.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 2.0_rp], &
             [6,6])

     endif

end subroutine getDiagTensor2Txy

subroutine get4thIITensor(ndime,sz,ii)
 use typre
 implicit none
 integer(ip), intent(in)    :: ndime,sz
 real(rp)   , intent(inout) :: ii(sz,sz)

 if (ndime.eq.2) then

      ii =  reshape([ 1.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 1.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 1.0_rp], &
             [3,3])

 elseif (ndime.eq.3) then

      ii =  reshape([ 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 1.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 1.0_rp], &
             [6,6])

     endif

end subroutine get4thIITensor

subroutine get4thIIVolumetricTensor(ndime,sz,ii)
 use typre
 implicit none
 integer(ip), intent(in)    :: ndime,sz
 real(rp)   , intent(inout) :: ii(sz,sz)

 if (ndime.eq.2) then

      ii =  reshape([ 1.0_rp, 1.0_rp, 0.0_rp, &
                      1.0_rp, 1.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp], &
             [3,3])

 elseif (ndime.eq.3) then

      ii =  reshape([ 1.0_rp, 1.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      1.0_rp, 1.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      1.0_rp, 1.0_rp, 1.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, &
                      0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp, 0.0_rp], &
             [6,6])

     endif

     ii = (1.0_rp/3.0_rp)*ii

end subroutine get4thIIVolumetricTensor

subroutine pushForward(ndime,sz,F,tensor,res)
 use typre
 implicit none
 integer(ip), intent(in)  :: ndime,sz
 real(rp)   , intent(in)  :: F(ndime,ndime),tensor(ndime,ndime)
 real(rp)   , intent(out) :: res(ndime,ndime)
 real(rp)             :: auxmat(ndime,ndime)

 auxmat = 0.0_rp
 res = 0.0_rp

 auxmat = matmul(tensor,transpose(F))
 res    = matmul(F,auxmat)

end subroutine pushForward

subroutine getVoigtStrain(sz,ndime,t,voigt)
 use typre
 implicit none
 integer(ip), intent(in)  :: ndime,sz
 real(rp)   , intent(in)  :: t(ndime,ndime)
 real(rp)   , intent(out) :: voigt(sz,1)

 if (ndime.eq.2) then

     voigt =  reshape([ t(1,1), t(2,2), 2.0_rp*t(1,2)], &
         [sz,1])

 elseif (ndime.eq.3) then

     voigt =  reshape([ t(1,1), t(2,2), t(3,3), 2.0_rp*t(2,3), 2.0_rp*t(1,3), 2.0_rp*t(1,2)], &
         [sz,1])

 endif

end subroutine getVoigtStrain

subroutine getVoigtStress(sz,ndime,t,voigt)
 use typre
 implicit none
 integer(ip), intent(in)  :: ndime,sz
 real(rp)   , intent(in)  :: t(ndime,ndime)
 real(rp)   , intent(out) :: voigt(sz)

 if (ndime.eq.2) then

     voigt =  reshape([ t(1,1), t(2,2), t(1,2)], &
         [sz])

 elseif (ndime.eq.3) then

     voigt =  reshape([ t(1,1), t(2,2), t(3,3), t(2,3), t(1,3), t(1,2)], &
         [sz])

 endif

end subroutine getVoigtStress

subroutine getStrainTensor(sz,ndime,voigt,t)
 use typre
 implicit none
 integer(ip), intent(in)  :: ndime,sz
 real(rp)   , intent(in)  :: voigt(sz)
 real(rp)   , intent(out) :: t(ndime,ndime)

 t=0.0_rp

 if (ndime.eq.2) then

     t =  reshape([      voigt(1),0.5_rp*voigt(3),&
                  0.5_rp*voigt(3),voigt(2)],&
         [ndime,ndime])

 elseif (ndime.eq.3) then

     t =  reshape([ voigt(1)     ,0.5_rp*voigt(6),0.5_rp*voigt(5),&
                  0.5_rp*voigt(6),       voigt(2),0.5_rp*voigt(4),&
                  0.5_rp*voigt(5),0.5_rp*voigt(4),       voigt(3)],&
         [ndime,ndime])

 endif

end subroutine getStrainTensor

subroutine getStressTensor(sz,ndime,voigt,t)
 use typre
 implicit none
 integer(ip), intent(in)  :: ndime,sz
 real(rp)   , intent(in)  :: voigt(sz)
 real(rp)   , intent(out) :: t(ndime,ndime)

 t=0.0_rp

 if (ndime.eq.2) then

     t =  reshape([voigt(1),voigt(3),&
                   voigt(3),voigt(2)],&
         [ndime,ndime])

 elseif (ndime.eq.3) then

     t =  reshape([ voigt(1),voigt(6),voigt(5),&
                    voigt(6),voigt(2),voigt(4),&
                    voigt(5),voigt(4),voigt(3)],&
         [ndime,ndime])

 endif

end subroutine

subroutine matvec(s1,s2,lmat,rvec,res)
 use typre
 implicit none
 integer(ip), intent(in)  :: s1,s2
 real(rp)   , intent(in)  :: lmat(s1,s2)
 real(rp)   , intent(in)  :: rvec(s2)
 real(rp)   , intent(out) :: res(s1)
 integer(ip) :: j,k

 res=0.0
 do j = 1,s1
   do k = 1,s2
      res(j) = res(j) + lmat(j,k)*rvec(k)
   enddo
enddo

end subroutine

subroutine matvecmult(s1,s2,lmat,rvec,res)
 use typre
 implicit none
 integer(ip), intent(in)  :: s1,s2
 real(rp)   , intent(in)  :: lmat(s1*s2,s1*s2)
 real(rp)   , intent(in)  :: rvec(s1*s2)
 real(rp)   , intent(out) :: res(s1*s2)
 integer(ip) :: j,k
 !real(rp),    intent(in)    :: lmat(s1,s2,s1,s2)
 !real(rp),    intent(in)    :: rvec(s1,s2)
 !real(rp),    intent(out)   :: res(s1,s2)
 !integer(ip) :: j,k,l,m

 res=0.0

 !Both forms produce the same result, second one
 !makes use of the way fortran saves matrices into
 !memory, has two less for loops, therefore efficient

 !do j=1,s2
 !    do k=1,s2
 !        do l=1,s1
 !           do m=1,s1
 !               res(l,m) = res(l,m) + lmat(m,j,l,k)*rvec(l,k)
 !           end do
 !        end do
 !    end do
 !end do

 do j = 1,s1*s2
   do k = 1,s1*s2
      res(j) = res(j) + lmat(j,k)*rvec(k)
   enddo
enddo

end subroutine

subroutine matmatmulti(s1,s2,lmat,rmat,res)
 use typre
 implicit none
 integer(ip), intent(in)  :: s1,s2
 real(rp)   , intent(in)  :: lmat(s1*s2,s1*s2)
 real(rp)   , intent(in)  :: rmat(s1*s2,s1*s2)
 real(rp)   , intent(out) :: res(s1*s2,s1*s2)
 integer(ip) :: i,j,k

 res=0.0

 do i = 1,s1*s2
     do j = 1,s1*s2
         do k = 1,s1*s2
             res(i,j) = res(i,j) + lmat(i,k)*rmat(k,j)
         enddo
     enddo
enddo

end subroutine

subroutine tracedoubledot(ndime,tensor,res)
 !This routine calculates the following
 !tr(A**2)
 use typre
 implicit none
 integer(ip), intent(in)  :: ndime
 real(rp)   , intent(in)  :: tensor(ndime,ndime)
 real(rp)   , intent(out) :: res
 integer(ip)              :: i,j

 res = 0.0_rp

      if (ndime.eq.2) then
          res = res + tensor(1,1)*tensor(1,1)&
              & + tensor(2,2)*tensor(2,2) + 2.0_rp*tensor(1,2)*tensor(1,2)

      else
          res = res + tensor(1,1)*tensor(1,1)&
              & + tensor(2,2)*tensor(2,2)+ tensor(3,3)*tensor(3,3) &
              & + 2.0_rp*tensor(1,2)*tensor(1,2)+2.0_rp*tensor(1,3)*tensor(1,3)&
              & + 2.0_rp*tensor(2,3)*tensor(2,3)
      endif

end subroutine

subroutine getTensorInvariants(ndime,tensor,invar)
 !This routine calculates the invariants
 !of a tensor
 use typre
 implicit none
 integer(ip), intent(in)    :: ndime
 real(rp)   , intent(in)    :: tensor(ndime,ndime)
 real(rp)   , intent(inout) :: invar(ndime)
 real(rp)  :: auxvar

 !Invariant 1
 auxvar = 0.0_rp
 call trace(ndime,tensor,auxvar)
 invar(1)= auxvar

 !Invariant 2
 auxvar = 0.0_rp
 call tracedoubledot(ndime,tensor,auxvar)
 invar(2) = 0.5*(invar(1)*invar(1)-auxvar)

 if (ndime.eq.3) then
  !Invariant 3
  auxvar = 0.0_rp
  call deter(tensor,auxvar,ndime)
  invar(3)= auxvar
 endif

end subroutine


      program image_processing
c     goal: show effect of cloning, partial evaluation and loop unrolling
c     and reduction parallelization for a Power architecture

c     kernel_size must be even
      parameter (image_size=512, kernel_size=3, nsteps=20)
      real image(image_size,image_size)
      real new_image(image_size,image_size)
      real kernel(kernel_size, kernel_size)

      do i = 1, kernel_size
         do j = 1, kernel_size
            kernel(i,j) = 1.
         enddo
      enddo

c     read *, image
      do i = 1, image_size
         do j = 1, image_size
            image(i,j) = 1.
         enddo
      enddo

      do n = 1, nsteps
         call convol(new_image, image, image_size, image_size,
     &        kernel, kernel_size, kernel_size)
      enddo

c     print *, new_image
      print *, new_image (image_size/2, image_size/2)

      end

      subroutine convol(new_image, image, isi, isj, kernel, ksi, ksj)
c     The convolution kernel is not applied on the outer part
c     of the image
      real image(isi,isj)
      real new_image(isi,isj)
      real kernel(ksi,ksj)

      do i = 1, isi
         do j = 1, isj
            new_image(i,j) = image(i,j)
         enddo
      enddo

      do 400 i = 1 + ksi/2, isi - ksi/2
         do 300 j = 1 + ksj/2, isj - ksj/2
            new_image(i,j) = 0.
            do 200 ki = 1, ksi
               do 100 kj = 1, ksj
                  new_image(i,j) = new_image(i,j) +
     &                 image(i+ki-ksi/2-1,j+kj-ksj/2-1)*
     &                 kernel(ki,kj)
 100           continue
 200        continue
            new_image(i,j) = new_image(i,j)/(ksi*ksj)
 300     continue
 400  continue

      end


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_2Darray_random_normal
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine provides a matrix of pseudo-random complex numbers independent,
! standard, normally distributed (expected value 0, standard deviation 1).
! Call u_randomseed_initialize(INFO) first to set the seed of the number
! generator.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  M, N            INTEGER
!                    positive integers, dimension of A
!
!
! OUTPUT VARIABLES:
!
!  A               COMPLEX(8) array of dimension (M,N)
!                    matrix of complex random numbers
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_2Darray_random_normal(M,N,A)

  implicit none

  ! input variables
  integer, intent(in) :: M, N
  complex(8), intent(inout) :: A(M,N)

  ! compute variables
  integer :: ii, jj
  real(8) :: u, v

  ! check N
  if ((N .LT. 1).OR.(M .LT. 1)) then
    return
  end if

  do jj = 1,M
     do ii = 1,N

        call z_scalar_random_normal(u,v)
        A(jj,ii) = cmplx(u,v,kind=8)

     end do
  end do

end subroutine z_2Darray_random_normal


! { dg-do run }
! PR fortran/66864
!
program t
   implicit none
   real(8) x
   x = 2.0d0**26.5d0
   if (floor(x) /= 94906265) STOP 1
   if (floor(2.0d0**26.5d0)/= 94906265) STOP 2
   x = 777666555.6d0
   if (floor(x) /= 777666555) STOP 3
   if (floor(777666555.6d0) /= 777666555) STOP 4
   x = 2000111222.6d0
   if (floor(x) /= 2000111222) STOP 5
   if (floor(2000111222.6d0) /= 2000111222) STOP 6
end program t


program black_hole_diffusion
  use mod_constants
  use mod_read_parameters
  use mod_variables
  use mod_integrator
  use mod_output
  use mod_timestep
  use mod_s_curve
  use mod_distance

  implicit none

  character(len=10)                      :: arg
  integer                                :: stp_value = 100000 ! select the stop iteration
  !  don't kill the job without stp_value
  real(x_precision), dimension(n_cell)   :: jnk1, jnk3
  character(len=100)                     :: line
  !--------------------------- Parameters for s_curve-----------------------
  real(x_precision), dimension(n_cell) :: T_c
  real(x_precision), dimension(n_cell) :: Sigma_c
  real(x_precision), dimension(n_cell) :: S_c
  !-------------------------------------------------------------------------

  integer                              :: start_iteration, iteration, ios, i, T_steps, S_steps
  type(state)                          :: s
  real(x_precision), dimension(n_cell) :: prev_S, prev_T, S_rel_diff
  real(x_precision)                    :: delta_S_max, delta_T_max, S_rel_diff_max
  real(x_precision)                    :: t
  real(x_precision)                    :: dt_nu, dt_T, pf
  real(x_precision), dimension(n_cell) :: mean
  logical                              :: T_converged
  logical                              :: unstable, wasunstable

  real(x_precision), dimension(n_cell) :: dist_crit

  call getarg(1, arg)
  mean        = 0._x_precision
  !----------------------------------------------
  ! Convergence criteria for S and T
  !----------------------------------------------
  delta_S_max = 1e-8_x_precision
  delta_T_max = 1e-4_x_precision

  !----------------------------------------------
  ! Read the parameters, generate state_0 and create adim state
  !----------------------------------------------
  call get_parameters()
  call make_temperature()
  call set_conditions()
  call curve(T_c, Sigma_c)

  ! Conversion into S*_crit
  S_c = Sigma_c * x_state%x
  dist_crit = 200. * x_state%x

  !----------------------------------------------
  ! Set the initial conditions for S, T
  !----------------------------------------------
  open(15, file="CI.dat", status="replace", iostat=ios)
  if (ios /= 0) then
     stop "Error while opening output file."
  end if

  ! Save initial conditions
  write(15, '(7(A16))')'r', 'T', 'Sigma', 'H'

  do i = 1, n_cell
     write(15, '(7(e16.6e2))') r_state%r(i), IC%T(i), IC%Sigma(i), IC%H(i)
  enddo

  close(15)

  !-------------------------------------------------------------------
  !------------------------------Restart------------------------------
  !---------------------- Select n_iterations-------------------------
  !------Call ./simul load > let the job do until n_iterations--------
  !-----------------------Call ./simul restart------------------------
  !-------------------------------------------------------------------
  if (arg == 'restart' .or. arg == 'load') then
     if (arg == 'restart') then
        print*, 'Creating restart file and saving old output file to output.dat.prev'
        call system ("tail -n 259 output.dat > restart.dat")
        call system ("cp output.dat output.dat.prev")
     end if
     open(21, file="restart.dat", action='read', iostat=ios)

     if (ios /= 0) then
        stop "Error while opening output file."
     end if
     read(21,*)line, start_iteration
     read(21,*)line, t
     read(21,*)line
     do i = 1, n_cell
        read(21,*)jnk1(i), s%T(i), s%Mdot(i), jnk3(i), s%s(i)
     end do
     s%T = s%T / state_0%T_0
     s%S = s%S / state_0%S_0 * x_state%x
     s%Mdot = s%Mdot / state_0%Mdot_0
     close(21)

     if (maxval(s%T - T_c) < 0) then
       ! …or right from its critical S…
       unstable = maxval(s%S - S_c) > 0
     else
       ! …then we’re unstable.
       unstable = .true.
     end if

     iteration = start_iteration

  elseif (arg == 'start') then
     s%T = IC%T / state_0%T_0
     s%S = IC%Sigma / state_0%S_0 * x_state%x
     ! Initial time = 0
     t = 0._x_precision
     ! Start
     start_iteration = 0
     iteration = 0
     unstable = .false.
     s%Mdot(n_cell) = 1._x_precision
  else
     print*, 'Unsupported action "', arg, '". Call ./simul [start|load|restart].'
     stop
  end if

  !----------------------------------------------
  ! Do an initial computation of the variables
  !----------------------------------------------
  call compute_variables(s)

  !----------------------------------------------
  ! Open files to write output to
  !----------------------------------------------
  open(13, file="output.dat", status="replace", iostat=ios)
  if (ios /= 0) then
     stop "Error while opening output file."
  end if
  open(14, file="output_integrated.dat", status="replace", iostat=ios)
  if (ios /= 0) then
     stop "Error while opening output file."
  end if

  !----------------------------------------------
  ! Save initial snapshot
  !----------------------------------------------
  call snapshot(s, iteration, t, 13, 14)

  !----------------------------------------------
  ! Compute initial timestep
  !----------------------------------------------
  call timestep_T(s, dt_T)
  call timestep_nu(s, dt_nu)
  write(*,*) 'dt_T_init, dt_nu_init:', dt_T, dt_nu

  !----------------------------------------------
  ! Start iterations
  !----------------------------------------------
  S_steps = 0
  do while (iteration < n_iterations)

     !--------------------------------------------
     ! Check if any point is in the unstable area
     !--------------------------------------------

     wasunstable = unstable
     ! If some point is above is critical temperature…
     if (maxval(s%T - T_c) < 0) then
       ! …or right from its critical S…
       unstable = maxval(s%S - S_c) > 0
     else
       ! …then we’re unstable.
       unstable = .true.
     end if

     if (unstable) then
        if (.not. wasunstable) then
           print*, 'Switched to explicit mode!'
        end if

        ! Do an explicit integration of both S and T over a thermic timestep
        call timestep_T(s, dt_T)
        dt_T = 0.01_x_precision * dt_T ! FIXME: This probably need to be tweaked a bit
        call do_timestep_S_exp(s, dt_T)
        call do_timestep_T_exp(s, dt_T)

        ! Increase time, increment number of iterations
        t = t + dt_T
        iteration = iteration + 1

        if (mod(iteration, output_freq) == 0) then
           if ((arg == 'load' .or. arg == 'restart') &
                .and. iteration-start_iteration > stp_value) then
              stop
           endif
           call snapshot(s, iteration, t, 13, 14)
           print*,'snapshot', iteration, t, 'exp', maxval(s%T - T_c), maxval(s%S - S_c), dt_T
        end if

     else
        S_steps = S_steps + 1
        if (wasunstable) then
           print*, 'Switched back to implicit mode!'
           s%Mdot(n_cell) = s%Mdot(n_cell) / 2._x_precision
           print*, 'Mdot un-kick! un-YOLOOOOO', s%Mdot(n_cell)
        end if

        ! Integrate S, then integrate T until we’re back on the curve

        !----------------------------------------------
        ! S integration
        !----------------------------------------------

        call timestep_nu(s, dt_nu)

        ! Take into account the distance to the critical point
        pf =  pre_factor(s%S, S_c, dist_crit)
        dt_nu = dt_nu * pf

        ! Do a single S integration
        prev_S = s%S ! We need to keep the old value for comparison
        call do_timestep_S_imp(s, dt_nu)

        ! Increase time, increment number of iterations
        t = t + dt_nu
        iteration = iteration + 1

        if (mod(iteration, output_freq) == 0 ) then
           if ((arg == 'load' .or. arg == 'restart') &
                .and. iteration-start_iteration > stp_value) then
              stop
           endif
           call snapshot(s, iteration, t, 13, 14)
           print*,'snapshot', iteration, t, 'S', dt_nu, dt_T, pf
        end if

        !----------------------------------------------
        ! T integrations
        ! Iterate while T hasn't converged
        !----------------------------------------------

        T_converged = .false.

        call compute_variables(s)

        T_steps = 0
        do while (.not. T_converged)
           T_steps = T_steps + 1
           if (T_steps >= 20 .and. mod(T_steps, 20) == 0) then
              print*, 'W: T is taking time to converge, already', T_steps, 'iterations'
           end if

           call compute_variables(s)
           call timestep_T(s, dt_T)

           ! Do a single T integration
           prev_T = s%T ! We need to keep the old value for comparison
           call do_timestep_T_imp(s, dt_T)

           ! Increase time, increment number of iterations
           t = t + dt_T
           iteration = iteration + 1

           ! Do a snapshot
           if (mod(iteration, output_freq) == 0 .or. (iteration < 24000 .and. mod(iteration,500) == 0)) then
              if ((arg == 'load' .or. arg == 'restart') &
                   .and. iteration-start_iteration > stp_value) then
                 stop
              endif
              call snapshot(s, iteration, t, 13, 14)
              print*,'snapshot', iteration, t, 'T', dt_nu, dt_T, pf
           end if

           ! Check if T converged everywhere
           T_converged = maxval(abs(prev_T - s%T)/s%T) / dt_T < delta_T_max

        end do

        !----------------------------------------------
        ! Mdot kick
        ! Increase Mdot at r_max if S is stalled
        !
        ! we give an mdot kick when the relative variation is below delta_S_max
        ! and when the mean over last 10 iterations does not evolve anymore
        !----------------------------------------------
        S_rel_diff = (prev_S - s%S) / s%S / dt_nu
        S_rel_diff_max = maxval(abs(S_rel_diff))

        if (S_rel_diff_max < delta_S_max * mean_size) then
           ! - - - - - - - - - - - - - - - - - - - - - - -
           ! compute the rolling mean of the latest S when getting
           ! close to the convergence
           ! - - - - - - - - - - - - - - - - - - - - - - -
           if (S_rel_diff_max < delta_S_max) then
              s%Mdot(n_cell) = s%Mdot(n_cell) * 1.05_x_precision
              print*, 'Converged totally!'
              print*, 'Mdot kick! YOLOOOOO', s%Mdot(n_cell), S_steps
              mean = 0._x_precision
           else
              mean = S_rel_diff / mean_size + &
                   (mean_size - 1._x_precision) / mean_size * mean

              if (maxval(abs(mean)) < delta_S_max) then
                 s%Mdot(n_cell) = s%Mdot(n_cell) * 1.05_x_precision
                 print*, 'Converged in mean!', maxval(abs(mean)), S_rel_diff_max
                 print*, 'Mdot kick! YOLOOOOO', s%Mdot(n_cell)
                 mean = 0._x_precision
              else
                 if (mod(iteration, output_freq) < 10) then
                    print*, maxval(abs(mean)), S_rel_diff_max
                 end if
              end if
           end if
        end if

     end if

     ! Recompute variables when the system is stable
     call compute_variables(s)

  end do

  close(13)
  close(14)
end program black_hole_diffusion


!> Author:   Jabir Ali Ouassou
!> Category: Foundation
!>
!> This module defines the data type 'nambu', which represents 4×4 complex matrices in spin and Nambu space. The module
!> overloads arithmetic operators to work with the new type, and defines and exports the Pauli matrices as constants.

module nambu_m
  use :: math_m
  use :: spin_m
  private

  ! Public interface
  public nambu, nambuv
  public inverse, trace, conjg, sum

  ! Type declaration
  type nambu
    complex(wp) :: matrix(4,4) = 0.0_wp   !! Encapsulate a spin and Nambu space matrix
  contains
    ! Overload constructors and operators
    generic :: nambu         => cons_rscalar, cons_cscalar, cons_cmatrix, cons_nambu
    generic :: assignment(=) => assr_rscalar, assr_cscalar, assr_cmatrix, assl_cmatrix
    generic :: operator(+)   => addl_rscalar, addr_rscalar, addl_cscalar, addr_cscalar, addl_cmatrix, addr_cmatrix, add_nambu
    generic :: operator(-)   => subl_rscalar, subr_rscalar, subl_cscalar, subr_cscalar, subl_cmatrix, subr_cmatrix, sub_nambu
    generic :: operator(*)   => mull_rscalar, mulr_rscalar, mull_cscalar, mulr_cscalar, mull_cmatrix, mulr_cmatrix, mul_nambu
    generic :: operator(/)   => divr_rscalar, divr_cscalar
    generic :: operator(**)  => expr_iscalar

    ! Specific methods for construction
    procedure,   nopass,   private :: cons_nambu   => nambu_cons_nambu     !! Construction from a nambu object
    procedure,   nopass,   private :: cons_rscalar => nambu_cons_rscalar   !! Construction from a real scalar
    procedure,   nopass,   private :: cons_cscalar => nambu_cons_cscalar   !! Construction from a complex scalar
    procedure,   nopass,   private :: cons_cmatrix => nambu_cons_cmatrix   !! Construction from a complex matrix

    ! Specific implementations of assignments
    procedure, pass(this), private :: assr_rscalar => nambu_assr_rscalar   !! Assign data from a real scalar      (right)
    procedure, pass(this), private :: assr_cscalar => nambu_assr_cscalar   !! Assign data from a complex scalar   (right)
    procedure, pass(this), private :: assl_cmatrix => nambu_assl_cmatrix   !! Assign data into a complex matrix   (left)
    procedure, pass(this), private :: assr_cmatrix => nambu_assr_cmatrix   !! Assign data from a complex matrix   (right)

    ! Specific implementations of addition
    procedure, pass(this), private :: add_nambu    => nambu_add_nambu      !! Addition with a nambu object
    procedure, pass(this), private :: addl_rscalar => nambu_addl_rscalar   !! Addition with a real scalar         (left)
    procedure, pass(this), private :: addr_rscalar => nambu_addr_rscalar   !! Addition with a real scalar         (right)
    procedure, pass(this), private :: addl_cscalar => nambu_addl_cscalar   !! Addition with a complex scalar      (left)
    procedure, pass(this), private :: addr_cscalar => nambu_addr_cscalar   !! Addition with a complex scalar      (right)
    procedure, pass(this), private :: addl_cmatrix => nambu_addl_cmatrix   !! Addition with a complex matrix      (left)
    procedure, pass(this), private :: addr_cmatrix => nambu_addr_cmatrix   !! Addition with a complex matrix      (right)

    ! Specific implementations of subtraction
    procedure, pass(this), private :: sub_nambu    => nambu_sub_nambu      !! Subtraction with a nambu object
    procedure, pass(this), private :: subl_rscalar => nambu_subl_rscalar   !! Subtraction with a real scalar      (left)
    procedure, pass(this), private :: subr_rscalar => nambu_subr_rscalar   !! Subtraction with a real scalar      (right)
    procedure, pass(this), private :: subl_cscalar => nambu_subl_cscalar   !! Subtraction with a complex scalar   (left)
    procedure, pass(this), private :: subr_cscalar => nambu_subr_cscalar   !! Subtraction with a complex scalar   (right)
    procedure, pass(this), private :: subl_cmatrix => nambu_subl_cmatrix   !! Subtraction with a complex matrix   (left)
    procedure, pass(this), private :: subr_cmatrix => nambu_subr_cmatrix   !! Subtraction with a complex matrix   (right)

    ! Specific implementations of multiplication
    procedure, pass(this), private :: mul_nambu    => nambu_mul_nambu      !! Multiplication by a nambu object
    procedure, pass(this), private :: mull_rscalar => nambu_mull_rscalar   !! Multiplication by a real scalar     (left)
    procedure, pass(this), private :: mulr_rscalar => nambu_mulr_rscalar   !! Multiplication by a real scalar     (right)
    procedure, pass(this), private :: mull_cscalar => nambu_mull_cscalar   !! Multiplication by a complex scalar  (left)
    procedure, pass(this), private :: mulr_cscalar => nambu_mulr_cscalar   !! Multiplication by a complex scalar  (right)
    procedure, pass(this), private :: mull_cmatrix => nambu_mull_cmatrix   !! Multiplication by a complex matrix  (left)
    procedure, pass(this), private :: mulr_cmatrix => nambu_mulr_cmatrix   !! Multiplication by a complex matrix  (right)

    ! Specific implementations of division
    procedure, pass(this), private :: divr_rscalar => nambu_divr_rscalar   !! Division by a real scalar           (right)
    procedure, pass(this), private :: divr_cscalar => nambu_divr_cscalar   !! Division by a complex scalar        (right)

    ! Specific implementations of exponentiation
    procedure, pass(this), private :: expr_iscalar => nambu_expr_iscalar   !! Exponentiation by an integer        (right)
  end type

  ! Public interfaces
  interface inverse
    !! Matrix inverse
    module procedure nambu_inv
  end interface

  interface trace
    !! Matrix trace
    module procedure nambu_trace
  end interface

  interface sum
    !! Matrix sum
    module procedure nambu_sum
  end interface

  interface conjg
    !! Complex conjugation
    module procedure nambu_conjg
  end interface

  interface nambuv
    !! Construct basis matrices
    module procedure nambuv_scalar, nambuv_vector
  end interface
contains

  !--------------------------------------------------------------------------------!
  !                            SPECIFIC CONSTRUCTORS                               !
  !--------------------------------------------------------------------------------!

  pure function nambuv_scalar(n) result(r)
    !! Constructs basis matrix number n in spin-nambu space.
    integer, intent(in) :: n
    type(nambu)         :: r

    select case (n)
      case(0)
        ! Basis matrix τ₀σ₀
        r % matrix(1:2,1:2) = +pauli0 % matrix
        r % matrix(3:4,3:4) = +pauli0 % matrix
      case(1)
        ! Basis matrix τ₀σ₁
        r % matrix(1:2,1:2) = +pauli1 % matrix
        r % matrix(3:4,3:4) = +pauli1 % matrix
      case(2)
        ! Basis matrix τ₀σ₂
        r % matrix(1:2,1:2) = +pauli2 % matrix
        r % matrix(3:4,3:4) = -pauli2 % matrix
      case(3)
        ! Basis matrix τ₀σ₃
        r % matrix(1:2,1:2) = +pauli3 % matrix
        r % matrix(3:4,3:4) = +pauli3 % matrix
      case(4)
        ! Basis matrix τ₃σ₀
        r % matrix(1:2,1:2) = +pauli0 % matrix
        r % matrix(3:4,3:4) = -pauli0 % matrix
      case(5)
        ! Basis matrix τ₃σ₁
        r % matrix(1:2,1:2) = +pauli1 % matrix
        r % matrix(3:4,3:4) = -pauli1 % matrix
      case(6)
        ! Basis matrix τ₃σ₂
        r % matrix(1:2,1:2) = +pauli2 % matrix
        r % matrix(3:4,3:4) = +pauli2 % matrix
      case(7)
        ! Basis matrix τ₃σ₃
        r % matrix(1:2,1:2) = +pauli3 % matrix
        r % matrix(3:4,3:4) = -pauli3 % matrix
    end select
  end function

  pure function nambuv_vector(v) result(r)
    !! Constructs a matrix representation of a vector.
    real(wp), dimension(1:3), intent(in) :: v
    type(nambu)                          :: r

    r = v(1)*nambuv(1) + v(2)*nambuv(2) + v(3)*nambuv(3)
  end function

  pure function nambu_cons_rscalar(other) result(this)
    !! Constructs a nambu object from a real scalar.
    real(wp),   intent(in) :: other
    type(nambu)            :: this

    this = other
  end function

  pure function nambu_cons_cscalar(other) result(this)
    !! Constructs a nambu object from a complex scalar.
    complex(wp), intent(in)  :: other
    type(nambu)              :: this

    this = other
  end function

  pure function nambu_cons_cmatrix(other) result(this)
    !! Constructs a nambu object from a complex matrix.
    complex(wp), intent(in) :: other(4,4)
    type(nambu)             :: this

    this = other
  end function

  pure function nambu_cons_nambu(other) result(this)
    !! Constructs a nambu object from an existing one.
    type(nambu), intent(in) :: other
    type(nambu)             :: this

    this = other
  end function

  !--------------------------------------------------------------------------------!
  !                         SPECIFIC IMPORT PROCEDURES                             !
  !--------------------------------------------------------------------------------!

  pure subroutine nambu_assr_rscalar(this, other)
    !! Imports data to a nambu object from a real scalar.
    class(nambu), intent(inout) :: this
    real(wp),     intent(in)    :: other

    this%matrix = other * identity(4)
  end subroutine

  pure subroutine nambu_assr_cscalar(this, other)
    !! Imports data to a nambu object from a complex scalar.
    class(nambu), intent(inout) :: this
    complex(wp),  intent(in)    :: other

    this%matrix = other * identity(4)
  end subroutine

  pure subroutine nambu_assr_cmatrix(this, other)
    !! Imports data to a nambu object from a complex matrix.
    class(nambu),  intent(inout) :: this
    complex(wp),   intent(in)    :: other(4,4)

    this % matrix = other
  end subroutine

  !--------------------------------------------------------------------------------!
  !                         SPECIFIC EXPORT PROCEDURES                             !
  !--------------------------------------------------------------------------------!

  pure subroutine nambu_assl_cmatrix(other, this)
    !! Exports data from a nambu object to a complex matrix.
    class(nambu), intent(in)  :: this
    complex(wp),  intent(out) :: other(4,4)

    other = this%matrix
  end subroutine

  !--------------------------------------------------------------------------------!
  !                     SPECIFIC EXPONENTIATION PROCEDURES                         !
  !--------------------------------------------------------------------------------!

  pure function nambu_expr_iscalar(this, other) result(r)
    !! Exponentiates the nambu object, where the power is a positive integer.
    class(nambu), intent(in) :: this
    integer,      intent(in) :: other
    type(nambu)              :: r
    integer                  :: n

    r = this
    do n=2,other
      r%matrix = r%matrix * this
    end do
  end function

  !--------------------------------------------------------------------------------!
  !                     SPECIFIC MULTIPLICATION PROCEDURES                         !
  !--------------------------------------------------------------------------------!

  elemental pure function nambu_mul_nambu(this, other) result(r)
    !! Defines multiplication of two nambu matrices.
    class(nambu), intent(in) :: this
    class(nambu), intent(in) :: other
    type(nambu)              :: r

    r%matrix = matmul(this%matrix, other%matrix)
  end function

  pure function nambu_mull_rscalar(other, this) result(r)
    !! Defines left multiplication of a nambu matrix by a real scalar.
    class(nambu), intent(in) :: this
    real(wp),     intent(in) :: other
    type(nambu)              :: r

    r%matrix = other * this%matrix
  end function

  pure function nambu_mulr_rscalar(this, other) result(r)
    !! Defines right multiplication of a nambu matrix by a real scalar.
    class(nambu), intent(in) :: this
    real(wp),     intent(in) :: other
    type(nambu)              :: r

    r%matrix = this%matrix * other
  end function

  pure function nambu_mull_cscalar(other, this) result(r)
    !! Defines left multiplication of a nambu matrix by a complex scalar.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other
    type(nambu)              :: r

    r%matrix = other * this%matrix
  end function

  function nambu_mulr_cscalar(this, other) result(r)
    !! Defines right multiplication of a nambu matrix by a complex scalar.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other
    type(nambu)              :: r

    r%matrix = this%matrix * other
  end function

  pure function nambu_mull_cmatrix(other, this) result(r)
    !! Defines left multiplication of a nambu matrix by a complex matrix.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other(4,4)
    type(nambu)              :: r

    r%matrix = matmul(other, this%matrix)
  end function

  pure function nambu_mulr_cmatrix(this, other) result(r)
    !! Defines right multiplication of a nambu matrix by a complex matrix.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other(4,4)
    type(nambu)              :: r

    r%matrix = matmul(this%matrix, other)
  end function

  !--------------------------------------------------------------------------------!
  !                        SPECIFIC DIVISION PROCEDURES                            !
  !--------------------------------------------------------------------------------!

  pure function nambu_divr_rscalar(this, other) result(r)
    !! Defines division of a nambu matrix by a real scalar.
    class(nambu), intent(in) :: this
    real(wp),     intent(in) :: other
    type(nambu)              :: r

    r%matrix = this%matrix / other
  end function

  pure function nambu_divr_cscalar(this, other) result(r)
    !! Defines division of a nambu matrix by a complex scalar.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other
    type(nambu)              :: r

    r%matrix = this%matrix / other
  end function

  !--------------------------------------------------------------------------------!
  !                        SPECIFIC ADDITION PROCEDURES                            !
  !--------------------------------------------------------------------------------!

  elemental pure function nambu_add_nambu(this, other) result(r)
    !! Defines addition of two nambu matrices.
    class(nambu), intent(in) :: this
    class(nambu), intent(in) :: other
    type(nambu)              :: r

    r%matrix = this%matrix + other%matrix
  end function

  pure function nambu_addl_rscalar(other, this) result(r)
    !! Defines left addition of a nambu matrix and a real scalar.
    class(nambu), intent(in) :: this
    real(wp),     intent(in) :: other
    type(nambu)              :: r

    r%matrix = other*identity(4) + this%matrix
  end function

  pure function nambu_addr_rscalar(this, other) result(r)
    !! Defines right addition of a nambu matrix and a real scalar.
    class(nambu), intent(in) :: this
    real(wp),     intent(in) :: other
    type(nambu)              :: r

    r%matrix = this%matrix + other*identity(4)
  end function

  pure function nambu_addl_cscalar(other, this) result(r)
    !! Defines left addition of a nambu matrix and a complex scalar.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other
    type(nambu)              :: r

    r%matrix = other*identity(4) + this%matrix
  end function

  pure function nambu_addr_cscalar(this, other) result(r)
    !! Defines right addition of a nambu matrix and a complex scalar.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other
    type(nambu)              :: r

    r%matrix = this%matrix + other*identity(4)
  end function

  pure function nambu_addl_cmatrix(other, this) result(r)
    !! Defines left addition of a nambu matrix and a complex matrix.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other(4,4)
    type(nambu)              :: r

    r%matrix = other + this%matrix
  end function

  pure function nambu_addr_cmatrix(this, other) result(r)
    !! Defines right addition of a nambu matrix and a complex matrix.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other(4,4)
    type(nambu)              :: r

    r%matrix = this%matrix + other
  end function

  !--------------------------------------------------------------------------------!
  !                       SPECIFIC SUBTRACTION PROCEDURES                          !
  !--------------------------------------------------------------------------------!

  elemental pure function nambu_sub_nambu(this, other) result(r)
    !! Defines subtraction of two nambu matrices.
    class(nambu), intent(in) :: this
    class(nambu), intent(in) :: other
    type(nambu)              :: r

    r%matrix = this%matrix - other%matrix
  end function

  pure function nambu_subl_rscalar(other, this) result(r)
    !! Defines left subtraction of a nambu matrix and a real scalar.
    class(nambu), intent(in) :: this
    real(wp),     intent(in) :: other
    type(nambu)              :: r

    r%matrix = other*identity(4) - this%matrix
  end function

  pure function nambu_subr_rscalar(this, other) result(r)
    !! Defines right subtraction of a nambu matrix and a real scalar.
    class(nambu), intent(in) :: this
    real(wp),     intent(in) :: other
    type(nambu)              :: r

    r%matrix = this%matrix - other*identity(4)
  end function

  pure function nambu_subl_cscalar(other, this) result(r)
    !! Defines left subtraction of a nambu matrix and a complex scalar.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other
    type(nambu)              :: r

    r%matrix = other*identity(4) - this%matrix
  end function

  pure function nambu_subr_cscalar(this, other) result(r)
    !! Defines right subtraction of a nambu matrix and a complex scalar.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other
    type(nambu)              :: r

    r%matrix = this%matrix - other*identity(4)
  end function

  pure function nambu_subl_cmatrix(other, this) result(r)
    !! Defines left subtraction of a nambu matrix and a complex matrix.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other(4,4)
    type(nambu)              :: r

    r%matrix = other - this%matrix
  end function

  pure function nambu_subr_cmatrix(this, other) result(r)
    !! Defines right subtraction of a nambu matrix and a complex matrix.
    class(nambu), intent(in) :: this
    complex(wp),  intent(in) :: other(4,4)
    type(nambu)              :: r

    r%matrix = this%matrix - other
  end function

  !--------------------------------------------------------------------------------!
  !                                MATRIX ALGEBRA                                  !
  !--------------------------------------------------------------------------------!

  elemental pure function nambu_conjg(this) result(r)
    !! Calculate the complex conjugate of the nambu matrix.
    class(nambu), intent(in) :: this
    type(nambu)              :: r

    r%matrix = conjg(this%matrix)
  end function

  elemental pure function nambu_trace(this) result(r)
    !! Calculate the trace of the nambu matrix.
    class(nambu), intent(in) :: this
    complex(wp)              :: r

    r = this%matrix(1,1) + this%matrix(2,2) + this%matrix(3,3) + this%matrix(4,4)
  end function

  pure function nambu_inv(this) result(r)
    !! Calculate the inverse of the nambu matrix.
    class(nambu), intent(in) :: this
    type(nambu)              :: r

    r%matrix = inverse(this%matrix)
  end function

  pure function nambu_sum(this) result(r)
    !! Calculate the sum of an array of nambu matrices.
    class(nambu), intent(in) :: this(:)
    type(nambu)              :: r
    integer                  :: n

    do n=1,size(this)
      r % matrix = r % matrix + this(n) % matrix
    end do
  end function
end module


c=======================================================================
c
c     subroutine SKGENOPT
c
c     Computing the function and gradient of
c     Theta(dual) = 0.5*[wopt'*Q*wopt] + wopt'*plin + cste
c
c-----------------------------------------------------------------------
      subroutine skgenopt ( n, qlin, rho, omega0, Q, ndual, dual,
     &                      neq, nin, ccst, bcst, cinf, csup,
     &                      iwork, dwork,
     &                      wopt, info)
c-----------------------------------------------------------------------
c
c     INPUT
c       n       : number of values                               integer
c       qlin    : vector(n) linear part of the objective funtcion double
c       rho     : mean returns (n)                                double
c       omega0  : vector(n) second order portfolio                double
c       Q     : semi definite matrix (n*n)                        double
c       ndual   : number of variables                            integer
c       dual   : dual solution lambda (ndual)                     double
c       neq     : number equality constraints                    integer
c       nin     : number inequality constraints                  integer
c       ccst    : matrix of constraints (n*(neq+nin))             double
c       bcst    : vector initial of constraints (neq+nin)         double
c       cinf    : lower bound (n)                                 double
c       csup    : upper bound (n)                                 double
c
c     WORKSPACE
c       iwork   : 3*n + 2*nin + neq + 1                           integer
c       dwork   : 2*n*n + 8*n + neq + 3*nin -array                 double
c
c
c     OUTPUT
c       wopt    : optimal portfolio (n)                            double
c       info    : diagnostic argument                             integer
c
c     CALL
c
c       buildthgen, qp
c
c-----------------------------------------------------------------------
c
      implicit none

c     Input arguments
      integer n, info, ndual, neq, nin
      double precision qlin(*), rho(*), Q(*), ccst(*), bcst(*)
      double precision dual(*), omega0(*), cinf(*), csup(*)
c     Output arguments
      double precision wopt(*)
c     Workspace
      double precision dwork(*)
      integer pdw, pdcov, pdlin, pdlagr

      integer iwork(*)
      integer piw

c     Local variables
      double precision var , opone, scal, lin, perf
c     Integer workspace
      piw = 1
c     needs 3*n + 2*nin + neq + 1
c       so 3*n + 2*nin + neq + 1
c     Total size is 3*n + 2*nin + neq + 1

c     Double workspace
      pdcov = 1
c     needs n*n
c        so n*n
      pdlin = pdcov + n*n
c     needs n
c        so n*n + n
      pdlagr = pdlin + n
c     needs n + neq + nin
c        so n*n + 2*n +neq +nin
      pdw = pdlagr + n + neq + nin
c     needs 3*n for buildthgen
c           n*n + 6*n + 2*nin for quapro
c
c     Total size is 2*n*n + 8*n + neq + 3*nin

       call buildthgen ( n, qlin, rho, omega0, Q, ndual, dual,
     &                   dwork(pdw), dwork(pdcov), dwork(pdlin))

       call qp ( n, dwork(pdcov), dwork(pdlin),
     &           neq, nin, ccst, bcst,
     &           cinf, csup, iwork(piw), dwork(pdw), dwork(pdlagr),
     &           wopt, info)
c
      return
      end


      function elem(m,n,k,l)
c
c compute the matrix element on h.o. states
c             + k    l
c     < m | (a )  (a)  | n >
c
c     implicit double precision (a-h,o-z)
      elem=0.
      if(n-l.ne.m-k) go to 90
      if(m.le.k-1) go to 90
      if(n.le.l-1) go to 90
      elem=1.
   10 if(l.eq.0) go to 20
      do i=1,l
        x=n-i+1
        elem=elem*sqrt(x)
      end do
   20 if(k.eq.0) go to 90
      do j=1,k
        y=n-l+j
        elem=elem*sqrt(y)
      end do
   90 continue
      return
      end


      SUBROUTINE GARCHLLH(N, Y, Z, H, NF, X, DPARM, MDIST, MYPAR, F)

      IMPLICIT NONE

C     DECLARATION OF ARGUMENTS
      INTEGER N
      DOUBLE PRECISION Y(N), Z(N), H(N)
      INTEGER NF
      DOUBLE PRECISION X(NF)
      DOUBLE PRECISION DPARM(3)
      INTEGER MDIST
      INTEGER MYPAR(11)
      DOUBLE PRECISION F

C     LOCAL VARIABLE
      INTEGER INITREC, LEVERAGE, INCMEAN, INCDELTA ,INCSKEW, INCSHAPE
      INTEGER NR, NS, NP, NQ, NORM
      DOUBLE PRECISION XMEAN, XOMEGA, XDELTA, XSKEW, XSHAPE
      INTEGER IAR, IMA, IOMEGA, IALPHA, IBETA, IDELTA, ISKEW, ISHAPE

      INTEGER I, NEXT, IP, IQ, IR
      DOUBLE PRECISION SUMALPHA, SUMBETA, PERSISTENCE
      DOUBLE PRECISION VAR, ZI, ZZ, HH, LLH, DD
      DOUBLE PRECISION XINVD

C     EXTRENAL FUNC
      DOUBLE PRECISION DLOG, DIST

C     MYPAR
      INITREC  = MYPAR(1)
      LEVERAGE = MYPAR(2)
      INCMEAN  = MYPAR(3)
      INCDELTA = MYPAR(4)
      INCSKEW  = MYPAR(5)
      INCSHAPE = MYPAR(6)
      NR = MYPAR(7)
      NS = MYPAR(8)
      NP = MYPAR(9)
      NQ = MYPAR(10)
      NORM = MYPAR(11)

C     DPARM
      XDELTA = DPARM(1)
      XSKEW  = DPARM(2)
      XSHAPE = DPARM(3)

C     VECTOR START POSITIONS:
      IAR    = INCMEAN + 1
      IMA    = INCMEAN+NR + 1
      IOMEGA = INCMEAN+NR+NS + 1
      IALPHA = INCMEAN+NR+NS+1 + 1
      IBETA  = INCMEAN+NR+NS+1+NP*(1+LEVERAGE) + 1
      IDELTA = INCMEAN+NR+NS+1+NP*(1+LEVERAGE)+NQ + 1
      ISKEW  = INCMEAN+NR+NS+1+NP*(1+LEVERAGE)+NQ+INCDELTA + 1
      ISHAPE = INCMEAN+NR+NS+1+NP*(1+LEVERAGE)+NQ+INCDELTA+INCSKEW+1

C     TODO
C     INCLUDE MEAN?
      IF (INCMEAN.EQ.1) THEN
          XMEAN = X(1)
      ELSE
          XMEAN = 0.0D0
      END IF

C     INCLUDE DELTA ?
      IF (INCDELTA.EQ.1) THEN
          XDELTA = X(IDELTA)
      END IF
      XINVD = 1.0D0/XDELTA

C     INCLUDE SKEW ?
      IF (INCSKEW.EQ.1) THEN
          XSKEW = X(ISKEW)
      END IF

C     INCLUDE SHAPE ?
      IF (INCSHAPE.EQ.1) THEN
          XSHAPE = X(ISHAPE)
      END IF

C     POSTION OMEGA:
      XOMEGA = X(IOMEGA)

C     ARMA RECURSION:
      DO I = 1, MAX(NR,NS)
         Z(I) = 0.0D0
      END DO
      DO I = MAX(NR,NS)+1, N
         Z(I) = Y(I) - XMEAN
         NEXT = IAR
         DO IR = 1, NR, 1
            Z(I) = Z(I) - X(NEXT)*Y(I-IR)
            NEXT = NEXT + 1
         END DO
         NEXT = IMA
         DO IR = 1, NS, 1
            Z(I) = Z(I) - X(NEXT)*Z(I-IR)
            NEXT = NEXT + 1
         END DO
      END DO

C     COMPUTE (UNLEVERAGED) PERSISTENCE:
      SUMALPHA = 0.0D0
      NEXT = IALPHA
      DO IP = 1, NP, 1
         SUMALPHA = SUMALPHA + X(NEXT)
         NEXT = NEXT + 1
      END DO
      NEXT = IBETA
      SUMBETA = 0.0D0
      DO IP = 1, NQ, 1
         SUMBETA = SUMBETA + X(NEXT)
         NEXT = NEXT + 1
      END DO
      PERSISTENCE = SUMALPHA + SUMBETA

C     INITIALZE RECURSION - 1 (FCP) | 2 (TSP) LIKE:
      IF (INITREC.EQ.1) THEN
         VAR = 0.0D0
         DO I = 1, N
            VAR = VAR + Z(I)**2
         END DO
         VAR = VAR/N
      END IF
      IF (INITREC.EQ.2) THEN
         VAR = XOMEGA/(1.0D0-PERSISTENCE)
      END IF

C     ITERATE H:
      DO I = 1, MAX(NP,NQ)
         H(I) = XOMEGA + PERSISTENCE*VAR
      END DO
      IF (LEVERAGE.EQ.1) THEN
          DO I = MAX(NP,NQ)+1, N
             H(I) = XOMEGA
             NEXT = IALPHA
             DO IP = 1, NP, 1
                ZI = DABS(Z(I-IP))-X(NEXT+NP)*Z(I-IP)
                H(I) = H(I) + X(NEXT)*DABS(ZI)**XDELTA
                NEXT = NEXT + 1
             END DO
             NEXT = IBETA
             DO IQ = 1, NQ, 1
                H(I) = H(I) + X(NEXT)*H(I-IQ)
                NEXT = NEXT + 1
             END DO
          END DO
      ELSE
          DO I = MAX(NP,NQ)+1, N
             H(I) = XOMEGA
             NEXT = IALPHA
             DO IP = 1, NP, 1
                H(I) = H(I) + X(NEXT)*DABS(Z(I-IP))**XDELTA
                NEXT = NEXT + 1
             END DO
             NEXT = IBETA
             DO IQ = 1, NQ, 1
                H(I) = H(I) + X(NEXT)*H(I-IQ)
                NEXT = NEXT + 1
             END DO
          END DO
      END IF

C     COMPUTE LIKELIHOOD:
      LLH = 0.0D0
      DO I = 1, N
         ZZ = Z(I)
         HH = DABS(H(I))**XINVD
         DD = DLOG( DIST(ZZ, HH, XSKEW, XSHAPE, MDIST) )
         LLH = LLH - DD
      END DO
      F = LLH

      RETURN
      END


!! FORTRAN ROUTINES TO DO QUICK WORK ON LOOPS IN HALOMODEL
module hod_routines
contains

subroutine simps(dx, func,val)
    implicit none
    !!simps works on functions defined at EQUIDISTANT values of x only

    real(8), intent(in) :: dx      !The grid spacing
    real(8), intent(in) :: func(:) !The function
    real(8), intent(out):: val     !The value of the integral

    integer :: n !length of func
    integer :: i,end
    real(8) :: endbit

    n = size(func)

    if (mod(n,2)==0) then
        end =  n-1
        endbit = (func(n)+func(n-1))*dx/2
    else
        end=n
        endbit=0.d0
    end if

    val = sum(func(1:end-2:2) + func(3:end:2) + 4*func(2:end-1:2))
    val = val*dx/3 + endbit
end subroutine simps

subroutine trapz(dx,func,val)
    implicit none
    !!trapz works on functions defined at EQUIDISTANT values of x only

    real(8), intent(in) :: dx !The grid spacing
    real(8), intent(in) :: func(:) !The function
    real(8), intent(out) :: val !The value of the integral

    integer :: n !length of func
    integer :: i

    val = func(1)+func(n)
    do i=2,n-1
        val = val + 2*func(i)
    end do
    val = val*dx/2
end subroutine

!!!!!!!!!!!!! START ACTUAL CALLED ROUTINES !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine power_gal_2h(nlnk,nm,u,bias,nsat,ncen,dndm,mass,power)
    implicit none

    integer, intent(in) :: nlnk, nm !Size of lnk and mass arrays respectively
    real(8), intent(in) :: bias(nm), nsat(nm),ncen(nm),dndm(nm), mass(nm)
    real(8), intent(in) :: u(nlnk,nm)

    real(8), intent(out):: power(nlnk)

    real(8) ::mass_part(nm)
    integer :: i
    real(8) :: integrand(nm),dm

    integrand = 0.d0
    dm = log(mass(2))-log(mass(1))

    mass_part = ncen*dndm*bias*mass
    do i=1,nlnk
        integrand = (1.d0+u(i,:) *nsat)*mass_part !multiply by mass as we integrate in log-space
        call simps(dm,integrand,power(i))
      !  if (i==nlnk) then
      !      write(*,*) maxval(integrand),minval(integrand)
      !      write(*,*) maxval(mass_part/mass),minval(mass_part/mass)
      !      write(*,*) maxval(u(i,:)),minval(u(i,:))
      !  end if
    end do

end subroutine

subroutine power_gal_1h_ss(nlnk,nm,u,dndm,nsat,ncen,mass,central,power)
    implicit none

    integer, intent(in) :: nlnk, nm !Size of lnk and mass arrays respectively
    real(8), intent(in) :: ncen(nm),nsat(nm),dndm(nm), mass(nm)
    real(8), intent(in) :: u(nlnk,nm)
    logical, intent(in) :: central

    real(8), intent(out):: power(nlnk)

    integer :: i
    real(8) :: integrand(nm),dm
    integrand = 0.d0

    dm = log(mass(2))-log(mass(1))

    do i=1,nlnk
        if (central)then
            integrand = ncen*nsat**2 * u(i,:)**2*dndm*mass
        else
            integrand = nsat**2 * u(i,:)**2 *dndm*mass
        end if
        call simps(dm,integrand,power(i))
    end do
end subroutine

subroutine corr_gal_1h_ss(nr,nm,mass,dndm,ncen,nsat,lam,central,corr)
    implicit none

    integer, intent(in) :: nr,nm
    real(8), intent(in) :: mass(nm), ncen(nm),nsat(nm),dndm(nm)
    real(8), intent(in) :: lam(nr,nm)
    logical, intent(in) :: central

    real(8), intent(out) :: corr(nr)

    integer :: i
    real(8) :: integrand(nm),dm
    integrand = 0.d0
    dm = log(mass(2))-log(mass(1))

    do i=1,nr
        if (central)then
            integrand = dndm*ncen*nsat**2*lam(i,:)/mass !Not mass**2 since int in log space
        else
            integrand = dndm*nsat**2*lam(i,:)/mass
        end if

        call simps(dm,integrand,corr(i))
    end do
end subroutine

subroutine corr_gal_1h_cs(nr,nm,r,mass,dndm,ncen,nsat,rho,mean_dens,delta_halo,corr)
    implicit none

    integer, intent(in) :: nr,nm
    real(8), intent(in) :: r(nr), mass(nm), ncen(nm),nsat(nm),dndm(nm)
    real(8), intent(in) :: rho(nr,nm),mean_dens,delta_halo

    real(8), intent(out) :: corr(nr)

    integer :: i
    real(8) :: mmin
    real(8) :: integrand(nm),dm

    dm = log(mass(2))-log(mass(1))

    do i=1,nr
        integrand = 0.d0
        mmin = 4*3.14159265*r(i)**3*mean_dens*delta_halo/3
        where (mass>mmin) integrand = dndm*2*ncen*nsat*rho(i,:)*mass !*mass since in logspace
        call simps(dm,integrand,corr(i))
    end do
end subroutine

subroutine corr_gal_1h(nr,nm,r,mass,dndm,ncen,nsat,rho,lam,central,mean_dens,delta_halo,corr)
    implicit none

    integer, intent(in) :: nr,nm
    real(8), intent(in) :: r(nr), mass(nm), ncen(nm),nsat(nm),dndm(nm)
    real(8), intent(in) :: rho(nr,nm),mean_dens,delta_halo
    real(8), intent(in) :: lam(nr,nm)
    logical, intent(in) :: central

    real(8), intent(out) :: corr(nr)

    integer :: i,j
    real(8) :: mmin
    real(8) :: integrand(nm),dm

    dm = log(mass(2))-log(mass(1))

    !Integrating in log-space, so everything is multiplied by mass
    do i=1,nr
        integrand = 0.d0
        if (central)then
            integrand = dndm*ncen*nsat**2*lam(i,:)
        else
            integrand = dndm*nsat**2*lam(i,:)
        end if

        mmin = 4*3.14159265*r(i)**3*mean_dens*delta_halo/3

        where (mass>mmin) integrand = integrand+dndm*2*ncen*nsat*rho(i,:)

        integrand = integrand * mass
        call simps(dm,integrand,corr(i))
    end do
end subroutine

subroutine get_subfind_centres(nhalos,npart,groupoffsets,grouplen,pos,centres)
    implicit none
    !This is here because of a potentially very large loop.

    integer, intent(in) :: nhalos,npart
    integer, intent(in) :: groupoffsets(nhalos), grouplen(nhalos)
    real, intent(inout) :: pos(npart,3)

    real, intent(out) :: centres(nhalos,3)

    integer :: i,j,a,b
    real :: boxsize

    boxsize = ceiling(maxval(pos))

    do i=1,nhalos
        a = groupoffsets(i) + 1
        b = groupoffsets(i) + grouplen(i)

        ! First calculate a centre
        !centres(i,:) = sum(pos(a:b,:))/grouplen(i)

        do j=1,3
            where ((pos(a:b,j)-minval(pos(a:b,j)))>boxsize/2) pos(a:b,j) = pos(a:b,j) - boxsize
            centres(i,j) = sum(pos(a:b,j))/grouplen(i)
        end do

        if (i==nhalos) then
            write(*,*) centres(i,:)
        end if
        do j=1,3
            if (centres(i,j)<0.0)then
                centres(i,j) = centres(i,j) + boxsize
            end if
        end do
    end do

end subroutine
end module


	program ftr
	implicit doubleprecision (a-h,o-z)
	dimension w(20000),t(20000)
	complex*16 ac(20000),ft(20000),ci,te
	real*4 a1,a2,a3,a4,a5
	character*32 fil1,fil2,fil3
	ci=(0.d0,1.d0)
	open(20,file='ftr_in',status='old')
	read(20,*) nm,beta
	read(20,*) fil1,fil2
        open(25,file=fil1,status='old')
        open(26,file=fil2)
c       energy  units
	eu=27.2d0/1836.15
	emx=50d0
	write(*,*) 'energy unit',eu

	do 1 i=1,nm
	  read(25,1000) x1,ac(i),x2
	 t(i)=x1
1	continue
	ac(1)=ac(1)/2.d0
	ac(nm)=ac(nm)/2.d0
c-------- damp the signal ----------------
        beta=-log(beta/x2)/t(nm)**2
        do 21 i=1,nm
21       ac(i)=ac(i)*exp(-beta*t(i)**2)

	pi=4.d0*atan(1.d0)
	dt=abs(t(2)-t(1))
	write(*,*) dt,nm
	h=0.5d0/nm/dt*pi
	nw=emx/h
	write(*,*) h,nw

	do 3 i=1,nw
	  w(i)=h*i
3	continue

	do 2 k=1,nw
	  ft(k)=(0.d0,0.d0)
	  do 4 i=1,nm
	    te=exp(ci*w(k)*t(i))
4	    ft(k)=ac(i)*te+ft(k)
c	  fin=dreal(ft(k))*dt
	  fin=abs(ft(k))*dt
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
          write(26,1000) w(k),fin,ft(k)*dt
2	  continue

1001    format(20(e14.5,1x))
1000    format(20(e14.7,1x))
	stop
	end


program modecoupmat_square

  use fieldinfo_
  use sub_
  implicit none

  integer :: np,np2,i,j,i1,j1
  real ::  lx,ly,labs,num(npmax),fac
  double precision :: dmat(npmax2),mat(npmax,npmax2)
  character ::  outf*100

  call getarg(1,outf)
  call binninginit

  mat=0.d0
  num=0.

  write(*,*) 'Start computing the convolution matrix due to a square patch of sky'

  do j=1,nj/2+1
     j1 = j-1
     write(*,*) j,'/',nj/2+1
     do i=j,ni/2+1
        i1 = i-1

        lx=float(i1)/rad1*(2.*pi)
        ly=float(j1)/rad2*(2.*pi)
        labs=sqrt(lx*lx+ly*ly)

        if (labs<llowbin(1)) cycle
        if (labs>=llowbin(npmax+1)) cycle

        np=1
        do while (labs>=llowbin(np))
           np=np+1
        enddo
        np=np-1

        call matcomp(lx,ly,dmat)

        if ((j1==0).or.(i1==j1)) then
           fac=1.
        else
           fac=2.
        endif

        do np2=1,npmax2
           mat(np,np2)=mat(np,np2)+dmat(np2)*fac
        enddo
        num(np)=num(np)+fac

     enddo
  enddo

  do np=1,npmax
     do np2=1,npmax2
        if (num(np)>0) then
           mat(np,np2)=mat(np,np2)/num(np)
        else
           if (np==np2) mat(np,np2)=1.d0
        endif
     enddo
  enddo

  call outmat(outf,mat)

contains

  subroutine matcomp(qx,qy,dmat)

    use fieldinfo_
    implicit none

    integer ::  ik,is,ismax,np
    real ::  qx,qy,q,cosi,sini,ds,theta,kpara,kperp,labs,pbl,qbl,s2,c2
    real ::  kx,ky,winx,winy,win,rx,ry,gx,gy
    integer :: ikmax1,ikmax
    integer, parameter :: iklim=ni*100
    real ::  kf,knyq,kmax,dk1,kmax1,dk2,k(iklim),dk(iklim)
    double precision ::  dmat(npmax2)

    q=sqrt(qx*qx+qy*qy)
    cosi=qx/q
    sini=qy/q

    pbl=q*q/2./pi

!  integral range of k is set from 0 to knyq/5.
!  From 0 to kf*4, binning width is kf/100.
!  From kf*4 to knyq/5, binning width is kf/4.

    kf=2.*pi/rad1
    knyq=kf*(ni/2)

    kmax=knyq/5.
    dk1=kf/100.
    ikmax1=400
    kmax1=dk1*ikmax1
    dk2=kf/4.
    ikmax=ikmax1+nint((kmax-kmax1)/dk2)

    do ik=1,ikmax1
       dk(ik)=dk1
       k(ik)=dk1*(ik-0.5)
    enddo

    do ik=ikmax1+1,ikmax
       dk(ik)=dk2
       k(ik)=kmax1+dk2*(ik-ikmax1-0.5)
    enddo

    dmat=0.d0

    do ik=1,ikmax
       ismax=2*max(ik,200)
       ds=2.*pi/ismax
       do is=1,ismax
          theta=ds*(is-1.)
          kpara=k(ik)*cos(theta)
          kperp=k(ik)*sin(theta)
          labs=sqrt(q*q+k(ik)*k(ik)+2.*kpara*q)

          qbl=2.*pi/labs/labs

          s2=(kperp/labs)**2
          c2=1.-s2

          kx=kpara*cosi-kperp*sini
          ky=kpara*sini+kperp*cosi

          rx=nint((qx+kx)/kf)*kf
          ry=nint((qy+ky)/kf)*kf

          labs=sqrt(rx*rx+ry*ry)

          if (labs<llowbin(1)) cycle
          if (labs>=llowbin(npmax+1)) cycle

          np=1
          do while (labs>=llowbin(np))
             np=np+1
          enddo
          np=np-1

          gx=kx/kf
          gy=ky/kf
          call recwin(gx,ni,winx)
          call recwin(gy,nj,winy)
          winx=winx/kf
          winy=winy/kf
          win=winx*winy
          dmat(np)=dmat(np)+k(ik)*dk(ik)*ds*(c2-s2)*(c2-s2)*win*qbl
          dmat(np+npmax)=dmat(np+npmax)+k(ik)*dk(ik)*ds*4*s2*c2*win*qbl
       enddo
    enddo

    dmat=dmat*pbl

  end subroutine matcomp

  subroutine recwin(s,nd,win)

    implicit none
    integer :: nd
    real :: s,win,spi
    real, parameter :: pi=3.14159265358979

    if (abs(s)<1.e-10) then
       win=1.
    else
       spi=s*pi
       win=(sin(spi)/(spi))/(sin(spi/nd)/(spi/nd))
       win=win*win
    endif

  end subroutine recwin

  subroutine recwin2(s,nd,win)

    implicit none
    integer :: nd
    real :: s,win,spi
    real, parameter :: pi=3.14159265358979

    if (abs(s)<1.e-10) then
       win=1./4.
    else
       spi=s*pi
       win=(sin(spi/2.)/(spi))/(sin(spi/nd)/(spi/nd))
       win=win*win
    endif

  end subroutine recwin2

  subroutine welchwin(s,nd,win)

    implicit none
    integer :: nd
    real :: s,win,spi,spind
    real, parameter :: pi=3.14159265358979

    if (abs(s)<1.e-10) then
       win=4./9.
    else
       spi=s*pi
       spind=spi/nd
       win=(cos(spi)-(sin(spi)/sin(spind)/nd))/(sin(spind)*nd)**2
       win=4.*win*win
    endif

  end subroutine welchwin

  subroutine outmat(outf,mat)

    use fieldinfo_
    implicit none
    integer :: np,np2
    double precision :: mat(npmax,npmax2)
    character :: outf*100

    write(*,*) 'output file: ',outf(1:len_trim(outf))

    open(2,file=outf,status='unknown')
    do np=1,npmax
       do np2=1,npmax2
          write(2,*) np,np2,mat(np,np2)
       enddo
       do np2=npmax2+1,npmax3
          write(2,*) np,np2,0.d0
       enddo
       write(2,*)
    enddo

    do np=npmax+1,npmax2
       do np2=1,npmax
          write(2,*) np,np2,mat(np-npmax,np2+npmax)
       enddo
       do np2=npmax+1,npmax2
          write(2,*) np,np2,mat(np-npmax,np2-npmax)
       enddo
       do np2=npmax2+1,npmax3
          write(2,*) np,np2,0.d0
       enddo
       write(2,*)
    enddo

    do np=npmax2+1,npmax3
       do np2=1,npmax2
          write(2,*) np,np2,0.d0
       enddo
       do np2=npmax2+1,npmax3
          write(2,*) np,np2,mat(np-npmax2,np2-npmax2)-mat(np-npmax,np2-npmax2)
       enddo
       write(2,*)
    enddo
    close(2)

  end subroutine outmat

end program Modecoupmat_square


c ======================================================================
c User Subroutine UMAT for Abaqus viscoelastic material
c By Irfan Habeeb CN (PhD, Technion - IIT)
c using the formulation https://imechanica.org/files/Kelvin-Voigt-Code-Development_0.pdf
c ======================================================================
      subroutine umat(stress,statev,ddsdde,sse,spd,scd,
     1 rpl,ddsddt,drplde,drpldt,
     2 stran,dstran,time,dtime,temp,dtemp,predef,dpred,cmname,
     3 ndi,nshr,ntens,nstatv,props,nprops,coords,drot,pnewdt,
     4 celent,dfgrd0,dfgrd1,noel,npt,layer,kspt,kstep,kinc)
C
      include 'aba_param.inc'
C
      character*80 cmname
      dimension stress(ntens),statev(nstatv),
     1 ddsdde(ntens,ntens),
     2 ddsddt(ntens),drplde(ntens),
     3 stran(ntens),dstran(ntens),time(2),predef(1),dpred(1),
     4 props(nprops),coords(3),drot(3,3),dfgrd0(3,3),dfgrd1(3,3)
C
      integer k1, k2
      real E, nu, lambda, mu, S(6), D1(6,6), D2(6,6), D3(6,6)

C material properties
      E = props(1)      ! Young's modulus
      nu = props(2)      ! Poisson's ratio
      eta = props(3)    ! viscoelastic coef.

C Lame's parameters
      lambda = E*nu/((1.0d0+nu)*(1.0d0-2.0d0*nu))
      mu = E/(2.0d0*(1.0d0+nu))

c stiffness matrix with viscous effects
      D1 = 0.d0
      D2 = 0.d0
      D3 = 0.d0
      if (dtime .gt. 0.d0) then
        do k1 = 1, ndi
          do k2 = 1, ndi
            D1(k1, k2) = lambda*(1.0d0 + 3.0d0*eta/(E*dtime))
            D2(k1, k2) = lambda
          end do
          D1(k1, k1) = lambda*(1.0d0 + 3.0d0*eta/(E*dtime)) +
     1      2.0d0*mu*(1.0d0 + eta/(mu*dtime))
          D2(k1, k1) = lambda + 2.0d0*mu
          D3(k1, k1) = -1.0d0
        end do
c shear stress
        do k1 = ndi+1, ndi+nshr
          D1(k1, k1) = mu*(1.0d0 + eta/(mu*dtime))
          D2(k1, k1) = mu
          D3(k1, k1) = -1.0d0
        end do
      else
        do k1 = 1, ndi
          do k2 = 1, ndi
            D1(k1, k2) = lambda
            D2(k1, k2) = lambda
          end do
          D1(k1, k1) = lambda + 2.0d0*mu
          D2(k1, k1) = lambda + 2.0d0*mu
          D3(k1, k1) = -1.0d0
        end do
        do k1 = ndi+1, ndi+nshr
          D1(k1, k1) = mu
          D2(k1, k1) = mu
          D3(k1, k1) = -1.0d0
        end do
      end if

c Stiffness matrix
      ddsdde(1:ntens, 1:ntens) = D1(1:ntens, 1:ntens)

c stress in the previous step
      S(1:ntens) = stress(1:ntens)

c Stress increment
      do k1 = 1, ntens
        do k2 = 1, ntens
          stress(k1) = stress(k1) + D1(k1, k2) * dstran(k2) +
     1      D2(k1, k2) * stran(k2) + D3(k1, k2) * S(k2)
        end do
      end do
c
      return
      end


!----------------------
!  Conway Game of Life
!    serial version
!----------------------

! This source code is from https://www.citutor.org

program life

  implicit none
  integer, parameter :: ni=250, nj=250, nsteps = 10000
  integer :: i, j, n, im, ip, jm, jp, nsum, isum
  integer, allocatable, dimension(:,:) :: old, new
  real :: arand

  ! allocate arrays, including room for ghost cells

  allocate(old(0:ni+1,0:nj+1), new(0:ni+1,0:nj+1))

  ! initialize elements of old to 0 or 1

  do j = 1, nj
     do i = 1, ni
        call random_number(arand)
        old(i,j) = nint(arand)
     enddo
  enddo

  !  iterate

  time_iteration: do n = 1, nsteps

     ! corner boundary conditions

     old(0,0) = old(ni,nj)
     old(0,nj+1) = old(ni,1)
     old(ni+1,nj+1) = old(1,1)
     old(ni+1,0) = old(1,nj)

     ! left-right boundary conditions

     old(1:ni,0) = old(1:ni,nj)
     old(1:ni,nj+1) = old(1:ni,1)

     ! top-bottom boundary conditions

     old(0,1:nj) = old(ni,1:nj)
     old(ni+1,1:nj) = old(1,1:nj)

     do j = 1, nj
        do i = 1, ni

           im = i - 1
           ip = i + 1
           jm = j - 1
           jp = j + 1
           nsum = old(im,jp) + old(i,jp) + old(ip,jp) &
                + old(im,j )             + old(ip,j ) &
                + old(im,jm) + old(i,jm) + old(ip,jm)

           select case (nsum)
           case (3)
              new(i,j) = 1
           case (2)
              new(i,j) = old(i,j)
           case default
              new(i,j) = 0
           end select

        enddo
     enddo

     ! copy new state into old state

     old = new

  enddo time_iteration

  ! Iterations are done; sum the number of live cells

  isum = sum(new(1:ni,1:nj))

  ! Print final number of live cells.

  write(*,*)"Number of live cells = ",isum

  deallocate(old, new)

end program life


    program demo_ceiling
    implicit none
    real :: x = 63.29
    real :: y = -63.59
       print *, ceiling(x)
       print *, ceiling(y)
       ! elemental
       print *,ceiling([ &
       &  -2.7,  -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, &
       &  0.0,   &
       &  +0.5,  +1.0, +1.5, +2.0, +2.2, +2.5, +2.7  ])
    end program demo_ceiling


      SUBROUTINE interp(uf,uc,nf)
      INTEGER nf
      DOUBLE PRECISION uc(nf/2+1,nf/2+1),uf(nf,nf)
      INTEGER ic,if,jc,jf,nc
      nc=nf/2+1
      do 12 jc=1,nc
        jf=2*jc-1
        do 11 ic=1,nc
          uf(2*ic-1,jf)=uc(ic,jc)
11      continue
12    continue
      do 14 jf=1,nf,2
        do 13 if=2,nf-1,2
          uf(if,jf)=.5d0*(uf(if+1,jf)+uf(if-1,jf))
13      continue
14    continue
      do 16 jf=2,nf-1,2
        do 15 if=1,nf
          uf(if,jf)=.5d0*(uf(if,jf+1)+uf(if,jf-1))
15      continue
16    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/interp.for


#include "scalar.fpp"

!=====================================================================!
! Module defining all constants used
!=====================================================================!

module constants

  use iso_fortran_env

  implicit none

  ! Floating precision
  integer, parameter :: SP = REAL32
  integer, parameter :: DP = REAL64
  integer, parameter :: QP = REAL128

  ! Set the working precision
  integer, parameter :: WP = DP

  ! Versioning numbers
  integer, parameter :: VERSION_MAJOR   = 0
  integer, parameter :: VERSION_MINOR   = 0
  integer, parameter :: VERSION_RELEASE = 0

  ! Physical constants
  type(scalar), parameter :: PI = 4.0_WP*atan(1.0_WP)
  !3.141592653589793238462643383279502884197169399375105820974944592307816406286
  !3.1415926535897931

  ! Handy double numbers
  type(scalar), parameter :: &
       LARGE        = huge(0.0_WP),       & ! biggest floating number
       TINY         = epsilon(0.0_WP),    & ! smallest floating number
       ZERO         = 0.0_WP,             & ! zero
       ONE          = 1.0_WP,             & ! one
       TWO          = 2.0_WP,             & ! two
       HALF         = 0.5_WP                ! half

  ! Maximum number of words in a single line, length of line, and
  ! length of single word
  integer, parameter :: MAX_WORDS    = 500
  integer, parameter :: MAX_LINE_LEN = 250
  integer, parameter :: MAX_WORD_LEN = 150

  ! Unit numbers
  integer, parameter :: LOG_UNIT = 6 ! unit # for writing log file

end module constants


      subroutine elastic_energy(ele, qe)

       use mod_parameters
	  common/custr/   sign1(nelemg),sign2(nelemg),
     > sign3(nelemg),sign4(nelemg)
	  common/wblock12/ Y_modulus(nume),possion_ratio(nume),tau_y(nume)
	  common/range/   mft,mlt,lft,llt,nftm1

	  integer nftm1, ink, ele
	  real E, v, Y_modulus, possion_ratio
	  real epx, epy, epxy, qe

	  qe=0.0
	  ink=ele+nftm1
	  E=Y_modulus(ink)
	  v=possion_ratio(ink)

	  epx=(1+v)/E*((1-v)*sign1(ele)-v*sign2(ele))
	  epy=(1+v)/E*(-v*sign1(ele)+(1-v)*sign2(ele))
	  epxy=(1+v)/E*2*sign4(ele)

	  qe=(sign1(ele)*epx+sign2(ele)*epy+sign4(ele)*epxy)/2.0

	  end


      subroutine GSRBHELMHOLTZVC1D(
     &           phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0
     &           ,irhshi0
     &           ,nrhscomp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,dx
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0
     &           ,iaCoefhi0
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0
     &           ,ibCoef0hi0
     &           ,nbCoef0comp
     &           ,lambda
     &           ,ilambdalo0
     &           ,ilambdahi0
     &           ,nlambdacomp
     &           ,redBlack
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0
      integer irhshi0
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           0:nrhscomp-1)
      integer iregionlo0
      integer iregionhi0
      REAL*8 dx
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0
      integer iaCoefhi0
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0
      integer ibCoef0hi0
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           0:nbCoef0comp-1)
      integer nlambdacomp
      integer ilambdalo0
      integer ilambdahi0
      REAL*8 lambda(
     &           ilambdalo0:ilambdahi0,
     &           0:nlambdacomp-1)
      integer redBlack
      REAL*8 dxinv,lofphi
      integer n,ncomp,indtot,imin,imax
      integer i
      ncomp = nphicomp
      if (ncomp .ne. nphicomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef0comp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp - 1
            imin = iregionlo0
            indtot = imin
            imin = imin + abs(mod(indtot + redBlack, 2))
            imax = iregionhi0
            do i = imin, imax, 2
              lofphi =
     &            alpha * aCoef(i,n) * phi(i,n)
     &          - beta  *
     &             (
     &               bCoef0(i+1,n)
     &               * (phi(i+1,n)-phi(i  ,n))
     &             - bCoef0(i  ,n)
     &               * (phi(i  ,n)-phi(i-1,n))
     &             ) * dxinv
              phi(i,n) = phi(i,n)
     &          - lambda(i,n) * (lofphi - rhs(i,n))
            enddo
      enddo
      return
      end
      subroutine VCCOMPUTEOP1D(
     &           lofphi
     &           ,ilofphilo0
     &           ,ilofphihi0
     &           ,nlofphicomp
     &           ,phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0
     &           ,iaCoefhi0
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0
     &           ,ibCoef0hi0
     &           ,nbCoef0comp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,dx
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nlofphicomp
      integer ilofphilo0
      integer ilofphihi0
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0,
     &           0:nlofphicomp-1)
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0
      integer iaCoefhi0
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0
      integer ibCoef0hi0
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           0:nbCoef0comp-1)
      integer iregionlo0
      integer iregionhi0
      REAL*8 dx
      REAL*8 dxinv
      integer n,ncomp
      integer i
      ncomp = nphicomp
      if (ncomp .ne. nlofphicomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef0comp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do i = iregionlo0,iregionhi0
          lofphi(i,n) =
     &        alpha * aCoef(i,n) * phi(i,n)
     &      - beta  *
     &         (
     &           bCoef0(i+1,n)
     &           * (phi(i+1,n) - phi(i  ,n))
     &         - bCoef0(i  ,n)
     &           * (phi(i  ,n) - phi(i-1,n))
     &         ) * dxinv
      enddo
      enddo
      return
      end
      subroutine VCCOMPUTERES1D(
     &           res
     &           ,ireslo0
     &           ,ireshi0
     &           ,nrescomp
     &           ,phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0
     &           ,irhshi0
     &           ,nrhscomp
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0
     &           ,iaCoefhi0
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0
     &           ,ibCoef0hi0
     &           ,nbCoef0comp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,dx
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nrescomp
      integer ireslo0
      integer ireshi0
      REAL*8 res(
     &           ireslo0:ireshi0,
     &           0:nrescomp-1)
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0
      integer irhshi0
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           0:nrhscomp-1)
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0
      integer iaCoefhi0
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0
      integer ibCoef0hi0
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           0:nbCoef0comp-1)
      integer iregionlo0
      integer iregionhi0
      REAL*8 dx
      REAL*8 dxinv
      integer n,ncomp
      integer i
      ncomp = nphicomp
      if (ncomp .ne. nrescomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef0comp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do i = iregionlo0,iregionhi0
          res(i,n) =
     &        rhs(i,n)
     &      - (alpha * aCoef(i,n) * phi(i,n)
     &       - beta  *
     &          (
     &            bCoef0(i+1,n)
     &            * (phi(i+1,n) - phi(i  ,n))
     &          - bCoef0(i  ,n)
     &            * (phi(i  ,n) - phi(i-1,n))
     &          ) * dxinv
     &        )
      enddo
      enddo
      return
      end
      subroutine RESTRICTRESVC1D(
     &           res
     &           ,ireslo0
     &           ,ireshi0
     &           ,nrescomp
     &           ,phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0
     &           ,irhshi0
     &           ,nrhscomp
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0
     &           ,iaCoefhi0
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0
     &           ,ibCoef0hi0
     &           ,nbCoef0comp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,dx
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nrescomp
      integer ireslo0
      integer ireshi0
      REAL*8 res(
     &           ireslo0:ireshi0,
     &           0:nrescomp-1)
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0
      integer irhshi0
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           0:nrhscomp-1)
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0
      integer iaCoefhi0
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0
      integer ibCoef0hi0
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           0:nbCoef0comp-1)
      integer iregionlo0
      integer iregionhi0
      REAL*8 dx
      REAL*8 denom,dxinv,lofphi
      integer n,ncomp
      integer i
      integer ii
      ncomp = nphicomp
      dxinv = (1.0d0) / (dx*dx)
      denom = 2
      do n = 0, ncomp-1
      do i = iregionlo0,iregionhi0
          ii = i/2
          lofphi =
     &        alpha * aCoef(i,n) * phi(i,n)
     &      - beta  *
     &         (
     &           bCoef0(i+1,n)
     &           * (phi(i+1,n)-phi(i  ,n))
     &         - bCoef0(i  ,n)
     &           * (phi(i  ,n)-phi(i-1,n))
     &         ) * dxinv
          res(ii,n) = res(ii,n)
     &                            + (rhs(i,n) - lofphi) / denom
      enddo
      enddo
      return
      end
      subroutine SUMFACES(
     &           lhs
     &           ,ilhslo0
     &           ,ilhshi0
     &           ,nlhscomp
     &           ,beta
     &           ,bCoefs
     &           ,ibCoefslo0
     &           ,ibCoefshi0
     &           ,nbCoefscomp
     &           ,iboxlo0
     &           ,iboxhi0
     &           ,dir
     &           ,scale
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nlhscomp
      integer ilhslo0
      integer ilhshi0
      REAL*8 lhs(
     &           ilhslo0:ilhshi0,
     &           0:nlhscomp-1)
      REAL*8 beta
      integer nbCoefscomp
      integer ibCoefslo0
      integer ibCoefshi0
      REAL*8 bCoefs(
     &           ibCoefslo0:ibCoefshi0,
     &           0:nbCoefscomp-1)
      integer iboxlo0
      integer iboxhi0
      integer dir
      REAL*8 scale
      REAL*8 sumVal
      integer i
      integer ii
      integer n
      ii = CHF_ID(0,dir)
      do n = 0, nlhscomp-1
      do i = iboxlo0,iboxhi0
          sumVal = bCoefs(i+ii,n)
     &           + bCoefs(i   ,n)
          lhs(i,n) = lhs(i,n) + scale * beta * sumVal
      enddo
      enddo
      return
      end


      subroutine anfm03(h,ih,r,ir,z,iz,w,ipvt,n,m,ind,modo,io)
C     SUBROUTINE ANFM03(H,IH,R,IR,Z,IZ,W,IPVT,N,M,IND,MODO,IO)
C
C***********************************************************************
C                                                                      *
C                                                                      *
C     Copyright:        Eduardo Casas Renteria                         *
C                       Cecilia Pola Mendez                            *
C                                                                      *
C       Departamento de Matematicas,estadistica y Computacion          *
C       -----------------------------------------------------          *
C                       UNIVERSIDAD DE CANTABRIA                       *
C                       ------------------------                       *
C                              ENERO 1988                              *
C                                                                      *
C***********************************************************************
C
C     OBJETIVO:
C        Esta subrutina calcula  la factorizacion de  Cholesky  (LL') de
C        una matriz del tipo  Z'HZ  con pivotacion de filas y columnas.
C        En realidad calcula la factorizacion de  PZ'HZP',  donde  P  es
C        una matriz de permutacion de filas.
C
C     LISTA DE LLAMADA:
C     DE ENTRADA:
C
C        H     Matriz de dimension  (IH,N).  En  sus  N  primeras  filas
C              contiene la matriz  H. Es suficiente suministrar la parte
C              triangular inferior.El resto de la matriz no es utilizado
C
C        IH    Primera dimension de la matriz  H. IH >= N.
C
C        R     Matriz de dimension  (IR,NR), con  NR=M-IND. Si  IND > 0,
C              en sus  primeras  filas  contiene  una caja  de dimension
C              (IND,NR)  que  almacena  parte  de  la  factorizacion  ya
C              iniciada  (de la columna  IND+1  a la columna  M  de  la
C              matriz  L' de la factorizacion de  PZ'HZP').
C
C        IR    Primera dimension de la matriz  R. IR >= M.
C
C        Z     Matriz de dimension  (IZ,M).  En  las  N  primeras  filas
C              contiene la matriz  Z,(con sus columnas en orden inverso)
C
C        IZ    Primera dimension de la matriz  Z. IZ >= N.
C
C        W     Vector de trabajo de dimension n
C
C        IPVT  Vector  entero  de trabajo  de  dimension  M-IND. Informa
C              sobre  la permutacion  P  que  de entrada  puede  haberse
C              realizado :
C                 IPVT(I)=J, indica que la permutacion  coloca a la fila
C              J-esima de  Z'HZ  en el lugar  I-esimo (analogamente con
C              las columnas).
C
C        N     Numero de filas de la matriz  Z.
C
C        M     Numero de columnas de la matriz  Z.
C
C        IND   Indicador que puede tomar los valores:
C                 0  : Se comienza la factorizacion. Se procura evitar
C                      la pivotacion durante la factorizacion.
C               > 0  : La matriz  PZ'HZP' esta parcialmente factorizada.
C                      El numero de filas (de L') calculadas es igual al
C                      valor de la variable  IND.
C
C        MODO  Indicador que toma los valores:
C                 0  : No se realiza la factorizacion si la matriz es
C                      indefinida.
C              <> 0  : Se calcula la factorizacion  (total o parcial).
C
C        IO     Numero de canal de salida de resultados.
C
C     DE SALIDA:
C
C        R      Si en entrada  IND > 0, R contiene en las primeras filas
C               la caja de la factorizacion de entrada  afectada  por la
C               permutacion  P  (CP'). A partir de la fila  IND+1  tiene
C               a la  matriz triangular superior de la factorizacion de
C               Cholesky  de la caja factorizada. (La factorizacion sera
C               parcial, en el caso indefinido).
C
C        IPVT   Indica la permutacion de filas y columnas realizada al
C               factorizar.
C
C        IND    Variable entera que toma los valores:
C                  N      :    No  se ha realizado la factorizacion  por
C                              ser la matriz indefinida (y  MODO=0).
C                (-1,ND+1):    Se ha finalizado la factorizacion. ND-IND
C                              es la dimension de la parte no nula de L'
C                (-ND-1,0):    No se ha finalizado la factorizacion, por
C                              ser la matriz indefinida:se ha encontrado
C                              un elemento negativo en el lugar  -IND de
C                              la diagonal de la matriz  L'.
C                (-2*ND-1,-ND):No se ha completado la factorizacion, por
C                              ser la matriz indefinida:  L' tiene en el
C                              lugar -IND-ND  de la diagonal un elemento
C                              nulo  y  el elemento  (-ND-IND,-ND-IND+1)
C                              es no nulo.
C               donde  ND  es la dimension  de la caja  a factorizar en
C               entrada.
C
C
C        Esta subrutina trabaja en doble precision via una sentencia
C     "implicit":
C                Implicit double precision (a-h,o-z)
C
C     SUBPROGRAMAS AUXILIARES: dipvtf,ddot,d1mach,zthz
C     FUNCIONES FORTRAN INTRINSECAS: abs,max,mod,sqrt
C
C
      implicit double precision(a-h,o-z)
      dimension h(ih,*),r(ir,*),z(iz,*),w(*),ipvt(*)
C
C     Se comprueba si los valores de las variables son correctos
C
      if(ih.lt.n .or. ir.lt.m .or. iz.lt.n .or. (m-ind).lt.1 .or. ind.lt
     &   .0) then
         write(io,'(10x,A)') 'INCORRECT LIST OF CALLING IN ANFM03.'
         stop
      end if
C
C     Se inicializan algunas variables de trabajo
C
css      epsmch=d1mach(4)
      epsmch=dlamch('p')
      eps=epsmch*10.d0
      if(ind.eq.0) then
         ndim=m
         iifact=0
         do 10 i=1,ndim
10       ipvt(i)=i
      else
         ndim=m-ind
         iifact=1
      end if
      smax=1.d0
      nm1=m+1
C
C     Se calculan los elementos diagonales
C
      do 20 i=1,ndim
         if(ind.eq.0) then
            nj=nm1-i
            ii=i
         else
            nj=nm1-ipvt(i)
            ii=ind+i
         end if
         s=zthz(h,ih,z,iz,n,nj,nj)
         if(ind.gt.0) s=s-ddot(ind,r(1,i),1,r(1,i),1)
         if(modo.eq.0 .and. s.lt.-eps) then
            ind=n
            return
         end if
         r(ii,i)=s
         s=abs(s)
         smax=max(s,smax)
20    continue
C
C     Se estudia el caso unidimensional
C
      if(ndim.eq.1) then
         ik=ind+1
         s=r(ik,1)
         if(s.gt.eps) then
            r(ik,1)=sqrt(s)
            ind=0
         else if(s.lt.-eps) then
            ind=-1
         else
            ind=1
         end if
         return
      end if
C
C     Se procede a factorizar la matriz (si n > 1)
C
      eps0=epsmch*smax
      eps=eps0*ind
      beta=max(eps0*ndim*10,sqrt(smax)*1.2d0)
      iibeta=0
      s1=0
      do 80 k=1,ndim-1
         eps=eps+eps0
         kk=k+1
         ik=k
         if(ind.gt.0) ik=k+ind
         ik0=ik-1
C
C     En caso de no haberse realizado pivotacion (iifact=0), se calcula
C     el elemento diagonal siguiente o todos los elementos diagonales
C     que restan (si la caja que queda por factorizar no es definida
C     positiva)
C
         if(iifact.eq.0) then
            r(k,k)=r(k,k)-ddot(ik0,r(1,k),1,r(1,k),1)
            sk=r(k,k)
            if(s1.gt.beta .or. sk.le.eps) then
               iifact=1
               do 25 i=kk,ndim
25             r(i,i)=r(i,i)-ddot(ik0,r(1,i),1,r(1,i),1)
            end if
         else
            sk=r(ik,k)
         end if
         if(s1.gt.beta) then
            s=-1
            iibeta=1
         else if(iifact.eq.1) then
            j=k
            s=sk
            do 30 i=kk,ndim
               ii=i+ind
               rii=r(ii,i)
               if(rii.gt.s) then
                  j=i
                  s=rii
               end if
30          continue
         else
            s=sk
            j=k
         end if
C
C     Si el mayor elemento diagonal es positivo, se permutan las filas y
C     columnas adecuadas para que ocupe el lugar (ind+k,k)
C
         if(s.gt.eps) then
            if(iifact.eq.1) then
               call dipvtf(r,ir,ipvt,ik0,k,j)
               r(ind+j,j)=sk
               l=nm1-ipvt(k)
            else
               l=nm1-k
            end if
            sk=sqrt(s)
            r(ik,k)=sk
            do 35 i=1,n
               s=ddot(i,h(i,1),ih,z(1,l),1)
               if(i.lt.n) then
                  i1=i+1
                  w(i)=s+ddot(n-i,h(i1,i),1,z(i1,l),1)
               end if
35          continue
            w(n)=s
            s1=0
            do 40 i=kk,ndim
               j=nm1-ipvt(i)
               s=ddot(n,z(1,j),1,w,1)
               if(ik0.gt.0) s=s-ddot(ik0,r(1,i),1,r(1,k),1)
               rik=s/sk
               s1=max(s1,abs(rik))
               r(ik,i)=rik
               ii=i
               if(ind.gt.0) ii=ii+ind
               if(iifact.eq.1) r(ii,i)=r(ii,i)-rik*rik
40          continue
         else
C
C     Si el mayor elemento diagonal no es positivo, se busca el menor
C
            s=sk
            j=k
            do 50 i=kk,ndim
               ii=ind+i
               rii=r(ii,i)
               if(rii.lt.s) then
                  j=i
                  s=rii
               end if
50          continue
C
C      Si el menor elemento diagonal es negativo, se permutan filas y
C      columnas para que se situe en el lugar (ind+k,k)
C
            if(s.lt.-eps) then
               if(modo.eq.0) then
                  ind=n
                  return
               end if
               call dipvtf(r,ir,ipvt,ik0,k,j)
               r(ik,k)=s
               r(ind+j,j)=sk
               ind=-k
               if(iibeta.eq.1) ind=ind-10*iz
               return
            else
C
C      Si ese menor elemento  es  nulo, se averigua  como es  la matriz:
C      semidefinida positiva o indefinida
C
               do 70 j=k,ndim-1
                  nj=nm1-ipvt(j)
                  ij=j+ind
                  do 55 i=1,n
                     s1=ddot(i,h(i,1),ih,z(1,nj),1)
                     if(i.lt.n) then
                        i1=i+1
                        w(i)=s1+ddot(n-i,h(i1,i),1,z(i1,nj),1)
                     end if
55                continue
                  w(n)=s1
                  do 60 i=j+1,ndim
                     s1=ddot(n,w,1,z(1,nm1-ipvt(i)),1)
                     if(ik0.gt.0) s1=s1-ddot(ik0,r(1,i),1,r(1,j),1)
                     r(ij,i)=s1
                     s1=abs(s1)
                     if(s1.gt.s) then
                        s=s1
                        l=i
                     end if
60                continue
C
C     En caso de ser indefinida, se hace la permutacion correspondiente
C     para colocar en el lugar (ind+k,k+1) al elemento no nulo
C
                  if(s.gt.eps) then
                     if(modo.eq.0) then
                        ind=n
                        return
                     end if
                     call dipvtf(r,ir,ipvt,ik0,j,k)
                     call dipvtf(r,ir,ipvt,ik0,l,kk)
                     r(ik,kk)=r(ij,l)
                     ind=-ndim-k
                     return
                  end if
70             continue
C
C     Se calcula el numero de elementos diagonales nulos en el caso
C     semidefinido positivo
C
               ind=ndim-k+1
               return
            end if
         end if
80    continue
C
C     Se estudia el ultimo elemento diagonal
C
      eps=eps0+eps
      in=ndim+ind
      if(iifact.eq.0) r(in,in)=r(in,in)-ddot(in-1,r(1,in),1,r(1,in),1)
      s=r(in,ndim)
      if(s.gt.eps) then
         r(in,ndim)=sqrt(s)
         ind=0
      else if(s.lt.-eps) then
         ind=-ndim
      else
         ind=1
      end if
      end


*dk,vorpoint
      subroutine vorpoint(n1,n2,n3,n4,xv,yv,zv,distsq)
       implicit real*8 (a-h,o-z)
C
C #####################################################################
C
C     PURPOSE -
C
C        This routine calculates the 3-D voronoi point
C
C     INPUT ARGUMENTS -
C
C        n1-n4  - the points in the tetrahedron
C
C
C     OUTPUT ARGUMENTS -
C
C        xv     - the x-coordinate of the Voronoi point
C        yv     - the y-coordinate of the Voronoi point
C        zv     - the z-coordinate of the Voronoi point
C        distsq - the Voronoi radius squared
C
C     CHANGE HISTORY -
C
C        $Log: vorpoint.f,v $
C        Revision 2.00  2007/11/09 20:04:06  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.4   Mon Apr 14 17:05:54 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.3   12/02/94 15:07:22   het
CPVCS    Added an option for the "cmo" access functions
CPVCS
CPVCS
CPVCS       Rev 1.2   12/01/94 18:50:00   het
CPVCS    Added a data type to the "cmo" calles
CPVCS       and added the "cmo.h" include file.
CPVCS
CPVCS       Rev 1.1   11/17/94 21:56:00   het
CPVCS    Added include files for chydro, neibor, cmerge, comdict. Added calles and
CPVCS    pointer statements for current_mesh_object database access.
CPVCS
CPVCS       Rev 1.0   11/10/94 12:20:20   pvcs
CPVCS    Original version.
C
C ######################################################################
C
      include "cmo.h"
      include "chydro.h"
      include "neibor.h"
C
C ######################################################################
C
      crosx(a,b,c,d,e,f)=b*f-c*e
      crosy(a,b,c,d,e,f)=c*d-a*f
      crosz(a,b,c,d,e,f)=a*e-b*d
C
C ######################################################################
C
C
C
C     ******************************************************************
C     FETCH MESH OBJECT NAME AND POINTER INFORMATION.
C
      if(icmoget.eq.1) then
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('xic',cmo,ipxic,lenxic,icmotype,ierror)
      call cmo_get_info('yic',cmo,ipyic,lenyic,icmotype,ierror)
      call cmo_get_info('zic',cmo,ipzic,lenzic,icmotype,ierror)
C
      endif
C
C     ******************************************************************
C
C
C
      xxsmall=1.0e-30
      xa=xic(n1)
      ya=yic(n1)
      za=zic(n1)
      xb=xic(n2)-xa
      yb=yic(n2)-ya
      zb=zic(n2)-za
      xc=xic(n3)-xa
      yc=yic(n3)-ya
      zc=zic(n3)-za
      xd=xic(n4)-xa
      yd=yic(n4)-ya
      zd=zic(n4)-za
      xn=crosx(xb,yb,zb,xc,yc,zc)
      yn=crosy(xb,yb,zb,xc,yc,zc)
      zn=crosz(xb,yb,zb,xc,yc,zc)
      x2=crosx(xn,yn,zn,xb,yb,zb)
      y2=crosy(xn,yn,zn,xb,yb,zb)
      z2=crosz(xn,yn,zn,xb,yb,zb)
      q=-0.5*(xc*xb+yc*yb+zc*zb-xc*xc-yc*yc-zc*zc)/
     *       (x2*xc+y2*yc+z2*zc+xxsmall)
      xl=q*x2+0.5*xb
      yl=q*y2+0.5*yb
      zl=q*z2+0.5*zb
      d=-0.5*(xd*xd+yd*yd+zd*zd)
      q=-(xd*xl+yd*yl+zd*zl+d)/(xd*xn+yd*yn+zd*zn+xxsmall)
      xv=q*xn+xl+xa
      yv=q*yn+yl+ya
      zv=q*zn+zl+za
      distsq=(xv-xa)**2+(yv-ya)**2+(zv-za)**2
C
      goto 9999
 9999 continue
      return
      end