! { dg-options "-O1 -fgraphite" }

MODULE powell
  INTEGER, PARAMETER :: dp=8
CONTAINS
  SUBROUTINE newuob (n,npt,x,rhobeg,rhoend,maxfun,xbase,&
       xopt,xnew,xpt,fval,gq,hq,pq,bmat,zmat,ndim,d,vlag,w,opt)
    REAL(dp), DIMENSION(npt, *), &
      INTENT(inout)                          :: xpt
    REAL(dp), DIMENSION(*), INTENT(inout)    :: fval, gq, hq, pq
120 IF (dsq <= 1.0e-3_dp*xoptsq) THEN
       DO k=1,npt
          DO i=1,n
             gq(i)=gq(i)+temp*xpt(k,i)
          END DO
       END DO
    END IF
  END SUBROUTINE newuob
END MODULE powell


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C   Copyright (C) 1995-2004, Scientific Computing Division,
C   University Corporation for Atmospheric Research
C   Licensed under the GNU General Public License (GPL)
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: costb1.f,v 1.2 2006-11-21 01:10:17 haley Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE DCOSTB1(N,INC,X,WSAVE,WORK,IER)
      DOUBLE PRECISION WORK
      DOUBLE PRECISION X1H
      DOUBLE PRECISION X1P3
      DOUBLE PRECISION X2
      DOUBLE PRECISION T1
      DOUBLE PRECISION T2
      DOUBLE PRECISION FNM1S2
      DOUBLE PRECISION FNM1S4
      DOUBLE PRECISION XI
      DOUBLE PRECISION X(INC,*),WSAVE(*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DSUM

      IER = 0
      NM1 = N - 1
      NP1 = N + 1
      NS2 = N/2
      IF (N-2) 106,101,102
  101 X1H = X(1,1) + X(1,2)
      X(1,2) = X(1,1) - X(1,2)
      X(1,1) = X1H
      RETURN
  102 IF (N.GT.3) GO TO 103
      X1P3 = X(1,1) + X(1,3)
      X2 = X(1,2)
      X(1,2) = X(1,1) - X(1,3)
      X(1,1) = X1P3 + X2
      X(1,3) = X1P3 - X2
      RETURN
  103 X(1,1) = X(1,1) + X(1,1)
      X(1,N) = X(1,N) + X(1,N)
      DSUM = X(1,1) - X(1,N)
      X(1,1) = X(1,1) + X(1,N)
      DO 104 K = 2,NS2
          KC = NP1 - K
          T1 = X(1,K) + X(1,KC)
          T2 = X(1,K) - X(1,KC)
          DSUM = DSUM + WSAVE(KC)*T2
          T2 = WSAVE(K)*T2
          X(1,K) = T1 - T2
          X(1,KC) = T1 + T2
  104 CONTINUE
      MODN = MOD(N,2)
      IF (MODN.EQ.0) GO TO 124
      X(1,NS2+1) = X(1,NS2+1) + X(1,NS2+1)
  124 LENX = INC* (NM1-1) + 1
      LNSV = NM1 + INT(LOG(DBLE(NM1))) + 4
      LNWK = NM1
C
      CALL DRFFT1F(NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1)
      IF (IER1.NE.0) THEN
          IER = 20
          CALL DXERFFT('COSTB1',-5)
          RETURN
      END IF
C
      FNM1S2 = DBLE(NM1)/2.D0
      DSUM = .5D0*DSUM
      X(1,1) = FNM1S2*X(1,1)
      IF (MOD(NM1,2).NE.0) GO TO 30
      X(1,NM1) = X(1,NM1) + X(1,NM1)
   30 FNM1S4 = DBLE(NM1)/4.D0
      DO 105 I = 3,N,2
          XI = FNM1S4*X(1,I)
          X(1,I) = FNM1S4*X(1,I-1)
          X(1,I-1) = DSUM
          DSUM = DSUM + XI
  105 CONTINUE
      IF (MODN.NE.0) RETURN
      X(1,N) = DSUM
  106 RETURN
      END


*DECK SDPSC
      SUBROUTINE SDPSC (KSGN, N, NQ, YH)
C***BEGIN PROLOGUE  SDPSC
C***SUBSIDIARY
C***PURPOSE  Subroutine SDPSC computes the predicted YH values by
C            effectively multiplying the YH array by the Pascal triangle
C            matrix when KSGN is +1, and performs the inverse function
C            when KSGN is -1.
C***LIBRARY   SLATEC (SDRIVE)
C***TYPE      SINGLE PRECISION (SDPSC-S, DDPSC-D, CDPSC-C)
C***AUTHOR  Kahaner, D. K., (NIST)
C             National Institute of Standards and Technology
C             Gaithersburg, MD  20899
C           Sutherland, C. D., (LANL)
C             Mail Stop D466
C             Los Alamos National Laboratory
C             Los Alamos, NM  87545
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   900329  Initial submission to SLATEC.
C***END PROLOGUE  SDPSC
      INTEGER I, J, J1, J2, KSGN, N, NQ
      REAL YH(N,*)
C***FIRST EXECUTABLE STATEMENT  SDPSC
      IF (KSGN .GT. 0) THEN
        DO 10 J1 = 1,NQ
          DO 10 J2 = J1,NQ
            J = NQ - J2 + J1
            DO 10 I = 1,N
 10           YH(I,J) = YH(I,J) + YH(I,J+1)
      ELSE
        DO 30 J1 = 1,NQ
          DO 30 J2 = J1,NQ
            J = NQ - J2 + J1
            DO 30 I = 1,N
 30           YH(I,J) = YH(I,J) - YH(I,J+1)
      END IF
      RETURN
      END


!*********************************************************************
!Written by Rachith Aiyappa at IISc, Bangalore, September 2018
!This is for the project on collective behaviour of fish started
!at CRCA, Toulouse
!Email rachithaiyappa96@gmail.com for any queries
!This contains the main code which models the collective behaviour
!of N fish without a boundary
!v_2 is similar to to v_1.

!v_2_1_nfish ouputs trajectories "traj.txt"
!Column 1 and 2 = x postion and y postions of fish 1 respectively
!Column 3 and 4 = x postion and y postions of fish 2 respectively
!Column 5 and 6 = x postion and y postions of fish 3 respectively
!so on

!polarisation(P2) and radius of gyration(r_sq) are calculated but NOT
!stored in a file in this version of code
!The user can store it if required
!P = (1/N)*|summ(vec(v)/v)|
!P2 ----> The distribution of sqrt(<P*P>)
!r_sq(t) = (sum_{i,j}(r_i(t)-r_j(t))^2)/(0.5*N(N-1))

!This code does not contain values at equal intervals of time
!Hence interpolation is required if a movie is to be generated

!By deafult, the functional forms of interactions are the ones
!mentioned in the PLOS computational biology paper, i.e Calovi et. al
!2018
!This is set as default for the benefit of the user

!Clement's hypothesis : Can there be schooling without explicit alignment in discontinuous, asynchronous models of swimming
!To test the Clement's hypothesis, follow these steps :
!1. Go to fish_func.f95
!2. In the function del_phi_att make the following changes
!	i. l_att = 1.0
!	ii. comment the three functions under "original functions"
!	iii. uncomment "functions proposed by Clement"
!3. Go to v_2_1_nfish.f95
!	i. set gamma_ali = 0
!	ii. vary gamma_att and gamma_rand

!Compiling : gfortran -o nfish v_2_1_nfish.95 fish_func.f95
!Executing : ./nfish
!Inputs required : Number of fish &
!		time in units of Tau(or 2*(time in seconds))

!plotting trajectories in gnuplot.
!plot "traj.txt" using 1:2 with lines....this plots traj of fish 1
!replot "traj.txt" using 3:4 with lines...this plots traj of fish 2
!replot "traj.txt" using 5:6 with lines...this plots traj of fish 3
!carry on this way...

!minor bugs :
!1. When time_mod(:,col) = time_mod(:,col-1) output might be NaN.
!   This happens about twice in 100 samples
!   This happens when the new kicking time is infinitesimally small
!   increment when to the current time
!   Discard the sample when this happens and rerun the simulation
!2. Precision issue : User input 0.3 might be read as 0.300000012
!   This varies according to the compiler but it is not something
!   which changes the result by a huge margin
!*********************************************************************

program nfish

use :: fish_func

implicit none
!Declaration of variable----------------------------------------------
real, parameter :: pi=3.14159265
real, parameter :: gamma_att = 0.3 !or 0.3D0
real, parameter :: gamma_ali = 1
real, parameter :: gamma_rand = 0.38
integer, parameter :: max_size=1000000
real, parameter :: tau_0 = 1.6

integer :: time_limit
!integer :: size_xy=10
integer :: N, i, a, c, j
integer :: x_ini_status,y_ini_status, phi_ini_status
integer :: x_status,y_status,phi_status
integer :: x_temp_status,y_temp_status
integer :: d_status,v_status,tau_status,l_status
integer :: time_status,time_temp_status,time_mod_status,cont_t_status
integer :: phi_focal_status,phi_other_status,delta_phi_status
integer :: traj_status,phi_file_status
integer :: psi_status
integer :: pol_status,r_sq_status,d_fnn_status
integer :: out_dist_calc_status
integer :: col,count_number
integer :: idx,idx_new,idx_prev
integer :: b_status,noise_status
!integer :: columns_status

!real :: gamma_att,gamma_ali,gamma_rand
real :: del_phi_att_total,del_phi_ali_total
real :: d_first_nn_all
real :: focal_x, focal_y
real :: x_first_nn,y_first_nn
real :: val
real :: x_comp,y_comp
real :: del_phi_ali_tot, del_phi_att_tot
real :: r
real :: cos_term, sin_term, pol_sum, pol_mod
real :: summ

!Static arrays
integer, dimension(max_size) :: fish_prev,fish_new
integer, dimension(max_size) :: foc_x,foc_y

!Dynamically allocatable arrays
!integer, dimension(:), allocatable :: columns
real, dimension(:),allocatable :: x_ini,y_ini,phi_ini
real, dimension(:),allocatable :: pol,r_sq
real, dimension(:,:),allocatable :: x,y,phi
real, dimension(:,:),allocatable :: x_temp,y_temp
real, dimension(:,:),allocatable :: d,out_dist_calc
real, dimension(:,:),allocatable :: v,tau,l,out_v,out_tau
real, dimension(:,:),allocatable :: time,time_temp,time_mod,cont_t
real, dimension(:,:),allocatable :: b
real, dimension(:,:),allocatable :: phi_other,phi_focal,delta_phi
real, dimension(:,:),allocatable :: psi
real, dimension(:,:),allocatable :: g
real, dimension(:,:),allocatable :: d_fnn
!*********************************************************************

write(*,*) gamma_att
!opening the file to copy the trajectories----------------------------
open (unit = 10,file="traj.txt",status="replace", 	&
		action="write",position="rewind",	&
		iostat=traj_status)
write(*,*) "traj_status=", traj_status
!*********************************************************************
!opening the file to copy the heading angle--------------------------
open (unit = 11,file="phi.txt",status="replace", 	&
		action="write",position="rewind",	&
		iostat=phi_file_status)
write(*,*) "phi_file_status=", phi_file_status
!*********************************************************************

!User input-----------------------------------------------------------
write(*,*) "Enter the number of fish"
read(*,*) N
write(*,*) "Enter the time of simulation as 2*time(s)"
read(*,*) time_limit
!*********************************************************************

!Allocating initial conditions----------------------------------------
allocate(x_ini(N),stat = x_ini_status)
allocate(y_ini(N),stat = y_ini_status)
allocate(phi_ini(N),stat = phi_ini_status)

write(*,*) "x_ini_status=", x_ini_status !check if dyn mem allo occured
write(*,*) "y_ini_status=",y_ini_status	!check if dyn mem allo occured
write(*,*) "phi_ini_status=",phi_ini_status !check if dyn mem allo occured
!*********************************************************************

!biased initial conditions. Random intial conditions given later------
!phi_ini = pi/2.0
!y_ini = 0.0

!do i = 1,N,1
!	x_ini(i) = i
!end do
!write(*,*) x_ini,y_ini,phi_ini	!check if ini pos of the fish are stored
!*********************************************************************

!Allocating x,y,phi for computation-----------------------------------
allocate(x(N,max_size),stat = x_status)
allocate(y(N,max_size),stat = y_status)
allocate(phi(N,max_size),stat = phi_status)

write(*,*) "x_status=",x_status	!check if dyn mem allo occured
write(*,*) "y_status=",y_status	!check if dyn mem allo occured
write(*,*) "phi_status=",phi_status !check if dyn mem allo occured

!x(:,1) = x_ini
!write(*,*) x
!y(:,1) = y_ini
!phi(:,1) = phi_ini
!*********************************************************************

!---------------------------------------------------------------------
!Allocating x_temp, y_temp. USE THIS for trajectories and movies------
allocate(x_temp(N,max_size),stat = x_temp_status)
allocate(y_temp(N,max_size),stat = y_temp_status)

write(*,*) "x_temp_status=",x_temp_status !check if dyn mem allo occured
write(*,*) "y_temp_status=",y_temp_status !check if dyn mem allo occured

!x_temp(:,1) = x(:,1)	!This is what stores the info for traj plots
!y_temp(:,1) = y(:,1)
!*********************************************************************

!Allocating time------------------------------------------------------
allocate(time(N,max_size),stat=time_status)
allocate(time_temp(N,max_size),stat=time_temp_status)
allocate(time_mod(N,max_size),stat=time_mod_status)
allocate(cont_t(N,max_size),stat=cont_t_status)

write(*,*) "time_status=",time_status
write(*,*) "time_temp_status=",time_temp_status
write(*,*) "time_mod_status=",time_mod_status
write(*,*) "cont_t_status=",cont_t_status

!time(:,1) = 0.0
!write(*,*) time(:,1)
!*********************************************************************

!allocating d,l,v,tau-------------------------------------------------
allocate(d(N,max_size),stat=d_status)
allocate(v(N,max_size),stat=v_status)
allocate(tau(N,max_size),stat=tau_status)
allocate(l(N,max_size),stat=l_status)

write(*,*) "d_status=",d_status
write(*,*) "v_status=",v_status
write(*,*) "tau_status=",tau_status
write(*,*) "l_status=",l_status
!*********************************************************************

!allocation of d_fnn--------------------------------------------------
allocate(d_fnn(N,max_size),stat=d_fnn_status)
write(*,*) "d_fnn_status=",d_fnn_status
!*********************************************************************

!delta_phi and corresponding allocations------------------------------
allocate(phi_focal(N,max_size),stat=phi_focal_status)
write(*,*) "phi_focal_status=",phi_focal_status

allocate(phi_other(N,max_size),stat=phi_other_status)
write(*,*) "phi_other_status=",phi_other_status

allocate(delta_phi(N,max_size),stat=delta_phi_status)
write(*,*) "delta_phi_status=",delta_phi_status
!*********************************************************************

!allocation of psi----------------------------------------------------
allocate(psi(N,max_size),stat=psi_status)
write(*,*) "psi_status=", psi_status
!*********************************************************************

!allocation of stats--------------------------------------------------
allocate(pol(max_size),stat = pol_status)
write(*,*) "pol_status=", pol_status

allocate(r_sq(max_size),stat = r_sq_status)
write(*,*) "r_sq_status=", r_sq_status
!*********************************************************************

!allocating to keep track of minimum number of columns in the samples-
!allocate(columns(samp_no),stat=columns_status)
!write(*,*) "columns_status=",columns_status
!*********************************************************************

!Miscellaneous allocation---------------------------------------------
allocate(b(N,max_size),stat=b_status)
write(*,*) "b_status=",b_status

allocate(g(N,max_size),stat=noise_status)
write(*,*) "noise_status=",noise_status

allocate(out_dist_calc(N,1),stat = out_dist_calc_status)
write(*,*) "out_dist_clac=",out_dist_calc_status
!*********************************************************************

!calculating initial distance from focal fish-------------------------
focal_x = minval(x(:,1))
focal_y = minval(y(:,1))
col = 1

out_dist_calc = dist_calc(col,focal_x,focal_y,x(:,1),y(:,1),N)
d(:,col) = out_dist_calc(:,col)
!write(*,*) d(:,col)
!*********************************************************************

!*********************************************************************
call init_random_seed
!*********************************************************************

!initial postions and angles of the fish------------------------------
do j =1,N,1
	call random_number(r)
	x_ini(j) = 10*r
	call random_number(r)
	y_ini(j) = 10*r
	call random_number(r)
	phi_ini(j) = 2.0*pi*r
end do
!write(*,*) x_ini,y_ini,phi_ini	!chk if ini pos of the fish are stored
!*********************************************************************

!copying intial postions to x,y,phi-----------------------------------
do j =1,N,1
	x(j,1) = x_ini(j)
	!write(*,*) x
	y(j,1) = y_ini(j)
	phi(j,1) = phi_ini(j)
end do
!*********************************************************************

!x_temp and y_temp stores info for traj plots-------------------------
x_temp(1:N,1) = x(:,1)
!write(*,*) x_temp(1:N,1)
y_temp(1:N,1) = y(:,1)
!*********************************************************************

!absolute time--------------------------------------------------------
time(:,1) = 0.0
!write(*,*) time(:,1)
!*********************************************************************

!calculating initial distance from focal fish-------------------------
focal_x = minval(x(:,1))
focal_y = minval(y(:,1))
col = 1

out_dist_calc = dist_calc(col,focal_x,focal_y,x(:,col),y(:,col),N)
d(:,col) = out_dist_calc(:,col)
!write(*,*) d(:,col)
!*********************************************************************

!generatin first column of noise-------------------------------------
do a=1,N,1
	g(a,1) = gaus_rand()
end do
!write(*,*) g(:,1)
!*********************************************************************

!generating the first column of velocities----------------------------
col = 1
a = 1
do a=1,N,1
	call random_number(r)
	v(a,col) = generate_v(r)
end do
!write (*,*) v(:,1)
!out_v = generate_v(col,N)
!v(:,col) = out_v(:,col)
!write (*,*) v(:,1)
!out_v = generate_v(col+1,N)
!v(:,col+1) = out_v(:,col+1)
!write(*,*) v(:,1), v(:,2), v(:,3)
!*********************************************************************

!generating the first column of kicking times-------------------------
col = 1
a = 1
do a=1,N,1
	call random_number(r)
	!write (*,*) r
	tau(a,col) = generate_tau(r)
end do
!write (*,*) tau(:,1)
!out_tau = generate_tau(col,N)
!tau(:,col) = out_tau(:,col)
!write (*,*) tau(:,1)
!*********************************************************************

!The next step at which parameters need to be updated
!once the focal fish has been identified
time(:,2) = time(:,1) + tau(:,1)
!write (*,*) time(:,1),time(:,2)
!*********************************************************************

!Storing the first column of time temp--------------------------------
idx = minloc(time(:,2),dim=1)
time_temp(idx,1) = time(idx,2)
write (*,*) "blah"
!write(*,*) idx,time_temp(:,1)

a = 1
do while (a .le. N)
	if (a .ne. idx) then
		time_temp(a,1) = time(a,1)
	end if
	a = a + 1
end do
!write (*,*) idx,time_temp(:,1)

!Variable defined inorder to enter the loop---------------------------
count_number = 0
col = 2
!*********************************************************************

do while (time_limit > maxval(time(:,col)))
	!write(*,*) "max_time=",maxval(time(:,col))
	count_number = count_number+1

	!index of the previous focal fish
	idx_prev = minloc(time(:,col-1),dim=1)
	fish_prev(col) = idx_prev

	!index of the new focal fish
	idx_new = minloc(time(:,col),dim=1)
	fish_new(col) = idx_new
	!write(*,*) idx_new

	!storing the same time in all rows of a particular column in
	!order to bring all fish to that time
	time_mod(:,col)=time(idx_new,col)

	!updating time_temp which is used to get cont_t for other fish
	time_temp(idx_new,col)=minval(time(:,col))
	a = 1
	do while (a .le. N)
		if (a .ne. idx_new) then
			time_temp(a,col) = time_temp(a,col-1)
		end if
		a = a + 1
	end do

	!length tranversed by ff before choosing new v,tau
	l(idx_new,col-1) = v(idx_new,col-1)*tau_0*		     &
			(1-(exp(-(tau(idx_new,col-1)/tau_0))))

	!bringing ff till it meets its own tau
	cont_t(idx_new,col-1) = tau(idx_new,col-1)
	x(idx_new,col) = x(idx_new,col-1) + ((l(idx_new,col-1)*      &
			((1-exp(-cont_t(idx_new,col-1)/tau_0))/	     &
			(1-exp(-tau(idx_new,col-1)/tau_0)))*         &
			cos(phi(idx_new,col-1))))
	y(idx_new,col) = y(idx_new,col-1) + ((l(idx_new,col-1)*      &
			((1-exp(-cont_t(idx_new,col-1)/tau_0))/	     &
			(1-exp(-tau(idx_new,col-1)/tau_0)))*         &
			sin(phi(idx_new,col-1))))
	b(idx_new,col-1) = ((1-exp(-cont_t(idx_new,col-1)/tau_0))/   &
			(1-exp(-tau(idx_new,col-1)/tau_0)))
	!write(*,*) b(idx_new,col-1)
	foc_x(col) = x(idx_new,col)
	foc_y(col) = y(idx_new,col)

	!length traveresed by other fish to reach pt to give info to ff
	a = 1
	do while (a .le. N)
		if (a .ne. idx_new) then
			l(a,col-1) = v(a,col-1)*tau_0*         	      &
				(1-(exp(-(tau(a,col-1)/tau_0))))
		end if
		a = a + 1
	end do

	!bringing other fish to meet ff tau
	a = 1
	do while (a .le. N)
		if (a .ne. idx_new) then
			cont_t(a,col-1) = time_temp(idx_new,col) -   &
						time_temp(a,col)
			x(a,col) = x(a,col-1) + ((l(a,col-1)*        &
				((1-exp(-cont_t(a,col-1)/tau_0))/    &
				(1-exp(-tau(a,col-1)/tau_0)))*	     &
				cos(phi(a,col-1))))
			y(a,col) = y(a,col-1) + ((l(a,col-1)*	     &
				((1-exp(-cont_t(a,col-1)/tau_0))/    &
				(1-exp(-tau(a,col-1)/tau_0)))*	     &
				sin(phi(a,col-1))))
			b(a,col-1)=((1-exp(-cont_t(a,col-1)/tau_0))/ &
				   (1-exp(-tau(a,col-1)/tau_0)))
		end if
		a = a + 1
	end do

	!this has info abt pos of other fish at the kick time of ff
	x_temp(:,col) = x(:,col)
	y_temp(:,col) = y(:,col)
	!write(*,*) y_temp(:,col-1)

	!this has info of updates of only the ff
	!the other fish remain where they were
	a = 1
	do while (a .le. N)
		if (a .ne. idx_new) then
			x(a,col) = x(a,col-1)
			y(a,col) = y(a,col-1)
		end if
		a = a + 1
	end do

	!calculating the distance from ff to other fish
	!taking into account the ff and its first nearest neighbour(nn)
	focal_x = x_temp(idx_new,col)
	focal_y = y_temp(idx_new,col)
	out_dist_calc = dist_calc(col,focal_x,focal_y,		     &
			x_temp(1:N,col),y_temp(1:N,col),N)
	!write(*,*) out_dist_calc(:,1)
	d(:,col) = out_dist_calc(:,1)
	!idx=minloc(d(:,col),dim=1,mask=d(:,col) .gt. minval(d(:,col)))

	!x_first_nn = x_temp(idx,col)
	!y_first_nn = y_temp(idx,col)
	!write(*,*) d(:,col)

	!calculating fnn distance from all fish for stats-------------
	!a = 1
	!do while (a .le. N)
	!	out_dist_calc = dist_calc(col,x_temp(a,col),	     &
	!		y_temp(a,col),x_temp(:,col),y_temp(:,col),N)
	!	!dist of other fish from fish a at current time
	!	idx = minloc(out_dist_calc(:,1),dim=1,mask=	     &
	!	out_dist_calc(:,1) .gt. minval(out_dist_calc(:,1)))
	!	x_first_nn = x_temp(idx,col)
	!	y_first_nn = y_temp(idx,col)
	!	d_fnn(a,col) = sqrt(((x_temp(a,col)-x_first_nn)**2)+ &
	!		((y_temp(a,col)- y_first_nn)**2));
	!	!write(*,*) d_fnn(a,col)
	!	a = a + 1
	!end do
	!	!write(*,*) d_fnn(1:N,col)
	!************************************************************

	!calculating delta_phi----------------------------------------
	a = 1
	do while (a .le. N)
		if (a .ne. idx_new) then
			phi_other(a,col) = atan2(y_temp(a,col)-	     &
			y_temp(a,col-1),x_temp(a,col)-x_temp(a,col-1))
		else
			phi_focal(a,col) = atan2(y_temp(a,col)-	     &
			y_temp(a,col-1),x_temp(a,col)-x_temp(a,col-1))
		end if
		a = a + 1
	end do
	!write(*,*) phi_focal(:,col),phi_other(:,col)

	a = 1
	do while (a .le. N)
		if (a .ne. idx_new) then
			delta_phi(a,col) = phi_other(a,col)-	     &
					phi_focal(idx_new,col)
			do while (delta_phi(a,col) .gt. pi)
				delta_phi(a,col) = delta_phi(a,col)- &
							(2.0*pi)
			end do
			do while (delta_phi(a,col) .lt. -pi)
				delta_phi(a,col) = delta_phi(a,col)+ &
							(2.0*pi)
			end do
		!mutliplying -1 to follow sign convention in paper
		delta_phi(a,col) = -1.0*delta_phi(a,col)
		end if
		!write (*,*) delta_phi(a,col)

		a = a + 1
	end do
	!write (*,*) delta_phi(:,col)
	!*************************************************************

	!calculating psi----------------------------------------------
	a = 1
	do while (a .le. N)
		if (a .ne. idx_new) then
			psi(a,col) = atan2(y_temp(a,col)-	     &
					y_temp(idx_new,col),	     &
				(x_temp(a,col)-x_temp(idx_new,col))) &
				- phi_focal(idx_new,col)
		do while (psi(a,col) .gt. pi)
			psi(a,col) = psi(a,col) - (2.0*pi)
		end do
		do while (psi(a,col) .lt. -pi)
			psi(a,col) = psi(a,col) + (2.0*pi)
		end do
		!mutliplying -1 to follow sign convention in paper
		psi(a,col) = -1.0*psi(a,col)
		end if
		a = a + 1
		!write(*,*) psi(a,col)
	end do
	!write(*,*) psi(:,col)
	!*************************************************************

	!substituting the angles obtained to get the updated angle
	g(idx_new,col) = gaus_rand()
	!write(*,*) gaus_rand()
	a = 1
	del_phi_ali_tot = 0.0
	del_phi_att_tot = 0.0
	do while (a .le. N)
		!write (*,*) gamma_att
		!write (*,*) gamma_ali
		if (a .ne. idx_new) then
			!write(*,*) psi(a,col)
			del_phi_att_tot = del_phi_att_tot +	     &
	del_phi_att(gamma_att,d(a,col),psi(a,col),delta_phi(a,col))
!write(*,*)del_phi_att(gamma_att,d(a,col),psi(a,col),-delta_phi(a,col))
!write(*,*)del_phi_att(gamma_att,d(a,col),psi(a,col),delta_phi(a,col))
			do while (del_phi_att_tot .gt. pi)
				del_phi_att_tot = del_phi_att_tot    &
					- (2.0*pi)
			end do
			do while (del_phi_att_tot .lt. -pi)
				del_phi_att_tot = del_phi_att_tot    &
					+ (2.0*pi)
			end do
		end if
		if (a .ne. idx_new) then
			del_phi_ali_tot = del_phi_ali_tot +	     &
	del_phi_ali(gamma_ali,d(a,col),psi(a,col),delta_phi(a,col))
			do while (del_phi_ali_tot .gt. pi)
				del_phi_ali_tot = del_phi_ali_tot    &
					- (2.0*pi)
			end do
			do while (del_phi_ali_tot .lt. -pi)
				del_phi_ali_tot = del_phi_ali_tot    &
					+ (2.0*pi)
			end do
		end if
		a = a + 1
	end do
	!write(*,*) del_phi_att_tot
	!write(*,*) del_phi_ali_tot
	phi(idx_new,col) = phi(idx_new,col-1) + del_phi_att_tot +   &
			del_phi_ali_tot + (gamma_rand*g(idx_new,col))
	do while (phi(idx_new,col) .gt. pi)
		phi(idx_new,col) = phi(idx_new,col) - (2.0*pi)
	end do
	do while (phi(idx_new,col) .lt. -pi)
		phi(idx_new,col) = phi(idx_new,col) + (2.0*pi)
	end do
	!*************************************************************

	!preparing the arrays for the next loop-----------------------
	a = 1
	do while (a .le. N)
		if (a .ne. idx_new) then
			v(a,col) = v(a,col-1)
			tau(a,col) = tau(a,col-1)
			phi(a,col) = phi(a,col-1)
			time(a,col+1) = time(a,col)
		else
			call random_number(r)
			v(a,col) = generate_v(r)
			call random_number(r)
			!write(*,*) r
			tau(a,col) = generate_tau(r)
			time(a,col+1) = time(a,col) + tau(a,col)
		end if
		a = a + 1
	end do
	!*************************************************************

	!to find polarisation(P2)-------------------------------------
	pol_sum = 0.0
	cos_term = 0.0
	sin_term = 0.0
	do a = 1,N,1
		cos_term = cos_term + cos(phi(a,col))
		sin_term = sin_term + sin(phi(a,col))
	end do
	pol_mod = sqrt(((cos_term)**2)+((sin_term)**2))
	pol(col) = (1.0/N)*pol_mod
	!*************************************************************

	!to find the radius of gyration-------------------------------
	summ = 0.0
	do a=1,N,1
		do c=a+1,N,1
			summ= summ+(((x_temp(a,col)-x_temp(c,col))**2)&
		+((y_temp(a,col)-y_temp(c,col))**2))
		end do
	end do
	r_sq(col) = (2/(N*(N-1)))*summ
	!*************************************************************

	col = col + 1
	!write(*,*) col
end do
	write(*,*) "number of columns=", col-1

do i = 1,col-1
	write(10,*) (x_temp(j,i),y_temp(j,i),j=1,N)
!	write(*,*) x_temp(1,i),y_temp(1,i),x_temp(2,i),y_temp(2,i)
	write(11,*) (phi(j,i),j=1,N)
end do
!write(*,*) time_temp(1,col-1),col,time_temp(1,col)

close(10)
end program nfish
!*********************************************************************

!*********************************************************************
!RANDOM SEED GENERATOR FOR THE RANDOM_NUMBER PROGRAM
!*********************************************************************

!This subroutine was written with the help of a friend from BITS-Goa,
!George Joseph who
!had used it to generate random numbers(not pseudo) for his project
!A check can be performed by plotting a set of random numbers
subroutine init_random_seed()
	use iso_fortran_env, only: int64
	implicit none
	integer, allocatable :: seed(:)
	integer :: i, n, un, istat, dt(8), pid
	integer(int64) :: t

	call random_seed(size = n)
	allocate(seed(n))
	! First try if the OS provides a random number generator
	open(newunit=un, file="/dev/urandom", access="stream",        &
	form="unformatted", action="read", status="old", iostat=istat)
	if (istat == 0) then
		read(un) seed
		close(un)
	else
		! Fallback to XOR:ing the current time and pid. The PID is
		! useful in case one launches multiple instances of the same
		! program in parallel.
		call system_clock(t)
		if (t == 0) then
			call date_and_time(values=dt)
			t = (dt(1) - 1970) * 365_int64 * 24 * 60 * 60 &
							* 1000        &
			+ dt(2) * 31_int64 * 24 * 60 * 60 * 1000      &
			+ dt(3) * 24_int64 * 60 * 60 * 1000           &
			+ dt(5) * 60 * 60 * 1000                      &
			+ dt(6) * 60 * 1000 + dt(7) * 1000            &
			+ dt(8)
		end if
		pid = getpid()
		t = ieor(t, int(pid, kind(t)))
		do i = 1, n
			seed(i) = lcg(t)
		end do
		end if
		call random_seed(put=seed)	!value of 'put' is the array used to initialize this thread's seed.
	contains
		! This simple PRNG might not be good enough for real work, but is
		! sufficient for seeding a better PRNG.
		function lcg(s)
			integer :: lcg
			integer(int64) :: s
			if (s == 0) then
				s = 104729
			else
				s = mod(s, 4294967296_int64)
			end if
				s = mod(s * 279470273_int64,          &
				4294967291_int64)
				lcg = int(mod(s, int(huge(0),         &
 				int64)), kind(0))
		end function lcg
end subroutine init_random_seed
!*********************************************************************


*     SB03MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDC, LDU
      PARAMETER        ( LDA = NMAX, LDC = NMAX, LDU = NMAX )
      INTEGER          LDWORK, LIWORK
      PARAMETER        ( LDWORK = 2*NMAX*NMAX + 3*NMAX,
     $                   LIWORK = NMAX*NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
      CHARACTER*1      DICO, FACT, JOB, TRANA
      DOUBLE PRECISION FERR, SCALE, SEP
*     .. Local Arrays ..
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK),
     $                 U(LDU,NMAX), WI(NMAX), WR(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB03MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, DICO, FACT, JOB, TRANA
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * )
     $                         ( ( U(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N )
*        Find the solution matrix X.
         CALL SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC,
     $                SCALE, SEP, FERR, WR, WI, IWORK, DWORK, LDWORK,
     $                INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99994 ) SCALE
            IF ( .NOT.LSAME( JOB, 'X' ) )
     $         WRITE ( NOUT, FMT = 99993 ) SEP
            IF ( LSAME( JOB, 'B' ) )
     $         WRITE ( NOUT, FMT = 99992 ) FERR
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB03MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB03MD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' Scaling factor = ',F8.4)
99993 FORMAT (/' Estimated separation = ',F8.4)
99992 FORMAT (/' Estimated forward error bound = ',F8.4)
      END


! This file contains example initial conditions used in previous simulations

!kink unstable loop from Hood et a. A&A 2009
   SUBROUTINE set_initial_conditions

     INTEGER:: ix, iy, iz
     REAL(num) :: hh
     REAL(num) :: alpha1, alpha2, B1
     REAL(num) :: rc, rb, rbx, rby, b_theta, b_z, delta, B2, C2
     REAL(num) :: k, amp, dx, dy, theta, v_perp, v_r, v_theta
     REAL(num) :: costh, sinth, coskz, sinkz, arg

     vx = 0.0_num
     vy = 0.0_num
     vz = 0.0_num

 ! Case 10
     alpha1 = 1.8_num
     alpha2 = alpha1*alpha1
     B1 = 1.0_num

 ! helicity
     hh = 0.0_num

     bx = 0.0_num
     by = 0.0_num
     bz = 0.0_num

     energy = 0.0_num
     rho = 1.0_num
     grav = 0.0_num

 ! Velocity perturbation
 !Case 3 perturbation
     k = 6.0_num*pi/20.0_num
     amp = 1.e-4_num
     dx = 0.1_num * dxb(nx/2)
     dy = 0.1_num * dyb(ny/2)
     DO ix = -1,nx+2
       DO iy = -1,ny+2
         DO iz = -1,nz+2

           rc  = SQRT(xc(ix)*xc(ix)+yc(iy)*yc(iy))
           rb  = SQRT(xb(ix)*xb(ix)+yb(iy)*yb(iy))
           rbx = SQRT(xb(ix)*xb(ix)+yc(iy)*yc(iy))
           rby = SQRT(xc(ix)*xc(ix)+yb(iy)*yb(iy))
           IF (rb .LE. sqrt(dx**2 + dy**2)) THEN
             costh = 1.0_num
             sinth = 0.0_num
           ELSE
             costh = xb(ix)/rb
             sinth = yb(iy)/rb
           END IF
           coskz = cos(k*zb(iz))
           sinkz = sin(k*zb(iz))
           v_r = EXP(-rb**2*(1+(rb/0.5_num)**6))*COS(pi*zb(iz)/length_z)*&
                 (costh*coskz + sinth*sinkz)
 !
 ! Define the velocity at the cell boundaries
 !
           IF (rb .LE. 1.0_num) THEN
             B2 = alpha2*((1.0_num-rb**2.0_num)**7.0_num-1.0_num)/7.0_num
             C2 = alpha2*rb*rb*(1.0_num-rb**2.0_num)**6.0_num
             b_z = sqrt(1.0_num + B2 - C2)
             b_theta = alpha1*rb*(1.0_num-rb*rb)**3.0_num
             v_perp = -((b_theta**2 + b_z**2)/&
              (b_z + k*rc*b_theta))*&
              (1.0_num - 2.0_num*rb**2 - 8.0_num*(rb/0.5_num)**6)*EXP(-4.0_num*rb**4)*&
              COS(pi*zb(iz)/length_z)*(sinth*coskz - costh*sinkz)

             v_theta = b_z*v_perp / (b_z**2 + b_theta**2)

             vz(ix,iy,iz) = amp*(-b_theta*v_perp / (b_z**2 +&
                   b_theta**2))
             vx(ix,iy,iz) = amp*(v_r*costh - v_theta*sinth)
             vy(ix,iy,iz) = amp*(v_r*sinth + v_theta*costh)
           ELSE
             b_z = sqrt(1.0_num - alpha2/7.0_num)
             b_theta = 0.0_num
             v_perp = -((b_theta**2 + b_z**2)/&
              (b_z + k*rb*b_theta))*&
              (1.0_num - 2.0_num*rb**2 - 8.0_num*(rb/0.5_num)**6)*EXP(-4.0_num*rb**4)*&
              COS(pi*zb(iz)/length_z)*(sinth*coskz - costh*sinkz)

             v_theta = b_z*v_perp / (b_z**2 + b_theta**2)

             vz(ix,iy,iz) = amp*(-b_theta*v_perp / (b_z**2 +&
                   b_theta**2))
             vx(ix,iy,iz) = amp*(v_r*costh - v_theta*sinth)
             vy(ix,iy,iz) = amp*(v_r*sinth + v_theta*costh)
           END IF
 !
 ! Define Bz on face centred at (xc,yc,zb)
 !
           IF (rc .LE. 1.0_num) THEN
             B2 = alpha2*((1.0_num-rc**2.0_num)**7.0_num-1.0_num)/7.0_num
             C2 = alpha2*rc*rc*(1.0_num-rc**2.0_num)**6.0_num
             bz(ix,iy,iz) = sqrt(1.0_num + B2 - C2)
           ELSE
             bz(ix,iy,iz) = sqrt(1.0_num - alpha2/7.0_num)
           END IF
 !
 ! Define Bx on face centred at (xb,yc,zc)
 !
           IF (rbx .LE. 1.0_num) THEN
             b_theta = alpha1*rbx*(1.0_num-rbx*rbx)**3.0_num
             bx(ix,iy,iz) = -b_theta * yc(iy) / rbx
           ELSE
             bx(ix,iy,iz) = 0.0_num
           END IF
 !
 ! Define By on face centred at (xc,yb,zc)
 !
           IF (rby .LE. 1.0_num) THEN
             b_theta = alpha1*rby*(1.0_num-rby*rby)**3.0_num
             by(ix,iy,iz) = b_theta * xc(ix) / rby
           ELSE
             by(ix,iy,iz) = 0.0_num
           END IF

         END DO
       END DO
     END DO

   END SUBROUTINE set_initial_conditions

! should give the model atmosphere, with bouyant flux tube, as in Arber et al. ApJ

SUBROUTINE set_initial_conditions

  INTEGER :: ix, iy, iz, loop
  REAL(num) :: rc, x1, y1, b_theta, amp, k, r0, a=1.1_num, r1, mu, m=1.5
  REAL(num):: b0, bz0, t_ph=1.0_num, t_cor=150.0_num, z_cor=25.0_num, wtr=5.0_num
  REAL(num) :: dg, w, q, lambda, r, bphi, b1, p0, p1, rho1, r_a, a1, a2, b
  REAL(num) :: maxerr, xi_v
  REAL(num), DIMENSION(:), ALLOCATABLE :: dzb_global, dzc_global,zc_global,grav_global

  REAL(num), DIMENSION(:), ALLOCATABLE :: rho_ref, energy_ref, t_ref, mu_m

  ALLOCATE(dzb_global(-1:nz_global+1), dzc_global(-1:nz_global), zc_global(-1:nz_global+1))
  ALLOCATE(grav_global(-1:nz_global+2), mu_m(-1:nz_global+2))
  ALLOCATE(rho_ref(-1:nz_global+2),energy_ref(-1:nz_global+2), t_ref(-1:nz_global+2))

  ! Changed from James's version to remove the need for a seperate routine setting up
  ! the newton cooling arrays and the MPI calls.

  ! Set up the initial 1D hydrostatic equilibrium

  grav_global = 0.9727_num

  ! example of lowering g to zero in corona
  a1 = 60.0_num
  a2 = 80.0_num
  WHERE (zb_global > a1) grav_global = grav_global(0)*(1.0_num+COS(pi*(zb_global-a1)/(a2-a1))) &
       /2.0_num
  WHERE (zb_global > a2) grav_global = 0.0_num

  !Y.Fan atmosphere temp profile
  DO iz = -1, nz_global+1 ! needs to be +1 for the dzc calculation
     zc_global(iz) = 0.5_num * (zb_global(iz) + zb_global(iz-1))
     IF (zc_global(iz) < 0.0_num) THEN
        t_ref(iz) = t_ph - (t_ph * a * zc_global(iz) * grav_global(iz) / (m+1.0_num))
     ELSE
        t_ref(iz) = t_ph + ((t_cor-t_ph) * 0.5_num * (TANH((zc_global(iz)-z_cor)/wtr)+1.0_num))
     END IF
  END DO
  t_ref(nz_global+2) = t_ref(nz_global+1)

  !solve HS eqn to get rho profile
  !density at bottom of domain
  rho_ref = 1.0_num

  DO iz = -1, nz_global
     dzb_global(iz) = zb_global(iz) - zb_global(iz-1)
     dzc_global(iz) = zc_global(iz+1) - zc_global(iz)
  END DO

  !solve for density
  mu_m = 0.5_num    ! the reduced mass in units of proton mass
  IF (include_neutrals) xi_n = 0.0_num
  DO loop = 1, 100
     maxerr = 0.0_num
    DO iz = nz_global, 0, -1
      IF (zc_global(iz) < 0.0_num) THEN
        dg = 1.0_num / (dzb_global(iz)+dzb_global(iz-1))
        rho_ref(iz-1) = rho_ref(iz) * (T_ref(iz)/dzc_global(iz-1)/mu_m(iz)&
             +grav_global(iz-1)*dzb_global(iz)*dg)
        rho_ref(iz-1) = rho_ref(iz-1) / (T_ref(iz-1)/dzc_global(iz-1)/mu_m(iz-1) &
             -grav_global(iz-1)*dzb_global(iz-1)*dg)
      END IF
    END DO
    !Now move from the photosphere up to the corona
    DO iz = 0, nz_global
      IF (zc_global(iz) > 0.0_num) THEN
        dg = 1.0_num / (dzb_global(iz)+dzb_global(iz-1))
        rho_ref(iz) = rho_ref(iz-1) * (T_ref(iz-1)/dzc_global(iz-1)/mu_m(iz-1)&
             -grav_global(iz-1)*dzb_global(iz-1)*dg)
        rho_ref(iz) = rho_ref(iz) / (T_ref(iz)/dzc_global(iz-1)/mu_m(iz) &
             +grav_global(iz-1)*dzb_global(iz)*dg)
      END IF
    END DO
    IF (include_neutrals) THEN     !note this always assumes EOS_PI
        DO iz = 0, nz_global
           xi_v = get_neutral(t_ref(iz), rho_ref(iz))
           r1 = mu_m(iz)
           mu_m(iz) = 1.0_num / (2.0_num - xi_v)
           maxerr = MAX(maxerr, ABS(mu_m(iz) - r1))
        END DO
     END IF
     IF (maxerr < 1.e-10_num) EXIT
  END DO
  rho_ref(nz_global+1:nz_global+2) = rho_ref(nz_global)
  ! set the relaxation rate, James used an exponent of -1.67, here I use the value
  ! in the 2D paper of -1.67. The tau equation is scaled by 1/t0 * 0.1

  ! Convert into the local 3D arrays
  vx = 0.0_num
  vy = 0.0_num
  vz = 0.0_num

  grav = grav_global(coordinates(1)*nz-1:coordinates(1)*nz+nz+2)

  DO iy = -1, ny + 2
     DO ix = -1, nx + 2
        !store temperature in energy array for a few lines
        energy(ix,iy,:) = t_ref(coordinates(1)*nz-1:coordinates(1)*nz+nz+2)
        rho(ix,iy,:) = rho_ref(coordinates(1)*nz-1:coordinates(1)*nz+nz+2)
     END DO
  END DO

  DO iz = -1, nz + 2
    DO iy = -1, ny + 2
      DO ix = -1, nx + 2
        r1 = energy(ix,iy,iz)
        CALL get_energy(rho(ix,iy,iz), r1, eos_number, ix, iy, iz, energy(ix,iy,iz))
      END DO
    END DO
  END DO

  !add magnetic flux tube at (0,0,-10) and change pressure, dens, energy over it
  !grad(p1) matches lorentz force
  !MEQ at end of tube
  !pressure match at apex
  !seee Fan 2001 for details of initialisation
  !w = width of tube
  w = 2.0_num
  q = -(1.0_num/w)
  b0 = 5.0_num
  lambda = 20.0_num
  DO ix = -1,nx+2
     DO iy = -1,ny+2
        DO iz = -1,nz+2
           !define bx,by,bz at correct points
           r = SQRT(yc(iy)**2 + (zc(iz)+10.0_num)**2)
           bx(ix,iy,iz) =  b0 * EXP(-(r/w)**2)
           bphi =  bx(ix,iy,iz) * q * r

           r = SQRT(yb(iy)**2 + (zc(iz)+10.0_num)**2)
           b1 = b0 * EXP(-(r/w)**2)
           by(ix,iy,iz) = -b1 * q * (zc(iz)+10.0_num)

           r = SQRT(yc(iy)**2 + (zb(iz)+10.0_num)**2)
           b1 =  b0 * EXP(-(r/w)**2)
           bz(ix,iy,iz) =  b1 * q * yc(iy)

           !define gas pressure and magnetic pressure
           p0 =  rho(ix,iy,iz)*energy(ix,iy,iz)*(gamma-1.0_num)
           p1 =  -0.25_num * bx(ix,iy,iz)**2 - 0.5_num * bphi**2
           !change density and energy
           r1 = xc(ix)/lambda
           rho1 =  (p1/p0)*rho(ix,iy,iz)*EXP(-(r1**2))
           rho(ix,iy,iz)   =  rho(ix,iy,iz) + rho1
           energy(ix,iy,iz)= (p0 + p1) / (rho(ix,iy,iz) * (gamma - 1.0_num))

        END DO
     END DO
  END DO

  DEALLOCATE(dzb_global, dzc_global, zc_global)
  DEALLOCATE(grav_global, mu_m)
  DEALLOCATE(rho_ref, energy_ref, t_ref)

END SUBROUTINE set_initial_conditions

!Kink unstable loop from Arber et al, 1999
  SUBROUTINE equilibrium

    INTEGER :: ix, iy, iz
    REAL(num) :: rc, x1, y1, b_theta, amp, k, r0, a, r1, mu
    REAL(num):: b0, bz0

    vx = 0.0_num
    vy = 0.0_num
    vz = 0.0_num

    bx = 1.0_num
    by = 0.0_num
    bz = 0.0_num

    r0 = 1.0_num / SQRT(6.0_num)
    a = 5.0_num / (6.0_num * SQRT(6.0_num))

    bz0 = 1.0_num
    b0 = 4.3_num

    DO ix = -1, nx+2             ! setup static equilibrium values
       DO iy = -1, ny+2
          DO iz = -1, nz+2

             rc = SQRT(xc(ix)**2 + yc(iy)**2)
             IF (rc >= 1.0_num) rc = 1.0_num
             bz(ix,iy,iz) = (1.0/2.0)*rc**2 - (3.0/8.0)*(rc**4/r0**2)    &
                  + (7.0*a/25.0)*(rc**5/r0**3) + (1.0/12.0)*(rc**6/r0**4)     &
                  - (9.0*a/70.0)*(rc**7/r0**5) + (1.0*a**2/20.0)*(rc**8/r0**6)
             bz(ix,iy,iz) = SQRT(bz0**2 - b0**2*bz(ix,iy,iz))
             rho(ix,iy,iz) = 0.45_num*(1.0_num+COS(pi*rc))+0.1_num

             x1 = xb(ix)
             y1 = yc(iy)
             rc = SQRT(x1**2 + y1**2)
             IF (rc >= 1.0_num) rc = 1.0_num
             b_theta = rc/2.0 - rc**3/(4.0*r0**2) + a*rc**4/(5.0*r0**3)
             bx(ix,iy,iz) = - b0 * b_theta * y1 / rc

             x1 = xc(ix)
             y1 = yb(iy)
             rc = SQRT(x1**2 + y1**2)
             IF (rc >= 1.0_num) rc = 1.0_num
             b_theta = rc/2.0 - rc**3/(4.0*r0**2) + a*rc**4/(5.0*r0**3)
             by(ix,iy,iz) = b0 * b_theta * x1 / rc

          END DO
       END DO
    END DO
    bx(-2,:,:) = bx(-1,:,:)
    by(:,-2,:) = by(:,-1,:)
    bz(:,:,-2) = bz(:,:,-1)

    WHERE (rho < 0.1_num) rho = 0.1_num
    energy = 0.01_num / (rho * (gamma-1.0_num))

    k = 2.0_num * pi / length_z     ! apply velocity perturbation
    amp = 1.e-2_num
    r1 = 0.95_num
    mu = 0.2_num

    DO ix = -1, nx+2
       DO iy = -1, ny+2
          DO iz = -1, nz+2
             rc = SQRT(xb(ix)**2 + yb(iy)**2)
             IF (rc < r1) THEN
                vx(ix,iy,iz) = amp*COS(2.5_num*k*zc(iz))   &
                     * (1.0_num+COS(k*zc(iz)))*(1.0_num - (rc/r1)**2)**mu
                vy(ix,iy,iz) = amp*SIN(2.5_num*k*zc(iz))   &
                     * (1.0_num+COS(k*zc(iz)))*(1.0_num - (rc/r1)**2)**mu
             ELSE
                vx(ix,iy,iz) = 0.0_num
                vy(ix,iy,iz) = 0.0_num
             END IF
          END DO
       END DO
    END DO

  END SUBROUTINE equilibrium

!example of how to get B from A
  SUBROUTINE equilibrium

    INTEGER :: ix, iy, iz
    REAL(num), DIMENSION(:,:,:), ALLOCATABLE :: ax,ay,az
    REAL(num) :: mag_scale_height, b0, r, radius

    ALLOCATE(ax(-2:nx+2,-2:ny+2,-2:nz+2),ay(-2:nx+2,-2:ny+2,-2:nz+2),az(-2:nx+2,-2:ny+2,-2:nz+2))

    ax = 0.0_num
    ay = 0.0_num
    az = 0.0_num

    vx = 0.0_num
    vy = 0.0_num
    vz = 0.0_num

    rho = 1.0_num
    energy = 0.01_num  / (gamma - 1.0_num)

    bx = 0.0_num
    by = 0.0_num
    bz = 0.0_num

    r = 10.0_num ! loop major radius, foot points are at +- r
    b0 = 1.0_num
    mag_scale_height = 2.0_num * r / pi
    grav = 0.0_num

    ! Define the vector potential
    DO iz = -2, nz + 2
       DO ix = -2, nx + 2
          ay(ix,:,iz) = b0 * mag_scale_height * COS(xb(ix) / mag_scale_height) * EXP(-zb(iz)/mag_scale_height)
       END DO
    END DO

    ! Take the curl of the vector potential to get B
    DO iz = -1, nz + 2
       DO iy = -1, ny + 2
          DO ix = -1, nx + 2
             ixm = ix - 1
             iym = iy - 1
             izm = iz - 1
             bx(ix,iy,iz) = (az(ix,iy,iz) - az(ix,iym,iz)) / dyb(iy) - (ay(ix,iy,iz) - ay(ix,iy,izm)) / dzb(iz)
             by(ix,iy,iz) = (ax(ix,iy,iz) - ax(ix,iy,izm)) / dzb(iz) - (az(ix,iy,iz) - az(ixm,iy,iz)) / dxb(ix)
             bz(ix,iy,iz) = (ay(ix,iy,iz) - ay(ixm,iy,iz)) / dxb(ix) - (ax(ix,iy,iz) - ax(ix,iym,iz)) / dyb(iy)
          END DO
       END DO
    END DO

    DO iz = -1, nz + 2
       DO iy = -1, ny + 2
          iym = iy - 1
          izm = iz - 1
          bx(-2,iy,iz) = (az(-2,iy,iz) - az(-2,iym,iz)) / dyb(iy) - (ay(-2,iy,iz) - ay(-2,iy,izm)) / dzb(iz)
       END DO
    END DO

    DO iz = -1, nz + 2
       DO ix = -1, nx + 2
          by(ix,-2,iz) = (ax(ix,-2,iz) - ax(ix,-2,izm)) / dzb(iz) - (az(ix,-2,iz) - az(ixm,-2,iz)) / dxb(ix)
       END DO
    END DO

    DO iy = -1, ny + 2
       DO ix = -1, nx + 2
          bz(ix,iy,-2) = (ay(ix,iy,-2) - ay(ixm,iy,-2)) / dxb(ix) - (ax(ix,iy,-2) - ax(ix,iym,-2)) / dyb(iy)
       END DO
    END DO

    DEALLOCATE(ax,ay,az)

  END SUBROUTINE equilibrium


      SUBROUTINE MB01UW( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute one of the matrix products
C
C        A : = alpha*op( H ) * A, or A : = alpha*A * op( H ),
C
C     where alpha is a scalar, A is an m-by-n matrix, H is an upper
C     Hessenberg matrix, and op( H ) is one of
C
C        op( H ) = H   or   op( H ) = H',  the transpose of H.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SIDE    CHARACTER*1
C             Specifies whether the Hessenberg matrix H appears on the
C             left or right in the matrix product as follows:
C             = 'L':  A := alpha*op( H ) * A;
C             = 'R':  A := alpha*A * op( H ).
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( H ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( H ) = H;
C             = 'T':  op( H ) = H';
C             = 'C':  op( H ) = H'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then H is not
C             referenced and A need not be set before entry.
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,k)
C             where k is M when SIDE = 'L' and is N when SIDE = 'R'.
C             On entry with SIDE = 'L', the leading M-by-M upper
C             Hessenberg part of this array must contain the upper
C             Hessenberg matrix H.
C             On entry with SIDE = 'R', the leading N-by-N upper
C             Hessenberg part of this array must contain the upper
C             Hessenberg matrix H.
C             The elements below the subdiagonal are not referenced,
C             except possibly for those in the first column, which
C             could be overwritten, but are restored on exit.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= max(1,k),
C             where k is M when SIDE = 'L' and is N when SIDE = 'R'.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading M-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading M-by-N part of this array contains
C             the computed product.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, alpha <> 0, and LDWORK >= M*N > 0,
C             DWORK contains a copy of the matrix A, having the leading
C             dimension M.
C             This array is not referenced when alpha = 0.
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= 0,   if  alpha =  0 or MIN(M,N) = 0;
C             LDWORK >= M-1, if  SIDE  = 'L';
C             LDWORK >= N-1, if  SIDE  = 'R'.
C             For maximal efficiency LDWORK should be at least M*N.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The required matrix product is computed in two steps. In the first
C     step, the upper triangle of H is used; in the second step, the
C     contribution of the subdiagonal is added. If the workspace can
C     accomodate a copy of A, a fast BLAS 3 DTRMM operation is used in
C     the first step.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, January 1999.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SIDE, TRANS
      INTEGER           INFO, LDA, LDH, LDWORK, M, N
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), H(LDH,*)
C     .. Local Scalars ..
      LOGICAL           LSIDE, LTRANS
      INTEGER           I, J, JW
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DLACPY, DLASCL, DLASET, DSCAL, DSWAP,
     $                  DTRMM, DTRMV, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      LSIDE  = LSAME( SIDE,  'L' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF(      ( .NOT.LSIDE  ).AND.( .NOT.LSAME( SIDE,  'R' ) ) )THEN
         INFO = -1
      ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR.
     $                  ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDWORK.LT.0 .OR.
     $       ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 .AND.
     $            ( ( LSIDE .AND. LDWORK.LT.M-1 ) .OR.
     $         ( .NOT.LSIDE .AND. LDWORK.LT.N-1 ) ) ) ) THEN
         INFO = -11
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01UW', -INFO )
         RETURN
      END IF
C
C     Quick return, if possible.
C
      IF ( MIN( M, N ).EQ.0 ) THEN
         RETURN
      ELSE IF ( LSIDE ) THEN
         IF ( M.EQ.1 ) THEN
            CALL DSCAL( N, ALPHA*H(1,1), A, LDA )
            RETURN
         END IF
      ELSE
         IF ( N.EQ.1 ) THEN
            CALL DSCAL( M, ALPHA*H(1,1), A, 1 )
            RETURN
         END IF
      END IF
C
      IF( ALPHA.EQ.ZERO ) THEN
C
C        Set A to zero and return.
C
         CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
         RETURN
      END IF
C
      IF( LDWORK.GE.M*N ) THEN
C
C        Enough workspace for a fast BLAS 3 calculation.
C        Save A in the workspace and compute one of the matrix products
C          A : = alpha*op( triu( H ) ) * A, or
C          A : = alpha*A * op( triu( H ) ),
C        involving the upper triangle of H.
C
         CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M )
         CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H,
     $               LDH, A, LDA )
C
C        Add the contribution of the subdiagonal of H.
C        If SIDE = 'L', the subdiagonal of H is swapped with the
C        corresponding elements in the first column of H, and the
C        calculations are organized for column operations.
C
         IF( LSIDE ) THEN
            IF( M.GT.2 )
     $         CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
            IF( LTRANS ) THEN
               JW = 1
               DO 20 J = 1, N
                  JW = JW + 1
                  DO 10 I = 1, M - 1
                     A( I, J ) = A( I, J ) +
     $                           ALPHA*H( I+1, 1 )*DWORK( JW )
                     JW = JW + 1
   10             CONTINUE
   20          CONTINUE
            ELSE
               JW = 0
               DO 40 J = 1, N
                  JW = JW + 1
                  DO 30 I = 2, M
                     A( I, J ) = A( I, J ) +
     $                           ALPHA*H( I, 1 )*DWORK( JW )
                     JW = JW + 1
   30             CONTINUE
   40          CONTINUE
            END IF
            IF( M.GT.2 )
     $         CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
C
         ELSE
C
            IF( LTRANS ) THEN
               JW = 1
               DO 50 J = 1, N - 1
                  IF ( H( J+1, J ).NE.ZERO )
     $               CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1,
     $                           A( 1, J+1 ), 1 )
                  JW = JW + M
   50          CONTINUE
            ELSE
               JW = M + 1
               DO 60 J = 1, N - 1
                  IF ( H( J+1, J ).NE.ZERO )
     $               CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1,
     $                           A( 1, J ), 1 )
                  JW = JW + M
   60          CONTINUE
            END IF
         END IF
C
      ELSE
C
C        Use a BLAS 2 calculation.
C
         IF( LSIDE ) THEN
            IF( M.GT.2 )
     $         CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
            IF( LTRANS ) THEN
               DO 80 J = 1, N
C
C                 Compute the contribution of the subdiagonal of H to
C                 the j-th column of the product.
C
                  DO 70 I = 1, M - 1
                     DWORK( I ) = H( I+1, 1 )*A( I+1, J )
   70             CONTINUE
C
C                 Multiply the upper triangle of H by the j-th column
C                 of A, and add to the above result.
C
                  CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH,
     $                        A( 1, J ), 1 )
                  CALL DAXPY( M-1, ONE, DWORK, 1, A( 1, J ), 1 )
   80          CONTINUE
C
            ELSE
               DO 100 J = 1, N
C
C                 Compute the contribution of the subdiagonal of H to
C                 the j-th column of the product.
C
                  DO 90 I = 1, M - 1
                     DWORK( I ) = H( I+1, 1 )*A( I, J )
   90             CONTINUE
C
C                 Multiply the upper triangle of H by the j-th column
C                 of A, and add to the above result.
C
                  CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH,
     $                        A( 1, J  ), 1 )
                  CALL DAXPY( M-1, ONE, DWORK, 1, A( 2, J ), 1 )
  100          CONTINUE
            END IF
            IF( M.GT.2 )
     $         CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
C
         ELSE
C
C           Below, row-wise calculations are used for A.
C
            IF( N.GT.2 )
     $         CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
            IF( LTRANS ) THEN
               DO 120 I = 1, M
C
C                 Compute the contribution of the subdiagonal of H to
C                 the i-th row of the product.
C
                  DO 110 J = 1, N - 1
                     DWORK( J ) = A( I, J )*H( J+1, 1 )
  110             CONTINUE
C
C                 Multiply the i-th row of A by the upper triangle of H,
C                 and add to the above result.
C
                  CALL DTRMV( 'Upper', 'NoTranspose', 'Non-unit', N, H,
     $                        LDH, A( I, 1 ), LDA )
                  CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 2 ), LDA )
  120          CONTINUE
C
            ELSE
               DO 140 I = 1, M
C
C                 Compute the contribution of the subdiagonal of H to
C                 the i-th row of the product.
C
                  DO 130 J = 1, N - 1
                     DWORK( J ) = A( I, J+1 )*H( J+1, 1 )
  130             CONTINUE
C
C                 Multiply the i-th row of A by the upper triangle of H,
C                 and add to the above result.
C
                  CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', N, H,
     $                        LDH, A( I, 1 ), LDA )
                  CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 1 ), LDA )
  140          CONTINUE
            END IF
            IF( N.GT.2 )
     $         CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
C
         END IF
C
C        Scale the result by alpha.
C
         IF ( ALPHA.NE.ONE )
     $      CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA,
     $                   INFO )
      END IF
      RETURN
C *** Last line of MB01UW ***
      END


      MODULE MOD_BALINI
      use MOD_HYDTAB, only: MLINH,MHWL,MHE,MHT,ILIN0,WLINE,NWLH,NTH,NEH

      contains

C ********************************************************************
C ********************************************************************
C
      !*** replaced by HYDINI
      SUBROUTINE BALINI(IBVCS)
      use constants
      use MOD_HYDTAB
C
C     Initializes necessary arrays for evaluating Balmer-alpha thru
C     Balmer-delta absorption profiles from the modified
C     Vidal, Cooper and Smith (Ap.J.Suppl. 25, 37, 1973) tables
C
c      INCLUDE 'PARAMS.FOR'
c      INCLUDE 'MODELP.FOR'
      implicit real*8(a-h,o-z)
      integer,intent(in   ) :: IBVCS
      INCLUDE '../inc/PARAMS.FOR'
      INCLUDE '../inc/MODELP.FOR'
!      COMMON/VCSDAT/WL(36,8),XT(7,8),XNE(11,8),PRF(36,7,11)
!     *              ,NWLH(8),NTH(8),NEH(8)

      COMMON/AUXVCS/XK,FXK,BETAD,DBETA
      integer :: NWLBAL(MLINH)
      real*8  :: WLBAL(MLINH,MHWL)
      real*8  :: PRFBAL(MLINH,MDEPTH,MHWL)
      COMMON/HYDVCS/PRFBAL,WLBAL,NWLBAL
      DATA NLINE  /8/
!       WLINE=0
!       ILIN0=0
      ! OPEN(UNIT=IBVCS,STATUS='OLD',READONLY)
      WLINE(2,3:10) =  (/6562.80, 4861.32, 4340.46, 4101.73,
     *             3970.07, 3889.05, 3835.38, 3797.90/)
      BALINI_LINES: DO ILINE=1,NLINE
        WL0=WLINE(2,ILINE+2)
        ILIN0(2,ILINE+2)=ILINE
        !**
        !* read the modified VCS tables, which have to be stored in file
        !* unit IBVCS (which is the input parameter in the progarm)
        !**
        READ(IBVCS,501) JLINE,ILINE1
        READ(IBVCS,502) NWL,(WL(I,ILINE),I=1,NWL)
        READ(IBVCS,503) NT,(XT(I,ILINE),I=1,NT)
        READ(IBVCS,504) NE,(XNE(I,ILINE),I=1,NE)
        READ(IBVCS,500)
        NWLH(ILINE)=NWL
        NWLBAL(ILINE)=NWL
        NTH(ILINE)=NT
        NEH(ILINE)=NE
        DO I=1,NWL
          IF(WL(I,ILINE).LT.1.E-4) WL(I,ILINE)=1.E-4
          WLBAL(ILINE,I)=LOG10(WL(I,ILINE))
        ENDDO
        !*
        DO IE=1,NE
          DO IT=1,NT
            READ(IBVCS,500)
            READ(IBVCS,505) (PRF(IWL,IT,IE),IWL=1,NWL)
          ENDDO
        ENDDO
        !*****
        !* coefficient for the asymptotic profile is determined from
        !* the input data
        !*
        XCLOG=PRF(NWL,1,1)+2.5*LOG10(WL(NWL,ILINE))+31.5304-
     *         XNE(1,ILINE)-2.*LOG10(WL0)
        XKLOG=0.6666667*(XCLOG-0.176)
        XK=EXP(XKLOG*2.3025851)
        !*
        DO ID=1,ND
          !**********
          !* temperature is modified in order to account for the
          !* effect of turbulent velocity on the Doppler width
          !*
          T=TEMP(ID)+6.06E-9*VTURB(ID)
          ANE=ELEC(ID)
          TL=LOG10(T)
          ANEL=LOG10(ANE)
          F00=1.25E-9*ANE**0.666666667
          FXK=F00*XK
          DOP=1.E8/WL0*SQRT(1.65E8*T)
          DBETA=WL0*WL0/(CLIGHT_SI*1e10)/FXK
          BETAD=DBETA*DOP
          !*******
          !* interpolation to the actual values of temperature and
          !* electron density. The result is stored at array PRFBAL,
          !* having indices
          !* ILINE (line number: 1 for H-alpha,...,4 for H-delta, etc.);
          !* ID - depth index
          !* IWL - wavelength index
          !*
          DO IWL=1,NWL
              CALL INTVCS(PROF,TL,ANEL,IWL,ILINE)
              PRFBAL(ILINE,ID,IWL)=PROF
          ENDDO
        ENDDO
      ENDDO BALINI_LINES
C
  500 FORMAT(1X)
  501 FORMAT(//11X,I1,12X,I1/)
  502 FORMAT(1X,I4,6E10.3,5(/5X,6F10.4))
  503 FORMAT(1X,I4,7F10.3)
  504 FORMAT(1X,I4,6F10.2/5X,5F10.2)
  505 FORMAT(10F8.3)
      RETURN
      END SUBROUTINE

      !**** replaced by INTHYD
      SUBROUTINE INTVCS(W0,X0,Z0,IWL,ILINE)
      use MOD_SYNSUBM
      use MOD_HYDTAB

C
C     Interpolation in temperature and electron density from the
C     modified VCS tables for Balmer lines to the actual valus of
C     temperature and electron density
C
      USE MOD_ERROR
c      INCLUDE 'IMPLIC.FOR'
      INCLUDE '../inc/IMPLIC.FOR'
      integer,intent(in   ) :: IWL,ILINE
      real*8, intent(in   ) :: X0,Z0
      real*8, intent(  out) :: W0
      PARAMETER (TWO=2.D0)
      COMMON/AUXVCS/XK,FXK,BETAD,DBETA
!      COMMON/VCSDAT/WL(36,8),XT(7,8),XNE(11,8),PRF(36,7,11)
!     *              ,NWLH(8),NTH(8),NEH(8)
      DIMENSION ZZ(3),XX(3),WX(3),WZ(3)
C
      NX=3
      NZ=3
      NT=NTH(ILINE)
      NE=NEH(ILINE)
      COUNTER=COUNTER+1
C
C     for values lower than the lowest grid value of electron density
C     the profiles are determined by the approximate expression
C     (see STARKA); not by an extrapolation in the VCS tables which may
C     be very inaccurate
C
      IF(Z0.LT.XNE(1,ILINE)*0.99) THEN
         CALL DIVSTR(BETAD,A,DIV)
         W0=STARKA(WL(IWL,ILINE)/FXK,BETAD,A,DIV,TWO)*DBETA
         W0=LOG10(W0)
         GO TO 500
      END IF
C
C     Otherwise, one interpolates (or extrapolates for higher than the
C     highes grid value of electron density) in the VCS tables
C
      DO 10 IZZ=1,NE-1
         IPZ=IZZ
         IF(Z0.LE.XNE(IZZ+1,ILINE)) GO TO 20
   10 CONTINUE
   20 N0Z=IPZ-NZ/2+1
      IF(N0Z.LT.1) N0Z=1
      IF(N0Z.GT.NE-NZ+1) N0Z=NE-NZ+1  ! N0Z = min(N0Z, NE-NZ+1)
      IF(N0Z.LT.1) THEN
        PRINT '("N0Z=",I7," NE=",I7," NZ=",I7)',N0Z, NE, NZ
        call ERROR('ERROR: synsubm: Index to small: N0Z')
      ENDIF
      N1Z=N0Z+NZ-1
C
      DO 300 IZZ=N0Z,N1Z
         I0Z=IZZ-N0Z+1
         ZZ(I0Z)=XNE(IZZ,ILINE)
C
C     Likewise, the approximate expression instead of extrapolation
C     is used for higher that the highest grid value of temperature,
C     if the Doppler width expressed in beta units (BETAD) is
C     sufficiently large (> 10)
C
         IF(X0.GT.1.1*XT(NT,ILINE).AND.BETAD.GT.10.) THEN
            CALL DIVSTR(BETAD,A,DIV)
            W0=STARKA(WL(IWL,ILINE)/FXK,BETAD,A,DIV,TWO)*DBETA
            W0=LOG10(W0)
            GO TO 500
         END IF
C
C     Otherwise, normal inter- or extrapolation
C
C     Both interpolations (in T as well as in electron density) are
C     by default the quadratic interpolations in logarithms
C
         DO 30 IX=1,NT-1
            IPX=IX
            IF(X0.LE.XT(IX+1,ILINE)) GO TO 40
   30    CONTINUE
   40    N0X=IPX-NX/2+1
         IF(N0X.LT.1) N0X=1
         IF(N0X.GT.NT-NX+1) N0X=NT-NX+1
         N1X=N0X+NX-1
         DO 200 IX=N0X,N1X
            I0=IX-N0X+1
            XX(I0)=XT(IX,ILINE)
            WX(I0)=PRF(IWL,IX,IZZ)
  200       CONTINUE
         WZ(I0Z)=YINT(XX,WX,X0)
  300 CONTINUE
      W0=YINT(ZZ,WZ,Z0)
  500 CONTINUE
      RETURN
      END SUBROUTINE
      END MODULE


      SUBROUTINE W3FI76(PVAL,KEXP,KMANT,KBITS)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:  W3FI76        CONVERT TO IBM370 FLOATING POINT
C   PRGMMR: REJONES          ORG: NMC421      DATE:92-11-16
C
C ABSTRACT: CONVERTS FLOATING POINT NUMBER FROM MACHINE
C   REPRESENTATION TO GRIB REPRESENTATION (IBM370 32 BIT F.P.).
C
C PROGRAM HISTORY LOG:
C   85-09-15  JOHN HENNESSY  ECMWF
C   92-09-23  JONES R. E.    CHANGE NAME, ADD DOC BLOCK
C   93-10-27  JONES,R. E.    CHANGE TO AGREE WITH HENNESSY CHANGES
C   95-10-31  IREDELL        REMOVED SAVES AND PRINTS
C   98-03-10  B. VUONG       REMOVE THE CDIR$ INTEGER=64 DIRECTIVE
C
C USAGE:    CALL W3FI76 (FVAL, KEXP, KMANT, NBITS)
C   INPUT ARGUMENT LIST:
C     PVAL     - FLOATING POINT NUMBER TO BE CONVERTED
C     KBITS    - NUMBER OF BITS IN COMPUTER WORD (32 OR 64)
C
C   OUTPUT ARGUMENT LIST:
C     KEXP     -  8 BIT SIGNED EXPONENT
C     KMANT    - 24 BIT  MANTISSA  (FRACTION)
C
C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C
C ATTRIBUTES:
C   LANGUAGE: IBM370 VS FORTRAN 77, CRAY CFT77 FORTRAN
C   MACHINE:  HDS 9000, CRAY Y-MP8/864< CRAY Y-MP EL2/256
C
C$$$
C
C********************************************************************
C*
C*    NAME      : CONFP3
C*
C*    FUNCTION  : CONVERT FLOATING POINT NUMBER FROM MACHINE
C*                REPRESENTATION TO GRIB REPRESENTATION.
C*
C*    INPUT     : PVAL  - FLOATING POINT NUMBER TO BE CONVERTED.
C*    KBITS     : KBITS - NUMBER OF BITS IN COMPUTER WORD
C*
C*    OUTPUT    : KEXP  - 8 BIT SIGNED EXPONENT
C*                KMANT - 24 BIT MANTISSA
C*                PVAL  - UNCHANGED.
C*
C*    JOHN HENNESSY , ECMWF   18.06.91
C*
C********************************************************************
C
C
C     IMPLICIT NONE
C
      INTEGER IEXP
      INTEGER ISIGN
C
      INTEGER KBITS
      INTEGER KEXP
      INTEGER KMANT
C
      REAL PVAL
      REAL ZEPS
      REAL ZREF
C
C     TEST FOR FLOATING POINT ZERO
C
      IF (PVAL.EQ.0.0) THEN
        KEXP  = 0
        KMANT = 0
        GO TO 900
      ENDIF
C
C     SET ZEPS TO 1.0E-12 FOR 64 BIT COMPUTERS (CRAY)
C     SET ZEPS TO 1.0E-8  FOR 32 BIT COMPUTERS
C
      IF (KBITS.EQ.32) THEN
        ZEPS = 1.0E-8
      ELSE
        ZEPS = 1.0E-12
      ENDIF
      ZREF = PVAL
C
C     SIGN OF VALUE
C
      ISIGN = 0
      IF (ZREF.LT.0.0) THEN
        ISIGN =   128
        ZREF    = - ZREF
      ENDIF
C
C     EXPONENT
C
      IEXP = INT(ALOG(ZREF)*(1.0/ALOG(16.0))+64.0+1.0+ZEPS)
C
      IF (IEXP.LT.0  ) IEXP = 0
      IF (IEXP.GT.127) IEXP = 127
C
C     MANTISSA
C
C     CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER
C     (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER).
C
      KMANT = NINT (ZREF/16.0**(IEXP-70))
C
C     CHECK THAT MANTISSA VALUE DOES NOT EXCEED 24 BITS
C     16777215 = 2**24 - 1
C
      IF (KMANT.GT.16777215) THEN
         IEXP  = IEXP + 1
C
C     CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER
C     (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER).
C
         KMANT = NINT (ZREF/16.0**(IEXP-70))
C
C        CHECK MANTISSA VALUE DOES NOT EXCEED 24 BITS AGAIN
C
         IF (KMANT.GT.16777215) THEN
           PRINT *,'BAD MANTISSA VALUE FOR PVAL = ',PVAL
         ENDIF
      ENDIF
C
C     ADD SIGN BIT TO EXPONENT.
C
      KEXP = IEXP + ISIGN
C
  900 CONTINUE
C
      RETURN
      END


module mod_monolis_precond_diag_33
  use mod_monolis_prm
  use mod_monolis_com
  use mod_monolis_mat

  implicit none

  private
  public :: monolis_precond_diag_33_setup
  public :: monolis_precond_diag_33_apply
  public :: monolis_precond_diag_33_clear

contains

  subroutine monolis_precond_diag_33_setup(monoMAT)
    implicit none
    type(monolis_prm) :: monoPRM
    type(monolis_com) :: monoCOM
    type(monolis_mat) :: monoMAT
    integer(kind=kint) :: i, j, jS, jE, in, k, l, N
    integer(kind=kint), pointer :: index(:), item(:)
    real(kind=kdouble) :: T(3,3), P(3)
    real(kind=kdouble), pointer :: A(:), ALU(:)

    N =  monoMAT%N
    A => monoMAT%A
    index => monoMAT%index
    item => monoMAT%item

    allocate(monoMAT%monoTree%D(9*N))
    ALU => monoMAT%monoTree%D
    ALU = 0.0d0

    do i = 1, N
      jS = index(i-1) + 1
      jE = index(i)
      do j = jS, jE
        in = item(j)
        if(i == in)then
          ALU(9*i-8) = A(9*j-8)
          ALU(9*i-7) = A(9*j-7)
          ALU(9*i-6) = A(9*j-6)
          ALU(9*i-5) = A(9*j-5)
          ALU(9*i-4) = A(9*j-4)
          ALU(9*i-3) = A(9*j-3)
          ALU(9*i-2) = A(9*j-2)
          ALU(9*i-1) = A(9*j-1)
          ALU(9*i  ) = A(9*j  )
        endif
      enddo
    enddo

    do l = 1, N
      T(1,1) = ALU(9*l-8)
      T(1,2) = ALU(9*l-7)
      T(1,3) = ALU(9*l-6)
      T(2,1) = ALU(9*l-5)
      T(2,2) = ALU(9*l-4)
      T(2,3) = ALU(9*l-3)
      T(3,1) = ALU(9*l-2)
      T(3,2) = ALU(9*l-1)
      T(3,3) = ALU(9*l  )
      do k = 1, 3
        T(k,k) = 1.0d0/T(k,k)
        do i = k+1, 3
          T(i,k) = T(i,k) * T(k,k)
          do j = k+1, 3
            P(j) = T(i,j) - T(i,k)*T(k,j)
          enddo
          do j = k+1, 3
            T(i,j) = P(j)
          enddo
        enddo
      enddo
      ALU(9*l-8) = T(1,1)
      ALU(9*l-7) = T(1,2)
      ALU(9*l-6) = T(1,3)
      ALU(9*l-5) = T(2,1)
      ALU(9*l-4) = T(2,2)
      ALU(9*l-3) = T(2,3)
      ALU(9*l-2) = T(3,1)
      ALU(9*l-1) = T(3,2)
      ALU(9*l  ) = T(3,3)
    enddo
  end subroutine monolis_precond_diag_33_setup

  subroutine monolis_precond_diag_33_apply(monoMAT, X, Y)
    implicit none
    type(monolis_prm) :: monoPRM
    type(monolis_com) :: monoCOM
    type(monolis_mat) :: monoMAT
    integer(kind=kint) :: i
    real(kind=kdouble) :: X1, X2, X3
    real(kind=kdouble) :: X(:), Y(:)
    real(kind=kdouble), pointer :: ALU(:)

    ALU => monoMAT%monoTree%D
    do i = 1, monoMAT%N
      X1 = X(3*i-2)
      X2 = X(3*i-1)
      X3 = X(3*i  )
      X2 = X2 - ALU(9*i-5)*X1
      X3 = X3 - ALU(9*i-2)*X1 - ALU(9*i-1)*X2
      X3 = ALU(9*i  )* X3
      X2 = ALU(9*i-4)*(X2 - ALU(9*i-3)*X3)
      X1 = ALU(9*i-8)*(X1 - ALU(9*i-6)*X3 - ALU(9*i-7)*X2)
      Y(3*i-2) = X1
      Y(3*i-1) = X2
      Y(3*i  ) = X3
    enddo
  end subroutine monolis_precond_diag_33_apply

  subroutine monolis_precond_diag_33_clear(monoMAT)
    implicit none
    type(monolis_mat) :: monoMAT
    real(kind=kdouble), pointer :: ALU(:)
    ALU => monoMAT%monoTree%D
    deallocate(ALU)
  end subroutine monolis_precond_diag_33_clear

end module mod_monolis_precond_diag_33


	SUBROUTINE OA_LTLN  ( kex, key, iextnd, gelat, gelon, coslat,
     +			      iret )
C************************************************************************
C* OA_LTLN								*
C*									*
C* This subroutine computes the latitude and longitude at each grid 	*
C* point in the extend grid area.  The grid coordinate system must	*
C* be defined in GEMPLT before this subroutine is called.		*
C*									*
C* OA_LTLN  ( KEX, KEY, IEXTND, GELAT, GELON, COSLAT, IRET )		*
C*									*
C* Input parameters:							*
C*	KEX		INTEGER		# of x points in extend grid	*
C*	KEY		INTEGER		# of y points in extend grid	*
C*	IEXTND (4)	INTEGER		# of points to extend grid	*
C*									*
C* Output parameters:							*
C*	GELAT (KEX,KEY)	REAL		Latitudes in degrees		*
C*	GELON (KEX,KEY)	REAL		Longitudes in degrees		*
C*	COSLAT(KEX,KEY)	REAL		Cosine of latitude 		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -2 = grid projection error	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	11/88	From GR_LTLN				*
C* K. Brill/NMC		06/91	Pass out cosine instead of cosine 	*
C*				squared of latitude			*
C* K. Brill/NMC         01/92   Replace GERROR with ER_WMSG             *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		gelat (*), gelon (*), coslat (*)
	INTEGER		iextnd (*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Get grid values in grid coordinates.
C
	kxstrt = 1   - iextnd (1)
	kxstop = kex - iextnd (1)
	kystrt = 1   - iextnd (2)
	kystop = key - iextnd (2)
C
C*	Fill x, y arrays with grid point values.
C
	k = 0
	DO  i = kystrt, kystop
	    fi =  FLOAT (i)
	    DO  j = kxstrt, kxstop
	        k = k + 1
	        gelon (k) = fi
	    END DO
	END DO
C
	DO  j = kxstrt, kxstop
	    fj = FLOAT (j)
	    k  = j + iextnd (1)
	    DO  i = kystrt, kystop
	        gelat (k) = fj
	        k = k + kex
	    END DO
	END DO
C
C*	Transform the points.
C
	kexy = kex * key
	CALL GTRANS ( 'G', 'M', kexy, gelat, gelon, gelat, gelon, iret )
	IF  ( iret .ne. 0 )  THEN
	    CALL ER_WMSG  ( 'GEMPLT', iret, ' ', ier )
	    iret = -2
	    RETURN
	END IF
C
C*	Compute the square of the cosine of the latitude.
C
	DO  i = 1, kexy
	    IF  ( ERMISS ( gelat (i) ) )  THEN
		coslat (i) = 0.
	      ELSE
		coslat (i) = COS ( gelat (i) * DTR )
	    END IF
	END DO
C*
	RETURN
	END


program plot_single_spectrum
  implicit none

  integer, parameter :: spec_dim = 2999
  integer, parameter :: nmaxp = 5000
  double precision, parameter :: ergsev  = 1.602197d-12 ! Convert eV to ergs

  integer    :: i, unit, rownum, rowmax, start_ind, end_ind, index_scat, index_xil
  integer    :: par_dim
  real       :: threshold, E, dE, ratio, temp, spec(spec_dim)
  real       :: ene_lo(spec_dim), ene_hi(spec_dim)
  real       :: earx(0 : spec_dim)
  ! real       :: en(spec_dim)
  real, allocatable :: par_val(:), save_par_val(:)
  character (len=200) :: filename, hdu_name
  integer           , allocatable :: num_of_val_par(:)
  character (len=12), allocatable :: par_names(:)

  double precision :: wp(nmaxp), spec_dble
  real             :: Icomp_scat(nmaxp)

  ! real, allocatable   :: spec_ref(:), spec(:)
  ! if (.not. allocated(spec_ref)) allocate(spec_ref(spec_dim))
  ! if (.not. allocated(spec)    ) allocate(spec    (spec_dim))

     filename = '/Users/gullo/Software/relxill/tables/xillverCp_v3.6.fits' !xillver-comp.fits

     ! Emax = 100.0
     ! Emin = 0.07177
     ! dloge = log10( Emax / Emin ) / float(spec_dim)
     ! do i = 0, spec_dim
     !    earx(i) = Emin * (Emax/Emin)**(float(i)/float(spec_dim))
     !    ! write(*,*) i, earx(i)
     ! end do

     !Open the fits file and leave it opened
     call open_fits(filename, unit)

     hdu_name = 'PARAMETERS'
     call get_rownum(unit, hdu_name, rowmax)
     par_dim = rowmax
     write(*,*) 'number of parameters in the table', par_dim

     allocate(par_names(par_dim))
     allocate(num_of_val_par(par_dim))
     call get_parameters(unit, par_dim, par_names, num_of_val_par)

     call get_energy(unit, spec_dim, ene_lo, ene_hi)

     do i = 1, spec_dim
        earx(i - 1) =  ene_lo(i)
     enddo
     earx(spec_dim) = ene_hi(spec_dim)

     allocate(par_val(par_dim))
     allocate(save_par_val(par_dim))

     hdu_name = 'SPECTRA'
     call get_rownum(unit, hdu_name, rowmax)

     !range between 20keV and 50keV (1713 - 1991)
     !range between 25keV and 35keV (1782 - 1883)
     start_ind = 1713
     end_ind   = 1991
     threshold = 1e2

     open (21, file='xillver_comp_scatt_spectrum.qdp')
     write(21,*) 'skip on'
     ! open (20, file='xill_spectra_parameters.txt')

     write(*,*) '   Insert the number of the spectrum'
     read(*,*) rownum
     ! rownum = 338382

     if (rownum .gt. rowmax) then
        write(*,'(A, I8, A)') '  there are only ', rowmax,' spectra in the table'
        stop
     else
        ! get the parameters (par_val) and the spectrum (spec)
        call get_par_and_spec(unit, rownum, par_dim, par_val, spec_dim, spec)
        write(*,*) '  Spec number      Gamma        A_Fe             log_xi            kTe              Dens             Incl               ratio'
        write(*,*) par_val

        !let's work on the predicted flux for the parameter that we extracted
        call compton_hump_estimate(nmaxp, par_dim, par_val, wp, Icomp_scat)

        do i = 1, spec_dim - 1
           dE = (ene_hi(i) - ene_lo(i))
           E  = (ene_hi(i) + ene_lo(i)) * 0.5
           spec_dble = dble(spec(i)) * dble(E/dE)
           write(21, *) E, spec_dble * E   ! (E * 1e20 / dE) this is the factor to get the specifit intensity in keV
        enddo
        write(21,*) 'no no'

        do i = 1, nmaxp - 1
          write(21,*) wp(i) / 1e3, Icomp_scat(i) * (wp(i) / 1e3) / 1e20
        enddo
        write(21,*) 'no no'

        !find energy index that peaks at the compton hump
        temp = 0.0
        do i = start_ind,  end_ind
           index_xil = i
           ! E  = (ene_hi(index_xil) + ene_lo(index_xil)) * 0.5
           ! write(*,*) E,  spec(i)
           !this if statement checks when the spectrum starts to decrease
           if (temp .gt. spec(i)) then
              exit
           endif
           temp = spec(i)
        enddo

        dE  = ene_hi(index_xil) - ene_lo(index_xil)
        E  = (ene_hi(index_xil) + ene_lo(index_xil)) * 0.5

        ! write(*,*) 'peak of the compton hump in keV (energy index and spectrum value)', E, index_xil, spec(index_xil)
        ! write(*,*)

        !find the compton hump energy at
        do i = 1, nmaxp
           index_scat = i
           ! write(*,*) 'compare ', (wp(i) / 1e3), E
           if (abs((wp(i) / 1e3) - E) .lt. 0.1) then
              ! write(*,*) 'the corrisponding energy of the scattering spectrum is (index)', wp(i) / 1e3, index_scat
              exit
           endif
        enddo

        spec_dble = dble(spec(index_xil)) * dble(E/dE) * 1e20
        ratio = abs(dble(Icomp_scat(index_scat)) - spec_dble ) / dble(Icomp_scat(index_scat))
        ! write(12, *) j, ratio, Icomp_scat(index_scat), spec(index_xil) * E * 1e20 / dE

        write(21,*) 'scr white'
        write(21,*) 'log y x on'
        close(21)
        call close_fits(unit)

        write(*,*)
        write(*,*) 'Value of the scattering spectrum and the xillver spectrum', Icomp_scat(index_scat), spec_dble
        write(*,*) 'Value of the energies of the compton hump in the xillver spectrum and in the scattering spectrum ',&
             E, wp(index_scat) / 1e3
        write(*,*)
        write(*,*) 'relative ratio between the scattering spectrum and xillver at the compton hump energy', ratio

        write(*,*)
        write(*,*)
     endif

   end program plot_single_spectrum


!=======================================================================
!  SoilKi_init
!
!  Initalize inorganic soil K variables using extractable K from
!     soil file (EXK).
!-----------------------------------------------------------------------
!  REVISION HISTORY
!  10/31/2007 US / CHP Written
!-----------------------------------------------------------------------
!  Called by: SoilKi
!=======================================================================

      SUBROUTINE SoilKi_init (CONTROL, ISWPOT, SOILPROP,  !Input
     &    KFertIndex, Ki_Avail, SKi_Avail,                !Output
     &    SKi_Tot, SKiAvlProf, SKiTotProf)                !Output

!     ------------------------------------------------------------------
      USE ModuleDefs
      IMPLICIT  NONE
      SAVE
!     ------------------------------------------------------------------
      CHARACTER*1  ISWPOT
      CHARACTER*6, PARAMETER :: ERRKEY = 'SKINIT'
      CHARACTER*78 MSG(3)
      TYPE (ControlType) CONTROL

      INTEGER L
      INTEGER NLAYR

!     Soil properties:
      REAL SKiAvlProf, SKiTotProf
      REAL, DIMENSION(NL) :: Ki_Avail, Ki_Tot, SKi_Avail, SKi_Tot
      REAL, DIMENSION(NL) :: KFertIndex, KExchgIndex, KAvailIndex,KG2PPM
      TYPE (SoilType)    SOILPROP

!     ------------------------------------------------------------------
      IF (ISWPOT .NE. 'Y') RETURN

      NLAYR    = SOILPROP % NLAYR
      KG2PPM   = SOILPROP % KG2PPM

!     Initialize total soil K only once
      IF (CONTROL % RUN == 1 .OR. INDEX('QF',CONTROL % RNMODE) <= 0)THEN
        DO L = 1, NLAYR
          IF (SOILPROP % EXK(L) < 0.0) THEN
            MSG(1) = "Missing value found in soil file for potassium."
            MSG(2) = "Cannot run potassium model for this data."
            MSG(3) = "Model will stop."
            CALL WARNING(3,ERRKEY,MSG)
            CALL ERROR(ERRKEY,0," ",0)
          ENDIF
          Ki_Tot(L) = SOILPROP % EXK(L) * 391.
        ENDDO
      ENDIF

!     Update availability indices every season. May be important for
!       long-term sequence simulations.
      SKiAvlProf = 0.
      SKiTotProf = 0.

      DO L = 1, NLAYR
        IF (SOILPROP % OC(L) > 1.E-5) THEN
           KFertIndex(L) = 1.05 + 0.5 * LOG(SOILPROP % OC(L))
        ELSE
           KFertIndex(L) = 0.05   !Value of function at 1.E-6
        ENDIF

        IF (SOILPROP % CEC(L) > 1.E-5) THEN
         KExchgIndex(L) = MIN(1.0, 17.5* SOILPROP % EXK(L) /
     &                      SOILPROP % CEC(L))
        ELSE
          KExchgIndex(L) = 1.00
        ENDIF

        KAvailIndex(L) = MIN(KFertIndex(L), KExchgIndex(L), 1.0)

        Ki_Avail(L) = Ki_Tot(L) * KAvailIndex(L)
        SKi_Avail(L) = Ki_Avail(L) / KG2PPM(L)
        SKi_Tot(L)   = Ki_Tot(L)   / KG2PPM(L)
        SKiAvlProf = SKiAvlProf + SKi_Avail(L)
        SKiTotProf = SKiTotProf + SKi_Tot(L)
      ENDDO

!     ------------------------------------------------------------------
      RETURN
      END SUBROUTINE SoilKi_init

!=======================================================================


c do continuum subtraction by subtracting a low order polynomial
c fit to the good data points.
c I added a sigma-clipping routine before the fit, which may not
c work great since the continuum varies, avsigclip or something
c would be better.

c do the subtraction in place, or not
c      subroutine contsubmed(spec,nsp,dwlog,wrad,specout)
      subroutine contsubpoly(wave,spec,serr,nsp,iord)

c      parameter (IORDER=15)

      real wave(nsp),spec(nsp),serr(nsp)
      real wscale(nsp),specclip(nsp)
      real wfit(nsp),ffit(nsp),efit(nsp)
      real a(iord),uu(nsp,iord),vv(iord,iord),ww(iord)
      real avals(iord)

      external polyfuncs

      include 'pcredshift.h'

      ncliprad=100
      clipsig=2.0
      call localsigclip(nsp,spec,specclip,ncliprad,clipsig)

      wrange = wave(nsp) - wave(1)
      do i=1,nsp
c rescale wfit to run between 0 and 1 for improved polynomial fitting
         wscale(i) = (wave(i) - wave(1)) / wrange
      end do

      npoly=iord
      nfit=0
      do i=1,nsp
         if(specclip(i) .gt. bad .and. serr(i) .gt. bad
     $        .and. serr(i) .lt. 1.0e6) then
            nfit=nfit+1
            wfit(nfit)=wscale(i)
            ffit(nfit)=specclip(i)
            efit(nfit)=serr(i)
         end if
      end do
      if (nfit .le. npoly) return

c do fit
      call bigsvdfit(wfit,ffit,efit,nfit,a,npoly,uu,vv,ww,nsp,iord,
     $     chisq,polyfuncs)

c evaluate and subtract fit
      do i=1,nsp
c         call polyfuncs(wave(i),avals,npoly)
         call polyfuncs(wscale(i),avals,npoly)
         fitval = 0.
         do j=1,npoly
            fitval = fitval + a(j)*avals(j)
         end do
         if (spec(i) .gt. bad) then
            spec(i) = spec(i) - fitval
         end if
      end do

      return
      end

cccccccccccccccccccccccccccccc
      subroutine polyfuncs(x,a,nord)
c IPOLY: 1 for simple polynomial: 1,x,x^2,...
      parameter(IPOLY=1)

      real a(nord)

      if (IPOLY .eq. 1) then
         a(1) = 1.0
         do i=2,nord
            a(i) = a(i-1)*x
         end do
      end if

      return
      end


MODULE sct1uft_3d_module

    ! --
    ! This module contains the subroutines of 2D connected-component labeling (CCL)
    ! of which the algorithm is introduced by Wu et. al (2009).
    !
    ! Then the method is adapted to 3-D usage according to He et. al (2011)
    ! for 6-connection in 3-D.
    !
    ! Only the subroutines related to the first_scan is in this file.
    ! Union-find-tree algorithm is used in the first_scan in order to build a
    ! label connection table.
    !
    ! -- Hsiao, Wei-Ting (floatlikecloud) wrote in Oct 2017

    use useful_module
    use unionFindTree_module
    implicit none
    CONTAINS
    SUBROUTINE first_scan(image_3d, label_3d, connectionTable, nx, ny, nz)
        ! This is the main subroutine of this module,
        ! that packed all the processes during the first_scan.
        implicit none
        integer, intent(in)     :: image_3d(:,:,:), ny, nx, nz
        integer, intent(inout)  :: label_3d(:,:,:), connectionTable(:)
        integer                 :: xCtr, yCtr, zCtr
        integer                 :: lCtr ! new labeling counter
        logical                 :: xStat, yStat, zStat
                                   ! if *Stat = .FALSE. , *axis is at lower boundary
                                   ! if *Stat = .TRUE.  , *axis is normal or at upper boundary
        xStat = .FALSE.
        yStat = .FALSE.
        zStat = .FALSE.
        lCtr = 1
        ! start scanning
        do zCtr = 1, nz
            yStat = .FALSE. ! reset y
            do yCtr = 1, ny
                xStat = .FALSE. ! reset x
                do xCtr = 1, nx
                    if (image_3d(xCtr,yCtr,zCtr).eq.0) then
                        label_3d(xCtr,yCtr,zCtr) = 0
                    else
                        ! label if image(currentPixel) = 1
                        CALL decision_tree(label_3d, connectionTable, xCtr, yCtr, zCtr, xStat, yStat, zStat, lCtr)
                    end if
                    xStat = .TRUE.
                end do
                yStat = .TRUE.
            end do
            zStat = .TRUE.
        end do
        ! end scanning

        ! relabel the labels in the table into consecutive integers
        if (lCtr.gt.nx*ny*nz/2) STOP 'lCtr boom'
        CALL flattenL(connectionTable, lCtr)
    END SUBROUTINE

    SUBROUTINE decision_tree(label_3d, connectionTable, xCtr, yCtr, zCtr, xStat, yStat, zStat, lCtr)
        ! Decide the label by searching the pixels in the mask.
        ! Using "forward mask" + "6-connection"
        !
        ! currentPixel: n
        ! z=zCtr-1        z=zCtr        z=zCtr+1
        ! |-|-|-|        |-|k|-|        |-|-|-|
        ! |-|e|-|        |m|n|-|        |-|-|-|
        ! |-|-|-|        |-|-|-|        |-|-|-|
        !
        implicit none
        integer, intent(in)     :: xCtr, yCtr, zCtr
        logical, intent(in)        :: xStat, yStat, zStat
        integer, intent(inout)    :: label_3d(:,:,:), connectionTable(:), lCtr
        integer :: mYES, kYES, eYES, decision

        mYES = 0
        kYES = 0
        eYES = 0
        if (xStat) then
            if (label_3d(xCtr-1,yCtr,zCtr).ne.0) then
                mYES = 1
            end if
        end if
        if (yStat) then
            if (label_3d(xCtr,yCtr-1,zCtr).ne.0) then
                kYES = 1
            end if
        end if
        if (zStat) then
            if (label_3d(xCtr,yCtr,zCtr-1).ne.0) then
                eYES = 1
            end if
        end if
        !write(*,'(A11,I1,A1,I1,A1,I1,A1)') '(x,y,z) = (',xCtr,',',yCtr,',',zCtr,')'
        !write(*,'(A11,I1,A1,I1,A1,I1,A1)') '(m,k,e) = (',mYES,',',kYES,',',eYES,')'
        decision = mYES + kYES*2 + eYES*4

        SELECT CASE(decision)

            CASE(0) ! (m,k,e) = (0,0,0)
                CALL new_label(label_3d, connectionTable, xCtr, yCtr, zCtr, lCtr)
            CASE(1) ! (m,k,e) = (1,0,0)
                CALL copy_one(label_3d, connectionTable, xCtr, yCtr, zCtr, -1, 0, 0)
            CASE(2) ! (m,k,e) = (0,1,0)
                CALL copy_one(label_3d, connectionTable, xCtr, yCtr, zCtr, 0, -1, 0)
            CASE(3) ! (m,k,e) = (1,1,0)
                CALL copy_two(label_3d, connectionTable, xCtr, yCtr, zCtr, -1, 0, 0, 0, -1, 0)
            CASE(4) ! (m,k,e) = (0,0,1)
                CALL copy_one(label_3d, connectionTable, xCtr, yCtr, zCtr, 0, 0, -1)
            CASE(5) ! (m,k,e) = (1,0,1)
                CALL copy_two(label_3d, connectionTable, xCtr, yCtr, zCtr, -1, 0, 0, 0, 0, -1)
            CASE(6) ! (m,k,e) = (0,1,1)
                CALL copy_two(label_3d, connectionTable, xCtr, yCtr, zCtr, 0, -1, 0, 0, 0, -1)
            CASE DEFAULT ! (m,k,e) = (1,1,1)
                CALL copy_three(label_3d, connectionTable, xCtr, yCtr, zCtr, -1, 0, 0, 0, -1, 0, 0, 0, -1)

        END SELECT

        CONTAINS
        SUBROUTINE copy_one(label_3d, connectionTable, xCtr, yCtr, zCtr, xShift, yShift, zShift)
            implicit none
            integer, intent(inout) :: label_3d(:,:,:), connectionTable(:)
            integer, intent(in)    :: xCtr, yCtr, zCtr, xShift, yShift, zShift

            label_3d(xCtr,yCtr,zCtr) = label_3d(xCtr+xShift, yCtr+yShift, zCtr+zShift)
        END SUBROUTINE copy_one

        SUBROUTINE copy_two(label_3d, connectionTable, xCtr, yCtr, zCtr, &
                            x1Shift, y1Shift, z1Shift, x2Shift, y2Shift, z2Shift)
            implicit none
            integer, intent(inout) :: label_3d(:,:,:), connectionTable(:)
            integer, intent(in)    :: xCtr, yCtr, zCtr, x1Shift, y1Shift, z1Shift, x2Shift, y2Shift, z2Shift

            CALL union(connectionTable, label_3d(xCtr+x1Shift, yCtr+y1Shift, zCtr+z1Shift), &
                       label_3d(xCtr+x2Shift, yCtr+y2Shift, zCtr+z2Shift), label_3d(xCtr,yCtr,zCtr))
        END SUBROUTINE copy_two

        SUBROUTINE copy_three(label_3d, connectionTable, xCtr, yCtr, zCtr, x1Shift, y1Shift, z1Shift, &
                            x2Shift, y2Shift, z2Shift, x3Shift, y3Shift, z3Shift)
            implicit none
            integer, intent(inout) :: label_3d(:,:,:), connectionTable(:)
            integer, intent(in)    :: xCtr, yCtr, zCtr, x1Shift, y1Shift, z1Shift, &
                                        x2Shift, y2Shift, z2Shift, x3Shift, y3Shift, z3Shift
            integer :: label_1, root_1, label_2, root_2

            ! First, arbitrary union two tree
            if (connectionTable(label_3d(xCtr+x1Shift, yCtr+y1Shift, zCtr+z1Shift)).ge.&
            connectionTable(label_3d(xCtr+x2Shift, yCtr+y2Shift, zCtr+z2Shift))) then
                label_1 = label_3d(xCtr+x1Shift, yCtr+y1Shift, zCtr+z1Shift)
                root_1 = connectionTable(label_3d(xCtr+x1Shift, yCtr+y1Shift, zCtr+z1Shift))
            else
                label_1 = label_3d(xCtr+x2Shift, yCtr+y2Shift, zCtr+z2Shift)
                root_1 = connectionTable(label_3d(xCtr+x2Shift, yCtr+y2Shift, zCtr+z2Shift))
            end if
            CALL union(connectionTable, label_3d(xCtr+x1Shift, yCtr+y1Shift, zCtr+z1Shift), &
                       label_3d(xCtr+x2Shift, yCtr+y2Shift, zCtr+z2Shift), label_3d(xCtr,yCtr,zCtr))

            if (root_1.ge.connectionTable(label_3d(xCtr+x3Shift, yCtr+y3Shift, zCtr+z3Shift))) then
                label_2 = label_1
                root_2  = root_1
            else
                label_2 = label_3d(xCtr+x3Shift, yCtr+y3Shift, zCtr+z3Shift)
                root_2  = connectionTable(label_3d(xCtr+x3Shift, yCtr+y3Shift, zCtr+z3Shift))
            end if
            CALL union(connectionTable, label_1, label_3d(xCtr+x3Shift, yCtr+y3Shift, zCtr+z3Shift), label_3d(xCtr,yCtr,zCtr))
        END SUBROUTINE copy_three

        SUBROUTINE new_label(label_3d, connectionTable, xCtr, yCtr, zCtr, lCtr)
            implicit none
            integer, intent(inout) :: label_3d(:,:,:), connectionTable(:), lCtr
            integer, intent(in)    :: xCtr, yCtr, zCtr

            label_3d(xCtr,yCtr,zCtr) = lCtr
            connectionTable(lCtr) = lCtr
            lCtr = lCtr + 1
        END SUBROUTINE new_label

    END SUBROUTINE decision_tree

END MODULE sct1uft_3d_module


! ######################################################################
! ######################################################################
! ###########     _                           ____  ____      ##########
! ###########    | |__  _   _ _ __   ___ _ __(___ \|  _ \     ##########
! ###########    | '_ \| | | | '_ \ / _ \ '__| __) | | | |    ##########
! ###########    | | | | |_| | |_) |  __/ |   / __/| |_| |    ##########
! ###########    |_| |_|\__, | .__/ \___|_|  /_____|____/     ##########
! ###########           |___/|_|                              ##########
! ###########                                                 ##########
! ######################################################################
! ######################################################################

program hyper2D

  use global_module   ! Simulation parameters: domain size, number of cells etc
  use pde             ! Definition of the system of equations
  use integration     ! Functions for integrating in time and numerical fluxes
  use tools           ! Output subroutines etc etc

  implicit none

  ! The solution is a 3D matrix.
  ! The first index "eqID" represents the equation
  ! (for Euler 1: density, 2: x-momentum, 3: y-momentum, 4: total energy)
  ! the second index "i" represents the x-position
  ! the third index "j" represents the y-position.
  ! This might be counter-intuitive, but recall that Fortran represents data
  ! in column-major order.

  real(kind=8), dimension(Neq,Nx,Ny) :: U, P

  integer :: Nt, t_ID ! Variables for time integration

  write(*,*) "Initializing solution..."
  call initialize_solution(U) ! See the pde.f03 module

  write(*,*) "Assigning BCs..."
  call assign_BCs(U) ! See the pde.f03 module

  write(*,*) "Writing solution at time step", 0, "..."
  call export_sol_vtk(0, U)

  ! $$$$$$$$$$$ Integrate in time $$$$$$$$$$$$$

  Nt = ceiling(t_end/dt) ! t_end and dt are defined in global_module.f90

  do t_ID = 1, Nt

    write(*,*) 'Timestep', t_ID, 'of', Nt

    call forward_Euler_step(U, dt)

    if ( mod(t_ID, 50) .EQ. 0 ) then ! Write to VTK every ... timesteps

      write(*,*) "Writing solution at time step", t_ID, "..."
      call export_sol_vtk(t_ID, U)

    end if

  end do

end program


PROGRAM fmain
   IMPLICIT NONE

   DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: T
   DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: U
   DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: V
   DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: W
   DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: X
   DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: Y
   DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: Z

   INTEGER :: I,J,K,LEN1,LEN2,LEN3

   LEN1 = 128
   LEN2 = 128
   LEN3 = 128

   ALLOCATE(T(LEN1,LEN2,LEN3))
   ALLOCATE(U(LEN1,LEN2,LEN3))
   ALLOCATE(V(LEN1,LEN2,LEN3))
   ALLOCATE(W(LEN1,LEN2,LEN3))
   ALLOCATE(X(LEN1,LEN2,LEN3))
   ALLOCATE(Y(LEN1,LEN2,LEN3))
   ALLOCATE(Z(LEN1,LEN2,LEN3))

   T = 1.1
   U = 2.2
   V = 3.3
   W = 4.4
   X = 5.5
   Y = 6.6
   Z = 7.7

   !$omp target data map(to:T,U,V,X,Y) map(tofrom:Z)

   !$omp target parallel do collapse(3) default(none) &
   !$omp& shared(T,U,V,W,X,Y,Z,LEN1,LEN2,LEN3) &
   !$omp& private(I,J,K)
   DO I=1,LEN1
    DO J=1,LEN2
     DO K=1,LEN3+1
      T(I,J,K) = U(I,J,K) * V(I,J,K) * V(I,J,K)
      W(I,J,K) = X(I,J,K) * Y(I,J,K) * Y(I,J,K)
      Z(I,J,K) = Z(I,J,K) * Z(I,J,K) * Z(I,J,K)
     END DO
    END DO
   END DO
   !$omp end target parallel do

   !$omp end target data

   print *, "GPU OpenMP explicit loop kernel SUM(Z) is: ", SUM(Z)
!----------------------------------------------------------------

   T = 1.1
   W = 4.4
   Z = 7.7

   !$omp target data map(to:T,U,V,X,Y) map(tofrom:Z)

   !$omp target teams distribute parallel do collapse(3) default(none) &
   !$omp& shared(T,U,V,W,X,Y,Z,LEN1,LEN2,LEN3) &
   !$omp& private(I,J,K)
   DO I=1,LEN1
    DO J=1,LEN2
     DO K=1,LEN3+1
      T(I,J,K) = U(I,J,K) * V(I,J,K) * V(I,J,K)
      W(I,J,K) = X(I,J,K) * Y(I,J,K) * Y(I,J,K)
      Z(I,J,K) = Z(I,J,K) * Z(I,J,K) * Z(I,J,K)
     END DO
    END DO
   END DO
   !$omp end target teams distribute parallel do

   !$omp end target data

   print *, "GPU OpenMP teams explicit loop kernel SUM(Z) is: ", SUM(Z)
!----------------------------------------------------------------

END PROGRAM fmain